;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 126.99 ;;; Reason: ;;; More changes for cross compilation to make setf and locf methods ;;; available to the right frobbers at the right times. ;;; Again, should be transparent to native lambda compilation. ;;; Written 30-Sep-88 16:27:02 by smh at site Gigamos Cambridge ;;; while running on Alex from band 3 ;;; with Experimental System 126.95, Experimental ZWEI 126.14, Experimental ZMail 74.2, Experimental Local-File 76.0, Experimental File-Server 25.0, Experimental Lambda-Diag 18.0, Experimental Unix-Interface 15.0, Experimental Tape 26.4, microcode 1762, SDU Boot Tape 3.14, SDU ROM 102, Lambda/Falcon Development System. ; From modified file DJ: L.SYS; QCFILE.LISP#381 at 30-Sep-88 16:27:11 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCFILE  " (DEFUN COMPILE-STREAM (INPUT-STREAM GENERIC-PATHNAME FASD-FLAG PROCESS-FN QC-FILE-LOAD-FLAG QC-FILE-IN-CORE-FLAG PACKAGE-SPEC &OPTIONAL ignore IGNORE COMPILING-WHOLE-FILE-P (*target-computer* 'lambda-interface)) "This function does all the /"outer loop/" of the compiler, for file and editor compilation. to be compiled are read from INPUT-STREAM. The caller is responsible for handling any file attributes. GENERIC-PATHNAME is the file to record information for and use the attributes of. It may be NIL if compiling to core. FASD-FLAG is NIL if not making a QFASL file. PROCESS-FN is called on each form. QC-FILE-LOAD-FLAG, QC-FILE-IN-CORE-FLAG, and PACKAGE-SPEC are options. COMPILING-WHOLE-FILE-P should be T if you are processing all of the file." (LET ((*PACKAGE* *PACKAGE*) (*READ-BASE* *READ-BASE*) (*PRINT-BASE* *PRINT-BASE*) FDEFINE-FILE-PATHNAME (READ-FUNCTION (IF QC-FILE-CHECK-INDENTATION 'READ-CHECK-INDENTATION 'ZL:READ))) (FILE-OPERATION-WITH-WARNINGS (GENERIC-PATHNAME ':COMPILE COMPILING-WHOLE-FILE-P) (COMPILER-WARNINGS-CONTEXT-BIND ;; Override the package if required. It has been bound in any case. (AND PACKAGE-SPEC (SETQ *PACKAGE* (PKG-FIND-PACKAGE PACKAGE-SPEC))) ;; Override the generic pathname (SETQ FDEFINE-FILE-PATHNAME (LET ((PATHNAME (SEND INPUT-STREAM :SEND-IF-HANDLES :PATHNAME))) (AND PATHNAME (SEND PATHNAME :GENERIC-PATHNAME)))) ;; Having bound the variables, process the file. (LET ((QC-FILE-IN-PROGRESS T) (UNDO-DECLARATIONS-FLAG (or ; ||| force if cross compiling - smh 30sep88 (NOT QC-FILE-LOAD-FLAG) (not (eq *target-computer* *host-computer*)))) (LOCAL-DECLARATIONS NIL) (OPEN-CODE-MAP-SWITCH OPEN-CODE-MAP-SWITCH) ;(RUN-IN-MACLISP-SWITCH RUN-IN-MACLISP-SWITCH) ;(OBSOLETE-FUNCTION-WARNING-SWITCH OBSOLETE-FUNCTION-WARNING-SWITCH) (ALL-SPECIAL-SWITCH ALL-SPECIAL-SWITCH) (SOURCE-FILE-UNIQUE-ID) (FASD-PACKAGE NIL)) (WHEN FASD-FLAG ;; Copy all suitable file properties into the fasl file ;; Suitable means those that are lambda-bound when you read in a file. (LET ((PLIST (COPY-LIST (SEND GENERIC-PATHNAME :PROPERTY-LIST)))) ;; Remove unsuitable properties (DO ((L (LOCF PLIST))) ((NULL (CDR L))) (IF (NOT (NULL (GET (CADR L) 'FS:FILE-ATTRIBUTE-BINDINGS))) (SETQ L (CDDR L)) (SETF (CDR L) (CDDDR L)))) ;; Make sure the package property is really the package compiled in ;; Must load QFASL file into same package compiled in ;; On the other hand, if we did not override it ;; and the attribute list has a list for the package, write that list. (unless (and (consp (getf plist ':package)) (null package-spec)) (setf (getf plist ':package) (intern (package-name *package*) si:pkg-keyword-package))) (AND INPUT-STREAM (SETQ SOURCE-FILE-UNIQUE-ID (SEND INPUT-STREAM :SEND-IF-HANDLES :TRUENAME)) (SETF (GETF PLIST ':QFASL-SOURCE-FILE-UNIQUE-ID) SOURCE-FILE-UNIQUE-ID)) ;; If a file is being compiled across directories, remember where the ;; source really came from. (AND FDEFINE-FILE-PATHNAME FASD-STREAM (LET ((OUTFILE (SEND FASD-STREAM :SEND-IF-HANDLES :PATHNAME))) (WHEN OUTFILE (SETQ OUTFILE (SEND OUTFILE :GENERIC-PATHNAME)) (AND (NEQ OUTFILE FDEFINE-FILE-PATHNAME) (SETF (GETF PLIST ':SOURCE-FILE-GENERIC-PATHNAME) FDEFINE-FILE-PATHNAME))))) (MULTIPLE-VALUE-BIND (MAJOR MINOR) (SI:GET-SYSTEM-VERSION "System") (SETF (GETF PLIST ':COMPILE-DATA) `(,USER-ID ,SI:LOCAL-PRETTY-HOST-NAME ,(TIME:GET-UNIVERSAL-TIME) ,MAJOR ,MINOR ;; flush this next major release ;; --- fasload shouldn't even try to load qfasls this old (NEW-DESTINATIONS T ; NOT :new-destinations!! ;install this when we want to change FASD-FEF-Q ; new-cdr-codes ,(zerop sys:cdr-next) :SITE ,SI:SITE-NAME)))) ;; First thing in QFASL file must be property list ;; These properties wind up on the GENERIC-PATHNAME. (COND (QC-FILE-REL-FORMAT (FUNCALL (INTERN (STRING 'DUMP-FILE-PROPERTY-LIST) 'QFASL-REL) GENERIC-PATHNAME PLIST)) (T (FASD-FILE-PROPERTY-LIST PLIST))))) (QC-PROCESS-INITIALIZE) (DO ((EOF (NCONS NIL)) (FORM)) (()) ;; Detect EOF by peeking ahead, and also get an error now ;; if the stream is wedged. We really want to get an error ;; in that case, not make a warning. (LET ((CH (SEND INPUT-STREAM :TYI))) (OR CH (RETURN nil)) (SEND INPUT-STREAM :UNTYI CH)) (setq si:premature-warnings (append si:premature-warnings si:premature-warnings-this-object)) (let ((si:premature-warnings nil)) (SETQ FORM (LET ((READ-AREA (IF QC-FILE-LOAD-FLAG DEFAULT-CONS-AREA QCOMPILE-TEMPORARY-AREA)) (WARN-ON-ERRORS-STREAM INPUT-STREAM) (QC-FILE-READ-IN-PROGRESS FASD-FLAG)) ;looked at by XR-#,-MACRO (WARN-ON-ERRORS ('READ-ERROR "Error in reading") (FUNCALL (OR SI:*READFILE-READ-FUNCTION* READ-FUNCTION) INPUT-STREAM EOF)))) (setq si:premature-warnings-this-object si:premature-warnings)) (AND (EQ FORM EOF) (RETURN nil)) ;; Start a new whack if FASD-TABLE is getting too big. (AND FASD-FLAG ( (FASD-TABLE-LENGTH) QC-FILE-WHACK-THRESHOLD) (FASD-END-WHACK)) (WHEN (AND (ATOM FORM) FASD-FLAG) (WARN 'ATOM-AT-TOP-LEVEL :IMPLAUSIBLE "The atom ~S appeared at top level; this would do nothing at FASLOAD time." FORM)) (FUNCALL PROCESS-FN FORM))))))) )) ; From modified file DJ: L.SYS; QCP1.LISP#737 at 30-Sep-88 16:27:44 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCP1  " (DEFUN QCOMPILE0 (EXP FUNCTION-TO-BE-DEFINED GENERATING-MICRO-COMPILER-INPUT-P &OPTIONAL (NAME-TO-GIVE-FUNCTION FUNCTION-TO-BE-DEFINED)) (LET ((EXP1 EXP) (DEF-TO-BE-SXHASHED) (LVCNT) (MAXPDLLVL 0) ;deepest lvl reached by local pdl (PDLLVL 0) ;Runtine local pdllvl ;; p2 things (*CALL-BLOCK-PDL-LEVELS*) ;used only in lambda mode. (*open-frames* nil) ;used in cross compile mode. (*WITHIN-CATCH*) (*WITHIN-POSSIBLE-LOOP*) (*DROPTHRU* T) ;Can drop in if false, flush stuff till tag or (*TAGOUT*) (ALLGOTAGS) (*TLEVEL* T) (*P1VALUE* T) ;Compiling for all values (*BINDP* NIL) ;%BIND not yet used in this frame (*VARS* ()) (*ALLVARS* ()) (*FREEVARS* ()) (*LOCAL-FUNCTIONS* *OUTER-CONTEXT-LOCAL-FUNCTIONS*) (*FUNCTION-ENVIRONMENT* *OUTER-CONTEXT-FUNCTION-ENVIRONMENT*) (*PROGDESC-ENVIRONMENT* *OUTER-CONTEXT-PROGDESC-ENVIRONMENT*) (*GOTAG-ENVIRONMENT* *OUTER-CONTEXT-GOTAG-ENVIRONMENT*) (LL) (TLFUNINIT (not (eq *target-computer* 'lambda-interface))) ;crosscompiling, use FEF-INI-COMP-C not fef initialization. (*SPECIALFLAG*) (MACROFLAG) (*LOCAL-MAP* ()) ;names of local variables (*ARG-MAP* ()) ;names of arguments (*BASE-STACK-SLOTS* ()) ;aux-slots in cross-compile mode. (*STACK-SLOTS* ()) ;currently existing stack-slots in cross-compile mode. (*LOCAL-FUNCTION-MAP* ()) ;names of local functions (EXPR-DEBUG-INFO) (*FAST-ARGS-POSSIBLE* T) (*BREAKOFF-COUNT* 0) ;no internal functions yet (*LEXICAL-CLOSURE-COUNT* 0) (*lexical-ref-code-name-alist* ()) (MACROS-EXPANDED) ;List of all macros found in this function, ; for the debugging info. (SELF-FLAVOR-DECLARATION (cdr (assq :self-flavor local-declarations))) (*SELF-REFERENCES-PRESENT* NIL) ;Bound to T if any SELF-REFs are present (LOCAL-DECLARATIONS LOCAL-DECLARATIONS) ;Don't mung ouside value (SUBST-FLAG) ;T if this is a SUBST being compiled. ; Always put interpreted defn in debug info. (INHIBIT-SPECIAL-WARNINGS INHIBIT-SPECIAL-WARNINGS) (*CLOBBER-NONSPECIAL-VARS-LISTS* ()) wrapped-block-name (*placeholder-function-number* 0) (*placeholder-alist* nil) ) (BEGIN-PROCESSING-FUNCTION FUNCTION-TO-BE-DEFINED) (WHEN (LIST-MATCH-P FUNCTION-TO-BE-DEFINED `(:PROPERTY ,IGNORE :NAMED-STRUCTURE-INVOKE)) (WARN 'OBSOLETE-PROPERTY :IMPLAUSIBLE "NAMED-STRUCTURE-INVOKE, the property name, should not be a keyword.")) ;; If compiling a macro, compile its expansion function ;; and direct lap to construct a macro later. (WHEN (EQ (CAR EXP1) 'MACRO) (SETQ MACROFLAG T) (SETQ EXP1 (CDR EXP1)) (SETQ DEF-TO-BE-SXHASHED EXP1)) (UNLESS (MEMQ (CAR EXP1) '(LAMBDA ZL:SUBST CL:SUBST NAMED-LAMBDA NAMED-SUBST)) (WARN 'FUNCTION-NOT-VALID :FATAL "The definition is not a function at all.") (RETURN-FROM QCOMPILE0 NIL)) (IF (MEMQ (CAR EXP1) '(ZL:SUBST NAMED-SUBST CL:SUBST)) ;;>> This is pretty bogous (SETQ SUBST-FLAG T INHIBIT-SPECIAL-WARNINGS T)) ;; If a NAMED-LAMBDA, discard the name and save debug-info in special place. (WHEN (MEMQ (CAR EXP1) '(NAMED-LAMBDA NAMED-SUBST)) (SETQ EXPR-DEBUG-INFO (CDR-SAFE (CADR EXP1)) WRAPPED-BLOCK-NAME (unless (and (listp (fourth exp1)) (eql (first (fourth exp1)) 'block) (eql (second (fourth exp1)) (second exp1))) ;; Not already wrapped with this block name. (second exp1)) EXP1 `(,(IF (EQ (CAR EXP1) 'NAMED-LAMBDA) 'LAMBDA 'ZL:SUBST) . ,(CDDR EXP1))) ;; Debug info that is equivalent to declarations ;; should be turned back into declarations, coming before ;; declarations made outside of compilation ;; but after anything coming from a DECLARE in the body. ;>> Does not barf at bogoid declarations. (DOLIST (ELT (REVERSE EXPR-DEBUG-INFO)) (LET ((TEM (GET (CAR ELT) 'SI::DEBUG-INFO))) (WHEN TEM (IF (AND (SYMBOLP TEM) (GET TEM 'SI::DEBUG-INFO)) (SETQ ELT (CONS TEM (CDR ELT)))) (PUSH ELT LOCAL-DECLARATIONS))))) (SETQ LL (CADR EXP1)) ;lambda list. (unless (cl:listp ll) (warn 'invalid-lambda-list :impossible "~S is supposed to be a lambda-list" ll) (setq ll () exp1 `(,(car exp1) () . ,(cddr exp1)))) ;; Record the function's arglist for warnings about recursive calls. (OR THIS-FUNCTION-ARGLIST-FUNCTION-NAME (SETQ THIS-FUNCTION-ARGLIST-FUNCTION-NAME NAME-TO-GIVE-FUNCTION THIS-FUNCTION-ARGLIST LL)) ;; Extract documentation string and declarations from the front of the body. (MULTIPLE-VALUE-BIND (BODY LOCAL-DECLARATIONS DOCUMENTATION) (WITH-LIST (ENV *FUNCTION-ENVIRONMENT*) (EXTRACT-DECLARATIONS (CDDR EXP1) LOCAL-DECLARATIONS T ENV)) (IF WRAPPED-BLOCK-NAME (SETQ BODY `((BLOCK ,WRAPPED-BLOCK-NAME . ,BODY)))) (SETQ SELF-FLAVOR-DECLARATION (CDR (ASSQ ':SELF-FLAVOR LOCAL-DECLARATIONS))) ;; If the user just did (declare (:self-flavor flname)), ;; compute the full declaration for that flavor. (WHEN (AND SELF-FLAVOR-DECLARATION (NULL (CDR SELF-FLAVOR-DECLARATION))) (SETQ SELF-FLAVOR-DECLARATION (CDR (SI::FLAVOR-DECLARATION (CAR SELF-FLAVOR-DECLARATION))))) ;; Actual DEFMETHODs must always have SELF-FLAVOR (WHEN (EQ (CAR-SAFE FUNCTION-TO-BE-DEFINED) ':METHOD) (SETQ *SELF-REFERENCES-PRESENT* T)) ;; Process &KEY and &AUX vars, if there are any. (WHEN (OR (MEMQ '&KEY LL) (MEMQ '&AUX LL)) ;; Put arglist together with body again. (LET ((LAMEXP `(LAMBDA ,LL (DECLARE . ,LOCAL-DECLARATIONS) . ,BODY))) ;; If there are keyword arguments, expand them. (AND (MEMQ '&KEY LL) (SETQ LAMEXP (EXPAND-KEYED-LAMBDA LAMEXP))) ;; Now turn any &AUX variables in the LAMBDA into a LET* in the body. (SETQ LAMEXP (P1AUX LAMEXP)) ;; Separate lambda list and body again. (SETQ LL (CADR LAMEXP) BODY (CDDR LAMEXP))) ;; Can just pop off the declarations as we have them already from above (DO () ((NEQ (CAR-SAFE (CAR BODY)) 'DECLARE)) (POP BODY))) ;; Create the arglist accessable through (arglist foo 'compile) (LET ((L ())) (DOLIST (X (CADR EXP1)) (PUSH (COND ((EQ X '&AUX) (RETURN)) ((ATOM X) X) ;foo, &optional, etc ((CONSP (CAR X)) ;((:foo bar)), ((:foo bar) baz foop), etc (IF (CADR X) (LIST (CAAR X) (CADR X)) (CAAR X))) (T ;(foo), (foo bar), (foo bar foop) (IF (CADR X) (LIST (CAR X) (CADR X)) (CAR X)))) L)) (SETQ L (NREVERSE L)) (and (boundp '*compilation-environment*) *compilation-environment* (setf (getf (gethash THIS-FUNCTION-ARGLIST-FUNCTION-NAME (compilation-environment-plist-hashtab *compilation-environment*)) 'compiler-arglist) l)) (UNLESS (EQUAL L LL) (PUSH `(COMPILER-ARGLIST . ,L) LOCAL-DECLARATIONS))) ;; Now process the variables in the lambda list, after the local declarations. (SETQ LL (P1SBIND LL 'FEF-ARG-REQ NIL NIL LOCAL-DECLARATIONS)) (COND ((NOT (NULL (CDR BODY))) (SETQ EXP1 `(PROGN . ,BODY))) ((SETQ EXP1 (CAR BODY)))) (SETQ EXP1 (P1 EXP1)) ;Do pass 1 to single-expression body (push (cons 'placeholder-to-micro-function-table *placeholder-alist*) local-declarations) (SETQ LVCNT (compiler-target-switch (ASSIGN-LAP-ADDRESSES))) ;in cross-compile mode, number of aux-stack slots. ;; Now that we know all the variables needed by lexical closures, ;; make a list of them and put them into the entries in COMPILER-QUEUE ;; for each of those lexical closures. (let ((*variables-used-in-lexical-closures* (IF (ZEROP *LEXICAL-CLOSURE-COUNT*) () (RECORD-VARIABLES-USED-IN-LEXICAL-CLOSURES)))) (OUTF `(MFEF ,FUNCTION-TO-BE-DEFINED ,*SPECIALFLAG* ,(ELIMINATE-DUPLICATES-AND-REVERSE *ALLVARS*) ,*FREEVARS* ,NAME-TO-GIVE-FUNCTION)) (IF MACROFLAG (OUTF `(CONSTRUCT-MACRO))) (OUTF `(QTAG S-V-BASE)) (OUTF `(S-V-BLOCK)) (IF (AND SELF-FLAVOR-DECLARATION *SELF-REFERENCES-PRESENT*) (OUTF `(SELF-FLAVOR . ,SELF-FLAVOR-DECLARATION))) (OUTF `(QTAG DESC-LIST-ORG)) (OUTF `(PARAM LLOCBLOCK ,(IF (or (ZEROP *LEXICAL-CLOSURE-COUNT*) (neq *target-computer* 'lambda-interface)) ;cross compiling, this is number of stack slots. LVCNT ;; One extra for the lexical frame pointer. ;; One extra for the unshared frame list. (+ lvcnt *lexical-closure-count* 2) ; (+ LVCNT (* 4 *LEXICAL-CLOSURE-COUNT*) 3 ; (LENGTH *VARIABLES-USED-IN-LEXICAL-CLOSURES*)) ))) (OUTF `(A-D-L)) (OUTF `(QTAG QUOTE-BASE)) (OUTF `(ENDLIST)) ;Lap will insert quote vector here (WHEN (NOT (ZEROP *LEXICAL-CLOSURE-COUNT*)) (OUTF `(VARIABLES-USED-IN-LEXICAL-CLOSURES . ,(REVERSE (MAPCAR (LAMBDA (HOME) (LET ((TEM (VAR-LAP-ADDRESS HOME))) (CASE (CAR TEM) (ARG (CADR TEM)) (T (unless (fixnump (cadr tem)) ;|||smh 22sep88 ;; Without this test, a nonnumeric cadr here ;; crashed the entire lambda! (error "compiler error -- variables-used-in-lexical-closures: ~s" tem)) (%LOGDPB 1 %%Q-BOXED-SIGN-BIT (CADR TEM)))))) *VARIABLES-USED-IN-LEXICAL-CLOSURES*))))) ;; Set up the debug info from the local declarations and other things (LET ((DEBUG-INFO ()) TEM) (AND DOCUMENTATION (PUSH `(DOCUMENTATION ,DOCUMENTATION) DEBUG-INFO)) (DOLIST (DCL LOCAL-DECLARATIONS) (WHEN (SYMBOLP (CAR DCL)) (SETQ TEM (GET (CAR DCL) 'SI::DEBUG-INFO)) (IF (AND (SYMBOLP TEM) (GET TEM 'SI::DEBUG-INFO)) (SETQ DCL (CONS TEM (CDR DCL)))) (UNLESS (ASSQ (CAR DCL) DEBUG-INFO) (PUSH DCL DEBUG-INFO)))) ;; Propagate any other kinds of debug info from the expr definition. (DOLIST (DCL EXPR-DEBUG-INFO) (UNLESS (ASSQ (CAR DCL) DEBUG-INFO) (PUSH DCL DEBUG-INFO))) (WHEN (PLUSP *BREAKOFF-COUNT*) ; local functions (LET ((INTERNAL-OFFSETS (MAKE-LIST *BREAKOFF-COUNT*))) (OUTF `(BREAKOFFS ,INTERNAL-OFFSETS)) (PUSH `(:INTERNAL-FEF-OFFSETS . ,INTERNAL-OFFSETS) DEBUG-INFO))) ;; Include the local and arg maps if we have them. ;; They were built by ASSIGN-LAP-ADDRESSES. (WHEN *LOCAL-MAP* (PUSH `(LOCAL-MAP ,*LOCAL-MAP*) DEBUG-INFO)) (WHEN *ARG-MAP* (PUSH `(ARG-MAP ,*ARG-MAP*) DEBUG-INFO)) (WHEN *LOCAL-FUNCTION-MAP* (PUSH `(LOCAL-FUNCTION-MAP ,(NREVERSE *LOCAL-FUNCTION-MAP*)) DEBUG-INFO)) (when *lexical-ref-code-name-alist* (push `(lexical-ref-map . , *lexical-ref-code-name-alist*) debug-info)) ;; Include list of macros used, if any. (WHEN MACROS-EXPANDED (LET ((MACROS-AND-SXHASHES (MAPCAR (LAMBDA (MACRONAME) (LET ((HASH (EXPR-SXHASH MACRONAME))) (IF (OR HASH (CONSP MACRONAME)) (LIST MACRONAME HASH) MACRONAME))) MACROS-EXPANDED))) (IF QC-FILE-RECORD-MACROS-EXPANDED (PROGN ;; If in QC-FILE, put just macro names in the function ;; but put the names and sxhashes into the file's list. (PUSH `(:MACROS-EXPANDED ,MACROS-EXPANDED) DEBUG-INFO) (DOLIST (M MACROS-AND-SXHASHES) (OR (SI:MEMBER-EQUAL M QC-FILE-MACROS-EXPANDED) (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA)) (PUSH (COPY-TREE M) QC-FILE-MACROS-EXPANDED))))) (PUSH `(:MACROS-EXPANDED ,MACROS-AND-SXHASHES) DEBUG-INFO)))) (AND (OR (EQ QC-TF-OUTPUT-MODE 'COMPILE-TO-CORE) SUBST-FLAG) (eq *host-computer* *target-computer*) ;||| smh 30sep88 (PUSH `(INTERPRETED-DEFINITION ,EXP) DEBUG-INFO)) (WHEN SUBST-FLAG ;; Added the next form ||| smh 30sep88 ;; Why must the lambda treat _everything_ as a special form?? (when (boundp '*compilation-environment*) (setf (gethash function-to-be-defined (compiler:compilation-environment-macro-hashtab compiler:*compilation-environment*)) exp)) (LET* ((ARGS-INFO (ARGS-INFO EXP)) (DUMMY-FORM (CONS 'FOO (MAKE-LIST (+ (LDB %%ARG-DESC-MAX-ARGS ARGS-INFO) (IF (LDB-TEST %ARG-DESC-EVALED-REST ARGS-INFO) 1 0)) :INITIAL-ELEMENT '(gensymbol "DUMMY"))))) ;;>> this somewhat bogous. The environment should be much hairier. Or should it? (UNLESS (WITH-LIST (ENV *FUNCTION-ENVIRONMENT*) ;;>> BULLSHIT. this cannot hope to work. sigh. (EQUAL (SI::SUBST-EXPAND EXP DUMMY-FORM ENV NIL) (SI::SUBST-EXPAND EXP DUMMY-FORM ENV T))) ;; If simple and thoughtful substitution give the same result ;; even with the most intractable arguments, ;; we need not use thoughtful substitution for this defsubst. ;; Otherwise, mark it as requiring thoughtful substitution. (PUSH '(:NO-SIMPLE-SUBSTITUTION T) DEBUG-INFO)))) ;; Compute the sxhash now, after all displacing macros have been displaced (AND MACROFLAG (eq *host-computer* *target-computer*) ;||| (I'm unsure about this one) - smh 30sep88 (PUSH `(:EXPR-SXHASH ,(FUNCTION-EXPR-SXHASH DEF-TO-BE-SXHASHED)) DEBUG-INFO)) ;; Added the next form ||| smh 30sep88 (when (and macroflag (boundp '*compilation-environment*)) (cross-define-a-macro function-to-be-defined exp)) ;; If we aren't going to mark this function as requiring a mapping ;; table, provide anyway some info that the user declared it wanted one. (AND SELF-FLAVOR-DECLARATION (NOT *SELF-REFERENCES-PRESENT*) (eq *host-computer* *target-computer*) ;||| (I'm unsure about this one) - smh 30sep88 (PUSH `(:SELF-FLAVOR ,(CAR SELF-FLAVOR-DECLARATION)) DEBUG-INFO)) (OUTF `(DEBUG-INFO . ,DEBUG-INFO))) (OUTF `PROGSA) (compiler-target-switch ;for LAMBDA, just goes to P2SBIND. (P2SBIND-FOR-TOPLEVEL LL *VARS* NIL)) ;Can compile initializing code (LET ((*LEXICAL-CLOSURE-COUNT* 0) (*highest-lexical-closure-disconnected* 0)) (compiler-target-switch (P2 EXP1 'D-RETURN))) ;Do pass 2 (LET* ((MXPDL (1+ MAXPDLLVL)) (APPARENT-MAXIMUM-TOTAL-PDL-FRAME-SIZE (+ MXPDL (LENGTH *LOCAL-MAP*) (LENGTH *ARG-MAP*)))) (OUTF `(PARAM MXPDL ,MXPDL)) (WHEN (> APPARENT-MAXIMUM-TOTAL-PDL-FRAME-SIZE 225.) (WARN 'PDL-FRAME-TOO-LARGE :fatal "PDL frame at runtime limited to 256. (225. for safety)")))) *ALLVARS*))) )) ; From modified file DJ: L.SYS; QCP1.LISP#737 at 30-Sep-88 16:27:49 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCP1  " (defun cross-define-a-macro (function-to-be-defined exp) (if (symbolp function-to-be-defined) (setf (gethash function-to-be-defined (compiler:compilation-environment-macro-hashtab compiler:*compilation-environment*)) exp) (progn (when (eq (first function-to-be-defined) ':property) (setq function-to-be-defined (cdr function-to-be-defined))) (setf (getf (gethash (first function-to-be-defined) (compiler:compilation-environment-plist-hashtab compiler:*compilation-environment*)) (second function-to-be-defined)) exp)))) ))