(FILECREATED "15-Jul-86 13:46:54" {ERIS}<LISPCORE>SOURCES>COMPILE.;15 67179
changes to: (VARS COMPILECOMS)
previous date: "19-Jun-86 16:39:51" {ERIS}<LISPCORE>SOURCES>COMPILE.;14)
(* Copyright (c) 1984, 1985, 1986 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 RECOMPILEDEFAULT
COMPILE.EXT NOTCOMPILEDFILES BYTECOMPFLG COMPILEHEADER COMPVERSION DWIMIFYCOMPFLG
BCOMPL.SCRATCH DONTCOMPILEFNS LINKEDFNS NOFIXVARSLST0 NOFIXFNSLST0 CLISPTRANFLG
CLISPARRAY COMPSETKEYLST REREADFLG HISTSTR0 LISPXHISTORY COMPSETDEFAULTKEYLST
FILERDTBL 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 SPECVARS LOCALVARS)
(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 RECOMPILEDEFAULT COMPILE.EXT
NOTCOMPILEDFILES BYTECOMPFLG COMPILEHEADER COMPVERSION DWIMIFYCOMPFLG BCOMPL.SCRATCH
DONTCOMPILEFNS LINKEDFNS NOFIXVARSLST0 NOFIXFNSLST0 CLISPTRANFLG CLISPARRAY COMPSETKEYLST
REREADFLG HISTSTR0 LISPXHISTORY COMPSETDEFAULTKEYLST FILERDTBL 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 "19-Jun-86 12:19")
(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)))
[LET (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 "19-Jun-86 12:37")
(* 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.)
(* 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 (DFNFLG))
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 "19-Jun-86 14:11")
(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.)
(PROG ((DFNFLG DFNFLG)
(FILEPKGFLG)
(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 "19-Jun-86 14:17")
(* 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))
(PROG ((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) (* lmm "19-Jun-86 13:59")
(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)
(LET ((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 SPECVARS LOCALVARS)
(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 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3937 64479 (BCOMPL 3947 . 5507) (BCOMPL.BODY 5509 . 11553) (RESETOPENFILES 11555 .
11849) (BCOMPL1 11851 . 13092) (BCOMPL1A 13094 . 19372) (BCOMPL2 19374 . 24066) (BCOMPL3 24068 . 25111
) (BLOCK: 25113 . 25672) (BRECOMPILE 25674 . 42067) (BRECOMPILE1 42069 . 46021) (BRECOMPILE2 46023 .
46665) (BRECOMPILE3 46667 . 47586) (BLOCKCOMPILE 47588 . 48798) (BLOCKCOMPILE1 48800 . 52631) (COMPSET
52633 . 55057) (COMPSETREAD 55059 . 56092) (COMPSETY 56094 . 56197) (COMPSETF 56199 . 56328) (RCOMP3
56330 . 57644) (TCOMPL 57646 . 57896) (RECOMPILE 57898 . 57978) (RECOMP? 57980 . 58343) (COMPILE 58345
. 59183) (COMPILE1 59185 . 59653) (COMPILE1A 59655 . 61562) (COMPILE.FILECHECK 61564 . 61711) (COMPEM
61713 . 62352) (GETCFILE 62354 . 63701) (SPECVARS 63703 . 63997) (LOCALVARS 63999 . 64305) (
GLOBALVARS 64307 . 64477)) (66355 66914 (COMPILEMODE 66365 . 66912)))))
STOP