X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fclass.lisp;h=e93efb389c126dd3afb3b9ace5b5fdfc9ad0e0a9;hb=a3ab89c1db0dd9bfb911532ca134be16f16c4c1b;hp=7d9b77d17950e40832c2b3c0b638a5f85f8dd2de;hpb=7423377fd0981027ac9e9d07ff996d156e38206e;p=sbcl.git

diff --git a/src/code/class.lisp b/src/code/class.lisp
index 7d9b77d..e93efb3 100644
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -851,6 +851,21 @@
 	 ;; uncertain, since a subclass of both might be defined
 	 nil)))
 
+;;; KLUDGE: we need this because of the need to represent
+;;; intersections of two classes, even when empty at a given time, as
+;;; uncanonicalized intersections because of the possibility of later
+;;; defining a subclass of both classes.  The necessity for changing
+;;; the default return value from SUBTYPEP to NIL, T if no alternate
+;;; method is present comes about because, unlike the other places we
+;;; use INVOKE-COMPLEX-SUBTYPEP-ARG1-METHOD, in HAIRY methods and the
+;;; like, classes are in their own hierarchy with no possibility of
+;;; mixtures with other type classes.
+(!define-type-method (sb!xc:class :complex-subtypep-arg2) (type1 class2)
+  (if (and (intersection-type-p type1)
+	   (> (count-if #'class-p (intersection-type-types type1)) 1))
+      (values nil nil)
+      (invoke-complex-subtypep-arg1-method type1 class2 nil t)))
+
 (!define-type-method (sb!xc:class :unparse) (type)
   (class-proper-name type))