0.8.0.78.vector-nil-string.12:

	Use *SAETP* to generate the data for internal error definition
	(net win so far: 13)

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index d829f26..e5627f0 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -2010,7 +2010,7 @@ structure representations"
              "REGISTER-SAVE-PENALTY" "RETURN-PC-HEADER-WIDETAG"
              "RETURN-PC-RETURN-POINT-OFFSET" "RETURN-PC-SAVE-OFFSET"
             "SAETP-CTYPE" "SAETP-INITIAL-ELEMENT-DEFAULT"
-            "SAETP-N-BITS" "SAETP-TYPECODE" "SAETP-PRIMTYPE"
+            "SAETP-N-BITS" "SAETP-TYPECODE" "SAETP-PRIMITIVE-TYPE-NAME"
             "SAETP-N-PAD-ELEMENTS" "SAETP-SPECIFIER"
             "SAETP-COMPLEX-TYPECODE" "SAETP-IMPORTANCE"
             "*SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*"

diff --git a/src/code/interr.lisp b/src/code/interr.lisp
index 0f878d9..41247c1 100644 (file)
--- a/src/code/interr.lisp
+++ b/src/code/interr.lisp
@@ -103,21 +103,6 @@
         :datum object
         :expected-type 'simple-string))
 
-(deferr object-not-simple-base-string-error (object)
-  (error 'type-error
-        :datum object
-        :expected-type 'simple-base-string))
-
-(deferr object-not-simple-bit-vector-error (object)
-  (error 'type-error
-        :datum object
-        :expected-type 'simple-bit-vector))
-
-(deferr object-not-simple-vector-error (object)
-  (error 'type-error
-        :datum object
-        :expected-type 'simple-vector))
-
 (deferr object-not-fixnum-error (object)
   (error 'type-error
         :datum object
@@ -286,81 +271,23 @@
         :datum object
         :expected-type '(unsigned-byte 32)))
 
-(deferr object-not-simple-array-nil-error (object)
-  (error 'type-error
-        :datum object
-        :expected-type '(simple-array nil (*))))
-
-(deferr object-not-simple-array-unsigned-byte-2-error (object)
-  (error 'type-error
-        :datum object
-        :expected-type '(simple-array (unsigned-byte 2) (*))))
-
-(deferr object-not-simple-array-unsigned-byte-4-error (object)
-  (error 'type-error
-        :datum object
-        :expected-type '(simple-array (unsigned-byte 4) (*))))
-
-(deferr object-not-simple-array-unsigned-byte-8-error (object)
-  (error 'type-error
-        :datum object
-        :expected-type '(simple-array (unsigned-byte 8) (*))))
-
-(deferr object-not-simple-array-unsigned-byte-16-error (object)
-  (error 'type-error
-        :datum object
-        :expected-type '(simple-array (unsigned-byte 16) (*))))
-
-(deferr object-not-simple-array-unsigned-byte-32-error (object)
-  (error 'type-error
-        :datum object
-        :expected-type '(simple-array (unsigned-byte 32) (*))))
-
-(deferr object-not-simple-array-signed-byte-8-error (object)
-  (error 'type-error
-        :datum object
-        :expected-type '(simple-array (signed-byte 8) (*))))
-
-(deferr object-not-simple-array-signed-byte-16-error (object)
-  (error 'type-error
-        :datum object
-        :expected-type '(simple-array (signed-byte 16) (*))))
-
-(deferr object-not-simple-array-signed-byte-30-error (object)
-  (error 'type-error
-        :datum object
-        :expected-type '(simple-array (signed-byte 30) (*))))
-
-(deferr object-not-simple-array-signed-byte-32-error (object)
-  (error 'type-error
-        :datum object
-        :expected-type '(simple-array (signed-byte 32) (*))))
-
-(deferr object-not-simple-array-single-float-error (object)
-  (error 'type-error
-        :datum object
-        :expected-type '(simple-array single-float (*))))
-
-(deferr object-not-simple-array-double-float-error (object)
-  (error 'type-error
-        :datum object
-        :expected-type '(simple-array double-float (*))))
-
-(deferr object-not-simple-array-complex-single-float-error (object)
-  (error 'type-error
-        :datum object
-        :expected-type '(simple-array (complex single-float) (*))))
-
-(deferr object-not-simple-array-complex-double-float-error (object)
-  (error 'type-error
-        :datum object
-        :expected-type '(simple-array (complex double-float) (*))))
-
-#!+long-float
-(deferr object-not-simple-array-complex-long-float-error (object)
-  (error 'type-error
-        :datum object
-        :expected-type '(simple-array (complex long-float) (*))))
+(macrolet
+    ((define-simple-array-internal-errors ()
+        `(progn
+          ,@(map 'list
+                 (lambda (saetp)
+                   `(deferr ,(symbolicate
+                              "OBJECT-NOT-"
+                              (sb!vm:saetp-primitive-type-name saetp)
+                              "-ERROR")
+                             (object)
+                     (error 'type-error
+                            :datum object
+                            :expected-type `(simple-array
+                                             ,(sb!vm:saetp-specifier saetp)
+                                             (*)))))
+                 sb!vm:*specialized-array-element-type-properties*))))
+  (define-simple-array-internal-errors))
 
 (deferr object-not-complex-error (object)
   (error 'type-error

diff --git a/src/compiler/generic/interr.lisp b/src/compiler/generic/interr.lisp
index 1a96e19..43feea6 100644 (file)
--- a/src/compiler/generic/interr.lisp
+++ b/src/compiler/generic/interr.lisp
@@ -25,14 +25,8 @@
 (eval-when (:compile-toplevel :execute)
   (def!macro define-internal-errors (&rest errors)
             (let ((info (mapcar (lambda (x)
-                                   ;; FIXME: We shouldn't need placeholder
-                                   ;; NIL entries any more now that we
-                                   ;; pass our magic numbers cleanly
-                                   ;; through sbcl.h.
-                                  (if x
-                                      (cons (symbolicate (first x) "-ERROR")
-                                            (second x))
-                                      '(nil . "unused")))
+                                  (cons (symbolicate (first x) "-ERROR")
+                                        (second x)))
                                 errors)))
               `(progn
                  (setf sb!c:*backend-internal-errors*
@@ -59,12 +53,6 @@
    "Object is not of type LONG-FLOAT.")
   (object-not-simple-string
    "Object is not of type SIMPLE-STRING.")
-  (object-not-simple-base-string
-   "Object is not of type SIMPLE-BASE-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-vector
@@ -125,40 +113,6 @@
    "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-nil
-   "Object is not of type (SIMPLE-ARRAY NIL (*)).")
-  (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-signed-byte-8
-   "Object is not of type (SIMPLE-ARRAY (SIGNED-BYTE 8) (*)).")
-  (object-not-simple-array-signed-byte-16
-   "Object is not of type (SIMPLE-ARRAY (SIGNED-BYTE 16) (*)).")
-  (object-not-simple-array-signed-byte-30
-   "Object is not of type (SIMPLE-ARRAY FIXNUM (*)).")
-  (object-not-simple-array-signed-byte-32
-   "Object is not of type (SIMPLE-ARRAY (SIGNED-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 (*)).")
-  #!+long-float
-  (object-not-simple-array-long-float
-   "Object is not of type (SIMPLE-ARRAY LONG-FLOAT (*)).")
-  (object-not-simple-array-complex-single-float
-   "Object is not of type (SIMPLE-ARRAY (COMPLEX SINGLE-FLOAT) (*)).")
-  (object-not-simple-array-complex-double-float
-   "Object is not of type (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)).")
-  #!+long-float
-  (object-not-simple-array-complex-long-float
-   "Object is not of type (SIMPLE-ARRAY (COMPLEX LONG-FLOAT) (*)).")
   (object-not-complex
    "Object is not of type COMPLEX.")
   (object-not-complex-rational
@@ -185,4 +139,14 @@
   (layout-invalid
    "Object layout is invalid. (indicates obsolete instance)")
   (object-not-complex-vector
-   "Object is not a complex (non-SIMPLE-ARRAY) vector."))
+   "Object is not a complex (non-SIMPLE-ARRAY) vector.")
+  .
+  #.(map 'list
+        (lambda (saetp)
+          (list
+           (symbolicate "OBJECT-NOT-" (sb!vm:saetp-primitive-type-name saetp))
+           (format nil "Object is not of type ~A."
+                   (specifier-type
+                    `(simple-array ,(sb!vm:saetp-specifier saetp) (*))))))
+        sb!vm:*specialized-array-element-type-properties*))
+

diff --git a/version.lisp-expr b/version.lisp-expr
index 98b5e9a..cf19729 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.0.78.vector-nil-string.11"
+"0.8.0.78.vector-nil-string.12"