(FILECREATED " 6-Oct-86 22:36:57" {ERIS}<LISPCORE>SOURCES>CMLCOMPILE.;12 32372
changes to: (FNS COMPILE-FILE)
previous date: "30-Sep-86 23:14:12" {ERIS}<LISPCORE>SOURCES>CMLCOMPILE.;11)
(* "
Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT CMLCOMPILECOMS)
(RPAQQ CMLCOMPILECOMS
((COMS (FUNCTIONS CL:COMPILE DISASSEMBLE)
(FNS COMPILE-FILE INTERLISP-FORMAT-P INTERLISP-NLAMBDA-FUNCTION-P
COMPILE-FILE-EXPRESSION COMPILE-FILE-WALK-FUNCTION ARGTYPE.STATE
COMPILE.CHECK.ARGTYPE COMPILE.FILE.DEFINEQ COMPILE-FILE-SETF-SYMBOL-FUNCTION
COMPILE-FILE-EX/IMPORT COMPILE.FILE.APPLY COMPILE.FILE.RESET COMPILE-IN-CORE)
(VARS ARGTYPE.VARS)
(PROP COMPILE-FILE-EXPRESSION DEFINEQ * SETF-SYMBOL-FUNCTION)
(FUNCTIONS COMPILE-FILE-DECLARE:))
(COMS (FNS NEWDEFC)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (MOVD (QUOTE NEWDEFC)
(QUOTE DEFC)))))
(COMS (* ; "Optimizer definitions and environment hacking")
(DEFINE-TYPES OPTIMIZERS)
(FUNCTIONS COMPILER:OPTIMIZER-LIST)
(FUNCTIONS DEFOPTIMIZER)
(STRUCTURES COMPILER::ENV COMPILER:CONTEXT)
(FNS COMPILER:COPY-ENV-WITH-FUNCTION COMPILER:COPY-ENV-WITH-VARIABLE
COMPILER:ENV-BOUNDP COMPILER:ENV-FBOUNDP COMPILER:MAKE-EMPTY-ENV))
(PROP COMPILE-FILE-EXPRESSION PRETTYCOMPRINT)
(PROP FILETYPE CMLCOMPILE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA COMPILER:MAKE-EMPTY-ENV COMPILER:ENV-FBOUNDP COMPILER:ENV-BOUNDP
COMPILER:COPY-ENV-WITH-VARIABLE COMPILER:COPY-ENV-WITH-FUNCTION
COMPILE-FILE)))))
(DEFUN CL:COMPILE (NAME &OPTIONAL LAMBDA-EXPR) (LET ((NEW-NAME (OR NAME (QUOTE \CLCOMPILETEMP))))
(COMPILE-IN-CORE NEW-NAME (OR LAMBDA-EXPR
(GETD NAME)))
(AND LAMBDA-EXPR NAME (/PUTPROP NAME (QUOTE
EXPR)
LAMBDA-EXPR))
(OR NAME (GETD NEW-NAME))))
(DEFUN DISASSEMBLE (NAME-OR-COMPILED-FUNCTION &KEY LEVEL-P (RADIX 8)
(OUTPUT *STANDARD-OUTPUT*)
FIRST-BYTE MARKED-PC) (PRINTCODE
(if (CCODEP NAME-OR-COMPILED-FUNCTION)
then NAME-OR-COMPILED-FUNCTION
else (CL:COMPILE NIL (if (SYMBOLP
NAME-OR-COMPILED-FUNCTION
)
then (SYMBOL-FUNCTION
NAME-OR-COMPILED-FUNCTION
)
else
NAME-OR-COMPILED-FUNCTION
)))
LEVEL-P RADIX OUTPUT FIRST-BYTE MARKED-PC))
(DEFINEQ
(COMPILE-FILE
(CL:LAMBDA (FILENAME &KEY LAP REDEFINE OUTPUT-FILE (SAVE-EXPRS T)
(COMPILER-OUTPUT T)
(PROCESS-ENTIRE-FILE NIL PEFP)) (* Pavel " 6-Oct-86 22:36")
(LET (COMPILE.FILE.AFTER VALUE COMPILE.FILE.VALUE)
(DECLARE (SPECIAL COMPILE.FILE.AFTER COMPILE.FILE.VALUE))
(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 STRF REDEFINE)
(RESETSAVE SVFLG (AND SAVE-EXPRS REDEFINE (QUOTE DEFER)))
(RESETSAVE LAPFLG LAP)
(LET ((*PACKAGE* *INTERLISP-PACKAGE*)
(*READ-BASE* 10)
(LOCALVARS SYSLOCALVARS)
(SPECVARS T)
STREAM LSTFIL ROOTNAME INTERLISP-FORMAT ENV FORM)
(DECLARE (SPECIAL *PACKAGE* *READ-BASE* LOCALVARS SPECVARS LSTFIL))
(RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
(SETQ STREAM (OPENSTREAM FILENAME (QUOTE INPUT)))))
(MULTIPLE-VALUE-SETQ (ENV FORM)
(\PARSE-FILE-HEADER STREAM (QUOTE RETURN)
T))
(SETQ INTERLISP-FORMAT (AND ENV (NEQ ENV *COMMON-LISP-READ-ENVIRONMENT*)))
(if (NOT PEFP)
then (SETQ PROCESS-ENTIRE-FILE INTERLISP-FORMAT))
(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)))
(if OUTPUT-FILE
then (RESETSAVE LCFIL OUTPUT-FILE)
(PRINT-COMPILE-HEADER (LIST STREAM)
(QUOTE ("COMPILE-FILEd"))
ENV))
(WITH-READER-ENVIRONMENT
ENV
(PROG (DEFERRED.EXPRESSIONS)
(DECLARE (SPECIAL DEFERRED.EXPRESSIONS))
LP (COMPILE-FILE-EXPRESSION FORM OUTPUT-FILE NIL PROCESS-ENTIRE-FILE)
(SKIPSEPRCODES STREAM)
(if (EOFP STREAM)
then (AND PROCESS-ENTIRE-FILE (for EXP in (REVERSE
DEFERRED.EXPRESSIONS
)
do (APPLY* (CAR EXP)
(CDR EXP)
OUTPUT-FILE)))
(CLOSEF STREAM)
(RETURN))
(SETQ FORM (LET ((EXPRESSION (READ STREAM)))
(if INTERLISP-FORMAT
then EXPRESSION
else (CMLTRANSLATE EXPRESSION))))
(GO LP))
(PRINT NIL OUTPUT-FILE))
(SETQ COMPILE.FILE.VALUE (CLOSEF OUTPUT-FILE))))
(* ; "Do these after UNDONLSETQ entered")
(MAPC (REVERSE COMPILE.FILE.AFTER)
(FUNCTION EVAL))
COMPILE.FILE.VALUE)))
(INTERLISP-FORMAT-P
[LAMBDA (STREAM) (* bvm: " 3-Aug-86 14:01")
(SELCHARQ (PEEKCCODE STREAM)
(; NIL)
((↑F "(")
T)
NIL])
(INTERLISP-NLAMBDA-FUNCTION-P
[LAMBDA (X) (* lmm " 7-May-86 20:12")
(AND (LITATOM X)
(FMEMB (ARGTYPE X)
(QUOTE (1 3)))
(NOT (SPECIAL-FORM-P X])
(COMPILE-FILE-EXPRESSION
[LAMBDA (FORM COMPILED.FILE COMPILE.TIME.TOO DEFER) (* Pavel "22-Sep-86 14:36")
(DECLARE (SPECIAL COMPILED.FILE))
(AND (LISTP FORM)
(SELECTQ (CAR FORM)
((DECLARE:)
(COMPILE-FILE-DECLARE: FORM COMPILED.FILE COMPILE.TIME.TOO T DEFER))
((PROGN)
(for X in (CDR FORM) do (COMPILE-FILE-EXPRESSION X COMPILED.FILE COMPILE.TIME.TOO
DEFER)))
((QUOTE) (* ; " ignore top level quoted expression -i")
NIL)
((COMPILER-LET) (* ; " top level compiler-let. bind variables and recursively compile sub-expressions. This is here mainly for b PCL has top level compiler-lets")
[LET [(VARS (CL:MAPCAR (CL:FUNCTION (CL:LAMBDA (X)
(if (CONSP X)
then (CAR X)
else X)))
(CADR FORM)))
(VALS (CL:MAPCAR [CL:FUNCTION (CL:LAMBDA (X)
(if (CONSP X)
then (CL:EVAL (CADR X]
(CADR FORM]
(PROGV VARS VALS (CL:MAPC (CL:FUNCTION (CL:LAMBDA (X)
(COMPILE-FILE-EXPRESSION X
COMPILED.FILE
COMPILE.TIME.TOO DEFER)))
(CDDR FORM])
((EVAL-WHEN)
[LET [[EVAL.SPECIFIED (OR (FMEMB (QUOTE EVAL)
(CADR FORM))
(FMEMB (QUOTE CL:EVAL)
(CADR FORM]
[LOAD.SPECIFIED (OR (FMEMB (QUOTE LOAD)
(CADR FORM))
(FMEMB (QUOTE CL:LOAD)
(CADR FORM]
(COMPILE.SPECIFIED (OR (FMEMB (QUOTE COMPILE)
(CADR FORM))
(FMEMB (QUOTE CL:COMPILE)
(CADR FORM]
(COND
[(NOT LOAD.SPECIFIED)
(COND
((OR COMPILE.SPECIFIED (AND COMPILE.TIME.TOO EVAL.SPECIFIED))
(for INNER-FORM in (CDDR FORM) do (EVAL INNER-FORM]
(T (for INNER-FORM in (CDDR FORM)
do (COMPILE-FILE-EXPRESSION INNER-FORM COMPILED.FILE
(OR COMPILE.SPECIFIED (AND COMPILE.TIME.TOO EVAL.SPECIFIED)
)
DEFER])
((IN-PACKAGE) (* ;
"This is special because it has to be dumped to the output BEFORE the package changes")
(PRINT FORM COMPILED.FILE FILERDTBL)
(EVAL FORM))
(LET [(PROP (OR (GETPROP (CAR FORM)
(QUOTE COMPILE-FILE-EXPRESSION))
(GETPROP (CAR FORM)
(QUOTE COMPILE.FILE.EXPRESSION]
(if [AND (NOT PROP)
(NOT (SPECIAL-FORM-P (CAR FORM)))
(NOT (INTERLISP-NLAMBDA-FUNCTION-P (CAR FORM)))
(NEQ FORM (SETQ FORM (MACROEXPAND-1 FORM]
then (COMPILE-FILE-EXPRESSION FORM COMPILED.FILE COMPILE.TIME.TOO DEFER)
else (if COMPILE.TIME.TOO
then (EVAL FORM))
(if PROP
then (COMPILE.FILE.APPLY PROP FORM DEFER)
elseif [NOT (EQUAL FORM (SETQ FORM (WALK-FORM FORM :WALK-FUNCTION
(FUNCTION
COMPILE-FILE-WALK-FUNCTION]
then (COMPILE-FILE-EXPRESSION FORM COMPILED.FILE COMPILE.TIME.TOO DEFER)
else (COMPILE.FILE.APPLY (FUNCTION PRINT)
FORM DEFER])
(COMPILE-FILE-WALK-FUNCTION
[LAMBDA (FORM) (* lmm "26-Jun-86 17:25")
(if (NLISTP FORM)
then FORM
else (VALUES FORM (INTERLISP-NLAMBDA-FUNCTION-P (CAR FORM])
(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) (* bvm: "18-Sep-86 14:35")
(for DEF in (CDR FORM) unless (FMEMB (CAR DEF)
DONTCOMPILEFNS) do (COMPILE.CHECK.ARGTYPE
(CAR DEF)
(ARGTYPE (CADR DEF)))
(BYTECOMPILE2 (CAR DEF)
(COMPILE1A (CAR DEF)
(CADR DEF)
NIL])
(COMPILE-FILE-SETF-SYMBOL-FUNCTION
[LAMBDA (FORM LCFIL) (* bvm: " 8-Sep-86 16:55")
(if [AND (FMEMB (CAR (LISTP (THIRD FORM)))
(QUOTE (FUNCTION CL:FUNCTION)))
(EQ (CAR (LISTP (SECOND FORM)))
(QUOTE QUOTE))
(CONSP (SECOND (THIRD FORM]
then (BYTECOMPILE2 (CADR (SECOND FORM))
(CADR (THIRD FORM)))
else (PRINT (WALK-FORM FORM :WALK-FUNCTION (FUNCTION COMPILE-FILE-WALK-FUNCTION))
LCFIL])
(COMPILE-FILE-EX/IMPORT
[LAMBDA (FORM LCFIL RDTBL) (* bvm: " 3-Aug-86 15:05")
(* * "EXPORT, IMPORT, SHADOW, USE-PACKAGE are all implicitly EVAL@COMPILE, since they have to affect the package being used to read what follows")
(PRINT FORM LCFIL RDTBL)
(EVAL FORM])
(COMPILE.FILE.APPLY
[LAMBDA (PROP FORM DEFER) (* bvm: " 8-Sep-86 16:55")
(if DEFER
then (push DEFERRED.EXPRESSIONS (CONS PROP FORM))
else (APPLY* PROP FORM COMPILED.FILE])
(COMPILE.FILE.RESET
[LAMBDA (COMPILED.FILE SOURCEFILE ROOTNAME) (* bvm: " 9-Sep-86 15:16")
(* Cleans up after brecompile and
bcompl have finished operating,)
(if (AND COMPILED.FILE (OPENP COMPILED.FILE))
then (CLOSE-AND-MAYBE-DELETE COMPILED.FILE))
(if SOURCEFILE
then (CLOSEF? SOURCEFILE))
(if (NULL RESETSTATE)
then (* Finished successfully.)
(/SETATOMVAL (QUOTE NOTCOMPILEDFILES)
(REMOVE ROOTNAME NOTCOMPILEDFILES)) (* Removes FILES from
NOTCOMPILEDFILES.)])
(COMPILE-IN-CORE
[LAMBDA (fn-name fn-expr fn-type NOSAVE)
(DECLARE (SPECVARS LCFIL LAPFLG STRF SVFLG LSTFIL SPECVARS LOCALVARS DONT-TRANSFER-PUTD))
(* lmm " 2-Jun-86 22:04")
(* in-core compiling for functions and forms, without the interview.
if X is a list, we assume that we are being called merely to display the lap
and machine code. the form is compiled as the definition of FOO but the
compiled :CODE is thrown away. -
if X is a litatom, then saving, redefining, and printing is controlled by the
flags.)
(LET ((NOREDEFINE NIL)
(PRINTLAP NIL)
(DONT-TRANSFER-PUTD T))
(RESETVARS [(NLAMA NLAMA)
(NLAML NLAML)
(LAMS LAMS)
(LAMA LAMA)
(NOFIXFNSLST NOFIXFNSLST)
(NOFIXVARSLST NOFIXVARSLST)
(COUTFILE (COND
((AND (BOUNDP (QUOTE NULLFILE))
(STREAMP NULLFILE)
(OPENP NULLFILE))
NULLFILE)
(T (SETQ NULLFILE (OPENFILE (QUOTE {NULL})
(QUOTE OUTPUT]
(RETURN (RESETLST (* RESETLST to provide reset context
for macros under COMPILE1 as generated
e.g. by DECL.)
(PROG ((LCFIL)
[LAPFLG (AND PRINTLAP (COND
(BYTECOMPFLG T)
(T 2]
(STRF (NOT NOREDEFINE))
(SVFLG (if (EQ fn-type (QUOTE SELECTOR))
then (QUOTE SELECTOR)
else (NOT NOSAVE)))
(LSTFIL T)
(SPECVARS SYSSPECVARS)
(LOCALVARS T))
(RETURN (PROGN (SETQ fn-expr (COMPILE1A fn-name fn-expr T))
(PROG ((FREEVARS FREEVARS))
(RETURN (BYTECOMPILE2 fn-name fn-expr])
)
(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 SETF-SYMBOL-FUNCTION COMPILE-FILE-EXPRESSION COMPILE-FILE-SETF-SYMBOL-FUNCTION)
(DEFUN COMPILE-FILE-DECLARE: (FORM COMPILED.FILE EVAL@COMPILE DOCOPY DEFER)
(CL:DO ((TAIL (CDR FORM)
(CDR TAIL)))
((ENDP TAIL))
(CL:IF (SYMBOLP (CAR TAIL))
(CASE (CAR TAIL)
((EVAL@LOAD DOEVAL@LOAD DONTEVAL@LOAD)
NIL)
((EVAL@LOADWHEN)
(CL:POP TAIL))
((EVAL@COMPILE DOEVAL@COMPILE)
(SETQ EVAL@COMPILE T))
((DONTEVAL@COMPILE)
(SETQ EVAL@COMPILE NIL))
((EVAL@COMPILEWHEN)
(SETQ EVAL@COMPILE (EVAL (CAR (SETQ TAIL (CDR TAIL))))))
((COPY DOCOPY)
(SETQ DOCOPY T))
((DONTCOPY)
(SETQ DOCOPY NIL))
((COPYWHEN)
(SETQ DOCOPY (EVAL (CAR (SETQ TAIL (CDR TAIL))))))
((FIRST)
(FORMAT COUTFILE
"Warning: (DECLARE: -- FIRST -- --) not implemented in COMPILE-FILE: ~S~%%"
(CADR TAIL)))
((NOTFIRST COMPILERVARS))
(OTHERWISE (FORMAT COUTFILE "Warning: Ignoring unrecognized DECLARE: tag: ~S~%%"
(CAR TAIL))))
(COND
((EQ (QUOTE DECLARE:)
(CAR (CAR TAIL)))
(COMPILE-FILE-DECLARE: (CAR TAIL)
COMPILED.FILE EVAL@COMPILE DOCOPY DEFER))
(T (CL:WHEN EVAL@COMPILE (EVAL (CAR TAIL)))
(CL:WHEN DOCOPY (COMPILE-FILE-EXPRESSION (CAR TAIL)
COMPILED.FILE EVAL@COMPILE DEFER)))))))
(DEFINEQ
(NEWDEFC
[LAMBDA (NM DF) (* bvm: "30-Sep-86 23:12")
[COND
((EQ SVFLG (QUOTE DEFER))
(push COMPILE.FILE.AFTER (LIST (FUNCTION NEWDEFC)
(KWOTE NM)
(KWOTE DF)
T)))
((OR (NULL DFNFLG)
(EQ DFNFLG T))
[COND
((GETD NM)
(VIRGINFN NM T)
(COND
((NULL DFNFLG)
(FORMAT *ERROR-OUTPUT* "~&(~S redefined)~%%" NM)
(SAVEDEF NM]
(/PUTD NM DF T))
(T (* ;; "Save on CODE prop. Be nice and change it from archaic CCODEP object to modern compiled code object.")
(/PUTPROP NM (QUOTE CODE)
(if (ARRAYP DF)
then (create COMPILED-CLOSURE
FNHEADER ← (fetch (ARRAYP BASE) of DF))
else DF]
DF])
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(MOVD (QUOTE NEWDEFC)
(QUOTE DEFC))
)
(* ; "Optimizer definitions and environment hacking")
(DEF-DEFINE-TYPE OPTIMIZERS "COMPILER OPTIMIZERS" )
(DEFMACRO COMPILER:OPTIMIZER-LIST (FN) (BQUOTE (GET (\, FN)
(QUOTE COMPILER:OPTIMIZER-LIST))))
(DEFDEFINER DEFOPTIMIZER
OPTIMIZERS (NAME OPT-NAME &REST ARGLIST-BODY &ENVIRONMENT ENV)
"define an optimizer for NAME"
(COND
((NOT ARGLIST-BODY) (* ; "(defoptimizer name optfn)")
(PROG1 (* ;; "We purposely use this combination of PUTPROP and UNION here instead of `(PUSHNEW ',OPT-NAME (COMPILER:OPTIMIZER-LIST ',NAME)) in order to avoid generating a LET*. Files in the INIT can't use that form. This will all be much easier when the new compiler works...")
(BQUOTE (PUTPROP (QUOTE (\, NAME))
(QUOTE COMPILER:OPTIMIZER-LIST)
(UNION (GETPROP (QUOTE (\, NAME))
(QUOTE COMPILER:OPTIMIZER-LIST))
(LIST (QUOTE (\, OPT-NAME))))))
(SETQ NAME (INTERN (STRING-APPEND NAME "-OPTIMIZED-BY-" OPT-NAME)
(SYMBOL-PACKAGE OPT-NAME)))
(* ; " optimizer name is generated")
))
(T (LET* ((FORM-NAME NAME)
(ARG-LIST OPT-NAME)
(OPT-FN-NAME (if (AND OPT-NAME (SYMBOLP OPT-NAME)
(CDR ARGLIST-BODY))
then (* ;
"(defoptimizer form-name opt-name arglist . body)")
(SETQ NAME OPT-NAME)
(* ; "optimizer name is opt-name")
(PROG1 OPT-NAME (SETQ ARG-LIST (POP ARGLIST-BODY)))
else (* ;
"(defoptimizer form-name arglist . body) optimizer name is form name")
(PACK* "optimize-" FORM-NAME))))
(MULTIPLE-VALUE-BIND (BODY DECLS DOC)
(PARSE-DEFMACRO ARG-LIST (QUOTE $$WHOLE)
ARGLIST-BODY NAME ENV :ENVIRONMENT (QUOTE $$ENV)
:CONTEXT
(QUOTE $$CTX))
(BQUOTE (PROGN (DEFUN (\, OPT-FN-NAME) ($$WHOLE $$ENV $$CTX) (\,@ DECLS)
(\, BODY))
(PUTPROP (QUOTE (\, FORM-NAME))
(QUOTE COMPILER:OPTIMIZER-LIST)
(UNION (GETPROP (QUOTE (\, FORM-NAME))
(QUOTE COMPILER:OPTIMIZER-LIST))
(LIST (QUOTE (\, OPT-FN-NAME))))))))))))
(DEFSTRUCT (COMPILER::ENV (:CONSTRUCTOR COMPILER::MAKE-ENV)
(:COPIER COMPILER::COPY-ENV)
(:PREDICATE COMPILER::ENV-P)) (VENV NIL) (FENV NIL))
(DEFSTRUCT (COMPILER:CONTEXT (:CONSTRUCTOR COMPILER:MAKE-CONTEXT)
(:COPIER COMPILER::COPY-CONTEXT)
(:PREDICATE COMPILER::CONTEXT-P)) (TOP-LEVEL-P NIL) (VALUES-USED
:UNKNOWN)
(PREDICATE-P NIL))
(DEFINEQ
(COMPILER:COPY-ENV-WITH-FUNCTION
(CL:LAMBDA (ENV FN &OPTIONAL (KIND :FUNCTION)
EXP-FN) (* "Pavel" "26-Apr-86 15:13")
(* "Pavel" "25-Apr-86 18:53")
(LET [(NEW-ENV (CL:IF ENV (COMPILER::COPY-ENV ENV)
(COMPILER:MAKE-EMPTY-ENV]
(CL:PUSH (LIST FN KIND EXP-FN)
(COMPILER::ENV-FENV NEW-ENV))
NEW-ENV)))
(COMPILER:COPY-ENV-WITH-VARIABLE
(CL:LAMBDA (ENV VAR &OPTIONAL (KIND :LEXICAL)) (* "Pavel" "26-Apr-86 15:12")
(* "Pavel" "25-Apr-86 18:54")
(LET [(NEW-ENV (CL:IF ENV (COMPILER::COPY-ENV ENV)
(COMPILER:MAKE-EMPTY-ENV]
(CL:PUSH (CONS VAR KIND)
(COMPILER::ENV-VENV NEW-ENV))
NEW-ENV)))
(COMPILER:ENV-BOUNDP
[CL:LAMBDA (ENV VAR) (* "Pavel" "25-Apr-86 18:41")
(LET [(BINDING (CL:ASSOC VAR (COMPILER::ENV-VENV ENV]
(AND BINDING (CDR BINDING])
(COMPILER:ENV-FBOUNDP
[CL:LAMBDA (ENV FN) (* "Pavel" "25-Apr-86 18:42")
(LET [(BINDING (CL:ASSOC FN (COMPILER::ENV-FENV ENV]
(AND BINDING (LET ((KIND (SECOND BINDING)))
(CL:IF (EQ KIND :MACRO)
(VALUES :MACRO (THIRD BINDING))
KIND])
(COMPILER:MAKE-EMPTY-ENV
(CL:LAMBDA NIL (COMPILER::MAKE-ENV)))
)
(PUTPROPS PRETTYCOMPRINT COMPILE-FILE-EXPRESSION NILL)
(PUTPROPS CMLCOMPILE FILETYPE COMPILE-FILE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA COMPILER:MAKE-EMPTY-ENV COMPILER:ENV-FBOUNDP COMPILER:ENV-BOUNDP
COMPILER:COPY-ENV-WITH-VARIABLE COMPILER:COPY-ENV-WITH-FUNCTION COMPILE-FILE)
)
(PUTPROPS CMLCOMPILE COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (4001 22775 (COMPILE-FILE 4011 . 9446) (INTERLISP-FORMAT-P 9448 . 9669) (
INTERLISP-NLAMBDA-FUNCTION-P 9671 . 9913) (COMPILE-FILE-EXPRESSION 9915 . 14919) (
COMPILE-FILE-WALK-FUNCTION 14921 . 15169) (ARGTYPE.STATE 15171 . 15318) (COMPILE.CHECK.ARGTYPE 15320
. 17235) (COMPILE.FILE.DEFINEQ 17237 . 18003) (COMPILE-FILE-SETF-SYMBOL-FUNCTION 18005 . 18571) (
COMPILE-FILE-EX/IMPORT 18573 . 18915) (COMPILE.FILE.APPLY 18917 . 19169) (COMPILE.FILE.RESET 19171 .
20012) (COMPILE-IN-CORE 20014 . 22773)) (25026 26101 (NEWDEFC 25036 . 26099)) (30155 31882 (
COMPILER:COPY-ENV-WITH-FUNCTION 30165 . 30689) (COMPILER:COPY-ENV-WITH-VARIABLE 30691 . 31161) (
COMPILER:ENV-BOUNDP 31163 . 31391) (COMPILER:ENV-FBOUNDP 31393 . 31810) (COMPILER:MAKE-EMPTY-ENV 31812
. 31880)))))
STOP