X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcold-error.lisp;h=32f71adc1bcdb98d55a505c49c070bf17162d36c;hb=860543cc7ba0266e41e1d41ac9b6a208f3795f1a;hp=869cdbbc947d1402527fe44b99eeab8da0cc5e88;hpb=ce02ab2ecd9c6ae2e570abd8c93ebf3be55bbdad;p=sbcl.git diff --git a/src/code/cold-error.lisp b/src/code/cold-error.lisp index 869cdbb..32f71ad 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. @@ -23,6 +22,7 @@ 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." + (/noshow0 "entering SIGNAL") (let ((condition (coerce-to-condition datum arguments 'simple-condition @@ -31,20 +31,29 @@ (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)." + (/noshow0 "doing BREAK in because of *BREAK-ON-SIGNALS*") + (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* (now rebound to NIL)." condition))) (loop - (unless *handler-clusters* (return)) + (unless *handler-clusters* + (/noshow0 "leaving LOOP because of unbound *HANDLER-CLUSTERS*") + (return)) (let ((cluster (pop *handler-clusters*))) + (/noshow0 "got CLUSTER=..") + (/nohexstr cluster) (dolist (handler cluster) + (/noshow0 "looking at HANDLER=..") + (/nohexstr handler) (when (typep condition (car handler)) (funcall (cdr handler) condition))))) + + (/noshow0 "returning from SIGNAL") 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) +;;; a utility for SIGNAL, ERROR, CERROR, WARN, and INVOKE-DEBUGGER: +;;; Parse 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 fun-name) (cond ((typep datum 'condition) (if arguments (cerror "Ignore the additional arguments." @@ -53,7 +62,7 @@ :expected-type 'null :format-control "You may not supply additional arguments ~ when giving ~S to ~S." - :format-arguments (list datum function-name))) + :format-arguments (list datum fun-name))) datum) ((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION) (apply #'make-condition datum arguments)) @@ -66,77 +75,81 @@ :datum datum :expected-type '(or symbol string) :format-control "bad argument to ~S: ~S" - :format-arguments (list function-name datum))))) + :format-arguments (list fun-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 (find-caller-name-and-frame))))) (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." + "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 "printing ERROR arguments one by one..") + + (/show0 "cold-printing ERROR arguments one by one..") #!+sb-show (dolist (argument arguments) (sb!impl::cold-print argument)) - (sb!kernel:infinite-error-protect + (/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)))) + (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint))) + (/show0 "done coercing DATUM to CONDITION") (let ((sb!debug:*stack-top-hint* nil)) + (/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)))) + (let ((condition (coerce-to-condition datum + arguments + 'simple-error + 'error)) + (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) +;;; 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* (maybe-find-stack-top-hint))) + (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) - + (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 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 @@ -147,19 +160,26 @@ (/show0 "ignoring WARN in cold init, arguments=..") #!+sb-show (dolist (argument arguments) (sb!impl::cold-print argument))) - (sb!kernel:infinite-error-protect + (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") + (/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))))) + condition) + (/show0 "back from FORMAT, voila!"))))) nil)