X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=ea1fdaa568b04e3b5f612ab65f63f8caed592619;hb=a18894dbea4495b885e1747babf4e2593dfb705e;hp=2fb73b6646dd7056ea560f3c7dcaf2f772010c7e;hpb=cb43defd8ce791c9c5a8302c0bca20fcd1b60749;p=sbcl.git

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 2fb73b6..ea1fdaa 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -369,6 +369,36 @@
 ;;;; We provide a few special operations that can be meaningfully used
 ;;;; on VALUES types (as well as on any other type).
 
+;;; Return the minimum number of values possibly matching VALUES type
+;;; TYPE.
+(defun values-type-min-value-count (type)
+  (etypecase type
+    (named-type
+     (ecase (named-type-name type)
+       ((t *) 0)
+       ((nil) 0)))
+    (values-type
+     (length (values-type-required type)))))
+
+;;; Return the maximum number of values possibly matching VALUES type
+;;; TYPE.
+(defun values-type-max-value-count (type)
+  (etypecase type
+    (named-type
+     (ecase (named-type-name type)
+       ((t *) call-arguments-limit)
+       ((nil) 0)))
+    (values-type
+     (if (values-type-rest type)
+         call-arguments-limit
+         (+ (length (values-type-optional type))
+            (length (values-type-required type)))))))
+
+(defun values-type-may-be-single-value-p (type)
+  (<= (values-type-min-value-count type)
+      1
+      (values-type-max-value-count type)))
+
 (defun type-single-value-p (type)
   (and (values-type-p type)
        (not (values-type-rest type))
@@ -1051,7 +1081,11 @@
    ;; required to be a subclass of STANDARD-OBJECT.  -- CSR,
    ;; 2005-09-09
    (frob instance *instance-type*)
-   (frob funcallable-instance *funcallable-instance-type*))
+   (frob funcallable-instance *funcallable-instance-type*)
+   ;; new in sbcl-1.0.3.3: necessary to act as a join point for the
+   ;; extended sequence hierarchy.  (Might be removed later if we use
+   ;; a dedicated FUNDAMENTAL-SEQUENCE class for this.)
+   (frob extended-sequence *extended-sequence-type*))
  (setf *universal-fun-type*
        (make-fun-type :wild-args t
                       :returns *wild-type*)))
