X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Flate-type.lisp;h=007950a4e5f06f8f070d29a2e2464428b013fe5e;hb=8643c93d4db277f6e1cb880a42407ff29e19f618;hp=e1d2e25728c6539fbbfee79dc6c2e466f379e887;hpb=d052cf55544eb8c251146457d9245e8610e0a8f2;p=sbcl.git

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index e1d2e25..007950a 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -1051,7 +1051,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 +1146,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 +1159,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 +1202,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 +1237,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 +1257,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 +1294,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))))
 
@@ -2352,11 +2387,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)
@@ -2659,7 +2691,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
@@ -3092,6 +3124,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
 
@@ -3104,29 +3138,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