;;;; 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. ;;;; ;;;; This software is derived from the CMU CL system, which was ;;;; written at Carnegie Mellon University and released into the ;;;; public domain. The software is in the public domain and is ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. (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 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)) (let ((cluster (pop *handler-clusters*))) (dolist (handler cluster) (when (typep condition (car handler)) (funcall (cdr handler) condition))))) nil)) (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, 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)) (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) (infinite-error-protect (with-simple-restart (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." (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." (/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 ;; ideal would be to clean up cold load so that it doesn't call WARN.. ;; -- 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))) (infinite-error-protect (/show0 "doing COERCE-TO-CONDITION") (let ((condition (coerce-to-condition datum arguments '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)