(FILECREATED "15-Aug-85 16:14:40" {ERIS}<LISPCORE>LIBRARY>CMLCOMPILE.;6 12547
changes to: (FNS NEWDEFC)
previous date: " 9-Aug-85 18:19:25" {ERIS}<LISPCORE>LIBRARY>CMLCOMPILE.;5)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLCOMPILECOMS)
(RPAQQ CMLCOMPILECOMS ((FNS COMPILE-FILE COMPILE-FILE-EXPRESSION COMPILE.FILE.EXPRESSION
COMPILE.FILE.PUTDEF ARGTYPE.STATE COMPILE.CHECK.ARGTYPE
COMPILE.FILE.DEFINEQ COMPILE.FILE.DEFUN COMPILE.FILE.EXPRESSION
COMPILE.FILE.APPLY COMPILE.FILE.RESET)
(VARS ARGTYPE.VARS)
(PROP COMPILE.FILE.EXPRESSION DEFINEQ * FNS.PUTDEF)
(ADDVARS (SYSPROPS COMPILE.FILE.EXPRESSION))
(FNS NEWDEFC)
(P (MOVD (QUOTE NEWDEFC)
(QUOTE DEFC)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA COMPILE-FILE)))))
(DEFINEQ
(COMPILE-FILE
(CL:LAMBDA (FILENAME &KEY LAP REDEFINE OUTPUT-FILE (SAVE-EXPRS T)
(COMPILER-OUTPUT T)
PROCESS-ENTIRE-FILE) (* lmm " 9-Aug-85 18:08")
(LET (COMPILE.FILE.AFTER VALUE COMPILE.FILE.VALUE)
(DECLARE (SPECVARS COMPILE.FILE.AFTER))
[RESETLST (RESETSAVE NIL (LIST (QUOTE RESETUNDO))
(RESETUNDO))
(RESETSAVE NLAML NLAML)
(RESETSAVE NLAMA NLAMA)
(RESETSAVE LAMS LAMS)
(RESETSAVE LAMA LAMA)
(RESETSAVE DFNFLG NIL)
(RESETSAVE COUTFILE COMPILER-OUTPUT)
(RESETSAVE SVFLG (AND SAVE-EXPRS (QUOTE DEFER)))
(LET ((LOCALVARS SYSLOCALVARS)
(SPECVARS T)
STREAM LSTFIL ROOTNAME)
[RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
(SETQ STREAM (OPENSTREAM FILENAME (QUOTE INPUT]
(if LAP
then (SETQ LSTFIL COUTFILE))
(SETQ FILENAME (FULLNAME STREAM))
(RESETSAVE NIL (LIST (FUNCTION COMPILE.FILE.RESET)
[SETQ OUTPUT-FILE (OPENSTREAM
(OR OUTPUT-FILE (PACKFILENAME.STRING (QUOTE VERSION)
NIL
(QUOTE
EXTENSION)
COMPILE.EXT
(QUOTE BODY)
FILENAME))
(QUOTE OUTPUT)
(QUOTE NEW)
(QUOTE ((TYPE BINARY]
STREAM
(ROOTFILENAME FILENAME)))
(COND
(OUTPUT-FILE (PRINT (LIST (QUOTE FILECREATED)
(DATE)
(CONS COMPILEHEADER FILENAME)
COMPVERSION "COMPILE.FILEd" (QUOTE in)
HERALDSTRING
(QUOTE dated)
MAKESYSDATE)
OUTPUT-FILE FILERDTBL)))
(PROG (FILE.EXPRESSION DEFERRED.EXPRESSIONS)
(DECLARE (SPECVARS DEFERRED.EXPRESSIONS))
LP (COND
((OR (NULL (SETQ FILE.EXPRESSION (READ STREAM FILERDTBL)))
(EQ FILE.EXPRESSION (QUOTE STOP)))
[AND PROCESS.ENTIRE.FILE (MAPC (REVERSE DEFERRED.EXPRESSIONS)
(FUNCTION (LAMBDA (EXP)
(APPLY* (CAR EXP)
(CDR EXP)
OUTPUT-FILE FILERDTBL]
(CLOSEF STREAM)
(RETURN)))
(COMPILE-FILE-EXPRESSION FILE.EXPRESSION OUTPUT-FILE NIL NIL
PROCESS.ENTIRE.FILE)
(GO LP))
(PRINT (QUOTE STOP)
OUTPUT-FILE)
(SETQ COMPILE.FILE.VALUE (CLOSEF OUTPUT-FILE]
(* do these after UNDONLSETQ entered)
(MAPC (REVERSE COMPILE.FILE.AFTER)
(FUNCTION EVAL))
COMPILE.FILE.VALUE)))
(COMPILE-FILE-EXPRESSION
[LAMBDA (FORM COMPILED.FILE COMPILE.TIME.TOO DONT.COPY DEFER)
(* lmm " 8-Jul-85 15:21")
(SELECTQ (CAR (LISTP FORM))
(DECLARE: (PROG ((ORIG.COMPILE.TIME.TOO COMPILE.TIME.TOO)
(ORIG.DONT.COPY DONT.COPY)
(FORM (CDR FORM)))
LP (COND
((NLISTP FORM)
(RETURN))
((NLISTP (CAR FORM))
(SELECTQ (CAR FORM)
(DONTCOPY (SETQ DONT.COPY T))
((DOCOPY COPY)
(SETQ DONT.COPY NIL))
[COPYWHEN (SETQ DONT.COPY
(NOT (EVAL (CAR (SETQ FORM (CDR FORM]
(FIRST (PRINTOUT COUTFILE
"Warning: (DECLARE: -- FIRST -- --) not implemented in COMPILE.FILE: "
(CADR FORM)
T))
(NOTFIRST)
(DONTEVAL@COMPILE (SETQ COMPILE.TIME.TOO NIL))
((DOEVAL@COMPILE EVAL@COMPILE)
(SETQ COMPILE.TIME.TOO T))
[EVAL@COMPILEWHEN (SETQ COMPILE.TIME.TOO
(EVAL (CAR (SETQ FORM (CDR FORM]
(EVAL@LOADWHEN (SETQ FORM (CDR FORM)))
((DONTEVAL@LOAD DOEVAL@LOAD EVAL@LOAD)
NIL)
(PRINT (CONS (CAR FORM)
(QUOTE (UNRECOGNIZED DECLARE TAG)))
COUTFILE)))
(T (COMPILE-FILE-EXPRESSION (CAR FORM)
COMPILED.FILE COMPILE.TIME.TOO DONT.COPY
DEFER)))
(SETQ FORM (CDR FORM))
(GO LP)))
[EVAL.WHEN (LET* [(CONDITIONS (CADR FORM))
(COMPTIME (OR (FMEMB (QUOTE COMPILE)
CONDITIONS)
(AND COMPILE.TIME.TOO (FMEMB (QUOTE EVAL)
CONDITIONS]
(if (OR (FMEMB (QUOTE LOAD)
CONDITIONS))
then (for X in (CDDR FORM) do (COMPILE-FILE-EXPRESSION X
COMPILED.FILE
COMPTIME
DONT.COPY
DEFER))
elseif COMPTIME
then (MAPC (CDDR FORM)
(FUNCTION EVAL]
(PROGN (for X in (CDR FORM) do (COMPILE-FILE-EXPRESSION X COMPILED.FILE COMPILE.TIME.TOO
DONT.COPY DEFER)))
(PROGN (AND COMPILE.TIME.TOO (EVAL FORM))
(OR DONT.COPY (LET [(PROP (OR (GETPROP (CAR FORM)
(QUOTE COMPILE-FILE-EXPRESSION))
(GETPROP (CAR FORM)
(QUOTE COMPILE.FILE.EXPRESSION]
(if PROP
then (COMPILE.FILE.APPLY PROP FORM COMPILE.TIME.TOO
DONT.COPY DEFER)
elseif [AND (SETQ PROP (GETLIS (CAR FORM)
COMPILERMACROPROPS))
(NOT (EQUAL FORM (SETQ FORM (MACROEXPANSION
FORM
(CADR PROP]
then (COMPILE-FILE-EXPRESSION FORM COMPILED.FILE
COMPILE.TIME.TOO DONT.COPY
DEFER)
else (COMPILE.FILE.APPLY (FUNCTION PRINT)
FORM COMPILE.TIME.TOO DONT.COPY
DEFER])
(COMPILE.FILE.EXPRESSION
[LAMBDA (FORM COMPILED.FILE COMPILE.TIME.TOO DONT.COPY DEFER)
(* lmm " 8-Jul-85 15:23")
(* for back compatibility)
(COMPILE-FILE-EXPRESSION FORM COMPILED.FILE COMPILE.TIME.TOO DONT.COPY DEFER])
(COMPILE.FILE.PUTDEF
(LAMBDA (FORM LCFIL RDTBL) (* lmm " 9-Aug-85 13:52") (PROG (FN) (BYTECOMPILE2 (SETQ FN (EVAL (CADR
FORM))) (COMPILE1A FN (EVAL (CADDDR FORM)) NIL)))))
(ARGTYPE.STATE
[LAMBDA NIL
(for X in ARGTYPE.VARS do (PRINTOUT T X , (EVAL (CADR X))
T])
(COMPILE.CHECK.ARGTYPE
[LAMBDA (X AT) (* lmm "15-Jun-85 16:58")
(if (NEQ AT (LET (BLKFLG)
(COMP.ARGTYPE X)))
then (* incorrectly on one of the defining lists)
(for ATYPEPAIR in ARGTYPE.VARS
do (LET [(VAL (FMEMB X (EVALV (CADR ATYPEPAIR]
(if (EQ AT (CAR ATYPEPAIR))
then (if VAL
then (PRINTOUT COUTFILE "Compiler confused: " X " on "
(CADR ATYPEPAIR)
" but compiler doesn't think its a "
(CADDR ATYPEPAIR)))
[/SETTOPVAL (CADR ATYPEPAIR)
(CONS X (PROGN (GETTOPVAL (CADR ATYPEPAIR]
else (if VAL
then (PRINTOUT COUTFILE "Warning: compiler thought " X " "
(LIST (QUOTE a)
(OR (CADDR (ASSOC AT ARGTYPE.VARS))
"LAMBDA spread")
(QUOTE function))
" was a "
(CADDR ATYPEPAIR)
" because it was incorrectly on "
(CADR ATYPEPAIR)
T)
(/SETTOPVAL (CADR ATYPEPAIR)
(REMOVE X (PROGN (GETTOPVAL (CADR ATYPEPAIR])
(COMPILE.FILE.DEFINEQ
[LAMBDA (FORM LCFIL RDTBL) (* lmm " 5-Jul-85 15:42")
(for DEF in (CDR FORM)
do (COMPILE.CHECK.ARGTYPE (CAR DEF)
(ARGTYPE (CADR DEF)))
(BYTECOMPILE2 (CAR DEF)
(COMPILE1A (CAR DEF)
(CADR DEF)
NIL])
(COMPILE.FILE.DEFUN
(LAMBDA (FORM LCFIL RDTBL) (* lmm " 9-Aug-85 13:50") (BYTECOMPILE2 (CADR DEF) (COMPILE1A (CADR DEF) (
CADR DEF) NIL))))
(COMPILE.FILE.EXPRESSION
[LAMBDA (FORM COMPILED.FILE COMPILE.TIME.TOO DONT.COPY DEFER)
(* lmm " 8-Jul-85 15:23")
(* for back compatibility)
(COMPILE-FILE-EXPRESSION FORM COMPILED.FILE COMPILE.TIME.TOO DONT.COPY DEFER])
(COMPILE.FILE.APPLY
[LAMBDA (PROP FORM COMPILE.TIME.TOO DONT.COPY DEFER) (* lmm "27-Jun-85 17:36")
(PROGN (AND COMPILE.TIME.TOO (EVAL FORM))
(OR DONT.COPY (if DEFER
then (push DEFERRED.EXPRESSIONS (CONS PROP FORM))
else (APPLY* PROP FORM COMPILED.FILE FILERDTBL])
(COMPILE.FILE.RESET
[LAMBDA (COMPILED.FILE SOURCEFILE ROOTNAME) (* lmm "15-Jun-85 16:52")
(* Cleans up after brecompile and bcompl have finished
operating,)
[COND
(COMPILED.FILE (CLOSEF? COMPILED.FILE)
(AND RESETSTATE (DELFILE COMPILED.FILE]
(COND
(SOURCEFILE (CLOSEF? SOURCEFILE)))
(COND
((NULL RESETSTATE) (* Finished successfully.)
(/SETATOMVAL (QUOTE NOTCOMPILEDFILES)
(REMOVE ROOTNAME NOTCOMPILEDFILES)) (* Removes FILES from NOTCOMPILEDFILES.)
])
)
(RPAQQ ARGTYPE.VARS ((1 NLAML "NLAMBDA spread")
(2 LAMA "LAMBDA nospread")
(0 LAMS "LAMBDA spread")
(3 NLAMA "NLAMBDA no-spread")))
(PUTPROPS DEFINEQ COMPILE.FILE.EXPRESSION COMPILE.FILE.DEFINEQ)
(PUTPROPS * COMPILE.FILE.EXPRESSION NILL)
(PUTPROPS FNS.PUTDEF COMPILE.FILE.EXPRESSION COMPILE.FILE.PUTDEF)
(ADDTOVAR SYSPROPS COMPILE.FILE.EXPRESSION)
(DEFINEQ
(NEWDEFC
(LAMBDA (NM DF) (* lmm "15-Aug-85 16:06")
(COND
((EQ SVFLG (QUOTE DEFER))
(push COMPILE.FILE.AFTER (LIST (FUNCTION NEWDEFC)
(KWOTE NM)
(KWOTE DF)
T)))
((EQ SVFLG (QUOTE SELECTOR)) (* hack to allow compiling selectors)
(SELECTOR.PUTD NM DF T))
((OR (NULL DFNFLG)
(EQ DFNFLG T))
(COND
((GETD NM)
(VIRGINFN NM T)
(COND
((NULL DFNFLG)
(PRINT (CONS NM (QUOTE (redefined)))
T T) (* NOTE: this call to PRINT is changed to LISPXPRINT
later in the loadup.)
(SAVEDEF NM)))))
(/PUTD NM DF T) (* NOTE: this call to \PUTD is changed to /PUTD later
in the loadup.)
)
(T (/PUTPROP NM (QUOTE CODE)
DF) (* NOTE: this call to /PUTPROP is changed to /PUTPROP
later in the loadup.)
))
DF))
)
(MOVD (QUOTE NEWDEFC)
(QUOTE DEFC))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA COMPILE-FILE)
)
(PUTPROPS CMLCOMPILE COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (938 10723 (COMPILE-FILE 948 . 3767) (COMPILE-FILE-EXPRESSION 3769 . 6882) (
COMPILE.FILE.EXPRESSION 6884 . 7246) (COMPILE.FILE.PUTDEF 7248 . 7424) (ARGTYPE.STATE 7426 . 7549) (
COMPILE.CHECK.ARGTYPE 7551 . 8821) (COMPILE.FILE.DEFINEQ 8823 . 9170) (COMPILE.FILE.DEFUN 9172 . 9315)
(COMPILE.FILE.EXPRESSION 9317 . 9679) (COMPILE.FILE.APPLY 9681 . 10022) (COMPILE.FILE.RESET 10024 .
10721)) (11118 12280 (NEWDEFC 11128 . 12278)))))
STOP