Fix FORMAT compilation on non-simple strings.
[sbcl.git] / src / code / cold-error.lisp
blobf1d8e69ea8a693726a409d359fe308930cd9acd7
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
4 ;;;; more information.
5 ;;;;
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
15 "When (TYPEP condition *BREAK-ON-SIGNALS*) is true, then calls to SIGNAL will
16 enter the debugger prior to signalling that condition.")
18 (defun maybe-break-on-signal (condition)
19 (let ((old-bos *break-on-signals*)
20 (bos-actually-breaking nil))
21 (restart-case
22 (let ((break-on-signals *break-on-signals*)
23 (*break-on-signals* nil))
24 ;; The rebinding encloses the TYPEP so that a bogus
25 ;; type specifier will not lead to infinite recursion when
26 ;; TYPEP fails.
27 (when (typep condition break-on-signals)
28 (setf bos-actually-breaking t)
29 (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* ~
30 (now rebound to NIL)."
31 condition)))
32 ;; Give the user a chance to unset *BREAK-ON-SIGNALS* on the
33 ;; way out.
35 ;; (e.g.: Consider a long compilation. After a failed compile
36 ;; the user sets *BREAK-ON-SIGNALS* to T, and select the
37 ;; RECOMPILE restart. Once the user diagnoses and fixes the
38 ;; problem, he selects RECOMPILE again... and discovers that
39 ;; he's entered the *BREAK-ON-SIGNALS* hell with no escape,
40 ;; unless we provide this restart.)
41 (reassign (new-value)
42 :report
43 (lambda (stream)
44 (format stream
45 (if bos-actually-breaking
46 "Return from BREAK and assign a new value to ~
47 *BREAK-ON-SIGNALS*."
48 "Assign a new value to *BREAK-ON-SIGNALS* and ~
49 continue with signal handling.")))
50 :interactive
51 (lambda ()
52 (let (new-value)
53 (loop
54 (format *query-io*
55 "Enter new value for *BREAK-ON-SIGNALS*. ~
56 Current value is ~S.~%~
57 > "
58 old-bos)
59 (force-output *query-io*)
60 (let ((*break-on-signals* nil))
61 (setf new-value (eval (read *query-io*)))
62 (if (typep new-value 'type-specifier)
63 (return)
64 (format *query-io*
65 "~S is not a valid value for *BREAK-ON-SIGNALS* ~
66 (must be a type-specifier).~%"
67 new-value))))
68 (list new-value)))
69 (setf *break-on-signals* new-value)))))
71 (defun signal (datum &rest arguments)
72 "Invokes the signal facility on a condition formed from DATUM and
73 ARGUMENTS. If the condition is not handled, NIL is returned. If
74 (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked
75 before any signalling is done."
76 (declare (explicit-check))
77 (%signal (apply #'coerce-to-condition datum 'simple-condition 'signal arguments)))
78 (defun %signal (condition)
79 (let ((handler-clusters *handler-clusters*)
80 (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* '%signal)))
81 (when *break-on-signals*
82 (maybe-break-on-signal condition))
83 (do ((cluster (pop handler-clusters) (pop handler-clusters)))
84 ((null cluster)
85 nil)
86 ;; Remove CLUSTER from *HANDLER-CLUSTERS*: if a condition is
87 ;; signaled in either the type test, i.e. (the function (car
88 ;; handler)), or the handler, (the function (cdr handler)), the
89 ;; recursive SIGNAL call should not consider CLUSTER as doing
90 ;; would lead to infinite recursive SIGNAL calls.
91 (let ((*handler-clusters* handler-clusters))
92 (dolist (handler cluster)
93 (macrolet ((cast-to-fun (f possibly-symbolp)
94 ;; For efficiency the cases are tested in this order:
95 ;; - FUNCTIONP is just a lowtag test
96 ;; - FDEFN-P is a lowtag + widetag.
97 ;; Avoiding a SYMBOLP test is fine because
98 ;; SYMBOL-FUNCTION rejects bogosity anyway.
99 `(let ((f ,f))
100 (cond ((functionp f) f)
101 (,(if possibly-symbolp `(fdefn-p f) 't)
102 (sb!c:safe-fdefn-fun f))
103 ,@(if possibly-symbolp
104 `((t (symbol-function f))))))))
105 (let ((test (car (truly-the cons handler))))
106 (when (if (%instancep test) ; a condition classoid cell
107 (classoid-cell-typep test condition)
108 (funcall (cast-to-fun test nil) condition))
109 (funcall (cast-to-fun (cdr handler) t) condition)))))))))
111 ;;;; working with *CURRENT-ERROR-DEPTH* and *MAXIMUM-ERROR-DEPTH*
113 ;;; counts of nested errors (with internal errors double-counted)
114 (defvar *maximum-error-depth*) ; this gets set to 10 in !COLD-INIT
115 (!defvar *current-error-depth* 0)
117 ;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out
118 ;;; of hyperspace.
119 (defmacro infinite-error-protect (&rest forms)
120 `(let ((*current-error-depth* (infinite-error-protector)))
121 (/show0 "in INFINITE-ERROR-PROTECT, incremented error depth")
122 ;; This is almost totally unhelpful. Running with #!+sb-show does not mean
123 ;; that you care to see an additional 16K characters of output
124 ;; each time this macro is used when no error is actually happening.
125 #| #!+sb-show (sb!debug:print-backtrace :count 8) ; arbitrary truncation |#
126 ,@forms))
128 ;;; a helper function for INFINITE-ERROR-PROTECT
129 (defun infinite-error-protector ()
130 (/show0 "entering INFINITE-ERROR-PROTECTOR, *CURRENT-ERROR-DEPTH*=..")
131 (/hexstr *current-error-depth*)
132 ;; *MAXIMUM-ERROR-DEPTH* is not bound during cold-init, and testing BOUNDP
133 ;; is superfluous since REALP will return false either way.
134 (let ((cur (locally (declare (optimize (safety 0))) *current-error-depth*))
135 (max (locally (declare (optimize (safety 0))) *maximum-error-depth*)))
136 (cond ((or (not (fixnump cur)) (not (fixnump max)))
137 (%primitive print "Argh! corrupted error depth, halting")
138 (%primitive sb!c:halt))
139 ((> cur max)
140 (/show0 "*MAXIMUM-ERROR-DEPTH*=..")
141 (/hexstr max)
142 (/show0 "in INFINITE-ERROR-PROTECTOR, calling ERROR-ERROR")
143 (sb!impl::error-error "Help! "
145 " nested errors. "
146 "SB-KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded."))
148 (/show0 "returning normally from INFINITE-ERROR-PROTECTOR")
149 (1+ *current-error-depth*)))))
151 (defun error (datum &rest arguments)
152 "Invoke the signal facility on a condition formed from DATUM and ARGUMENTS.
153 If the condition is not handled, the debugger is invoked."
154 (/show0 "entering ERROR, argument list=..")
155 (/hexstr arguments)
157 (/show0 "cold-printing ERROR arguments one by one..")
158 #!+sb-show (dolist (argument arguments)
159 (sb!impl::cold-print argument))
160 (/show0 "done cold-printing ERROR arguments")
162 (infinite-error-protect
163 (let ((condition (apply #'coerce-to-condition datum 'simple-error 'error
164 arguments))
165 (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'error)))
166 (/show0 "signalling CONDITION from within ERROR")
167 (%signal condition)
168 (/show0 "done signalling CONDITION within ERROR")
169 (invoke-debugger condition))))
171 (defun cerror (continue-string datum &rest arguments)
172 (infinite-error-protect
173 (with-simple-restart
174 (continue "~A" (apply #'format nil continue-string arguments))
175 (let ((condition (apply #'coerce-to-condition datum
176 'simple-error 'cerror arguments)))
177 (with-condition-restarts condition (list (find-restart 'continue))
178 (let ((sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'cerror)))
179 (%signal condition)
180 (invoke-debugger condition))))))
181 nil)
183 ;;; like BREAK, but without rebinding *DEBUGGER-HOOK* to NIL, so that
184 ;;; we can use it in system code (e.g. in SIGINT handling) without
185 ;;; messing up --disable-debugger mode (which works by setting
186 ;;; *DEBUGGER-HOOK*); or for that matter, without messing up ordinary
187 ;;; applications which try to do similar things with *DEBUGGER-HOOK*
188 (defun %break (what &optional (datum "break") &rest arguments)
189 (infinite-error-protect
190 (with-simple-restart (continue "Return from ~S." what)
191 (let ((sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* '%break)))
192 (invoke-debugger
193 (apply #'coerce-to-condition datum 'simple-condition what arguments)))))
194 nil)
196 (defun break (&optional (datum "break") &rest arguments)
197 "Print a message and invoke the debugger without allowing any possibility
198 of condition handling occurring."
199 (let ((*debugger-hook* nil) ; as specifically required by ANSI
200 (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'break)))
201 (apply #'%break 'break datum arguments)))
203 ;;; These functions definitions are for cold-init.
204 ;;; The real definitions are found in 'condition.lisp'
205 (defvar *!cold-warn-action* nil)
206 (defun warn (datum &rest arguments)
207 (when (and (stringp datum) (plusp (mismatch "defining setf macro" datum)))
208 (return-from warn nil))
209 (let ((action (cond ((boundp '*!cold-warn-action*) *!cold-warn-action*)
210 ((not (member datum
211 '(asterisks-around-constant-variable-name
212 redefinition-with-defun)))
213 'print))))
214 (when (member action '(lose print))
215 (let ((*package* *cl-package*))
216 (write-string "cold WARN: datum=") ; WRITE could be too broken as yet
217 (write (get-lisp-obj-address datum) :radix t :base 16)
218 (write-string " = ")
219 (write datum)
220 (write-char #\space)
221 (write (get-lisp-obj-address arguments) :radix t :base 16)
222 (terpri)))
223 (when (eq action 'lose) (sb!sys:%primitive sb!c:halt))))
224 (defun style-warn (datum &rest arguments)
225 (declare (notinline warn))
226 (apply 'warn datum arguments))