0.8.21.28:

[sbcl.git] / src / compiler / ir1report.lisp

diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp
index 5dcac30..b297eb4 100644 (file)
--- a/src/compiler/ir1report.lisp
+++ b/src/compiler/ir1report.lisp
@@ -16,27 +16,6 @@
 
 (declaim (special *current-path*))
 
 
 (declaim (special *current-path*))
 

-;;; We bind print level and length when printing out messages so that
-;;; we don't dump huge amounts of garbage.
-;;;
-;;; FIXME: It's not possible to get the defaults right for everyone.
-;;; So: Should these variables be in the SB-EXT package? Or should we
-;;; just get rid of them completely and just use the bare
-;;; CL:*PRINT-FOO* variables instead?
-(declaim (type (or unsigned-byte null)
-              *compiler-error-print-level*
-              *compiler-error-print-length*
-              *compiler-error-print-lines*))
-(defvar *compiler-error-print-level* 5
-  #!+sb-doc
-  "the value for *PRINT-LEVEL* when printing compiler error messages")
-(defvar *compiler-error-print-length* 10
-  #!+sb-doc
-  "the value for *PRINT-LENGTH* when printing compiler error messages")
-(defvar *compiler-error-print-lines* 12
-  #!+sb-doc
-  "the value for *PRINT-LINES* when printing compiler error messages")
-

 (defvar *enclosing-source-cutoff* 1
   #!+sb-doc
   "The maximum number of enclosing non-original source forms (i.e. from
 (defvar *enclosing-source-cutoff* 1
   #!+sb-doc
   "The maximum number of enclosing non-original source forms (i.e. from

@@ -72,7 +51,9 @@
   ;; the file position at which the top level form starts, if applicable
   (file-position nil :type (or index null))
   ;; the original source part of the source path
   ;; the file position at which the top level form starts, if applicable
   (file-position nil :type (or index null))
   ;; the original source part of the source path

-  (original-source-path nil :type list))
+  (original-source-path nil :type list)
+  ;; the lexenv active at the time
+  (lexenv nil :type (or null lexenv)))

 
 ;;; If true, this is the node which is used as context in compiler warning
 ;;; messages.
 
 ;;; If true, this is the node which is used as context in compiler warning
 ;;; messages.

@@ -186,39 +167,11 @@
 ;;; compiler warnings.
 (defun stringify-form (form &optional (pretty t))
   (with-standard-io-syntax
 ;;; compiler warnings.
 (defun stringify-form (form &optional (pretty t))
   (with-standard-io-syntax

-   (let ((*print-readably* nil)
-         (*print-pretty* pretty)
-         (*print-level* *compiler-error-print-level*)
-         (*print-length* *compiler-error-print-length*)
-         (*print-lines* *compiler-error-print-lines*))
-     (if pretty
-         (format nil "~<~@;  ~S~:>" (list form))
-         (prin1-to-string form)))))
-
-;;; shorthand for a repeated idiom in creating debug names
-;;;
-;;; the problem, part I: We want to create debug names that look like
-;;; "&MORE processor for <something>" where <something> might be
-;;; either a source-name value (typically a symbol) or a non-symbol
-;;; debug-name value (typically a string). It's awkward to handle this
-;;; with FORMAT because we'd like to splice a source-name value using
-;;; "~S" (to get package qualifiers) but a debug-name value using "~A"
-;;; (to avoid irrelevant quotes at string splice boundaries).
-;;;
-;;; the problem, part II: The <something> is represented as a pair
-;;; of values, SOURCE-NAME and DEBUG-NAME, where SOURCE-NAME is used
-;;; if it's not .ANONYMOUS. (This is parallel to the way that ordinarily
-;;; we don't use a value if it's NIL, instead defaulting it. But we
-;;; can't safely/comfortably use NIL for that in this context, since
-;;; the app programmer can use NIL as a name, so we use the private
-;;; symbol .ANONYMOUS. instead.)
-;;;
-;;; the solution: Use this function to convert whatever it is to a
-;;; string, which FORMAT can then splice using "~A".
-(defun as-debug-name (source-name debug-name)
-  (if (eql source-name '.anonymous.)
-      debug-name
-      (debug-namify "~S" source-name)))
+    (with-compiler-io-syntax
+        (let ((*print-pretty* pretty))
+          (if pretty
+              (format nil "~<~@;  ~S~:>" (list form))
+              (prin1-to-string form))))))

 
 ;;; Return a COMPILER-ERROR-CONTEXT structure describing the current
 ;;; error context, or NIL if we can't figure anything out. ARGS is a
 
 ;;; Return a COMPILER-ERROR-CONTEXT structure describing the current
 ;;; error context, or NIL if we can't figure anything out. ARGS is a

