X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcold-error.lisp;h=7718c2937cf8bbe9376643344e9fd82613257ce8;hb=ef8fd235fa2ca39e444710d1bc275acbc8d3279c;hp=17e8600f09a8fbc0499e5cb49c2adc8f09e25c34;hpb=4eb1a6d3ad2b7dcc19ac0ec979a1eb1eb049659a;p=sbcl.git diff --git a/src/code/cold-error.lisp b/src/code/cold-error.lisp index 17e8600..7718c29 100644 --- a/src/code/cold-error.lisp +++ b/src/code/cold-error.lisp @@ -32,7 +32,7 @@ (*break-on-signals* nil)) (when (typep condition old-bos) (/noshow0 "doing BREAK in because of *BREAK-ON-SIGNALS*") - (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* (now NIL)." + (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* (now rebound to NIL)." condition))) (loop (unless *handler-clusters* @@ -50,33 +50,6 @@ (/noshow0 "returning from SIGNAL") nil)) -;;; 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." - '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 fun-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 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 @@ -84,7 +57,7 @@ (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))))) + (nth-value 1 (find-caller-name-and-frame))))) (defun error (datum &rest arguments) #!+sb-doc @@ -98,7 +71,7 @@ (sb!impl::cold-print argument)) (/show0 "done cold-printing ERROR arguments") - (sb!kernel:infinite-error-protect + (infinite-error-protect (let ((condition (coerce-to-condition datum arguments 'simple-error 'error)) (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint))) @@ -110,15 +83,13 @@ (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))) + (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)) @@ -128,11 +99,11 @@ ;;; 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 +;;; 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) - (sb!kernel:infinite-error-protect + (infinite-error-protect (with-simple-restart (continue "Return from ~S." what) (let ((sb!debug:*stack-top-hint* (maybe-find-stack-top-hint))) (invoke-debugger @@ -162,7 +133,7 @@ (/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)))