1.0.32.31: type system now understands (and <array-type> (not simple-array))

Taken to mean the <array-type> 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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"