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 maybe-break-on-signal (condition)
20 (let ((old-bos *break-on-signals
*)
21 (bos-actually-breaking nil
))
23 (let ((break-on-signals *break-on-signals
*)
24 (*break-on-signals
* nil
))
25 ;; The rebinding encloses the TYPEP so that a bogus
26 ;; type specifier will not lead to infinite recursion when
28 (when (typep condition break-on-signals
)
29 (setf bos-actually-breaking t
)
30 (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* ~
31 (now rebound to NIL)."
33 ;; Give the user a chance to unset *BREAK-ON-SIGNALS* on the
36 ;; (e.g.: Consider a long compilation. After a failed compile
37 ;; the user sets *BREAK-ON-SIGNALS* to T, and select the
38 ;; RECOMPILE restart. Once the user diagnoses and fixes the
39 ;; problem, he selects RECOMPILE again... and discovers that
40 ;; he's entered the *BREAK-ON-SIGNALS* hell with no escape,
41 ;; unless we provide this restart.)
46 (if bos-actually-breaking
47 "Return from BREAK and assign a new value to ~
49 "Assign a new value to *BREAK-ON-SIGNALS* and ~
50 continue with signal handling.")))
56 "Enter new value for *BREAK-ON-SIGNALS*. ~
57 Current value is ~S.~%~
60 (force-output *query-io
*)
61 (let ((*break-on-signals
* nil
))
62 (setf new-value
(eval (read *query-io
*)))
63 (if (typep new-value
'type-specifier
)
66 "~S is not a valid value for *BREAK-ON-SIGNALS* ~
67 (must be a type-specifier).~%"
70 (setf *break-on-signals
* new-value
)))))
72 (defun signal (datum &rest arguments
)
74 "Invokes the signal facility on a condition formed from DATUM and
75 ARGUMENTS. If the condition is not handled, NIL is returned. If
76 (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked
77 before any signalling is done."
79 (coerce-to-condition datum arguments
'simple-condition
'signal
))
80 (handler-clusters *handler-clusters
*)
81 (sb!debug
:*stack-top-hint
* (or sb
!debug
:*stack-top-hint
* 'signal
))
82 ;; possible FIXME: despite that fndb says COERCE-TO-CONDITION
83 ;; returns CONDITION, compiler doesn't know that CONDITION
84 ;; is an INSTANCE and emits a type-check.
85 (layout (%instance-layout condition
)))
86 (when *break-on-signals
*
87 (maybe-break-on-signal condition
))
88 (do ((cluster (pop handler-clusters
) (pop handler-clusters
)))
91 ;; Remove CLUSTER from *HANDLER-CLUSTERS*: if a condition is
92 ;; signaled in either the type test, i.e. (the function (car
93 ;; handler)), or the handler, (the function (cdr handler)), the
94 ;; recursive SIGNAL call should not consider CLUSTER as doing
95 ;; would lead to infinite recursive SIGNAL calls.
96 (let ((*handler-clusters
* handler-clusters
))
97 (dolist (handler cluster
)
98 (macrolet ((cast-to-fun (f possibly-symbolp
)
99 ;; For efficiency the cases are tested in this order:
100 ;; - FUNCTIONP is just a lowtag test
101 ;; - FDEFN-P is a lowtag + widetag.
102 ;; Avoiding a SYMBOLP test is fine because
103 ;; SYMBOL-FUNCTION rejects bogosity anyway.
105 (cond ((functionp f
) f
)
106 (,(if possibly-symbolp
`(fdefn-p f
) 't
)
107 (sb!c
:safe-fdefn-fun f
))
108 ,@(if possibly-symbolp
109 `((t (symbol-function f
))))))))
110 (let ((test (car (truly-the cons handler
))))
111 (when (if (%instancep test
) ; a condition classoid cell
112 (classoid-cell-typep layout test condition
)
113 (funcall (cast-to-fun test nil
) condition
))
114 (funcall (cast-to-fun (cdr handler
) t
) condition
)))))))))
116 ;;;; working with *CURRENT-ERROR-DEPTH* and *MAXIMUM-ERROR-DEPTH*
118 ;;; counts of nested errors (with internal errors double-counted)
119 (defvar *maximum-error-depth
*) ; this gets set to 10 in !COLD-INIT
120 (!defvar
*current-error-depth
* 0)
122 ;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out
124 (defmacro infinite-error-protect
(&rest forms
)
125 `(let ((*current-error-depth
* (infinite-error-protector)))
126 (/show0
"in INFINITE-ERROR-PROTECT, incremented error depth")
127 ;; This is almost totally unhelpful. Running with #!+sb-show does not mean
128 ;; that you care to see an additional 16K characters of output
129 ;; each time this macro is used when no error is actually happening.
130 #|
#!+sb-show
(sb!debug
:print-backtrace
:count
8) ; arbitrary truncation |#
133 ;;; a helper function for INFINITE-ERROR-PROTECT
134 (defun infinite-error-protector ()
135 (/show0
"entering INFINITE-ERROR-PROTECTOR, *CURRENT-ERROR-DEPTH*=..")
136 (/hexstr
*current-error-depth
*)
137 ;; *MAXIMUM-ERROR-DEPTH* is not bound during cold-init, and testing BOUNDP
138 ;; is superfluous since REALP will return false either way.
139 (let ((cur (locally (declare (optimize (safety 0))) *current-error-depth
*))
140 (max (locally (declare (optimize (safety 0))) *maximum-error-depth
*)))
141 (cond ((or (not (fixnump cur
)) (not (fixnump max
)))
142 (%primitive print
"Argh! corrupted error depth, halting")
143 (%primitive sb
!c
:halt
))
145 (/show0
"*MAXIMUM-ERROR-DEPTH*=..")
147 (/show0
"in INFINITE-ERROR-PROTECTOR, calling ERROR-ERROR")
148 (sb!impl
::error-error
"Help! "
151 "SB-KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded."))
153 (/show0
"returning normally from INFINITE-ERROR-PROTECTOR")
154 (1+ *current-error-depth
*)))))
156 (defun error (datum &rest arguments
)
158 "Invoke the signal facility on a condition formed from DATUM and ARGUMENTS.
159 If the condition is not handled, the debugger is invoked."
160 (/show0
"entering ERROR, argument list=..")
163 (/show0
"cold-printing ERROR arguments one by one..")
164 #!+sb-show
(dolist (argument arguments
)
165 (sb!impl
::cold-print argument
))
166 (/show0
"done cold-printing ERROR arguments")
168 (infinite-error-protect
169 (let ((condition (coerce-to-condition datum arguments
170 'simple-error
'error
))
171 (sb!debug
:*stack-top-hint
* (or sb
!debug
:*stack-top-hint
* 'error
)))
172 (/show0
"done coercing DATUM to CONDITION")
173 (/show0
"signalling CONDITION from within ERROR")
175 (/show0
"done signalling CONDITION within ERROR")
176 (invoke-debugger condition
))))
178 (defun cerror (continue-string datum
&rest arguments
)
179 (infinite-error-protect
181 (continue "~A" (apply #'format nil continue-string arguments
))
182 (let ((condition (coerce-to-condition datum
186 (with-condition-restarts condition
(list (find-restart 'continue
))
187 (let ((sb!debug
:*stack-top-hint
* (or sb
!debug
:*stack-top-hint
* 'cerror
)))
189 (invoke-debugger condition
))))))
192 ;;; like BREAK, but without rebinding *DEBUGGER-HOOK* to NIL, so that
193 ;;; we can use it in system code (e.g. in SIGINT handling) without
194 ;;; messing up --disable-debugger mode (which works by setting
195 ;;; *DEBUGGER-HOOK*); or for that matter, without messing up ordinary
196 ;;; applications which try to do similar things with *DEBUGGER-HOOK*
197 (defun %break
(what &optional
(datum "break") &rest arguments
)
198 (infinite-error-protect
199 (with-simple-restart (continue "Return from ~S." what
)
200 (let ((sb!debug
:*stack-top-hint
* (or sb
!debug
:*stack-top-hint
* '%break
)))
202 (coerce-to-condition datum arguments
'simple-condition what
)))))
205 (defun break (&optional
(datum "break") &rest arguments
)
207 "Print a message and invoke the debugger without allowing any possibility
208 of condition handling occurring."
209 (let ((*debugger-hook
* nil
) ; as specifically required by ANSI
210 (sb!debug
:*stack-top-hint
* (or sb
!debug
:*stack-top-hint
* 'break
)))
211 (apply #'%break
'break datum arguments
)))
213 (defun %warn
(datum arguments super default-type
)
214 (infinite-error-protect
215 (let ((condition (coerce-to-condition datum arguments default-type
'warn
))
216 (superclassoid-name (classoid-name super
)))
217 ;: CONDITION is necessarily an INSTANCE,
218 ;; but pedantry requires it be the right subtype of instance.
219 (unless (classoid-typep (%instance-layout condition
)
221 (error 'simple-type-error
222 :datum datum
:expected-type superclassoid-name
223 :format-control
"~S does not designate a ~A class"
224 :format-arguments
(list datum superclassoid-name
)))
225 (restart-case (signal condition
)
227 :report
"Skip warning."
228 (return-from %warn nil
)))
229 (format *error-output
* "~&~@<~S: ~3i~:_~A~:>~%"
230 superclassoid-name condition
)))
233 (defun warn (datum &rest arguments
)
235 "Warn about a situation by signalling a condition formed by DATUM and
236 ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart
237 exists that causes WARN to immediately return NIL."
238 (%warn datum arguments
(find-classoid 'warning
) 'simple-warning
))
240 (defun style-warn (datum &rest arguments
)
241 (%warn datum arguments
(find-classoid 'style-warning
) 'simple-style-warning
))