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

Contents of /src/code/interr.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.24 - (hide annotations)
Sat Mar 28 21:07:08 1992 UTC (22 years, 1 month 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 wlott 1.1 ;;; -*- Log: code.log; Package: KERNEL -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.16 ;;; 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 wlott 1.24 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/interr.lisp,v 1.24 1992/03/28 21:07:08 wlott Exp $")
11 ram 1.16 ;;;
12 wlott 1.1 ;;; **********************************************************************
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 wlott 1.24 (export '(infinite-error-protect find-caller-name *maximum-error-depth*))
23 wlott 1.1
24    
25    
26     ;;;; Internal Errors
27    
28 wlott 1.24 (defvar *internal-errors*
29     (macrolet ((frob ()
30     (map 'vector #'cdr (c:backend-internal-errors c:*backend*))))
31     (frob)))
32 wlott 1.1
33    
34     (eval-when (compile eval)
35    
36 wlott 1.24 (defmacro deferr (name args &rest body)
37 wlott 1.7 (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 wlott 1.24 (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 wlott 1.1
77 wlott 1.7 ) ; Eval-When (Compile Eval)
78 wlott 1.1
79    
80    
81 wlott 1.24 (deferr unknown-error (&rest args)
82 wlott 1.1 (error "Unknown error:~{ ~S~})" args))
83    
84 wlott 1.24 (deferr object-not-function-error (object)
85 wlott 1.15 (error 'type-error
86     :function-name name
87     :datum object
88     :expected-type 'function))
89 wlott 1.1
90 wlott 1.24 (deferr object-not-list-error (object)
91 wlott 1.15 (error 'type-error
92     :function-name name
93     :datum object
94     :expected-type 'list))
95 wlott 1.1
96 wlott 1.24 (deferr object-not-bignum-error (object)
97 wlott 1.15 (error 'type-error
98     :function-name name
99     :datum object
100     :expected-type 'bignum))
101 wlott 1.1
102 wlott 1.24 (deferr object-not-ratio-error (object)
103 wlott 1.15 (error 'type-error
104     :function-name name
105     :datum object
106     :expected-type 'ratio))
107 wlott 1.1
108 wlott 1.24 (deferr object-not-single-float-error (object)
109 wlott 1.15 (error 'type-error
110     :function-name name
111     :datum object
112     :expected-type 'single-float))
113 wlott 1.1
114 wlott 1.24 (deferr object-not-double-float-error (object)
115 wlott 1.15 (error 'type-error
116     :function-name name
117     :datum object
118     :expected-type 'double-float))
119 wlott 1.1
120 wlott 1.24 (deferr object-not-simple-string-error (object)
121 wlott 1.15 (error 'type-error
122     :function-name name
123     :datum object
124     :expected-type 'simple-string))
125 wlott 1.1
126 wlott 1.24 (deferr object-not-simple-bit-vector-error (object)
127 wlott 1.15 (error 'type-error
128     :function-name name
129     :datum object
130     :expected-type 'simple-bit-vector))
131 wlott 1.1
132 wlott 1.24 (deferr object-not-simple-vector-error (object)
133 wlott 1.15 (error 'type-error
134     :function-name name
135     :datum object
136     :expected-type 'simple-vector))
137 wlott 1.1
138 wlott 1.24 (deferr object-not-fixnum-error (object)
139 wlott 1.15 (error 'type-error
140     :function-name name
141     :datum object
142     :expected-type 'fixnum))
143 wlott 1.1
144 wlott 1.24 (deferr object-not-function-or-symbol-error (object)
145 wlott 1.15 (error 'type-error
146     :function-name name
147     :datum object
148     :expected-type '(or function symbol)))
149 wlott 1.1
150 wlott 1.24 (deferr object-not-vector-error (object)
151 wlott 1.15 (error 'type-error
152     :function-name name
153     :datum object
154     :expected-type 'vector))
155 wlott 1.1
156 wlott 1.24 (deferr object-not-string-error (object)
157 wlott 1.15 (error 'type-error
158     :function-name name
159     :datum object
160     :expected-type 'string))
161 wlott 1.1
162 wlott 1.24 (deferr object-not-bit-vector-error (object)
163 wlott 1.15 (error 'type-error
164     :function-name name
165     :datum object
166     :expected-type 'bit-vector))
167 wlott 1.1
168 wlott 1.24 (deferr object-not-array-error (object)
169 wlott 1.15 (error 'type-error
170     :function-name name
171     :datum object
172     :expected-type 'array))
173 wlott 1.1
174 wlott 1.24 (deferr object-not-number-error (object)
175 wlott 1.15 (error 'type-error
176     :function-name name
177     :datum object
178     :expected-type 'number))
179 wlott 1.1
180 wlott 1.24 (deferr object-not-rational-error (object)
181 wlott 1.15 (error 'type-error
182     :function-name name
183     :datum object
184     :expected-type 'rational))
185 wlott 1.1
186 wlott 1.24 (deferr object-not-float-error (object)
187 wlott 1.15 (error 'type-error
188     :function-name name
189     :datum object
190     :expected-type 'float))
191 wlott 1.1
192 wlott 1.24 (deferr object-not-real-error (object)
193 wlott 1.15 (error 'type-error
194     :function-name name
195     :datum object
196     :expected-type 'real))
197 wlott 1.1
198 wlott 1.24 (deferr object-not-integer-error (object)
199 wlott 1.15 (error 'type-error
200     :function-name name
201     :datum object
202     :expected-type 'integer))
203 wlott 1.1
204 wlott 1.24 (deferr object-not-cons-error (object)
205 wlott 1.15 (error 'type-error
206     :function-name name
207     :datum object
208     :expected-type 'cons))
209 wlott 1.1
210 wlott 1.24 (deferr object-not-symbol-error (object)
211 wlott 1.15 (error 'type-error
212     :function-name name
213     :datum object
214     :expected-type 'symbol))
215 wlott 1.1
216 wlott 1.24 (deferr undefined-symbol-error (symbol)
217 wlott 1.15 (error 'undefined-function
218     :function-name name
219     :name symbol))
220 wlott 1.1
221 wlott 1.24 (deferr object-not-coercable-to-function-error (object)
222 wlott 1.15 (error 'type-error
223     :function-name name
224     :datum object
225     :expected-type 'coercable-to-function))
226 wlott 1.1
227 wlott 1.24 (deferr invalid-argument-count-error (nargs)
228 wlott 1.15 (error 'simple-error
229     :function-name name
230     :format-string "Invalid number of arguments: ~S"
231     :format-arguments (list nargs)))
232 wlott 1.1
233 wlott 1.24 (deferr bogus-argument-to-values-list-error (list)
234 wlott 1.15 (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 wlott 1.1
239 wlott 1.24 (deferr unbound-symbol-error (symbol)
240 wlott 1.15 (error 'unbound-variable :function-name name :name symbol))
241 wlott 1.1
242 wlott 1.24 (deferr object-not-base-char-error (object)
243 wlott 1.15 (error 'type-error
244     :function-name name
245     :datum object
246 wlott 1.18 :expected-type 'base-char))
247 wlott 1.1
248 wlott 1.24 (deferr object-not-sap-error (object)
249 wlott 1.15 (error 'type-error
250     :function-name name
251     :datum object
252     :expected-type 'system-area-pointer))
253 wlott 1.1
254 wlott 1.24 (deferr invalid-unwind-error ()
255 wlott 1.15 (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 wlott 1.1
260 wlott 1.24 (deferr unseen-throw-tag-error (tag)
261 wlott 1.15 (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 ram 1.19
266 wlott 1.24 (deferr nil-function-returned-error (function)
267 ram 1.19 (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 wlott 1.1
273 wlott 1.24 (deferr division-by-zero-error (this that)
274 wlott 1.15 (error 'division-by-zero
275     :function-name name
276     :operation 'division
277     :operands (list this that)))
278 wlott 1.1
279 wlott 1.24 (deferr object-not-type-error (object type)
280 wlott 1.15 (error 'type-error
281     :function-name name
282     :datum object
283     :expected-type type))
284 wlott 1.1
285 wlott 1.24 (deferr odd-keyword-arguments-error ()
286 wlott 1.15 (error 'simple-error
287     :function-name name
288     :format-string "Odd number of keyword arguments."))
289 wlott 1.1
290 wlott 1.24 (deferr unknown-keyword-argument-error (key)
291 wlott 1.15 (error 'simple-error
292     :function-name name
293     :format-string "Unknown keyword: ~S"
294     :format-arguments (list key)))
295 wlott 1.1
296 wlott 1.24 (deferr invalid-array-index-error (array bound index)
297 wlott 1.15 (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 wlott 1.1
303 wlott 1.24 (deferr object-not-simple-array-error (object)
304 wlott 1.15 (error 'type-error
305     :function-name name
306     :datum object
307     :expected-type 'simple-array))
308 wlott 1.1
309 wlott 1.24 (deferr object-not-signed-byte-32-error (object)
310 wlott 1.15 (error 'type-error
311     :function-name name
312     :datum object
313     :expected-type '(signed-byte 32)))
314 wlott 1.1
315 wlott 1.24 (deferr object-not-unsigned-byte-32-error (object)
316 wlott 1.15 (error 'type-error
317     :function-name name
318     :datum object
319     :expected-type '(unsigned-byte 32)))
320 wlott 1.1
321 wlott 1.24 (deferr object-not-simple-array-unsigned-byte-2-error (object)
322 wlott 1.15 (error 'type-error
323     :function-name name
324     :datum object
325     :expected-type '(simple-array (unsigned-byte 2) (*))))
326 wlott 1.1
327 wlott 1.24 (deferr object-not-simple-array-unsigned-byte-4-error (object)
328 wlott 1.15 (error 'type-error
329     :function-name name
330     :datum object
331     :expected-type '(simple-array (unsigned-byte 4) (*))))
332 wlott 1.1
333 wlott 1.24 (deferr object-not-simple-array-unsigned-byte-8-error (object)
334 wlott 1.15 (error 'type-error
335     :function-name name
336     :datum object
337     :expected-type '(simple-array (unsigned-byte 8) (*))))
338 wlott 1.1
339 wlott 1.24 (deferr object-not-simple-array-unsigned-byte-16-error (object)
340 wlott 1.15 (error 'type-error
341     :function-name name
342     :datum object
343     :expected-type '(simple-array (unsigned-byte 16) (*))))
344 wlott 1.1
345 wlott 1.24 (deferr object-not-simple-array-unsigned-byte-32-error (object)
346 wlott 1.15 (error 'type-error
347     :function-name name
348     :datum object
349     :expected-type '(simple-array (unsigned-byte 32) (*))))
350 wlott 1.1
351 wlott 1.24 (deferr object-not-simple-array-single-float-error (object)
352 wlott 1.15 (error 'type-error
353     :function-name name
354     :datum object
355     :expected-type '(simple-array single-float (*))))
356 wlott 1.1
357 wlott 1.24 (deferr object-not-simple-array-double-float-error (object)
358 wlott 1.15 (error 'type-error
359     :function-name name
360     :datum object
361     :expected-type '(simple-array double-float (*))))
362 wlott 1.1
363 wlott 1.24 (deferr object-not-complex-error (object)
364 wlott 1.15 (error 'type-error
365     :function-name name
366     :datum object
367     :expected-type 'complex))
368 wlott 1.1
369 wlott 1.24 (deferr object-not-weak-pointer-error (object)
370 wlott 1.15 (error 'type-error
371     :function-name name
372     :datum object
373     :expected-type 'weak-pointer))
374 wlott 1.11
375 wlott 1.24 (deferr object-not-structure-error (object)
376 wlott 1.15 (error 'type-error
377 wlott 1.11 :function-name name
378 wlott 1.15 :datum object
379     :expected-type 'structure))
380    
381 wlott 1.1
382    
383 ram 1.20 ;;; 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 ram 1.21 (error-error "Help! " *current-error-depth* " nested errors. "
392 ram 1.20 "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
393     (progn ,@forms)))
394     (%primitive halt)))
395 wlott 1.1
396 ram 1.20 ;;; 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 wlott 1.6
403 ram 1.20 ;;; 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 ram 1.21 (let ((*print-readably* nil))
435     (dolist (item messages) (princ item *terminal-io*))
436     (debug:internal-debug)))))
437 ram 1.20
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 ram 1.21 (defvar *finding-name* nil)
445 ram 1.20
446     ;;; FIND-CALLER-NAME -- Internal
447     ;;;
448     (defun find-caller-name ()
449 ram 1.21 (if *finding-name*
450 wlott 1.23 (values "<error finding name>" nil)
451 ram 1.20 (handler-case
452 wlott 1.23 (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 ram 1.20
463    
464 wlott 1.6 (defun find-interrupted-name ()
465     (if *finding-name*
466 wlott 1.23 (values "<error finding name>" nil)
467 wlott 1.6 (handler-case
468     (let ((*finding-name* t))
469     (do ((frame (di:top-frame) (di:frame-down frame)))
470     ((or (null frame)
471 wlott 1.10 (and (di::compiled-frame-p frame)
472     (di::compiled-frame-escaped frame)))
473     (if (di::compiled-frame-p frame)
474 wlott 1.23 (values (di:debug-function-name
475     (di:frame-debug-function frame))
476 wlott 1.24 (progn
477     (di:flush-frames-above frame)
478     frame))
479 wlott 1.23 (values "<error finding name>" nil)))))
480     (error ()
481     (values "<error finding name>" nil))
482     (di:debug-condition ()
483     (values "<error finding name>" nil)))))
484 wlott 1.6
485 ram 1.20
486     ;;;; internal-error signal handler.
487 wlott 1.6
488 wlott 1.13 (defun internal-error (scp continuable)
489 wlott 1.22 (declare (type system-area-pointer scp) (ignore continuable))
490 ram 1.20 (infinite-error-protect
491 wlott 1.24 (let ((scp (locally
492     (declare (optimize (inhibit-warnings 3)))
493     (alien:sap-alien scp (* unix:sigcontext)))))
494 wlott 1.22 (multiple-value-bind
495     (error-number arguments)
496     (vm:internal-error-arguments scp)
497 wlott 1.23 (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 wlott 1.24 (handler (and (< -1 error-number (length *internal-errors*))
502     (svref *internal-errors* error-number))))
503     (cond ((null handler)
504 wlott 1.23 (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 wlott 1.24 ((not (functionp handler))
515 wlott 1.23 (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 wlott 1.24 handler
522 wlott 1.23 (mapcar #'(lambda (sc-offset)
523     (di::sub-access-debug-var-slot
524     fp sc-offset scp))
525     arguments))))
526     (t
527 wlott 1.24 (funcall handler name fp scp arguments)))))))))
528 ram 1.20

  ViewVC Help
Powered by ViewVC 1.1.5