;;; -*- Mode:LISP; Package:COMPILER; Readtable:ZL; Base:10 -*- ;;; This is the beginning of a compilation environment implementation. ;;; It allows cross compilations to be done whick keep the target ;;; environment separate from the compiling environment. ;;; Things like SPECIAL proclamations, MACRO definitions, DEFCONSTANTs, ;;; and (ulp) DEFTYPEs can all be stored in a data structure. ;;; Perhaps all this trash should be in qcdefs. ;;; The strategy is to find all the places where this data gets squirreled ;;; away and conditionalize them on the value of *TARGET-COMPUTER*. ;;; Lots left To Do or Check, including but not limited to: ;;; - DEFCONSTANT, DEFVAR ;;; - DEFTYPE ;;; - DEFSUBST ;;; - DEFFLAVOR, DEFMETHOD, DEFWRAPPER (cl:defstruct (compilation-environment (:print-function (lambda (struct stream level) (ignore level) (printing-random-object (struct stream :type) (princ "for " stream) (prin1 (compilation-environment-target struct) stream))))) (target nil :documentation "The *TARGET-COMPUTER* which this environment is for.") #+never ;It should be thus ... (plist-hashtab (make-hash-table :test #'eq) :documentation "Maps symbols onto property lists.") ; but it ain't. Groady lists instead... (local-declarations nil :documentation "Alist carrying COMPILER:FILE-LOCAL-DECLARATIONS between file compiles.") (SPECIAL-LIST nil :documentation "List carrying COMPILER:FILE-SPECIAL-LIST between file compiles.") (UNSPECIAL-LIST nil :documentation "List carrying COMPILER:FILE-UNSPECIAL-LIST between file compiles.")) ;;; The current COMPILATION-ENVIRONMENT is bound to this var. If non-nil, DEFVAR, ;;; DEFMACRO, and friends operate on the COMPILATION-ENVIRONMENT. This defvar will ;;; need to be moved to a much earlier file once system 4 sources are unfrozified. ;;; Ditto the above defstruct. (defvar *compilation-environment* nil "When cross compiling, the compilation environment in which to save deficrud.") (defvar-resettable *file-local-declarations-boundp* nil nil "Bound T by outermost entry to the compiler (e.g. COMPILE) so FILE-LOCAL-DECLARATIONS and friends can be bound just once, allowing meaningful compilation environments to be saved between COMPILE-FILEs.") (defmacro with-compilation-environment (environment &body body) `(if *file-local-declarations-boundp* (error "Lose -- recursive WITH-COMPILATION-ENVIRONMENTs") (let* ((environment ,environment) (*file-local-declarations-boundp* t) (*compilation-environment* environment) (file-local-declarations (compilation-environment-local-declarations environment)) (file-special-list (compilation-environment-special-list environment)) (file-unspecial-list (compilation-environment-unspecial-list environment))) (multiple-value-prog1 (progn ,@body) (setf (compilation-environment-local-declarations environment) file-local-declaration (compilation-environment-special-list environment) file-special-list (compilation-environment-unspecial-list environment) file-unspecial-list))))) (defmacro bind-local-declarations-maybe ((file-local-declarations file-special-list file-unspecial-list) &body body) `(let-if (not *file-local-declarations-boundp*) ((file-local-declarations ,file-local-declarations) (file-special-list ,file-special-list) (file-unspecial-list ,file-unspecial-list)) ,@body)) ;;; Beam me up, Jim! (defun k-compile-file-with-ce (environment &rest args) (with-compilation-environment environment (apply #'k-compile-file args))) ;;; The following are from qcfile. (DEFUN COMPILE-STREAM (INPUT-STREAM GENERIC-PATHNAME FASD-FLAG PROCESS-FN QC-FILE-LOAD-FLAG QC-FILE-IN-CORE-FLAG PACKAGE-SPEC &OPTIONAL FILE-LOCAL-DECLARATIONS-arg 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. FILE-LOCAL-DECLARATIONS is normally initialized to NIL, but you can optionally pass in an initializations for it. 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))) (bind-local-declarations-maybe (file-local-declarations-arg nil nil) (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)))))))) (DEFUN QC-FILE (INFILE &OPTIONAL OUTFILE LOAD-FLAG IN-CORE-FLAG PACKAGE-SPEC FILE-LOCAL-DECLARATIONS-arg 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))) (bind-local-declarations-maybe (file-local-declarations-arg nil nil) ;; 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 (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 FILE-LOCAL-DECLARATIONS 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 FILE-LOCAL-DECLARATIONS 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)