;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 126.18 ;;; Reason: ;;; Patch in basic support for cross compilation. ;;; ;;; Function COMPILE-STREAM: Remove bogus conditionalization. ;;; Function COMPILE-FILE-DRIVER: Keyword interface for what used to be QC-FILE ;;; (which remains for compatability, but calls COMPILE-FILE-DRIVER now). ;;; The arglist was getting quite out of hand! ;;; Adds :target-computer, :target-features, :environment-pathname, and ;;; :byte-size keyword args to the functionality of QC-FILE. ;;; Function COMPILE-FILE: Use COMPILE-FILE-DRIVER. ;;; Function COMPILE-FILE-FOR-FALCON: Call the cross compiler, and write an ;;; environment file, too. ;;; Function QC-FILE: Now a compatability stub. Call COMPILE-FILE-DRIVER to do ;;; the work. ;;; Function WRITE-COMPILATION-ENVIRONMENT: Write a compilation environment to ;;; an FDEF file. ;;; Function LOAD-TO-COMPILATION-ENVIRONMENT-INTERNAL: Used by the FDEF files. ;;; Variable *FALCON-ENVIRONMENT*: Environment holding global information about ;;; the Falcon system. ;;; Variable SI::*FALCON-FEATURES*: Features list for the Falcon. ;;; Initially: ;;; (:falcon :gigamos :lexical :commonlisp :loop :defstruct :lispm :mit :lmi ;;; :common :sort :fasload :string :newio :roman ;;; :trace :grindef :grind) ;;; Written 8-Aug-88 18:15:02 by smh (Steve Haflich) at site Gigamos Cambridge ;;; while running on Harpo from band 3 ;;; with Experimental System 126.17, ZWEI 125.12, ZMail 73.2, Local-File 75.2, File-Server 24.1, Unix-Interface 13.0, Tape 24.2, Lambda-Diag 17.0, microcode 1762, SDU Boot Tape 3.12, SDU ROM 102, kold 4aug88. ; From modified file DJ: L.SYS; QCFILE.LISP#367 at 8-Aug-88 18:15:39 #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 (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 (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; QCFILE.LISP#367 at 8-Aug-88 18:15:50 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCFILE  " (DEFUN COMPILE-FILE (INPUT-FILE &KEY OUTPUT-FILE (SET-DEFAULT-PATHNAME T) LOAD ((:PACKAGE PACKAGE-SPEC)) explicit-compilation-environment) "Compile file INPUT-FILE to a QFASL file named OUTPUT-FILE. OUTPUT-FILE defaults based on INPUT-FILE, which defaults using the standard defaults. SET-DEFAULT-PATHNAME if NIL means do not set the defaults. PACKAGE if non-NIL is the package to compile in. LOAD means to load the file after compiling it." (LET* ((FILE (FS:MERGE-PATHNAME-DEFAULTS (OR INPUT-FILE "") *DEFAULT-PATHNAME-DEFAULTS*)) (RESULT (CATCH-ERROR-RESTART (EH:DEBUGGER-CONDITION "Give up on compiling ~A." FILE) (ERROR-RESTART (EH:DEBUGGER-CONDITION "Retry compiling ~A." FILE) (compile-file-driver file :output-file output-file :package-spec package-spec :explicit-compilation-environment explicit-compilation-environment :dont-set-default-p (not set-default-pathname)))))) (AND RESULT LOAD (LOAD RESULT :SET-DEFAULT-PATHNAME NIL)) RESULT)) )) ; From modified file DJ: L.SYS; QCFILE.LISP#367 at 8-Aug-88 18:15:52 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCFILE  " (DEFUN COMPILE-FILE-for-falcon (INPUT-FILE &KEY OUTPUT-FILE (SET-DEFAULT-PATHNAME T) LOAD ((:PACKAGE PACKAGE-SPEC)) (explicit-compilation-environment nil explicit-p)) "Compile file INPUT-FILE to a QFASL file named OUTPUT-FILE. OUTPUT-FILE defaults based on INPUT-FILE, which defaults using the standard defaults. SET-DEFAULT-PATHNAME if NIL means do not set the defaults. PACKAGE if non-NIL is the package to compile in. LOAD means to load the file after compiling it." (LET* ((*compilation-environment* (if explicit-p explicit-compilation-environment *falcon-environment*)) (env (if explicit-p *compilation-environment* (make-compilation-environment :target 'falcon))) (FILE (FS:MERGE-PATHNAME-DEFAULTS (OR INPUT-FILE "") *DEFAULT-PATHNAME-DEFAULTS*)) (RESULT (CATCH-ERROR-RESTART (EH:DEBUGGER-CONDITION "Give up on compiling ~A." FILE) (ERROR-RESTART (EH:DEBUGGER-CONDITION "Retry compiling ~A." FILE) (compile-file-driver file :output-file output-file :package-spec package-spec :explicit-compilation-environment env :target-computer 'k :target-features si:*falcon-features* :environment-pathname (send (or output-file input-file) :new-type :fdef) :byte-size 8. :dont-set-default-p (NOT SET-DEFAULT-PATHNAME)))))) (AND RESULT LOAD (LOAD RESULT :SET-DEFAULT-PATHNAME NIL)) RESULT)) ;; Note: Some file servers just cant hack :IF-EXISTS :SUPERSEDE without first deleting the old ;; QFASL. Therefore if compilation bombs you lose your old qfasl file forever. ;; Also MAKE-SYSTEM looks at creation dates, not version numbers in any case. ;; -gjc )) ; From modified file DJ: L.SYS; QCFILE.LISP#367 at 8-Aug-88 18:15:59 #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 explicit-compilation-environment DONT-SET-DEFAULT-P READ-THEN-PROCESS-FLAG) (compile-file-driver infile :output-file outfile :load-flag load-flag :in-core-flag in-core-flag :package-spec package-spec :explicit-compilation-environment explicit-compilation-environment :dont-set-default-p dont-set-default-p :read-then-process-flag read-then-process-flag)) )) ; From modified file DJ: L.SYS; QCFILE.LISP#367 at 8-Aug-88 18:16:01 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCFILE  " (defun compile-file-driver (input-file &key output-file load-flag in-core-flag package-spec explicit-compilation-environment dont-set-default-p read-then-process-flag ((:target-computer *target-computer*) 'lambda-interface) ((:target-features si:*target-features*)) (environment-pathname) (byte-size 16.) &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 INPUT-FILE, producing a binary file and calling it OUTPUT-FILE. 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 INPUT-FILE (FS:MERGE-PATHNAME-DEFAULTS INPUT-FILE FS:LOAD-PATHNAME-DEFAULTS NIL)) (WITH-OPEN-STREAM (INPUT-STREAM (FILE-RETRY-NEW-PATHNAME (INPUT-FILE FS:FILE-ERROR) (SEND INPUT-FILE :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 INPUT-FILE (SEND INPUT-STREAM :PATHNAME)) (OR DONT-SET-DEFAULT-P (FS:SET-DEFAULT-PATHNAME INPUT-FILE FS:LOAD-PATHNAME-DEFAULTS)) (SETQ GENERIC-PATHNAME (SEND INPUT-FILE :GENERIC-PATHNAME)) (SETQ OUTPUT-FILE (COND ((TYPEP OUTPUT-FILE 'PATHNAME) (IF (SEND OUTPUT-FILE :VERSION) OUTPUT-FILE (SEND OUTPUT-FILE :NEW-PATHNAME :VERSION (IF *QC-FILE-OUTPUT-SAME-VERSION* (SEND (SEND INPUT-STREAM :TRUENAME) :VERSION) :NEWEST)))) (OUTPUT-FILE (FS:MERGE-PATHNAME-DEFAULTS OUTPUT-FILE INPUT-FILE (SI:PATHNAME-DEFAULT-BINARY-FILE-TYPE GENERIC-PATHNAME) (IF *QC-FILE-OUTPUT-SAME-VERSION* (SEND (SEND INPUT-STREAM :TRUENAME) :VERSION) :NEWEST))) (T (SEND INPUT-FILE :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 ;; File compilation always gets its's own environment, which is discarded after the ;; compilation. If there is non-null environment, the new environment established ;; here is `inside' that environment, and captures everything in it. (let ((*compilation-environment* (or explicit-compilation-environment (make-compilation-environment :target *target-computer*)))) ;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 *target-computer*) ;; 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) OUTPUT-FILE))))) (T (WITH-OPEN-STREAM (FASD-STREAM (IF *QC-FILE-OUTPUT-SAME-VERSION* (OPEN OUTPUT-FILE :DIRECTION :OUTPUT :CHARACTERS NIL :BYTE-SIZE byte-size :IF-EXISTS :SUPERSEDE) (OPEN OUTPUT-FILE :DIRECTION :OUTPUT :CHARACTERS NIL :BYTE-SIZE byte-size))) (with-fasd-indirect-array (fasd-stream) (FLET ((DOIT () (LOCKING-RESOURCES (SETQ OUTPUT-FILE (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 *target-computer*) ;; 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 OUTPUT-FILE :NEW-TYPE *QC-FILE-OUTPUT-DRIBBLE-TYPE*) :DIRECTION :OUTPUT :CHARACTERS T :IF-EXISTS :SUPERSEDE) (OPEN (SEND OUTPUT-FILE :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)))))))) (when environment-pathname (write-compilation-environment *compilation-environment* environment-pathname)) ))) OUTPUT-FILE)) ;;; COMPILE-STREAM when called by QC-FILE calls this on each form in the file )) ; From modified file DJ: L.SYS; QCFILE.LISP#367 at 8-Aug-88 18:16:22 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCFILE  " (defun write-compilation-environment (compilation-environment pathname &aux pvals mvals) ;;(print-ce compilation-environment) (maphash #'(lambda (k v) (push (cons k v) pvals)) (compilation-environment-plist-hashtab compilation-environment)) (maphash #'(lambda (k v) (push (cons k v) mvals)) (compilation-environment-macro-hashtab compilation-environment)) (zl:dump-forms-to-file (fs:merge-pathname-components pathname nil :default-type :FDEF) `((load-to-compilation-environment-internal ',(compilation-environment-target compilation-environment) ',pvals ',mvals)) `(:package ,(package-name *package*) :readtable ,(car (si:rdtbl-names *readtable*))))) )) ; From modified file DJ: L.SYS; QCFILE.LISP#367 at 8-Aug-88 18:16:24 #8R COMPILER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS: SYS; QCFILE  " (defun load-to-compilation-environment-internal (target plists macros) (unless (compilation-environment-p *compilation-environment*) (error "Attempting to load a compilation-environment without binding *COMPILATION-ENVIRONMENT* to a COMPILATION-ENVIRONMENT object.")) (unless (equal (compilation-environment-target *compilation-environment*) target) (error "Attepting to load a compilation-environment for target ~S but *COMPILATION-ENVIRONMENT* has a target of ~S." target (compilation-environment-target *compilation-environment*))) (let ((pht (compilation-environment-plist-hashtab *compilation-environment*))) (dolist (key-pvals plists) (let ((plist (gethash key-pvals pht))) (do ((p (cdr key-pvals) (cddr p))) ((null p)) (setf (getf plist (car p)) (cadr p))) (setf (gethash key-pvals pht) plist)))) (let ((mht (compilation-environment-macro-hashtab *compilation-environment*))) (dolist (key-macro macros) (setf (gethash (car key-macro) mht) (cdr key-macro))))) ;;;; Barf all over SPECIAL and UNSPECIAL "declarations." ;;; When not compiling a file, etc., or in Maclisp, ;;; we simply put on or remove a SPECIAL property. ;;; When compiling a file (COMPILE-NO-LOAD-FLAG is T) ;;; we just use FILE-LOCAL-DECLARATIONS to make the change. ;;; SPECIAL just pushes one big entry on FILE-LOCAL-DECLARATIONS, to save consing. ;;; UNSPECIAL, for each symbol, tries to avoid lossage in the case where a symbol ;;; is repeatedly made special and then unspecial again, by removing any existing ;;; unshadowed SPECIALs from FILE-LOCAL-DECLARATIONS, and then putting on an UNSPECIAL ;;; only if there isn't already one. This way, FILE-LOCAL-DECLARATIONS doesn't keep growing. ;;; SPECIAL-1 and UNSPECIAL-1 can be used to make a computed symbol special or unspecial. )) ; From modified file DJ: SMH; KENV-SUPPORT.LISP#11 at 8-Aug-88 18:16:42 #10R COMPILER#: #!:CL (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER"))) (PATCH-SOURCE-FILE "SYS:SYS;QCFILE  " (defvar *falcon-environment* (make-compilation-environment :target 'falcon)) ;; This should be compile-file-for-k )) ; From file JB: K; SYSDEF.LISP#382 at 8-Aug-88 18:17:45 #10R USER#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "USER"))) (COMPILER::PATCH-SOURCE-FILE "SYS:SYS;QCFILE  " (defvar si::*falcon-features* '(:falcon :gigamos :lexical :commonlisp :loop :defstruct :lispm :mit :lmi :common :sort :fasload :string :newio :roman :trace :grindef :grind)) ))