0.8.1.34:

[sbcl.git] / src / compiler / array-tran.lisp

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index d425b36..b6b7c51 100644 (file)
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -41,6 +41,12 @@
        ;; 2002-08-21
        *wild-type*)))
 
+(defun extract-declared-element-type (array)
+  (let ((type (continuation-type array)))
+    (if (array-type-p type)
+       (array-type-element-type type)
+       *wild-type*)))
+
 ;;; The ``new-value'' for array setters must fit in the array, and the
 ;;; return type is going to be the same as the new-value for SETF
 ;;; functions.
@@ -136,7 +142,12 @@
          `(,(if simple 'simple-array 'array)
             ,(cond ((not element-type) t)
                    ((constant-continuation-p element-type)
-                    (continuation-value element-type))
+                   (let ((ctype (careful-specifier-type
+                                 (continuation-value element-type))))
+                     (cond
+                       ((or (null ctype) (unknown-type-p ctype)) '*)
+                       (t (sb!xc:upgraded-array-element-type
+                           (continuation-value element-type))))))
                    (t
                     '*))
             ,(cond ((constant-continuation-p dims)
@@ -268,8 +279,14 @@
         (len (if (constant-continuation-p length)
                  (continuation-value length)
                  '*))
-        (result-type-spec `(simple-array ,eltype (,len)))
         (eltype-type (ir1-transform-specifier-type eltype))
+        (result-type-spec
+         `(simple-array
+           ,(if (unknown-type-p eltype-type)
+                (give-up-ir1-transform
+                 "ELEMENT-TYPE is an unknown type: ~S" eltype)
+                (sb!xc:upgraded-array-element-type eltype))
+           (,len)))
         (saetp (find-if (lambda (saetp)
                           (csubtypep eltype-type (sb!vm:saetp-ctype saetp)))
                         sb!vm:*specialized-array-element-type-properties*)))
@@ -345,8 +362,11 @@
               (rank (length dims))
               (spec `(simple-array
                       ,(cond ((null element-type) t)
-                             ((constant-continuation-p element-type)
-                              (continuation-value element-type))
+                             ((and (constant-continuation-p element-type)
+                                   (ir1-transform-specifier-type
+                                    (continuation-value element-type)))
+                              (sb!xc:upgraded-array-element-type
+                               (continuation-value element-type)))
                              (t '*))
                           ,(make-list rank :initial-element '*))))
          `(let ((header (make-array-header sb!vm:simple-array-widetag ,rank)))
@@ -495,7 +515,7 @@
          (give-up-ir1-transform))
         (t
          (let ((dim (continuation-value dimension)))
-           `(the (integer 0 ,dim) index)))))
+           `(the (integer 0 (,dim)) index)))))
 \f
 ;;;; WITH-ARRAY-DATA
 
@@ -743,16 +763,17 @@
 ;;; value?
 \f
 ;;; Pick off some constant cases.
-(deftransform array-header-p ((array) (array))
+(defoptimizer (array-header-p derive-type) ((array))
   (let ((type (continuation-type array)))
-    (unless (array-type-p type)
-      (give-up-ir1-transform))
-    (let ((dims (array-type-dimensions type)))
-      (cond ((csubtypep type (specifier-type '(simple-array * (*))))
-            ;; no array header
-            nil)
-           ((and (listp dims) (/= (length dims) 1))
-            ;; multi-dimensional array, will have a header
-            t)
-           (t
-            (give-up-ir1-transform))))))
+    (cond ((not (array-type-p type))
+           nil)
+          (t
+           (let ((dims (array-type-dimensions type)))
+             (cond ((csubtypep type (specifier-type '(simple-array * (*))))
+                    ;; no array header
+                    (specifier-type 'null))
+                   ((and (listp dims) (/= (length dims) 1))
+                    ;; multi-dimensional array, will have a header
+                    (specifier-type '(eql t)))
+                   (t
+                    nil)))))))