Newer
Older
;;; -*- Log: code.log; Package: KERNEL -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/interr.lisp,v 1.27 1993/05/29 07:02:15 wlott Exp $")
;;; **********************************************************************
;;;
;;; Functions and macros to define and deal with internal errors (i.e.
;;; problems that can be signaled from assembler code).
;;;
;;; Written by William Lott.
;;;
(in-package "KERNEL")
(export '(infinite-error-protect find-caller-name *maximum-error-depth*))
(defvar *internal-errors*
(macrolet ((frob ()
(map 'vector #'cdr (c:backend-internal-errors c:*backend*))))
(frob)))
(defmacro deferr (name args &rest body)
(let* ((rest-pos (position '&rest args))
(required (if rest-pos (subseq args 0 rest-pos) args))
(fp (gensym))
(sigcontext (gensym))
(sc-offsets (gensym))
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
(temp (gensym))
(fn-name (symbolicate name "-HANDLER")))
`(progn
(defun ,fn-name (name ,fp ,sigcontext ,sc-offsets)
(declare (ignorable name ,fp ,sigcontext ,sc-offsets))
(macrolet ((set-value (var value)
(let ((pos (position var ',required)))
(unless pos
(error "~S isn't one of the required args."
var))
`(let ((,',temp ,value))
(di::sub-set-debug-var-slot
,',fp (nth ,pos ,',sc-offsets)
,',temp ,',sigcontext)
(setf ,var ,',temp)))))
(let (,@(let ((offset -1))
(mapcar #'(lambda (var)
`(,var (di::sub-access-debug-var-slot
,fp
(nth ,(incf offset)
,sc-offsets)
,sigcontext)))
required))
,@(when rest-pos
`((,(nth (1+ rest-pos) args)
(mapcar #'(lambda (sc-offset)
(di::sub-access-debug-var-slot
,fp
sc-offset
,sigcontext))
(nthcdr ,rest-pos ,sc-offsets))))))
,@body)))
(setf (svref *internal-errors* ,(error-number-or-lose name))
#',fn-name))))
) ; Eval-When (Compile Eval)
(deferr unknown-error (&rest args)
(deferr object-not-function-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'function))
(deferr object-not-list-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'list))
(deferr object-not-bignum-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'bignum))
(deferr object-not-ratio-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'ratio))
(deferr object-not-single-float-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'single-float))
(deferr object-not-double-float-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'double-float))
(deferr object-not-simple-string-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'simple-string))
(deferr object-not-simple-bit-vector-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'simple-bit-vector))
(deferr object-not-simple-vector-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'simple-vector))
(deferr object-not-fixnum-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'fixnum))
(deferr object-not-function-or-symbol-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(or function symbol)))
(deferr object-not-vector-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'vector))
(deferr object-not-string-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'string))
(deferr object-not-bit-vector-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'bit-vector))
(deferr object-not-array-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'array))
(deferr object-not-number-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'number))
(deferr object-not-rational-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'rational))
(deferr object-not-float-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'float))
(deferr object-not-real-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'real))
(deferr object-not-integer-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'integer))
(deferr object-not-cons-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'cons))
(deferr object-not-symbol-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'symbol))
(deferr undefined-symbol-error (fdefn-or-symbol)
(error 'undefined-function
:function-name name
:name (etypecase fdefn-or-symbol
(symbol fdefn-or-symbol)
(fdefn (fdefn-name fdefn-or-symbol)))))
(deferr object-not-coercable-to-function-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'coercable-to-function))
(deferr invalid-argument-count-error (nargs)
(error 'simple-error
:function-name name
:format-string "Invalid number of arguments: ~S"
:format-arguments (list nargs)))
(deferr bogus-argument-to-values-list-error (list)
(error 'simple-error
:function-name name
:format-string "Attempt to use VALUES-LIST on a dotted-list:~% ~S"
:format-arguments (list list)))
(deferr unbound-symbol-error (symbol)
(error 'unbound-variable :function-name name :name symbol))
(deferr object-not-base-char-error (object)
(error 'type-error
:function-name name
:datum object
(deferr object-not-sap-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'system-area-pointer))
(deferr invalid-unwind-error ()
(error 'control-error
:function-name name
:format-string
"Attempt to RETURN-FROM a block or GO to a tag that no longer exists"))
(deferr unseen-throw-tag-error (tag)
(error 'control-error
:function-name name
:format-string "Attempt to THROW to a tag that does not exist: ~S"
:format-arguments (list tag)))
(deferr nil-function-returned-error (function)
(error 'control-error
:function-name name
:format-string
"Function with declared result type NIL returned:~% ~S"
:format-arguments (list function)))
(deferr division-by-zero-error (this that)
(error 'division-by-zero
:function-name name
:operation 'division
:operands (list this that)))
(deferr object-not-type-error (object type)
(error (if (and (%instancep object)
(layout-invalid (%instance-layout object)))
'layout-invalid
'type-error)
:function-name name
:datum object
:expected-type type))
(deferr layout-invalid-error (object layout)
(error 'layout-invalid
:function-name name
:datum object
:expected-type (layout-class layout)))
(deferr odd-keyword-arguments-error ()
(error 'simple-error
:function-name name
:format-string "Odd number of keyword arguments."))
(deferr unknown-keyword-argument-error (key)
(error 'simple-error
:function-name name
:format-string "Unknown keyword: ~S"
:format-arguments (list key)))
(deferr invalid-array-index-error (array bound index)
(error 'simple-error
:function-name name
:format-string
"Invalid array index, ~D for ~S. Should have been less than ~D"
:format-arguments (list index array bound)))
(deferr object-not-simple-array-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'simple-array))
(deferr object-not-signed-byte-32-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(signed-byte 32)))
(deferr object-not-unsigned-byte-32-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(unsigned-byte 32)))
(deferr object-not-simple-array-unsigned-byte-2-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array (unsigned-byte 2) (*))))
(deferr object-not-simple-array-unsigned-byte-4-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array (unsigned-byte 4) (*))))
(deferr object-not-simple-array-unsigned-byte-8-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array (unsigned-byte 8) (*))))
(deferr object-not-simple-array-unsigned-byte-16-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array (unsigned-byte 16) (*))))
(deferr object-not-simple-array-unsigned-byte-32-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array (unsigned-byte 32) (*))))
(deferr object-not-simple-array-single-float-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array single-float (*))))
(deferr object-not-simple-array-double-float-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type '(simple-array double-float (*))))
(deferr object-not-complex-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'complex))
(deferr object-not-weak-pointer-error (object)
(error 'type-error
:function-name name
:datum object
:expected-type 'weak-pointer))
(deferr object-not-instance-error (object)
(error 'type-error
:datum object
;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out of
;;; hyperspace.
;;;
(defmacro infinite-error-protect (&rest forms)
`(if (and (boundp '*error-system-initialized*)
(numberp *current-error-depth*))
(let ((*current-error-depth* (1+ *current-error-depth*)))
(if (> *current-error-depth* *maximum-error-depth*)
(error-error "Help! " *current-error-depth* " nested errors. "
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
"KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
(progn ,@forms)))
(%primitive halt)))
;;; Track the depth of recursive errors.
;;;
(defvar *maximum-error-depth* 10
"The maximum number of nested errors allowed. Internal errors are
double-counted.")
(defvar *current-error-depth* 0 "The current number of nested errors.")
;;; These specials are used by ERROR-ERROR to track the success of recovery
;;; attempts.
;;;
(defvar *error-error-depth* 0)
(defvar *error-throw-up-count* 0)
;;; This protects against errors that happen before we run this top-level form.
;;;
(defvar *error-system-initialized* t)
;;; ERROR-ERROR can be called when the error system is in trouble and needs
;;; to punt fast. Prints a message without using format. If we get into
;;; this recursively, then halt.
;;;
(defun error-error (&rest messages)
(let ((*error-error-depth* (1+ *error-error-depth*)))
(when (> *error-throw-up-count* 50)
(%primitive halt)
(throw 'lisp::top-level-catcher nil))
(case *error-error-depth*
(1)
(2
(lisp::stream-init))
(3
(incf *error-throw-up-count*)
(throw 'lisp::top-level-catcher nil))
(t
(%primitive halt)
(throw 'lisp::top-level-catcher nil)))
(with-standard-io-syntax
(let ((*print-readably* nil))
(dolist (item messages) (princ item *terminal-io*))
(debug:internal-debug)))))
;;;; Fetching errorful function name.
;;; Used to prevent infinite recursive lossage when we can't find the caller
;;; for some reason.
;;;
(defvar *finding-name* nil)
;;; FIND-CALLER-NAME -- Internal
;;;
(defun find-caller-name ()
(if *finding-name*
(values "<error finding name>" nil)
(handler-case
(let* ((*finding-name* t)
(frame (di:frame-down (di:frame-down (di:top-frame))))
(name (di:debug-function-name
(di:frame-debug-function frame))))
(di:flush-frames-above frame)
(values name frame))
(error ()
(values "<error finding name>" nil))
(di:debug-condition ()
(values "<error finding name>" nil)))))
(defun find-interrupted-name ()
(if *finding-name*
(values "<error finding name>" nil)
(handler-case
(let ((*finding-name* t))
(do ((frame (di:top-frame) (di:frame-down frame)))
((null frame)
(values "<error finding name>" nil))
(when (and (di::compiled-frame-p frame)
(di::compiled-frame-escaped frame))
(di:flush-frames-above frame)
(return (values (di:debug-function-name
(di:frame-debug-function frame))
frame)))))
(error ()
(values "<error finding name>" nil))
(di:debug-condition ()
(values "<error finding name>" nil)))))
;;;; internal-error signal handler.
(defun internal-error (scp continuable)
(declare (type system-area-pointer scp) (ignore continuable))
(infinite-error-protect
(let ((scp (locally
(declare (optimize (inhibit-warnings 3)))
(alien:sap-alien scp (* unix:sigcontext)))))
(multiple-value-bind
(error-number arguments)
(vm:internal-error-arguments scp)
(multiple-value-bind
(name debug:*stack-top-hint*)
(find-interrupted-name)
(let ((fp (int-sap (vm:sigcontext-register scp vm::cfp-offset)))
(handler (and (< -1 error-number (length *internal-errors*))
(svref *internal-errors* error-number))))
(cond ((null handler)
(error 'simple-error
:function-name name
:format-string
"Unknown internal error, ~D? args=~S"
:format-arguments
(list error-number
(mapcar #'(lambda (sc-offset)
(di::sub-access-debug-var-slot
fp sc-offset scp))
arguments))))
((not (functionp handler))
(error 'simple-error
:function-name name
:format-string
"Internal error ~D: ~A. args=~S"
:format-arguments
(list error-number
handler
(mapcar #'(lambda (sc-offset)
(di::sub-access-debug-var-slot
fp sc-offset scp))
arguments))))
(t
(funcall handler name fp scp arguments)))))))))