[Sbcl-commits] CVS: sbcl/src/code class.lisp,1.37,1.38 late-type.lisp,1.73,1.74 type-class.lisp,1.18,1.19

[Christophe R. <cr...@us...>]

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1:/tmp/cvs-serv4199/src/code

Modified Files:
	class.lisp late-type.lisp type-class.lisp 
Log Message:
0.7.13.11:
	Merge "type system insanity" (CSR sbcl-devel 2002-03-01)
	... extend INVOKE-COMPLEX-SUBTYPEP-ARG1-METHOD to take return
		values for the case that no next method is found
	... define and use (once!) equivalent logic for COMPLEX-=
	... be more uncertain on intersections of class types, since we
		create them when we don't know enough to canonicalize
	... various other cases demand more uncertainty, too (e.g.
		intersections involving HAIRY-TYPEs)
	No known failures inherent to the type system!


Index: class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/class.lisp,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -d -r1.37 -r1.38
--- class.lisp	2 Oct 2002 12:09:17 -0000	1.37
+++ class.lisp	3 Mar 2003 11:16:07 -0000	1.38
@@ -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))
 

Index: late-type.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/late-type.lisp,v
retrieving revision 1.73
retrieving revision 1.74
diff -u -d -r1.73 -r1.74
--- late-type.lisp	28 Feb 2003 15:50:33 -0000	1.73
+++ late-type.lisp	3 Mar 2003 11:16:07 -0000	1.74
@@ -1011,6 +1011,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 +1070,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 +2425,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 +2559,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)))

Index: type-class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/type-class.lisp,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -d -r1.18 -r1.19
--- type-class.lisp	14 Dec 2002 22:10:09 -0000	1.18
+++ type-class.lisp	3 Mar 2003 11:16:07 -0000	1.19
@@ -280,11 +280,21 @@
 ;;; when no next method exists. -- WHN 2002-04-07
 ;;;
 ;;; (We miss CLOS! -- CSR and WHN)
-(defun invoke-complex-subtypep-arg1-method (type1 type2)
+(defun invoke-complex-subtypep-arg1-method (type1 type2 &optional subtypep win)
   (let* ((type-class (type-class-info type1))
 	 (method-fun (type-class-complex-subtypep-arg1 type-class)))
     (if method-fun
 	(funcall (the function method-fun) type1 type2)
-	(values nil nil))))
+	(values subtypep win))))
+
+;;; KLUDGE: This function is dangerous, as its overuse could easily
+;;; cause stack exhaustion through unbounded recursion.  We only use
+;;; it in one place; maybe it ought not to be a function at all?
+(defun invoke-complex-=-other-method (type1 type2)
+  (let* ((type-class (type-class-info type1))
+	 (method-fun (type-class-complex-= type-class)))
+    (if method-fun
+	(funcall (the function method-fun) type2 type1)
+	(values nil t))))
 
 (!defun-from-collected-cold-init-forms !type-class-cold-init)