@@ -1142,10 +1176,10 @@
   (aver (not (eq type2 *wild-type*))) ; * isn't really a type.
   (cond ((eq type2 *universal-type*)
          (values t t))
-        ((or (type-might-contain-other-types-p type1)
-             ;; some CONS types can conceal danger
-             (and (cons-type-p type1)
-                  (cons-type-might-be-empty-type type1)))
+        ;; some CONS types can conceal danger
+        ((and (cons-type-p type1) (cons-type-might-be-empty-type type1))
+         (values nil nil))
+        ((type-might-contain-other-types-p type1)
          ;; those types can be other types in disguise.  So we'd
          ;; better delegate.
          (invoke-complex-subtypep-arg1-method type1 type2))
@@ -1155,6 +1189,12 @@
          ;; member types can be subtypep INSTANCE and
          ;; FUNCALLABLE-INSTANCE in surprising ways.
          (invoke-complex-subtypep-arg1-method type1 type2))
+        ((and (eq type2 *extended-sequence-type*) (classoid-p type1))
+         (let* ((layout (classoid-layout type1))
+                (inherits (layout-inherits layout))
+                (sequencep (find (classoid-layout (find-classoid 'sequence))
+                                 inherits)))
+           (values (if sequencep t nil) t)))
         ((and (eq type2 *instance-type*) (classoid-p type1))
          (if (member type1 *non-instance-classoid-types* :key #'find-classoid)
              (values nil t)
@@ -1192,6 +1232,21 @@
   ;; Perhaps when bug 85 is fixed it can be reenabled.
   ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
   (cond
+    ((eq type2 *extended-sequence-type*)
+     (typecase type1
+       (structure-classoid *empty-type*)
+       (classoid
+        (if (member type1 *non-instance-classoid-types* :key #'find-classoid)
+            *empty-type*
+            (if (find (classoid-layout (find-classoid 'sequence))
+                      (layout-inherits (classoid-layout type1)))
+                type1
+                nil)))
+       (t
+        (if (or (type-might-contain-other-types-p type1)
+                (member-type-p type1))
+            nil
+            *empty-type*))))
     ((eq type2 *instance-type*)
      (typecase type1
        (structure-classoid type1)
@@ -1212,14 +1267,14 @@
      (typecase type1
        (structure-classoid *empty-type*)
        (classoid
-        (if (and (not (member type1 *non-instance-classoid-types*
-                              :key #'find-classoid))
-                 (find (classoid-layout (find-classoid 'function))
-                       (layout-inherits (classoid-layout type1))))
-            type1
-            (if (type= type1 (find-classoid 'function))
-                type2
-                nil)))
+        (if (member type1 *non-instance-classoid-types* :key #'find-classoid)
+            *empty-type*
+            (if (find (classoid-layout (find-classoid 'function))
+                      (layout-inherits (classoid-layout type1)))
+                type1
+                (if (type= type1 (find-classoid 'function))
+                    type2
+                    nil))))
        (fun-type nil)
        (t
         (if (or (type-might-contain-other-types-p type1)
@@ -1232,6 +1287,15 @@
   ;; Perhaps when bug 85 is fixed this can be reenabled.
   ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
   (cond
+    ((eq type2 *extended-sequence-type*)
+     (if (classoid-p type1)
+         (if (or (member type1 *non-instance-classoid-types*
+                         :key #'find-classoid)
+                 (not (find (classoid-layout (find-classoid 'sequence))
+                            (layout-inherits (classoid-layout type1)))))
+             nil
+             type2)
+         nil))
     ((eq type2 *instance-type*)
      (if (classoid-p type1)
          (if (or (member type1 *non-instance-classoid-types*
@@ -1260,7 +1324,8 @@
     ((eq x *universal-type*) *empty-type*)
     ((eq x *empty-type*) *universal-type*)
     ((or (eq x *instance-type*)
-         (eq x *funcallable-instance-type*))
+         (eq x *funcallable-instance-type*)
+         (eq x *extended-sequence-type*))
      (make-negation-type :type x))
     (t (bug "NAMED type unexpected: ~S" x))))
 
@@ -1847,8 +1912,9 @@
                            (mapcar #'do-complex (union-type-types ctype))))
                    ((typep ctype 'member-type)
                     (apply #'type-union
-                           (mapcar (lambda (x) (do-complex (ctype-of x)))
-                                   (member-type-members ctype))))
+                           (mapcar-member-type-members
+                            (lambda (x) (do-complex (ctype-of x)))
+                            ctype)))
                    ((and (typep ctype 'intersection-type)
                          ;; FIXME: This is very much a
                          ;; not-quite-worst-effort, but we are required to do
@@ -2352,11 +2418,8 @@ used for a COMPLEX component.~:@>"
                           (array-type-specialized-element-type type2))
                    t)))))
 
-;;; FIXME: is this dead?
 (!define-superclasses array
-  ((base-string base-string)
-   (vector vector)
-   (array))
+  ((vector vector) (array))
   !cold-init-forms)
 
 (defun array-types-intersect (type1 type2)
@@ -2418,15 +2481,10 @@ used for a COMPLEX component.~:@>"
           (wild1 (eq eltype1 *wild-type*))
           (wild2 (eq eltype2 *wild-type*))
           (e2 nil))
-     ;; This is possibly a bit more conservative then it needs to be:
-     ;; it seems that wild eltype in either should lead to wild eltype
-     ;; in result, but the rest of the type-system doesn't seem too
-     ;; happy about that. --NS 2006-08-23
-     (when (and (or (and wild1 wild2)
-                    (and (not (or wild1 wild2))
-                         (or (setf e2 (csubtypep eltype1 eltype2))
-                             (csubtypep eltype2 eltype1))))
-                (type= stype1 stype2))
+     (when (or wild1 wild2
+               (and (or (setf e2 (csubtypep eltype1 eltype2))
+                        (csubtypep eltype2 eltype1))
+                    (type= stype1 stype2)))
        (make-array-type
         :dimensions (cond ((or (eq dims1 '*) (eq dims2 '*))
                            '*)
@@ -2439,7 +2497,7 @@ used for a COMPLEX component.~:@>"
                            '*))
         :complexp (if (eq complexp1 complexp2) complexp1 :maybe)
         :element-type (if (or wild2 e2) eltype2 eltype1)
-        :specialized-element-type stype1))))
+        :specialized-element-type (if wild2 stype2 stype1)))))
 
 (!define-type-method (array :simple-intersection2) (type1 type2)
   (declare (type array-type type1 type2))
@@ -2501,39 +2559,28 @@ used for a COMPLEX component.~:@>"
 (!define-type-class member)
 
 (!define-type-method (member :negate) (type)
-  (let ((members (member-type-members type)))
-    (if (some #'floatp members)
-        (let (floats)
-          (dolist (pair `((0.0f0 . ,(load-time-value (make-unportable-float :single-float-negative-zero)))
-                          (0.0d0 . ,(load-time-value (make-unportable-float :double-float-negative-zero)))
-                          #!+long-float
-                          (0.0l0 . ,(load-time-value (make-unportable-float :long-float-negative-zero)))))
-            (when (member (car pair) members)
-              (aver (not (member (cdr pair) members)))
-              (push (cdr pair) floats)
-              (setf members (remove (car pair) members)))
-            (when (member (cdr pair) members)
-              (aver (not (member (car pair) members)))
-              (push (car pair) floats)
-              (setf members (remove (cdr pair) members))))
-          (apply #'type-intersection
-                 (if (null members)
-                     *universal-type*
+  (let ((xset (member-type-xset type))
+        (fp-zeroes (member-type-fp-zeroes type)))
+    (if fp-zeroes
+        ;; Hairy case, which needs to do a bit of float type
+        ;; canonicalization.
+        (apply #'type-intersection
+               (if (xset-empty-p xset)
+                   *universal-type*
+                   (make-negation-type
+                    :type (make-member-type :xset xset)))
+               (mapcar
+                (lambda (x)
+                  (let* ((opposite (neg-fp-zero x))
+                         (type (ctype-of opposite)))
+                    (type-union
                      (make-negation-type
-                      :type (make-member-type :members members)))
-                 (mapcar
-                  (lambda (x)
-                    (let ((type (ctype-of x)))
-                      (type-union
-                       (make-negation-type
-                        :type (modified-numeric-type type
-                                                     :low nil :high nil))
-                       (modified-numeric-type type
-                                              :low nil :high (list x))
-                       (make-member-type :members (list x))
-                       (modified-numeric-type type
-                                              :low (list x) :high nil))))
-                  floats)))
+                      :type (modified-numeric-type type :low nil :high nil))
+                     (modified-numeric-type type :low nil :high (list opposite))
+                     (make-member-type :members (list opposite))
+                     (modified-numeric-type type :low (list opposite) :high nil))))
+                fp-zeroes))
+        ;; Easy case
         (make-negation-type :type type))))
 
 (!define-type-method (member :unparse) (type)
@@ -2544,13 +2591,23 @@ used for a COMPLEX component.~:@>"
       (t `(member ,@members)))))
 
 (!define-type-method (member :simple-subtypep) (type1 type2)
-  (values (subsetp (member-type-members type1) (member-type-members type2))
-          t))
+   (values (and (xset-subset-p (member-type-xset type1)
+                                 (member-type-xset type2))
+                (subsetp (member-type-fp-zeroes type1)
+                         (member-type-fp-zeroes type2)))
+           t))
 
 (!define-type-method (member :complex-subtypep-arg1) (type1 type2)
-  (every/type (swapped-args-fun #'ctypep)
-              type2
-              (member-type-members type1)))
+  (block punt
+    (mapc-member-type-members
+     (lambda (elt)
+       (multiple-value-bind (ok surep) (ctypep elt type2)
+         (unless surep
+           (return-from punt (values nil nil)))
+         (unless ok
+           (return-from punt (values nil t)))))
+     type1)
+    (values t t)))
 
 ;;; We punt if the odd type is enumerable and intersects with the
 ;;; MEMBER type. If not enumerable, then it is definitely not a
@@ -2562,46 +2619,48 @@ used for a COMPLEX component.~:@>"
         (t (values nil t))))
 
 (!define-type-method (member :simple-intersection2) (type1 type2)
-  (let ((mem1 (member-type-members type1))
-        (mem2 (member-type-members type2)))
-    (cond ((subsetp mem1 mem2) type1)
-          ((subsetp mem2 mem1) type2)
-          (t
-           (let ((res (intersection mem1 mem2)))
-             (if res
-                 (make-member-type :members res)
-                 *empty-type*))))))
+  (make-member-type :xset (xset-intersection (member-type-xset type1)
+                                             (member-type-xset type2))
+                    :fp-zeroes (intersection (member-type-fp-zeroes type1)
+                                             (member-type-fp-zeroes type2))))
 
 (!define-type-method (member :complex-intersection2) (type1 type2)
   (block punt
-    (collect ((members))
-      (let ((mem2 (member-type-members type2)))
-        (dolist (member mem2)
-          (multiple-value-bind (val win) (ctypep member type1)
-            (unless win
-              (return-from punt nil))
-            (when val (members member))))
-        (cond ((subsetp mem2 (members)) type2)
-              ((null (members)) *empty-type*)
-              (t
-               (make-member-type :members (members))))))))
+    (let ((xset (alloc-xset))
+          (fp-zeroes nil))
+      (mapc-member-type-members
+       (lambda (member)
+         (multiple-value-bind (ok sure) (ctypep member type1)
+           (unless sure
+             (return-from punt nil))
+           (when ok
+             (if (fp-zero-p member)
+                 (pushnew member fp-zeroes)
+                 (add-to-xset member xset)))))
+       type2)
+      (if (and (xset-empty-p xset) (not fp-zeroes))
+          *empty-type*
+          (make-member-type :xset xset :fp-zeroes fp-zeroes)))))
 
 ;;; We don't need a :COMPLEX-UNION2, since the only interesting case is
 ;;; a union type, and the member/union interaction is handled by the
 ;;; union type method.
 (!define-type-method (member :simple-union2) (type1 type2)
-  (let ((mem1 (member-type-members type1))
-        (mem2 (member-type-members type2)))
-    (cond ((subsetp mem1 mem2) type2)
-          ((subsetp mem2 mem1) type1)
-          (t
-           (make-member-type :members (union mem1 mem2))))))
+  (make-member-type :xset (xset-union (member-type-xset type1)
+                                      (member-type-xset type2))
+                    :fp-zeroes (union (member-type-fp-zeroes type1)
+                                      (member-type-fp-zeroes type2))))
 
 (!define-type-method (member :simple-=) (type1 type2)
-  (let ((mem1 (member-type-members type1))
-        (mem2 (member-type-members type2)))
-    (values (and (subsetp mem1 mem2)
-                 (subsetp mem2 mem1))
+  (let ((xset1 (member-type-xset type1))
+        (xset2 (member-type-xset type2))
+        (l1 (member-type-fp-zeroes type1))
+        (l2 (member-type-fp-zeroes type2)))
+    (values (and (eql (xset-count xset1) (xset-count xset2))
+                 (xset-subset-p xset1 xset2)
+                 (xset-subset-p xset2 xset1)
+                 (subsetp l1 l2)
+                 (subsetp l2 l1))
             t)))
 
 (!define-type-method (member :complex-=) (type1 type2)
@@ -2664,7 +2723,7 @@ used for a COMPLEX component.~:@>"
 ;;; mechanically unparsed.
 (!define-type-method (intersection :unparse) (type)
   (declare (type ctype type))
-  (or (find type '(ratio keyword) :key #'specifier-type :test #'type=)
+  (or (find type '(ratio keyword compiled-function) :key #'specifier-type :test #'type=)
       `(and ,@(mapcar #'type-specifier (intersection-type-types type)))))
 
 ;;; shared machinery for type equality: true if every type in the set
@@ -3097,6 +3156,8 @@ used for a COMPLEX component.~:@>"
                  (type-intersection (cons-type-car-type type1)
                                     (cons-type-car-type type2))
                  cdr-int2)))))
+
+(!define-superclasses cons ((cons)) !cold-init-forms)
 
 ;;;; CHARACTER-SET types
 
@@ -3109,29 +3170,29 @@ used for a COMPLEX component.~:@>"
 (!define-type-method (character-set :negate) (type)
   (let ((pairs (character-set-type-pairs type)))
     (if (and (= (length pairs) 1)
-            (= (caar pairs) 0)
-            (= (cdar pairs) (1- sb!xc:char-code-limit)))
-       (make-negation-type :type type)
-       (let ((not-character
-              (make-negation-type
-               :type (make-character-set-type
-                      :pairs '((0 . #.(1- sb!xc:char-code-limit)))))))
-         (type-union
-          not-character
-          (make-character-set-type
-           :pairs (let (not-pairs)
-                    (when (> (caar pairs) 0)
-                      (push (cons 0 (1- (caar pairs))) not-pairs))
-                    (do* ((tail pairs (cdr tail))
-                          (high1 (cdar tail))
-                          (low2 (caadr tail)))
-                         ((null (cdr tail))
-                          (when (< (cdar tail) (1- sb!xc:char-code-limit))
-                            (push (cons (1+ (cdar tail))
-                                        (1- sb!xc:char-code-limit))
-                                  not-pairs))
-                          (nreverse not-pairs))
-                      (push (cons (1+ high1) (1- low2)) not-pairs)))))))))
+             (= (caar pairs) 0)
+             (= (cdar pairs) (1- sb!xc:char-code-limit)))
+        (make-negation-type :type type)
+        (let ((not-character
+               (make-negation-type
+                :type (make-character-set-type
+                       :pairs '((0 . #.(1- sb!xc:char-code-limit)))))))
+          (type-union
+           not-character
+           (make-character-set-type
+            :pairs (let (not-pairs)
+                     (when (> (caar pairs) 0)
+                       (push (cons 0 (1- (caar pairs))) not-pairs))
+                     (do* ((tail pairs (cdr tail))
+                           (high1 (cdar tail) (cdar tail))
+                           (low2 (caadr tail) (caadr tail)))
+                          ((null (cdr tail))
+                           (when (< (cdar tail) (1- sb!xc:char-code-limit))
+                             (push (cons (1+ (cdar tail))
+                                         (1- sb!xc:char-code-limit))
+                                   not-pairs))
+                           (nreverse not-pairs))
+                       (push (cons (1+ high1) (1- low2)) not-pairs)))))))))
 
 (!define-type-method (character-set :unparse) (type)
   (cond
@@ -3252,14 +3313,20 @@ used for a COMPLEX component.~:@>"
     (collect ((res))
       (dolist (x-type x-types)
         (if (member-type-p x-type)
-            (collect ((members))
-              (dolist (mem (member-type-members x-type))
-                (multiple-value-bind (val win) (ctypep mem y)
-                  (unless win (return-from type-difference nil))
-                  (unless val
-                    (members mem))))
-              (when (members)
-                (res (make-member-type :members (members)))))
+            (let ((xset (alloc-xset))
+                  (fp-zeroes nil))
+              (mapc-member-type-members
+               (lambda (elt)
+                 (multiple-value-bind (ok sure) (ctypep elt y)
+                   (unless sure
+                     (return-from type-difference nil))
+                   (unless ok
+                     (if (fp-zero-p elt)
+                         (pushnew elt fp-zeroes)
+                         (add-to-xset elt xset)))))
+               x-type)
+              (unless (and (xset-empty-p xset) (not fp-zeroes))
+                (res (make-member-type :xset xset :fp-zeroes fp-zeroes))))
             (dolist (y-type y-types (res x-type))
               (multiple-value-bind (val win) (csubtypep x-type y-type)
                 (unless win (return-from type-difference nil))
@@ -3268,13 +3335,14 @@ used for a COMPLEX component.~:@>"
                   (return-from type-difference nil))))))
       (let ((y-mem (find-if #'member-type-p y-types)))
         (when y-mem
-          (let ((members (member-type-members y-mem)))
-            (dolist (x-type x-types)
-              (unless (member-type-p x-type)
-                (dolist (member members)
-                  (multiple-value-bind (val win) (ctypep member x-type)
-                    (when (or (not win) val)
-                      (return-from type-difference nil)))))))))
+          (dolist (x-type x-types)
+            (unless (member-type-p x-type)
+              (mapc-member-type-members
+               (lambda (member)
+                 (multiple-value-bind (ok sure) (ctypep member x-type)
+                   (when (or (not sure) ok)
+                     (return-from type-difference nil))))
+               y-mem)))))
       (apply #'type-union (res)))))
 
 (!def-type-translator array (&optional (element-type '*)