;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************

;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;

(ext:file-comment "$Header: src/compiler/main.lisp $")

;;;

;;; **********************************************************************
;;;
;;;    This file contains the top-level interfaces to the compiler.
;;; 
;;; Written by Rob MacLachlan
;;;

(in-package "C")

(in-package "EXTENSIONS")

(intl:textdomain "cmucl")

(export '(*compile-progress* compile-from-stream *block-compile-default*

			     start-block end-block
			     *byte-compile-default*
			     *byte-compile-top-level*))

(in-package "LISP")
(export '(*compile-verbose* *compile-print* *compile-file-pathname*

			    *compile-file-truename*
			    compile-file-pathname))

(in-package "C")

(declaim (special *constants* *free-variables* *compile-component*
		  *code-vector* *next-location* *result-fixups*
		  *free-functions* *source-paths*
		  *continuation-number* *continuation-numbers*
		  *number-continuations* *tn-id* *tn-ids* *id-tns*
		  *label-ids* *label-id* *id-labels*
		  *undefined-warnings* *compiler-error-count*
		  *compiler-warning-count* *compiler-note-count*
		  *compiler-error-output* *compiler-error-bailout*
		  *compiler-trace-output*
		  *last-source-context* *last-original-source*
		  *last-source-form* *last-format-string* *last-format-args*
		  *last-message-count* *lexical-environment*
		  *coalesce-constants*))

;;; Exported:

(defvar *block-compile-default* :specified

  "The default value for the :Block-Compile argument to COMPILE-FILE.")

(declaim (type (member t nil :specified) *block-compile-default*))

;;; Exported:
(defvar *byte-compile-default* :maybe

  "The default value for the :Byte-Compile argument to COMPILE-FILE.")

