;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 126.42 ;;; Reason: ;;; Force FDEF files version number to track source file version number. ;;; Written 11-Aug-88 17:17:16 by smh at site Gigamos Cambridge ;;; while running on Harpo from band 3 ;;; with Experimental System 126.41, ZWEI 125.15, 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#376 at 11-Aug-88 17:17:31 #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-c-e-p) (environment-pathname nil env-supplied-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-c-e-p explicit-compilation-environment *falcon-environment*)) (env (if explicit-c-e-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 (if env-supplied-p environment-pathname (let ((pathname-source (if output-file ;not exactly right (FS:MERGE-PATHNAME-DEFAULTS output-file file) file))) (send pathname-source :new-pathname :type :fdef :version (IF *QC-FILE-OUTPUT-SAME-VERSION* (SEND (SEND pathname-source :TRUENAME) :VERSION) :NEWEST)))) :byte-size 8. :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#376 at 11-Aug-88 17:17:38 #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 called OUTPUT-FILE. PACKAGE-SPEC specifies which package in which to read the source. 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)) ))