(FILECREATED "24-Sep-86 10:57:33" {ERIS}<LISPCORE>LIBRARY>CMLCOMPILE.;69 32453  

      changes to:  (FUNCTIONS DEFOPTIMIZER)

      previous date: "22-Sep-86 14:49:57" {ERIS}<LISPCORE>LIBRARY>CMLCOMPILE.;67)


(* 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: "15-Sep-86 18:04")
         (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)
                                          "COMPILE-FILEd" ENV))
                          (WITH-READER-ENVIRONMENT
                           ENV
                           (if NIL
                               then (PRINT (QUOTE (IN-PACKAGE "USER"))
                                           OUTPUT-FILE FILERDTBL) 
                                                  (* ; 
                                           "Force the output file to read in the appropriate package")
                                    (SETQ *PACKAGE* (FIND-PACKAGE "USER")))
                           (PROG (DEFERRED.EXPRESSIONS)
                                 (DECLARE (SPECIAL DEFERRED.EXPRESSIONS))
                             LP  (COMPILE-FILE-EXPRESSION FORM OUTPUT-FILE NIL PROCESS-ENTIRE-FILE)
                                 (SKIPSEPRS 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: (DECLARE:-FORM COMPILED.FILE EVAL@COMPILE DOCOPY DEFER)
   (CL:DO ((TAIL (CDR DECLARE:-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) 
                       (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)                                            (* gbn " 7-Aug-86 18:54")
    (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* "~&~A redefined ~&" NM)
                (SAVEDEF NM]
        (/PUTD NM DF T))
       (T (/PUTPROP NM (QUOTE CODE)
                 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 23209 (COMPILE-FILE 4012 . 9795) (INTERLISP-FORMAT-P 9797 . 10018) (
INTERLISP-NLAMBDA-FUNCTION-P 10020 . 10262) (COMPILE-FILE-EXPRESSION 10264 . 15353) (
COMPILE-FILE-WALK-FUNCTION 15355 . 15603) (ARGTYPE.STATE 15605 . 15752) (COMPILE.CHECK.ARGTYPE 15754
 . 17669) (COMPILE.FILE.DEFINEQ 17671 . 18437) (COMPILE-FILE-SETF-SYMBOL-FUNCTION 18439 . 19005) (
COMPILE-FILE-EX/IMPORT 19007 . 19349) (COMPILE.FILE.APPLY 19351 . 19603) (COMPILE.FILE.RESET 19605 . 
20446) (COMPILE-IN-CORE 20448 . 23207)) (25464 26182 (NEWDEFC 25474 . 26180)) (30236 31963 (
COMPILER:COPY-ENV-WITH-FUNCTION 30246 . 30770) (COMPILER:COPY-ENV-WITH-VARIABLE 30772 . 31242) (
COMPILER:ENV-BOUNDP 31244 . 31472) (COMPILER:ENV-FBOUNDP 31474 . 31891) (COMPILER:MAKE-EMPTY-ENV 31893
 . 31961)))))
STOP