0.8.9.4:

[sbcl.git] / src / compiler / generic / primtype.lisp

diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp
index 7310a2d..1178b6a 100644 (file)
--- a/src/compiler/generic/primtype.lisp
+++ b/src/compiler/generic/primtype.lisp
@@ -100,45 +100,18 @@
 
 ;;; primitive other-pointer array types
 (/show0 "primtype.lisp 96")
-(!def-primitive-type simple-string (descriptor-reg)
-  :type simple-base-string)
-(!def-primitive-type simple-bit-vector (descriptor-reg))
-(!def-primitive-type simple-vector (descriptor-reg))
-(!def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg)
-  :type (simple-array (unsigned-byte 2) (*)))
-(!def-primitive-type simple-array-unsigned-byte-4 (descriptor-reg)
-  :type (simple-array (unsigned-byte 4) (*)))
-(!def-primitive-type simple-array-unsigned-byte-8 (descriptor-reg)
-  :type (simple-array (unsigned-byte 8) (*)))
-(!def-primitive-type simple-array-unsigned-byte-16 (descriptor-reg)
-  :type (simple-array (unsigned-byte 16) (*)))
-(!def-primitive-type simple-array-unsigned-byte-32 (descriptor-reg)
-  :type (simple-array (unsigned-byte 32) (*)))
-(!def-primitive-type simple-array-signed-byte-8 (descriptor-reg)
-  :type (simple-array (signed-byte 8) (*)))
-(!def-primitive-type simple-array-signed-byte-16 (descriptor-reg)
-  :type (simple-array (signed-byte 16) (*)))
-(!def-primitive-type simple-array-signed-byte-30 (descriptor-reg)
-  :type (simple-array (signed-byte 30) (*)))
-(!def-primitive-type simple-array-signed-byte-32 (descriptor-reg)
-  :type (simple-array (signed-byte 32) (*)))
-(!def-primitive-type simple-array-single-float (descriptor-reg)
-  :type (simple-array single-float (*)))
-(!def-primitive-type simple-array-double-float (descriptor-reg)
-  :type (simple-array double-float (*)))
-#!+long-float
-(!def-primitive-type simple-array-long-float (descriptor-reg)
-  :type (simple-array long-float (*)))
-(!def-primitive-type simple-array-complex-single-float (descriptor-reg)
-  :type (simple-array (complex single-float) (*)))
-(!def-primitive-type simple-array-complex-double-float (descriptor-reg)
-  :type (simple-array (complex double-float) (*)))
-#!+long-float
-(!def-primitive-type simple-array-complex-long-float (descriptor-reg)
-  :type (simple-array (complex long-float) (*)))
-
-;;; Note: The complex array types are not included, 'cause it is pointless to
-;;; restrict VOPs to them.
+(macrolet ((define-simple-array-primitive-types ()
+              `(progn
+                ,@(map 'list
+                       (lambda (saetp)
+                         `(!def-primitive-type
+                           ,(saetp-primitive-type-name saetp)
+                           (descriptor-reg)
+                           :type (simple-array ,(saetp-specifier saetp) (*))))
+                       *specialized-array-element-type-properties*))))
+  (define-simple-array-primitive-types))
+;;; Note: The complex array types are not included, 'cause it is
+;;; pointless to restrict VOPs to them.
 
 ;;; other primitive other-pointer types
 (!def-primitive-type system-area-pointer (sap-reg descriptor-reg))
@@ -149,7 +122,7 @@
 \f
 ;;;; PRIMITIVE-TYPE-OF and friends
 
-;;; Return the most restrictive primitive type that contains Object.
+;;; Return the most restrictive primitive type that contains OBJECT.
 (/show0 "primtype.lisp 147")
 (!def-vm-support-routine primitive-type-of (object)
   (let ((type (ctype-of object)))
@@ -159,30 +132,6 @@
          (t
           *backend-t-primitive-type*))))
 
-(defvar *simple-array-primitive-types*
-  '((base-char . simple-string)
-    (bit . simple-bit-vector)
-    ((unsigned-byte 2) . simple-array-unsigned-byte-2)
-    ((unsigned-byte 4) . simple-array-unsigned-byte-4)
-    ((unsigned-byte 8) . simple-array-unsigned-byte-8)
-    ((unsigned-byte 16) . simple-array-unsigned-byte-16)
-    ((unsigned-byte 32) . simple-array-unsigned-byte-32)
-    ((signed-byte 8) . simple-array-signed-byte-8)
-    ((signed-byte 16) . simple-array-signed-byte-16)
-    (fixnum . simple-array-signed-byte-30)
-    ((signed-byte 32) . simple-array-signed-byte-32)
-    (single-float . simple-array-single-float)
-    (double-float . simple-array-double-float)
-    #!+long-float (long-float . simple-array-long-float)
-    ((complex single-float) . simple-array-complex-single-float)
-    ((complex double-float) . simple-array-complex-double-float)
-    #!+long-float
-    ((complex long-float) . simple-array-complex-long-float)
-    (t . simple-vector))
-  #!+sb-doc
-  "An a-list for mapping simple array element types to their
-  corresponding primitive types.")
-
 ;;; Return the primitive type corresponding to a type descriptor
 ;;; structure. The second value is true when the primitive type is
 ;;; exactly equivalent to the argument Lisp type.
@@ -326,6 +275,9 @@
             (let* ((dims (array-type-dimensions type))
                    (etype (array-type-specialized-element-type type))
                    (type-spec (type-specifier etype))
+                   ;; FIXME: We're _WHAT_?  Testing for type equality
+                   ;; with a specifier and #'EQUAL?  *BOGGLE*.  --
+                   ;; CSR, 2003-06-24
                    (ptype (cdr (assoc type-spec *simple-array-primitive-types*
                                       :test #'equal))))
               (if (and (consp dims) (null (rest dims)) ptype)
@@ -363,11 +315,11 @@
         (ecase (named-type-name type)
           ((t *) (values *backend-t-primitive-type* t))
           ((nil) (any))))
-       (sb!xc:built-in-class
-        (case (sb!xc:class-name type)
+       (built-in-classoid
+        (case (classoid-name type)
           ((complex function instance
             system-area-pointer weak-pointer)
-           (values (primitive-type-or-lose (sb!xc:class-name type)) t))
+           (values (primitive-type-or-lose (classoid-name type)) t))
           (funcallable-instance
            (part-of function))
           (base-char
@@ -378,11 +330,13 @@
            (any))))
        (fun-type
         (exactly function))
-       (sb!xc:class
+       (classoid
         (if (csubtypep type (specifier-type 'function))
             (part-of function)
             (part-of instance)))
        (ctype
-        (any))))))
+         (if (csubtypep type (specifier-type 'function))
+            (part-of function)
+             (any)))))))
 
 (/show0 "primtype.lisp end of file")