0.7.13.pcl-class.1

[sbcl.git] / src / code / late-type.lisp

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 88eb018..15b8cb5 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -77,15 +77,16 @@
       (values
        ;; FIXME: This old CMU CL code probably deserves a comment
        ;; explaining to us mere mortals how it works...
-       (and (sb!xc:typep type2 'sb!xc:class)
+       (and (sb!xc:typep type2 'classoid)
            (dolist (x info nil)
              (when (or (not (cdr x))
                        (csubtypep type1 (specifier-type (cdr x))))
                (return
                 (or (eq type2 (car x))
-                    (let ((inherits (layout-inherits (class-layout (car x)))))
+                    (let ((inherits (layout-inherits
+                                     (classoid-layout (car x)))))
                       (dotimes (i (length inherits) nil)
-                        (when (eq type2 (layout-class (svref inherits i)))
+                        (when (eq type2 (layout-classoid (svref inherits i)))
                           (return t)))))))))
        t)))
 
@@ -110,7 +111,7 @@
                              (destructuring-bind
                                  (super &optional guard)
                                  spec
-                               (cons (sb!xc:find-class super) guard)))
+                               (cons (find-classoid super) guard)))
                            ',specs)))
         (setf (type-class-complex-subtypep-arg1 ,type-class)
               (lambda (type1 type2)
@@ -1011,6 +1012,23 @@
   ;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type.
   (values (eq type1 type2) t))
 
+(!define-type-method (named :complex-=) (type1 type2)
+  (cond
+    ((and (eq type2 *empty-type*)
+         (intersection-type-p type1)
+         ;; not allowed to be unsure on these... FIXME: keep the list
+         ;; of CL types that are intersection types once and only
+         ;; once.
+         (not (or (type= type1 (specifier-type 'ratio))
+                  (type= type1 (specifier-type 'keyword)))))
+     ;; things like (AND (EQL 0) (SATISFIES ODDP)) or (AND FUNCTION
+     ;; STREAM) can get here.  In general, we can't really tell
+     ;; whether these are equal to NIL or not, so
+     (values nil nil))
+    ((type-might-contain-other-types-p type1)
+     (invoke-complex-=-other-method type1 type2))
+    (t (values nil t))))
+
 (!define-type-method (named :simple-subtypep) (type1 type2)
   (aver (not (eq type1 *wild-type*))) ; * isn't really a type.
   (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t))
@@ -1053,7 +1071,9 @@
   (aver (not (eq type2 *wild-type*))) ; * isn't really a type.
   (cond ((eq type2 *universal-type*)
         (values t t))
-       ((hairy-type-p type1)
+       ((type-might-contain-other-types-p type1)
+        ;; those types can be *EMPTY-TYPE* or *UNIVERSAL-TYPE* in
+        ;; disguise.  So we'd better delegate.
         (invoke-complex-subtypep-arg1-method type1 type2))
        (t
         ;; FIXME: This seems to rely on there only being 2 or 3
@@ -2406,9 +2426,7 @@
             (intersection-type-types type2)))
 
 (defun %intersection-complex-subtypep-arg1 (type1 type2)
-  (any/type (swapped-args-fun #'csubtypep)
-           type2
-           (intersection-type-types type1)))
+  (type= type1 (type-intersection type1 type2)))
 
 (defun %intersection-simple-subtypep (type1 type2)
   (every/type #'%intersection-complex-subtypep-arg1
@@ -2542,8 +2560,7 @@
 
 (!define-type-method (union :complex-=) (type1 type2)
   (declare (ignore type1))
-  (if (some #'(lambda (x) (or (hairy-type-p x)
-                             (negation-type-p x)))
+  (if (some #'type-might-contain-other-types-p 
            (union-type-types type2))
       (values nil nil)
       (values nil t)))
@@ -2812,8 +2829,8 @@
 (defun defined-ftype-matches-declared-ftype-p (defined-ftype declared-ftype)
   (declare (type ctype defined-ftype declared-ftype))
   (flet ((is-built-in-class-function-p (ctype)
-          (and (built-in-class-p ctype)
-               (eq (built-in-class-%name ctype) 'function))))
+          (and (built-in-classoid-p ctype)
+               (eq (built-in-classoid-name ctype) 'function))))
     (cond (;; DECLARED-FTYPE could certainly be #<BUILT-IN-CLASS FUNCTION>;
           ;; that's what happens when we (DECLAIM (FTYPE FUNCTION FOO)).
           (is-built-in-class-function-p declared-ftype)