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

Contents of /src/code/interr.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5