;;; -*- Mode:LISP; Package:COMPILER; Readtable:T; Base:8; Patch-File:Yes -*-
;;; This is from SYS: SYS; QCFILE
;;;

(defvar *atoms-exempted-from-warning* '())

(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 NIL) IGNORE
		                 COMPILING-WHOLE-FILE-P
		       &AUX (*PACKAGE* *PACKAGE*)
		            (*READ-BASE* *READ-BASE*) (*PRINT-BASE* *PRINT-BASE*)
			    FILE-SPECIAL-LIST FILE-UNSPECIAL-LIST
			    FDEFINE-FILE-PATHNAME
			    (READ-FUNCTION (IF QC-FILE-CHECK-INDENTATION
					       'READ-CHECK-INDENTATION
					       'READ)))
  "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."
  (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 (AND (MEMQ ':PATHNAME (SEND INPUT-STREAM ':WHICH-OPERATIONS))
				(SEND INPUT-STREAM ':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 (COPYLIST (SEND GENERIC-PATHNAME ':PLIST))))
	   ;; 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 (NOT (ATOM (GETF PLIST ':PACKAGE)))
			(STRING= (PACKAGE-NAME *PACKAGE*)
				 (CAR (GETF PLIST ':PACKAGE))))
	     (PUTPROP (LOCF PLIST)
		      (INTERN (PACKAGE-NAME *PACKAGE*) SI:PKG-KEYWORD-PACKAGE)
		      ':PACKAGE))
	   (AND INPUT-STREAM
		(MEMQ ':TRUENAME (SEND INPUT-STREAM ':WHICH-OPERATIONS))
		(SETQ SOURCE-FILE-UNIQUE-ID (SEND INPUT-STREAM ':TRUENAME))
		(PUTPROP (LOCF PLIST)
			 SOURCE-FILE-UNIQUE-ID
			 ':QFASL-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 (AND (MEMQ ':PATHNAME
					  (SEND FASD-STREAM ':WHICH-OPERATIONS))
				    (SEND FASD-STREAM ':PATHNAME))))
		  (COND (OUTFILE
			 (SETQ OUTFILE (SEND OUTFILE ':GENERIC-PATHNAME))
			 (AND (NEQ OUTFILE FDEFINE-FILE-PATHNAME)
			      (PUTPROP (LOCF PLIST) FDEFINE-FILE-PATHNAME
				       ':SOURCE-FILE-GENERIC-PATHNAME))))))
	   (MULTIPLE-VALUE-BIND (MAJOR MINOR)
	       (SI:GET-SYSTEM-VERSION "System")
	     (PUTPROP (LOCF PLIST)
		      `(,USER-ID
			,SI:LOCAL-PRETTY-HOST-NAME
			,(TIME:GET-UNIVERSAL-TIME)
			,MAJOR ,MINOR
			(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))
		      ':COMPILE-DATA))
	   ;; First thing in QFASL file must be property list
	   ;; These properties wind up on the GENERIC-PATHNAME.
	   (COND (QC-FILE-REL-FORMAT
		  (QFASL-REL::DUMP-FILE-PROPERTY-LIST
		    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))
	   (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))
	 ;; 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 (not (memq form *atoms-exempted-from-warning*)))
	   (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))))))