(FILECREATED "30-Sep-86 23:14:12" {ERIS}<LISPCORE>SOURCES>CMLCOMPILE.;11 32432
changes to: (FNS NEWDEFC COMPILE-FILE)
previous date: "29-Sep-86 23:59:59" {ERIS}<LISPCORE>SOURCES>CMLCOMPILE.;10)
(* "
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)) (* bvm: "29-Sep-86 23:13")
(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 (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 (4002 22752 (COMPILE-FILE 4012 . 9423) (INTERLISP-FORMAT-P 9425 . 9646) (
INTERLISP-NLAMBDA-FUNCTION-P 9648 . 9890) (COMPILE-FILE-EXPRESSION 9892 . 14896) (
COMPILE-FILE-WALK-FUNCTION 14898 . 15146) (ARGTYPE.STATE 15148 . 15295) (COMPILE.CHECK.ARGTYPE 15297
. 17212) (COMPILE.FILE.DEFINEQ 17214 . 17980) (COMPILE-FILE-SETF-SYMBOL-FUNCTION 17982 . 18548) (
COMPILE-FILE-EX/IMPORT 18550 . 18892) (COMPILE.FILE.APPLY 18894 . 19146) (COMPILE.FILE.RESET 19148 .
19989) (COMPILE-IN-CORE 19991 . 22750)) (25086 26161 (NEWDEFC 25096 . 26159)) (30215 31942 (
COMPILER:COPY-ENV-WITH-FUNCTION 30225 . 30749) (COMPILER:COPY-ENV-WITH-VARIABLE 30751 . 31221) (
COMPILER:ENV-BOUNDP 31223 . 31451) (COMPILER:ENV-FBOUNDP 31453 . 31870) (COMPILER:MAKE-EMPTY-ENV 31872
. 31940)))))
STOP