"When (TYPEP condition *BREAK-ON-SIGNALS*) is true, then calls to SIGNAL will
enter the debugger prior to signalling that condition.")
-(defun signal (datum &rest arguments)
- #!+sb-doc
- "Invokes the signal facility on a condition formed from DATUM and
- ARGUMENTS. If the condition is not handled, NIL is returned. If
- (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked
- before any signalling is done."
- (let ((condition (coerce-to-condition datum
- arguments
- 'simple-condition
- 'signal))
- (*handler-clusters* *handler-clusters*)
- (old-bos *break-on-signals*))
+(defun maybe-break-on-signal (condition)
+ (let ((old-bos *break-on-signals*)
+ (bos-actually-breaking nil))
(restart-case
- (when (typep condition *break-on-signals*)
- (let ((*break-on-signals* nil))
+ (let ((break-on-signals *break-on-signals*)
+ (*break-on-signals* nil))
+ ;; The rebinding encloses the TYPEP so that a bogus
+ ;; type specifier will not lead to infinite recursion when
+ ;; TYPEP fails.
+ (when (typep condition break-on-signals)
+ (setf bos-actually-breaking t)
(break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* ~
(now rebound to NIL)."
condition)))
;; unless we provide this restart.)
(reassign (new-value)
:report
- "Return from BREAK and assign a new value to *BREAK-ON-SIGNALS*."
+ (lambda (stream)
+ (format stream
+ (if bos-actually-breaking
+ "Return from BREAK and assign a new value to ~
+ *BREAK-ON-SIGNALS*."
+ "Assign a new value to *BREAK-ON-SIGNALS* and ~
+ continue with signal handling.")))
:interactive
(lambda ()
(let (new-value)
(loop
- (format *query-io*
- "Enter new value for *BREAK-ON-SIGNALS*. ~
- Current value is ~S.~%~
- > "
- old-bos)
- (force-output *query-io*)
- (let ((*break-on-signals* nil))
- (setf new-value (eval (read *query-io*)))
- (if (typep new-value 'type-specifier)
- (return)
- (format *query-io*
- "~S is not a valid value for *BREAK-ON-SIGNALS* ~
- (must be a type-specifier).~%"
- new-value))))
+ (format *query-io*
+ "Enter new value for *BREAK-ON-SIGNALS*. ~
+ Current value is ~S.~%~
+ > "
+ old-bos)
+ (force-output *query-io*)
+ (let ((*break-on-signals* nil))
+ (setf new-value (eval (read *query-io*)))
+ (if (typep new-value 'type-specifier)
+ (return)
+ (format *query-io*
+ "~S is not a valid value for *BREAK-ON-SIGNALS* ~
+ (must be a type-specifier).~%"
+ new-value))))
(list new-value)))
- (setf *break-on-signals* new-value)))
+ (setf *break-on-signals* new-value)))))
+
+(defun signal (datum &rest arguments)
+ #!+sb-doc
+ "Invokes the signal facility on a condition formed from DATUM and
+ ARGUMENTS. If the condition is not handled, NIL is returned. If
+ (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked
+ before any signalling is done."
+ (let ((condition (coerce-to-condition datum
+ arguments
+ 'simple-condition
+ 'signal))
+ (*handler-clusters* *handler-clusters*)
+ (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'signal)))
+ (when *break-on-signals*
+ (maybe-break-on-signal condition))
(loop
(unless *handler-clusters*
(return))
(funcall (cdr handler) condition)))))
nil))
-;;; 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 (find-caller-name-and-frame)))))
-
(defun error (datum &rest arguments)
#!+sb-doc
"Invoke the signal facility on a condition formed from DATUM and ARGUMENTS.
(infinite-error-protect
(let ((condition (coerce-to-condition datum arguments
'simple-error 'error))
- (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
+ (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'error)))
(/show0 "done coercing DATUM to CONDITION")
- (let ((sb!debug:*stack-top-hint* nil))
- (/show0 "signalling CONDITION from within ERROR")
- (signal condition))
+ (/show0 "signalling CONDITION from within ERROR")
+ (signal condition)
(/show0 "done signalling CONDITION within ERROR")
(invoke-debugger condition))))
(let ((condition (coerce-to-condition datum
arguments
'simple-error
- 'cerror))
- (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
+ 'cerror)))
(with-condition-restarts condition (list (find-restart 'continue))
- (let ((sb!debug:*stack-top-hint* nil))
- (signal condition))
- (invoke-debugger condition)))))
+ (let ((sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'cerror)))
+ (signal condition)
+ (invoke-debugger condition))))))
nil)
;;; like BREAK, but without rebinding *DEBUGGER-HOOK* to NIL, so that
(defun %break (what &optional (datum "break") &rest arguments)
(infinite-error-protect
(with-simple-restart (continue "Return from ~S." what)
- (let ((sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
+ (let ((sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* '%break)))
(invoke-debugger
(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
+of condition handling occurring."
+ (let ((*debugger-hook* nil) ; as specifically required by ANSI
+ (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'break)))
(apply #'%break 'break datum arguments)))
(defun warn (datum &rest arguments)
projects / sbcl.git / blobdiff