-;;;; 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.
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
: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.
(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))))
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
(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."