(FILECREATED " 9-MAR-83 21:55:57" {PHYLUM}<LISPCORE>SYSTEM>COMPILE.;20 53743
changes to: (VARS COMPILECOMS)
previous date: "21-FEB-83 20:36:51" {PHYLUM}<LISPCORE>SYSTEM>COMPILE.;19)
(PRETTYCOMPRINT COMPILECOMS)
(RPAQQ COMPILECOMS [(FNS BCOMPL BCOMPL1 BCOMPL1A BCOMPL2 BCOMPL3 BLOCK: BRECOMPILE BRECOMPILE1
BRECOMPILE2 BRECOMPILE3 BLOCKCOMPILE BLOCKCOMPILE1 COMPSET COMPSETREAD
COMPSETY COMPSETF RCOMP3 TCOMPL RECOMPILE RECOMP? COMPILE COMPILE1 COMPILE1A
FILECHECK COMPEM GETCFILE SPECVARS LOCALVARS GLOBALVARS)
(ADDVARS (NOLINKFNS HELP ERRORX ERRORSET EVALV FAULTEVAL INTERRUPT SEARCHPDL MAPDL BREAK1
EDITE EDITL)
(LINKFNS)
(FREEVARS)
(SYSSPECVARS HELPCLOCK LISPXHIST RESETSTATE OLDVALUE UNDOSIDE0)
(SYSLOCALVARS)
(LOCALFREEVARS)
(BLKLIBRARY)
(RETFNS)
(BLKAPPLYFNS)
(DONTCOMPILEFNS)
(NLAML)
(NLAMA)
(LAMS)
(LAMA))
(INITVARS (SPECVARS T)
(LOCALVARS SYSLOCALVARS))
(INITVARS (DWIMIFYCOMPFLG)
(COMPILEHEADER "compiled on ")
(COMPSETLST (QUOTE (ST F STF S Y N 1 2 NIL T)))
[COMPSETKEYLST (QUOTE ((ST "ore and redefine " KEYLST ("" (F . "orget exprs")))
(S . "ame as last time")
(F . "ile only")
(T . "o terminal")
(1)
(2)
(Y . "es")
(N . "o"]
[COMPSETDEFAULTKEYLST (QUOTE ((Y . "es")
(N . "o"]
(BCOMPL.SCRATCH (SELECTQ (SYSTEMTYPE)
(D (QUOTE {CORE}BCOMPL.SCRATCH))
(QUOTE BCOMPL.SCRATCH;T)))
(RECOMPILEDEFAULT (QUOTE EXPRS))
(COUTFILE T)
(SVFLG T)
(STRF T)
(LSTFIL T)
(LCFIL)
(LAPFLG T))
(DECLARE: DONTCOPY (MACROS DIGITCHARP))
(P (MOVD? (QUOTE NILL)
(QUOTE FILECHANGES)))
(* COMPILEMODE)
(PROP VARTYPE COMPILEMODELST)
(FNS COMPILEMODE)
(BLOCKS (COMPILEMODE COMPILEMODE (NOLINKFNS . T)))
(GLOBALVARS NLAMA NLAML LAMA LAMS SYSSPECVARS SYSLOCALVARS GLOBALVARS NOFIXFNSLST
NOFIXVARSLST RECOMPILEDEFAULT COMPILE.EXT NOTCOMPILEDFILES BYTECOMPFLG
COMPILEHEADER COMPVERSION DWIMIFYCOMPFLG BCOMPL.SCRATCH DONTCOMPILEFNS RETFNS
BLKLIBRARY NOLINKFNS LINKFNS NORMALCOMMENTSFLG BUILDMAPFLG LINKEDFNS
NOFIXVARSLST0 NOFIXFNSLST0 CLISPTRANFLG CLISPARRAY FILEPKGFLG NOSPELLFLG
COMPSETKEYLST REREADFLG HISTSTR0 LISPXHISTORY COMPSETDEFAULTKEYLST FILERDTBL
DFNFLG FILELST DWIMFLG DWIMWAIT EXPRSLST)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA GLOBALVARS LOCALVARS SPECVARS BLOCK:)
(NLAML BCOMPL3)
(LAMA])
(DEFINEQ
(BCOMPL
[LAMBDA (FILES CFILE NOBLOCKSFLG OPTIONSSET)
(* lmm "19-NOV-82 12:07")
(* BCOMPL is like TCOMPL, except that it reads in all of FILES before starting any compilations, so that a BLOCK can
contain functions in several FILES. BLOCKS are set up using a DECLARE statement of the form
(DECLARE (BLOCK: BLKNAME BLKFN1 BLKFN2 ... (VAR1 VALUE) (VAR2 VALUE) ...) (BLOCK: BLKNAME ...) ...) -
where BLKFN1 ... are the functions in the BLOCK, and VAR1 ... are values for ENTRIES, RETFNS, SPECVARS, etc. A
variable setting of the form (VAR . list) sets variable to UNION of the list with the variable's top level value.
A variable setting of the form (VAR . ATOM) simply sets the variable to that atom, e.g. (NOLINKFLG . T))
(RESETTOPVALS ((NLAML NLAML)
(NLAMA NLAMA)
(LAMS LAMS)
(LAMA LAMA)
(DWIMIFYCOMPFLG DWIMIFYCOMPFLG))
(* RESETTOPVALS is used for variables whose top-value in both deep and shallow is
likely to be affected by expressions on the file)
(RESETVARS ((NORMALCOMMENTSFLG T)
(NOFIXVARSLST NOFIXVARSLST)
(NOFIXFNSLST NOFIXFNSLST)
(BYTECOMPFLG BYTECOMPFLG)
(EXPRSLST))
(* Save BYTECOMPFLG LAMS and LAMA)
(RETURN (PROG (DEFS CHANGES OTHERS FIRST BLOCKS BLKFNS FILEROOT TEM
SCRATCHFILE (SPECVARS T)
(LOCALVARS SYSLOCALVARS))
(RESETSAVE (INPUT))
(SETQ FILES (for F on (MKLIST FILES) collect (FILECHECK
F)))
(* Checks that all FILES are there, and if not, attempts spelling correction.)
(OR OPTIONSSET (COMPSET NIL (QUOTE (F %
))
FILES))
(* OPTIONSSET is T on calls from TCOMPL. In this case, the first COMPSET has
already been performed.)
(COMPSET (OR CFILE (PACKFILENAME (QUOTE NAME)
(SETQ FILEROOT
(NAMEFIELD
(CAR FILES)))
(QUOTE EXTENSION)
COMPILE.EXT))
NIL FILES)
[COND
(LCFIL (SETQ SCRATCHFILE (OPENFILE BCOMPL.SCRATCH
(QUOTE BOTH)
(QUOTE NEW]
(RESETSAVE NIL (LIST (QUOTE BCOMPL3)
NIL FILES SCRATCHFILE))
(* BCOMPL3 will close and if necessary delete all the appropriate files when
bcompl finishes, or control-d or control-e occurs.)
(COND
(LCFIL (PRINT (LIST (QUOTE FILECREATED)
(DATE)
(CONS COMPILEHEADER FILES)
COMPVERSION
(COND
(NOBLOCKSFLG (QUOTE tcompl'd))
(T (QUOTE bcompl'd)))
(QUOTE in)
(COND
((BOUNDP (QUOTE SYSOUTFILE))
SYSOUTFILE)
(T HERALDSTRING))
(QUOTE dated)
(COND
((BOUNDP (QUOTE SYSOUTDATE))
SYSOUTDATE)
(T MAKESYSDATE)))
LCFIL FILERDTBL)))
(SETQ NOFIXVARSLST (NCONC (MAPCONC FILES
(FUNCTION BCOMPL1))
NOFIXVARSLST))
(SETQ NOFIXFNSLST
(APPEND NLAMA NLAML LAMS
(NCONC [MAPCAR DEFS (FUNCTION (LAMBDA (X)
(RCOMP3 (CAR X)
(CADR X]
NOFIXFNSLST)))
(* The BCOMPL1 reads in FILES. It returns a list of variables set in the files. The RCOMP3 adds function to NLAMA,
LAMS, etc., and returns a list of functions. NOFIXFNLST is reset in case there is any dwimifying to be done.)
(COND
(SCRATCHFILE
(* writes others on a scratchfile so space can be freed up.
will be copied onto lcfil aftr compilation.)
(for X in OTHERS
do (PRINT X SCRATCHFILE FILERDTBL))
(PRINT NIL SCRATCHFILE FILERDTBL)
(SETQ OTHERS NIL)))
[OR DWIMIFYCOMPFLG (SETQ DWIMIFYCOMPFLG
(EQMEMB (QUOTE CLISP)
(GETPROP FILEROOT (QUOTE FILETYPE]
(* The FILETYPE may have been set during the course of BCOMPL1.)
[MAPC FIRST (FUNCTION (LAMBDA (X)
(PRINT X LCFIL FILERDTBL]
[PROG (LISPXHIST)
(DECLARE (SPECVARS LISPXHIST))
(* compile blocks MAPC not used because BCOMPL2 checks BLOCKS.
lispxhist rebound bcause no need to save information when compiling from file)
(AND NOBLOCKSFLG (GO NOBLOCKLP))
BLOCKLP
(COND
(BLOCKS (BCOMPL2 (CAR BLOCKS))
(SETQ BLOCKS (CDR BLOCKS))
(GO BLOCKLP)))
(* COMPILE other functions. done this way instead of MAPC to release the defs as
soon aspossible.)
NOBLOCKLP
(COND
(DEFS (AND (NOT (FMEMB (CAAR DEFS)
DONTCOMPILEFNS))
(COMPILE1 (CAAR DEFS)
(CADAR DEFS)))
(SETQ DEFS (CDR DEFS))
(GO NOBLOCKLP]
(RETURN LCFIL])
(BCOMPL1
[LAMBDA (X) (* rmk: " 4-NOV-81 18:50")
(* X is either the name of a file, or a list of non-defineq expression on a file. In the first case, BCOMPL1 reads
the expressions on the file, printing the dates, gathering definitions on DEFS (a free varible), evaluating
DECLARE:'s, and gathering expressions to be printed on the file on OTHERS (a free variable). Value is a list of VARS
set in the file.)
(COND
((LITATOM X)
(INFILE X)
(AND (RANDACCESSP (INPUT))
(SETFILEPTR NIL 0)) (* if file was already open, infile doesnt reset file
pointer.)
))
(RESETVARS ((DFNFLG T))
(* if top level value of DFNFLG is PROP, still want to evaluate expressions in declarations etc as though it were T.
i.e. make BCOMPL1A equivalent to doing a LOADCOMP)
(PROG (TEM VARS)
LP (COND
((NULL X)
(RETURN VARS))
((LISTP X)
(SETQ TEM (CAR X))
(SETQ X (CDR X)))
((OR (NULL (SETQ TEM (READ X FILERDTBL)))
(EQ TEM (QUOTE STOP)))
(CLOSEF X)
(RETURN VARS)))
(BCOMPL1A TEM (QUOTE DEFAULT)
(QUOTE DEFAULT)
(QUOTE DEFAULT))
(GO LP])
(BCOMPL1A
[LAMBDA (X COMPCOPYFLG COMPEVALFLG FIRSTFLG)
(* dav: " 8-JAN-83 13:30")
(PROG (TEM)
[SELECTQ
(CAR (LISTP X))
(FILECREATED (SETQ CHANGES (NCONC (FILECHANGES X (QUOTE FNS))
CHANGES))
(SETQ FIRST (NCONC1 FIRST X)))
(DEFINEQ [COND
((EQ COMPCOPYFLG (QUOTE DEFAULT))
(* DEFAULT means to copy the COMPILED definitions to the file.)
(SETQ DEFS (NCONC DEFS (CDR (LISTP X])
[DECLARE: (* supercedes DECLARE, DEFLIST with third argument, and PROGN with funny atom.)
(* Note thatDECLARE: itself isnt copied to compiled file.
nor is it evaluated at compile time.)
(RESETVARS ((DFNFLG DFNFLG)
FILEPKGFLG)
(RETURN
(PROG [(COMPEVALFLG0 COMPEVALFLG)
(COMPCOPYFLG0 (EQ COMPCOPYFLG (QUOTE DEFAULT)))
(FIRSTFLG0 FIRSTFLG)
(X (CDR (LISTP X]
(* FLG is the flag in effect when the DECLARE: staated, FLG0 the current flag. the use of two flags permits turning
a flag off and then back on and the same level, but prohibiting turning the flag on at a lower level, i.e.
overriding a higher comand with a lower one)
LP [COND
((NLISTP X)
(RETURN))
((LISTP (CAR (LISTP X)))
(BCOMPL1A (CAR (LISTP X))
COMPCOPYFLG0 COMPEVALFLG0 FIRSTFLG0))
(T (SELECTQ (CAR (LISTP X))
(DONTCOPY (SETQ COMPCOPYFLG0 NIL))
((DOCOPY COPY)
(AND (EQ COMPCOPYFLG (QUOTE DEFAULT))
(SETQ COMPCOPYFLG0 T))
(* when a DECLARE: is encountered inside of a DECLARE: DOCOPY, want the entire DECLARE: copied
(because it may contain EVAL@LOADWHEN tags). in this cse dont we dont want each individual element also to be
copied. starting compcopyflg0 off at NIL and only resetting when compcopyflg is DEFAULT achieves this.)
)
[COPYWHEN (AND (EQ COMPCOPYFLG (QUOTE DEFAULT))
(SETQ COMPCOPYFLG0
(AND (EVAL (CADR (LISTP X)))
T)))
(SETQ X (CDR (LISTP X]
(FIRST
(* these expressions are copied to the compiled file before any functions.)
(AND FIRSTFLG (SETQ FIRSTFLG0 T)))
(NOTFIRST (SETQ FIRSTFLG0 NIL))
(DONTEVAL@COMPILE (SETQ COMPEVALFLG0 NIL))
((DOEVAL@COMPILE EVAL@COMPILE)
(AND COMPEVALFLG (SETQ COMPEVALFLG0 T)))
[EVAL@COMPILEWHEN
(AND COMPEVALFLG
(SETQ COMPEVALFLG0
(AND (EVAL (CADR (LISTP X)))
T)))
(SETQ X (CDR (LISTP X]
(COMPILERVARS
(* From ADDVARS NLAMA and NLAML in prettydef.
The resetting of dfnflg will suppress the
(NLAMA RESET) message.)
(SETQ DFNFLG T))
[EVAL@LOADWHEN (SETQ X (CDR (LISTP X]
((DONTEVAL@LOAD DOEVAL@LOAD EVAL@LOAD)
NIL)
(PRINT (CONS (CAR (LISTP X))
(QUOTE (UNRECOGNIZED DECLARE TAG)))
COUTFILE]
(SETQ X (CDR (LISTP X)))
(GO LP]
(DEFLIST (AND (EQ COMPCOPYFLG (QUOTE DEFAULT))
(SETQ COMPCOPYFLG T))
(* Normally DEFLIST's are copied to the compiled file but not evaluated.
This is the standard case for the PROP option.)
)
((SETQ SETQQ RPAQ RPAQQ)
(SETQ VARS (CONS (CADR (LISTP X))
VARS))
(AND (EQ COMPCOPYFLG (QUOTE DEFAULT))
(SETQ COMPCOPYFLG T)))
(COND
((EQ (CAR (LISTP X))
COMMENTFLG)
(RETURN))
((EQ COMPCOPYFLG (QUOTE DEFAULT))
(SETQ COMPCOPYFLG T]
(COND
((EQ COMPCOPYFLG T)
[COND
((EQ FIRSTFLG T)
(SETQ FIRST (NCONC1 FIRST X)))
(T (SETQ OTHERS (NCONC1 OTHERS X]
(* OTHERS is a list of expressions to be written out later. FIRST is a list of expressions to be written out before
the compiled code goes out)
))
(COND
((EQ COMPEVALFLG T)
(EVAL X)))
(RETURN])
(BCOMPL2
[LAMBDA (BLOCK FILEMAPLST) (* lmm "19-NOV-82 11:48")
(* Thisfunction processes a single block.)
(* FILEMAPLST is given when recompiling.)
(RESETTOPVALS ((GLOBALVARS GLOBALVARS)
(RETFNS RETFNS)
(BLKLIBRARY BLKLIBRARY)
(NOLINKFNS NOLINKFNS)
(LINKFNS LINKFNS)
(DONTCOMPILEFNS DONTCOMPILEFNS))
(PROG ((SPECVARS SPECVARS)
(LOCALVARS LOCALVARS)
(BLKNAME (CAR BLOCK))
BLKAPPLYFNS ENTRIES LOCALFREEVARS X TEM LST (BNDLEV 0)
(TEM2))
(COND
((NULL BLKNAME)
(* BLKNAME NIL means regualr compiling unless declared otherwise)
(SPECVARS . T))
(T (LOCALVARS . T)))
(GO LP1)
LP (* Loop through BLOCK making assignments for non-atomic expressions and gathering
on LST the definitions for the atoms.)
(COND
((LISTP (SETQ X (CAR BLOCK)))
(* A declaration)
[SETQ TEM (COND
((EQ (CADR X)
(QUOTE *))
(EVAL (CADDR X)))
(T (CDR X]
[SELECTQ (CAR X)
((SPECVARS LOCALVARS)
(EVAL X))
(SET (CAR X)
(COND
((NLISTP (CDR X))
(CDR X))
([LISTP (SETQ TEM2 (EVAL (CAR X]
(APPEND TEM TEM2))
(T TEM]
(GO LP1))
((AND FILEMAPLST (NULL BLKNAME)
(NOT (RECOMP? X FNS)))
(* Function is not goin to be compiled, so no point in looking up its definition. Note that BRECOMPILE never calls
BCOMPL2 on a block (other than one with a NIL name) unless the entire block is going to have to be recompiled.)
(SETQ TEM (LIST X)))
[FILEMAPLST (COND
((NULL (SETQ TEM (BRECOMPILE3 X FILEMAPLST)))
[COMPEM (CONS X (QUOTE (not compileable]
(GO LP1]
((SETQ TEM (FASSOC X DEFS))
(AND [NOTANY (CDR BLOCKS)
(FUNCTION (LAMBDA (X)
(FMEMB (CAR TEM)
(CDR X]
(SETQ DEFS (DREMOVE TEM DEFS)))
(* This is done primarily to release the space for recompilation as soon as
possible.)
)
[(EXPRP (SETQ TEM (VIRGINFN X T)))
(* this is a new feature. it is designed to allow the user to have defnitions for functions in a library file and to
load them in to the files thatneed them at compile time by doing a loadfns. thus he doesnt have to have a
defiitionor blklibrarydef for the functon in each file that uses it. note that when recopiling, this feature falls
out because BRECOMPILE3 checks for an incore definition before it goes to the file anyway, and doesntdistinguish
between defiitions of functions in the file, and those that just happen to have in core definitions.)
(SETQ TEM (LIST X TEM T))
(COMPEM (CONS X (QUOTE (not on file, compiling in core definition]
(T [COMPEM (CONS X (QUOTE (not compileable]
(GO LP1)))
(SETQ LST (NCONC1 LST TEM))
(SETQ BLKFNS (CONS X BLKFNS))
(* A list of those functions contained in blocks.
All others will be compiled separately.)
LP1 (COND
((SETQ BLOCK (CDR BLOCK))
(GO LP))
((AND (NULL LST)
BLKNAME)
(* BLOCK consists of single function: BLKNAME, e.g. (FOO) or (FOO (SPECVARS --) (globavlars --)) have to go back
through loop to look up definition on defs.)
(SETQ BLOCK (LIST BLKNAME))
(GO LP)))
(COND
((NULL BLKNAME)
(* By using NIL for BLOCK name, user indicates this is a non-block compilation. However, he can set LINKFLG to T,
thereby causing all calls to be linked, even though he is not compiling a BLOCK. He can also set NOLINKFNS and
GLOBALVARS.)
(PROG NIL
L1 (COND
((NULL LST)
(RETURN))
[(OR (NULL FILEMAPLST)
(AND (CADAR LST)
(RECOMP? (CAAR LST)
FNS)))
(AND (NOT (MEMB (CAAR LST)
DONTCOMPILEFNS))
(COMPILE1 (CAAR LST)
(CADAR LST)
(CADDAR LST]
(T (BRECOMPILE1 (CAAR LST)
T)))
(SETQ LST (CDR LST))
(GO L1)))
(T (* BLOCKCOMPILE1 will also make some checks on ENTRIES.)
(BLOCKCOMPILE1 BLKNAME (PROG1 LST (SETQ LST NIL))
ENTRIES)))
(RETURN])
(BCOMPL3
[NLAMBDA (CFILE FILES SCRATCHFILE)
(* lmm "18-MAR-81 09:27")
(* Cleans up after brecompile and bcompl have finished operating,)
(COND
(SCRATCHFILE [COND
((NULL RESETSTATE)
(* finished successfully.)
(COPYBYTES SCRATCHFILE LCFIL 0 (GETFILEPTR SCRATCHFILE]
(AND (OPENP SCRATCHFILE)
(CLOSEF SCRATCHFILE))
(DELFILE SCRATCHFILE)))
(COND
((AND LCFIL (NEQ LCFIL T)
(NEQ LCFIL (QUOTE NIL:))
(OPENP LCFIL (QUOTE OUTPUT)))
(CLOSEF LCFIL)
(AND RESETSTATE (DELFILE LCFIL)))
(T (SETQ LCFIL NIL)))
(COND
((AND LSTFIL LSTFIL1 (OPENP LSTFIL1 (QUOTE OUTPUT)))
(CLOSEF LSTFIL1)))
(COND
((AND CFILE (NEQ CFILE T)
(NEQ CFILE NIL)
(OPENP CFILE (QUOTE INPUT)))
(CLOSEF CFILE)))
[MAPC FILES (FUNCTION (LAMBDA (FILE)
(AND (OPENP FILE)
(CLOSEF FILE))
(COND
((NULL RESETSTATE)
(* Finished successfully.)
(/SETATOMVAL (QUOTE NOTCOMPILEDFILES)
(REMOVE (NAMEFIELD FILE T)
NOTCOMPILEDFILES))
(* Removes FILES from NOTCOMPILEDFILES.)
]
(AND (NULL RESETSTATE)
(NEQ (POSITION COUTFILE)
0)
(TERPRI COUTFILE])
(BLOCK:
[NLAMBDA X (* wt: "26-FEB-78 20:27")
(* Used in DECLARE: expressions to set up blocks. See comment in BCOMPL. probaby this shuld be implemented by havng
bcompl1 specifically check for BLOCK: rater than simply having EVAL called, because that way can distinguish between
block declarations in file being compiled from block declaraions in a file being LOADCOMP'ed.
for now this is handled by havng LOADCOMP rebind BLOCKS.)
(SETQ BLOCKS (NCONC1 BLOCKS X])
(BRECOMPILE
[LAMBDA (FILES CFILE FNS NOBLOCKSFLG)
(* lmm "19-NOV-82 11:49")
(* FNS is a list of functions to be recompiled. The object is to make a file that looks exactly like that produced
by BCOMPL (PFILE) except to greatly reduce the work by copying from CFILE the compiled definitions those functions
not being recompiled. BRECOMPILE is driven by PFILE, and the algorithm is whenever a DEFINEQ is encountered, process
all OF the functions in the DEFINEQ as follows: COMPILE the definition OF the function IF it is on the list FNS, or
IF FNS is T and the function is currently defined as an EXPR. Otherwise copy its compiled definition from CFILE.
Note that functions with compiled definitions in CFILE that do not appear in PFILE are NOT copied.
This corresponds to the case where functions have been deleted from PFILE.)
(RESETTOPVALS
((NLAMA NLAMA)
(NLAML NLAML)
(LAMS LAMS)
(LAMA LAMA)
(DWIMIFYCOMPFLG DWIMIFYCOMPFLG))
(RESETVARS ((NORMALCOMMENTSFLG T)
(NOFIXFNSLST NOFIXFNSLST)
(NOFIXVARSLST NOFIXVARSLST)
(BUILDMAPFLG T)
(BYTECOMPFLG BYTECOMPFLG)
(EXPRSLST)) (* No RECORDUSAGE, set BYTECOMPFLG)
(RETURN
(PROG (CHANGES OTHERS FIRST FILEMAPLST FNLST BLKFNS BLOCKS FILE TEM ADRLST
SCRATCHFILE (SPECVARS T)
(LOCALVARS SYSLOCALVARS))
(COND
((AND (NULL CFILE)
(NULL FNS))
(* BRECOMPILE (FILE) is equivalent to RECOMPILE (PFILE CFILE T T) Thus, you can LOAD a file in using LOAD
(FILE PROP) edit selected functions causing them to be unsaved, PRETTYDEF the file, and then simply perform
RECOMPILE (FILE) (* Note the CFILE=NIL is interpreted as meaning PFILE.COM even when FNS supplied.))
(* Another possibility is with COREFLG=NIL and FNS=T, in which case the list of
the functions changed on the file will be used.)
(SETQ FNS RECOMPILEDEFAULT)))
(RESETSAVE (INPUT))
(SETQ FILES (for X on (MKLIST FILES) collect (FILECHECK X)))
(SETQ FILE (NAMEFIELD (CAR FILES)))
(SETQ TEM (PACKFILENAME (QUOTE NAME)
FILE
(QUOTE EXTENSION)
COMPILE.EXT))
(COND
((EQ FNS (QUOTE ALL))
(* Dont need CFILE since are going to compile everything. This feature is useful when your compiled file is
clobbered, but you have alredy loaded in the symbolic file.)
(SETQ CFILE NIL))
([NULL (CAR (ERSETQ (GETCFILE FILES (OR CFILE TEM)
(COND
(NOBLOCKSFLG (QUOTE TCOMPL))
(T (QUOTE BCOMPL]
(RETURN NIL))
(T (SETQ CFILE (INPUT))
(* Gets full name.)
(SETFILEPTR CFILE 0)))
(COMPSET NIL (QUOTE (S T %
))
FILES)
(COMPSET TEM NIL FILES)
[AND LCFIL (SETQ SCRATCHFILE (OPENFILE BCOMPL.SCRATCH (QUOTE BOTH)
(QUOTE NEW]
(RESETSAVE NIL (LIST (QUOTE BCOMPL3)
CFILE FILES SCRATCHFILE))
(* BCOMPL3 will close and if necessary delete all the appropriate files when brecompile finishes, or control-d or
control-e occurs. distinguishes two cases by smashing first argument to T at end of brecompile if it completes.
Note that this call differs from the call for bcompl in that cfile is also specified. this corresponds to the fact
that recompile has an extra file open.)
[AND CFILE (FILECREATED1 (CDR (READ CFILE FILERDTBL]
(* checks compversons on .COM file)
[SETQ FILEMAPLST
(MAPCAR FILES
(FUNCTION (LAMBDA (FL)
(PROG (FNLST (VARLST (QUOTE COMPILING))
DONELST
(LDFLG (QUOTE EXPRESSIONS)))
(* FNLST is used as a free variable in SCANFILE0)
(INFILE FL)
(SETFILEPTR FL 0)
(RETURN (CONS [CONS FL (LOADFNSCAN (GETFILEMAP
FL
(NAMEFIELD FL T]
(DREVERSE DONELST)))
(* SCANFILE0 scans the file, building a map if one not already there. Value is the map. In addition, sets DONELST to
a lit of all non-defineq expressions.)
]
[SETQ FNLST (MAPCONC FILEMAPLST
(FUNCTION (LAMBDA (X)
(MAPCONC (CDDAR X)
(FUNCTION (LAMBDA (X)
(MAPCAR (CDDR X)
(FUNCTION CAR]
(* FILEMAPLST is a list of information about each file. CAR of each entry on FILEMAPLST is the filemap.
The first entry on the filemap is the file name, and the second would be NIL. We start mapping down CDDR of the
filemap, (CDDAR X), and each element therein corresponds to a single DEFINEQ. CDDR is a list of
(FN ADR1 . ADR2), so the inner MAPCAR gathers up the names of the functions. The reason for not asking LOADFNS to do
this is in most cases the map will already have been built, so LOADFNS wont even go inside of the defineq.)
(SETQ NOFIXVARSLST (NCONC [MAPCONC FILEMAPLST (FUNCTION (LAMBDA (X)
(BCOMPL1 (CDR X]
NOFIXVARSLST))
(SETQ NOFIXFNSLST (APPEND NLAMA NLAML LAMS FNLST NOFIXFNSLST))
(* BCOMPL1 returns a list of VARS set in the files. NOFIXFNLST and NOFIXVARSLST are reset in case there is any
dwimifying to be done BCOMPL1 also sets free variable OTHERS to list of expressions to be printed on compiled file
when all is done.)
(AND LCFIL
(PRINT [NCONC [LIST (QUOTE FILECREATED)
(DATE)
(CONS COMPILEHEADER FILES)
COMPVERSION
(COND
(NOBLOCKSFLG (QUOTE recompiled))
(T (QUOTE brecompiled]
[COND
((EQ FNS (QUOTE ALL))
(LIST (QUOTE ALL)))
(T (CONS (SELECTQ FNS
(CHANGES (QUOTE changes:))
((EXPRS T)
(QUOTE exprs:))
(QUOTE explicitly:))
(OR [SUBSET FNLST (FUNCTION (LAMBDA (X)
(RECOMP? X FNS]
(LIST (QUOTE nothing]
(LIST (QUOTE in)
(COND
((BOUNDP (QUOTE SYSOUTFILE))
SYSOUTFILE)
(T HERALDSTRING))
(QUOTE dated)
(COND
((BOUNDP (QUOTE SYSOUTDATE))
SYSOUTDATE)
(T MAKESYSDATE]
LCFIL FILERDTBL))
[MAPC FNLST (FUNCTION (LAMBDA (X)
(RCOMP3 X (VIRGINFN X]
(COND
(SCRATCHFILE
(* writes others on a scratchfile so space can be freed up.
will be copied onto lcfil aftr compilation.)
(for X in OTHERS do (PRINT X SCRATCHFILE FILERDTBL))
(PRINT NIL SCRATCHFILE FILERDTBL)
(SETQ OTHERS NIL)))
[MAPC FIRST (FUNCTION (LAMBDA (X)
(PRINT X LCFIL FILERDTBL]
[OR DWIMIFYCOMPFLG (SETQ DWIMIFYCOMPFLG (EQMEMB (QUOTE CLISP)
(GETPROP FILE (QUOTE
FILETYPE]
(OR (EQ FNS (QUOTE ALL))
(INPUT CFILE))
[OR NOBLOCKSFLG (MAPC BLOCKS (FUNCTION (LAMBDA (BLOCK)
(COND
((NULL (CAR BLOCK))
(BCOMPL2 BLOCK FILEMAPLST))
([SOME BLOCK (FUNCTION (LAMBDA (X)
(AND (ATOM X)
(RECOMP? X FNS]
(* If any function in the BLOCK is to be recompiled, the whole BLOCK must be
recompiled.)
(BCOMPL2 BLOCK FILEMAPLST))
(T (BRECOMPILE1 BLOCK]
(* NOBLOCKSFLG is T for calls from RECOMPILE.
In this case, even if there were any blocks, ignore them.)
(* Now COMPILE rest of functions.)
[MAPC FNLST (FUNCTION (LAMBDA (X)
(COND
((OR (FMEMB X BLKFNS)
(FMEMB X DONTCOMPILEFNS)))
((RECOMP? X FNS)
(* The HELP is bcause if X is on FNS, then it follos X is in the file map, and brecompile3 should be able to produce
its definition.)
(COMPILE1 X [CADR (SETQ TEM (OR (BRECOMPILE3 X FILEMAPLST)
(HELP (QUOTE BRECOMPILE]
(CADDR TEM)))
(T (BRECOMPILE1 X T]
(RETURN LCFIL])
(BRECOMPILE1
[LAMBDA (FN/BLOCK NOBLOCKSFLG) (* wt: "11-MAY-79 15:04")
(* Looks for FN/BLOCK and its subfunctions on CFILE,
skipping till found.)
(COND
[(AND (NULL NOBLOCKSFLG)
BYTECOMPFLG
(NEQ BYTECOMPFLG (QUOTE NOBLOCK)))
(PROG [(LST (APPEND (CDR (ASSOC (QUOTE ENTRIES)
FN/BLOCK))
(CDR (ASSOC (QUOTE RETFNS)
FN/BLOCK))
(CDR (ASSOC (QUOTE BLKAPPLYFNS)
FN/BLOCK))
(LISTP (CDR (ASSOC (QUOTE NOLINKFNS)
FN/BLOCK)))
(LIST (CAR FN/BLOCK]
(MAPC (CDR FN/BLOCK)
(FUNCTION (LAMBDA (X)
(COND
((LITATOM X)
(SETQ BLKFNS (CONS X BLKFNS))
(BRECOMPILE1 (COND
((NOT (MEMB X LST))
(* functions that are normally "visible" are compiled
with the same names. othrs use this naming convention)
(SETQ X (PACK* (QUOTE \)
(CAR FN/BLOCK)
(QUOTE /)
X)))
(T X))
T]
(T (PROG ([NAME (COND
(NOBLOCKSFLG FN/BLOCK)
(T (CAR FN/BLOCK]
X ADR (ADRLST0 ADRLST))
LP (SETQ ADR (GETFILEPTR CFILE))
(COND
[(NULL (ATOM (SETQ X (READ CFILE FILERDTBL]
[(OR (EQ X NAME)
(BRECOMPILE2 X NAME))
(PRIN2 X COUTFILE T)
(PRIN1 (QUOTE ", ")
COUTFILE)
(OUTPUT LCFIL)
(LCSKIP X T)
(* copy the function)
(COND
((EQ X NAME)
[COND
((NULL NOBLOCKSFLG)
(SETQ BLKFNS (CONS X BLKFNS))
(MAPC (CDR FN/BLOCK)
(FUNCTION (LAMBDA (X)
(COND
((ATOM X)
(SETQ BLKFNS (CONS X BLKFNS)))
((EQ (CAR X)
(QUOTE ENTRIES))
(MAPC (CDR X)
(FUNCTION (LAMBDA (X)
(COND
((EQ X NAME)
(* already copied, e.g. NAME is block name as well as an
entry))
((PROGN (SETQ ADR (GETFILEPTR CFILE))
(NEQ (READ CFILE FILERDTBL)
X))
[COMPEM (CONS X (QUOTE (not found]
(SETFILEPTR CFILE ADR))
(T (PRIN2 X COUTFILE T)
(PRIN1 (QUOTE ", ")
COUTFILE)
(LCSKIP X T]
(RETURN]
([AND (EQ ADRLST0 ADRLST)
(SOME ADRLST (FUNCTION (LAMBDA (Y)
(* NAME is not the next function on the file. Before skipping this function, see if NAME has been encountered
earlier by scanning ADRLST. This saves skipping all the way down to the end of the file in the case that NAME is
simply out of order. Only do this the first time, i.e. once you hve determined that NAME is not on ADRLST, and
skipped X, then no reason to recheck ADRLST.)
(COND
((OR (EQ (CAR Y)
NAME)
(BRECOMPILE2 (CAR Y)
NAME))
(* NAME was previously encountered and skipped over,
e.g. out of order.)
(SETFILEPTR CFILE (CDR Y))
(BRECOMPILE1 FN/BLOCK NOBLOCKSFLG)
(SETFILEPTR CFILE ADR)
(* Reset filepointer back to where it was.)
T]
(RETURN))
((OR (NULL X)
(EQ X (QUOTE STOP)))
(COND
((SETQ X (BRECOMPILE3 NAME FILEMAPLST))
(COMPILE1 NAME (CADR X)
(CADDR X)))
(T [COMPEM (CONS NAME (QUOTE (not found]
(* The only way i can see the COMPEM happening is if a function is included in a block declaration but is not in one
of the files, since the list of functions used to drive brecompile/recompile is precisely all of the functions on
the file.)
))
(SETFILEPTR CFILE ADR)
(* So next read wont hit end of file.)
(RETURN))
(T (SETQ ADRLST (NCONC1 ADRLST (CONS X ADR)))
(LCSKIP X)))
(GO LP])
(BRECOMPILE2
[LAMBDA (X FN) (* bvm: "22-OCT-82 15:45")
(* True if X is a sub-function of FN, i.e. X is FN
followed by one or more Annnn substrings.)
(AND (STRPOS FN X 1 NIL T)
(PROG [(NX (ADD1 (NCHARS X)))
(N (ADD1 (NCHARS FN]
LP (COND
([AND (ILEQ (IPLUS N 5)
NX)
(EQ (NTHCHARCODE X N)
(CHARCODE A))
(from 1 to 4 always (DIGITCHARP (NTHCHARCODE X (add N 1]
(COND
((EQ (add N 1)
NX)
(RETURN T))
(T (GO LP])
(BRECOMPILE3
[LAMBDA (FN FILEMAPLST) (* returns definition of FN, either from in core, or
from the file.)
(PROG (TEM FILE)
(RETURN (COND
((EXPRP (SETQ TEM (VIRGINFN FN T)))
(* Value is of the form (FN DEF FLG) WHERE FLG=T MEANS THE DEFINITION WAS OBTAINED FROM IN-CORE, SO THAT IT IS OK TO
DO SPELLING CORRECTION.)
(LIST FN TEM T))
([SOME FILEMAPLST (FUNCTION (LAMBDA (X)
(SETQ FILE (CAAR X))
(SOME (CDDAR X)
(FUNCTION (LAMBDA (Y)
(SETQ TEM (FASSOC FN (CDDR Y]
(SETFILEPTR FILE (CADR TEM))
(SETQ TEM (READ FILE FILERDTBL))
(COND
((NEQ FN (CAR TEM))
(ERROR (QUOTE "filemap does not agree with contents of")
FILE T)))
TEM])
(BLOCKCOMPILE
[LAMBDA (BLKNAME BLKFNS ENTRIES FLG)
(* lmm "19-NOV-82 11:50")
(RESETTOPVALS ((NLAMA NLAMA)
(NLAML NLAML)
(LAMS LAMS)
(LAMA LAMA))
(RESETVARS ((NOFIXFNSLST NOFIXFNSLST)
(NOFIXVARSLST NOFIXVARSLST)
(EXPRSLST))
(RETURN (PROG ((LOCALVARS T)
(SPECVARS SYSSPECVARS))
(* Corresponds to COMPILE.)
[COND
[(LISTP BLKNAME)
(COND
((AND (NULL BLKFNS)
(NULL ENTRIES))
(* A common mistake, user calls BLOCKCOMPILE as he would COMPILE.)
(SETQ BLKFNS BLKNAME)
(SETQ BLKNAME (CAR BLKNAME)))
(T (ERROR (QUOTE "block name not atomic")
BLKNAME T]
((NULL BLKFNS)
(SETQ BLKFNS (LIST BLKNAME]
(COMPSET)
(RETURN (PROG1 (BLOCKCOMPILE1 BLKNAME BLKFNS ENTRIES)
(COND
((AND (NULL FLG)
LCFIL)
(PRINT NIL LCFIL FILERDTBL)
(CLOSEF LCFIL)))
(COND
((AND (NULL FLG)
LSTFIL)
(CLOSEF LSTFIL])
(BLOCKCOMPILE1
[LAMBDA (BLKNAME BLKFNS ENTRIES)
(* lmm "19-NOV-82 11:51")
(PROG (BLOCKLIST NEWDEF FN DEF COREFLG CALLTAGS TEM (TAGNUM -1)
(FREEVARS FREEVARS))
(COND
((AND (EQ BLKNAME (CAR ENTRIES))
(NULL (CDR ENTRIES))
(NULL BLKAPPLYFNS))
(* MKENTRIES treats the case of ENTRIES=NIL specially by not setting up a
separate BLOCK.)
(SETQ ENTRIES NIL)))
[COND
((AND (NULL ENTRIES)
BLKAPPLYFNS) (* Above caper only works if no BLKAPPLYFNS)
(SETQ ENTRIES (LIST BLKNAME]
(COND
([SETQ TEM (SOME (APPEND BLKAPPLYFNS (OR ENTRIES (LIST BLKNAME)))
(FUNCTION (LAMBDA (X)
(AND (NOT (MEMB X BLKFNS))
(NOT (ASSOC X BLKFNS]
[COMPEM (CONS (CAR TEM)
(QUOTE (not on BLKFNS]
(RETURN))
((MEMB BLKNAME ENTRIES)
[COMPEM (CONS BLKNAME (APPEND (QUOTE (can't be both an entry and the block name))
(COND
((CDR ENTRIES)
(QUOTE (since there is more than one entry)))
(T (QUOTE (when there are also BLKAPPLYFNS]
(RETURN)))
(AND (NEQ (POSITION COUTFILE)
0)
(TERPRI COUTFILE))
LP (COND
((NLISTP BLKFNS)
(GO NX))
((LISTP (SETQ TEM (CAR BLKFNS)))
(* when blockcompile1 is called from bcompl/brecompile via bcompl2, BLKFNS is a list of elements of the form
(name def coreflg). When called from blockcompile, it is a list of function names.)
(SETQ FN (CAR TEM))
(SETQ DEF (CADR TEM))
(SETQ COREFLG (CADDR TEM))
(* COREFLG is T if DEF is in core. It will determine the setting of NOSPELLFLG and FILEPKGFLG for any dwimifing from
the call to COMPILE1A for this function.)
)
((EXPRP (SETQ DEF (VIRGINFN TEM T)))
(SETQ FN TEM)
(SETQ COREFLG T))
(T [COMPEM (CONS TEM (QUOTE (not compileable]
(RETURN)))
(SETQ BLOCKLIST (CONS FN BLOCKLIST))
(SETQ CALLTAGS (NCONC1 CALLTAGS (LIST FN (SETQ TAGNUM (SUB1 TAGNUM))
(COMPILE1A FN DEF COREFLG)
COREFLG)))
(* CALLTAGS will be a list of TUPLES (FN LAPTAG DEF COREFLG) which is used for internal entry points.
CALLTAGS can be added to from library or from internally genereated functions e/g functional arguments.)
(SETQ BLKFNS (CDR BLKFNS))
(GO LP)
NX (SETQ BLKFNS NIL)
[SETQ COREFLG (MAPCAR CALLTAGS (FUNCTION (LAMBDA (X)
(CONS (CAR X)
(CADDDR X]
(* for use by compileuserfn, so can tell which functions ar n core and which are
from on the file)
[SETQ TEM (COND
(BYTECOMPFLG
(* rrb dont know who uses COREFLG but need the room for the byte compiler that the definitions are taking up so
reset it here.)
(BYTEBLOCKCOMPILE2 BLKNAME CALLTAGS ENTRIES))
(T (BLOCKCOMPILE2 BLKNAME CALLTAGS ENTRIES]
(COND
(STRF (* Store and redefine)
(AND (NOT (FMEMB BLKNAME LINKEDFNS))
(SETQ LINKEDFNS (CONS BLKNAME LINKEDFNS)))
[MAPC COREFLG (FUNCTION (LAMBDA (X)
(COND
((EXPRP (CAR X))
(SAVEDEF (CAR X))
(/PUTD (CAR X))
(SETQ EXPRSLST (CONS (CAR X)
EXPRSLST))
(* so that if this function appears more than once in block declaration, will be
compiled more than once)
]
(* All of the entries would now be compiled. the other function should have their definitions be removed from
definition cell, so that subsequent recompile will do the right thing.)
))
(RETURN (OR TEM BLKNAME])
(COMPSET
[LAMBDA (FILE FLG FILES) (* lmm "23-DEC-81 01:02")
(* If FILE is not NIL, COMPSET doesn't ask any questions but simply initializes the output FILE, LCFIL.
If FLG is T (AND FILE IS NIL) COMPSET doesn't ask for an output FILE, but does set up LAPFLG, STRF, SVFLG, and
LSTFIL. -
-
BCOMPL and BRECOMPILE both call COMPSET twice, once with FILE NIL and FLG T, and once with FILE set to their output
FILE. -
COMPILE calls COMPSET only once, with both arguments NIL.)
(PROG (OLDO)
(COND
(FILE (GO NT)))
[SELECTQ [SETQ FILE (COMPSETREAD (QUOTE "listing? ")
COMPSETKEYLST
(OR FLG (QUOTE (S T %
]
(S [COND
(LAPFLG (PRIN1 (QUOTE "file: ")
T)
(SETQ LSTFIL (COMPSETF (COMPSETREAD]
(GO NOCHANGE))
((ST STF)
(SETQ LAPFLG NIL)
(SETQ STRF T)
(SETQ SVFLG (EQ FILE (QUOTE ST)))
(GO NOCHANGE))
(F (SETQ LAPFLG NIL)
(SETQ STRF NIL)
(SETQ SVFLG NIL)
(GO NOCHANGE))
(COND
((SETQ LAPFLG (COMPSETY FILE))
(SELECTQ FILE
((Y YES 1 2)
(PRIN1 (QUOTE "file: ")
T)
(SETQ FILE (COMPSETREAD)))
NIL)
(SETQ LSTFIL (COMPSETF FILE]
[COND
([SETQ STRF (COMPSETY (COMPSETREAD (QUOTE "redefine? "]
(SETQ SVFLG (COMPSETY (COMPSETREAD (QUOTE "save exprs? "]
NOCHANGE
(COND
([AND LAPFLG (NEQ LSTFIL (QUOTE T))
(NOT (OPENP LSTFIL (QUOTE OUTPUT]
[SETQ LSTFIL1 (SETQ LSTFIL (OPENFILE LSTFIL (QUOTE OUTPUT)
(QUOTE NEW)
NIL
(QUOTE ((TYPE TEXT]
(* LSTFIL1 is set when the file is opened for this compilation. in this case it will be closed when the compilation
is finished or aborttd.)
)
(T (SETQ LSTFIL1 NIL)))
(COND
([AND (NULL FLG)
(COMPSETY (COMPSETREAD (QUOTE "output file? ")
NIL
(QUOTE (N %
]
(PRIN1 (QUOTE "file name: ")
T)
(SETQ FILE (COMPSETREAD)))
(T (SETQ FILE NIL)))
NT [COND
([AND (SETQ LCFIL (COMPSETF FILE))
(NEQ LCFIL T)
(NULL (OPENP LCFIL (QUOTE OUTPUT]
(SETQ LCFIL (OPENFILE LCFIL (QUOTE OUTPUT)
(QUOTE NEW)
NIL
(QUOTE ((TYPE BINARY]
(RETURN (QUOTE DONE])
(COMPSETREAD
[LAMBDA (MESS KEYLST DEFAULT) (* wt: "23-AUG-80 01:29")
(PROG (X)
(COND
((OR (NULL DWIMFLG)
(AND READBUF (SETQ READBUF (LISPXREADBUF READBUF)))|
(NULL MESS))
(AND MESS (PRIN1 MESS T))
(SETQ X (LISPXREAD T))
(AND (NULL REREADFLG)
(EQ (PEEKC T)
(QUOTE %
))
(READC T)) (* so that askuser doesnt echo the carriage return again
when it is called for next question.)
)
(T (SETQ REREADFLG NIL)
(SETQ X (ASKUSER DWIMWAIT DEFAULT MESS (OR KEYLST COMPSETDEFAULTKEYLST)
T T))
(* COMPSETDEFAULTKEYLST is a Y or N list with conforimation required. user can make no confirmation by simply
setting it to NIL, and letting askuser default to its list.)
))
(RETURN (COND
((NULL LISPXHISTORY)
X)
(REREADFLG (PRINT X T T))
(T (NCONC (CAAAR LISPXHISTORY)
(LIST HISTSTR0 X))
X])
(COMPSETY
[LAMBDA (A)
(SELECTQ A
((Y YES)
T)
((N NO)
NIL)
A])
(COMPSETF
[LAMBDA (A) (* lmm " 5-NOV-82 00:13")
(SELECTQ A
(T T)
(N NIL)
A])
(RCOMP3
[LAMBDA (FN DEF) (* wt: " 7-JUL-78 13:06")
(PROG (TYPE TEM1 TEM2)
(SELECTQ (SETQ TYPE (ARGTYPE DEF))
(NIL)
[1 (COND
((NOT (MEMB FN NLAML))
(/SET (QUOTE NLAML)
(CONS FN NLAML))
(SETQQ TEM1 NLAML)
(GO ERROR))
((MEMB FN (GETATOMVAL (SETQQ TEM1 NLAMA)))
(GO ERROR1]
[3 (COND
((NOT (MEMB FN NLAMA))
(/SET (QUOTE NLAMA)
(CONS FN NLAMA))
(SETQQ TEM1 NLAMA)
(GO ERROR))
((MEMB FN (GETATOMVAL (SETQQ TEM1 NLAML)))
(GO ERROR1]
[(0 2)
(COND
([OR (MEMB FN (GETATOMVAL (SETQQ TEM1 NLAMA)))
(MEMB FN (GETATOMVAL (SETQQ TEM1 NLAML]
(GO ERROR1))
((NEQ (ARGTYPE FN)
TYPE)
(* Situation can occur when TCOMPLING a file which contains a LAMBDA definition for a function, but for which the
incore definition is an NLAMBDA.)
(SETQ LAMS (CONS FN LAMS]
(HELP))
(RETURN FN)
ERROR1
(/SET TEM1 (REMOVE FN (GETATOMVAL TEM1)))
(SETQ TEM2 " was incorrectly on ")
ERROR
(PRIN1 (QUOTE "***note: ")
COUTFILE)
(PRIN2 FN COUTFILE T)
(PRIN1 (OR TEM2 (QUOTE " was not on "))
COUTFILE)
(PRINT TEM1 COUTFILE)
(RETURN FN])
(TCOMPL
[LAMBDA (FILES) (* lmm "19-NOV-82 12:07")
(COMPSET NIL (QUOTE (F %
)))
(for FILE inside FILES collect (OR (CAR (ERSETQ (BCOMPL FILE NIL T T)))
(CONS FILE (QUOTE (not compiled])
(RECOMPILE
[LAMBDA (PFILE CFILE FNS)
(BRECOMPILE PFILE CFILE FNS T])
(RECOMP?
[LAMBDA (X FNS) (* rmk: "24-MAY-82 21:14"
)
(SELECTQ FNS
(ALL T)
(CHANGES (FMEMB X CHANGES))
[(T EXPRS)
(OR (MEMB X EXPRSLST)
(EXPRP (OR (GETPROP X (QUOTE ADVISED))
(GETPROP X (QUOTE BROKEN))
X]
(COND
((NLISTP FNS)
(EQ X FNS))
(T (FMEMB X FNS])
(COMPILE
[LAMBDA (X FLG) (* lmm "19-NOV-82 11:51")
(RESETTOPVALS ((NLAMA NLAMA)
(NLAML NLAML)
(LAMS LAMS)
(LAMA LAMA))
(RESETVARS ((NOFIXFNSLST NOFIXFNSLST)
(NOFIXVARSLST NOFIXVARSLST))
(RETURN (PROG ((SPECVARS SPECVARS)
(LOCALVARS LOCALVARS))
(COMPSET)
[SETQ X (MAPCAR (COND
((ATOM X)
(LIST X))
(T X))
(FUNCTION (LAMBDA (FN)
(COMPILE1 FN (VIRGINFN FN T)
T]
(COND
((AND (NULL FLG)
LCFIL)
(PRINT NIL LCFIL FILERDTBL)
(CLOSEF LCFIL)))
(COND
((AND (NULL FLG)
LSTFIL)
(CLOSEF LSTFIL)))
(RETURN X])
(COMPILE1
[LAMBDA (FN DEF COREFLG) (* lmm "19-NOV-82 11:52")
(* COREFLG is used by COMPILE1A to reset NOSPELLFLG so that spelling correction not aatempted when DWIMIFYING
definitions from the file. COREFLG IS ALSO USED BY COMPILEUSERFN FOR SAME PURPOSE)
(SETQ DEF (COMPILE1A FN DEF COREFLG))
(PROG ((FREEVARS FREEVARS))
(RETURN (COND
(BYTECOMPFLG (BYTECOMPILE2 FN DEF))
(T (COMPILE2 FN DEF])
(COMPILE1A
[LAMBDA (FN DEF COREFLG) (* rmk: " 8-SEP-82 11:47")
(COND
[(EXPRP DEF)
(PROG (TEM)
(* Used by compile1 and blockcompile1. dwimifies def where approrpriate and also checks to see if it has a remote
clisptranslation (e.g. for sri qlisp.))
[COND
((OR DWIMIFYCOMPFLG (SELECTQ
[CAR (SETQ TEM (LISTP (CAR (LISTP (CDR (LISTP (CDR DEF]
(CLISP: T)
(* (EQ (CAR (LISTP (CDR TEM)))
(QUOTE DECLARATIONS:)))
NIL))
(PRINT (LIST (QUOTE dwimifying)
FN)
COUTFILE T)
(RESETVARS ((NOSPELLFLG (OR NOSPELLFLG (NULL COREFLG)))
(FILEPKGFLG (AND FILEPKGFLG COREFLG)))
(SETQ NOFIXFNSLST0 NOFIXFNSLST)
(SETQ NOFIXVARSLST0 NOFIXVARSLST)
(DWIMIFY0 DEF FN)
(COND
((TAILP NOFIXFNSLST NOFIXFNSLST0)
(SETQ NOFIXFNSLST NOFIXFNSLST0)))
(COND
((TAILP NOFIXVARSLST NOFIXVARSLST0)
(SETQ NOFIXVARSLST NOFIXVARSLST0]
(AND (NEQ (POSITION COUTFILE)
0)
(TERPRI COUTFILE))
(RETURN (COND
((AND CLISPTRANFLG (EQ (CAR DEF)
CLISPTRANFLG))
(CADR DEF))
((AND CLISPARRAY (GETHASH DEF CLISPARRAY)))
(T DEF]
(T DEF])
(FILECHECK
[LAMBDA (TAIL) (* rmk: "10-JUN-82 09:30")
(* Used by BCOMPL and BRECOMPILE. Tries to find FILE, if unsuccessful, corrects spelling on FILE.
Value is (corrected) FILE. In all cases, if cannot find FILE or correct spelling, gives an error.)
(PROG (Y (FILE (CAR TAIL)))
(RETURN (COND
((OR (NULL FILE)
(EQ FILE T))
FILE)
((INFILEP FILE))
([AND DWIMFLG (EQ (NAMEFIELD FILE T)
FILE)
(SETQ Y (MISSPELLED? FILE 70 FILELST T TAIL))
(SETQ Y (INFILEP (SETQ FILE Y] (* No spelling correction if version number specified,
or a directory field is used.)
Y)
(T
(* This will cause a file-not-found error, which may do file spelling correction. Could be a FINDFILE followed by an
ERRORX, but the ERRORX would then duplicate the spelling search.)
(CLOSEF (OPENFILE FILE (QUOTE INPUT])
(COMPEM
[LAMBDA (X Y ERRORFLG FL) (* wt: " 7-JUL-78 13:07")
(* ERRORFLG is NIL when called from COMP.
Just prints X and goes on.)
(AND (NULL FL)
(SETQ FL COUTFILE))
(COND
[(NULL ERRORFLG)
(PRIN1 (QUOTE "
*****")
FL)
(PRIN1 X FL T)
(COND
(Y (SPACES 1 FL)
(PRIN1 Y FL)))
(TERPRI FL)
(COND
((NEQ FL T)
(* so error message printed both places)
(COMPEM X Y NIL T]
(T (PRIN1 (QUOTE "*****")
T)
(ERROR X Y T])
(GETCFILE
[LAMBDA (FILES CFILE FN) (* lmm "14-NOV-81 18:29")
(PROG (X STR)
(COND
([NULL (NLSETQ (SETQ X (INFILE CFILE]
(* The reason it is done this way instead of with an INFILEP is that the user may have specified corrective action
when INFILE fails via ERRORFNS, e.g. check anther directory, spelling correct, etc.)
[COND
((NULL DWIMFLG) (* Let the error happen.)
(RETURN (INFILE CFILE]
(SETQQ STR "not found,"))
((NOT (RANDACCESSP (INPUT)))
(SETQQ STR "is not a random access file,"))
(T (RETURN X)))
(TERPRI T)
(COND
((EQ (ASKUSER DWIMWAIT (QUOTE Y)
(LIST CFILE STR (QUOTE "shall I")
FN
(COND
((AND (LISTP FILES)
(NULL (CDR FILES)))
(CAR FILES))
(T FILES))
(QUOTE "instead")))
(QUOTE Y))
(APPLY* FN FILES)
(RETURN)))
(COND
((EQ (ASKUSER DWIMWAIT (QUOTE Y)
(LIST (QUOTE
"Shall I just forget about compiling")
FILES))
(QUOTE Y))
[COND
((OR (EQ (CAR READBUF)
(QUOTE ST))
(EQ (CAR READBUF)
(QUOTE F))) (* E.g. From CLEANUP.)
(SETQ READBUF (CDR READBUF]
(PROG (RESETSTATE)
(APPLY* (QUOTE BCOMPL3)
NIL FILES))
(RETURN NIL)))
(PRIN1 (QUOTE "Then what shall I use for CFILE ? ")
T)
(RETURN (GETCFILE FILES (READ T T)
FN])
(SPECVARS
[NLAMBDA A (* lmm " 8-APR-82 21:49")
(SETQ SPECVARS (COND
((LISTP A)
(COND
((LISTP SPECVARS)
(APPEND A SPECVARS))
((EQ SPECVARS T)
T)
(T A)))
(T (SETQ LOCALVARS (UNION (LISTP LOCALVARS)
SYSLOCALVARS))
T])
(LOCALVARS
[NLAMBDA A (* lmm " 8-APR-82 21:49")
(SETQ LOCALVARS (COND
((LISTP A)
(COND
((LISTP LOCALVARS)
(APPEND A LOCALVARS))
((EQ LOCALVARS T)
T)
(T A)))
(T (SETQ SPECVARS (UNION (LISTP SPECVARS)
SYSSPECVARS))
T)))
NIL])
(GLOBALVARS
[NLAMBDA A (* wt: " 2-NOV-79 11:00")
(COND
((LISTP A)
(SETQ GLOBALVARS (UNION A GLOBALVARS])
)
(ADDTOVAR NOLINKFNS HELP ERRORX ERRORSET EVALV FAULTEVAL INTERRUPT SEARCHPDL MAPDL BREAK1 EDITE EDITL)
(ADDTOVAR LINKFNS )
(ADDTOVAR FREEVARS )
(ADDTOVAR SYSSPECVARS HELPCLOCK LISPXHIST RESETSTATE OLDVALUE UNDOSIDE0)
(ADDTOVAR SYSLOCALVARS )
(ADDTOVAR LOCALFREEVARS )
(ADDTOVAR BLKLIBRARY )
(ADDTOVAR RETFNS )
(ADDTOVAR BLKAPPLYFNS )
(ADDTOVAR DONTCOMPILEFNS )
(ADDTOVAR NLAML )
(ADDTOVAR NLAMA )
(ADDTOVAR LAMS )
(ADDTOVAR LAMA )
(RPAQ? SPECVARS T)
(RPAQ? LOCALVARS SYSLOCALVARS)
(RPAQ? DWIMIFYCOMPFLG )
(RPAQ? COMPILEHEADER "compiled on ")
(RPAQ? COMPSETLST (QUOTE (ST F STF S Y N 1 2 NIL T)))
(RPAQ? COMPSETKEYLST (QUOTE ((ST "ore and redefine " KEYLST ("" (F . "orget exprs")))
(S . "ame as last time")
(F . "ile only")
(T . "o terminal")
(1)
(2)
(Y . "es")
(N . "o"))))
(RPAQ? COMPSETDEFAULTKEYLST (QUOTE ((Y . "es")
(N . "o"))))
(RPAQ? BCOMPL.SCRATCH (SELECTQ (SYSTEMTYPE)
(D (QUOTE {CORE}BCOMPL.SCRATCH))
(QUOTE BCOMPL.SCRATCH;T)))
(RPAQ? RECOMPILEDEFAULT (QUOTE EXPRS))
(RPAQ? COUTFILE T)
(RPAQ? SVFLG T)
(RPAQ? STRF T)
(RPAQ? LSTFIL T)
(RPAQ? LCFIL )
(RPAQ? LAPFLG T)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS DIGITCHARP MACRO [LAMBDA (CHAR)
(AND (IGEQ CHAR (CHARCODE 0))
(ILEQ CHAR (CHARCODE 9])
)
)
(MOVD? (QUOTE NILL)
(QUOTE FILECHANGES))
(* COMPILEMODE)
(PUTPROPS COMPILEMODELST VARTYPE ALIST)
(DEFINEQ
(COMPILEMODE
[LAMBDA (MODE) (* lmm: "22-JUL-77 03:53")
(* returns current compile mode. If given a mode (one of ALTO MAXC or PDP10) looks it up on COMPILEMODELST and
sets values appropriately.)
(PROG1 COMPILEMODE (COND
(MODE [MAPC [CDR (OR (ASSOC MODE COMPILEMODELST)
(ERROR MODE (QUOTE ?]
(FUNCTION (LAMBDA (X)
(COND
((LISTP (CAR X))
(EVAL (CAR X)))
(T (SET (CAR X)
(CDR X]
(SETQ COMPILEMODE MODE])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: COMPILEMODE COMPILEMODE (NOLINKFNS . T))
]
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS NLAMA NLAML LAMA LAMS SYSSPECVARS SYSLOCALVARS GLOBALVARS NOFIXFNSLST
NOFIXVARSLST RECOMPILEDEFAULT COMPILE.EXT NOTCOMPILEDFILES BYTECOMPFLG COMPILEHEADER
COMPVERSION DWIMIFYCOMPFLG BCOMPL.SCRATCH DONTCOMPILEFNS RETFNS BLKLIBRARY NOLINKFNS
LINKFNS NORMALCOMMENTSFLG BUILDMAPFLG LINKEDFNS NOFIXVARSLST0 NOFIXFNSLST0 CLISPTRANFLG
CLISPARRAY FILEPKGFLG NOSPELLFLG COMPSETKEYLST REREADFLG HISTSTR0 LISPXHISTORY
COMPSETDEFAULTKEYLST FILERDTBL DFNFLG FILELST DWIMFLG DWIMWAIT EXPRSLST)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA GLOBALVARS LOCALVARS SPECVARS BLOCK:)
(ADDTOVAR NLAML BCOMPL3)
(ADDTOVAR LAMA )
)
(PUTPROPS COMPILE COPYRIGHT (NONE))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2494 50706 (BCOMPL 2504 . 7764) (BCOMPL1 7766 . 9064) (BCOMPL1A 9066 . 13254) (BCOMPL2
13256 . 17814) (BCOMPL3 17816 . 19166) (BLOCK: 19168 . 19727) (BRECOMPILE 19729 . 28119) (BRECOMPILE1
28121 . 32073) (BRECOMPILE2 32075 . 32717) (BRECOMPILE3 32719 . 33545) (BLOCKCOMPILE 33547 . 34757) (
BLOCKCOMPILE1 34759 . 38590) (COMPSET 38592 . 40990) (COMPSETREAD 40992 . 42025) (COMPSETY 42027 .
42130) (COMPSETF 42132 . 42261) (RCOMP3 42263 . 43577) (TCOMPL 43579 . 43829) (RECOMPILE 43831 . 43911
) (RECOMP? 43913 . 44276) (COMPILE 44278 . 45084) (COMPILE1 45086 . 45554) (COMPILE1A 45556 . 46818) (
FILECHECK 46820 . 47809) (COMPEM 47811 . 48450) (GETCFILE 48452 . 49928) (SPECVARS 49930 . 50224) (
LOCALVARS 50226 . 50532) (GLOBALVARS 50534 . 50704)) (52294 52853 (COMPILEMODE 52304 . 52851)))))
STOP