X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fprimtype.lisp;h=2ee50b094528526e38eab4059b66a4a85143209f;hb=ba871531b6b394da295c9a4527346e1e6327ccca;hp=1492378df910fcbbdd10000f3955a3a358469dfd;hpb=f1ffbf976aaa50b7b22f126b97e34afe06a91210;p=sbcl.git

diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp
index 1492378..2ee50b0 100644
--- a/src/compiler/generic/primtype.lisp
+++ b/src/compiler/generic/primtype.lisp
@@ -126,7 +126,8 @@
 (!def-vm-support-routine primitive-type-of (object)
   (let ((type (ctype-of object)))
     (cond ((not (member-type-p type)) (primitive-type type))
-          ((equal (member-type-members type) '(nil))
+          ((and (eql 1 (member-type-size type))
+                (equal (member-type-members type) '(nil)))
            (primitive-type-or-lose 'list))
           (t
            *backend-t-primitive-type*))))
@@ -313,69 +314,80 @@
                              (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))))))
+               (res (any)))
+           ;; why NIL for the exact?  Well, we assume that the
+           ;; intersection type is in fact doing something for us:
+           ;; that is, that each of the types in the intersection is
+           ;; in fact cutting off some of the type lattice.  Since no
+           ;; intersection type is represented by a primitive type and
+           ;; primitive types are mutually exclusive, it follows that
+           ;; no intersection type can represent the entirety of the
+           ;; primitive type.  (And NIL is the conservative answer,
+           ;; anyway).  -- CSR, 2006-09-14
+           (dolist (type types (values res nil))
+             (multiple-value-bind (ptype)
+                 (primitive-type type)
+               (cond
+                 ;; if the result so far is (any), any improvement on
+                 ;; the specificity of the primitive type is valid.
+                 ((eq res (any))
+                  (setq res ptype))
+                 ;; if the primitive type returned is (any), the
+                 ;; result so far is valid.  Likewise, if the
+                 ;; primitive type is the same as the result so far,
+                 ;; everything is fine.
+                 ((or (eq ptype (any)) (eq ptype res)))
+                 ;; otherwise, we have something hairy and confusing,
+                 ;; such as (and condition funcallable-instance).
+                 ;; Punt.
+                 (t (return (any))))))))
         (member-type
-         (let* ((members (member-type-members type))
-                (res (primitive-type-of (first members))))
-           (dolist (mem (rest members) (values res nil))
-             (let ((ptype (primitive-type-of mem)))
-               (unless (eq ptype res)
-                 (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)))))))))
+         (let (res)
+           (block nil
+             (mapc-member-type-members
+              (lambda (member)
+                (let ((ptype (primitive-type-of member)))
+                  (if res
+                      (unless (eq ptype res)
+                        (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)))))
+                      (setf res ptype))))
+              type))
+           res))
         (named-type
          (ecase (named-type-name type)
            ((t *) (values *backend-t-primitive-type* t))
+           ((instance) (exactly instance))
+           ((funcallable-instance) (part-of function))
+           ((extended-sequence) (any))
            ((nil) (any))))
-       (character-set-type
-        (let ((pairs (character-set-type-pairs type)))
-          (if (and (= (length pairs) 1)
-                   (= (caar pairs) 0)
-                   (= (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)))))))
+        (character-set-type
+         (let ((pairs (character-set-type-pairs type)))
+           (if (and (= (length pairs) 1)
+                    (= (caar pairs) 0)
+                    (= (cdar pairs) (1- sb!xc:char-code-limit)))
+               (exactly character)
+               (part-of character))))
+        (built-in-classoid
+         (case (classoid-name type)
+           ((complex function system-area-pointer weak-pointer)
+            (values (primitive-type-or-lose (classoid-name type)) t))
+           (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")