X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcold-error.lisp;h=e4e094c95bf9d21bb4a1e160d8585017b1c47a2f;hb=82cd148d729c241e79c8df04b700beec1b7c55de;hp=ba5a7f0b400afb4f800a9bb02d09100148fd3a1d;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/code/cold-error.lisp b/src/code/cold-error.lisp index ba5a7f0..e4e094c 100644 --- 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. @@ -10,13 +9,66 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -(in-package "SB!CONDITIONS") +(in-package "SB!KERNEL") (defvar *break-on-signals* nil #!+sb-doc "When (TYPEP condition *BREAK-ON-SIGNALS*) is true, then calls to SIGNAL will enter the debugger prior to signalling that condition.") +(defun maybe-break-on-signal (condition) + (let ((old-bos *break-on-signals*) + (bos-actually-breaking nil)) + (restart-case + (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))) + ;; Give the user a chance to unset *BREAK-ON-SIGNALS* on the + ;; way out. + ;; + ;; (e.g.: Consider a long compilation. After a failed compile + ;; the user sets *BREAK-ON-SIGNALS* to T, and select the + ;; RECOMPILE restart. Once the user diagnoses and fixes the + ;; problem, he selects RECOMPILE again... and discovers that + ;; he's entered the *BREAK-ON-SIGNALS* hell with no escape, + ;; unless we provide this restart.) + (reassign (new-value) + :report + (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)))) + (list 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 @@ -24,120 +76,85 @@ (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*)) - (let ((old-bos *break-on-signals*) - (*break-on-signals* nil)) - (when (typep condition old-bos) - (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* (now NIL)." - condition))) + 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)) + (unless *handler-clusters* + (return)) (let ((cluster (pop *handler-clusters*))) - (dolist (handler cluster) - (when (typep condition (car handler)) - (funcall (cdr handler) condition))))) + (dolist (handler cluster) + (when (typep condition (car handler)) + (funcall (cdr handler) condition))))) 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. -(defun coerce-to-condition (datum arguments default-type function-name) - (cond ((typep datum 'condition) - (if arguments - (cerror "Ignore the additional arguments." - 'simple-type-error - :datum arguments - :expected-type 'null - :format-control "You may not supply additional arguments ~ - when giving ~S to ~S." - :format-arguments (list datum function-name))) - datum) - ((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION) - (apply #'make-condition datum arguments)) - ((or (stringp datum) (functionp datum)) - (make-condition default-type - :format-control datum - :format-arguments arguments)) - (t - (error 'simple-type-error - :datum datum - :expected-type '(or symbol string) - :format-control "bad argument to ~S: ~S" - :format-arguments (list function-name datum))))) - (defun error (datum &rest arguments) #!+sb-doc - "Invoke the signal facility on a condition formed from datum and arguments. - If the condition is not handled, the debugger is invoked." - (/show0 "entering ERROR") - #!+sb-show - (unless *cold-init-complete-p* - (/show0 "ERROR in cold init, arguments=..") - #!+sb-show (dolist (argument arguments) - (sb!impl::cold-print argument))) - (sb!kernel:infinite-error-protect + "Invoke the signal facility on a condition formed from DATUM and ARGUMENTS. + If the condition is not handled, the debugger is invoked." + (/show0 "entering ERROR, argument list=..") + (/hexstr arguments) + + (/show0 "cold-printing ERROR arguments one by one..") + #!+sb-show (dolist (argument arguments) + (sb!impl::cold-print argument)) + (/show0 "done cold-printing ERROR arguments") + + (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)))) - (let ((sb!debug:*stack-top-hint* nil)) - (signal condition)) + 'simple-error 'error)) + (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'error))) + (/show0 "done coercing DATUM to CONDITION") + (/show0 "signalling CONDITION from within ERROR") + (signal condition) + (/show0 "done signalling CONDITION within ERROR") (invoke-debugger condition)))) (defun cerror (continue-string datum &rest arguments) - (sb!kernel:infinite-error-protect + (infinite-error-protect (with-simple-restart - (continue "~A" (apply #'format nil continue-string arguments)) - (let ((condition (if (typep datum 'condition) - datum - (coerce-to-condition datum - 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)))) - (with-condition-restarts condition (list (find-restart 'continue)) - (let ((sb!debug:*stack-top-hint* nil)) - (signal condition)) - (invoke-debugger condition))))) + (continue "~A" (apply #'format nil continue-string arguments)) + (let ((condition (coerce-to-condition datum + arguments + 'simple-error + 'cerror))) + (with-condition-restarts condition (list (find-restart 'continue)) + (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 +;;; we can use it in system code (e.g. in SIGINT handling) without +;;; messing up --disable-debugger mode (which works by setting +;;; *DEBUGGER-HOOK*); or for that matter, without messing up ordinary +;;; applications which try to do similar things with *DEBUGGER-HOOK* +(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* (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." - (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))))) - (invoke-debugger - (coerce-to-condition datum arguments 'simple-condition 'break))))) - nil) +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) #!+sb-doc "Warn about a situation by signalling a condition formed by DATUM and ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart exists that causes WARN to immediately return NIL." - (/noshow0 "entering WARN") + (/show0 "entering WARN") ;; KLUDGE: The current cold load initialization logic causes several calls ;; to WARN, so we need to be able to handle them without dying. (And calling ;; FORMAT or even PRINC in cold load is a good way to die.) Of course, the @@ -145,22 +162,29 @@ ;; -- WHN 19991009 (if (not *cold-init-complete-p*) (progn - (/show0 "ignoring WARN in cold init, arguments=..") - #!+sb-show (dolist (argument arguments) - (sb!impl::cold-print argument))) - (sb!kernel:infinite-error-protect + (/show0 "ignoring WARN in cold init, arguments=..") + #!+sb-show (dolist (argument arguments) + (sb!impl::cold-print argument))) + (infinite-error-protect + (/show0 "doing COERCE-TO-CONDITION") (let ((condition (coerce-to-condition datum arguments - 'simple-warning 'warn))) - (check-type condition warning "a warning condition") - (restart-case (signal condition) - (muffle-warning () - :report "Skip warning." - (return-from warn nil))) - (let ((badness (etypecase condition - (style-warning 'style-warning) - (warning 'warning)))) - (format *error-output* - "~&~@<~S: ~3i~:_~A~:>~%" - badness - condition))))) + 'simple-warning 'warn))) + (/show0 "back from COERCE-TO-CONDITION, doing ENFORCE-TYPE") + (enforce-type condition warning) + (/show0 "back from ENFORCE-TYPE, doing RESTART-CASE MUFFLE-WARNING") + (restart-case (signal condition) + (muffle-warning () + :report "Skip warning." + (return-from warn nil))) + (/show0 "back from RESTART-CASE MUFFLE-WARNING (i.e. normal return)") + + (let ((badness (etypecase condition + (style-warning 'style-warning) + (warning 'warning)))) + (/show0 "got BADNESS, calling FORMAT") + (format *error-output* + "~&~@<~S: ~3i~:_~A~:>~%" + badness + condition) + (/show0 "back from FORMAT, voila!"))))) nil)