0.8.19.30: less COMPILE-FILE verbosity
[sbcl.git] / src / compiler / main.lisp
index aabf3da..3465260 100644 (file)
 (defvar *toplevel-lambdas*)
 (declaim (list *toplevel-lambdas*))
 
 (defvar *toplevel-lambdas*)
 (declaim (list *toplevel-lambdas*))
 
+;;; The current non-macroexpanded toplevel form as printed when
+;;; *compile-print* is true.
+(defvar *top-level-form-noted* nil)
+
 (defvar sb!xc:*compile-verbose* t
   #!+sb-doc
   "The default for the :VERBOSE argument to COMPILE-FILE.")
 (defvar sb!xc:*compile-verbose* t
   #!+sb-doc
   "The default for the :VERBOSE argument to COMPILE-FILE.")
@@ -69,7 +73,7 @@
   "The default for the :PRINT argument to COMPILE-FILE.")
 (defvar *compile-progress* nil
   #!+sb-doc
   "The default for the :PRINT argument to COMPILE-FILE.")
 (defvar *compile-progress* nil
   #!+sb-doc
-  "When this is true, the compiler prints to *ERROR-OUTPUT* progress
+  "When this is true, the compiler prints to *STANDARD-OUTPUT* progress
   information about the phases of compilation of each function. (This
   is useful mainly in large block compilations.)")
 
   information about the phases of compilation of each function. (This
   is useful mainly in large block compilations.)")
 
 (defun maybe-mumble (&rest foo)
   (when *compile-progress*
     (compiler-mumble "~&")
 (defun maybe-mumble (&rest foo)
   (when *compile-progress*
     (compiler-mumble "~&")
-    (pprint-logical-block (*error-output* nil :per-line-prefix "; ")
+    (pprint-logical-block (*standard-output* nil :per-line-prefix "; ")
        (apply #'compiler-mumble foo))))
 
 (deftype object () '(or fasl-output core-object null))
        (apply #'compiler-mumble foo))))
 
 (deftype object () '(or fasl-output core-object null))
               (zerop *compiler-warning-count*)
               (zerop *compiler-style-warning-count*)
               (zerop *compiler-note-count*))
               (zerop *compiler-warning-count*)
               (zerop *compiler-style-warning-count*)
               (zerop *compiler-note-count*))
-    (format *error-output* "~&")
-    (pprint-logical-block (*error-output* nil :per-line-prefix "; ")
+    (fresh-line *standard-output*)
+    (pprint-logical-block (*standard-output* nil :per-line-prefix "; ")
       (compiler-mumble "compilation unit ~:[finished~;aborted~]~
                        ~[~:;~:*~&  caught ~W fatal ERROR condition~:P~]~
                        ~[~:;~:*~&  caught ~W ERROR condition~:P~]~
       (compiler-mumble "compilation unit ~:[finished~;aborted~]~
                        ~[~:;~:*~&  caught ~W fatal ERROR condition~:P~]~
                        ~[~:;~:*~&  caught ~W ERROR condition~:P~]~
                       *compiler-warning-count*
                       *compiler-style-warning-count*
                       *compiler-note-count*)))
                       *compiler-warning-count*
                       *compiler-style-warning-count*
                       *compiler-note-count*)))
-  (format *error-output* "~&"))
+  (fresh-line *standard-output*))
 
 ;;; Evaluate BODY, then return (VALUES BODY-VALUE WARNINGS-P
 ;;; FAILURE-P), where BODY-VALUE is the first value of the body, and
 
 ;;; Evaluate BODY, then return (VALUES BODY-VALUE WARNINGS-P
 ;;; FAILURE-P), where BODY-VALUE is the first value of the body, and
 
          (when *compile-progress*
            (compiler-mumble "") ; Sync before doing more output.
 
          (when *compile-progress*
            (compiler-mumble "") ; Sync before doing more output.
-           (pre-pack-tn-stats component *error-output*))
+           (pre-pack-tn-stats component *standard-output*))
 
          (when *check-consistency*
            (maybe-mumble "check-life ")
 
          (when *check-consistency*
            (maybe-mumble "check-life ")
     (aver (eql (node-component (lambda-bind lambda)) component)))
 
   (let* ((*component-being-compiled* component))
     (aver (eql (node-component (lambda-bind lambda)) component)))
 
   (let* ((*component-being-compiled* component))
-    (when sb!xc:*compile-print*
-      (compiler-mumble "~&; compiling ~A: " (component-name component)))
 
     (ir1-phases component)
 
 
     (ir1-phases component)
 
       (%compile-component component)))
 
   (clear-constant-info)
       (%compile-component component)))
 
   (clear-constant-info)
-
-  (when sb!xc:*compile-print*
-    (compiler-mumble "~&"))
-
+  
   (values))
 \f
 ;;;; clearing global data structures
   (values))
 \f
 ;;;; clearing global data structures
     (format t "~4TL~D: ~S~:[~; [closure]~]~%"
            (label-id (entry-info-offset entry))
            (entry-info-name entry)
     (format t "~4TL~D: ~S~:[~; [closure]~]~%"
            (label-id (entry-info-offset entry))
            (entry-info-name entry)
-           (entry-info-closure-p entry)))
+           (entry-info-closure-tn entry)))
   (terpri)
   (pre-pack-tn-stats component *standard-output*)
   (terpri)
   (terpri)
   (pre-pack-tn-stats component *standard-output*)
   (terpri)
   ;; If a file, the truename of the corresponding source file. If from
   ;; a Lisp form, :LISP. If from a stream, :STREAM.
   (name (missing-arg) :type (or pathname (member :lisp :stream)))
   ;; If a file, the truename of the corresponding source file. If from
   ;; a Lisp form, :LISP. If from a stream, :STREAM.
   (name (missing-arg) :type (or pathname (member :lisp :stream)))
