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

Contents of /src/code/interr.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.24 - (show annotations)
Sat Mar 28 21:07:08 1992 UTC (22 years ago) by wlott
Branch: MAIN
Changes since 1.23: +104 -305 lines
Extract the error number info out of the backend at compile-time, instead
of requiring that the run-time and compile-time info remain consistent.
Fixed FIND-INTERRUPTED-FRAME to FLUSH-FRAMES-ABOVE before returning the
frame.
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.24 1992/03/28 21:07:08 wlott 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 (symbol)
217 (error 'undefined-function
218 :function-name name
219 :name symbol))
220
221 (deferr object-not-coercable-to-function-error (object)
222 (error 'type-error
223 :function-name name
224 :datum object
225 :expected-type 'coercable-to-function))
226
227 (deferr invalid-argument-count-error (nargs)
228 (error 'simple-error
229 :function-name name
230 :format-string "Invalid number of arguments: ~S"
231 :format-arguments (list nargs)))
232
233 (deferr bogus-argument-to-values-list-error (list)
234 (error 'simple-error
235 :function-name name
236 :format-string "Attempt to use VALUES-LIST on a dotted-list:~% ~S"
237 :format-arguments (list list)))
238
239 (deferr unbound-symbol-error (symbol)
240 (error 'unbound-variable :function-name name :name symbol))
241
242 (deferr object-not-base-char-error (object)
243 (error 'type-error
244 :function-name name
245 :datum object
246 :expected-type 'base-char))
247
248 (deferr object-not-sap-error (object)
249 (error 'type-error
250 :function-name name
251 :datum object
252 :expected-type 'system-area-pointer))
253
254 (deferr invalid-unwind-error ()
255 (error 'control-error
256 :function-name name
257 :format-string
258 "Attempt to RETURN-FROM a block or GO to a tag that no longer exists"))
259
260 (deferr unseen-throw-tag-error (tag)
261 (error 'control-error
262 :function-name name
263 :format-string "Attempt to THROW to a tag that does not exist: ~S"
264 :format-arguments (list tag)))
265
266 (deferr nil-function-returned-error (function)
267 (error 'control-error
268 :function-name name
269 :format-string
270 "Function with declared result type NIL returned:~% ~S"
271 :format-arguments (list function)))
272
273 (deferr division-by-zero-error (this that)
274 (error 'division-by-zero
275 :function-name name
276 :operation 'division
277 :operands (list this that)))
278
279 (deferr object-not-type-error (object type)
280 (error 'type-error
281 :function-name name
282 :datum object
283 :expected-type type))
284
285 (deferr odd-keyword-arguments-error ()
286 (error 'simple-error
287 :function-name name
288 :format-string "Odd number of keyword arguments."))
289
290 (deferr unknown-keyword-argument-error (key)
291 (error 'simple-error
292 :function-name name
293 :format-string "Unknown keyword: ~S"
294 :format-arguments (list key)))
295
296 (deferr invalid-array-index-error (array bound index)
297 (error 'simple-error
298 :function-name name
299 :format-string
300 "Invalid array index, ~D for ~S. Should have been less than ~D"
301 :format-arguments (list index array bound)))
302
303 (deferr object-not-simple-array-error (object)
304 (error 'type-error
305 :function-name name
306 :datum object
307 :expected-type 'simple-array))
308
309 (deferr object-not-signed-byte-32-error (object)
310 (error 'type-error
311 :function-name name
312 :datum object
313 :expected-type '(signed-byte 32)))
314
315 (deferr object-not-unsigned-byte-32-error (object)
316 (error 'type-error
317 :function-name name
318 :datum object
319 :expected-type '(unsigned-byte 32)))
320
321 (deferr object-not-simple-array-unsigned-byte-2-error (object)
322 (error 'type-error
323 :function-name name
324 :datum object
325 :expected-type '(simple-array (unsigned-byte 2) (*))))
326
327 (deferr object-not-simple-array-unsigned-byte-4-error (object)
328 (error 'type-error
329 :function-name name
330 :datum object
331 :expected-type '(simple-array (unsigned-byte 4) (*))))
332
333 (deferr object-not-simple-array-unsigned-byte-8-error (object)
334 (error 'type-error
335 :function-name name
336 :datum object
337 :expected-type '(simple-array (unsigned-byte 8) (*))))
338
339 (deferr object-not-simple-array-unsigned-byte-16-error (object)
340 (error 'type-error
341 :function-name name
342 :datum object
343 :expected-type '(simple-array (unsigned-byte 16) (*))))
344
345 (deferr object-not-simple-array-unsigned-byte-32-error (object)
346 (error 'type-error
347 :function-name name
348 :datum object
349 :expected-type '(simple-array (unsigned-byte 32) (*))))
350
351 (deferr object-not-simple-array-single-float-error (object)
352 (error 'type-error
353 :function-name name
354 :datum object
355 :expected-type '(simple-array single-float (*))))
356
357 (deferr object-not-simple-array-double-float-error (object)
358 (error 'type-error
359 :function-name name
360 :datum object
361 :expected-type '(simple-array double-float (*))))
362
363 (deferr object-not-complex-error (object)
364 (error 'type-error
365 :function-name name
366 :datum object
367 :expected-type 'complex))
368
369 (deferr object-not-weak-pointer-error (object)
370 (error 'type-error
371 :function-name name
372 :datum object
373 :expected-type 'weak-pointer))
374
375 (deferr object-not-structure-error (object)
376 (error 'type-error
377 :function-name name
378 :datum object
379 :expected-type 'structure))
380
381
382
383 ;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out of
384 ;;; hyperspace.
385 ;;;
386 (defmacro infinite-error-protect (&rest forms)
387 `(if (and (boundp '*error-system-initialized*)
388 (numberp *current-error-depth*))
389 (let ((*current-error-depth* (1+ *current-error-depth*)))
390 (if (> *current-error-depth* *maximum-error-depth*)
391 (error-error "Help! " *current-error-depth* " nested errors. "
392 "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
393 (progn ,@forms)))
394 (%primitive halt)))
395
396 ;;; Track the depth of recursive errors.
397 ;;;
398 (defvar *maximum-error-depth* 10
399 "The maximum number of nested errors allowed. Internal errors are
400 double-counted.")
401 (defvar *current-error-depth* 0 "The current number of nested errors.")
402
403 ;;; These specials are used by ERROR-ERROR to track the success of recovery
404 ;;; attempts.
405 ;;;
406 (defvar *error-error-depth* 0)
407 (defvar *error-throw-up-count* 0)
408
409 ;;; This protects against errors that happen before we run this top-level form.
410 ;;;
411 (defvar *error-system-initialized* t)
412
413 ;;; ERROR-ERROR can be called when the error system is in trouble and needs
414 ;;; to punt fast. Prints a message without using format. If we get into
415 ;;; this recursively, then halt.
416 ;;;
417 (defun error-error (&rest messages)
418 (let ((*error-error-depth* (1+ *error-error-depth*)))
419 (when (> *error-throw-up-count* 50)
420 (%primitive halt)
421 (throw 'lisp::top-level-catcher nil))
422 (case *error-error-depth*
423 (1)
424 (2
425 (lisp::stream-init))
426 (3
427 (incf *error-throw-up-count*)
428 (throw 'lisp::top-level-catcher nil))
429 (t
430 (%primitive halt)
431 (throw 'lisp::top-level-catcher nil)))
432
433 (with-standard-io-syntax
434 (let ((*print-readably* nil))
435 (dolist (item messages) (princ item *terminal-io*))
436 (debug:internal-debug)))))
437
438
439 ;;;; Fetching errorful function name.
440
441 ;;; Used to prevent infinite recursive lossage when we can't find the caller
442 ;;; for some reason.
443 ;;;
444 (defvar *finding-name* nil)
445
446 ;;; FIND-CALLER-NAME -- Internal
447 ;;;
448 (defun find-caller-name ()
449 (if *finding-name*
450 (values "<error finding name>" nil)
451 (handler-case
452 (let* ((*finding-name* t)
453 (frame (di:frame-down (di:frame-down (di:top-frame))))
454 (name (di:debug-function-name
455 (di:frame-debug-function frame))))
456 (di:flush-frames-above frame)
457 (values name frame))
458 (error ()
459 (values "<error finding name>" nil))
460 (di:debug-condition ()
461 (values "<error finding name>" nil)))))
462
463
464 (defun find-interrupted-name ()
465 (if *finding-name*
466 (values "<error finding name>" nil)
467 (handler-case
468 (let ((*finding-name* t))
469 (do ((frame (di:top-frame) (di:frame-down frame)))
470 ((or (null frame)
471 (and (di::compiled-frame-p frame)
472 (di::compiled-frame-escaped frame)))
473 (if (di::compiled-frame-p frame)
474 (values (di:debug-function-name
475 (di:frame-debug-function frame))
476 (progn
477 (di:flush-frames-above frame)
478 frame))
479 (values "<error finding name>" nil)))))
480 (error ()
481 (values "<error finding name>" nil))
482 (di:debug-condition ()
483 (values "<error finding name>" nil)))))
484
485
486 ;;;; internal-error signal handler.
487
488 (defun internal-error (scp continuable)
489 (declare (type system-area-pointer scp) (ignore continuable))
490 (infinite-error-protect
491 (let ((scp (locally
492 (declare (optimize (inhibit-warnings 3)))
493 (alien:sap-alien scp (* unix:sigcontext)))))
494 (multiple-value-bind
495 (error-number arguments)
496 (vm:internal-error-arguments scp)
497 (multiple-value-bind
498 (name debug:*stack-top-hint*)
499 (find-interrupted-name)
500 (let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset)))
501 (handler (and (< -1 error-number (length *internal-errors*))
502 (svref *internal-errors* error-number))))
503 (cond ((null handler)
504 (error 'simple-error
505 :function-name name
506 :format-string
507 "Unknown internal error, ~D? args=~S"
508 :format-arguments
509 (list error-number
510 (mapcar #'(lambda (sc-offset)
511 (di::sub-access-debug-var-slot
512 fp sc-offset scp))
513 arguments))))
514 ((not (functionp handler))
515 (error 'simple-error
516 :function-name name
517 :format-string
518 "Internal error ~D: ~A. args=~S"
519 :format-arguments
520 (list error-number
521 handler
522 (mapcar #'(lambda (sc-offset)
523 (di::sub-access-debug-var-slot
524 fp sc-offset scp))
525 arguments))))
526 (t
527 (funcall handler name fp scp arguments)))))))))
528

  ViewVC Help
Powered by ViewVC 1.1.5