Improve ARRAY-RANK transform.

* Don't crash on bad types.
* Delay the transform if the type isn't yet known.

Fixes lp#1252108.

diff --git a/NEWS b/NEWS
index 43e881f..0458bbf 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -16,6 +16,7 @@ changes relative to sbcl-1.1.13:
     specification (multiple integer arguments) and signals a continuable error
     if the current SBCL version is lower (older) than the specification.
     (lp#674372)
+  * enhancement: better ARRAY-RANK result derivation. (lp#1252108)
   * bug fix: EQUALP now compares correctly structures with raw slots larger
     than a single word.
   * bug fix: contribs couldn't be built on Windows with MinGW.

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index f3cf136..3403ac3 100644 (file)
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -722,14 +722,16 @@
     (t :maybe)))
 
 ;;; If we can tell the rank from the type info, use it instead.
-(deftransform array-rank ((array))
+(deftransform array-rank ((array) (array) * :node node)
   (let ((array-type (lvar-type array)))
     (let ((dims (array-type-dimensions-or-give-up array-type)))
       (cond ((listp dims)
              (length dims))
-            ((eq t (array-type-complexp array-type))
+            ((eq t (and (array-type-p array-type)
+                        (array-type-complexp array-type)))
              '(%array-rank array))
             (t
+             (delay-ir1-transform node :constraint)
              `(if (array-header-p array)
                   (%array-rank array)
                   1))))))

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 895a104..577c434 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4941,3 +4941,19 @@
   (assert (handler-case
               (compile nil `(lambda (x) (array-row-major-index x)))
             (warning () nil))))
+
+(with-test (:name :array-rank-transform)
+  (compile nil `(lambda (a) (array-rank (the an-imaginary-type a)))))
+
+(with-test (:name (:array-rank-fold :bug-1252108))
+  (let (noted)
+    (handler-bind ((sb-ext::code-deletion-note
+                     (lambda (x)
+                       (setf noted x))))
+      (compile nil
+               `(lambda (a)
+                  (typecase a
+                    ((array t 2)
+                     (when (= (array-rank a) 3)
+                       (array-dimension a 2)))))))
+    (assert noted)))