0.8.19.30: less COMPILE-FILE verbosity
authorNikodemus Siivola <nikodemus@random-state.net>
Thu, 17 Feb 2005 14:30:38 +0000 (14:30 +0000)
committerNikodemus Siivola <nikodemus@random-state.net>
Thu, 17 Feb 2005 14:30:38 +0000 (14:30 +0000)
           First stab at fixing bug #7. To get output approximately as
           verbose as the old behaviour use :TOP-LEVEL-FORMS as the
           value of the :PRINT option to COMPILE-FILE.

           Note: Giving users control over the way things are printed
           via *COMPILER-PRINT-VARIABLE-ALIST* is OTOH a good thing,
           but it also seems to be used for ratheer diverse things,
           and people could reasonably want to customize them
           separately. Gah.

           Also list x86/FreeBSD4 as "expected to pass tests" in
           make.sh output, as that seems to be the case.

BUGS
NEWS
doc/manual/compiler.texinfo
make.sh
src/compiler/debug.lisp
src/compiler/ir1report.lisp
src/compiler/ir1tran-lambda.lisp
src/compiler/main.lisp
version.lisp-expr

diff --git a/BUGS b/BUGS
index 5928112..f5b6399 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -84,11 +84,6 @@ WORKAROUND:
 
   d: (fixed in 0.8.1.5)
 
 
   d: (fixed in 0.8.1.5)
 
-7:
-  The "compiling top-level form:" output ought to be condensed.
-  Perhaps any number of such consecutive lines ought to turn into a
-  single "compiling top-level forms:" line.
-
 27:
   Sometimes (SB-EXT:QUIT) fails with 
        Argh! maximum interrupt nesting depth (4096) exceeded, exiting
 27:
   Sometimes (SB-EXT:QUIT) fails with 
        Argh! maximum interrupt nesting depth (4096) exceeded, exiting
diff --git a/NEWS b/NEWS
index a0d9764..302a2f3 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -3,6 +3,9 @@ changes in sbcl-0.8.20 (0.9alpha.0?) relative to sbcl-0.8.19:
     Lichteblau)
   * fixed loading of multiply forward-referenced layouts. 
     (thanks to Cheuksan Wang)
     Lichteblau)
   * fixed loading of multiply forward-referenced layouts. 
     (thanks to Cheuksan Wang)
+  * fixed bug 7: less verbose COMPILE-FILE output. Additionally, the
+    output is now directed to *STANDARD-OUTPUT* as specified by ANSI. 
+    (see COMPILE-FILE documentation for details of :PRINT option)
   * fixed bugs 19 and 317: fixed-format floating point printing is
     more accurate.  This also fixes a bug reported by Adam Warner
     related to the ~@F format directive.
   * fixed bugs 19 and 317: fixed-format floating point printing is
     more accurate.  This also fixes a bug reported by Adam Warner
     related to the ~@F format directive.
index 546f817..cfc034f 100644 (file)
@@ -11,7 +11,7 @@ naive translation. Efficiency issues are sufficiently varied and
 separate that they have their own chapter, @ref{Efficiency}.
 
 @menu
 separate that they have their own chapter, @ref{Efficiency}.
 
 @menu
-* Diagnostic Messages::         
+* Diagnostic Messages::
 * Handling of Types::           
 * Compiler Policy::             
 * Compiler Errors::             
 * Handling of Types::           
 * Compiler Policy::             
 * Compiler Errors::             
diff --git a/make.sh b/make.sh
index 970a734..a1a1586 100755 (executable)
--- a/make.sh
+++ b/make.sh
@@ -133,8 +133,9 @@ echo "the new SBCL, you can try:"
 echo
 echo "  cd tests && sh ./run-tests.sh"
 echo
 echo
 echo "  cd tests && sh ./run-tests.sh"
 echo
-echo "  (All tests should pass on x86/Linux and ppc/Darwin, on other platforms"
-echo "  some failures are currently expected; patches welcome as always.)"
+echo "  (All tests should pass on x86/Linux, x86/FreeBSD4, and ppc/Darwin. On"
+echo "  other platforms some failures are currently expected; patches welcome"
+echo "  as always.)"
 echo
 echo "To build documentation:"
 echo
 echo
 echo "To build documentation:"
 echo
index 84c120d..ae59919 100644 (file)
 
 ;;; Dump some info about how many TNs there, and what the conflicts data
 ;;; structures are like.
 
 ;;; Dump some info about how many TNs there, and what the conflicts data
 ;;; structures are like.
