diff --git a/compiler/generic/interr.lisp b/compiler/generic/interr.lisp new file mode 100644 index 0000000000000000000000000000000000000000..5ed26f9ce070ffd138631cfe09468770aa1b5df6 --- /dev/null +++ b/compiler/generic/interr.lisp @@ -0,0 +1,155 @@ +;;; -*- 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/compiler/generic/interr.lisp,v 1.1 1992/03/21 19:42:50 wlott Exp $") +;;; +;;; ********************************************************************** +;;; +;;; This file defines all of the internal errors. How they are handled is +;;; defined in .../code/interr.lisp. How they are signaled depends on the +;;; machine. +;;; +;;; Written by William Lott. +;;; +(in-package "KERNEL") + +(export '(error-number-or-lose)) + + +(defun error-number-or-lose (name) + (or (position name (c:backend-internal-errors c:*backend*) :key #'car) + (error "Unknown internal error: ~S" name))) + + +(eval-when (compile eval) + +(defmacro define-internal-errors (&rest errors) + (let ((info (mapcar #'(lambda (x) + (if x + (cons (symbolicate (first x) "-ERROR") + (second x)) + '(nil . "unused"))) + errors))) + `(progn + (export ',(remove nil (macar #'car info))) + (setf (c:backend-internal-errors c:*target-backend*) + ',(coerce info 'vector)) + nil))) + +); eval-when + + +(define-internal-errors + (unknown + "Unknown. System lossage.") + (object-not-function + "Object is not of type FUNCTION.") + (object-not-list + "Object is not of type LIST.") + (object-not-bignum + "Object is not of type BIGNUM.") + (object-not-ratio + "Object is not of type RATIO.") + (object-not-single-float + "Object is not of type SINGLE-FLOAT.") + (object-not-double-float + "Object is not of type DOUBLE-FLOAT.") + (object-not-simple-string + "Object is not of type SIMPLE-STRING.") + (object-not-simple-bit-vector + "Object is not of type SIMPLE-BIT-VECTOR.") + (object-not-simple-vector + "Object is not of type SIMPLE-VECTOR.") + (object-not-fixnum + "Object is not of type FIXNUM.") + (object-not-function-or-symbol + "Object is not of type FUNCTION or SYMBOL.") + (object-not-vector + "Object is not of type VECTOR.") + (object-not-string + "Object is not of type STRING.") + (object-not-bit-vector + "Object is not of type BIT-VECTOR.") + (object-not-array + "Object is not of type ARRAY.") + (object-not-number + "Object is not of type NUMBER.") + (object-not-rational + "Object is not of type RATIONAL.") + (object-not-float + "Object is not of type FLOAT.") + (object-not-real + "Object is not of type REAL.") + (object-not-integer + "Object is not of type INTEGER.") + (object-not-cons + "Object is not of type CONS.") + (object-not-symbol + "Object is not of type SYMBOL.") + (undefined-symbol + "Undefined symbol.") + (object-not-coercable-to-function + "Object is not coercable to type FUNCTION.") + (invalid-argument-count + "Invalid argument count.") + (bogus-argument-to-values-list + "Bogus argument to VALUES-LIST.") + (unbound-symbol + "Unbound symbol.") + nil + (object-not-sap + "Object is not a System Area Pointer (SAP).") + (invalid-unwind + "Attempt to RETURN-FROM a block that no longer exists.") + (unseen-throw-tag + "Attempt to THROW to a non-existent tag.") + (division-by-zero + "Attempt to divide by zero.") + (object-not-type + "Object is of the wrong type.") + (odd-keyword-arguments + "Odd number of keyword arguments.") + (unknown-keyword-argument + "Unknown keyword.") + nil + nil + (invalid-array-index + "Invalid array index.") + (wrong-number-of-indices + "Wrong number of indices.") + (object-not-simple-array + "Object is not of type SIMPLE-ARRAY.") + (object-not-signed-byte-32 + "Object is not of type (SIGNED-BYTE 32).") + (object-not-unsigned-byte-32 + "Object is not of type (UNSIGNED-BYTE 32).") + (object-not-simple-array-unsigned-byte-2 + "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 2) (*)).") + (object-not-simple-array-unsigned-byte-4 + "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 4) (*)).") + (object-not-simple-array-unsigned-byte-8 + "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)).") + (object-not-simple-array-unsigned-byte-16 + "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 16) (*)).") + (object-not-simple-array-unsigned-byte-32 + "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 32) (*)).") + (object-not-simple-array-single-float + "Object is not of type (SIMPLE-ARRAY SINGLE-FLOAT (*)).") + (object-not-simple-array-double-float + "Object is not of type (SIMPLE-ARRAY DOUBLE-FLOAT (*)).") + (object-not-complex + "Object is not of type COMPLEX.") + (object-not-weak-pointer + "Object is not a WEAK-POINTER.") + (object-not-structure + "Object is not a STRUCTURE.") + (object-not-base-char + "Object is not of type BASE-CHAR.") + (nil-function-returned + "Function with declared result type NIL returned."))