Fix make-array transforms.

[sbcl.git] / src / compiler / generic / late-type-vops.lisp

diff --git a/src/compiler/generic/late-type-vops.lisp b/src/compiler/generic/late-type-vops.lisp
index 42bf108..4a9016b 100644 (file)
--- a/src/compiler/generic/late-type-vops.lisp
+++ b/src/compiler/generic/late-type-vops.lisp
@@ -11,12 +11,11 @@
 (in-package "SB!VM")
 \f
 (!define-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
-  (even-fixnum-lowtag odd-fixnum-lowtag)
+  #.fixnum-lowtags
   ;; we can save a register on the x86.
   :variant simple
   ;; we can save a couple of instructions and a branch on the ppc.
-  ;; FIXME: make this be FIXNUM-MASK
-  :mask 3)
+  :mask fixnum-tag-mask)
 
 (!define-type-vops functionp check-fun function object-not-fun-error
   (fun-pointer-lowtag)
@@ -30,6 +29,10 @@
   (instance-pointer-lowtag)
   :mask lowtag-mask)
 
+(!define-type-vops %other-pointer-p nil nil nil
+  (other-pointer-lowtag)
+  :mask lowtag-mask)
+
 (!define-type-vops bignump check-bignum bignum object-not-bignum-error
   (bignum-widetag))
 
@@ -38,7 +41,7 @@
 
 (!define-type-vops complexp check-complex complex object-not-complex-error
   (complex-widetag complex-single-float-widetag complex-double-float-widetag
-                  #!+long-float complex-long-float-widetag))
+                   #!+long-float complex-long-float-widetag))
 
 (!define-type-vops complex-rational-p check-complex-rational nil
     object-not-complex-rational-error
@@ -47,7 +50,7 @@
 (!define-type-vops complex-float-p check-complex-float nil
     object-not-complex-float-error
   (complex-single-float-widetag complex-double-float-widetag
-                               #!+long-float complex-long-float-widetag))
+                                #!+long-float complex-long-float-widetag))
 
 (!define-type-vops complex-single-float-p check-complex-single-float complex-single-float
     object-not-complex-single-float-error
@@ -57,11 +60,6 @@
     object-not-complex-double-float-error
   (complex-double-float-widetag))
 
-#!+long-float
-(!define-type-vops complex-long-float-p check-complex-long-float complex-long-float
-    object-not-complex-long-float-error
-  (complex-long-float-widetag))
-
 (!define-type-vops single-float-p check-single-float single-float
     object-not-single-float-error
   (single-float-widetag))
@@ -70,33 +68,29 @@
     object-not-double-float-error
   (double-float-widetag))
 
-#!+long-float
-(!define-type-vops long-float-p check-long-float long-float
-    object-not-long-float-error
-  (long-float-widetag))
-
 (!define-type-vops simple-string-p check-simple-string nil
     object-not-simple-string-error
-  (simple-base-string-widetag simple-array-nil-widetag))
+  (#!+sb-unicode simple-character-string-widetag
+   simple-base-string-widetag simple-array-nil-widetag))
 
 (macrolet
     ((define-simple-array-type-vops ()
-        `(progn
-          ,@(map 'list
-                 (lambda (saetp)
-                   (let ((primtype (saetp-primitive-type-name saetp)))
-                   `(!define-type-vops
-                     ,(symbolicate primtype "-P")
-                     ,(symbolicate "CHECK-" primtype)
-                     ,primtype
-                     ,(symbolicate "OBJECT-NOT-" primtype "-ERROR")
-                     (,(saetp-typecode saetp)))))
-                 *specialized-array-element-type-properties*))))
+         `(progn
+           ,@(map 'list
+                  (lambda (saetp)
+                    (let ((primtype (saetp-primitive-type-name saetp)))
+                    `(!define-type-vops
+                      ,(symbolicate primtype "-P")
+                      ,(symbolicate "CHECK-" primtype)
+                      ,primtype
+                      ,(symbolicate "OBJECT-NOT-" primtype "-ERROR")
+                      (,(saetp-typecode saetp)))))
+                  *specialized-array-element-type-properties*))))
   (define-simple-array-type-vops))
 
