-
Notifications
You must be signed in to change notification settings - Fork 313
/
error.lisp
344 lines (326 loc) · 18.2 KB
/
error.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
;;;; SBCL-specific parts of the condition system, i.e. parts which
;;;; don't duplicate/clobber functionality already provided by the
;;;; cross-compilation host Common Lisp
;;;; 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")
;;; a utility for SIGNAL, ERROR, CERROR, WARN, COMPILER-NOTIFY 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 default-type fun-name &rest arguments)
(declare (explicit-check)
(dynamic-extent arguments))
(cond ((and (%instancep datum)
(let ((layout (%instance-layout datum)))
(and (logtest (layout-flags layout) +condition-layout-flag+)
;; An invalid layout will drop into the (MAKE-CONDITION) branch
;; which rightly fails because ALLOCATE-CONDITION asserts that
;; the first argument is a condition-designator, which it won't be.
(not (layout-invalid layout)))))
(when (and arguments (not (eq fun-name 'cerror)))
(cerror "Ignore the additional arguments."
'simple-type-error
:datum (copy-list arguments)
:expected-type 'null
:format-control "You may not supply additional arguments ~
when giving ~S to ~S."
:format-arguments (list datum fun-name)))
datum)
((or (stringp datum) (functionp datum))
(make-condition default-type
:format-control datum
:format-arguments (copy-list arguments)))
(t
(apply #'make-condition datum arguments))))
;;; This condition inherits from the hosts's classes when compiling
;;; the cross-compiler and the target's when cross-compiling.
(define-condition simple-program-error (simple-condition program-error) ())
(defun %program-error (&optional datum &rest arguments)
(error (apply #'coerce-to-condition datum
'simple-program-error '%program-error arguments)))
;;;; HANDLER-BIND
(sb-xc:defmacro %handler-bind (bindings form &environment env)
(unless bindings
(return-from %handler-bind form))
;; Type specifiers in BINDINGS which name classoids are parsed
;; into the classoid, otherwise are translated local TYPEP wrappers.
;;
;; As a further optimization, it is possible to eliminate some runtime
;; consing (which is a speed win if not a space win, since it's dx already)
;; in special cases such as (HANDLER-BIND ((WARNING #'MUFFLE-WARNING)) ...).
;; If all bindings are optimizable, then the runtime cost of making them
;; is one dx cons cell for the whole cluster.
;; Otherwise it takes 1+2N cons cells where N is the number of bindings.
;;
(collect ((cluster-entries) (dummy-forms))
(flet ((const-cons (test handler)
;; If possible, render HANDLER as a load-time constant so that
;; consing the test and handler is also load-time constant.
(if (and (listp handler)
(memq (car handler) '(quote function))
(not (sb-c::fun-locally-defined-p (cadr handler) env))
(legal-fun-name-p (cadr handler)))
;; The CLHS writeup of HANDLER-BIND says "Exceptional Situations: None."
;; which might suggest that it's not an error if #'HANDLER is un-fboundp
;; on entering the body, but we should check in safe code.
(let ((name (cadr handler)))
(cond ((info :function :info name) ; known
;; This takes care of CONTINUE,ABORT,MUFFLE-WARNING.
;; #' will be evaluated in the null environment.
`(load-time-value (cons ,test (the (function (condition)) #',name))
t))
(t
(when (eq (car handler) 'function)
;; Referencing #'F is enough to get a compile-time warning about unknown
;; functions, but the use itself is flushable, so employ SAFE-FDEFN-FUN.
(dummy-forms `#',name)
(when (sb-c:policy env (= safety 3))
(dummy-forms `(sb-c:safe-fdefn-fun
(load-time-value
(find-or-create-fdefn ',name) t)))))
`(load-time-value
(cons ,test (the (function-designator (condition)) ',name))
t))))
`(cons ,(case (car test)
((named-lambda function) test)
(t `(load-time-value ,test t)))
(the (function-designator (condition)) ,handler))))
(const-list (items)
;; If the resultant list is (LIST (L-T-V ...) (L-T-V ...) ...)
;; then pull the L-T-V outside.
(if (every (lambda (x) (typep x '(cons (eql load-time-value))))
items)
`(load-time-value (list ,@(mapcar #'second items)) t)
`(list ,@items))))
(with-current-source-form (bindings)
(dolist (binding bindings)
(with-current-source-form (binding)
(unless (proper-list-of-length-p binding 2)
(error "ill-formed handler binding: ~S" binding))
(destructuring-bind (type handler) binding
(setq type (typexpand type env))
;; Simplify a singleton AND or OR.
(when (typep type '(cons (member and or) (cons t null)))
(setf type (second type)))
(cluster-entries
(const-cons
;; Compute the test expression
(cond ((member type '(t condition))
;; Every signal is necesarily a CONDITION, so
;; whether you wrote T or CONDITION, this is
;; always an eligible handler.
'#'constantly-t)
((typep type '(cons (eql satisfies) (cons symbol null)))
;; (SATISFIES F) => #'F but never a local definition of F.
;; The predicate is used only if needed - it's not an error if not
;; fboundp (though dangerously stupid) - so reference #'F for the
;; compiler to see the use of the name. But (KLUDGE): since the
;; ref is to force a compile-time effect, the interpreter should not
;; see that form, because there is no way for it to perform an
;; unsafe ref, and it wouldn't signal a style-warning anyway.
(let ((name (second type)))
;; FIXME: if you've locally flet NAME (why would you do that?)
;; then this does not notice the use of the global function.
(when (typep env 'lexenv) (dummy-forms `#',name))
`',name))
((and (symbolp type)
(condition-classoid-p (find-classoid type nil)))
;; It's debatable whether we need to go through
;; a classoid-cell instead of just using
;; load-time-value on FIND-CLASS, but the extra
;; indirection is safer, and no slower than
;; what TYPEP does.
`(find-classoid-cell ',type :create t))
(t ; No runtime consing here- not a closure.
`(named-lambda (%handler-bind ,type) (c)
(declare (optimize (sb-c:verify-arg-count 0)))
(typep c ',type))))
;; If the supplied handler is spelled (LAMBDA ...) or
;; #'(LAMBDA ...), then insert a declaration to elide
;; arg checking.
;;
;; KLUDGE: This should really be done in a cleaner way.
(let ((lambda-expression
(typecase handler
((cons (eql function) (cons (cons (eql lambda)) null))
(cadr handler))
((cons (eql lambda))
handler))))
(if lambda-expression
`(lambda ,(cadr lambda-expression)
(declare (sb-c::source-form ,binding))
,@(when (typep (cadr lambda-expression) '(cons t null))
'((declare (sb-c::local-optimize (sb-c::verify-arg-count 0)))))
,@(cddr lambda-expression))
handler))))))))
`(let ((*handler-clusters*
(cons ,(const-list (cluster-entries))
*handler-clusters*)))
(declare (dynamic-extent *handler-clusters*))
,@(dummy-forms)
,form))))
(sb-xc:defmacro handler-bind (bindings &body forms)
"(HANDLER-BIND ( {(type handler)}* ) body)
Executes body in a dynamic context where the given handler bindings are in
effect. Each handler must take the condition being signalled as an argument.
The bindings are searched first to last in the event of a signalled
condition."
;; Bindings which meet specific criteria can be established with
;; slightly less runtime overhead than in general.
;; To allow the optimization, TYPE must be either be (SATISFIES P)
;; or a symbol naming a condition class at compile time,
;; and HANDLER must be a global function specified as either 'F or #'F.
`(%handler-bind ,bindings
#-x86 (progn ,@forms)
;; Need to catch FP errors here!
#+x86 (multiple-value-prog1 (progn ,@forms) (float-wait))))
;;;; HANDLER-CASE and IGNORE-ERRORS.
(sb-xc:defmacro handler-case (form &rest cases)
"(HANDLER-CASE form { (type ([var]) body) }* )
Execute FORM in a context with handlers established for the condition types. A
peculiar property allows type to be :NO-ERROR. If such a clause occurs, and
form returns normally, all its values are passed to this clause as if by
MULTIPLE-VALUE-CALL. The :NO-ERROR clause accepts more than one var
specification."
(let ((no-error-clause (assoc ':no-error cases)))
(if no-error-clause
(let ((normal-return (make-symbol "normal-return"))
(error-return (make-symbol "error-return")))
`(block ,error-return
(multiple-value-call (lambda ,@(cdr no-error-clause))
(block ,normal-return
(return-from ,error-return
(handler-case (return-from ,normal-return ,form)
,@(remove no-error-clause cases)))))))
(let* ((local-funs nil)
(annotated-cases
(mapcar (lambda (case)
(with-current-source-form (case)
(with-unique-names (block fun)
(destructuring-bind (type ll &body body) case
(unless (and (listp ll)
(symbolp (car ll))
(null (cdr ll)))
(error "Malformed HANDLER-CASE lambda-list. Should be either () or (symbol), not ~s."
ll))
(multiple-value-bind (body declarations)
(parse-body body nil)
(push `(,fun ,ll
(declare (sb-c::source-form ,case))
,@declarations
(progn ,@body))
local-funs))
(list block type ll fun)))))
cases)))
(with-unique-names (block form-fun)
(let ((body `(%handler-bind
,(mapcar (lambda (annotated-case)
(destructuring-bind (block type ll fun-name) annotated-case
(declare (ignore fun-name))
(list type
`(lambda (temp)
,@(unless ll
`((declare (ignore temp))))
(return-from ,block
,@(and ll '(temp)))))))
annotated-cases)
(return-from ,block (,form-fun)))))
(labels ((wrap (cases)
(if cases
(destructuring-bind (fun-block type ll fun-name) (car cases)
(declare (ignore type))
`(return-from ,block
,(if ll
`(,fun-name (block ,fun-block
,(wrap (cdr cases))))
`(progn (block ,fun-block
,(wrap (cdr cases)))
(,fun-name)))))
body)))
`(dx-flet ((,form-fun ()
#-x86 (progn ,form) ;; no declarations are accepted
;; Need to catch FP errors here!
#+x86 (multiple-value-prog1 ,form (float-wait)))
,@(reverse local-funs))
(declare (inline ,form-fun
,@(mapcar #'car local-funs)))
(block ,block
,(wrap annotated-cases))))))))))
(sb-xc:defmacro ignore-errors (&rest forms)
"Execute FORMS handling ERROR conditions, returning the result of the last
form, or (VALUES NIL the-ERROR-that-was-caught) if an ERROR was handled."
`(handler-case (progn ,@forms)
(error (condition) (values nil condition))))
;;; Condition slot access - needs DYNAMIC-SPACE-OBJ-P which needs misc-aliens
;;; which isn't available in target-error.
#-sb-xc-host
(labels
((atomic-acons (condition key val alist)
;; Force new conses to the heap if instance is arena-allocated
(cas (condition-assigned-slots condition)
alist
(if (dynamic-space-obj-p condition)
(locally (declare (sb-c::tlab :system)) (acons key val alist))
(acons key val alist))))
(initval (instance slot classoid operation)
(let ((instance-length (%instance-length instance)))
(do ((i (+ sb-vm:instance-data-start 1) (+ i 2)))
((>= i instance-length)
(find-slot-default instance classoid slot
(eq operation 'slot-boundp)))
(when (memq (%instance-ref instance i) (condition-slot-initargs slot))
(return (%instance-ref instance (1+ i)))))))
(%get (condition name operation)
;; Shared code for CONDITION-SLOT-VALUE and CONDITION-SLOT-BOUNDP.
;; First look for a slot with :CLASS allocation
(let ((classoid (layout-classoid (%instance-layout condition))))
(dolist (cslot (condition-classoid-class-slots classoid))
(when (eq (condition-slot-name cslot) name)
(return-from %get (car (condition-slot-cell cslot)))))
(let* ((alist (condition-assigned-slots condition))
(cell (assq name alist)))
(when cell (return-from %get (cdr cell)))
;; find the slot definition or else signal an error
(let* ((slot (or (find-condition-class-slot classoid name)
(return-from %get
(values (slot-missing (classoid-pcl-class classoid)
condition name 'slot-value)))))
(val (initval condition slot classoid operation)))
(loop
(let ((old (atomic-acons condition name val alist)))
(when (eq old alist) (return val))
(setq alist old cell (assq name alist))
(when cell (return (cdr cell))))))))))
;; This is a stupid argument order. Shouldn't NEW-VALUE be first ?
(defun set-condition-slot-value (condition new-value name)
(dolist (cslot (condition-classoid-class-slots
(layout-classoid (%instance-layout condition))))
(when (eq (condition-slot-name cslot) name)
(return-from set-condition-slot-value
(setf (car (condition-slot-cell cslot)) new-value))))
;; Apparently this does not care that there might not exist a slot named NAME
;; in the class, at least in this function. It seems to be handled
;; at a higher level of the slot access protocol.
(let ((alist (condition-assigned-slots condition)))
(loop
(let ((cell (assq name alist)))
(when cell
(return (setf (cdr cell) new-value))))
(let ((old (atomic-acons condition name new-value alist)))
(if (eq old alist) (return new-value) (setq alist old))))))
(defun condition-slot-value (condition name)
(let ((value (%get condition name 'slot-value)))
(if (unbound-marker-p value)
(let ((class (classoid-pcl-class (layout-classoid (%instance-layout condition)))))
(values (slot-unbound class condition name)))
value)))
(defun condition-slot-boundp (condition name)
(not (unbound-marker-p (%get condition name 'slot-boundp))))
(defun condition-slot-makunbound (condition name)
(set-condition-slot-value condition sb-pcl:+slot-unbound+ name)))