0.8.16.32: Fix #302

            * PRIMITIVE-TYPE used to return (any) for all intersection
               types. Make it smarter.

diff --git a/BUGS b/BUGS
index 5105302..0c13efc 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -1101,14 +1101,6 @@ WORKAROUND:
   gives the error
     failed AVER: "(NOT (AND (NOT EQUALP) CERTAINP))"
 
-302: Undefined type messes up DATA-VECTOR-REF expansion.
-  Compiling this file
-    (defun dis (s ei x y)
-      (declare (type (simple-array function (2)) s) (type ei ei))
-      (funcall (aref s ei) x y))
-  on sbcl-0.8.7.36/X86/Linux causes a BUG to be signalled:
-    full call to SB-KERNEL:DATA-VECTOR-REF
-
 303: "nonlinear LVARs" (aka MISC.293)
     (defun buu (x)
       (multiple-value-call #'list

diff --git a/NEWS b/NEWS
index 6c17834..03e3eba 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -16,6 +16,8 @@ changes in sbcl-0.8.17 relative to sbcl-0.8.16:
   * minor incompatible change: SB-C::*COMPILER-ERROR-PRINT-FOO* variables
     are no longer supported: use SB-EXT:*COMPILER-PRINT-VARIABLE-ALIST*
     instead. 
+  * fixed bug #302: better primitive-type selection for intersection
+    types.
   * fixed bug #308: non-graphic characters now all have names, as
     required.  (reported by Bruno Haible)
   * bug fix: Cyclic structures and unprintable objects in compiler

diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp
index 962b22f..a219a4f 100644 (file)
--- a/src/compiler/generic/primtype.lisp
+++ b/src/compiler/generic/primtype.lisp
@@ -283,12 +283,35 @@
                       (primitive-type type)
                     (unless ptype-exact (setq exact nil))
                     (unless (eq ptype res)
-                      (let ((new-ptype
-                             (or (maybe-numeric-type-union res ptype)
+                      (let ((new-ptype 
+                              (or (maybe-numeric-type-union res ptype)
                                  (maybe-numeric-type-union ptype res))))
                         (if new-ptype
                             (setq res new-ptype)
                             (return (any)))))))))))
+        (intersection-type
+         (let ((types (intersection-type-types type))
+               (res (any))
+               (exact nil))
+           (dolist (type types (values res exact))
+             (when (eq type (specifier-type 'function))
+               ;; KLUDGE: Deal with (and function instance), both of which
+               ;; have an exact primitive type.
+               (return (part-of function)))
+             (multiple-value-bind (ptype ptype-exact)
+                   (primitive-type type)
+                 (when ptype-exact
+                   ;; Apart from the previous kludge exact primitive
+                   ;; types should match, if indeed there are any. It
+                   ;; may be that this assumption isn't really safe,
+                   ;; but at least we'll see what breaks. -- NS 20041104
+                   (aver (or (not exact) (eq ptype res)))
+                   (setq exact t))
+                 (when (or ptype-exact (and (not exact) (eq res (any))))
+                   ;; Try to find a narrower representation then
+                   ;; (any). Takes care of undecidable types in
+                   ;; intersections with decidable ones.
+                   (setq res ptype))))))
        (member-type
         (let* ((members (member-type-members type))
                (res (primitive-type-of (first members))))
@@ -311,26 +334,26 @@
                    (= (cdar pairs) (1- sb!xc:char-code-limit)))
               (exactly character)
               (part-of character))))
-       (built-in-classoid
-        (case (classoid-name type)
-          ((complex function instance
-            system-area-pointer weak-pointer)
-           (values (primitive-type-or-lose (classoid-name type)) t))
-          (funcallable-instance
-           (part-of function))
-          (cons-type
-           (part-of list))
-          (t
-           (any))))
-       (fun-type
-        (exactly function))
-       (classoid
-        (if (csubtypep type (specifier-type 'function))
-            (part-of function)
-            (part-of instance)))
-       (ctype
-         (if (csubtypep type (specifier-type 'function))
-            (part-of function)
-             (any)))))))
+       (built-in-classoid
+        (case (classoid-name type)
+          ((complex function instance
+                    system-area-pointer weak-pointer)
+           (values (primitive-type-or-lose (classoid-name type)) t))
+          (funcallable-instance
+           (part-of function))
+          (cons-type
+           (part-of list))
+          (t
+           (any))))
+       (fun-type
+        (exactly function))
+       (classoid
+        (if (csubtypep type (specifier-type 'function))
+            (part-of function)
+            (part-of instance)))
+       (ctype
+        (if (csubtypep type (specifier-type 'function))
+            (part-of function)
+            (any)))))))
 
 (/show0 "primtype.lisp end of file")

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 3bbe2c5..e9ca625 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -1598,3 +1598,10 @@
                   (compilation-speed 0) (speed 1)))
        (if (logbitp 0 (ash (1- a) (min 11 a))) 0 0)))
    805)))
+
+;;; bug #302
+(assert (compile
+         nil
+         '(lambda (s ei x y)
+           (declare (type (simple-array function (2)) s) (type ei ei))
+           (funcall (aref s ei) x y))))

diff --git a/version.lisp-expr b/version.lisp-expr
index 6dcb422..c15a297 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".)
-"0.8.16.31"
+"0.8.16.32"