From 7ce5108fd5ec5b599d4ae9e8aedc1a0d458af102 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Tue, 2 Jun 2009 17:23:08 +0000 Subject: [PATCH] 1.0.28.73: regression from 1.0.28.21 * One leg of logic lost in the refactoring: if the type to verify is (SIMPLE-ARRAY * (*)) we need to check that there is no array header. --- src/compiler/typetran.lisp | 16 +++++++++++----- tests/compiler.pure.lisp | 6 ++++++ version.lisp-expr | 2 +- 3 files changed, 18 insertions(+), 6 deletions(-) diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 2f10b1e..bada4f6 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -335,8 +335,8 @@ ;;; specified by TYPE, where STYPE is the type we have checked against ;;; (which is the same but for dimensions and element type). ;;; -;;; Secondary return value is true if generated tests passing imply -;;; that the array has a header. +;;; Secondary return value is true if passing the generated tests implies that +;;; the array has a header. (defun test-array-dimensions (obj type stype) (declare (type array-type type stype)) (let ((obj `(truly-the ,(type-specifier stype) ,obj)) @@ -357,9 +357,15 @@ (= (%array-rank ,obj) 0)) t)) ((not (array-type-complexp type)) - (values (unless (eq '* (car dims)) - `((= (vector-length ,obj) ,@dims))) - nil)) + (if (csubtypep stype (specifier-type 'vector)) + (values (unless (eq '* (car dims)) + `((= (vector-length ,obj) ,@dims))) + nil) + (values (if (eq '* (car dims)) + `((not (array-header-p ,obj))) + `((not (array-header-p ,obj)) + (= (vector-length ,obj) ,@dims))) + nil))) (t (values (unless (eq '* (car dims)) `((if (array-header-p ,obj) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index db2bfc4..a7fd779 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -2917,3 +2917,9 @@ :initial-element x))) 10 #c(1.0 2.0))))) + +(with-test (:name :regression-1.0.28.21) + (let ((fun (compile nil `(lambda (x) (typep x '(simple-array * 1)))))) + (assert (funcall fun (vector 1 2 3))) + (assert (funcall fun "abc")) + (assert (not (funcall fun (make-array '(2 2))))))) diff --git a/version.lisp-expr b/version.lisp-expr index fe9eba3..f650062 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.28.72" +"1.0.28.73" -- 1.7.10.4