(FILECREATED "12-Oct-86 16:03:55" {ERIS}<LISPCORE>SOURCES>CMLCOMPILE.;13 33265
changes to: (VARS CMLCOMPILECOMS)
(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
NEWDEFC)
(FUNCTIONS CL:COMPILE DISASSEMBLE COMPILE-FILE-DECLARE: COMPILER:OPTIMIZER-LIST
DEFOPTIMIZER)
(DEFINE-TYPES OPTIMIZERS)
previous date: " 6-Oct-86 22:36:57" {ERIS}<LISPCORE>SOURCES>CMLCOMPILE.;12)
(* "
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 PRETTYCOMPRINT)
(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 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)
(PUTPROPS PRETTYCOMPRINT COMPILE-FILE-EXPRESSION NILL)
(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 (XCL:PACK (LIST 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")
(XCL:PACK (LIST "optimize-" FORM-NAME)
(SYMBOL-PACKAGE 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 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 (4563 23499 (COMPILE-FILE 4573 . 10008) (INTERLISP-FORMAT-P 10010 . 10232) (
INTERLISP-NLAMBDA-FUNCTION-P 10234 . 10479) (COMPILE-FILE-EXPRESSION 10481 . 15530) (
COMPILE-FILE-WALK-FUNCTION 15532 . 15784) (ARGTYPE.STATE 15786 . 15935) (COMPILE.CHECK.ARGTYPE 15937
. 17870) (COMPILE.FILE.DEFINEQ 17872 . 18641) (COMPILE-FILE-SETF-SYMBOL-FUNCTION 18643 . 19214) (
COMPILE-FILE-EX/IMPORT 19216 . 19559) (COMPILE.FILE.APPLY 19561 . 19815) (COMPILE.FILE.RESET 19817 .
20659) (COMPILE-IN-CORE 20661 . 23497)) (25893 26975 (NEWDEFC 25903 . 26973)) (31108 32835 (
COMPILER:COPY-ENV-WITH-FUNCTION 31118 . 31642) (COMPILER:COPY-ENV-WITH-VARIABLE 31644 . 32114) (
COMPILER:ENV-BOUNDP 32116 . 32344) (COMPILER:ENV-FBOUNDP 32346 . 32763) (COMPILER:MAKE-EMPTY-ENV 32765
. 32833)))))
STOP