1 ;;;; miscellaneous error stuff that needs to be in the cold load
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!KERNEL")
14 (defvar *break-on-signals* nil
16 "When (TYPEP condition *BREAK-ON-SIGNALS*) is true, then calls to SIGNAL will
17 enter the debugger prior to signalling that condition.")
19 (defun signal (datum &rest arguments)
21 "Invokes the signal facility on a condition formed from DATUM and
22 ARGUMENTS. If the condition is not handled, NIL is returned. If
23 (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked
24 before any signalling is done."
25 (let ((condition (coerce-to-condition datum
29 (*handler-clusters* *handler-clusters*)
30 (old-bos *break-on-signals*)
31 (bos-actually-breaking nil))
33 (let ((break-on-signals *break-on-signals*)
34 (*break-on-signals* nil))
35 ;; The rebinding encloses the TYPEP so that a bogus
36 ;; type specifier will not lead to infinite recursion when
38 (when (typep condition break-on-signals)
39 (setf bos-actually-breaking t)
40 (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* ~
41 (now rebound to NIL)."
43 ;; Give the user a chance to unset *BREAK-ON-SIGNALS* on the
46 ;; (e.g.: Consider a long compilation. After a failed compile
47 ;; the user sets *BREAK-ON-SIGNALS* to T, and select the
48 ;; RECOMPILE restart. Once the user diagnoses and fixes the
49 ;; problem, he selects RECOMPILE again... and discovers that
50 ;; he's entered the *BREAK-ON-SIGNALS* hell with no escape,
51 ;; unless we provide this restart.)
56 (if bos-actually-breaking
57 "Return from BREAK and assign a new value to ~
59 "Assign a new value to *BREAK-ON-SIGNALS* and ~
60 continue with signal handling.")))
66 "Enter new value for *BREAK-ON-SIGNALS*. ~
67 Current value is ~S.~%~
70 (force-output *query-io*)
71 (let ((*break-on-signals* nil))
72 (setf new-value (eval (read *query-io*)))
73 (if (typep new-value 'type-specifier)
76 "~S is not a valid value for *BREAK-ON-SIGNALS* ~
77 (must be a type-specifier).~%"
80 (setf *break-on-signals* new-value)))
82 (unless *handler-clusters*
84 (let ((cluster (pop *handler-clusters*)))
85 (dolist (handler cluster)
86 (when (typep condition (car handler))
87 (funcall (cdr handler) condition)))))
90 (defun error (datum &rest arguments)
92 "Invoke the signal facility on a condition formed from DATUM and ARGUMENTS.
93 If the condition is not handled, the debugger is invoked."
94 (/show0 "entering ERROR, argument list=..")
97 (/show0 "cold-printing ERROR arguments one by one..")
98 #!+sb-show (dolist (argument arguments)
99 (sb!impl::cold-print argument))
100 (/show0 "done cold-printing ERROR arguments")
102 (infinite-error-protect
103 (let ((condition (coerce-to-condition datum arguments
104 'simple-error 'error))
105 (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'error)))
106 (/show0 "done coercing DATUM to CONDITION")
107 (/show0 "signalling CONDITION from within ERROR")
109 (/show0 "done signalling CONDITION within ERROR")
110 (invoke-debugger condition))))
112 (defun cerror (continue-string datum &rest arguments)
113 (infinite-error-protect
115 (continue "~A" (apply #'format nil continue-string arguments))
116 (let ((condition (coerce-to-condition datum
120 (with-condition-restarts condition (list (find-restart 'continue))
121 (let ((sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'cerror)))
123 (invoke-debugger condition))))))
126 ;;; like BREAK, but without rebinding *DEBUGGER-HOOK* to NIL, so that
127 ;;; we can use it in system code (e.g. in SIGINT handling) without
128 ;;; messing up --disable-debugger mode (which works by setting
129 ;;; *DEBUGGER-HOOK*); or for that matter, without messing up ordinary
130 ;;; applications which try to do similar things with *DEBUGGER-HOOK*
131 (defun %break (what &optional (datum "break") &rest arguments)
132 (infinite-error-protect
133 (with-simple-restart (continue "Return from ~S." what)
134 (let ((sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* '%break)))
136 (coerce-to-condition datum arguments 'simple-condition what)))))
139 (defun break (&optional (datum "break") &rest arguments)
141 "Print a message and invoke the debugger without allowing any possibility
142 of condition handling occurring."
143 (declare (optimize (sb!c::rest-conversion 0)))
144 (let ((*debugger-hook* nil) ; as specifically required by ANSI
145 (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'break)))
146 (apply #'%break 'break datum arguments)))
148 (defun warn (datum &rest arguments)
150 "Warn about a situation by signalling a condition formed by DATUM and
151 ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart
152 exists that causes WARN to immediately return NIL."
153 (/show0 "entering WARN")
154 ;; KLUDGE: The current cold load initialization logic causes several calls
155 ;; to WARN, so we need to be able to handle them without dying. (And calling
156 ;; FORMAT or even PRINC in cold load is a good way to die.) Of course, the
157 ;; ideal would be to clean up cold load so that it doesn't call WARN..
159 (if (not *cold-init-complete-p*)
161 (/show0 "ignoring WARN in cold init, arguments=..")
162 #!+sb-show (dolist (argument arguments)
163 (sb!impl::cold-print argument)))
164 (infinite-error-protect
165 (/show0 "doing COERCE-TO-CONDITION")
166 (let ((condition (coerce-to-condition datum arguments
167 'simple-warning 'warn)))
168 (/show0 "back from COERCE-TO-CONDITION, doing ENFORCE-TYPE")
169 (enforce-type condition warning)
170 (/show0 "back from ENFORCE-TYPE, doing RESTART-CASE MUFFLE-WARNING")
171 (restart-case (signal condition)
173 :report "Skip warning."
174 (return-from warn nil)))
175 (/show0 "back from RESTART-CASE MUFFLE-WARNING (i.e. normal return)")
177 (let ((badness (etypecase condition
178 (style-warning 'style-warning)
179 (warning 'warning))))
180 (/show0 "got BADNESS, calling FORMAT")
181 (format *error-output*
182 "~&~@<~S: ~3i~:_~A~:>~%"
185 (/show0 "back from FORMAT, voila!")))))