+  ;; the external format that we'll call OPEN with, if NAME is a file.
+  (external-format nil)
   ;; 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
   ;; 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
   (stream nil :type (or stream null)))
 
 ;;; Given a pathname, return a SOURCE-INFO structure.
   (stream nil :type (or stream null)))
 
 ;;; Given a pathname, return a SOURCE-INFO structure.
-(defun make-file-source-info (file)
+(defun make-file-source-info (file external-format)
   (let ((file-info (make-file-info :name (truename file)
                                   :untruename file
   (let ((file-info (make-file-info :name (truename file)
                                   :untruename file
+                                   :external-format external-format
                                   :write-date (file-write-date file))))
 
     (make-source-info :file-info file-info)))
                                   :write-date (file-write-date file))))
 
     (make-source-info :file-info file-info)))
   (declare (type source-info info))
   (or (source-info-stream info)
       (let* ((file-info (source-info-file-info info))
   (declare (type source-info info))
   (or (source-info-stream info)
       (let* ((file-info (source-info-file-info info))
-            (name (file-info-name file-info)))
+            (name (file-info-name file-info))
+             (external-format (file-info-external-format file-info)))
        (setf sb!xc:*compile-file-truename* name
              sb!xc:*compile-file-pathname* (file-info-untruename file-info)
        (setf sb!xc:*compile-file-truename* name
              sb!xc:*compile-file-pathname* (file-info-untruename file-info)
-             (source-info-stream info) (open name :direction :input)))))
+             (source-info-stream info)
+              (open name :direction :input
+                    :external-format external-format)))))
 
 ;;; Close the stream in INFO if it is open.
 (defun close-source-info (info)
 
 ;;; Close the stream in INFO if it is open.
 (defun close-source-info (info)
 ;;; *TOPLEVEL-LAMBDAS* instead.
 (defun convert-and-maybe-compile (form path)
   (declare (list path))
 ;;; *TOPLEVEL-LAMBDAS* instead.
 (defun convert-and-maybe-compile (form path)
   (declare (list path))
-  (let* ((*lexenv* (make-lexenv :policy *policy*
-                               :handled-conditions *handled-conditions*
-                               :disabled-package-locks *disabled-package-locks*))
+  (let* ((*top-level-form-noted* (note-top-level-form form t))
+         (*lexenv* (make-lexenv 
+                    :policy *policy*
+                    :handled-conditions *handled-conditions*
+                    :disabled-package-locks *disabled-package-locks*))
         (tll (ir1-toplevel form path nil)))
         (tll (ir1-toplevel form path nil)))
-    (cond ((eq *block-compile* t) (push tll *toplevel-lambdas*))
-         (t (compile-toplevel (list tll) nil)))))
+    (if (eq *block-compile* t) 
+        (push tll *toplevel-lambdas*)
+        (compile-toplevel (list tll) nil))
+    nil))
 
 ;;; Macroexpand FORM in the current environment with an error handler.
 ;;; We only expand one level, so that we retain all the intervening
 
 ;;; Macroexpand FORM in the current environment with an error handler.
 ;;; We only expand one level, so that we retain all the intervening
 (defun preprocessor-macroexpand-1 (form)
   (handler-case (sb!xc:macroexpand-1 form *lexenv*)
     (error (condition)
 (defun preprocessor-macroexpand-1 (form)
   (handler-case (sb!xc:macroexpand-1 form *lexenv*)
     (error (condition)
-      (signal condition)
       (compiler-error "(during macroexpansion of ~A)~%~A"
       (compiler-error "(during macroexpansion of ~A)~%~A"
-                     (let ((*print-level* 1)
+                     (let ((*print-level* 2)
                            (*print-length* 2))
                        (format nil "~S" form))
                      condition))))
                            (*print-length* 2))
                        (format nil "~S" form))
                      condition))))
     ;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..)
 
     (locall-analyze-clambdas-until-done (list fun))
     ;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..)
 
     (locall-analyze-clambdas-until-done (list fun))