-(defun pre-pack-tn-stats (component &optional (stream *error-output*))
+(defun pre-pack-tn-stats (component &optional (stream *standard-output*))
   (declare (type component component))
   (let ((wired 0)
        (global 0)
   (declare (type component component))
   (let ((wired 0)
        (global 0)
index d8d529c..6dbedfb 100644 (file)
 ;;; count when we are done.
 (defun note-message-repeats (&optional (terpri t))
   (cond ((= *last-message-count* 1)
 ;;; count when we are done.
 (defun note-message-repeats (&optional (terpri t))
   (cond ((= *last-message-count* 1)
-        (when terpri (terpri *error-output*)))
+        (when terpri (terpri *standard-output*)))
        ((> *last-message-count* 1)
        ((> *last-message-count* 1)
-          (format *error-output* "~&; [Last message occurs ~W times.]~2%"
+          (format *standard-output* "~&; [Last message occurs ~W times.]~2%"
                 *last-message-count*)))
   (setq *last-message-count* 0))
 
                 *last-message-count*)))
   (setq *last-message-count* 0))
 
 (defun %print-compiler-message (format-string format-args)
   (declare (type simple-string format-string))
   (declare (type list format-args))  
 (defun %print-compiler-message (format-string format-args)
   (declare (type simple-string format-string))
   (declare (type list format-args))  
-  (let ((stream *error-output*)
+  (let ((stream *standard-output*)
        (context (find-error-context format-args)))
     (cond
      (context
        (context (find-error-context format-args)))
     (cond
      (context
             (format stream "in:~{~<~%    ~4:;~{ ~S~}~>~^ =>~}" in))
           (format stream "~%"))
 
             (format stream "in:~{~<~%    ~4:;~{ ~S~}~>~^ =>~}" in))
           (format stream "~%"))
 
-
        (unless (and last
                     (string= form
                              (compiler-error-context-original-source last)))
        (unless (and last
                     (string= form
                              (compiler-error-context-original-source last)))
@@ -411,7 +410,7 @@ has written, having proved that it is unreachable."))
              (signal condition)
            (muffle-warning ()
              (return-from maybe-compiler-notify (values))))
              (signal condition)
            (muffle-warning ()
              (return-from maybe-compiler-notify (values))))
-         (let ((stream *error-output*))
+         (let ((stream *standard-output*))
            (pprint-logical-block (stream nil :per-line-prefix ";")
              (format stream " note: ~3I~_")
              (pprint-logical-block (stream nil)
            (pprint-logical-block (stream nil :per-line-prefix ";")
              (format stream " note: ~3I~_")
              (pprint-logical-block (stream nil)
@@ -428,8 +427,8 @@ has written, having proved that it is unreachable."))
 (defun compiler-mumble (format-string &rest format-args)
   (note-message-repeats)
   (setq *last-error-context* nil)
 (defun compiler-mumble (format-string &rest format-args)
   (note-message-repeats)
   (setq *last-error-context* nil)
-  (apply #'format *error-output* format-string format-args)
-  (force-output *error-output*)
+  (apply #'format *standard-output* format-string format-args)
+  (force-output *standard-output*)
   (values))
 
 ;;; Return a string that somehow names the code in COMPONENT. We use
   (values))
 
 ;;; Return a string that somehow names the code in COMPONENT. We use
index 75c81ea..534933e 100644 (file)
 ;;; The INLINE-EXPANSION is a LAMBDA-WITH-LEXENV, or NIL if there is
 ;;; no inline expansion.
 (defun %compiler-defun (name lambda-with-lexenv compile-toplevel)
 ;;; The INLINE-EXPANSION is a LAMBDA-WITH-LEXENV, or NIL if there is
 ;;; no inline expansion.
 (defun %compiler-defun (name lambda-with-lexenv compile-toplevel)
-
   (let ((defined-fun nil)) ; will be set below if we're in the compiler
   (let ((defined-fun nil)) ; will be set below if we're in the compiler
-
     (when compile-toplevel
       ;; better be in the compiler
       (aver (boundp '*lexenv*)) 
     (when compile-toplevel
       ;; better be in the compiler
       (aver (boundp '*lexenv*)) 
-      (when sb!xc:*compile-print*
-       (compiler-mumble "~&; recognizing DEFUN ~S~%" name))
       (remhash name *free-funs*)
       (setf defined-fun (get-defined-fun name))
       (remhash name *free-funs*)
       (setf defined-fun (get-defined-fun name))
-
       (aver (fasl-output-p *compile-object*))
       (if (member name *fun-names-in-this-file* :test #'equal)
          (warn 'duplicate-definition :name name)
       (aver (fasl-output-p *compile-object*))
       (if (member name *fun-names-in-this-file* :test #'equal)
          (warn 'duplicate-definition :name name)
index 39e1d69..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
 ;;; *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
   (handler-case (sb!xc:macroexpand-1 form *lexenv*)
     (error (condition)
       (compiler-error "(during macroexpansion of ~A)~%~A"
   (handler-case (sb!xc:macroexpand-1 form *lexenv*)
     (error (condition)
       (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))))
                        *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."
-
+  "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)
   (let* ((fasl-output nil)
         (output-file-name nil)
         (compile-won nil)
                          :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))))
index d09672d..b075cec 100644 (file)
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.19.29"
+"0.8.19.30"