From 23f8e9ceab1920526552bb8d9f68f68bd1ec80b0 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Wed, 23 Apr 2003 15:19:41 +0000
Subject: [PATCH] 	Make the type system more forgiving wrt to unknown
 types. 	Temporary fix for -0d0/0d0 and member types.

	* src/code/type.lisp (reparse-unknown-type): New function.
	(type-union2, type-intersection2): Use it.
	(hierarchical-intersection2, hierarchical-union2): Moved to
	typedef.lisp.
	(member): Temporary fix for -0d0/0d0 problem; Christophe Rhodes is
	working on the real fix.

	* src/code/typedefs.lisp (type-class): Use hierachical-union2
	and hierachical-intersection2 as inits for slots simple-union
	and simple-intersection, like SBCL does.
	(hierarchical-intersection2, hierarchical-union2): Moved
	here from type.lisp.
---
 code/type.lisp     | 40 +++++++++++++++++++---------------------
 code/typedefs.lisp | 18 +++++++++++++++---
 2 files changed, 34 insertions(+), 24 deletions(-)

diff --git a/code/type.lisp b/code/type.lisp
index be46ff82f..31cc801b6 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.56 2003/04/17 21:19:04 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.57 2003/04/23 15:19:41 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -446,6 +446,12 @@
 
 ); eval-when (compile eval)
 
+(declaim (inline reparse-unknown-type))
+(defun reparse-unknown-type (type)
+  (if (unknown-type-p type)
+      (specifier-type (type-specifier type))
+      type))
+
 (declaim (inline swapped-args-fun))
 (defun swapped-args-fun (fun)
   (declare (type function fun))
@@ -461,19 +467,6 @@
 	  (equal-but-no-car-recursion (cdr x) (cdr y))))
     (t nil)))
 
-(defun hierarchical-intersection2 (type1 type2)
-  (multiple-value-bind (subtypep1 win1) (csubtypep type1 type2)
-    (multiple-value-bind (subtypep2 win2) (csubtypep type2 type1)
-      (cond (subtypep1 type1)
-	    (subtypep2 type2)
-	    ((and win1 win2) *empty-type*)
-	    (t nil)))))
-
-(defun hierarchical-union2 (type1 type2)
-  (cond ((csubtypep type1 type2) type2)
-	((csubtypep type2 type1) type1)
-	(t nil)))
-
 (defun any/type (op thing list)
   (declare (type function op))
   (let ((certain? t))
@@ -1137,6 +1130,8 @@
 			   :init-form cold-load-init)
 	      ((type1 eq) (type2 eq))
   (declare (type ctype type1 type2))
+  (setq type1 (reparse-unknown-type type1))
+  (setq type2 (reparse-unknown-type type2))
   (cond ((eq type1 type2) type1)
 	((csubtypep type1 type2) type2)
 	((csubtypep type2 type1) type1)
@@ -1214,6 +1209,8 @@
 				  :init-form cold-load-init)
     ((type1 eq) (type2 eq))
   (declare (type ctype type1 type2))
+  (setq type1 (reparse-unknown-type type1))
+  (setq type2 (reparse-unknown-type type2))
   (cond ((eq type1 type2)
 	 ;; FIXME: For some reason, this doesn't catch e.g. type1 =
 	 ;; type2 = (SPECIFIER-TYPE
@@ -2840,16 +2837,17 @@
 
 (def-type-translator member (&rest members)
   (if members
-      (let (ms numbers)
+      (collect ((non-numbers) (numbers))
 	(dolist (m (remove-duplicates members))
-	  (typecase m
-	    (number (push (ctype-of m) numbers))
-	    (t (push m ms))))
+	  (if (and (numberp m)
+		   (not (and (floatp m) (zerop m))))
+	      (numbers (ctype-of m))
+	      (non-numbers m)))
 	(apply #'type-union
-	       (if ms
-		   (make-member-type :members ms)
+	       (if (non-numbers)
+		   (make-member-type :members (non-numbers))
 		   *empty-type*)
-	       (nreverse numbers)))
+	       (numbers)))
       *empty-type*))
 
 
diff --git a/code/typedefs.lisp b/code/typedefs.lisp
index 6809683d5..49df20422 100644
--- a/code/typedefs.lisp
+++ b/code/typedefs.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/typedefs.lisp,v 1.12 2001/03/04 20:12:44 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/typedefs.lisp,v 1.13 2003/04/23 15:19:41 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -161,12 +161,12 @@
   ;; that class.  If the result is a two-type union, then return NIL.
   ;; VANILLA-UNION returns whichever argument is a supertype of the other, or
   ;; NIL.
-  (simple-union #'vanilla-union :type function)
+  (simple-union #'hierarchical-union2 :type function)
   (complex-union nil :type (or function null))
   ;;
   ;; The default intersection methods assume that if one type is a subtype of
   ;; the other, then that type is the intersection.
-  (simple-intersection #'vanilla-intersection :type function)
+  (simple-intersection #'hierarchical-intersection2 :type function)
   (complex-intersection nil :type (or function null))
   ;;
   (simple-= #'must-supply-this :type function)
@@ -389,6 +389,18 @@
 	((csubtypep type2 type1) type1)
 	(t nil)))
 
+(defun hierarchical-intersection2 (type1 type2)
+  (multiple-value-bind (subtypep1 win1) (csubtypep type1 type2)
+    (multiple-value-bind (subtypep2 win2) (csubtypep type2 type1)
+      (cond (subtypep1 type1)
+	    (subtypep2 type2)
+	    ((and win1 win2) *empty-type*)
+	    (t nil)))))
+
+(defun hierarchical-union2 (type1 type2)
+  (cond ((csubtypep type1 type2) type2)
+	((csubtypep type2 type1) type1)
+	(t nil)))
 
 ;;; TYPE-CACHE-HASH  --  Interface
 ;;;
-- 
GitLab