From 792668aff416a047bb3df218d448d8660303d1db Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Mon, 18 Nov 2013 15:16:04 +0400 Subject: [PATCH] Improve ARRAY-RANK transform. * Don't crash on bad types. * Delay the transform if the type isn't yet known. Fixes lp#1252108. --- NEWS | 1 + src/compiler/array-tran.lisp | 6 ++++-- tests/compiler.pure.lisp | 16 ++++++++++++++++ 3 files changed, 21 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index 43e881f..0458bbf 100644 --- 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 --- 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 --- 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))) -- 1.7.10.4