-    
+
     (multiple-value-bind (components-from-dfo top-components hairy-top)
         (find-initial-dfo (list fun))
     (multiple-value-bind (components-from-dfo top-components hairy-top)
         (find-initial-dfo (list fun))
+      (declare (ignore hairy-top))
 
       (let ((*all-components* (append components-from-dfo top-components)))
 
       (let ((*all-components* (append components-from-dfo top-components)))
-       ;; FIXME: This is more monkey see monkey do based on CMU CL
-       ;; code. If anyone figures out why to only prescan HAIRY-TOP
-       ;; and TOP-COMPONENTS here, instead of *ALL-COMPONENTS* or
-       ;; some other combination of results from FIND-INITIAL-VALUES,
-       ;; it'd be good to explain it.
-       (mapc #'preallocate-physenvs-for-toplevelish-lambdas hairy-top)
-       (mapc #'preallocate-physenvs-for-toplevelish-lambdas top-components)
         (dolist (component-from-dfo components-from-dfo)
           (compile-component component-from-dfo)
           (replace-toplevel-xeps component-from-dfo)))
         (dolist (component-from-dfo components-from-dfo)
           (compile-component component-from-dfo)
           (replace-toplevel-xeps component-from-dfo)))
                        *compile-object*)
   (values))
 
                        *compile-object*)
   (values))
 
