;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 126.8 ;;; Reason: ;;; Completely changes how definitions and declarations are maintained local to a file compilation, ;;; preparatory to providing real cross-compilation support. A new first-class object exists, called ;;; a COMPILATION-ENVIRONMENT. The variable COMPILER:*COMPILATION-ENVIRONMENT* can be bound to ;;; one of these. GETDECL and PUTDECL have been modified, and these vars no longer exist: ;;; FILE-LOCAL-DECLARATIONS, FILE-SPECIAL-LIST, FILE-UNSPECIAL-LIST. ;;; ;;; Also includes a couple K-compatibility customizations to QCP1. ;;; Written 2-Aug-88 16:54:50 by smh at site Gigamos Cambridge ;;; while running on Harpo from band 1 ;;; with ZWEI 125.9, ZMail 73.0, Local-File 75.1, File-Server 24.1, Unix-Interface 13.0, Tape 24.2, Lambda-Diag 17.0, Experimental System 126.7, microcode 1761, SDU Boot Tape 3.12, SDU ROM 102, 126.2 + k-sys. ; From modified buffer QCDEFS.LISP#> L.SYS; DJ: at 2-Aug-88 17:00:42 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCDEFS  " ;;; LOCAL-DECLARATIONS (on SYSTEM) is a list of local declarations. ;;; Each local declaration is a list starting with an atom which says ;;; what type of declaration it is. The meaning of the rest of the ;;; list depends on the type of declaration. ;;; The compiler is interested only in SPECIAL and UNSPECIAL declarations, ;;; for which the rest of the list contains the symbols being declared, ;;; and MACRO declarations, which look like (DEF symbol MACRO LAMBDA args ..body...), ;;; and ARGLIST declarations, which specify arglists to go in the debugging info ;;; (to override the actual arglist of the function, for user information) ;;; which look like (ARGLIST FOO &OPTIONAL BAR ...), etc. ;;; Things get onto LOCAL-DECLARATIONS in two ways: ;;; 1) inside a LOCAL-DECLARE, the specified declarations are bound onto the front. ;;; 2) if UNDO-DECLARATIONS-FLAG is T, some kinds of declarations ;;; in a file being compiled into a QFASL file ;;; are consed onto the front, and not popped off until LOCAL-DECLARATIONS ;;; is unbound at the end of the whole file. (DEFVAR-RESETTABLE LOCAL-DECLARATIONS NIL NIL "List of local declarations made by LOCAL-DECLARE or DECLARE. Each one is a list starting with a local declaration type, followed by more information meaningful according to that type.") (DEFVAR-RESETTABLE UNDO-DECLARATIONS-FLAG NIL NIL "T during file-to-file compilation, causes DEFMACRO and DEFSUBST to work differently. They store elements in *COMPILATION-ENVIRONMENT* rather than actually defining functions in the environment.") ;; COMPILATION-ENVIRONMENT implementation. -smh 1aug88 (defvar *compilation-environment* :unbound ;Bind me -- do not set me! "The compilation-environment in which compile-time definitions should be recorded.") (cl:defstruct (compilation-environment (:print-function (lambda (struct stream level) (ignore level) (printing-random-object (struct stream :type) (when (compilation-environment-target struct) (princ "for " stream) (prin1 (compilation-environment-target struct) stream)))))) (target nil :documentation "The *TARGET-COMPUTER* which this environment is for.") ;; The primary use for NEXT is to permit definitions local to a COMPILE-FILE to be stored ;; separately from the environment `in' which the COMPILE-FILE is happening. (next (and (boundp '*compilation-environment*) *compilation-environment*) :documentation "The enclosing environment") (plist-hashtab (make-hash-table :test #'equal) :documentation "Maps symbols onto property lists.") (macro-hashtab (make-hash-table :test #'equal) :documentation "Macro definitions.") ) (defmacro bind-compilation-environment-maybe (environment &body body) `(let-if (not (boundp 'w*compilation-environment*)) ((*compilation-environment* ,environment)) ,@body)) ;; The next three vars have been replaced by *COMPILATION-ENVIRONMENT*. -smh 1aug88 #+never (DEFVAR-RESETTABLE FILE-SPECIAL-LIST NIL NIL "List of symbols declared globally special in file being compiled.") #+never (DEFVAR-RESETTABLE FILE-UNSPECIAL-LIST NIL NIL "List of symbols declared globally unspecial in file being compiled.") ;;; FILE-LOCAL-DECLARATIONS is just like LOCAL-DECLARATIONS except that it is ;;; local to the file being compiled. The reason this exists is so that if ;;; you have a (LOCAL-DECLARE ((ARGLIST ...)) ...) around a (MACRO...), ;;; at compile-time the macro wants to be saved on LOCAL-DECLARATIONS, but that ;;; is bound by the LOCAL-DECLARE, so it uses FILE-LOCAL-DECLARATIONS instead. #+never (DEFVAR-RESETTABLE FILE-LOCAL-DECLARATIONS NIL NIL "Like LOCAL-DECLARATIONS for declarations at top level in file being compiled. However, SPECIAL and UNSPECIAL declarations are handled differently using FILE-SPECIALS and FILE-UNSPECIALS, for greater speed in SPECIALP.") )) ; From modified buffer QFCTNS.LISP#> L.SYS; DJ: at 2-Aug-88 17:06:19 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFCTNS  " (DEFspecialk MACRO ("E FUNCTION-SPEC &REST DEF) "Define FUNCTION-SPEC as a macro; this is the most primitive way. LAMBDA-LIST should specify one arg, which gets the whole form that is the macro call. BODY is what is evaluated to produce the expansion of the macro call. Example: (MACRO FIRST (FORM) `(CONS ,(CADR FORM))) Note that (CAR FORM) would be the symbol FIRST, since FORM is a call to the macro FIRST." (DECLARE (ARGLIST "E FUNCTION-SPEC LAMBDA-LIST &REST BODY)) (OR (SYMBOLP FUNCTION-SPEC) (SETQ FUNCTION-SPEC (STANDARDIZE-FUNCTION-SPEC FUNCTION-SPEC))) (AND UNDO-DECLARATIONS-FLAG (COMPILER:FUNCTION-REFERENCED-P FUNCTION-SPEC) (COMPILER:WARN 'MACRO-USED-BEFORE-DEFINED ':IMPOSSIBLE "The macro ~S was used before it was defined" FUNCTION-SPEC)) (SETQ DEF (PROCESS-DEFUN-BODY FUNCTION-SPEC DEF)) (SETQ DEF (CONS 'MACRO DEF)) ;; Put macro definition where it belongs (don't really define it if compiling) (COND ((AND (BOUNDP 'UNDO-DECLARATIONS-FLAG) UNDO-DECLARATIONS-FLAG) (IF (EQ (CAR-SAFE FUNCTION-SPEC) ':PROPERTY) (PUTDECL (CADR FUNCTION-SPEC) (CADDR FUNCTION-SPEC) DEF)) (setf (gethash function-spec (compiler:compilation-environment-macro-hashtab compiler:*compilation-environment*)) def) ;; (PUSH `(DEF ,FUNCTION-SPEC . ,DEF) FILE-LOCAL-DECLARATIONS) ) (T (FDEFINE FUNCTION-SPEC DEF T))) FUNCTION-SPEC) (DEFspecialk DEFF-MACRO ("E FUNCTION &EVAL DEFINITION) "Define FUNCTION with definition DEFINITION, which should be a subst or macro. If found in a file being compiled, this definition will be in effect during compilation as well as when the compiled file is loaded. That is how DEFF-MACRO differs from DEFF." (AND (BOUNDP 'UNDO-DECLARATIONS-FLAG) UNDO-DECLARATIONS-FLAG (COMPILER:FUNCTION-REFERENCED-P FUNCTION) (COMPILER:WARN 'MACRO-USED-BEFORE-DEFINED ':IMPOSSIBLE "The macro ~S was used before it was defined" FUNCTION)) ;; Put macro definition where it belongs (don't really define it if compiling) (COND ((AND (BOUNDP 'UNDO-DECLARATIONS-FLAG) UNDO-DECLARATIONS-FLAG) (WHEN (EQ (CAR-SAFE FUNCTION) ':PROPERTY) (PUTDECL (CADR FUNCTION) (CADDR FUNCTION) DEFINITION)) (setf (gethash function (compiler:compilation-environment-macro-hashtab compiler:*compilation-environment*)) definition) ;; (PUSH `(DEF ,FUNCTION . ,DEFINITION) FILE-LOCAL-DECLARATIONS) ) (T (FDEFINE FUNCTION DEFINITION T))) FUNCTION) )) ; From modified buffer QFCTNS.LISP#> L.SYS; DJ: at 2-Aug-88 17:06:54 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFCTNS  " (DEFUN DEFSUBST-1 (SYMBOL DEF) (OR (SYMBOLP SYMBOL) (SETQ SYMBOL (STANDARDIZE-FUNCTION-SPEC SYMBOL))) (AND UNDO-DECLARATIONS-FLAG (COMPILER:FUNCTION-REFERENCED-P SYMBOL) (COMPILER:WARN 'MACRO-USED-BEFORE-DEFINED ':IMPOSSIBLE "The defsubst ~S was used before it was defined" SYMBOL)) ;; Convert body into NAMED-SUBST, hacking declarations (SETQ DEF (CONS 'NAMED-SUBST (CDR (PROCESS-DEFUN-BODY SYMBOL DEF T)))) (DO ((PTR (CADDR DEF) (CDR PTR))) ((NULL PTR)) (LET ((ELT (CAR PTR))) (COND ((AND (MEMQ ELT LAMBDA-LIST-KEYWORDS) (NOT (MEMQ ELT '(&REST &OPTIONAL)))) (COND ((EQ ELT '&AUX) (SETQ DEF (LIST* (CAR DEF) (CADR DEF) (LDIFF (CADDR DEF) PTR) (CDDDR DEF)))) ((EQ ELT '&KEY) (SETQ DEF (LIST* (CAR DEF) (CADR DEF) (APPEND (LDIFF (CADDR DEF) PTR) '(&REST IGNORE)) (CDDDR DEF)))) (T (SETQ DEF (LIST* (CAR DEF) (CADR DEF) (REMQ ELT (CADDR DEF)) (CDDDR DEF))))) (IF UNDO-DECLARATIONS-FLAG (COMPILER:WARN 'BAD-DEFSUBST-KEYWORDS ':IMPOSSIBLE "The defsubst ~S uses the lambda-list keyword ~S" SYMBOL ELT) (FERROR "The defsubst ~S uses the lambda-list keyword ~S" SYMBOL ELT)))))) ;; Put macro definition where it belongs (don't really define it if compiling) (COND ((AND (BOUNDP 'UNDO-DECLARATIONS-FLAG) UNDO-DECLARATIONS-FLAG) (setf (gethash symbol (compiler:compilation-environment-macro-hashtab compiler:*compilation-environment*)) def) ;; (PUSH `(DEF ,SYMBOL . ,DEF) FILE-LOCAL-DECLARATIONS) ) (T (FDEFINE SYMBOL DEF T))) SYMBOL) )) ; From modified buffer QFCTNS.LISP#> L.SYS; DJ: at 2-Aug-88 17:07:49 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFCTNS  " ;;; Push a random declaration on for the duration of a file being compiled. (DEFUN PUTDECL (NAME PROP VALUE) "Executed while compiling a file, creates a compile-time property. Compile-time properties are accessed using GETDECL." ;; Theoretically, when not somewhere inside a COMPILE-FILE, i.e. when there is no ;; *COMPILATION-ENVIRONMENT* established, PUTDECL should not be called at all. ;; Unfortunately, certain obnoxious macros like DEFSTRUCT expand to ;; EVAL-WHEN-COMPILE DEFDECL forms, effectively solving a problem twice instead ;; instead of just once, thereby causing much grief. So we make PUTDECL do ;; the right thing if there is no *COMPILATION-ENVIRONMENT*. (if (boundp 'compiler:*compilation-environment*) ;; A more trusting loser might try to do this atomically without the intermediate ;; fetch of the whole plist. (let ((plist (gethash name (compiler:compilation-environment-plist-hashtab compiler:*compilation-environment*)))) (setf (getf plist prop) value) (setf (gethash name (compiler:compilation-environment-plist-hashtab compiler:*compilation-environment*)) plist)) (putprop name value prop))) ;;; Get either the current loaded definition or a property ;;; or the actual value of the property. (DEFUN GETDECL (NAME PROP) "GET, for macro expansion and compilation. Allows the actual property of NAME to be overridden by a local declaration (prop name value) such as PUTDECL or DEFDECL would create. NAME may be any symbol or function spec." (DOLIST (DECL LOCAL-DECLARATIONS) (AND (EQ (CAR DECL) PROP) (EQUAL (CADR DECL) NAME) (RETURN-from getdecl (CADDR DECL)))) (when (boundp 'compiler:*compilation-environment*) (do ((env compiler:*compilation-environment* (compiler:compilation-environment-next env))) ((null env)) (multiple-value-bind (val foundp) (gethash name (compiler:compilation-environment-plist-hashtab env)) (when foundp (setq val (getf val prop)) ;what about property of NIL ??? (when val (return-from getdecl val)))))) #+never (DOLIST (DECL FILE-LOCAL-DECLARATIONS) (AND (EQ (CAR DECL) PROP) (EQUAL (CADR DECL) NAME) (RETURN (CADDR DECL)))) (IF (SYMBOLP NAME) (GET NAME PROP) (FUNCTION-SPEC-GET NAME PROP))) (DEFUN DECLARED-DEFINITION (FUNCTION-SPEC &AUX DEF) "Return the definition of FUNCTION-SPEC for macro expansion purposes. This may be the actual definition, or it may be specified by a local declaration. If it is encapsulated, unencapsulate it." (SETQ DEF (OR (DOLIST (L LOCAL-DECLARATIONS) (AND (EQ (CAR L) 'DEF) (EQUAL (CADR L) FUNCTION-SPEC) ;Not EQ, might be a list (RETURN (CDDR L)))) (when (boundp 'compiler:*compilation-environment*) (do ((env compiler:*compilation-environment* (compiler:compilation-environment-next env)) tem) ((null env)) (when (setq tem (gethash function-spec (compiler:compilation-environment-macro-hashtab env))) (return tem)))) #+never (DOLIST (L FILE-LOCAL-DECLARATIONS) (AND (EQ (CAR L) 'DEF) (EQUAL (CADR L) FUNCTION-SPEC) ;Not EQ, might be a list (RETURN (CDDR L)))) (AND (FDEFINEDP FUNCTION-SPEC) (SETQ DEF (FDEFINITION FUNCTION-SPEC)) (COND ((ATOM DEF) DEF) ((EQ (CAR DEF) 'MACRO) DEF) (T (FDEFINITION (UNENCAPSULATE-FUNCTION-SPEC FUNCTION-SPEC))))))) (COND ((AND DEF (SYMBOLP DEF)) (DECLARED-DEFINITION DEF)) (T DEF))) )) ; From modified buffer QCP1.LISP#> L.SYS; DJ: at 2-Aug-88 17:11:47 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCP1  " ;;; Compile a function which already has an interpreted definition, ;;; or define it to a newly supplied definition's compilation. ;;; If the definition is one which is legal but cannot meaningfully ;;; be compiled, we just leave it unchanged. (DEFUN COMPILE (NAME &OPTIONAL LAMBDA-EXP (PROCESSING-MODE 'MACRO-COMPILE)) "Compile the definition of NAME, or its previous interpreted definition if it is already compiled. If LAMBDA-EXP is supplied, it is compiled and made the definition of NAME. If NAME is NIL, LAMBDA-EXP is compiled and the result is just returned." (IF (NULL NAME) (COMPILE-LAMBDA LAMBDA-EXP (gensymbol "ANON-FN")) (LOCKING-RESOURCES-NO-QFASL (FILE-OPERATION-WITH-WARNINGS (T ':COMPILE) (COMPILER-WARNINGS-CONTEXT-BIND (LET (TEM) (QC-PROCESS-INITIALIZE) (OR LAMBDA-EXP (AND (FDEFINEDP NAME) (SETQ TEM (FDEFINITION (SI:UNENCAPSULATE-FUNCTION-SPEC NAME))) (TYPECASE TEM (CONS (SETQ LAMBDA-EXP TEM)) (CLOSURE (IF (AND (FIND-PACKAGE "INTERPRETER") (BOUNDP-IN-CLOSURE TEM (INTERN "INTERPRETER-CLOSURE" "INTERPRETER")) (SYMEVAL-IN-CLOSURE TEM (INTERN "INTERPRETER-CLOSURE" "INTERPRETER"))) (SETQ LAMBDA-EXP (SYMEVAL-IN-CLOSURE TEM (INTERN "ORIGINAL-DEFINITION" "INTERPRETER"))) (FERROR "Compilation of closures not yet hacked."))) (COMPILED-FUNCTION (SETQ TEM (ASSQ 'INTERPRETED-DEFINITION (DEBUGGING-INFO TEM))) (SETQ LAMBDA-EXP (CADR TEM))) (T NIL))) (FERROR "Can't find LAMBDA expression for ~S" NAME)) (LET ((INHIBIT-FDEFINE-WARNINGS T)) (COMPILE-1 NAME LAMBDA-EXP PROCESSING-MODE)) NAME)))))) )) ; From modified buffer QCP1.LISP#> L.SYS; DJ: at 2-Aug-88 17:12:03 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCP1  " (DEFUN COMPILE-LAMBDA (LAMBDA-EXP &OPTIONAL NAME (PROCESSING-MODE 'MACRO-COMPILE)) "Compile the function LAMBDA-EXP and return a compiled-function object. That compiled function will record NAME as its name, but we do not actually define NAME." ; (AND QC-FILE-IN-PROGRESS ;Check for condition likely to cause temporary area lossage ; (FORMAT *ERROR-OUTPUT* "~&COMPILE: Compiler recursively entered, you may lose.~%")) (LOCKING-RESOURCES-NO-QFASL (FILE-OPERATION-WITH-WARNINGS (T ':COMPILE) (COMPILER-WARNINGS-CONTEXT-BIND (LET (TEM (INHIBIT-FDEFINE-WARNINGS T)) (QC-PROCESS-INITIALIZE) (COMPILE-1 `(:LOCATION ,(LOCF TEM)) LAMBDA-EXP PROCESSING-MODE NAME) TEM))))) )) ; From modified buffer QCP1.LISP#> L.SYS; DJ: at 2-Aug-88 17:12:11 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCP1  " (DEFUN COMPILE-LAMBDAS (LAMBDA-EXPS &OPTIONAL NAMES (PROCESSING-MODE 'MACRO-COMPILE)) "Compile the functions LAMBDA-EXPS and return a list of compiled-function objects. That compiled function will record NAME as its name, but we do not actually define NAME." (LOCKING-RESOURCES-NO-QFASL (FILE-OPERATION-WITH-WARNINGS (T ':COMPILE) (COMPILER-WARNINGS-CONTEXT-BIND (LET ((INHIBIT-FDEFINE-WARNINGS T)) (QC-PROCESS-INITIALIZE) (DO ((L1 LAMBDA-EXPS (CDR L1)) (L2 NAMES (CDR L2)) (RESULTS NIL)) ((NULL L1) (NREVERSE RESULTS)) (LET ((TEM NIL) (LAMBDA-EXP (CAR L1)) (NAME (CAR L2))) (COMPILE-1 `(:LOCATION ,(LOCF TEM)) LAMBDA-EXP PROCESSING-MODE NAME) (PUSH TEM RESULTS)))))))) )) ; From modified buffer QCP1.LISP#> L.SYS; DJ: at 2-Aug-88 17:12:41 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCP1  " (DEFUN EXPAND-KEYED-LAMBDA (LAMBDA-EXP) (LET (LAMBDA-LIST BODY MAYBE-REST-ARG KEYCHECKS PSEUDO-KEYNAMES) (IF (EQ (CAR LAMBDA-EXP) 'LAMBDA) (SETQ LAMBDA-LIST (CADR LAMBDA-EXP) BODY (CDDR LAMBDA-EXP)) (SETQ LAMBDA-LIST (CADDR LAMBDA-EXP) BODY (CDDDR LAMBDA-EXP))) ;named-lambda (MULTIPLE-VALUE-BIND (POSITIONAL-ARGS NIL AUXVARS REST-ARG nil KEYKEYS KEYNAMES KEYINITS KEYFLAGS ALLOW-OTHER-KEYS) (DECODE-KEYWORD-ARGLIST LAMBDA-LIST) (SETQ PSEUDO-KEYNAMES (COPY-LIST KEYNAMES)) (MULTIPLE-VALUE-BIND (NIL DECLS) (WITH-LIST (ENV *FUNCTION-ENVIRONMENT*) (EXTRACT-DECLARATIONS BODY NIL NIL ENV)) ;; For each keyword arg, decide whether we need to init it to KEYWORD-GARBAGE ;; and check explicitly whether that has been overridden. ;; If the arg is optional ;; and the initial value is a constant, we can really init it to that. ;; Otherwise we create a dummy variable initialized to KEYWORD-GARBAGE; ;; after all keywords are decoded, we bind the intended variable, in sequence. ;; However a var that can shadow something (including any special var) ;; must always be replaced with a dummy. (DO ((KIS KEYINITS (CDR KIS)) (KNS KEYNAMES (CDR KNS)) (PKNS PSEUDO-KEYNAMES (CDR PKNS)) (KFS KEYFLAGS (CDR KFS))) ((NULL KNS)) (LET ((KEYNAME (CAR KNS)) PSEUDO-KEYNAME (KEYFLAG (CAR KFS)) (KEYINIT (CAR KIS))) (OR (AND (NULL KEYFLAG) (CONSTANTP KEYINIT) (NOT (find KEYNAME *VARS* :key #'var-name)) (NOT (LEXICAL-VAR-P KEYNAME)) (NOT (SPECIALP KEYNAME))) (PROGN (SETF (CAR KIS) 'SI::KEYWORD-GARBAGE) (SETQ PSEUDO-KEYNAME (gensymbol keyname)) (SETF (CAR PKNS) PSEUDO-KEYNAME) (PUSH `(,KEYNAME (COND ((EQ ,PSEUDO-KEYNAME SI::KEYWORD-GARBAGE) ,KEYINIT) (T ,(AND KEYFLAG `(SETQ ,KEYFLAG T)) ,PSEUDO-KEYNAME))) KEYCHECKS))))) (SETQ KEYFLAGS (REMQ NIL KEYFLAGS)) (SETQ KEYCHECKS (NREVERSE KEYCHECKS)) ;; If the user didn't ask for a rest arg, make one for the ;; outer function anyway. (OR REST-ARG (SETQ REST-ARG (gensymbol "REST") MAYBE-REST-ARG (LIST '&REST REST-ARG))) `(LAMBDA (,@POSITIONAL-ARGS ,@MAYBE-REST-ARG) (DECLARE . ,DECLS) (LET* (,@(MAPCAR (LAMBDA (V INIT) `(,V ,INIT)) PSEUDO-KEYNAMES KEYINITS) ,@KEYFLAGS) (DECLARE . ,DECLS) ; (COND ((EQ (CAR ,REST-ARG) 'PERMUTATION-TABLE) ; (OR (%PERMUTE-ARGS) ; (PROGN (RECOMPUTE-KEYWORD-PERMUTATION-TABLE ; (CDR ,REST-ARG) ; (%P-CONTENTS-OFFSET (%STACK-FRAME-POINTER) %LP-FEF) ; ',KEYKEYS) ; (%PERMUTE-ARGS))) ; ;; If the function really wants the rest arg, ; ;; flush the permutation table and its keyword. ; ,(AND (NOT MAYBE-REST-ARG) `(SETQ ,REST-ARG (CDDR ,REST-ARG)))) ; (T ,(case *target-computer* (k (generate-k-keyword-args-decode pseudo-keynames rest-arg keykeys allow-other-keys)) (otherwise `(WHEN ,REST-ARG (SI::STORE-KEYWORD-ARG-VALUES ;; kludgey-compilation-variable-location is just like ;; variable-location except that it doesn't increment ;; the var-use-count of its arg (KLUDGEY-COMPILATION-VARIABLE-LOCATION ,(CAR PSEUDO-KEYNAMES)) ,REST-ARG ',KEYKEYS ,ALLOW-OTHER-KEYS)))) (LET* ,KEYCHECKS (DECLARE . ,DECLS) ((LAMBDA ,AUXVARS . ,BODY))))))))) )) ; From modified buffer QCP1.LISP#> L.SYS; DJ: at 2-Aug-88 17:12:55 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCP1  " (DEFUN (:PROPERTY KLUDGEY-COMPILATION-VARIABLE-LOCATION P1) (FORM &AUX TEM TEM1) (SETQ FORM (CADR FORM)) (SETQ TEM (COND ((SETQ TEM1 (find FORM *VARS* :key #'var-name)) (AND (EQ (VAR-KIND TEM1) 'FEF-ARG-FREE) (ZEROP (VAR-USE-COUNT TEM1)) (PUSH (VAR-NAME TEM1) *FREEVARS*)) (VAR-LAP-ADDRESS TEM1)) ((SPECIALP FORM) FORM) (T (BARF FORM "Lossage in keyed-lambda compilation")))) (cond ((SYMBOLP TEM) `(%EXTERNAL-VALUE-CELL ',TEM)) (t (when (eq *target-computer* 'k) (case (first tem) (local-ref (push 'variable-location (var-misc (second tem)))))) `(VARIABLE-LOCATION ,TEM)))) )) ; From modified buffer QCP1.LISP#> L.SYS; DJ: at 2-Aug-88 17:13:26 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCP1  " (DEFUN COMPILER-OPTIMIZE-EXTERNAL (FORM) "Binds top level variables needed by compiler-optimize" (LOCKING-RESOURCES-NO-QFASL (FILE-OPERATION-WITH-WARNINGS (T ':COMPILE) (COMPILER-WARNINGS-CONTEXT-BIND (QC-PROCESS-INITIALIZE) (LET ((QC-TF-OUTPUT-MODE 'COMPILE-TO-CORE) (*FUNCTION-ENVIRONMENT* NIL) (LOCAL-DECLARATIONS NIL) (INHIBIT-STYLE-WARNINGS-SWITCH NIL)) (COMPILER-OPTIMIZE FORM)))))) )) ; From modified buffer QCP1.LISP#> L.SYS; DJ: at 2-Aug-88 17:14:25 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCP1  " (DEFUN SPECIALP (SYMBOL) ;; Do this test because I am not convinced that the compiler ;; won't break if we *really* look at the declarations. (if (not *inherit-special-declarations?*) (eq (find-type symbol this-frame-declarations) 'fef-special) (DOLIST (DECL LOCAL-DECLARATIONS ;; Here if no local declaration says anything. ;; Try FILE-(UN)SPECIAL-LIST which reflect global decls in the file. ;; Now uses *COMPILATION-ENVIRONMENT* -smh 1aug88 (OR (getdecl SYMBOL 'special) ALL-SPECIAL-SWITCH (GET SYMBOL 'SPECIAL) (GET SYMBOL 'SYSTEM-CONSTANT) (MEMQ SYMBOL BARF-SPECIAL-LIST))) (AND (MEMQ (CAR DECL) '(SPECIAL UNSPECIAL)) (MEMQ SYMBOL (CDR DECL)) (RETURN (EQ (CAR DECL) 'SPECIAL)))))) )) ; From modified buffer QCP1.LISP#> L.SYS; DJ: at 2-Aug-88 17:14:40 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCP1  " (DEFUN FIND-TYPE (SYMBOL THIS-FRAME-DECLARATIONS &AUX LOSE) (DOLIST (DECL THIS-FRAME-DECLARATIONS) (AND (MEMQ (CAR DECL) '(SPECIAL UNSPECIAL)) (MEMQ SYMBOL (CDR DECL)) (RETURN-FROM FIND-TYPE (IF (EQ (CAR DECL) 'SPECIAL) 'FEF-SPECIAL 'FEF-LOCAL)))) (DOLIST (DECL LOCAL-DECLARATIONS) (AND (MEMQ (CAR DECL) '(SPECIAL UNSPECIAL)) (MEMQ SYMBOL (CDR DECL)) (IF (EQ (CAR DECL) 'SPECIAL) (RETURN-FROM NIL (SETQ LOSE T)) (RETURN-FROM FIND-TYPE 'FEF-LOCAL)))) #+never (IF (OR (MEMQ SYMBOL FILE-SPECIAL-LIST) (AND (NOT (MEMQ SYMBOL FILE-UNSPECIAL-LIST)) (OR ALL-SPECIAL-SWITCH (GET SYMBOL 'SPECIAL) (GET SYMBOL 'SYSTEM-CONSTANT) (MEMQ SYMBOL BARF-SPECIAL-LIST)))) (RETURN-FROM FIND-TYPE 'FEF-SPECIAL)) (IF (OR (getdecl SYMBOL 'special) ALL-SPECIAL-SWITCH (GET SYMBOL 'SPECIAL) (GET SYMBOL 'SYSTEM-CONSTANT) (MEMQ SYMBOL BARF-SPECIAL-LIST)) (RETURN-FROM FIND-TYPE 'FEF-SPECIAL)) (IF (or (not *inherit-special-declarations?*) (NOT LOSE)) 'FEF-LOCAL (WARN 'INHERITED-SPECIAL-DECLARATION :OBSOLETE "A local SPECIAL declaration for ~S is being inherited. The declaration should be at the beginning of the construct that binds the variable. It still works now, but fix it quickly before it stops working." SYMBOL) 'FEF-SPECIAL)) )) ; From modified buffer QCP1.LISP#> L.SYS; DJ: at 2-Aug-88 17:15:46 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCP1  " (DEFUN P1LAMBDA (LAMBDA ARGS) (LET (ARGLIST BODY ARGS1 OPTIONAL PROGVARS VAR QUOTEFLAG SPECIAL-FLAG SPECIAL-VARS UNSPECIAL-FLAG UNSPECIAL-VARS KEYCHECKS BORDER-VARIABLE PSEUDO-KEYNAMES) (SETQ LAMBDA (SI::LAMBDA-EXP-ARGS-AND-BODY (P1AUX LAMBDA))) (SETQ ARGLIST (CAR LAMBDA) BODY (CDR LAMBDA)) (MULTIPLE-VALUE-BIND (NIL NIL NIL REST-ARG NIL KEYKEYS KEYNAMES KEYINITS KEYFLAGS ALLOW-OTHER-KEYS) (DECODE-KEYWORD-ARGLIST ARGLIST) (WHEN (AND KEYNAMES (NOT REST-ARG)) (SETQ REST-ARG (gensymbol "REST"))) (SETQ ARGS1 ARGS) (DO ((ARGLIST1 ARGLIST (CDR ARGLIST1))) (NIL) (SETQ VAR (CAR ARGLIST1)) (COND ((NULL ARGLIST1) (RETURN T)) ((EQ VAR '&KEY) (PUSH (LIST REST-ARG `(LIST . ,ARGS1)) PROGVARS) (RETURN (SETQ ARGS1 NIL))) ((EQ VAR '&REST) (POP ARGLIST1) (PUSH (LIST (CAR ARGLIST1) `(LIST . ,ARGS1)) PROGVARS) (RETURN (SETQ ARGS1 NIL))) ((EQ VAR '&OPTIONAL) (SETQ OPTIONAL T)) ;; soon to be obsolete ((EQ VAR '"E) (SETQ QUOTEFLAG T)) ;; soon to be obsolete ((EQ VAR '&EVAL) (SETQ QUOTEFLAG NIL)) ((EQ VAR '&SPECIAL) (warn 'obsolete-lambda-list-keyword :obsolete "~~S in lambda-lists is obsolete and will not be supported in the future.~% ~ Use the ~S declaration.~" '&special 'special) (SETQ SPECIAL-FLAG T UNSPECIAL-FLAG NIL)) ((EQ VAR '&LOCAL) (warn 'obsolete-lambda-list-keyword :obsolete "~~S in lambda-lists is obsolete and will not be supported in the future.~% ~ Use the ~S declaration.~" '&special 'unspecial) (SETQ SPECIAL-FLAG NIL UNSPECIAL-FLAG T)) ;; soon also to be obsolete ((EQ VAR '&FUNCTIONAL)) ((MEMQ VAR LAMBDA-LIST-KEYWORDS) (WARN 'BAD-INTERNAL-LAMBDA-KEYWORD :IMPOSSIBLE "~S is not supported in internal lambdas." VAR)) (T (AND SPECIAL-FLAG (PUSH VAR SPECIAL-VARS)) (AND UNSPECIAL-FLAG (PUSH VAR UNSPECIAL-VARS)) (COND ((SYMBOLP VAR) (PUSH (LIST VAR (IF QUOTEFLAG `',(CAR ARGS1) (CAR ARGS1))) PROGVARS)) (T (UNLESS (NOT OPTIONAL) (WARN 'BAD-ARGUMENT-LIST :IMPOSSIBLE "The mandatory argument ~S of an internal lambda ~ was given a default value." (CAR VAR))) (PUSH (LIST (CAR VAR) (IF ARGS1 (IF QUOTEFLAG `',(CAR ARGS1) (CAR ARGS1)) (CADR VAR))) PROGVARS))) (POP ARGS1)))) (WHEN KEYNAMES (SETQ PSEUDO-KEYNAMES (COPY-LIST KEYNAMES)) ;; For each keyword arg, decide whether we need to init it to KEYWORD-GARBAGE ;; and check explicitly whether that has been overridden. ;; If the initial value is a constant, we can really init it to that. ;; Otherwise we create a dummy variable initialized to KEYWORD-GARBAGE; ;; after all keywords are decoded, we bind the intended variable, in sequence. ;; However a var that can shadow something (including any special var) ;; must always be replaced with a dummy. (DO ((KIS KEYINITS (CDR KIS)) (KNS KEYNAMES (CDR KNS)) (PKNS PSEUDO-KEYNAMES (CDR PKNS)) (KFS KEYFLAGS (CDR KFS))) ((NULL KNS)) (LET ((KEYNAME (CAR KNS)) PSEUDO-KEYNAME (KEYFLAG (CAR KFS)) (KEYINIT (CAR KIS))) (OR (AND (NULL KEYFLAG) (CONSTANTP KEYINIT) (NOT (find KEYNAME *VARS* :key #'var-name)) (NOT (LEXICAL-VAR-P KEYNAME)) (NOT (SPECIALP KEYNAME))) (PROGN (SETF (CAR KIS) 'SI::KEYWORD-GARBAGE) (SETQ PSEUDO-KEYNAME (gensymbol keyname)) (SETF (CAR PKNS) PSEUDO-KEYNAME) (PUSH `(,KEYNAME (COND ((EQ ,PSEUDO-KEYNAME SI::KEYWORD-GARBAGE) ,KEYINIT) (T ,(AND KEYFLAG `(SETQ ,KEYFLAG T)) ,PSEUDO-KEYNAME))) KEYCHECKS))))) (SETQ KEYFLAGS (REMQ NIL KEYFLAGS)) (SETQ KEYCHECKS (NREVERSE KEYCHECKS)) ;; BORDER-VARIABLE is a local we put in the binding list ;; as the easiest way of being able to get a locative to the ;; slot before the first of our keyword arg locals. (SETQ BORDER-VARIABLE (gensymbol "KEYWORDS-LOC")) (SETQ BODY `((LET* (,BORDER-VARIABLE ,@(MAPCAR (LAMBDA (V INIT) `(,V ,INIT)) PSEUDO-KEYNAMES KEYINITS) ,@KEYFLAGS) (DECLARE (IGNORE ,BORDER-VARIABLE)) ,(case *target-computer* (k (generate-k-keyword-args-decode pseudo-keynames rest-arg keykeys allow-other-keys)) (otherwise `(WHEN ,REST-ARG (SI::STORE-KEYWORD-ARG-VALUES-INTERNAL-LAMBDA (KLUDGEY-COMPILATION-VARIABLE-LOCATION ,BORDER-VARIABLE) ,REST-ARG ',KEYKEYS ,ALLOW-OTHER-KEYS)))) (LET* ,KEYCHECKS . ,BODY))))) ;; Take all DECLAREs off the body and put them on DECLS. (MULTIPLE-VALUE-BIND (BODY DECLS) (with-list (env *function-environment*) (EXTRACT-DECLARATIONS-RECORD-MACROS BODY NIL NIL env)) (WHEN SPECIAL-VARS (PUSH `(SPECIAL . ,SPECIAL-VARS) DECLS)) (WHEN UNSPECIAL-VARS (PUSH `(UNSPECIAL . ,UNSPECIAL-VARS) DECLS)) (WHEN DECLS (PUSH `(DECLARE . ,DECLS) BODY)) (P1 `(LET-FOR-LAMBDA ,(NRECONC PROGVARS (IF ARGS1 `((IGNORE (PROGN . ,ARGS1))))) . ,BODY)))))) )) ; From modified buffer TYPES.LISP#> L.SYS; DJ: at 2-Aug-88 17:50:13 #10R SYSTEM-INTERNALS#: #!:CL (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; TYPES  " (defmacro deftype (name arglist &body body) "Defines NAME as a data type name for use in TYPEP, etc. A list starting with NAME, used as a type specifier, expands by binding the args in ARGLIST and then evaluating the BODY. The value of BODY should be another type specifier. Any optional arguments in ARGLIST which do not have default values specified will be bound to * by default, rather than NIL." (check-type name symbol) (cond ((memq name *standard-system-type-specifiers*) (ferror "~~S is the name of a standard type specifier used by the system. Redefining it would probably break the world.~" name)) ((or (getdecl name 'defstruct-description) (getdecl name 'si::flavors) #+never (let ((tem (assq 'si::flavors file-local-declarations))) (and tem (get tem name))) (get name 'si::flavor)) (cerror "Yes, please. I want to lose. ~S ~S anyway" "~*~S is already the name of a ~:[flavor~;structure~] ~\(~S ~S ...) will cause (~S foo '~S) not to recognize existing ~:[instances of that flavor~;structures of that type~] in new code, ~ but not affect (~S foo '~S)~%in existing compiled code. You may lose!~" 'deftype name (getdecl name 'defstruct-description) 'deftype name 'typep name (getdecl name 'defstruct-description) 'typep name))) (let ((argcopy (copy-list arglist)) optionalf doc) (if (stringp (car body)) (setq doc (car body))) (do ((tail argcopy (cdr tail))) ((null tail)) (cond ((eq (car tail) '&optional) (setq optionalf t)) ((memq (car tail) '(&key &rest &aux)) (return)) ((and optionalf (atom (car tail)) (not (memq (car tail) lambda-list-keywords))) (setf (car tail) `(,(car tail) '*))))) `(progn (eval-when (load eval) (si:record-source-file-name ',name 'deftype) (clear-cached-subtype-info ',name) (defun (:property ,name type-expander) ,argcopy . ,body) (remprop ',name 'type-alias-for) (setf (documentation ',name 'type) ',doc)) (eval-when (compile) (putdecl ',name (function (lambda ,argcopy . ,body)) 'type-expander)) ',name))) )) ; From modified buffer TYPES.LISP#> L.SYS; DJ: at 2-Aug-88 17:51:23 #10R SYSTEM-INTERNALS#: #!:CL (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; TYPES  " (defun type-canonicalize-1 (typespec record-dependencies dependencies &aux tem) (macrolet ((record-dependency (x) `(if record-dependencies (pushnew ,x dependencies :test #'eq))) (type-canonicalize-2 (x) `(multiple-value-setq (nil dependencies) (type-canonicalize ,x record-dependencies dependencies)))) (flet ((find-tail-of-same-type (y list &aux x) (setq x (if (consp y) (car y) y)) (unless (memq x '(and or not cl:member zl:member satisfies)) (do ((z list (cdr z))) ((null z)) (when (or (eq (car z) x) (eq (caar-safe z) x)) (return z)))))) (values (block canon (cond ((symbolp typespec) (cond ((memq typespec *standard-system-type-specifiers*) (cond ((get typespec 'type-alias-for)) ((setq tem (get typespec 'type-expander)) (funcall tem)) (t typespec))) ((setq tem (get typespec 'type-alias-for)) ;;(record-dependency typespec) (type-canonicalize-2 tem)) ((setq tem (getdecl typespec 'type-expander)) (record-dependency typespec) (type-canonicalize-2 (funcall tem))) ;;>> trace aliases? ((getdecl typespec 'si:flavor) typespec) ((getdecl typespec 'defstruct-description) typespec) ((get typespec 'si:flavor) typespec) (t (throw 'invalid-type-specifier "~S is not a known type specifier")))) ((and (consp typespec) (symbolp (car typespec))) (do-forever (unless (setq tem (get (car typespec) 'type-alias-for)) (return)) ;;(record-dependency tem) (setq typespec `(,tem . ,(cdr typespec)))) (case (car typespec) (or (do ((tail (cdr typespec) (cdr tail)) elt (frobs nil)) ((null tail) (cond ((cdr frobs) `(or . ,(nreverse frobs))) ;; (or foo) => foo (frobs (car frobs)) ;; (or) => t (t t))) (setq elt (type-canonicalize-2 (car tail))) (case (if (consp elt) (car elt) elt) (or (setq tail (append elt (cdr tail)))) ((t) (setq dependencies nil) (return-from canon t)) ((nil)) ;splice out NIL's (t (if (setq tem (find-tail-of-same-type elt frobs)) (cond ((atom (car tem))) ;; (or (foo bar baz) foo) => foo ((atom elt) (setf (car tem) elt)) (t (push elt frobs))) (push elt frobs)))))) (and (do ((tail (cdr typespec) (cdr tail)) elt (frobs nil)) ((null tail) (cond ((cdr frobs) `(and . ,(nreverse frobs))) (t (car frobs)))) (setq elt (type-canonicalize-2 (car tail))) (case (if (consp elt) (car elt) elt) (and (setq tail (append elt (cdr tail)))) ((nil) (setq dependencies nil) (return-from canon nil)) ((t)) (t (if (setq tem (find-tail-of-same-type elt frobs)) (cond ((atom (car tem)) (setf (car tem) elt)) ((atom elt)) (t (push elt frobs))) (push elt frobs)))))) (not (let ((z (type-canonicalize-2 (cadr typespec)))) (if (eq (car-safe z) 'not) (cadr z) `(not ,z)))) (t (cond ((dolist (elt (cdr typespec) t) (unless (eq elt '*) (return nil))) ;; (foo * * *) => foo (type-canonicalize-2 (car typespec))) ((setq tem (getdecl (car typespec) 'type-expander)) (record-dependency (car typespec)) (apply tem (cdr typespec))) ((setq tem (get (car typespec) 'type-canonicalizer)) (multiple-value-setq (nil dependencies) (apply tem record-dependencies dependencies typespec (cdr typespec)))) ((memq (car typespec) *standard-system-type-specifiers*) (throw 'invalid-type-specifier ;; Yow! Can I reimplement lisp primitives using FORMAT? "The type specifier ~1{~S~:} may not be used with \"arguments\"")) (t (throw 'invalid-type-specifier "~1{~S~:} is not a known type specifier")))))) (t (throw 'invalid-type-specifier "~S cannot be a type specifier!")))) dependencies)))) )) ; From modified buffer TYPES.LISP#> L.SYS; DJ: at 2-Aug-88 17:51:56 #10R SYSTEM-INTERNALS#: #!:CL (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; TYPES  " (defun typep-two-args (form &aux type) (cond ((and (= (length form) 3) (self-evaluating-p (caddr form))) (condition-case (error) (progn (setq type (if (consp (caddr form)) (cadr (caddr form)) ;(typep foo ':bar) (caddr form))) ;(typep foo :bar) (flet ((frob (type &aux tem) (if (and (symbolp type) (setq tem (get type 'type-optimizer))) (funcall tem form) (if (and (symbolp type) (setq tem (get type 'type-alias-for))) `(typep ,(cadr form) ',tem) (cond ((symbolp type) (cond ((setq tem (get type 'type-optimizer)) (funcall tem form)) ((and (setq tem (get type 'type-predicate)) (symbolp tem)) `(,tem ,(cadr form))) ((setq tem (or (rassq type type-of-alist) (rassq type typep-one-arg-alist))) `(eq (%data-type ,(cadr form)) ,(car tem))) ((getdecl type 'si::defstruct-description) `(typep-structure-or-flavor . ,(cdr form))) ;; defflavor is so nauseating... ((setq tem (or (getdecl type 'si:flavor) (get type 'si:flavor))) ;; this is from get-flavor-tracing-aliases ;; let's hear it for modularity... (if (flavor-get tem :alias-flavor) (setq type (car (dont-optimize (flavor-depends-on tem)))) (setq type tem)) `(typep-structure-or-flavor ,(cadr form) ',(dont-optimize (flavor-name type)))) ; ((class-symbolp type) ; `(subinstance-of-class-symbol-p ,(cadr form) ; ',type)) (t form))) (t (let ((typecar (get (car type) 'type-alias-for (car type)))) (cond ((setq tem (get typecar 'type-optimizer)) (apply tem form (cdr type))) ((and (setq tem (get typecar 'type-predicate)) (symbolp tem)) `(,tem ,(cadr form))) (t form))))))))) (let ((tem (frob type))) (cond ((not (equal tem form)) tem) (t (setq form (frob (type-canonicalize type nil nil))) tem))))) (error (compiler::warn 'compiler::bad-type-specification :implausible "Error expanding type specification ~S for ~S:~% ~A" (caddr form) 'typep error) form))) ((cdddr form) (compiler::warn 'compiler::bad-type-specification :implausuble "~S is a malformed type-specification" (cddr form)) form) (t form))) )) ; From modified buffer LTOP.LISP#> L.SYS; DJ: at 2-Aug-88 17:53:30 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; LTOP  " (DEFUN LISP-REINITIALIZE (&OPTIONAL (CALLED-BY-USER T) &AUX (COLD-BOOT *COLD-BOOTING*)) "Resets various global constants and initializes the error system." (unless called-by-user (unclosurebind 'inhibit-scheduling-flag 'default-cons-area) ;; Flush any likely losing closure binding forwarding pointers ;; left around from a closure we were in when we warm booted. (UNCLOSUREBIND 'PRIN1 'SELF '*PACKAGE* '*READTABLE*)) (SETQ INHIBIT-SCHEDULING-FLAG T) ;In case called by the user (SETQ DEFAULT-CONS-AREA WORKING-STORAGE-AREA) ;; these are defvar-resettabled too late for the cold-load, since things use getdecl (setq local-declarations nil ;; file-local-declarations nil compiler::qc-file-in-progress nil undo-declarations-flag nil eh::condition-resume-handlers nil eh::condition-handlers nil eh::condition-default-handlers nil) ;; This is ok to do asap since it doesn't do any evaluation. (when (not cold-boot) ;>> Not sure if this is right. (dolist (x *boot-reset-values*) (unless called-by-user (unclosurebind (car x))) (set (car x) (cdr x)))) (unless called-by-user (unclosurebind 'zwei::*local-variables* 'zwei::*local-bound-variables*) (when (variable-boundp zwei::*local-bound-variables*) (apply #'unclosurebind zwei::*local-bound-variables*)) (when (variable-boundp *default-process-closure-variables*) (apply #'unclosurebind *default-process-closure-variables*))) (UNLESS (GET 'CDR-NIL 'SYSTEM-CONSTANT) (MAPC (LAMBDA (Y) (MAPC (LAMBDA (X) (OR (GET X 'SYSTEM-CONSTANT) (SETF (GET X 'SYSTEM-CONSTANT) T))) (SYMBOL-VALUE Y))) SYSTEM-CONSTANT-LISTS) (MAPC (LAMBDA (Y) (MAPC (LAMBDA (X) (OR (GET X 'SPECIAL) (SETF (GET X 'SPECIAL) T))) (SYMBOL-VALUE Y))) SYSTEM-VARIABLE-LISTS) (PUTPROP T T 'SYSTEM-CONSTANT) (PUTPROP T T 'SPECIAL) (PUTPROP NIL T 'SYSTEM-CONSTANT) (PUTPROP NIL T 'SPECIAL)) (SELECT-PROCESSOR (:EXPLORER (SETQ TV::TV-QUAD-SLOT #xf5) (SETQ RG-QUAD-SLOT NIL) (SETQ SDU-QUAD-SLOT NIL) (setq video-board-type :explorer) ) (:LAMBDA (setq rg-quad-slot (%lambda-rg-quad-slot)) (setq sdu-quad-slot (%lambda-sdu-quad-slot)) (let ((tv (%lambda-tv-quad-slot))) (case (ldb (byte 8 8) tv) ((0 1) (setq tv::tv-quad-slot (ldb (byte 8 0) tv)) (setq video-board-type :vcmem)) (2 (setq video-board-type :quad) (setq quad-video-control-virtual-address (lsh (ash 177277400 -1) 1))) (t (ferror "bad video board type"))))) (:CADR (SETQ TV::TV-QUAD-SLOT nil) (SETQ RG-QUAD-SLOT NIL) (SETQ SDU-QUAD-SLOT NIL) (setq video-board-type :cadr))) ;;; This section below causes DISK-RESTORE and DISK-SAVE to fail. The microcode ;;; that refers to AMEM-EVCP-VECTOR has all been commented out (previous to this) ;;; and the LMM says that AMEM-EVCP-VECTOR is obsolete. --mrc ; ;; Provide ucode with space to keep EVCPs stuck into a-memory locations ; ;; by closure-binding the variables that forward there. ; (UNLESS (AND (BOUNDP 'AMEM-EVCP-VECTOR) AMEM-EVCP-VECTOR) ; (SETQ AMEM-EVCP-VECTOR ; (MAKE-ARRAY (+ (LENGTH A-MEMORY-LOCATION-NAMES) #o100 #o20) ; ;; in case ucode grows. ; :AREA PERMANENT-STORAGE-AREA))) (UNLESS CALLED-BY-USER (AND (FBOUNDP 'COMPILER::MA-RESET) ;Unload microcompiled defs, because they are gone! (COMPILER::MA-RESET)) ; Hopefully manage to do this before any gets called. ;; Set up the TV sync program as soon as possible; until it is set up ;; read references to the TV buffer can get NXM errors which cause a ;; main-memory parity error halt. Who-line updating can do this. (TV::INITIALIZE-RUN-LIGHT-LOCATIONS) ;; Clear all the bits of the main screen after a cold boot. (AND COLD-BOOT (CLEAR-SCREEN-BUFFER IO-SPACE-VIRTUAL-ADDRESS))) ;; Do something at least if errors occur during loading (OR (FBOUNDP 'FERROR) (FSET 'FERROR #'FERROR-COLD-LOAD)) (OR (FBOUNDP 'CERROR) (FSET 'CERROR #'CERROR-COLD-LOAD)) (OR (FBOUNDP 'UNENCAPSULATE-FUNCTION-SPEC) (FSET 'UNENCAPSULATE-FUNCTION-SPEC (LAMBDA (X) X))) (OR (FBOUNDP 'FS::MAKE-PATHNAME-INTERNAL) (FSET 'FS::MAKE-PATHNAME-INTERNAL #'LIST)) (OR (FBOUNDP 'FS::MAKE-FASLOAD-PATHNAME) (FSET 'FS::MAKE-FASLOAD-PATHNAME #'LIST)) ;; defined is in sys2;gc However, we need this stuff far earlier than that. (or (variable-boundp gc::*gc-flip-generations*) ;; used by the hasharrays before gc is loaded (setq gc::*gc-flip-generations* (make-array 4 :initial-element 0 :area control-tables))) ;; used by expansions of gc:without-flipping and gc:without-scavenging (or (fboundp 'gc::without-flipping-internal) (fset 'gc::without-flipping-internal 'funcall)) (or (fboundp 'gc::without-scavenging-internal) (fset 'gc::without-scavenging-internal 'funcall)) ;; Allow streams to work before WHOLIN loaded (OR (BOUNDP 'TV::WHO-LINE-FILE-STATE-SHEET) (SETQ TV::WHO-LINE-FILE-STATE-SHEET 'IGNORE)) (NUMBER-GC-ON) ;This seems to work now, make it the default (UNLESS (VARIABLE-BOUNDP *PACKAGE*) (PKG-INITIALIZE)) (SETQ *PACKAGE* PKG-USER-PACKAGE) ;; initialize the reader ;; Get the right readtable. (unless (variable-boundp initial-readtable) (setq initial-readtable *readtable* *readtable* (copy-readtable *readtable*) standard-readtable *readtable*) (setf (rdtbl-names *readtable*) (rdtbl-names initial-readtable)) (setq initial-common-lisp-readtable common-lisp-readtable common-lisp-readtable (copy-readtable common-lisp-readtable)) (setf (rdtbl-names common-lisp-readtable) (rdtbl-names initial-common-lisp-readtable)) (setq *all-readtables* (list *readtable* common-lisp-readtable))) ;; initialize the printer (unless (boundp 'prin1) (setq prin1 nil)) (WHEN (NOT (BOUNDP 'CURRENT-PROCESS)) ;Very first time around (SETQ SCHEDULER-EXISTS NIL CURRENT-PROCESS NIL TV::WHO-LINE-PROCESS NIL TV::LAST-WHO-LINE-PROCESS NIL) (UNLESS (FBOUNDP 'TV::WHO-LINE-RUN-STATE-UPDATE) (FSET 'TV:WHO-LINE-RUN-STATE-UPDATE (LAMBDA (&REST IGNORE) NIL)))) (SETQ TV::KBD-LAST-ACTIVITY-TIME (TIME)) ; Booting is keyboard activity. (INITIALIZE-WIRED-KBD-BUFFER) (ecase video-board-type (:vcmem ;; now that the "unibus" channel is set up, turn on 60Hz interrupts ;; first the vector (compiler::%nubus-write tv::tv-quad-slot 8 (dpb rg-quad-slot (byte 8 24.) (* 4 (+ #o400 #o260)))) (compiler::%nubus-write tv::tv-quad-slot 4 (logior #o40 (compiler::%nubus-read tv::tv-quad-slot 4)))) (:quad (%p-store-tag-and-pointer (%pointer-plus quad-video-control-virtual-address (// #x14 4)) 0 #o242) ;;read this location to clear pending vertical blank interrupt (%p-pointer (%pointer-plus quad-video-control-virtual-address 4)) ;;clear pending keyboard interrupt (%p-pointer (%pointer-plus quad-video-control-virtual-address 3)) ;;clear pending mouse interrupt (%p-pointer (%pointer-plus quad-video-control-virtual-address 11.)) ) (:explorer (start-si-ints))) (SETQ SELF NIL SELF-MAPPING-TABLE NIL) (DISABLE-SERVICES) (IF COLD-BOOT (SETQ FS::USER-LOGIN-MACHINE NIL)) ;; The first time, this does top-level EVAL's from the cold-load files (OR (BOUNDP 'ORIGINAL-LISP-CRASH-LIST) ;Save it for possible later inspection (SETQ ORIGINAL-LISP-CRASH-LIST LISP-CRASH-LIST)) (MAPC #'EVAL LISP-CRASH-LIST) (SETQ LISP-CRASH-LIST NIL) (when (fboundp 'eh::initialize-debugger) (eh::initialize-debugger)) (if (fboundp 'gc::initialize) (gc::initialize)) ;; Reattach IO streams. Note that *TERMINAL-IO* will be fixed later to go to a window. (UNLESS CALLED-BY-USER (UNCLOSUREBIND '*TERMINAL-IO* '*STANDARD-OUTPUT* '*STANDARD-INPUT* '*QUERY-IO* '*TRACE-OUTPUT* '*ERROR-OUTPUT* '*DEBUG-IO*) (SETQ *TERMINAL-IO* COLD-LOAD-STREAM *STANDARD-OUTPUT* SYN-TERMINAL-IO *STANDARD-INPUT* SYN-TERMINAL-IO *QUERY-IO* SYN-TERMINAL-IO *DEBUG-IO* SYN-TERMINAL-IO *TRACE-OUTPUT* SYN-TERMINAL-IO *ERROR-OUTPUT* SYN-TERMINAL-IO) (SEND *TERMINAL-IO* :HOME-CURSOR)) (SETQ TV::MOUSE-WINDOW NIL) ;This gets looked at before the mouse process is turned on (KBD-CONVERT-NEW 1_15.) ;Reset state of shift keys ; (select-processor ; (:cadr ; (WHEN (FBOUNDP 'CADR::CLEAR-UNIBUS-MAP) ;clear valid bits on unibus map. ; (CADR:CLEAR-UNIBUS-MAP))) ; and necessary if sharing Unibus with PDP11. ; ; Do this before SYSTEM-INITIALIZATION-LIST to ; ; avoid screwing ETHERNET code. ; ((:explorer :lambda))) (if (fboundp 'find-processor-configuration-structure) (find-processor-configuration-structure)) ;; These are initializations that have to be done before other initializations (INITIALIZATIONS 'SYSTEM-INITIALIZATION-LIST T) ;; At this point if the window system is loaded, it is all ready to go ;; and the initial Lisp listener has been exposed and selected. So do ;; any future typeout on it. But if any typeout happened on the cold-load ;; stream, leave it there (clobbering the Lisp listener's bits). This does not ;; normally happen, but just in case we do the set-cursorpos below so that ;; if anything strange gets typed out it won't get erased. Note that normally ;; we do not do any typeout nor erasing on the cold-load-stream, to avoid bashing ;; the bits of whatever window was exposed before a warm boot. (COND (CALLED-BY-USER) ((FBOUNDP 'TV::WINDOW-INITIALIZE) (MULTIPLE-VALUE-BIND (X Y) (SEND *TERMINAL-IO* :READ-CURSORPOS) (SEND TV::INITIAL-LISP-LISTENER :SET-CURSORPOS X Y)) (SETQ *TERMINAL-IO* TV::INITIAL-LISP-LISTENER) (SEND *TERMINAL-IO* :SEND-IF-HANDLES :SET-PACKAGE *PACKAGE*) (SEND *TERMINAL-IO* :FRESH-LINE)) (T (SETQ TV::INITIAL-LISP-LISTENER NIL) ;Not created yet (SEND *TERMINAL-IO* :CLEAR-REST-OF-LINE))) (WHEN CURRENT-PROCESS (SEND CURRENT-PROCESS :RUN-REASON 'LISP-INITIALIZE)) ;; prevent screw from things being traced during initialization (if (fboundp 'untrace) (untrace)) (if (fboundp 'breakon) (unbreakon)) ;; Have to check explicitly for cold-booting since can't just rely on initializations ;; to see that everything in this list has already run (ie at last cold boot) ;; since luser may have added own new inits since then ;; The "SYSTEM-START-UP-FILE" is run first, because it may set up the network ;; address etc. (WHEN *COLD-BOOTING* (IF (FBOUNDP 'EXECUTE-SYSTEM-STARTUP-FILE) (EXECUTE-SYSTEM-STARTUP-FILE)) (INITIALIZATIONS 'COLD-INITIALIZATION-LIST)) (INITIALIZATIONS 'WARM-INITIALIZATION-LIST T) (IF (BOUNDP 'EH::ERROR-TABLE) (EH::ENABLE-TRAPPING)) (AND *COLD-BOOTING* (BOUNDP 'TIME:*LAST-TIME-UPDATE-TIME*) (let ((frob (catch-error (list si:local-host (get-universal-time))))) (when frob (push frob cold-boot-history)))) (SETQ *COLD-BOOTING* NIL) (IF (FBOUNDP 'PRINT-HERALD) (PRINT-HERALD) (SEND *STANDARD-OUTPUT* :FRESH-LINE) (PRINC "Lisp Machine cold load environment, beware! ;; *READ//PRINT-BASE* = ") (LET ((*PRINT-BASE* 10.)) (PRINC *READ-BASE*)) (PRINC ", *PACKAGE* = ") (PRINC (PACKAGE-NAME *PACKAGE*)) (PRINC ".")) ;; This process no longer needs to be able to run except for the usual reasons. ;; The delayed-restart processes may now be allowed to run (WHEN CURRENT-PROCESS (SEND CURRENT-PROCESS :REVOKE-RUN-REASON 'LISP-INITIALIZE) (WHEN WARM-BOOTED-PROCESS (FORMAT T "Warm boot while running ~S. Its variable bindings remain in effect; its unwind-protects have been lost.~%" WARM-BOOTED-PROCESS) (WHEN (NOT (OR (EQ (PROCESS-WARM-BOOT-ACTION WARM-BOOTED-PROCESS) 'PROCESS-WARM-BOOT-RESTART) (EQ WARM-BOOTED-PROCESS INITIAL-PROCESS) (TYPEP WARM-BOOTED-PROCESS 'SI:SIMPLE-PROCESS))) (IF (YES-OR-NO-P "Reset it? Answer No if you want to debug it. ") (RESET-WARM-BOOTED-PROCESS) (FORMAT T "~&Do ~S to examine it, or do /~S to reset it and let it run again.~% If you examine it, you will see a state that is not quite the latest one." '(DEBUG-WARM-BOOTED-PROCESS) '(RESET-WARM-BOOTED-PROCESS))))) (LOOP FOR (P . RR) IN DELAYED-RESTART-PROCESSES DO (WITHOUT-INTERRUPTS (SETF (PROCESS-RUN-REASONS P) RR) (PROCESS-CONSIDER-RUNNABILITY P))) (SETQ DELAYED-RESTART-PROCESSES NIL)) ;; The global value of *TERMINAL-IO* is a stream which goes to an auto-exposing ;; window. Some processes, such as Lisp listeners, rebind it to something else. ;; CALLED-BY-USER is T if called from inside one of those. (WHEN (AND (NOT CALLED-BY-USER) (FBOUNDP TV::DEFAULT-BACKGROUND-STREAM) (NEQ (SYMBOL-FUNCTION TV::DEFAULT-BACKGROUND-STREAM) COLD-LOAD-STREAM)) (SETQ *TERMINAL-IO* TV::DEFAULT-BACKGROUND-STREAM)) ;; Now that -all- initialization has been completed, allow network servers if we are an ;; ordinary machine. If we are a primarily a server, an INIT file should call ;; (SI:ENABLE-SERVICES). The idea is that random machines aren't important enough to ;; be manually enabled as servers, but real server machines should, so that they ;; have a chance to be properly initialized, which would usually include loading an ;; INIT file which did things like load patches and salvage the file system. (when (fboundp 'get-site-option) (unless (get-site-option :server-machine) (enable-services)) (when (and (get-site-option :default-initial-form) cold-boot) (maybe-execute-default-initial-form))) ) )) ; From modified buffer QCFILE.LISP#> L.SYS; DJ: at 2-Aug-88 17:55:36 #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) (*fasd-interface* 'lambda-fasd-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 (NOT QC-FILE-LOAD-FLAG)) (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 (compiler-fasd-switch (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 buffer QCFILE.LISP#> L.SYS; DJ: at 2-Aug-88 17:56:39 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCFILE  " (DEFUN QC-FILE (INFILE &OPTIONAL OUTFILE LOAD-FLAG IN-CORE-FLAG PACKAGE-SPEC ignore ;was FILE-LOCAL-DECLARATIONS -smh DONT-SET-DEFAULT-P READ-THEN-PROCESS-FLAG &AUX GENERIC-PATHNAME QC-FILE-MACROS-EXPANDED (QC-FILE-RECORD-MACROS-EXPANDED T) (QC-FILE-REL-FORMAT QC-FILE-REL-FORMAT)) "Compile Lisp source file INFILE, producing a binary file and calling it OUTFILE. PACKAGE-SPEC specifies which package to read the source in (usually the file's attribute list provides the right default). LOAD-FLAG and IN-CORE-FLAG are semi-losing features; leave them NIL." ;READ-THEN-PROCESS-FLAG says read the entire file before compiling (less thrashing) ;; Default the specified input and output file names. Open files. (SETQ INFILE (FS:MERGE-PATHNAME-DEFAULTS INFILE FS:LOAD-PATHNAME-DEFAULTS NIL)) (WITH-OPEN-STREAM (INPUT-STREAM (FILE-RETRY-NEW-PATHNAME (INFILE FS:FILE-ERROR) (SEND INFILE :OPEN-CANONICAL-DEFAULT-TYPE :LISP))) ;; The input pathname might have been changed by the user in response to an error. ;; Also, find out what type field was actually found. (SETQ INFILE (SEND INPUT-STREAM :PATHNAME)) (OR DONT-SET-DEFAULT-P (FS:SET-DEFAULT-PATHNAME INFILE FS:LOAD-PATHNAME-DEFAULTS)) (SETQ GENERIC-PATHNAME (SEND INFILE :GENERIC-PATHNAME)) (SETQ OUTFILE (COND ((TYPEP OUTFILE 'PATHNAME) (IF (SEND OUTFILE :VERSION) OUTFILE (SEND OUTFILE :NEW-PATHNAME :VERSION (IF *QC-FILE-OUTPUT-SAME-VERSION* (SEND (SEND INPUT-STREAM :TRUENAME) :VERSION) :NEWEST)))) (OUTFILE (FS:MERGE-PATHNAME-DEFAULTS OUTFILE INFILE (SI:PATHNAME-DEFAULT-BINARY-FILE-TYPE GENERIC-PATHNAME) (IF *QC-FILE-OUTPUT-SAME-VERSION* (SEND (SEND INPUT-STREAM :TRUENAME) :VERSION) :NEWEST))) (T (SEND INFILE :NEW-PATHNAME :TYPE (SI:PATHNAME-DEFAULT-BINARY-FILE-TYPE GENERIC-PATHNAME) :VERSION (IF *QC-FILE-OUTPUT-SAME-VERSION* (SEND (SEND INPUT-STREAM :TRUENAME) :VERSION) :NEWEST))))) ;; Get the file property list again, in case we don't have it already or it changed (FS:READ-ATTRIBUTE-LIST GENERIC-PATHNAME INPUT-STREAM) (let ((compile-in-roots-prop (get generic-pathname :compile-in-roots))) (cond ((and compile-in-roots-prop (not (cl:member (si:package-root-name (if package-spec package-spec *package*)) compile-in-roots-prop :test 'string-equal))) (ferror "This file is supposed to be compiled only in ~s hierarchies, not ~s" compile-in-roots-prop (si:package-root-name (if package-spec package-spec *package*)))))) (OR QC-FILE-REL-FORMAT-OVERRIDE (CASE (SEND GENERIC-PATHNAME :GET ':FASL) (:REL (SETQ QC-FILE-REL-FORMAT T)) (:FASL (SETQ QC-FILE-REL-FORMAT NIL)) ((NIL)) (T (FERROR "File property FASL value not FASL or REL in file ~A" GENERIC-PATHNAME)))) ;; Bind all the variables required by the file property list. (MULTIPLE-VALUE-BIND (VARIABLES VALS) (FS:FILE-ATTRIBUTE-BINDINGS GENERIC-PATHNAME) (PROGV VARIABLES VALS (bind-compilation-environment-maybe (make-compilation-environment) ;make a resource? (COND (QC-FILE-REL-FORMAT (LET ((FASD-STREAM NIL)) ;REL compiling doesn't work the same way (LOCKING-RESOURCES (FUNCALL (INTERN (STRING 'DUMP-START) 'QFASL-REL)) (COMPILE-STREAM INPUT-STREAM GENERIC-PATHNAME FASD-STREAM 'QC-FILE-WORK-COMPILE LOAD-FLAG IN-CORE-FLAG PACKAGE-SPEC nil ; was FILE-LOCAL-DECLARATIONS -smh READ-THEN-PROCESS-FLAG) ;; Output a record of the macros expanded and their current sxhashes. (WHEN QC-FILE-MACROS-EXPANDED (FUNCALL (INTERN (STRING 'DUMP-FORM) 'QFASL-REL) `(SI:FASL-RECORD-FILE-MACROS-EXPANDED ',QC-FILE-MACROS-EXPANDED))) (LET ((*PACKAGE* (IF PACKAGE-SPEC (PKG-FIND-PACKAGE PACKAGE-SPEC) *PACKAGE*))) (FUNCALL (INTERN (STRING 'WRITE-REL-FILE) 'QFASL-REL) OUTFILE))))) (T (WITH-OPEN-STREAM (FASD-STREAM (IF *QC-FILE-OUTPUT-SAME-VERSION* (OPEN OUTFILE :DIRECTION :OUTPUT :CHARACTERS NIL :BYTE-SIZE 16. :IF-EXISTS :SUPERSEDE) (OPEN OUTFILE :DIRECTION :OUTPUT :CHARACTERS NIL :BYTE-SIZE 16.))) (FLET ((DOIT () (LOCKING-RESOURCES (SETQ OUTFILE (SEND FASD-STREAM :PATHNAME)) (FASD-INITIALIZE) (FASD-START-FILE) (COMPILE-STREAM INPUT-STREAM GENERIC-PATHNAME FASD-STREAM 'QC-FILE-WORK-COMPILE LOAD-FLAG IN-CORE-FLAG PACKAGE-SPEC nil ; was FILE-LOCAL-DECLARATIONS -smh READ-THEN-PROCESS-FLAG T) ;; Output a record of the macros expanded and their current sxhashes. (WHEN QC-FILE-MACROS-EXPANDED (FASD-FORM `(SI::FASL-RECORD-FILE-MACROS-EXPANDED ',QC-FILE-MACROS-EXPANDED))) (FASD-END-WHACK) (FASD-END-FILE)))) (COND (*QC-FILE-OUTPUT-DRIBBLE-TYPE* (WITH-OPEN-STREAM (DRIBBLE-FILE (IF *QC-FILE-OUTPUT-SAME-VERSION* (OPEN (SEND OUTFILE :NEW-TYPE *QC-FILE-OUTPUT-DRIBBLE-TYPE*) :DIRECTION :OUTPUT :CHARACTERS T :IF-EXISTS :SUPERSEDE) (OPEN (SEND OUTFILE :NEW-TYPE *QC-FILE-OUTPUT-DRIBBLE-TYPE*) :DIRECTION :OUTPUT :CHARACTERS T))) (FORMAT DRIBBLE-FILE "Compilation log started at ~\time\ by ~S for~% INPUT: ~S~% OUTPUT: ~S~2%" (TIME:GET-UNIVERSAL-TIME) SI:USER-ID (SEND INPUT-STREAM :TRUENAME) (SEND FASD-STREAM :TRUENAME)) (LET ((DRIBBLE-STREAM (SI:MAKE-DRIBBLE-STREAM *TERMINAL-IO* DRIBBLE-FILE))) (LET ((*STANDARD-INPUT* DRIBBLE-STREAM) (*STANDARD-OUTPUT* DRIBBLE-STREAM) (*QUERY-IO* DRIBBLE-STREAM) (*ERROR-OUTPUT* DRIBBLE-STREAM) (*TRACE-OUTPUT* DRIBBLE-STREAM) (TIME (TIME)) (DW (SI:READ-METER 'SI:%DISK-WAIT-TIME))) (DOIT) (FORMAT DRIBBLE-FILE "~&~3%Compilation complete at ~\time\~ ~%~\scientific\seconds realtime ~\scientific\seconds disk wait~%" (TIME:GET-UNIVERSAL-TIME) (QUOTIENT (TIME-DIFFERENCE (TIME) TIME) 60.0) (QUOTIENT (- (SI:READ-METER 'SI:%DISK-WAIT-TIME) DW) 1.0E6)) (GC:STATUS DRIBBLE-FILE) (GC:PRINT-STATISTICS DRIBBLE-FILE))))) ('ELSE (DOIT))))))))))) OUTFILE) )) ; From modified buffer QCFILE.LISP#> L.SYS; DJ: at 2-Aug-88 17:57:05 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCFILE  " (DEFUN FASL-UPDATE-STREAM (INFILE OUTFILE INPUT-STREAM READ-FUNCTION &AUX QC-FILE-LOAD-FLAG (QC-FILE-IN-CORE-FLAG T) (DEFAULT-CONS-AREA DEFAULT-CONS-AREA)) (DECLARE (IGNORE INFILE)) (LET ((QC-FILE-IN-PROGRESS T) (LOCAL-DECLARATIONS NIL) (FASD-PACKAGE NIL)) (LOCKING-RESOURCES (WITH-OPEN-FILE (FASD-STREAM OUTFILE :DIRECTION :OUTPUT :CHARACTERS NIL :BYTE-SIZE 16.) (FASD-INITIALIZE) (FASD-START-FILE) ;; First thing in QFASL file must be property list ;; Only property supported just now is PACKAGE property (FASD-ATTRIBUTES-LIST (LIST ':PACKAGE (INTERN (PACKAGE-NAME *PACKAGE*) SI:PKG-KEYWORD-PACKAGE))) (QC-PROCESS-INITIALIZE) (DO ((EOF '(())) FORM) (NIL) ;; Start a new whack if FASD-TABLE is getting too big. (AND ( (FASD-TABLE-LENGTH) QC-FILE-WHACK-THRESHOLD) (FASD-END-WHACK)) ;; Read and macroexpand in temp area. (SETQ DEFAULT-CONS-AREA QCOMPILE-TEMPORARY-AREA) (LET ((QC-FILE-READ-IN-PROGRESS T)) (SETQ FORM (FUNCALL READ-FUNCTION INPUT-STREAM EOF))) (AND (EQ EOF FORM) (RETURN NIL)) (SETQ FORM (MACROEXPAND FORM)) (SETQ DEFAULT-CONS-AREA BACKGROUND-CONS-AREA) ;; Output this form in the appropriate way. (COMPILE-DRIVER FORM 'FASL-UPDATE-FORM NIL)) (FASD-END-WHACK) (FASD-END-FILE))))) )) ; From modified buffer QCFILE.LISP#> L.SYS; DJ: at 2-Aug-88 17:57:25 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCFILE  " (DEFUN SPECIAL-1 (SYMBOL) "Make SYMBOL be marked special as special." (COND (UNDO-DECLARATIONS-FLAG (putdecl symbol 'special 't)) (T (PUTPROP SYMBOL (OR FDEFINE-FILE-PATHNAME T) 'SPECIAL)))) )) ; From modified buffer QCFILE.LISP#> L.SYS; DJ: at 2-Aug-88 17:57:36 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCFILE  " (DEFUN UNSPECIAL-1 (SYMBOL) "Make SYMBOL not be marked as special." (COND (UNDO-DECLARATIONS-FLAG (putdecl SYMBOL 'special 'nil)) (T (REMPROP SYMBOL 'SPECIAL) (REMPROP SYMBOL 'SYSTEM-CONSTANT)))) )) ; From modified buffer FLAVOR.LISP#> L.SYS2; DJ: at 2-Aug-88 18:00:48 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; FLAVOR  " (DEFUN COMPILATION-FLAVOR (FLAVOR-OR-NAME &OPTIONAL (USE-COMPILATION-FLAVORS *JUST-COMPILING*)) "Returns the appropriate flavor object for the specified flavor. If compiling, it returns the compilation-time flavor object corresponding to the specified flavor or flavor name. If not compiling, returns the actual installed flavor object. USE-COMPILATION-FLAVORS specifies whether to assume we are compiling or not; it defaults to the truth." (OR (AND USE-COMPILATION-FLAVORS (getdecl (IF (SYMBOLP FLAVOR-OR-NAME) FLAVOR-OR-NAME (FLAVOR-NAME FLAVOR-OR-NAME)) 'flavor)) (IF (SYMBOLP FLAVOR-OR-NAME) (GET FLAVOR-OR-NAME 'FLAVOR) FLAVOR-OR-NAME))) )) ; From modified buffer FLAVOR.LISP#> L.SYS2; DJ: at 2-Aug-88 18:01:27 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; FLAVOR  " (DEFUN COMPILATION-DEFINE-FLAVOR (FLAVOR-NAME FL) (putdecl flavor-name 'FLAVOR fl)) ))