;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 126.13 ;;; Reason: ;;; COMPILE-FILE now takes an additional keyword arg: :EXPLICIT-COMPILATION-ENVIRONMENT. ;;; This is passed through to QC-FILE. ;;; Written 4-Aug-88 16:54:58 by smh at site Gigamos Cambridge ;;; while running on Harpo from band 3 ;;; with Experimental System 126.12, ZWEI 125.10, ZMail 73.0, 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#366 at 4-Aug-88 16:55:10 #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) (QC-FILE FILE OUTPUT-FILE NIL NIL PACKAGE-SPEC explicit-compilation-environment (NOT SET-DEFAULT-PATHNAME)))))) (AND RESULT LOAD (LOAD RESULT :SET-DEFAULT-PATHNAME NIL)) RESULT)) )) ; From modified file DJ: L.SYS; QCFILE.LISP#366 at 4-Aug-88 16:55:19 #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 &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 ;; 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)))) ;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) ))