X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcold-error.lisp;h=e4e094c95bf9d21bb4a1e160d8585017b1c47a2f;hb=cee8ef591040db9a79cdd19297867672a9529051;hp=429516038c2571b6029279e54912ef916204ff84;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/cold-error.lisp b/src/code/cold-error.lisp index 4295160..e4e094c 100644 --- a/src/code/cold-error.lisp +++ b/src/code/cold-error.lisp @@ -16,21 +16,17 @@ "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))) @@ -45,27 +41,48 @@ ;; 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)) @@ -75,15 +92,6 @@ (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. @@ -99,11 +107,10 @@ (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)))) @@ -114,12 +121,11 @@ (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 @@ -130,7 +136,7 @@ (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) @@ -138,8 +144,9 @@ (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)