(FILECREATED " 8-Jul-85 15:33:27" {ERIS}<LISPCORE>SOURCES>COMPILE.;13 54136
changes to: (VARS COMPILECOMS)
previous date: " 5-Jul-85 15:45:32" {ERIS}<LISPCORE>SOURCES>COMPILE.;12)
(* Copyright (c) 1984, 1985 by Xerox Corporation. All rights reserved. The following program was
created in 1984 but has not been published within the meaning of the copyright law, is furnished
under license, and may not be used, copied and/or disclosed except in accordance with the terms of
said license.)
(PRETTYCOMPRINT COMPILECOMS)
(RPAQQ COMPILECOMS [(GLOBALVARS NLAMA NLAML LAMA LAMS SYSSPECVARS SYSLOCALVARS GLOBALVARS NOFIXFNSLST
NOFIXVARSLST RECOMPILEDEFAULT COMPILE.EXT NOTCOMPILEDFILES
BYTECOMPFLG COMPILEHEADER COMPVERSION DWIMIFYCOMPFLG BCOMPL.SCRATCH
DONTCOMPILEFNS BUILDMAPFLG LINKEDFNS NOFIXVARSLST0 NOFIXFNSLST0
CLISPTRANFLG CLISPARRAY FILEPKGFLG NOSPELLFLG COMPSETKEYLST REREADFLG
HISTSTR0 LISPXHISTORY COMPSETDEFAULTKEYLST FILERDTBL DFNFLG DWIMFLG
DWIMWAIT EXPRSLST)
(FNS BCOMPL BCOMPL.BODY RESETOPENFILES BCOMPL1 BCOMPL1A BCOMPL2 BCOMPL3 BLOCK: BRECOMPILE
BRECOMPILE1 BRECOMPILE2 BRECOMPILE3 BLOCKCOMPILE BLOCKCOMPILE1 COMPSET COMPSETREAD
COMPSETY COMPSETF RCOMP3 TCOMPL RECOMPILE RECOMP? COMPILE COMPILE1 COMPILE1A
COMPILE.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 CHANGES))
(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)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA GLOBALVARS LOCALVARS SPECVARS BLOCK:)
(NLAML BCOMPL3)
(LAMA])
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS NLAMA NLAML LAMA LAMS SYSSPECVARS SYSLOCALVARS GLOBALVARS NOFIXFNSLST NOFIXVARSLST
RECOMPILEDEFAULT COMPILE.EXT NOTCOMPILEDFILES BYTECOMPFLG COMPILEHEADER COMPVERSION
DWIMIFYCOMPFLG BCOMPL.SCRATCH DONTCOMPILEFNS BUILDMAPFLG LINKEDFNS NOFIXVARSLST0
NOFIXFNSLST0 CLISPTRANFLG CLISPARRAY FILEPKGFLG NOSPELLFLG COMPSETKEYLST REREADFLG
HISTSTR0 LISPXHISTORY COMPSETDEFAULTKEYLST FILERDTBL DFNFLG DWIMFLG DWIMWAIT EXPRSLST)
)
(DEFINEQ
(BCOMPL
[LAMBDA (FILES CFILE NOBLOCKSFLG OPTIONSSET) (* lmm " 4-SEP-84 23:14")
(* 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)
(EXPRSLST)) (* RESETTOPVALS is used for variables whose top-value in
both deep and shallow is likely to be affected by
expressions on the file)
(RESETVARS ((NOFIXVARSLST NOFIXVARSLST)
(NOFIXFNSLST NOFIXFNSLST))
(SETQ FILES (RESETOPENFILES FILES))
(* Checks that all FILES are there, and if not, attempts
spelling correction. Opens them for input, too, and
returns the input stream)
(RETURN (BCOMPL.BODY FILES CFILE NOBLOCKSFLG OPTIONSSET])
(BCOMPL.BODY
[LAMBDA (FILES CFILE NOBLOCKSFLG OPTIONSSET) (* lmm " 4-SEP-84 23:13")
(PROG (DEFS CHANGES OTHERS FIRST BLOCKS BLKFNS FILEROOT TEM SCRATCHFILE (SPECVARS T)
(LOCALVARS SYSLOCALVARS))
[OR OPTIONSSET (COMPSET NIL (QUOTE (F %
] (* 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)))
[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)
HERALDSTRING
(QUOTE dated)
MAKESYSDATE)
LCFIL FILERDTBL)))
[RESETVARS (DFNFLG)
(* 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)
(for X in FILES do (PROG (TEM)
LP (COND
((OR (NULL (SETQ TEM (READ X FILERDTBL)))
(EQ TEM (QUOTE STOP)))
(CLOSEF X)
(RETURN)))
(BCOMPL1A TEM (QUOTE DEFAULT)
(QUOTE DEFAULT)
(QUOTE DEFAULT))
(GO LP]
(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])
(RESETOPENFILES
[LAMBDA (FILES) (* lmm "26-Jul-84 16:28")
[RESETSAVE NIL (LIST [FUNCTION (LAMBDA (FILES)
(MAPC FILES (FUNCTION CLOSEF?]
(SETQ FILES (for F inside FILES collect (OPENFILE F (QUOTE INPUT]
FILES])
(BCOMPL1
[LAMBDA (X) (* lmm "11-Jul-84 17:40")
(* 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.)
(RESETVARS (DFNFLG)
(* 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)
LP (COND
((NULL X)
(RETURN))
((LISTP X)
(SETQ TEM (CAR X))
(SETQ X (CDR X)))
((OR (NULL (SETQ TEM (READ X FILERDTBL)))
(EQ TEM (QUOTE STOP)))
(CLOSEF X)
(RETURN)))
(BCOMPL1A TEM (QUOTE DEFAULT)
(QUOTE DEFAULT)
(QUOTE DEFAULT))
(GO LP])
(BCOMPL1A
[LAMBDA (X COMPCOPYFLG COMPEVALFLG FIRSTFLG) (* lmm "11-Jul-84 17:39")
(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 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 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]
((SETQ SETQQ RPAQ RPAQQ)
(push NOFIXVARSLST (CADR X))
(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 COREOK) (* lmm "22-SEP-84 21:15")
(* 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 COREOK)))
[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.)
)
[[AND COREOK (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 "26-Jul-84 16:46")
(* Cleans up after brecompile and bcompl have finished
operating,)
(COND
(SCRATCHFILE [COND
((NULL RESETSTATE) (* finished successfully.)
(COPYBYTES SCRATCHFILE LCFIL 0 (GETFILEPTR SCRATCHFILE]
(CLOSEF? SCRATCHFILE)
(DELFILE SCRATCHFILE)))
[COND
(LCFIL (CLOSEF? LCFIL)
(AND RESETSTATE (DELFILE LCFIL]
(COND
((AND LSTFIL LSTFIL1)
(CLOSEF? LSTFIL1)))
(COND
(CFILE (CLOSEF? CFILE)))
[MAPC FILES (FUNCTION (LAMBDA (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 "22-SEP-84 21:22")
(* 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)
(EXPRSLST))
(RESETVARS ((NOFIXFNSLST NOFIXFNSLST)
(NOFIXVARSLST NOFIXVARSLST)
(BUILDMAPFLG T))
(RETURN (PROG (CHANGES OTHERS FIRST FILEMAPLST FNLST BLKFNS BLOCKS FILE FILE.COM TEM ADRLST
SCRATCHFILE (SPECVARS T)
(LOCALVARS SYSLOCALVARS)
ROOTS COREOK)
(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 (RESETOPENFILES FILES))
(COND
((SETQ TEM (for FILE in FILES when (NOT (RANDACCESSP FILE)) collect FILE))
(GO NONRAND)))
(SETQ FILE (NAMEFIELD (CAR FILES)))
(SETQ FILE.COM (PACKFILENAME (QUOTE NAME)
FILE
(QUOTE EXTENSION)
COMPILE.EXT))
(COND
((EQ FNS (QUOTE ALL))
(GO BRECALL)))
CFILERETRY
(COND
([NLSETQ (SETQ CFILE (OPENFILE (OR CFILE FILE.COM)
(QUOTE INPUT)
(QUOTE OLD)
NIL
(QUOTE ((TYPE BINARY]
(COND
((NOT (RANDACCESSP CFILE))
(SETQ TEM (CLOSEF CFILE))
(GO NONRAND)))
(GO BREC))
((EQ (ASKUSER DWIMWAIT (QUOTE Y)
(LIST (OR CFILE FILE.COM)
"not found;" " compile all functions on "
(COND
((AND (LISTP FILES)
(NULL (CDR FILES)))
(CAR FILES))
(T FILES))
(QUOTE "instead")))
(QUOTE Y))
(GO BRECALL))
((EQ (ASKUSER DWIMWAIT (QUOTE Y)
(LIST (QUOTE "Just forget about compiling")
FILES))
(QUOTE Y))
(SELECTQ (CAR READBUF)
((ST F STF)
(* E.g. From CLEANUP.)
(SETQ READBUF (CDR READBUF)))
NIL)
(ERROR!))
(T (PRIN1
"File to use for CFILE (source of compiled definitions not being recompiled): "
T)
(SETQ CFILE (READ T T))
(GO CFILERETRY)))
BRECALL
(SETQQ FNS ALL)
(SETQ CFILE NIL)
BREC(COMPSET NIL (QUOTE (S T %
)))
[SETQ LCFIL (OPENFILE FILE.COM (QUOTE OUTPUT)
(QUOTE NEW)
NIL
(QUOTE ((TYPE BINARY]
(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. 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.)
[SETQ COREOK (for X in FILES always (AND (EQ (CDAR (GETPROP (SETQ TEM (ROOTFILENAME
X))
(QUOTE FILEDATES)))
X)
(FMEMB (CDAR (GETPROP TEM (QUOTE FILE)))
(QUOTE (LOADFNS T]
[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)
(SETFILEPTR FL 0)
(INPUT FL)
(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 (for X in FILEMAPLST join (for X in (CDDAR X) join (for X
in (CDDR X)
collect (CAR X]
(* 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)
HERALDSTRING
(QUOTE dated)
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 (LITATOM X)
(RECOMP? X FNS]
(* If any function in the BLOCK is to be recompiled, the
whole BLOCK must be recompiled.)
(BCOMPL2 BLOCK FILEMAPLST COREOK))
(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.)
(for X in FNLST do (if (OR (FMEMB X BLKFNS)
(FMEMB X DONTCOMPILEFNS))
elseif (RECOMP? X FNS)
then
(* 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 (BRECOMPILE3 X FILEMAPLST COREOK)
))
(CADDR TEM))
else (BRECOMPILE1 X T)))
(RETURN LCFIL)
NONRAND
(printout T TEM " not RANDACCESSP, using " (if NOBLOCKSFLG
then (QUOTE TCOMPL)
else (QUOTE BCOMPL))
" instead." T)
(RETURN (BCOMPL.BODY FILES NIL NOBLOCKSFLG])
(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 COREOK) (* lmm "22-SEP-84 21:12")
(* returns definition of FN, either from in core, or
from the file.)
(PROG (TEM FILE)
(RETURN (COND
([AND COREOK (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) (* lmm "11-Jul-84 17:33")
(* 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 "23-AUG-84 02:02")
(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)
LAPFLG 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])
(COMPILE.FILECHECK
[LAMBDA (FILE) (* lmm "11-Jul-84 17:27")
(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) (* lmm "26-Jul-84 16:47")
(PROG (X STR)
RETRY
(COND
([NLSETQ (SETQ X (OPENFILE CFILE (QUOTE INPUT)
(QUOTE OLD]
(* 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
((RANDACCESSP X)
(RETURN X)))
(CLOSEF X)
(SETQQ STR "is not a random access file,"))
(T (SETQQ STR "not found,")))
(TERPRI T)
(COND
((EQ (ASKUSER DWIMWAIT (QUOTE Y)
(LIST (OR X CFILE)
STR " compile all functions on " (COND
((AND (LISTP FILES)
(NULL (CDR FILES)))
(CAR FILES))
(T FILES))
(QUOTE "instead")))
(QUOTE Y))
(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]
(ERROR!)))
(PRIN1 (QUOTE "Then what shall I use for CFILE ? ")
T)
(SETQ CFILE (READ T T))
(GO RETRY])
(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 CHANGES))
(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 COMPILERVARS
(ADDTOVAR NLAMA GLOBALVARS LOCALVARS SPECVARS BLOCK:)
(ADDTOVAR NLAML BCOMPL3)
(ADDTOVAR LAMA )
)
(PUTPROPS COMPILE COPYRIGHT ("Xerox Corporation" T 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3215 51735 (BCOMPL 3225 . 4785) (BCOMPL.BODY 4787 . 8459) (RESETOPENFILES 8461 . 8755)
(BCOMPL1 8757 . 9827) (BCOMPL1A 9829 . 13789) (BCOMPL2 13791 . 18483) (BCOMPL3 18485 . 19528) (BLOCK:
19530 . 20089) (BRECOMPILE 20091 . 29968) (BRECOMPILE1 29970 . 33922) (BRECOMPILE2 33924 . 34566) (
BRECOMPILE3 34568 . 35487) (BLOCKCOMPILE 35489 . 36699) (BLOCKCOMPILE1 36701 . 40532) (COMPSET 40534
. 42958) (COMPSETREAD 42960 . 43993) (COMPSETY 43995 . 44098) (COMPSETF 44100 . 44229) (RCOMP3 44231
. 45545) (TCOMPL 45547 . 45797) (RECOMPILE 45799 . 45879) (RECOMP? 45881 . 46244) (COMPILE 46246 .
47084) (COMPILE1 47086 . 47554) (COMPILE1A 47556 . 48818) (COMPILE.FILECHECK 48820 . 48967) (COMPEM
48969 . 49608) (GETCFILE 49610 . 50957) (SPECVARS 50959 . 51253) (LOCALVARS 51255 . 51561) (GLOBALVARS
51563 . 51733)) (53317 53876 (COMPILEMODE 53327 . 53874)))))
STOP