From: Christophe Rhodes Date: Thu, 19 Nov 2009 11:50:42 +0000 (+0000) Subject: 1.0.32.31: type system now understands (and (not simple-array)) X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=c2cc1c425f71dbf858f609a5d5a94e2541d08824;p=sbcl.git 1.0.32.31: type system now understands (and (not simple-array)) Taken to mean the with COMPLEXP T (rather than :MAYBE). Adjust the type test transform to use the old technique for testing for complex arrays (using an explicit (NOT SIMPLE-ARRAY) test rather than a full call to %TYPEP, as you would otherwise get; this is a KLUDGE, but no worse than before). Include a test case for bug #309129, which this fixes. --- diff --git a/NEWS b/NEWS index 5ebc074..e3d2053 100644 --- a/NEWS +++ b/NEWS @@ -66,6 +66,8 @@ changes relative to sbcl-1.0.32: bug #396597) * bug fix: correctly dump literal objects in defaulting forms of arglists. (reported by Attila Lendvai; launchpad bug #310132) + * bug fix: distinguish in type specifiers between arrays that might be + complex and arrays that are definitely complex. (launchpad bug #309129) changes in sbcl-1.0.32 relative to sbcl-1.0.31: * optimization: faster FIND and POSITION on strings of unknown element type diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index ea1fdaa..6b1fd40 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -1531,11 +1531,26 @@ (aver (not (eq (type-union not1 not2) *universal-type*))) nil)))) +(defun maybe-complex-array-refinement (type1 type2) + (let* ((ntype (negation-type-type type2)) + (ndims (array-type-dimensions ntype)) + (ncomplexp (array-type-complexp ntype)) + (nseltype (array-type-specialized-element-type ntype)) + (neltype (array-type-element-type ntype))) + (if (and (eql ndims '*) (null ncomplexp) + (eql neltype *wild-type*) (eql nseltype *wild-type*)) + (make-array-type :dimensions (array-type-dimensions type1) + :complexp t + :element-type (array-type-element-type type1) + :specialized-element-type (array-type-specialized-element-type type1))))) + (!define-type-method (negation :complex-intersection2) (type1 type2) (cond ((csubtypep type1 (negation-type-type type2)) *empty-type*) ((eq (type-intersection type1 (negation-type-type type2)) *empty-type*) type1) + ((and (array-type-p type1) (array-type-p (negation-type-type type2))) + (maybe-complex-array-refinement type1 type2)) (t nil))) (!define-type-method (negation :simple-union2) (type1 type2) @@ -2343,21 +2358,31 @@ used for a COMPLEX component.~:@>" (complexp (array-type-complexp type))) (cond ((eq dims '*) (if (eq eltype '*) - (if complexp 'array 'simple-array) - (if complexp `(array ,eltype) `(simple-array ,eltype)))) + (ecase complexp + ((t) '(and array (not simple-array))) + ((:maybe) 'array) + ((nil) 'simple-array)) + (ecase complexp + ((t) `(and (array ,eltype) (not simple-array))) + ((:maybe) `(array ,eltype)) + ((nil) `(simple-array ,eltype))))) ((= (length dims) 1) (if complexp - (if (eq (car dims) '*) - (case eltype - (bit 'bit-vector) - ((base-char #!-sb-unicode character) 'base-string) - (* 'vector) - (t `(vector ,eltype))) - (case eltype - (bit `(bit-vector ,(car dims))) - ((base-char #!-sb-unicode character) - `(base-string ,(car dims))) - (t `(vector ,eltype ,(car dims))))) + (let ((answer + (if (eq (car dims) '*) + (case eltype + (bit 'bit-vector) + ((base-char #!-sb-unicode character) 'base-string) + (* 'vector) + (t `(vector ,eltype))) + (case eltype + (bit `(bit-vector ,(car dims))) + ((base-char #!-sb-unicode character) + `(base-string ,(car dims))) + (t `(vector ,eltype ,(car dims))))))) + (if (eql complexp :maybe) + answer + `(and ,answer (not simple-array)))) (if (eq (car dims) '*) (case eltype (bit 'simple-bit-vector) @@ -2371,9 +2396,10 @@ used for a COMPLEX component.~:@>" ((t) `(simple-vector ,(car dims))) (t `(simple-array ,eltype ,dims)))))) (t - (if complexp - `(array ,eltype ,dims) - `(simple-array ,eltype ,dims)))))) + (ecase complexp + ((t) `(and (array ,eltype ,dims) (not simple-array))) + ((:maybe) `(array ,eltype ,dims)) + ((nil) `(simple-array ,eltype ,dims))))))) (!define-type-method (array :simple-subtypep) (type1 type2) (let ((dims1 (array-type-dimensions type1)) diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 4f47e17..6abf25c 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -406,14 +406,24 @@ ;; not safe to assume here that it will eventually ;; have (UPGRADED-ARRAY-ELEMENT-TYPE type)=T, so punt.) (not (unknown-type-p (array-type-element-type type))) - (eq (array-type-complexp stype) (array-type-complexp type))) - (once-only ((n-obj obj)) - (multiple-value-bind (tests headerp) - (test-array-dimensions n-obj type stype) - `(and (,pred ,n-obj) - ,@tests - ,@(test-array-element-type n-obj type stype headerp)))) - `(%typep ,obj ',(type-specifier type))))) + (or (eq (array-type-complexp stype) (array-type-complexp type)) + (and (eql (array-type-complexp stype) :maybe) + (eql (array-type-complexp type) t)))) + (once-only ((n-obj obj)) + (multiple-value-bind (tests headerp) + (test-array-dimensions n-obj type stype) + `(and (,pred ,n-obj) + ,@(when (and (eql (array-type-complexp stype) :maybe) + (eql (array-type-complexp type) t)) + ;; KLUDGE: this is a bit lame; if we get here, + ;; we already know that N-OBJ is an array, but + ;; (NOT SIMPLE-ARRAY) doesn't know that. On the + ;; other hand, this should get compiled down to + ;; two widetag tests, so it's only a bit lame. + `((typep ,n-obj '(not simple-array)))) + ,@tests + ,@(test-array-element-type n-obj type stype headerp)))) + `(%typep ,obj ',(type-specifier type))))) ;;; Transform a type test against some instance type. The type test is ;;; flushed if the result is known at compile time. If not properly diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 6bf6dfd..81f7f5f 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -3367,3 +3367,19 @@ ;;; doing the same in-core to break. (with-test (:name :bug-310132) (compile nil '(lambda (&optional (foo #p"foo/bar"))))) + +(with-test (:name :bug-309129) + (let* ((src '(lambda (v) (values (svref v 0) (vector-pop v)))) + (warningp nil) + (fun (handler-bind ((warning (lambda (c) + (setf warningp t) (muffle-warning c)))) + (compile nil src)))) + (assert warningp) + (handler-case (funcall fun #(1)) + (type-error (c) + ;; we used to put simply VECTOR into EXPECTED-TYPE, rather + ;; than explicitly (AND VECTOR (NOT SIMPLE-ARRAY)) + (assert (not (typep (type-error-datum c) (type-error-expected-type c))))) + (:no-error (&rest values) + (declare (ignore values)) + (error "no error"))))) diff --git a/version.lisp-expr b/version.lisp-expr index d8a0544..0745dea 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.32.30" +"1.0.32.31"