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

Contents of /src/code/interr.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (hide annotations)
Sat Nov 9 02:47:16 1991 UTC (22 years, 5 months ago) by wlott
Branch: MAIN
Changes since 1.17: +6 -6 lines
Changed BASE-CHARACTER to BASE-CHAR
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.18 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/interr.lisp,v 1.18 1991/11/09 02:47:16 wlott Exp $")
11 ram 1.16 ;;;
12 wlott 1.1 ;;; **********************************************************************
13     ;;;
14 wlott 1.18 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/interr.lisp,v 1.18 1991/11/09 02:47:16 wlott Exp $
15 wlott 1.1 ;;;
16     ;;; Functions and macros to define and deal with internal errors (i.e.
17     ;;; problems that can be signaled from assembler code).
18     ;;;
19     ;;; Written by William Lott.
20     ;;;
21    
22     (in-package "KERNEL")
23    
24     (export '(error-number-or-lose))
25    
26     (export '(unknown-error object-not-function-error object-not-list-error
27     object-not-bignum-error object-not-ratio-error
28     object-not-single-float-error object-not-double-float-error
29     object-not-simple-string-error object-not-simple-bit-vector-error
30     object-not-simple-vector-error object-not-fixnum-error
31     object-not-function-or-symbol-error object-not-vector-error
32     object-not-string-error object-not-bit-vector-error
33     object-not-array-error object-not-number-error
34     object-not-rational-error object-not-float-error
35     object-not-real-error object-not-integer-error
36     object-not-cons-error object-not-symbol-error
37     undefined-symbol-error object-not-coercable-to-function-error
38     invalid-argument-count-error bogus-argument-to-values-list-error
39 wlott 1.18 unbound-symbol-error object-not-base-char-error
40 wlott 1.1 object-not-sap-error invalid-unwind-error unseen-throw-tag-error
41     division-by-zero-error object-not-type-error
42     odd-keyword-arguments-error unknown-keyword-argument-error
43     not-<=-error not-=-error invalid-array-index-error
44     wrong-number-of-indices-error object-not-simple-array-error
45     object-not-signed-byte-32-error object-not-unsigned-byte-32-error
46     object-not-simple-array-unsigned-byte-2-error
47     object-not-simple-array-unsigned-byte-4-error
48     object-not-simple-array-unsigned-byte-8-error
49     object-not-simple-array-unsigned-byte-16-error
50     object-not-simple-array-unsigned-byte-32-error
51     object-not-simple-array-single-float-error
52     object-not-simple-array-double-float-error
53 wlott 1.11 object-not-complex-error object-not-weak-pointer-error
54     object-not-structure-error))
55 wlott 1.1
56    
57    
58     ;;;; Internal Errors
59    
60     (defvar *internal-errors* (make-array 10 :initial-element nil))
61    
62     (defstruct (error-info
63     (:print-function %print-error-info))
64     name
65     description
66     function)
67    
68     (defun %print-error-info (info stream depth)
69     (declare (ignore depth))
70     (format stream "#<error-info for ~S>" (error-info-name info)))
71    
72     (defun error-number-or-lose (name)
73     (or (position-if #'(lambda (info)
74     (and info (eq name (error-info-name info))))
75     *internal-errors*)
76     (error "Unknown internal error: ~S" name)))
77    
78    
79     (eval-when (compile eval)
80    
81 wlott 1.3 (defvar *meta-errors*)
82 wlott 1.1 (setf *meta-errors* (make-array 10 :initial-element nil))
83    
84     (defun meta-error-number (name)
85     (or (when (boundp '*internal-errors*)
86     (position-if #'(lambda (info)
87     (and info (eq name (error-info-name info))))
88     *internal-errors*))
89     (position name *meta-errors*)
90     (do ((number 0 (1+ number)))
91     ((and (or (not (boundp '*internal-errors*))
92     (>= number (length *internal-errors*))
93     (null (svref *internal-errors* number)))
94     (or (>= number (length *meta-errors*))
95     (null (svref *meta-errors* number))))
96     (when (>= number (length *meta-errors*))
97     (setf *meta-errors*
98     (replace (make-array (+ number 10) :initial-element nil)
99     *meta-errors*)))
100     (setf (svref *meta-errors* number) name)
101     number))))
102    
103    
104     (defmacro deferr (name description args &rest body)
105 wlott 1.7 (let* ((rest-pos (position '&rest args))
106     (required (if rest-pos (subseq args 0 rest-pos) args))
107     (fp (gensym))
108     (sigcontext (gensym))
109     (sc-offsets (gensym))
110     (temp (gensym)))
111     `(%deferr ',name
112     ,(meta-error-number name)
113     ,description
114 wlott 1.10 #+new-compiler
115 wlott 1.7 #'(lambda (name ,fp ,sigcontext ,sc-offsets)
116 wlott 1.9 (declare (ignorable name ,fp ,sigcontext ,sc-offsets))
117 wlott 1.7 (macrolet ((set-value (var value)
118     (let ((pos (position var ',required)))
119     (unless pos
120     (error "~S isn't one of the required args."
121     var))
122     `(let ((,',temp ,value))
123     (di::sub-set-debug-var-slot
124     ,',fp (nth ,pos ,',sc-offsets)
125     ,',temp ,',sigcontext)
126     (setf ,var ,',temp)))))
127     (let (,@(let ((offset -1))
128     (mapcar #'(lambda (var)
129     `(,var (di::sub-access-debug-var-slot
130     ,fp
131     (nth ,(incf offset)
132     ,sc-offsets)
133     ,sigcontext)))
134     required))
135     ,@(when rest-pos
136     `((,(nth (1+ rest-pos) args)
137     (mapcar #'(lambda (sc-offset)
138     (di::sub-access-debug-var-slot
139     ,fp
140     sc-offset
141     ,sigcontext))
142     (nthcdr ,rest-pos ,sc-offsets))))))
143     ,@body))))))
144 wlott 1.1
145 wlott 1.15
146 wlott 1.7 ) ; Eval-When (Compile Eval)
147 wlott 1.1
148 wlott 1.10 (defun %deferr (name number description #+new-compiler function)
149 wlott 1.1 (when (>= number (length *internal-errors*))
150     (setf *internal-errors*
151     (replace (make-array (+ number 10) :initial-element nil)
152     *internal-errors*)))
153     (setf (svref *internal-errors* number)
154     (make-error-info :name name
155     :description description
156 wlott 1.10 #+new-compiler :function #+new-compiler function))
157 wlott 1.1 name)
158    
159    
160    
161 wlott 1.7
162 wlott 1.1 (deferr unknown-error
163     "Unknown. System lossage."
164     (&rest args)
165     (error "Unknown error:~{ ~S~})" args))
166    
167     (deferr object-not-function-error
168     "Object is not of type FUNCTION."
169 wlott 1.7 (object)
170 wlott 1.15 (error 'type-error
171     :function-name name
172     :datum object
173     :expected-type 'function))
174 wlott 1.1
175     (deferr object-not-list-error
176     "Object is not of type LIST."
177 wlott 1.15 (object)
178     (error 'type-error
179     :function-name name
180     :datum object
181     :expected-type 'list))
182 wlott 1.1
183     (deferr object-not-bignum-error
184     "Object is not of type BIGNUM."
185 wlott 1.15 (object)
186     (error 'type-error
187     :function-name name
188     :datum object
189     :expected-type 'bignum))
190 wlott 1.1
191     (deferr object-not-ratio-error
192     "Object is not of type RATIO."
193 wlott 1.15 (object)
194     (error 'type-error
195     :function-name name
196     :datum object
197     :expected-type 'ratio))
198 wlott 1.1
199     (deferr object-not-single-float-error
200     "Object is not of type SINGLE-FLOAT."
201 wlott 1.15 (object)
202     (error 'type-error
203     :function-name name
204     :datum object
205     :expected-type 'single-float))
206 wlott 1.1
207     (deferr object-not-double-float-error
208     "Object is not of type DOUBLE-FLOAT."
209 wlott 1.15 (object)
210     (error 'type-error
211     :function-name name
212     :datum object
213     :expected-type 'double-float))
214 wlott 1.1
215     (deferr object-not-simple-string-error
216     "Object is not of type SIMPLE-STRING."
217 wlott 1.15 (object)
218     (error 'type-error
219     :function-name name
220     :datum object
221     :expected-type 'simple-string))
222 wlott 1.1
223     (deferr object-not-simple-bit-vector-error
224     "Object is not of type SIMPLE-BIT-VECTOR."
225 wlott 1.15 (object)
226     (error 'type-error
227     :function-name name
228     :datum object
229     :expected-type 'simple-bit-vector))
230 wlott 1.1
231     (deferr object-not-simple-vector-error
232     "Object is not of type SIMPLE-VECTOR."
233 wlott 1.15 (object)
234     (error 'type-error
235     :function-name name
236     :datum object
237     :expected-type 'simple-vector))
238 wlott 1.1
239     (deferr object-not-fixnum-error
240     "Object is not of type FIXNUM."
241 wlott 1.15 (object)
242     (error 'type-error
243     :function-name name
244     :datum object
245     :expected-type 'fixnum))
246 wlott 1.1
247     (deferr object-not-function-or-symbol-error
248 wlott 1.15 "Object is not of type FUNCTION or SYMBOL."
249     (object)
250     (error 'type-error
251     :function-name name
252     :datum object
253     :expected-type '(or function symbol)))
254 wlott 1.1
255     (deferr object-not-vector-error
256     "Object is not of type VECTOR."
257 wlott 1.15 (object)
258     (error 'type-error
259     :function-name name
260     :datum object
261     :expected-type 'vector))
262 wlott 1.1
263     (deferr object-not-string-error
264     "Object is not of type STRING."
265 wlott 1.15 (object)
266     (error 'type-error
267     :function-name name
268     :datum object
269     :expected-type 'string))
270 wlott 1.1
271     (deferr object-not-bit-vector-error
272     "Object is not of type BIT-VECTOR."
273 wlott 1.15 (object)
274     (error 'type-error
275     :function-name name
276     :datum object
277     :expected-type 'bit-vector))
278 wlott 1.1
279     (deferr object-not-array-error
280     "Object is not of type ARRAY."
281 wlott 1.15 (object)
282     (error 'type-error
283     :function-name name
284     :datum object
285     :expected-type 'array))
286 wlott 1.1
287     (deferr object-not-number-error
288     "Object is not of type NUMBER."
289 wlott 1.15 (object)
290     (error 'type-error
291     :function-name name
292     :datum object
293     :expected-type 'number))
294 wlott 1.1
295     (deferr object-not-rational-error
296     "Object is not of type RATIONAL."
297 wlott 1.15 (object)
298     (error 'type-error
299     :function-name name
300     :datum object
301     :expected-type 'rational))
302 wlott 1.1
303     (deferr object-not-float-error
304     "Object is not of type FLOAT."
305 wlott 1.15 (object)
306     (error 'type-error
307     :function-name name
308     :datum object
309     :expected-type 'float))
310 wlott 1.1
311     (deferr object-not-real-error
312     "Object is not of type REAL."
313 wlott 1.15 (object)
314     (error 'type-error
315     :function-name name
316     :datum object
317     :expected-type 'real))
318 wlott 1.1
319     (deferr object-not-integer-error
320     "Object is not of type INTEGER."
321 wlott 1.15 (object)
322     (error 'type-error
323     :function-name name
324     :datum object
325     :expected-type 'integer))
326 wlott 1.1
327     (deferr object-not-cons-error
328     "Object is not of type CONS."
329 wlott 1.15 (object)
330     (error 'type-error
331     :function-name name
332     :datum object
333     :expected-type 'cons))
334 wlott 1.1
335     (deferr object-not-symbol-error
336     "Object is not of type SYMBOL."
337 wlott 1.15 (object)
338     (error 'type-error
339     :function-name name
340     :datum object
341     :expected-type 'symbol))
342 wlott 1.1
343     (deferr undefined-symbol-error
344     "Undefined symbol."
345 wlott 1.15 (symbol)
346     (error 'undefined-function
347     :function-name name
348     :name symbol))
349 wlott 1.1
350     (deferr object-not-coercable-to-function-error
351     "Object is not coercable to type FUNCTION."
352 wlott 1.15 (object)
353     (error 'type-error
354     :function-name name
355     :datum object
356     :expected-type 'coercable-to-function))
357 wlott 1.1
358     (deferr invalid-argument-count-error
359     "Invalid argument count."
360 wlott 1.7 (nargs)
361 wlott 1.15 (error 'simple-error
362     :function-name name
363     :format-string "Invalid number of arguments: ~S"
364     :format-arguments (list nargs)))
365 wlott 1.1
366     (deferr bogus-argument-to-values-list-error
367     "Bogus argument to VALUES-LIST."
368 wlott 1.15 (list)
369     (error 'simple-error
370     :function-name name
371     :format-string "Attempt to use VALUES-LIST on a dotted-list:~% ~S"
372     :format-arguments (list list)))
373 wlott 1.1
374     (deferr unbound-symbol-error
375     "Unbound symbol."
376 wlott 1.15 (symbol)
377     (error 'unbound-variable :function-name name :name symbol))
378 wlott 1.1
379 wlott 1.18 (deferr object-not-base-char-error
380     "Object is not of type BASE-CHAR."
381 wlott 1.15 (object)
382     (error 'type-error
383     :function-name name
384     :datum object
385 wlott 1.18 :expected-type 'base-char))
386 wlott 1.1
387     (deferr object-not-sap-error
388     "Object is not a System Area Pointer (SAP)."
389 wlott 1.15 (object)
390     (error 'type-error
391     :function-name name
392     :datum object
393     :expected-type 'system-area-pointer))
394 wlott 1.1
395     (deferr invalid-unwind-error
396     "Attempt to RETURN-FROM a block that no longer exists."
397 wlott 1.15 ()
398     (error 'control-error
399     :function-name name
400     :format-string
401     "Attempt to RETURN-FROM a block or GO to a tag that no longer exists"))
402 wlott 1.1
403     (deferr unseen-throw-tag-error
404     "Attempt to THROW to a non-existent tag."
405 wlott 1.15 (tag)
406     (error 'control-error
407     :function-name name
408     :format-string "Attempt to THROW to a tag that does not exist: ~S"
409     :format-arguments (list tag)))
410 wlott 1.1
411     (deferr division-by-zero-error
412     "Attempt to divide by zero."
413 wlott 1.15 (this that)
414     (error 'division-by-zero
415     :function-name name
416     :operation 'division
417     :operands (list this that)))
418 wlott 1.1
419     (deferr object-not-type-error
420     "Object is of the wrong type."
421 wlott 1.15 (object type)
422     (error 'type-error
423     :function-name name
424     :datum object
425     :expected-type type))
426 wlott 1.1
427     (deferr odd-keyword-arguments-error
428     "Odd number of keyword arguments."
429 wlott 1.15 ()
430     (error 'simple-error
431     :function-name name
432     :format-string "Odd number of keyword arguments."))
433 wlott 1.1
434     (deferr unknown-keyword-argument-error
435     "Unknown keyword."
436 wlott 1.15 (key)
437     (error 'simple-error
438     :function-name name
439     :format-string "Unknown keyword: ~S"
440     :format-arguments (list key)))
441 wlott 1.1
442     (deferr not-<=-error
443     "Not less than or equal."
444 wlott 1.15 (this that)
445     (error 'simple-error
446     :function-name name
447     :format-string "Assertion that ~S <= ~S failed."
448     :format-arguments (list this that)))
449 wlott 1.1
450     (deferr not-=-error
451     "Not equal."
452 wlott 1.15 (this that)
453     (error 'simple-error
454     :function-name name
455     :format-string "Assertion that ~S = ~S failed."
456     :format-arguments (list this that)))
457 wlott 1.1
458     (deferr invalid-array-index-error
459     "Invalid array index."
460 wlott 1.15 (array bound index)
461     (error 'simple-error
462     :function-name name
463     :format-string
464     "Invalid array index, ~D for ~S. Should have been less than ~D"
465     :format-arguments (list index array bound)))
466 wlott 1.1
467 wlott 1.15
468     ;;; ### Is this used?
469 wlott 1.1 (deferr wrong-number-of-indices-error
470     "Wrong number of indices."
471     (&rest args)
472     (error "wrong-number-of-indices:~{ ~S~}" args))
473    
474     (deferr object-not-simple-array-error
475     "Object is not of type SIMPLE-ARRAY."
476 wlott 1.15 (object)
477     (error 'type-error
478     :function-name name
479     :datum object
480     :expected-type 'simple-array))
481 wlott 1.1
482     (deferr object-not-signed-byte-32-error
483     "Object is not of type (SIGNED-BYTE 32)."
484 wlott 1.15 (object)
485     (error 'type-error
486     :function-name name
487     :datum object
488     :expected-type '(signed-byte 32)))
489 wlott 1.1
490     (deferr object-not-unsigned-byte-32-error
491     "Object is not of type (UNSIGNED-BYTE 32)."
492 wlott 1.15 (object)
493     (error 'type-error
494     :function-name name
495     :datum object
496     :expected-type '(unsigned-byte 32)))
497 wlott 1.1
498     (deferr object-not-simple-array-unsigned-byte-2-error
499     "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 2) (*))."
500 wlott 1.15 (object)
501     (error 'type-error
502     :function-name name
503     :datum object
504     :expected-type '(simple-array (unsigned-byte 2) (*))))
505 wlott 1.1
506     (deferr object-not-simple-array-unsigned-byte-4-error
507     "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 4) (*))."
508 wlott 1.15 (object)
509     (error 'type-error
510     :function-name name
511     :datum object
512     :expected-type '(simple-array (unsigned-byte 4) (*))))
513 wlott 1.1
514     (deferr object-not-simple-array-unsigned-byte-8-error
515     "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*))."
516 wlott 1.15 (object)
517     (error 'type-error
518     :function-name name
519     :datum object
520     :expected-type '(simple-array (unsigned-byte 8) (*))))
521 wlott 1.1
522     (deferr object-not-simple-array-unsigned-byte-16-error
523     "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 16) (*))."
524 wlott 1.15 (object)
525     (error 'type-error
526     :function-name name
527     :datum object
528     :expected-type '(simple-array (unsigned-byte 16) (*))))
529 wlott 1.1
530     (deferr object-not-simple-array-unsigned-byte-32-error
531     "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 32) (*))."
532 wlott 1.15 (object)
533     (error 'type-error
534     :function-name name
535     :datum object
536     :expected-type '(simple-array (unsigned-byte 32) (*))))
537 wlott 1.1
538     (deferr object-not-simple-array-single-float-error
539     "Object is not of type (SIMPLE-ARRAY SINGLE-FLOAT (*))."
540 wlott 1.15 (object)
541     (error 'type-error
542     :function-name name
543     :datum object
544     :expected-type '(simple-array single-float (*))))
545 wlott 1.1
546     (deferr object-not-simple-array-double-float-error
547     "Object is not of type (SIMPLE-ARRAY DOUBLE-FLOAT (*))."
548 wlott 1.15 (object)
549     (error 'type-error
550     :function-name name
551     :datum object
552     :expected-type '(simple-array double-float (*))))
553 wlott 1.1
554     (deferr object-not-complex-error
555     "Object is not of type COMPLEX."
556 wlott 1.15 (object)
557     (error 'type-error
558     :function-name name
559     :datum object
560     :expected-type 'complex))
561 wlott 1.1
562 wlott 1.4 (deferr object-not-weak-pointer-error
563 wlott 1.3 "Object is not a WEAK-POINTER."
564 wlott 1.15 (object)
565     (error 'type-error
566     :function-name name
567     :datum object
568     :expected-type 'weak-pointer))
569 wlott 1.11
570     (deferr object-not-structure-error
571     "Object is not a STRUCTURE."
572     (object)
573 wlott 1.15 (error 'type-error
574 wlott 1.11 :function-name name
575 wlott 1.15 :datum object
576     :expected-type 'structure))
577    
578 wlott 1.1
579    
580 wlott 1.13 ;;;; internal-error signal handler.
581 wlott 1.1
582 wlott 1.6 (defvar *finding-name* nil)
583    
584     (defun find-interrupted-name ()
585     (if *finding-name*
586     "<error finding name>"
587     (handler-case
588     (let ((*finding-name* t))
589     (do ((frame (di:top-frame) (di:frame-down frame)))
590     ((or (null frame)
591 wlott 1.10 (and (di::compiled-frame-p frame)
592     (di::compiled-frame-escaped frame)))
593     (if (di::compiled-frame-p frame)
594 wlott 1.6 (di:debug-function-name
595     (di:frame-debug-function frame))
596     "<error finding name>"))))
597     (error () "<error finding name>")
598     (di:debug-condition () "<error finding name>"))))
599    
600    
601 wlott 1.13 (defun internal-error (scp continuable)
602     (declare (ignore continuable))
603 wlott 1.2 (alien-bind ((sc (make-alien 'mach:sigcontext
604     #.(c-sizeof 'mach:sigcontext)
605     scp)
606 wlott 1.1 mach:sigcontext
607 wlott 1.17 t))
608 wlott 1.13 (multiple-value-bind
609     (error-number arguments)
610 wlott 1.14 (vm:internal-error-arguments (alien-value sc))
611 wlott 1.13 (let ((fp (int-sap (di::escape-register (alien-value sc)
612     vm::cfp-offset)))
613     (name (find-interrupted-name))
614     (info (and (< -1 error-number (length *internal-errors*))
615     (svref *internal-errors* error-number))))
616     (cond ((null info)
617 wlott 1.7 (error 'simple-error
618 wlott 1.13 :function-name name
619     :format-string
620     "Unknown internal error, ~D? args=~S"
621     :format-arguments
622     (list error-number
623     (mapcar #'(lambda (sc-offset)
624     (di::sub-access-debug-var-slot
625     fp
626     sc-offset
627     (alien-value sc)))
628     arguments))))
629     ((null (error-info-function info))
630     (error 'simple-error
631     :function-name name
632     :format-string
633     "Internal error ~D: ~A. args=~S"
634     :format-arguments
635     (list error-number
636     (error-info-description info)
637     (mapcar #'(lambda (sc-offset)
638     (di::sub-access-debug-var-slot
639     fp
640     sc-offset
641     (alien-value sc)))
642     arguments))))
643     (t
644     (funcall (error-info-function info) name fp sc arguments)))))))

  ViewVC Help
Powered by ViewVC 1.1.5