-(!define-type-vops base-char-p check-base-char base-char
-    object-not-base-char-error
-  (base-char-widetag))
+(!define-type-vops characterp check-character character
+    object-not-character-error
+  (character-widetag))
 
 (!define-type-vops system-area-pointer-p check-system-area-pointer
       system-area-pointer
@@ -120,11 +114,15 @@
   (funcallable-instance-header-widetag))
 
 (!define-type-vops array-header-p nil nil nil
-  (simple-array-widetag complex-base-string-widetag complex-bit-vector-widetag
+  (simple-array-widetag
+   #!+sb-unicode complex-character-string-widetag
+   complex-base-string-widetag complex-bit-vector-widetag
    complex-vector-widetag complex-array-widetag complex-vector-nil-widetag))
 
 (!define-type-vops stringp check-string nil object-not-string-error
-  (simple-base-string-widetag complex-base-string-widetag
+  (#!+sb-unicode simple-character-string-widetag
+   #!+sb-unicode complex-character-string-widetag
+   simple-base-string-widetag complex-base-string-widetag
    simple-array-nil-widetag complex-vector-nil-widetag))
 
 (!define-type-vops base-string-p check-base-string nil object-not-base-string-error
@@ -138,16 +136,21 @@
     object-not-vector-nil-error
   (simple-array-nil-widetag complex-vector-nil-widetag))
 
+#!+sb-unicode
+(!define-type-vops character-string-p check-character-string nil
+    object-not-character-string-error
+  (simple-character-string-widetag complex-character-string-widetag))
+
 (!define-type-vops vectorp check-vector nil object-not-vector-error
   (complex-vector-widetag .
    #.(append
       (map 'list
-          #'saetp-typecode
-          *specialized-array-element-type-properties*)
+           #'saetp-typecode
+           *specialized-array-element-type-properties*)
       (mapcan (lambda (saetp)
-               (when (saetp-complex-typecode saetp)
-                 (list (saetp-complex-typecode saetp))))
-             (coerce *specialized-array-element-type-properties* 'list)))))
+                (when (saetp-complex-typecode saetp)
+                  (list (saetp-complex-typecode saetp))))
+              (coerce *specialized-array-element-type-properties* 'list)))))
 
 ;;; Note that this "type VOP" is sort of an oddball; it doesn't so
 ;;; much test for a Lisp-level type as just expose a low-level type
@@ -167,8 +170,8 @@
     object-not-simple-array-error
   (simple-array-widetag .
    #.(map 'list
-         #'saetp-typecode
-         *specialized-array-element-type-properties*)))
+          #'saetp-typecode
+          *specialized-array-element-type-properties*)))
 
 (!define-type-vops arrayp check-array nil object-not-array-error
   (simple-array-widetag
@@ -176,17 +179,15 @@
    complex-vector-widetag .
    #.(append
       (map 'list
-          #'saetp-typecode
-          *specialized-array-element-type-properties*)
+           #'saetp-typecode
+           *specialized-array-element-type-properties*)
       (mapcan (lambda (saetp)
-               (when (saetp-complex-typecode saetp)
-                 (list (saetp-complex-typecode saetp))))
-             (coerce *specialized-array-element-type-properties* 'list)))))
+                (when (saetp-complex-typecode saetp)
+                  (list (saetp-complex-typecode saetp))))
+              (coerce *specialized-array-element-type-properties* 'list)))))
 
 (!define-type-vops numberp check-number nil object-not-number-error
-  (even-fixnum-lowtag
-   odd-fixnum-lowtag
-   bignum-widetag
+  (bignum-widetag
    ratio-widetag
    single-float-widetag
    double-float-widetag
@@ -194,22 +195,22 @@
    complex-widetag
    complex-single-float-widetag
    complex-double-float-widetag
-   #!+long-float complex-long-float-widetag))
+   #!+long-float complex-long-float-widetag
+   . #.fixnum-lowtags))
 
 (!define-type-vops rationalp check-rational nil object-not-rational-error
-  (even-fixnum-lowtag odd-fixnum-lowtag ratio-widetag bignum-widetag))
+  (ratio-widetag bignum-widetag . #.fixnum-lowtags))
 
 (!define-type-vops integerp check-integer nil object-not-integer-error
-  (even-fixnum-lowtag odd-fixnum-lowtag bignum-widetag))
+  (bignum-widetag . #.fixnum-lowtags))
 
 (!define-type-vops floatp check-float nil object-not-float-error
   (single-float-widetag double-float-widetag #!+long-float long-float-widetag))
 
 (!define-type-vops realp check-real nil object-not-real-error
-  (even-fixnum-lowtag
-   odd-fixnum-lowtag
-   ratio-widetag
+  (ratio-widetag
    bignum-widetag
    single-float-widetag
    double-float-widetag
-   #!+long-float long-float-widetag))
+   #!+long-float long-float-widetag
+   . #.fixnum-lowtags))