/[cmucl]/src/code/interr.lisp
ViewVC logotype

Contents of /src/code/interr.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.25.1.2 - (show annotations) (vendor branch)
Mon Feb 8 22:25:00 1993 UTC (21 years, 2 months ago) by ram
Branch: new_struct
Changes since 1.25.1.1: +3 -3 lines
object-not-structure-error  => object-not-instance-error 
1 ;;; -*- Log: code.log; Package: KERNEL -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/interr.lisp,v 1.25.1.2 1993/02/08 22:25:00 ram Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Functions and macros to define and deal with internal errors (i.e.
15 ;;; problems that can be signaled from assembler code).
16 ;;;
17 ;;; Written by William Lott.
18 ;;;
19
20 (in-package "KERNEL")
21
22 (export '(infinite-error-protect find-caller-name *maximum-error-depth*))
23
24
25
26 ;;;; Internal Errors
27
28 (defvar *internal-errors*
29 (macrolet ((frob ()
30 (map 'vector #'cdr (c:backend-internal-errors c:*backend*))))
31 (frob)))
32
33
34 (eval-when (compile eval)
35
36 (defmacro deferr (name args &rest body)
37 (let* ((rest-pos (position '&rest args))
38 (required (if rest-pos (subseq args 0 rest-pos) args))
39 (fp (gensym))
40 (sigcontext (gensym))
41 (sc-offsets (gensym))
42 (temp (gensym))
43 (fn-name (symbolicate name "-HANDLER")))
44 `(progn
45 (defun ,fn-name (name ,fp ,sigcontext ,sc-offsets)
46 (declare (ignorable name ,fp ,sigcontext ,sc-offsets))
47 (macrolet ((set-value (var value)
48 (let ((pos (position var ',required)))
49 (unless pos
50 (error "~S isn't one of the required args."
51 var))
52 `(let ((,',temp ,value))
53 (di::sub-set-debug-var-slot
54 ,',fp (nth ,pos ,',sc-offsets)
55 ,',temp ,',sigcontext)
56 (setf ,var ,',temp)))))
57 (let (,@(let ((offset -1))
58 (mapcar #'(lambda (var)
59 `(,var (di::sub-access-debug-var-slot
60 ,fp
61 (nth ,(incf offset)
62 ,sc-offsets)
63 ,sigcontext)))
64 required))
65 ,@(when rest-pos
66 `((,(nth (1+ rest-pos) args)
67 (mapcar #'(lambda (sc-offset)
68 (di::sub-access-debug-var-slot
69 ,fp
70 sc-offset
71 ,sigcontext))
72 (nthcdr ,rest-pos ,sc-offsets))))))
73 ,@body)))
74 (setf (svref *internal-errors* ,(error-number-or-lose name))
75 #',fn-name))))
76
77 ) ; Eval-When (Compile Eval)
78
79
80
81 (deferr unknown-error (&rest args)
82 (error "Unknown error:~{ ~S~})" args))
83
84 (deferr object-not-function-error (object)
85 (error 'type-error
86 :function-name name
87 :datum object
88 :expected-type 'function))
89
90 (deferr object-not-list-error (object)
91 (error 'type-error
92 :function-name name
93 :datum object
94 :expected-type 'list))
95
96 (deferr object-not-bignum-error (object)
97 (error 'type-error
98 :function-name name
99 :datum object
100 :expected-type 'bignum))
101
102 (deferr object-not-ratio-error (object)
103 (error 'type-error
104 :function-name name
105 :datum object
106 :expected-type 'ratio))
107
108 (deferr object-not-single-float-error (object)
109 (error 'type-error
110 :function-name name
111 :datum object
112 :expected-type 'single-float))
113
114 (deferr object-not-double-float-error (object)
115 (error 'type-error
116 :function-name name
117 :datum object
118 :expected-type 'double-float))
119
120 (deferr object-not-simple-string-error (object)
121 (error 'type-error
122 :function-name name
123 :datum object
124 :expected-type 'simple-string))
125
126 (deferr object-not-simple-bit-vector-error (object)
127 (error 'type-error
128 :function-name name
129 :datum object
130 :expected-type 'simple-bit-vector))
131
132 (deferr object-not-simple-vector-error (object)
133 (error 'type-error
134 :function-name name
135 :datum object
136 :expected-type 'simple-vector))
137
138 (deferr object-not-fixnum-error (object)
139 (error 'type-error
140 :function-name name
141 :datum object
142 :expected-type 'fixnum))
143
144 (deferr object-not-function-or-symbol-error (object)
145 (error 'type-error
146 :function-name name
147 :datum object
148 :expected-type '(or function symbol)))
149
150 (deferr object-not-vector-error (object)
151 (error 'type-error
152 :function-name name
153 :datum object
154 :expected-type 'vector))
155
156 (deferr object-not-string-error (object)
157 (error 'type-error
158 :function-name name
159 :datum object
160 :expected-type 'string))
161
162 (deferr object-not-bit-vector-error (object)
163 (error 'type-error
164 :function-name name
165 :datum object
166 :expected-type 'bit-vector))
167
168 (deferr object-not-array-error (object)
169 (error 'type-error
170 :function-name name
171 :datum object
172 :expected-type 'array))
173
174 (deferr object-not-number-error (object)
175 (error 'type-error
176 :function-name name
177 :datum object
178 :expected-type 'number))
179
180 (deferr object-not-rational-error (object)
181 (error 'type-error
182 :function-name name
183 :datum object
184 :expected-type 'rational))
185
186 (deferr object-not-float-error (object)
187 (error 'type-error
188 :function-name name
189 :datum object
190 :expected-type 'float))
191
192 (deferr object-not-real-error (object)
193 (error 'type-error
194 :function-name name
195 :datum object
196 :expected-type 'real))
197
198 (deferr object-not-integer-error (object)
199 (error 'type-error
200 :function-name name
201 :datum object
202 :expected-type 'integer))
203
204 (deferr object-not-cons-error (object)
205 (error 'type-error
206 :function-name name
207 :datum object
208 :expected-type 'cons))
209
210 (deferr object-not-symbol-error (object)
211 (error 'type-error
212 :function-name name
213 :datum object
214 :expected-type 'symbol))
215
216 (deferr undefined-symbol-error (fdefn-or-symbol)
217 (error 'undefined-function
218 :function-name name
219 :name (etypecase fdefn-or-symbol
220 (symbol fdefn-or-symbol)
221 (fdefn (fdefn-name fdefn-or-symbol)))))
222
223 (deferr object-not-coercable-to-function-error (object)
224 (error 'type-error
225 :function-name name
226 :datum object
227 :expected-type 'coercable-to-function))
228
229 (deferr invalid-argument-count-error (nargs)
230 (error 'simple-error
231 :function-name name
232 :format-string "Invalid number of arguments: ~S"
233 :format-arguments (list nargs)))
234
235 (deferr bogus-argument-to-values-list-error (list)
236 (error 'simple-error
237 :function-name name
238 :format-string "Attempt to use VALUES-LIST on a dotted-list:~% ~S"
239 :format-arguments (list list)))
240
241 (deferr unbound-symbol-error (symbol)
242 (error 'unbound-variable :function-name name :name symbol))
243
244 (deferr object-not-base-char-error (object)
245 (error 'type-error
246 :function-name name
247 :datum object
248 :expected-type 'base-char))
249
250 (deferr object-not-sap-error (object)
251 (error 'type-error
252 :function-name name
253 :datum object
254 :expected-type 'system-area-pointer))
255
256 (deferr invalid-unwind-error ()
257 (error 'control-error
258 :function-name name
259 :format-string
260 "Attempt to RETURN-FROM a block or GO to a tag that no longer exists"))
261
262 (deferr unseen-throw-tag-error (tag)
263 (error 'control-error
264 :function-name name
265 :format-string "Attempt to THROW to a tag that does not exist: ~S"
266 :format-arguments (list tag)))
267
268 (deferr nil-function-returned-error (function)
269 (error 'control-error
270 :function-name name
271 :format-string
272 "Function with declared result type NIL returned:~% ~S"
273 :format-arguments (list function)))
274
275 (deferr division-by-zero-error (this that)
276 (error 'division-by-zero
277 :function-name name
278 :operation 'division
279 :operands (list this that)))
280
281 (deferr object-not-type-error (object type)
282 (error (if (and (%instancep object)
283 (layout-invalid (%instance-layout object)))
284 'layout-invalid
285 'type-error)
286 :function-name name
287 :datum object
288 :expected-type type))
289
290 (deferr layout-invalid-error (object layout)
291 (error 'layout-invalid
292 :function-name name
293 :datum object
294 :expected-type (layout-class layout)))
295
296 (deferr odd-keyword-arguments-error ()
297 (error 'simple-error
298 :function-name name
299 :format-string "Odd number of keyword arguments."))
300
301 (deferr unknown-keyword-argument-error (key)
302 (error 'simple-error
303 :function-name name
304 :format-string "Unknown keyword: ~S"
305 :format-arguments (list key)))
306
307 (deferr invalid-array-index-error (array bound index)
308 (error 'simple-error
309 :function-name name
310 :format-string
311 "Invalid array index, ~D for ~S. Should have been less than ~D"
312 :format-arguments (list index array bound)))
313
314 (deferr object-not-simple-array-error (object)
315 (error 'type-error
316 :function-name name
317 :datum object
318 :expected-type 'simple-array))
319
320 (deferr object-not-signed-byte-32-error (object)
321 (error 'type-error
322 :function-name name
323 :datum object
324 :expected-type '(signed-byte 32)))
325
326 (deferr object-not-unsigned-byte-32-error (object)
327 (error 'type-error
328 :function-name name
329 :datum object
330 :expected-type '(unsigned-byte 32)))
331
332 (deferr object-not-simple-array-unsigned-byte-2-error (object)
333 (error 'type-error
334 :function-name name
335 :datum object
336 :expected-type '(simple-array (unsigned-byte 2) (*))))
337
338 (deferr object-not-simple-array-unsigned-byte-4-error (object)
339 (error 'type-error
340 :function-name name
341 :datum object
342 :expected-type '(simple-array (unsigned-byte 4) (*))))
343
344 (deferr object-not-simple-array-unsigned-byte-8-error (object)
345 (error 'type-error
346 :function-name name
347 :datum object
348 :expected-type '(simple-array (unsigned-byte 8) (*))))
349
350 (deferr object-not-simple-array-unsigned-byte-16-error (object)
351 (error 'type-error
352 :function-name name
353 :datum object
354 :expected-type '(simple-array (unsigned-byte 16) (*))))
355
356 (deferr object-not-simple-array-unsigned-byte-32-error (object)
357 (error 'type-error
358 :function-name name
359 :datum object
360 :expected-type '(simple-array (unsigned-byte 32) (*))))
361
362 (deferr object-not-simple-array-single-float-error (object)
363 (error 'type-error
364 :function-name name
365 :datum object
366 :expected-type '(simple-array single-float (*))))
367
368 (deferr object-not-simple-array-double-float-error (object)
369 (error 'type-error
370 :function-name name
371 :datum object
372 :expected-type '(simple-array double-float (*))))
373
374 (deferr object-not-complex-error (object)
375 (error 'type-error
376 :function-name name
377 :datum object
378 :expected-type 'complex))
379
380 (deferr object-not-weak-pointer-error (object)
381 (error 'type-error
382 :function-name name
383 :datum object
384 :expected-type 'weak-pointer))
385
386 (deferr object-not-instance-error (object)
387 (error 'type-error
388 :function-name name
389 :datum object
390 :expected-type 'instance))
391
392
393
394 ;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out of
395 ;;; hyperspace.
396 ;;;
397 (defmacro infinite-error-protect (&rest forms)
398 `(if (and (boundp '*error-system-initialized*)
399 (numberp *current-error-depth*))
400 (let ((*current-error-depth* (1+ *current-error-depth*)))
401 (if (> *current-error-depth* *maximum-error-depth*)
402 (error-error "Help! " *current-error-depth* " nested errors. "
403 "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
404 (progn ,@forms)))
405 (%primitive halt)))
406
407 ;;; Track the depth of recursive errors.
408 ;;;
409 (defvar *maximum-error-depth* 10
410 "The maximum number of nested errors allowed. Internal errors are
411 double-counted.")
412 (defvar *current-error-depth* 0 "The current number of nested errors.")
413
414 ;;; These specials are used by ERROR-ERROR to track the success of recovery
415 ;;; attempts.
416 ;;;
417 (defvar *error-error-depth* 0)
418 (defvar *error-throw-up-count* 0)
419
420 ;;; This protects against errors that happen before we run this top-level form.
421 ;;;
422 (defvar *error-system-initialized* t)
423
424 ;;; ERROR-ERROR can be called when the error system is in trouble and needs
425 ;;; to punt fast. Prints a message without using format. If we get into
426 ;;; this recursively, then halt.
427 ;;;
428 (defun error-error (&rest messages)
429 (let ((*error-error-depth* (1+ *error-error-depth*)))
430 (when (> *error-throw-up-count* 50)
431 (%primitive halt)
432 (throw 'lisp::top-level-catcher nil))
433 (case *error-error-depth*
434 (1)
435 (2
436 (lisp::stream-init))
437 (3
438 (incf *error-throw-up-count*)
439 (throw 'lisp::top-level-catcher nil))
440 (t
441 (%primitive halt)
442 (throw 'lisp::top-level-catcher nil)))
443
444 (with-standard-io-syntax
445 (let ((*print-readably* nil))
446 (dolist (item messages) (princ item *terminal-io*))
447 (debug:internal-debug)))))
448
449
450 ;;;; Fetching errorful function name.
451
452 ;;; Used to prevent infinite recursive lossage when we can't find the caller
453 ;;; for some reason.
454 ;;;
455 (defvar *finding-name* nil)
456
457 ;;; FIND-CALLER-NAME -- Internal
458 ;;;
459 (defun find-caller-name ()
460 (if *finding-name*
461 (values "<error finding name>" nil)
462 (handler-case
463 (let* ((*finding-name* t)
464 (frame (di:frame-down (di:frame-down (di:top-frame))))
465 (name (di:debug-function-name
466 (di:frame-debug-function frame))))
467 (di:flush-frames-above frame)
468 (values name frame))
469 (error ()
470 (values "<error finding name>" nil))
471 (di:debug-condition ()
472 (values "<error finding name>" nil)))))
473
474
475 (defun find-interrupted-name ()
476 (if *finding-name*
477 (values "<error finding name>" nil)
478 (handler-case
479 (let ((*finding-name* t))
480 (do ((frame (di:top-frame) (di:frame-down frame)))
481 ((or (null frame)
482 (and (di::compiled-frame-p frame)
483 (di::compiled-frame-escaped frame)))
484 (if (di::compiled-frame-p frame)
485 (values (di:debug-function-name
486 (di:frame-debug-function frame))
487 (progn
488 (di:flush-frames-above frame)
489 frame))
490 (values "<error finding name>" nil)))))
491 (error ()
492 (values "<error finding name>" nil))
493 (di:debug-condition ()
494 (values "<error finding name>" nil)))))
495
496
497 ;;;; internal-error signal handler.
498
499 (defun internal-error (scp continuable)
500 (declare (type system-area-pointer scp) (ignore continuable))
501 (infinite-error-protect
502 (let ((scp (locally
503 (declare (optimize (inhibit-warnings 3)))
504 (alien:sap-alien scp (* unix:sigcontext)))))
505 (multiple-value-bind
506 (error-number arguments)
507 (vm:internal-error-arguments scp)
508 (multiple-value-bind
509 (name debug:*stack-top-hint*)
510 (find-interrupted-name)
511 (let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset)))
512 (handler (and (< -1 error-number (length *internal-errors*))
513 (svref *internal-errors* error-number))))
514 (cond ((null handler)
515 (error 'simple-error
516 :function-name name
517 :format-string
518 "Unknown internal error, ~D? args=~S"
519 :format-arguments
520 (list error-number
521 (mapcar #'(lambda (sc-offset)
522 (di::sub-access-debug-var-slot
523 fp sc-offset scp))
524 arguments))))
525 ((not (functionp handler))
526 (error 'simple-error
527 :function-name name
528 :format-string
529 "Internal error ~D: ~A. args=~S"
530 :format-arguments
531 (list error-number
532 handler
533 (mapcar #'(lambda (sc-offset)
534 (di::sub-access-debug-var-slot
535 fp sc-offset scp))
536 arguments))))
537 (t
538 (funcall handler name fp scp arguments)))))))))
539

  ViewVC Help
Powered by ViewVC 1.1.5