@@ -264,7 +217,10 @@
                     (declare (ignore ignore))
                     pos)
                   :original-source-path
                     (declare (ignore ignore))
                     pos)
                   :original-source-path

-                  (source-path-original-source path))))))))))
+                  (source-path-original-source path)
+                  :lexenv (if context
+                              (node-lexenv context)
+                              (if (boundp '*lexenv*) *lexenv* nil)))))))))))

 \f
 ;;;; printing error messages
 
 \f
 ;;;; printing error messages
 

@@ -289,11 +245,12 @@
 ;;; If the last message was given more than once, then print out an
 ;;; indication of how many times it was repeated. We reset the message
 ;;; count when we are done.
 ;;; If the last message was given more than once, then print out an
 ;;; indication of how many times it was repeated. We reset the message
 ;;; count when we are done.

-(defun note-message-repeats (&optional (terpri t))
+(defun note-message-repeats (stream &optional (terpri t))

   (cond ((= *last-message-count* 1)
   (cond ((= *last-message-count* 1)

-        (when terpri (terpri *error-output*)))
+        (when terpri 
+          (terpri stream)))

        ((> *last-message-count* 1)
        ((> *last-message-count* 1)

-          (format *error-output* "~&; [Last message occurs ~W times.]~2%"
+        (format stream "~&; [Last message occurs ~W times.]~2%"

                 *last-message-count*)))
   (setq *last-message-count* 0))
 
                 *last-message-count*)))
   (setq *last-message-count* 0))
 

@@ -305,91 +262,84 @@
 ;;;
 ;;; We suppress printing of messages identical to the previous, but
 ;;; record the number of times that the message is repeated.
 ;;;
 ;;; We suppress printing of messages identical to the previous, but
 ;;; record the number of times that the message is repeated.

-(defun print-compiler-message (format-string format-args)
+(defmacro print-compiler-message (stream format-string format-args)
+  `(with-compiler-io-syntax
+     (%print-compiler-message ,stream ,format-string ,format-args)))

 
 

+(defun %print-compiler-message (stream format-string format-args)

   (declare (type simple-string format-string))
   (declare (type simple-string format-string))

-  (declare (type list format-args))
+  (declare (type list format-args))  
+  (let ((context (find-error-context format-args)))
+    (cond (context
+          (let ((file (compiler-error-context-file-name context))
+                (in (compiler-error-context-context context))
+                (form (compiler-error-context-original-source context))
+                (enclosing (compiler-error-context-enclosing-source context))
+                (source (compiler-error-context-source context))
+                (last *last-error-context*))
+
+            (unless  (and last
+                          (equal file (compiler-error-context-file-name last)))
+              (when (pathnamep file)
+                (note-message-repeats stream)
+                (setq last nil)
+                (format stream "~2&; file: ~A~%" (namestring file))))
+            
+            (unless (and last
+                         (equal in (compiler-error-context-context last)))
+              (note-message-repeats stream)
+              (setq last nil)
+              (pprint-logical-block (stream nil :per-line-prefix "; ")
+                (format stream "in:~{~<~%    ~4:;~{ ~S~}~>~^ =>~}" in))
+              (terpri stream))
+            
+            (unless (and last
+                         (string= form
+                                  (compiler-error-context-original-source last)))
+              (note-message-repeats stream)
+              (setq last nil)
+              (pprint-logical-block (stream nil :per-line-prefix "; ")
+                (format stream "  ~A" form))
+              (fresh-line stream))
+            
+            (unless (and last
+                         (equal enclosing
+                                (compiler-error-context-enclosing-source last)))
+              (when enclosing
+                (note-message-repeats stream)
+                (setq last nil)
+                (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing)))
+            
+            (unless (and last
+                         (equal source (compiler-error-context-source last)))
+              (setq *last-format-string* nil)
+              (when source
+                (note-message-repeats stream)
+                (dolist (src source)
+                  (fresh-line stream)
+                  (write-string "; ==>" stream)
+                  (terpri stream)
+                  (pprint-logical-block (stream nil :per-line-prefix "; ")
+                    (write-string src stream)))))))
+         (t
+          (fresh-line stream)
+          (note-message-repeats stream)
+          (setq *last-format-string* nil)))
+    
+    (setq *last-error-context* context))
+
+  ;; FIXME: this testing for effective equality of compiler messages
+  ;; is ugly, and really ought to be done at a higher level.
+  (unless (and (equal format-string *last-format-string*)
+              (tree-equal format-args *last-format-args*))
+    (note-message-repeats stream nil)
+    (setq *last-format-string* format-string)
+    (setq *last-format-args* format-args)
+    (fresh-line stream)
+    (pprint-logical-block (stream nil :per-line-prefix "; ")
+      (format stream "~&~?" format-string format-args))
+    (fresh-line stream))

   
   

-  (let ((stream *error-output*)
-       (context (find-error-context format-args)))
-    (cond
-     (context
-      (let ((file (compiler-error-context-file-name context))
-           (in (compiler-error-context-context context))
-           (form (compiler-error-context-original-source context))
-           (enclosing (compiler-error-context-enclosing-source context))
-           (source (compiler-error-context-source context))
-           (last *last-error-context*))
-
-       (unless (and last
-                    (equal file (compiler-error-context-file-name last)))
-         (when (pathnamep file)
-           (note-message-repeats)
-           (setq last nil)
-            (format stream "~2&; file: ~A~%" (namestring file))))
-
-       (unless (and last
-                    (equal in (compiler-error-context-context last)))
-         (note-message-repeats)
-         (setq last nil)
-          (format stream "~&")
-          (pprint-logical-block (stream nil :per-line-prefix "; ")
-            (format stream "in:~{~<~%    ~4:;~{ ~S~}~>~^ =>~}" in))
-          (format stream "~%"))
-
-
-       (unless (and last
-                    (string= form
-                             (compiler-error-context-original-source last)))
-         (note-message-repeats)
-         (setq last nil)
-          (format stream "~&")
-          (pprint-logical-block (stream nil :per-line-prefix "; ")
-            (format stream "  ~A" form))
-          (format stream "~&"))
-
-       (unless (and last
-                    (equal enclosing
-                           (compiler-error-context-enclosing-source last)))
-         (when enclosing
-           (note-message-repeats)
-           (setq last nil)
-           (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing)))
-
-       (unless (and last
-                    (equal source (compiler-error-context-source last)))
-         (setq *last-format-string* nil)
-         (when source
-           (note-message-repeats)
-           (dolist (src source)
-              (format stream "~&")
-              (write-string "; ==>" stream)
-              (format stream "~&")
-              (pprint-logical-block (stream nil :per-line-prefix "; ")
-                (write-string src stream)))))))
-     (t
-       (format stream "~&")
-      (note-message-repeats)
-      (setq *last-format-string* nil)
-       (format stream "~&")))
-
-    (setq *last-error-context* context)
-
-    ;; FIXME: this testing for effective equality of compiler messages
-    ;; is ugly, and really ought to be done at a higher level.
-    (unless (and (equal format-string *last-format-string*)
-                (tree-equal format-args *last-format-args*))
-      (note-message-repeats nil)
-      (setq *last-format-string* format-string)
-      (setq *last-format-args* format-args)
-      (let ((*print-level*  *compiler-error-print-level*)
-           (*print-length* *compiler-error-print-length*)
-           (*print-lines*  *compiler-error-print-lines*))
-        (format stream "~&")
-        (pprint-logical-block (stream nil :per-line-prefix "; ")
-          (format stream "~&~?" format-string format-args))
-        (format stream "~&"))))
-

   (incf *last-message-count*)
   (values))
 
   (incf *last-message-count*)
   (values))
 

@@ -403,17 +353,10 @@
                (style-warning 'style-warning)
                (warning 'warning)
                ((or error compiler-error) 'error))))
                (style-warning 'style-warning)
                (warning 'warning)
                ((or error compiler-error) 'error))))

-    (multiple-value-bind (format-string format-args)
-       (if (typep condition 'simple-condition)
-           (values (simple-condition-format-control condition)
-                   (simple-condition-format-arguments condition))
-           (values "~A"
-                   (list (with-output-to-string (s)
-                           (princ condition s)))))
-      (print-compiler-message
-       (format nil "caught ~S:~%  ~A" what format-string)
-       format-args)))
-  (values))
+    (print-compiler-message
+     *error-output*
+     (format nil "caught ~S:~%~~@<  ~~@;~~A~~:>" what)
+     (list (princ-to-string condition)))))

 
 ;;; The act of signalling one of these beasts must not cause WARNINGSP
 ;;; (or FAILUREP) to be set from COMPILE or COMPILE-FILE, so we can't
 
 ;;; The act of signalling one of these beasts must not cause WARNINGSP
 ;;; (or FAILUREP) to be set from COMPILE or COMPILE-FILE, so we can't

@@ -433,62 +376,57 @@ a STYLE-WARNING (or any more serious condition)."))
    "A condition type signalled when the compiler deletes code that the user
 has written, having proved that it is unreachable."))
 
    "A condition type signalled when the compiler deletes code that the user
 has written, having proved that it is unreachable."))
 

-(defun compiler-notify (datum &rest args)
-  (unless (if *compiler-error-context*
+(macrolet ((with-condition ((condition datum args) &body body)
+            (with-unique-names (block)
+              `(block ,block
+                 (let ((,condition
+                        (coerce-to-condition ,datum ,args
+                                             'simple-compiler-note
+                                             'with-condition)))
+                   (restart-case
+                       (signal ,condition)
+                     (muffle-warning ()
+                       (return-from ,block (values))))
+                   ,@body
+                   (values))))))
+
+  (defun compiler-notify (datum &rest args)
+    (unless (if *compiler-error-context*

              (policy *compiler-error-context* (= inhibit-warnings 3))
              (policy *lexenv* (= inhibit-warnings 3)))
              (policy *compiler-error-context* (= inhibit-warnings 3))
              (policy *lexenv* (= inhibit-warnings 3)))

-    (let ((condition
-          (coerce-to-condition datum args
-                               'simple-compiler-note 'compiler-notify)))
-      (restart-case
-         (signal condition)
-       (muffle-warning ()
-         (return-from compiler-notify (values))))
-      (incf *compiler-note-count*)
-      (multiple-value-bind (format-string format-args)
-         (if (typep condition 'simple-condition)
-             (values (simple-condition-format-control condition)
-                     (simple-condition-format-arguments condition))
-             (values "~A"
-                     (list (with-output-to-string (s)
-                             (princ condition s)))))
-       (print-compiler-message (format nil "note: ~A" format-string)
-                               format-args))))
-  (values))
-
-;;; Issue a note when we might or might not be in the compiler.
-(defun maybe-compiler-notify (&rest rest)
-  (if (boundp '*lexenv*) ; if we're in the compiler
-      (apply #'compiler-notify rest)
-      (progn
-       (let ((condition
-              (coerce-to-condition (car rest) (cdr rest)
-                                   'simple-compiler-note
-                                   'maybe-compiler-notify)))
-         (restart-case
-             (signal condition)
-           (muffle-warning ()
-             (return-from maybe-compiler-notify (values))))
+      (with-condition (condition datum args)
+       (incf *compiler-note-count*)
+       (print-compiler-message 
+        *error-output*
+        (format nil "note: ~~A")
+        (list (princ-to-string condition)))))
+    (values))
+
+  ;; Issue a note when we might or might not be in the compiler.
+  (defun maybe-compiler-notify (&rest rest)
+    (if (boundp '*lexenv*) ; if we're in the compiler
+       (apply #'compiler-notify rest)
+       (with-condition (condition (car rest) (cdr rest))

          (let ((stream *error-output*))
            (pprint-logical-block (stream nil :per-line-prefix ";")
              (format stream " note: ~3I~_")
              (pprint-logical-block (stream nil)
                (format stream "~A" condition)))
            ;; (outside logical block, no per-line-prefix)
          (let ((stream *error-output*))
            (pprint-logical-block (stream nil :per-line-prefix ";")
              (format stream " note: ~3I~_")
              (pprint-logical-block (stream nil)
                (format stream "~A" condition)))
            ;; (outside logical block, no per-line-prefix)

-           (fresh-line stream)))
-       (values))))
+           (fresh-line stream))))))

 
 ;;; The politically correct way to print out progress messages and
 ;;; such like. We clear the current error context so that we know that
 ;;; it needs to be reprinted, and we also FORCE-OUTPUT so that the
 ;;; message gets seen right away.
 (declaim (ftype (function (string &rest t) (values)) compiler-mumble))
 
 ;;; The politically correct way to print out progress messages and
 ;;; such like. We clear the current error context so that we know that
 ;;; it needs to be reprinted, and we also FORCE-OUTPUT so that the
 ;;; message gets seen right away.
 (declaim (ftype (function (string &rest t) (values)) compiler-mumble))

-(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*)
-  (values))
+(defun compiler-mumble (control &rest args)
+  (let ((stream *standard-output*))
+    (note-message-repeats stream)
+    (setq *last-error-context* nil)
+    (apply #'format stream control args)
+    (force-output stream)
+    (values)))

 
 ;;; Return a string that somehow names the code in COMPONENT. We use
 ;;; the source path for the bind node for an arbitrary entry point to
 
 ;;; Return a string that somehow names the code in COMPONENT. We use
 ;;; the source path for the bind node for an arbitrary entry point to

@@ -564,13 +502,27 @@ has written, having proved that it is unreachable."))
           ;; Check for boundness so we don't blow up if we're called
           ;; when IR1 conversion isn't going on.
           (boundp '*lexenv*)
           ;; Check for boundness so we don't blow up if we're called
           ;; when IR1 conversion isn't going on.
           (boundp '*lexenv*)

-          ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below
-          ;; isn't a good idea; we should have INHIBIT-WARNINGS
-          ;; affect compiler notes, not STYLE-WARNINGs. And I'm not
-          ;; sure what the BOUNDP '*LEXENV* test above is for; it's
-          ;; likely a good idea, but it probably deserves an
-          ;; explanatory comment.
-          (policy *lexenv* (= inhibit-warnings 3)))
+          (or
+           ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below
+           ;; isn't a good idea; we should have INHIBIT-WARNINGS
+           ;; affect compiler notes, not STYLE-WARNINGs. And I'm not
+           ;; sure what the BOUNDP '*LEXENV* test above is for; it's
+           ;; likely a good idea, but it probably deserves an
+           ;; explanatory comment.
+           (policy *lexenv* (= inhibit-warnings 3))
+           ;; KLUDGE: weird decoupling between here and where we're
+           ;; going to signal the condition.  I don't think we can
+           ;; rewrite this using SIGNAL and RESTART-CASE (to take
+           ;; advantage of the (SATISFIES HANDLE-CONDITION-P)
+           ;; handler, because if that doesn't handle it the ordinary
+           ;; compiler handlers will trigger.
+           (typep
+            (ecase kind
+              (:variable (make-condition 'warning))
+              ((:function :type) (make-condition 'style-warning)))
+            (car
+             (rassoc 'muffle-warning
+                     (lexenv-handled-conditions *lexenv*))))))

     (let* ((found (dolist (warning *undefined-warnings* nil)
                    (when (and (equal (undefined-warning-name warning) name)
                               (eq (undefined-warning-kind warning) kind))
     (let* ((found (dolist (warning *undefined-warnings* nil)
                    (when (and (equal (undefined-warning-name warning) name)
                               (eq (undefined-warning-kind warning) kind))