0.pre7.55:

[sbcl.git] / src / code / cold-error.lisp

diff --git a/src/code/cold-error.lisp b/src/code/cold-error.lisp
index 869cdbb..768551a 100644 (file)
--- a/src/code/cold-error.lisp
+++ b/src/code/cold-error.lisp
@@ -1,5 +1,4 @@
-;;;; miscellaneous stuff that needs to be in the cold load which would
-;;;; otherwise be byte-compiled
+;;;; miscellaneous error stuff that needs to be in the cold load
 
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.
@@ -42,8 +41,8 @@
     nil))
 
 ;;; COERCE-TO-CONDITION is used in SIGNAL, ERROR, CERROR, WARN, and
-;;; INVOKE-DEBUGGER for parsing the hairy argument conventions into a single
-;;; argument that's directly usable by all the other routines.
+;;; INVOKE-DEBUGGER for parsing the hairy argument conventions into a
+;;; single argument that's directly usable by all the other routines.
 (defun coerce-to-condition (datum arguments default-type function-name)
   (cond ((typep datum 'condition)
         (if arguments
@@ -68,6 +67,15 @@
                :format-control "bad argument to ~S: ~S"
                :format-arguments (list function-name datum)))))
 
+;;; a shared idiom in ERROR, CERROR, and BREAK: The user probably
+;;; doesn't want to hear that the error "occurred in" one of these
+;;; functions, so we try to point the top of the stack to our caller
+;;; instead.
+(eval-when (:compile-toplevel :execute)
+  (defmacro-mundanely maybe-find-stack-top-hint ()
+    `(or sb!debug:*stack-top-hint*
+        (nth-value 1 (sb!kernel:find-caller-name-and-frame)))))
+
 (defun error (datum &rest arguments)
   #!+sb-doc
   "Invoke the signal facility on a condition formed from datum and arguments.
@@ -80,16 +88,7 @@
   (sb!kernel:infinite-error-protect
     (let ((condition (coerce-to-condition datum arguments
                                          'simple-error 'error))
-         ;; FIXME: Why is *STACK-TOP-HINT* in SB-DEBUG instead of SB-DI?
-         ;; SB-DEBUG should probably be only for true interface stuff.
-         (sb!debug:*stack-top-hint* sb!debug:*stack-top-hint*))
-      (unless (and (condition-function-name condition)
-                  sb!debug:*stack-top-hint*)
-       (multiple-value-bind (name frame) (sb!kernel:find-caller-name)
-         (unless (condition-function-name condition)
-           (setf (condition-function-name condition) name))
-         (unless sb!debug:*stack-top-hint*
-           (setf sb!debug:*stack-top-hint* frame))))
+         (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
       (let ((sb!debug:*stack-top-hint* nil))
        (signal condition))
       (invoke-debugger condition))))
@@ -104,33 +103,32 @@
                                                arguments
                                                'simple-error
                                                'error)))
-           (sb!debug:*stack-top-hint* sb!debug:*stack-top-hint*))
-       (unless (and (condition-function-name condition)
-                    sb!debug:*stack-top-hint*)
-         (multiple-value-bind (name frame) (sb!kernel:find-caller-name)
-           (unless (condition-function-name condition)
-             (setf (condition-function-name condition) name))
-           (unless sb!debug:*stack-top-hint*
-             (setf sb!debug:*stack-top-hint* frame))))
+           (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
        (with-condition-restarts condition (list (find-restart 'continue))
          (let ((sb!debug:*stack-top-hint* nil))
            (signal condition))
          (invoke-debugger condition)))))
   nil)
 
-(defun break (&optional (datum "break") &rest arguments)
-  #!+sb-doc
-  "Print a message and invoke the debugger without allowing any possibility
-   of condition handling occurring."
+;;; like BREAK, but without rebinding *DEBUGGER-HOOK* to NIL, so that
+;;; we can use it in system code (e.g. in SIGINT handling) without
+;;; messing up --noprogrammer mode (which works by setting
+;;; *DEBUGGER-HOOK*)
+(defun %break (what &optional (datum "break") &rest arguments)
   (sb!kernel:infinite-error-protect
-    (with-simple-restart (continue "Return from BREAK.")
-      (let ((sb!debug:*stack-top-hint*
-            (or sb!debug:*stack-top-hint*
-                (nth-value 1 (sb!kernel:find-caller-name)))))
+    (with-simple-restart (continue "Return from ~S." what)
+      (let ((sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
        (invoke-debugger
-        (coerce-to-condition datum arguments 'simple-condition 'break)))))
+        (coerce-to-condition datum arguments 'simple-condition what)))))
   nil)
 
+(defun break (&optional (datum "break") &rest arguments)
+  #!+sb-doc
+  "Print a message and invoke the debugger without allowing any possibility
+   of condition handling occurring."
+  (let ((*debugger-hook* nil)) ; as specifically required by ANSI
+    (apply #'%break 'break datum arguments)))
+           
 (defun warn (datum &rest arguments)
   #!+sb-doc
   "Warn about a situation by signalling a condition formed by DATUM and
@@ -150,7 +148,7 @@
       (sb!kernel:infinite-error-protect
        (let ((condition (coerce-to-condition datum arguments
                                             'simple-warning 'warn)))
-        (check-type condition warning "a warning condition")
+        (enforce-type condition warning)
         (restart-case (signal condition)
           (muffle-warning ()
             :report "Skip warning."