From c04807d03e5f36c55ec5181f7e895ccb774c6dfd Mon Sep 17 00:00:00 2001
From: toy <toy>
Date: Wed, 4 Dec 2002 17:25:55 +0000
Subject: [PATCH] o Make named :complex-subtypep-arg2 return T, T when the
 second type   is the type T.  (This still needs more work.) o Put back the
 original hairy :complex-subtypep-arg1 case to handle   AND specifiers.  This
 still needs more work too.

---
 code/type.lisp | 21 ++++++++++++++++-----
 1 file changed, 16 insertions(+), 5 deletions(-)

diff --git a/code/type.lisp b/code/type.lisp
index f41a72c15..3acc31c61 100644
--- a/code/type.lisp
+++ b/code/type.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.46 2002/11/13 19:47:19 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.47 2002/12/04 17:25:55 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -972,9 +972,13 @@
   (values (eq type1 *empty-type*) t))
 
 (define-type-method (named :complex-subtypep-arg2) (type1 type2)
-  (if (hairy-type-p type1)
-      (values nil nil)
-      (values (not (eq type2 *empty-type*)) t)))
+  (cond ((eq type2 *universal-type*)
+	 (values t t))
+	((hairy-type-p type1)
+	 ;; This obviously needs more work!
+	 (values nil nil))
+	(t
+	 (values (not (eq type2 *empty-type*)) t))))
 
 (define-type-method (named :complex-intersection) (type1 type2)
   (vanilla-intersection type1 type2))
@@ -1049,7 +1053,14 @@
 ;; This is the implementation used in SBCL.
 (define-type-method (hairy :complex-subtypep-arg1) (type1 type2)
   (let ((hairy-spec (hairy-type-specifier type1)))
-     (cond ((and (consp hairy-spec) (eq (car hairy-spec) 'not))
+     (cond ((and (consp hairy-spec) (eq (car hairy-spec) 'and))
+	    (block PUNT
+	      (if (any-type-op csubtypep type2
+			       (mapcar #'specifier-type (cdr hairy-spec))
+			       :list-first t)
+		  (values t t)
+		  (values nil nil))))
+	   ((and (consp hairy-spec) (eq (car hairy-spec) 'not))
 	    ;; You may not believe this. I couldn't either. But then I
 	    ;; sat down and drew lots of Venn diagrams. Comments
 	    ;; involving a and b refer to the call (subtypep '(not a)
-- 
GitLab