From: Stas Boukarev <stassats@gmail.com>
Date: Sun, 5 Jan 2014 09:54:19 +0000 (+0400)
Subject: Fix make-array transforms.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;ds=sidebyside;p=sbcl.git

Fix make-array transforms.

Don't call UPGRADED-ARRAY-ELEMENT-TYPE on types without checking that
they don't contain unknown types (i.e., intersections or unions
containing unknown-type), since U-A-E-T now signals errors for these.

Reported by Bart Botta.
---

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 72bf994..612236d 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1351,6 +1351,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "%COMPARE-AND-SWAP-SYMBOL-VALUE"
                "%CONCATENATE-TO-BASE-STRING"
                "%CONCATENATE-TO-STRING"
+               "CONTAINS-UNKNOWN-TYPE-P"
                "%COS" "%COS-QUICK"
                "%COSH" "%DATA-VECTOR-AND-INDEX" "%DEPOSIT-FIELD"
                "%DOUBLE-FLOAT" "%DPB" "%EQL"
diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 04a93f2..8190493 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -49,6 +49,13 @@
         (funcall method type2 type1)
         (hierarchical-intersection2 type1 type2))))
 
+(defun contains-unknown-type-p (ctype)
+  (cond ((unknown-type-p ctype) t)
+        ((intersection-type-p ctype)
+         (some #'contains-unknown-type-p (intersection-type-types ctype)))
+        ((union-type-p ctype)
+         (some #'contains-unknown-type-p (union-type-types ctype)))))
+
 ;;; This is used by !DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1
 ;;; method. INFO is a list of conses
 ;;;   (SUPERCLASS-CLASS . {GUARD-TYPE-SPECIFIER | NIL}).
diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index c44afb4..bc2fc02 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -294,7 +294,7 @@
                          (let ((ctype (careful-specifier-type
                                        (lvar-value element-type))))
                            (cond
-                             ((or (null ctype) (unknown-type-p ctype)) '*)
+                             ((or (null ctype) (contains-unknown-type-p ctype)) '*)
                              (t (sb!xc:upgraded-array-element-type
                                  (lvar-value element-type))))))
                         (t
@@ -639,7 +639,7 @@
           (element-type-ctype (and (constant-lvar-p element-type)
                                    (ir1-transform-specifier-type
                                     (lvar-value element-type)))))
-      (when (unknown-type-p element-type-ctype)
+      (when (contains-unknown-type-p element-type-ctype)
         (give-up-ir1-transform))
       (unless (every #'integerp dims)
         (give-up-ir1-transform
diff --git a/src/compiler/generic/vm-type.lisp b/src/compiler/generic/vm-type.lisp
index 9d0a031..5c78b2b 100644
--- a/src/compiler/generic/vm-type.lisp
+++ b/src/compiler/generic/vm-type.lisp
@@ -107,13 +107,6 @@
     (double-float 'double-float)
     #!+long-float (long-float 'long-float)))
 
-(defun contains-unknown-type-p (ctype)
-  (cond ((unknown-type-p ctype) t)
-        ((intersection-type-p ctype)
-         (some #'contains-unknown-type-p (intersection-type-types ctype)))
-        ((union-type-p ctype)
-         (some #'contains-unknown-type-p (union-type-types ctype)))))
-
 ;;; This function is called when the type code wants to find out how
 ;;; an array will actually be implemented. We set the
 ;;; SPECIALIZED-ELEMENT-TYPE to correspond to the actual
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 1fd9166..604e176 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4973,4 +4973,10 @@
 
 (with-test (:name :upgraded-array-element-type-undefined-type)
   (raises-error? (upgraded-array-element-type 'an-undefined-type))
-  (raises-error? (upgraded-array-element-type '(and fixnum an-undefined-type))))
+  (raises-error? (upgraded-array-element-type '(and fixnum an-undefined-type)))
+  (compile nil '(lambda ()
+                 (make-array 10
+                  :element-type '(or null an-undefined-type))))
+  (compile nil '(lambda ()
+                 (make-array '(10 10)
+                  :element-type '(or null an-undefined-type)))))