;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 126.18
;;; Reason:
;;;  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)
;;;  -- smh & RWK
;;; 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))

))