X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1report.lisp;h=5dcac3059415fe4af4364fa912f6bc7ae865a32c;hb=35b5e97163c45e89659dbd75c91d653b49c758d3;hp=d12c204d405c3df51e09c740b323e56f29f880e6;hpb=dc84ceb894fdbe315f82dd8336f3ba894435a669;p=sbcl.git

diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp
index d12c204..5dcac30 100644
--- a/src/compiler/ir1report.lisp
+++ b/src/compiler/ir1report.lisp
@@ -129,11 +129,14 @@
 (defun source-form-context (form)
   (cond ((atom form) nil)
 	((>= (length form) 2)
-	 (funcall (gethash (first form) *source-context-methods*
-			   (lambda (x)
-			     (declare (ignore x))
-			     (list (first form) (second form))))
-		  (rest form)))
+         (let* ((context-fun-default (lambda (x)
+				       (declare (ignore x))
+				       (list (first form) (second form))))
+		(context-fun (gethash (first form)
+				      *source-context-methods*
+				      context-fun-default)))
+           (declare (type function context-fun))
+           (funcall context-fun (rest form))))
 	(t
 	 form)))
 
@@ -372,6 +375,8 @@
 
     (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)
@@ -397,7 +402,7 @@
 	(what (etypecase condition
 		(style-warning 'style-warning)
 		(warning 'warning)
-		(error 'error))))
+		((or error compiler-error) 'error))))
     (multiple-value-bind (format-string format-args)
 	(if (typep condition 'simple-condition)
 	    (values (simple-condition-format-control condition)
@@ -405,40 +410,73 @@
 	    (values "~A"
 		    (list (with-output-to-string (s)
 			    (princ condition s)))))
-      (print-compiler-message (format nil
-				      "caught ~S:~%  ~A"
-				      what
-				      format-string)
-			      format-args)))
+      (print-compiler-message
+       (format nil "caught ~S:~%  ~A" what format-string)
+       format-args)))
   (values))
 
-;;; COMPILER-NOTE is vaguely like COMPILER-ERROR and the other
-;;; condition-signalling functions, but it just writes some output
-;;; instead of signalling. (In CMU CL, it did signal a condition, but
-;;; this didn't seem to work all that well; it was weird to have
-;;; COMPILE-FILE return with WARNINGS-P set when the only problem was
-;;; that the compiler couldn't figure out how to compile something as
-;;; efficiently as it liked.)
-(defun compiler-note (format-string &rest format-args)
+;;; 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
+;;; inherit from WARNING or STYLE-WARNING.
+;;;
+;;; FIXME: the handling of compiler-notes could be unified with
+;;; warnings and style-warnings (see the various handler functions
+;;; below).
+(define-condition compiler-note (condition) ()
+  (:documentation
+   "Root of the hierarchy of conditions representing information discovered
+by the compiler that the user might wish to know, but which does not merit
+a STYLE-WARNING (or any more serious condition)."))
+(define-condition simple-compiler-note (simple-condition compiler-note) ())
+(define-condition code-deletion-note (simple-compiler-note) ()
+  (:documentation
+   "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*
 	      (policy *compiler-error-context* (= inhibit-warnings 3))
 	      (policy *lexenv* (= inhibit-warnings 3)))
-    (incf *compiler-note-count*)
-    (print-compiler-message (format nil "note: ~A" format-string)
-			    format-args))
+    (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-note (&rest rest)
+(defun maybe-compiler-notify (&rest rest)
   (if (boundp '*lexenv*) ; if we're in the compiler
-      (apply #'compiler-note rest)
-      (let ((stream *error-output*))
-	(pprint-logical-block (stream nil :per-line-prefix ";")
-	  
-	  (format stream " note: ~3I~_")
-	  (pprint-logical-block (stream nil)
-	    (apply #'format stream rest)))
-	(fresh-line stream)))) ; (outside logical block, no per-line-prefix)
+      (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))))
+	  (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))))
 
 ;;; The politically correct way to print out progress messages and
 ;;; such like. We clear the current error context so that we know that
@@ -461,7 +499,7 @@
     (aver ep) ; else no entry points??
     (multiple-value-bind (form context)
 	(find-original-source
-	 (node-source-path (continuation-next (block-start ep))))
+	 (node-source-path (block-start-node ep)))
       (declare (ignore form))
       (let ((*print-level* 2)
 	    (*print-pretty* nil))