+(defun note-top-level-form (form &optional finalp)
+  (when *compile-print*
+    (cond ((not *top-level-form-noted*)
+           (let ((*print-length* 2)
+                 (*print-level* 2)
+                 (*print-pretty* nil))
+             (with-compiler-io-syntax
+                 (compiler-mumble "~&; ~:[compiling~;converting~] ~S" 
+                                  *block-compile* form)))
+             form)
+          ((and finalp
+                (eq :top-level-forms *compile-print*)
+                (neq form *top-level-form-noted*))
+           (let ((*print-length* 1)
+                 (*print-level* 1)
+                 (*print-pretty* nil))
+             (with-compiler-io-syntax
+                 (compiler-mumble "~&; ... top level ~S" form)))
+           form)
+          (t
+           *top-level-form-noted*))))
+
 ;;; Process a top level FORM with the specified source PATH.
 ;;;  * If this is a magic top level form, then do stuff.
 ;;;  * If this is a macro, then expand it.
 ;;; Process a top level FORM with the specified source PATH.
 ;;;  * If this is a magic top level form, then do stuff.
 ;;;  * If this is a macro, then expand it.
 ;;; COMPILE-TIME-TOO is as defined in ANSI
 ;;; "3.2.3.1 Processing of Top Level Forms".
 (defun process-toplevel-form (form path compile-time-too)
 ;;; COMPILE-TIME-TOO is as defined in ANSI
 ;;; "3.2.3.1 Processing of Top Level Forms".
 (defun process-toplevel-form (form path compile-time-too)
-
   (declare (list path))
 
   (declare (list path))
 
-  (catch 'process-toplevel-form-error-abort
+  (catch 'process-toplevel-form-error-abort    
     (let* ((path (or (gethash form *source-paths*) (cons form path)))
           (*compiler-error-bailout*
            (lambda (&optional condition)
     (let* ((path (or (gethash form *source-paths*) (cons form path)))
           (*compiler-error-bailout*
            (lambda (&optional condition)
              (throw 'process-toplevel-form-error-abort nil))))
 
       (flet ((default-processor (form)
              (throw 'process-toplevel-form-error-abort nil))))
 
       (flet ((default-processor (form)
-               ;; When we're cross-compiling, consider: what should we
-               ;; do when we hit e.g.
-               ;;   (EVAL-WHEN (:COMPILE-TOPLEVEL)
-               ;;     (DEFUN FOO (X) (+ 7 X)))?
-               ;; DEFUN has a macro definition in the cross-compiler,
-               ;; and a different macro definition in the target
-               ;; compiler. The only sensible thing is to use the
-               ;; target compiler's macro definition, since the
-               ;; cross-compiler's macro is in general into target
-               ;; functions which can't meaningfully be executed at
-               ;; cross-compilation time. So make sure we do the EVAL
-               ;; here, before we macroexpand.
-               ;;
-               ;; Then things get even dicier with something like
-               ;;   (DEFCONSTANT-EQX SB!XC:LAMBDA-LIST-KEYWORDS ..)
-               ;; where we have to make sure that we don't uncross
-               ;; the SB!XC: prefix before we do EVAL, because otherwise
-               ;; we'd be trying to redefine the cross-compilation host's
-               ;; constants.
-               ;;
-               ;; (Isn't it fun to cross-compile Common Lisp?:-)
-               #+sb-xc-host
-               (progn
-                 (when compile-time-too
-                   (eval form)) ; letting xc host EVAL do its own macroexpansion
-                 (let* (;; (We uncross the operator name because things
-                        ;; like SB!XC:DEFCONSTANT and SB!XC:DEFTYPE
-                        ;; should be equivalent to their CL: counterparts
-                        ;; when being compiled as target code. We leave
-                        ;; the rest of the form uncrossed because macros
-                        ;; might yet expand into EVAL-WHEN stuff, and
-                        ;; things inside EVAL-WHEN can't be uncrossed
-                        ;; until after we've EVALed them in the
-                        ;; cross-compilation host.)
-                        (slightly-uncrossed (cons (uncross (first form))
-                                                  (rest form)))
-                        (expanded (preprocessor-macroexpand-1
-                                   slightly-uncrossed)))
-                   (if (eq expanded slightly-uncrossed)
-                       ;; (Now that we're no longer processing toplevel
-                       ;; forms, and hence no longer need to worry about
-                       ;; EVAL-WHEN, we can uncross everything.)
-                       (convert-and-maybe-compile expanded path)
-                       ;; (We have to demote COMPILE-TIME-TOO to NIL
-                       ;; here, no matter what it was before, since
-                       ;; otherwise we'd tend to EVAL subforms more than
-                       ;; once, because of WHEN COMPILE-TIME-TOO form
-                       ;; above.)
-                       (process-toplevel-form expanded path nil))))
-               ;; When we're not cross-compiling, we only need to
-               ;; macroexpand once, so we can follow the 1-thru-6
-               ;; sequence of steps in ANSI's "3.2.3.1 Processing of
-               ;; Top Level Forms".
-               #-sb-xc-host
-               (let ((expanded (preprocessor-macroexpand-1 form)))
-                (cond ((eq expanded form)
-                       (when compile-time-too
-                         (eval-in-lexenv form *lexenv*))
-                       (convert-and-maybe-compile form path))
-                      (t
-                       (process-toplevel-form expanded
-                                              path
-                                              compile-time-too))))))
+               (let ((*top-level-form-noted* (note-top-level-form form)))
+                 ;; When we're cross-compiling, consider: what should we
+                 ;; do when we hit e.g.
+                 ;;   (EVAL-WHEN (:COMPILE-TOPLEVEL)
+                 ;;     (DEFUN FOO (X) (+ 7 X)))?
+                 ;; DEFUN has a macro definition in the cross-compiler,
+                 ;; and a different macro definition in the target
+                 ;; compiler. The only sensible thing is to use the
+                 ;; target compiler's macro definition, since the
+                 ;; cross-compiler's macro is in general into target
+                 ;; functions which can't meaningfully be executed at
+                 ;; cross-compilation time. So make sure we do the EVAL
+                 ;; here, before we macroexpand.
+                 ;;
+                 ;; Then things get even dicier with something like
+                 ;;   (DEFCONSTANT-EQX SB!XC:LAMBDA-LIST-KEYWORDS ..)
+                 ;; where we have to make sure that we don't uncross
+                 ;; the SB!XC: prefix before we do EVAL, because otherwise
+                 ;; we'd be trying to redefine the cross-compilation host's
+                 ;; constants.
+                 ;;
+                 ;; (Isn't it fun to cross-compile Common Lisp?:-)
+                 #+sb-xc-host
+                 (progn
+                   (when compile-time-too
+                     (eval form)) ; letting xc host EVAL do its own macroexpansion
+                   (let* (;; (We uncross the operator name because things
+                          ;; like SB!XC:DEFCONSTANT and SB!XC:DEFTYPE
+                          ;; should be equivalent to their CL: counterparts
+                          ;; when being compiled as target code. We leave
+                          ;; the rest of the form uncrossed because macros
+                          ;; might yet expand into EVAL-WHEN stuff, and
+                          ;; things inside EVAL-WHEN can't be uncrossed
+                          ;; until after we've EVALed them in the
+                          ;; cross-compilation host.)
+                          (slightly-uncrossed (cons (uncross (first form))
+                                                    (rest form)))
+                          (expanded (preprocessor-macroexpand-1
+                                     slightly-uncrossed)))
+                     (if (eq expanded slightly-uncrossed)
+                         ;; (Now that we're no longer processing toplevel
+                         ;; forms, and hence no longer need to worry about
+                         ;; EVAL-WHEN, we can uncross everything.)
+                         (convert-and-maybe-compile expanded path)
+                         ;; (We have to demote COMPILE-TIME-TOO to NIL
+                         ;; here, no matter what it was before, since
+                         ;; otherwise we'd tend to EVAL subforms more than
+                         ;; once, because of WHEN COMPILE-TIME-TOO form
+                         ;; above.)
+                         (process-toplevel-form expanded path nil))))
+                 ;; When we're not cross-compiling, we only need to
+                 ;; macroexpand once, so we can follow the 1-thru-6
+                 ;; sequence of steps in ANSI's "3.2.3.1 Processing of
+                 ;; Top Level Forms".
+                 #-sb-xc-host
+                 (let ((expanded (preprocessor-macroexpand-1 form)))
+                   (cond ((eq expanded form)
+                          (when compile-time-too
+                            (eval-in-lexenv form *lexenv*))
+                          (convert-and-maybe-compile form path))
+                         (t
+                          (process-toplevel-form expanded
+                                                 path
+                                                 compile-time-too)))))))
         (if (atom form)
             #+sb-xc-host
             ;; (There are no xc EVAL-WHEN issues in the ATOM case until
         (if (atom form)
             #+sb-xc-host
             ;; (There are no xc EVAL-WHEN issues in the ATOM case until
 ;;; COMPILE-LOAD-TIME-VALUE stuff. -- WHN 20000201
 (defun compile-toplevel (lambdas load-time-value-p)
   (declare (list lambdas))
 ;;; COMPILE-LOAD-TIME-VALUE stuff. -- WHN 20000201
 (defun compile-toplevel (lambdas load-time-value-p)
   (declare (list lambdas))
-
+  
   (maybe-mumble "locall ")
   (locall-analyze-clambdas-until-done lambdas)
 
   (maybe-mumble "locall ")
   (locall-analyze-clambdas-until-done lambdas)
 
 ;;; compilation.
 (defun finish-block-compilation ()
   (when *block-compile*
 ;;; compilation.
 (defun finish-block-compilation ()
   (when *block-compile*
+    (when *compile-print*
+      (compiler-mumble "~&; block compiling converted top level forms..."))
     (when *toplevel-lambdas*
       (compile-toplevel (nreverse *toplevel-lambdas*) nil)
       (setq *toplevel-lambdas* ()))
     (when *toplevel-lambdas*
       (compile-toplevel (nreverse *toplevel-lambdas*) nil)
       (setq *toplevel-lambdas* ()))
         (*readtable* *readtable*)
         (sb!xc:*compile-file-pathname* nil) ; really bound in
         (sb!xc:*compile-file-truename* nil) ; SUB-SUB-COMPILE-FILE
         (*readtable* *readtable*)
         (sb!xc:*compile-file-pathname* nil) ; really bound in
         (sb!xc:*compile-file-truename* nil) ; SUB-SUB-COMPILE-FILE
-
         (*policy* *policy*)
        (*handled-conditions* *handled-conditions*)
        (*disabled-package-locks* *disabled-package-locks*)
         (*policy* *policy*)
        (*handled-conditions* *handled-conditions*)
        (*disabled-package-locks* *disabled-package-locks*)
       ;; the input file.
       (fatal-compiler-error (condition)
        (signal condition)
       ;; the input file.
       (fatal-compiler-error (condition)
        (signal condition)
-       (format *error-output*
-              "~@<compilation aborted because of fatal error: ~2I~_~A~:>"
-              condition)
+       (when *compile-verbose*
+         (format *standard-output*
+                 "~@<compilation aborted because of fatal error: ~2I~_~A~:>"
+                 condition))
        (values nil t t)))))
 
 ;;; Return a pathname for the named file. The file must exist.
        (values nil t t)))))
 
 ;;; Return a pathname for the named file. The file must exist.
       (format nil "~D:~2,'0D:~2,'0D" thr min sec))))
 
 ;;; Print some junk at the beginning and end of compilation.
       (format nil "~D:~2,'0D:~2,'0D" thr min sec))))
 
 ;;; Print some junk at the beginning and end of compilation.
-(defun start-error-output (source-info)
+(defun print-compile-start-note (source-info)
   (declare (type source-info source-info))
   (let ((file-info (source-info-file-info source-info)))
     (compiler-mumble "~&; compiling file ~S (written ~A):~%"
   (declare (type source-info source-info))
   (let ((file-info (source-info-file-info source-info)))
     (compiler-mumble "~&; compiling file ~S (written ~A):~%"
                                                   :print-weekday nil
                                                   :print-timezone nil)))
   (values))
                                                   :print-weekday nil
                                                   :print-timezone nil)))
   (values))
-(defun finish-error-output (source-info won)
+
+(defun print-compile-end-note (source-info won)
   (declare (type source-info source-info))
   (compiler-mumble "~&; compilation ~:[aborted after~;finished in~] ~A~&"
                   won
   (declare (type source-info source-info))
   (compiler-mumble "~&; compilation ~:[aborted after~;finished in~] ~A~&"
                   won
      ;; extensions
      (trace-file nil) 
      ((:block-compile *block-compile-arg*) nil))
      ;; extensions
      (trace-file nil) 
      ((:block-compile *block-compile-arg*) nil))
-
   #!+sb-doc
   #!+sb-doc
-  "Compile INPUT-FILE, producing a corresponding fasl file and returning
-   its filename. Besides the ANSI &KEY arguments :OUTPUT-FILE, :VERBOSE,
-   :PRINT, and :EXTERNAL-FORMAT,the following extensions are supported:
-     :TRACE-FILE
-        If given, internal data structures are dumped to the specified
-        file, or if a value of T is given, to a file of *.trace type
-        derived from the input file name.
-   Also, as a workaround for vaguely-non-ANSI behavior, the :BLOCK-COMPILE
-   argument is quasi-supported, to determine whether multiple
-   functions are compiled together as a unit, resolving function
-   references at compile time. NIL means that global function names
-   are never resolved at compilation time. Currently NIL is the
-   default behavior, because although section 3.2.2.3, \"Semantic
-   Constraints\", of the ANSI spec allows this behavior under all
-   circumstances, the compiler's runtime scales badly when it
-   tries to do this for large files. If/when this performance
-   problem is fixed, the block compilation default behavior will
-   probably be made dependent on the SPEED and COMPILATION-SPEED
-   optimization values, and the :BLOCK-COMPILE argument will probably
-   become deprecated."
-
-  (unless (eq external-format :default)
-    (error "Non-:DEFAULT EXTERNAL-FORMAT values are not supported."))
+  "Compile INPUT-FILE, producing a corresponding fasl file and
+returning its filename.
+
+  :PRINT
+     If true, a message per non-macroexpanded top level form is printed 
+     to *STANDARD-OUTPUT*. Top level forms that whose subforms are
+     processed as top level forms (eg. EVAL-WHEN, MACROLET, PROGN) receive
+     no such message, but their subforms do.
+
+     As an extension to ANSI, if :PRINT is :top-level-forms, a message 
+     per top level form after macroexpansion is printed to *STANDARD-OUTPUT*. 
+     For example, compiling an IN-PACKAGE form will result in a message about
+     a top level SETQ in addition to the message about the IN-PACKAGE form'
+     itself.
+
+     Both forms of reporting obey the SB-EXT:*COMPILER-PRINT-VARIABLE-ALIST*.
+
+  :BLOCK-COMPILE
+     Though COMPILE-FILE accepts an additional :BLOCK-COMPILE
+     argument, it is not currently supported. (non-standard)
+
+  :TRACE-FILE
+     If given, internal data structures are dumped to the specified
+     file, or if a value of T is given, to a file of *.trace type
+     derived from the input file name. (non-standard)"
+;;; Block compilation is currently broken.
+#|
+  "Also, as a workaround for vaguely-non-ANSI behavior, the
+:BLOCK-COMPILE argument is quasi-supported, to determine whether
+multiple functions are compiled together as a unit, resolving function
+references at compile time. NIL means that global function names are
+never resolved at compilation time. Currently NIL is the default
+behavior, because although section 3.2.2.3, \"Semantic Constraints\",
+of the ANSI spec allows this behavior under all circumstances, the
+compiler's runtime scales badly when it tries to do this for large
+files. If/when this performance problem is fixed, the block
+compilation default behavior will probably be made dependent on the
+SPEED and COMPILATION-SPEED optimization values, and the
+:BLOCK-COMPILE argument will probably become deprecated."
+|#
   (let* ((fasl-output nil)
         (output-file-name nil)
         (compile-won nil)
         (warnings-p nil)
         (failure-p t) ; T in case error keeps this from being set later
         (input-pathname (verify-source-file input-file))
   (let* ((fasl-output nil)
         (output-file-name nil)
         (compile-won nil)
         (warnings-p nil)
         (failure-p t) ; T in case error keeps this from being set later
         (input-pathname (verify-source-file input-file))
-        (source-info (make-file-source-info input-pathname))
+        (source-info (make-file-source-info input-pathname external-format))
         (*compiler-trace-output* nil)) ; might be modified below
 
     (unwind-protect
         (*compiler-trace-output* nil)) ; might be modified below
 
     (unwind-protect
                          :direction :output))))
 
          (when sb!xc:*compile-verbose*
                          :direction :output))))
 
          (when sb!xc:*compile-verbose*
-           (start-error-output source-info))
+           (print-compile-start-note source-info))
          (let ((*compile-object* fasl-output)
                dummy)
            (multiple-value-setq (dummy warnings-p failure-p)
          (let ((*compile-object* fasl-output)
                dummy)
            (multiple-value-setq (dummy warnings-p failure-p)
          (compiler-mumble "~2&; ~A written~%" (namestring output-file-name))))
 
       (when sb!xc:*compile-verbose*
          (compiler-mumble "~2&; ~A written~%" (namestring output-file-name))))
 
       (when sb!xc:*compile-verbose*
-       (finish-error-output source-info compile-won))
+       (print-compile-end-note source-info compile-won))
 
       (when *compiler-trace-output*
        (close *compiler-trace-output*)))
 
       (when *compiler-trace-output*
        (close *compiler-trace-output*)))
        (t
         (when (fasl-constant-already-dumped-p constant *compile-object*)
           (return-from emit-make-load-form nil))
        (t
         (when (fasl-constant-already-dumped-p constant *compile-object*)
           (return-from emit-make-load-form nil))
-        (let* ((name (let ((*print-level* 1) (*print-length* 2))
-                       (with-output-to-string (stream)
-                         (write constant :stream stream))))
+        (let* ((name (write-to-string constant :level 1 :length 2))
                (info (if init-form
                          (list constant name init-form)
                          (list constant))))
                (info (if init-form
                          (list constant name init-form)
                          (list constant))))