;;; Exported:
(defvar *byte-compile-top-level* t

  "Similar to *BYTE-COMPILE-DEFAULT*, but controls the compilation of top-level

  forms (evaluated at load-time) when the :BYTE-COMPILE argument is :MAYBE
  (the default.)  When true, we decide to byte-compile.")

;;; Exported:
(defvar *loop-analyze* nil

  "Whether loop analysis should be done or not.")

;;; Value of the :byte-compile argument to the compiler.
(defvar *byte-compile* :maybe)

;;; Bound by COMPILE-COMPONENT to T when byte-compiling, and NIL when

;;; native compiling.  During IR1 conversion this can also be :MAYBE, in which
;;; case we must look at the policy, see (byte-compiling).

;;;

(defvar *byte-compiling* :maybe)
(declaim (type (member t nil :maybe) *byte-compile* *byte-compiling*
	       *byte-compile-default*))

(defvar compiler-version "1.1")

(pushnew :python *features*)
(setf (getf ext:*herald-items* :python)
      `("    Python " ,compiler-version ", target "
	,#'(lambda (stream)
	     (write-string (backend-version *backend*) stream))))

(defvar *check-consistency* nil)

(defvar *record-xref-info* nil

  "Whether the compiler should record cross-reference information.")

(defvar *all-components*)

;;; The current block compilation state.  These are initialized to the 
;;; :Block-Compile and :Entry-Points arguments that COMPILE-FILE was called
;;; with.  Subsequent START-BLOCK or END-BLOCK declarations alter the values.

;;;

;;; *Block-Compile-Argument* holds the original value of the :block-compile
;;; argument, which overrides any internal declarations.
;;;

(defvar *block-compile*)

(defvar *block-compile-argument*)
(declaim (type (member nil t :specified)
	       *block-compile* *block-compile-argument*))

(defvar *entry-points*)
(declaim (list *entry-points*))

;;;

;;; When block compiling, used by PROCESS-FORM to accumulate top-level lambdas
;;; resulting from compiling subforms.  (In reverse order.)
;;;
(defvar *top-level-lambdas*)

(declaim (list *top-level-lambdas*))

(defvar *compile-verbose* t

  "The default for the :VERBOSE argument to COMPILE-FILE.")

(defvar *compile-print* t

  "The default for the :PRINT argument to COMPILE-FILE.")

(defvar *compile-progress* nil

  "The default for the :PROGRESS argument to COMPILE-FILE.")

(defvar *compile-file-pathname* nil

  "The defaulted pathname of the file currently being compiled, or NIL if not

  compiling.")
(defvar *compile-file-truename* nil

  "The TRUENAME of the file currently being compiled, or NIL if not

  compiling.")

(declaim (type (or pathname null) *compile-file-pathname*
	       *compile-file-truename*))

;;; The values of *Package* and policy when compilation started.

;;;
(defvar *initial-package*)
(defvar *initial-cookie*)

(defvar *initial-interface-cookie*)

;;; The source-info structure for the current compilation.  This is null
;;; globally to indicate that we aren't currently in any identifiable
;;; compilation.
;;;
(defvar *source-info* nil)

(defvar *user-source-info* nil

  "The user supplied source-info for the current compilation.  

  This is the :source-info argument to COMPILE-FROM-STREAM and will be
  stored in the INFO slot of the DEBUG-SOURCE in code components and 
  in the user USER-INFO slot of STREAM-SOURCE-LOCATIONs.")

;;; Maybe-Mumble  --  Internal
;;;

;;;    Mumble conditional on *compile-progress*.

;;;
(defun maybe-mumble (&rest foo)

  (when *compile-progress*

    (apply #'compiler-mumble foo)))

(deftype object () '(or fasl-file core-object null))

(defvar *compile-object* nil)
(declaim (type object *compile-object*))


;;;; Component compilation:

(defparameter max-optimize-iterations 6

  "The upper limit on the number of times that we will consecutively do IR1

  optimization that doesn't introduce any new code.  A finite limit is
  necessary, since type inference may take arbitrarily long to converge.")

(defevent ir1-optimize-until-done "IR1-OPTIMIZE-UNTIL-DONE called.")
(defevent ir1-optimize-maxed-out "Hit MAX-OPTIMIZE-ITERATIONS limit.")

;;; IR1-Optimize-Until-Done  --  Internal
;;;
;;;    Repeatedly optimize Component until no further optimizations can be
;;; found or we hit our iteration limit.  When we hit the limit, we clear the

;;; component and block REOPTIMIZE flags to discourage the following

;;; optimization attempt from pounding on the same code.
;;;
(defun ir1-optimize-until-done (component)
  (declare (type component component))
  (maybe-mumble "Opt")
  (event ir1-optimize-until-done)
  (let ((count 0)
	(cleared-reanalyze nil))
    (loop
      (when (component-reanalyze component)

	(setf count 0)
	(setf cleared-reanalyze t)

	(setf (component-reanalyze component) nil))
      (setf (component-reoptimize component) nil)
      (ir1-optimize component)

      (cond ((component-reoptimize component)
	     (incf count)
	     (when (= count max-optimize-iterations)
	       (maybe-mumble "*")
	       (cond ((retry-delayed-transforms :optimize)
		      (maybe-mumble "+")
		      (setf count 0))
		     (t
		      (event ir1-optimize-maxed-out)
		      (setf (component-reoptimize component) nil)
		      (do-blocks (block component)
			(setf (block-reoptimize block) nil))
		      (return)))))
	    ((retry-delayed-transforms :optimize)
	     (setf count 0)
	     (maybe-mumble "+"))
	    (t
	     (return)))

      (maybe-mumble "."))
    (when cleared-reanalyze

      (setf (component-reanalyze component) t))
    (maybe-mumble " "))

  (undefined-value))

(defparameter *constraint-propagate* t)

(defparameter *reoptimize-after-type-check-max* 10)

(defevent reoptimize-maxed-out

  "*REOPTIMIZE-AFTER-TYPE-CHECK-MAX* exceeded.")

;;; DFO-AS-NEEDED  --  Internal
;;;
;;;    Iterate doing FIND-DFO until no new dead code is discovered.
;;;
(defun dfo-as-needed (component)
  (declare (type component component))
  (when (component-reanalyze component)
    (maybe-mumble "DFO")
    (loop
      (find-dfo component)
      (unless (component-reanalyze component)
	(maybe-mumble " ")
	(return))
      (maybe-mumble ".")))
  (undefined-value))

;;; IR1-Phases  --  Internal
;;;
;;;    Do all the IR1 phases for a non-top-level component.
;;;
(defun ir1-phases (component)
  (declare (type component component))

  (let ((*constraint-number* 0)

	(loop-count 1)
	(*delayed-transforms* nil))

    (declare (special *constraint-number* *delayed-transforms*))

    (loop

     (ir1-optimize-until-done component)
     (when (or (component-new-functions component)
	       (component-reanalyze-functions component))
       (maybe-mumble "Locall ")
       (local-call-analyze component))
     (dfo-as-needed component)
     (when *constraint-propagate*
       (maybe-mumble "Constraint ")
       (constraint-propagate component))
     (when (retry-delayed-transforms :constraint)
       (maybe-mumble "Rtran "))
     ;; Delay the generation of type checks until the type constraints have
     ;; had time to propagate, else the compiler can confuse itself.
     (unless (and (or (component-reoptimize component)
		      (component-reanalyze component)
		      (component-new-functions component)
		      (component-reanalyze-functions component))
		  (< loop-count (- *reoptimize-after-type-check-max* 4)))
       (maybe-mumble "Type ")
       (generate-type-checks component)
       (unless (or (component-reoptimize component)
		   (component-reanalyze component)
		   (component-new-functions component)
		   (component-reanalyze-functions component))
	 (return)))
     (when (>= loop-count *reoptimize-after-type-check-max*)
       (maybe-mumble "[Reoptimize Limit]")
       (event reoptimize-maxed-out)
       (return))
     (incf loop-count)))

  (ir1-finalize component)

  (undefined-value))

;;; Native-Compile-Component  --  Internal

;;;

(defun native-compile-component (component)
  (let ((*code-segment* nil)

	(*elsewhere* nil)
	(*elsewhere-label* nil))

    (maybe-mumble "GTN ")
    (gtn-analyze component)
    (maybe-mumble "LTN ")
    (ltn-analyze component)

    (dfo-as-needed component)

    (maybe-mumble "Control ")

    (control-analyze component #'make-ir2-block)

    (when (ir2-component-values-receivers (component-info component))
      (maybe-mumble "Stack ")

      (stack-analyze component)
      ;;
      ;; Assign BLOCK-NUMBER for any cleanup blocks introduced by stack
      ;; analysis.  There shouldn't be any unreachable code after control, so
      ;; this won't delete anything.
      (dfo-as-needed component))

    (unwind-protect
	(progn
	  (maybe-mumble "IR2Tran ")
	  (init-assembler)
	  (entry-analyze component)
	  (ir2-convert component)
	  
	  (when (policy nil (>= speed cspeed))
	    (maybe-mumble "Copy ")
	    (copy-propagate component))
	  
	  (select-representations component)
	  
	  (when *check-consistency*
	    (maybe-mumble "Check2 ")
	    (check-ir2-consistency component))
	  
	  (delete-unreferenced-tns component)
	  
	  (maybe-mumble "Life ")
	  (lifetime-analyze component)
	  
	  (when *compile-progress*
	    (compiler-mumble "") ; Sync before doing random output.
	    (pre-pack-tn-stats component *compiler-error-output*))
	  
	  (when *check-consistency*
	    (maybe-mumble "CheckL ")
	    (check-life-consistency component))

	  (maybe-mumble "Pack ")
	  (pack component)
	  
	  (when *check-consistency*
	    (maybe-mumble "CheckP ")
	    (check-pack-consistency component))
	  
	  (when *compiler-trace-output*

	    (describe-component component *compiler-trace-output*)
	    (describe-ir2-component component *compiler-trace-output*))

	  
	  (maybe-mumble "Code ")
	  (multiple-value-bind
	      (length trace-table fixups)
	      (generate-code component)

	    (when (and *compiler-trace-output*
		       (backend-disassem-params *backend*))

	      (format *compiler-trace-output*

		      (intl:gettext "~|~%Disassembly of code for ~S~2%") component)

	      (disassem:disassemble-assem-segment *code-segment*
						  *compiler-trace-output*
						  *backend*))

	    (etypecase *compile-object*
	      (fasl-file
	       (maybe-mumble "FASL")
	       (fasl-dump-component component *code-segment*
				    length trace-table fixups
				    *compile-object*))
	      (core-object
	       (maybe-mumble "Core")
	       (make-core-component component *code-segment*

				    length trace-table fixups
				    *compile-object*))

	      (null))))

      (when *code-segment*
	(new-assem:release-segment *code-segment*))
      (when *elsewhere*
	(new-assem:release-segment *elsewhere*))))

  ;; We are done, so don't bother keeping anything around.

  (nuke-ir2-component component)
  (setf (component-info component) nil)

  
  (undefined-value))

;;; BYTE-COMPILING  --  Interface
;;;
;;;    Return our best guess for whether we will byte compile code currently
;;; being IR1 converted.  Only a guess because the decision is made on a

;;; per-component basis.

;;;

(defun byte-compiling ()

  (if (eq *byte-compiling* :maybe)

      (or (eq *byte-compile* t)

	  (policy nil (zerop speed) (<= debug 1)))

      (and *byte-compile* *byte-compiling*)))

;;; DELETE-IF-NO-ENTRIES  --  Internal
;;;
;;;    Delete components with no external entry points before we try to
;;; generate code.  Unreachable closures can cause IR2 conversion to puke on
;;; itself, since it is the reference to the closure which normally causes the
;;; components to be combined.  This doesn't really cover all cases...
;;;
(defun delete-if-no-entries (component)
  (dolist (fun (component-lambdas component)
	       (delete-component component))
    (case (functional-kind fun)
      (:top-level (return))
      (:external
       (unless (every #'(lambda (ref)
			  (eq (block-component (node-block ref))
			      component))
		      (leaf-refs fun))
	 (return))))))

;;; COMPILE-COMPONENT -- internal.
;;;
(defun compile-component (component)

  (let* ((*compile-component* component)

	 (*byte-compiling*

	  (ecase *byte-compile*
	    ((t) t)
	    ((nil) nil)
	    (:maybe

	     (dolist (fun (component-lambdas component) t)
	       (unless (policy (lambda-bind fun)

			       (zerop speed) (<= debug 1))

		 (return nil)))))))

    (when *compile-print*

      (compiler-mumble "~&")
      (pprint-logical-block (*compiler-error-output* nil :per-line-prefix "; ")

	(compiler-mumble (intl:gettext "~:[~;Byte ~]Compiling ~A: ")

		       *byte-compiling*

		       (component-name component))))

    (ir1-phases component)

    (when *loop-analyze*
      (dfo-as-needed component)
      (maybe-mumble "Dom ")
      (find-dominators component)
      (maybe-mumble "Loop ")
      (loop-analyze component))

    (maybe-mumble "Env ")
    (environment-analyze component)
    (dfo-as-needed component)

    (delete-if-no-entries component)

    (when *record-xref-info*
      (maybe-mumble "[record-xref-info]~%")
      (record-component-xrefs component))

    (unless (eq (block-next (component-head component))
		(component-tail component))
      (if *byte-compiling*
	  (byte-compile-component component)
	  (native-compile-component component))))

  (clear-constant-info)

  (when *compile-print*
    (compiler-mumble "~&"))

  (undefined-value))


;;;; Clearing global data structures:

;;; CLEAR-CONSTANT-INFO  --  Internal

;;;

;;;    Clear the INFO in constants in the *FREE-VARIABLES*, etc.  In addition
;;; to allowing stuff to be reclaimed, this is required for correct assignment
;;; of constant offsets, since we need to assign a new offset for each
;;; component.  We don't clear the FUNCTIONAL-INFO slots, since they are used
;;; to keep track of functions across component boundaries.

;;;

(defun clear-constant-info ()

  (maphash #'(lambda (k v)
	       (declare (ignore k))
	       (setf (leaf-info v) nil))
	   *constants*)

  (maphash #'(lambda (k v)
	       (declare (ignore k))
	       (when (constant-p v)
		 (setf (leaf-info v) nil)))
	   *free-variables*)

  (undefined-value))

;;; CLEAR-IR1-INFO  --  Internal
;;;
;;;    Blow away the REFS for all global variables, and recycle the IR1 for
;;; Component.
;;;
(defun clear-ir1-info (component)
  (declare (type component component))

  (labels ((blast (x)
	     (maphash #'(lambda (k v)
			  (declare (ignore k))

			  (when (leaf-p v)
			    (setf (leaf-refs v)
				  (delete-if #'here-p (leaf-refs v)))
			    (when (basic-var-p v)
			      (setf (basic-var-sets v)
				    (delete-if #'here-p (basic-var-sets v))))))

		      x))
	   (here-p (x)
	     (eq (block-component (node-block x)) component)))

    (blast *free-variables*)
    (blast *free-functions*)
    (blast *constants*))
  (macerate-ir1-component component)
  (undefined-value))

;;; CLEAR-STUFF  --  Interface

;;;
;;;    Clear all the global variables used by the compiler.

;;;

(defun clear-stuff (&optional (debug-too t))

  ;;
  ;; Clear global tables.

  (when (boundp '*free-functions*)
    (clrhash *free-functions*)
    (clrhash *free-variables*)
    (clrhash *constants*))

  (when debug-too
    (clrhash *continuation-numbers*)
    (clrhash *number-continuations*)
    (setq *continuation-number* 0)
    (clrhash *tn-ids*)
    (clrhash *id-tns*)
    (setq *tn-id* 0)
    (clrhash *label-ids*)
    (clrhash *id-labels*)

    (setq *label-id* 0)
    ;;
    ;; Clear some Pack data structures (for GC purposes only.)
    (assert (not *in-pack*))
    (dolist (sb (backend-sb-list *backend*))
      (when (finite-sb-p sb)
	(fill (finite-sb-live-tns sb) nil))))

  ;;
  ;; Reset Gensym.

  (setq lisp:*gensym-counter* 0)

  (values))

;;; PRINT-SUMMARY  --  Interface
;;;
;;;    This function is called by WITH-COMPILATION-UNIT at the end of a
;;; compilation unit.  It prints out any residual unknown function warnings and

;;; the total error counts.  ABORT-P should be true when the compilation unit
;;; was aborted by throwing out.  ABORT-COUNT is the number of dynamically

;;; enclosed nested compilation units that were aborted.
;;;
(defun print-summary (abort-p abort-count)
  (unless abort-p

    (handler-bind ((warning #'compiler-warning-handler))
      (let ((undefs (sort *undefined-warnings* #'string<
			  :key #'(lambda (x)
				   (let ((x (undefined-warning-name x)))
				     (if (symbolp x)
					 (symbol-name x)
					 (prin1-to-string x)))))))
	(unless *converting-for-interpreter*
	  (dolist (undef undefs)
	    (let ((name (undefined-warning-name undef))
		  (kind (undefined-warning-kind undef))

                  (context (undefined-warning-context undef))

		  (warnings (undefined-warning-warnings undef))
		  (count (undefined-warning-count undef)))
	      (dolist (*compiler-error-context* warnings)

		(compiler-warning _N"Undefined ~(~A~) ~S~@[ ~A~]" kind name context))

	      
	      (let ((warn-count (length warnings)))
		(when (and warnings (> count warn-count))
		  (let ((more (- count warn-count)))

		    (compiler-warning _N"~D more use~:P of undefined ~(~A~) ~S."

				      more kind name)))))))
	
	(dolist (kind '(:variable :function :type))
	  (let ((summary (mapcar #'undefined-warning-name
				 (remove kind undefs :test-not #'eq
					 :key #'undefined-warning-kind))))
	    (when summary
	      (compiler-warning

	       _N"~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~

		~%  ~{~<~%  ~1:;~S~>~^ ~}"
	       (cdr summary) kind summary)))))))

  (unless (or *converting-for-interpreter*
	      (and (not abort-p) (zerop abort-count)
		   (zerop *compiler-error-count*)
		   (zerop *compiler-warning-count*)
		   (zerop *compiler-note-count*)))

    (compiler-mumble

     (intl:gettext "~2&; Compilation unit ~:[finished~;aborted~].~

      ~[~:;~:*~&;   ~D fatal error~:P~]~
      ~[~:;~:*~&;   ~D error~:P~]~
      ~[~:;~:*~&;   ~D warning~:P~]~

      ~[~:;~:*~&;   ~D note~:P~]~2%")

     abort-p
     abort-count
     *compiler-error-count*
     *compiler-warning-count*
     *compiler-note-count*)))

;;;; Trace output:

;;; Describe-Component  --  Internal
;;;
;;;    Print out some useful info about Component to Stream.
;;;

(defun describe-component (component *standard-output*)

  (declare (type component component))

  (format t (intl:gettext "~|~%;;;; Component: ~S~2%") (component-name component))

  (print-blocks component)  
  (undefined-value))


(defun describe-ir2-component (component *standard-output*)

  (format t (intl:gettext "~%~|~%;;;; IR2 component: ~S~2%") (component-name component))

  (format t (intl:gettext "Entries:~%"))

  (dolist (entry (ir2-component-entries (component-info component)))

    (format t (intl:gettext "~4TL~D: ~S~:[~; [Closure]~]~%")

	    (label-id (entry-info-offset entry))
	    (entry-info-name entry)
	    (entry-info-closure-p entry)))

  (terpri)
  (pre-pack-tn-stats component *standard-output*)
  (terpri)
  (print-ir2-blocks component)
  (terpri)

  (undefined-value))


;;;; File reading:
;;;
;;;    When reading from a file, we have to keep track of some source
;;; information.  We also exploit our ability to back up for printing the error
;;; context and for recovering from errors.
;;;
;;; The interface we provide to this stuff is the stream-oid Source-Info
;;; structure.  The bookkeeping is done as a side-effect of getting the next
;;; source form.


;;; The File-Info structure holds all the source information for a given file.
;;;
(defstruct file-info
  ;;
  ;; If a file, the truename of the corresponding source file.  If from a Lisp
  ;; form, :LISP, if from a stream, :STREAM.

  (name (required-argument) :type (or pathname (member :lisp :stream)))

  ;;

  ;; The defaulted, but not necessarily absolute file name (i.e. prior to

  ;; TRUENAME call.)  Null if not a file.  This is used to set
  ;; *COMPILE-FILE-PATHNAME*, and if absolute, is dumped in the debug-info.
  (untruename nil :type (or pathname null))

  ;;

  ;; The file's write date (if relevant.)
  (write-date nil :type (or unsigned-byte null))
  ;;

  ;; This file's FILE-COMMENT, or NIL if none.
  (comment nil :type (or simple-string null))
  ;;

  ;; The source path root number of the first form in this file (i.e. the
  ;; total number of forms converted previously in this compilation.)
  (source-root 0 :type unsigned-byte)
  ;;
  ;; Parallel vectors containing the forms read out of the file and the file
  ;; positions that reading of each form started at (i.e. the end of the
  ;; previous form.)

  (forms (make-array 10 :fill-pointer 0 :adjustable t) :type (vector t))

  (positions (make-array 10 :fill-pointer 0 :adjustable t) :type (vector t))
  ;;
  ;; Language to use.  Normally Lisp, but sometimes Dylan.

  (language :lisp :type (member :lisp #+nil :dylan)))

;;; The Source-Info structure provides a handle on all the source information
;;; for an entire compilation.
;;;
(defstruct (source-info
	    (:print-function
	     (lambda (s stream d)
	       (declare (ignore s d))
	       (format stream "#<Source-Info>"))))
  ;;
  ;; The UT that compilation started at.
  (start-time (get-universal-time) :type unsigned-byte)
  ;;
  ;; A list of the file-info structures for this compilation.
  (files nil :type list)
  ;;
  ;; The tail of the Files for the file we are currently reading.
  (current-file nil :type list)
  ;;
  ;; The stream that we are using to read the Current-File.  Null if no stream
  ;; has been opened yet.

  (stream nil :type (or stream null))
  ;;
  ;; External format to use for the stream if the stream hasn't been opened
  #+unicode

  (external-format :default)
  ;;
  ;; How to handle decoding errors when reading the source file.
  ;; Default is T to signal an error.
  #+unicode
  (decoding-error t))

;;; Make-File-Source-Info  --  Internal
;;;
;;;    Given a list of pathnames, return a Source-Info structure.
;;;

(defun make-file-source-info (files external-format decoding-error)

  (declare (list files))
  (let ((file-info
	 (mapcar #'(lambda (x)

		     (make-file-info :name (truename x)

				     :untruename x

				     :write-date (file-write-date x)

				     :language :lisp))

		 files)))
    (make-source-info :files file-info

		      :current-file file-info
		      #+unicode :external-format

		      #+unicode external-format

		      #+unicode :decoding-error
		      #+unicode decoding-error)))

;;; MAKE-LISP-SOURCE-INFO  --  Interface
;;;
;;;    Return a SOURCE-INFO to describe the incremental compilation of Form.
;;; Also used by EVAL:INTERNAL-EVAL.
;;;
(defun make-lisp-source-info (form)
  (make-source-info
   :start-time (get-universal-time)
   :files (list (make-file-info :name :lisp
				:forms (vector form)
				:positions '#(0)))))


;;; MAKE-STREAM-SOURCE-INFO  --  Internal
;;;
;;;    Return a SOURCE-INFO which will read from Stream.
;;;

(defun make-stream-source-info (stream language)

  (declare (type (member :lisp) language))

  (let ((files (list (make-file-info :name :stream :language language))))

    (make-source-info
     :files files
     :current-file files
     :stream stream)))


;;; Normal-Read-Error  --  Internal
;;;
;;;    Print an error message for a non-EOF error on Stream.  Old-Pos is a
;;; preceding file position that hopefully comes before the beginning of the
;;; line.  Of course, this only works on streams that support the file-position
;;; operation.
;;;
(defun normal-read-error (stream old-pos condition)

  (declare (type stream stream) (type unsigned-byte old-pos))

  (let ((pos (file-position stream)))
    (file-position stream old-pos)
    (let ((start old-pos))
      (loop
	(let ((line (read-line stream nil))
	      (end (file-position stream)))
	  (when (>= end pos)