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

Contents of /src/code/interr.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5