X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=ac0ce019b20f8193caf7608399a9db2285b50308;hb=15d6e7c9a2c3234f95dfe278046fa2fee1b0c007;hp=ff45e57e9324a541e764129b70bc05f9e57d53a5;hpb=b20abacbe79a0b0da4f17389c06ec030a237da14;p=sbcl.git

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index ff45e57..ac0ce01 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -307,6 +307,10 @@
     ((csubtypep type1 (specifier-type 'function)) nil)
     (t :call-other-method)))
 (!define-type-method (function :complex-union2) (type1 type2)
+  (declare (ignore type2))
+  ;; TYPE2 is a FUNCTION type.  If TYPE1 is a classoid type naming
+  ;; FUNCTION, then it is the union of the two; otherwise, there is no
+  ;; special union.
   (cond
     ((type= type1 (specifier-type 'function)) type1)
     (t nil)))
@@ -1031,11 +1035,6 @@
 
 (!define-type-class named)
 
-(defvar *wild-type*)
-(defvar *empty-type*)
-(defvar *universal-type*)
-(defvar *universal-fun-type*)
-
 (!cold-init-forms
  (macrolet ((frob (name var)
 	      `(progn
@@ -1466,9 +1465,8 @@
 	(:real
 	 base+bounds)
 	(:complex
-	 (if (eq base+bounds 'real)
-	     'complex
-	     `(complex ,base+bounds)))
+	 (aver (neq base+bounds 'real))
+	 `(complex ,base+bounds))
 	((nil)
 	 (aver (eq base+bounds 'real))
 	 'number)))))
@@ -1704,68 +1702,40 @@
 
 (!def-type-translator complex (&optional (typespec '*))
   (if (eq typespec '*)
-      (make-numeric-type :complexp :complex)
+      (specifier-type '(complex real))
       (labels ((not-numeric ()
 		 (error "The component type for COMPLEX is not numeric: ~S"
 			typespec))
 	       (not-real ()
-	         (error "The component type for COMPLEX is not real: ~S"
+	         (error "The component type for COMPLEX is not a subtype of REAL: ~S"
 			typespec))
 	       (complex1 (component-type)
 	         (unless (numeric-type-p component-type)
 		   (not-numeric))
 		 (when (eq (numeric-type-complexp component-type) :complex)
 		   (not-real))
-		 (modified-numeric-type component-type :complexp :complex))
-	       (complex-union (component)
-		 (unless (numberp component)
-		   (not-numeric))
-		 ;; KLUDGE: This TYPECASE more or less does
-		 ;; (UPGRADED-COMPLEX-PART-TYPE (TYPE-OF COMPONENT)),
-		 ;; (plus a small hack to treat (EQL COMPONENT 0) specially)
-		 ;; but uses logic cut and pasted from the DEFUN of
-		 ;; UPGRADED-COMPLEX-PART-TYPE. That's fragile, because
-		 ;; changing the definition of UPGRADED-COMPLEX-PART-TYPE
-		 ;; would tend to break the code here. Unfortunately,
-		 ;; though, reusing UPGRADED-COMPLEX-PART-TYPE here
-		 ;; would cause another kind of fragility, because
-		 ;; ANSI's definition of TYPE-OF is so weak that e.g.
-		 ;; (UPGRADED-COMPLEX-PART-TYPE (TYPE-OF 1/2)) could
-		 ;; end up being (UPGRADED-COMPLEX-PART-TYPE 'REAL)
-		 ;; instead of (UPGRADED-COMPLEX-PART-TYPE 'RATIONAL).
-		 ;; So using TYPE-OF would mean that ANSI-conforming
-		 ;; maintenance changes in TYPE-OF could break the code here.
-		 ;; It's not clear how best to fix this. -- WHN 2002-01-21,
-		 ;; trying to summarize CSR's concerns in his patch
-		 (typecase component
-		   (complex (error "The component type for COMPLEX (EQL X) ~
-                                    is complex: ~S"
-				   component))
-		   ((eql 0) (specifier-type nil)) ; as required by ANSI
-		   (single-float (specifier-type '(complex single-float)))
-		   (double-float (specifier-type '(complex double-float)))
-		   #!+long-float
-		   (long-float (specifier-type '(complex long-float)))
-		   (rational (specifier-type '(complex rational)))
-		   (t (specifier-type '(complex real))))))
+		 (if (csubtypep component-type (specifier-type '(eql 0)))
+		     *empty-type*
+		     (modified-numeric-type component-type
+					    :complexp :complex))))
 	(let ((ctype (specifier-type typespec)))
-	  (typecase ctype
-	    (numeric-type (complex1 ctype))
-	    (union-type (apply #'type-union
-			       ;; FIXME: This code could suffer from
-			       ;; (admittedly very obscure) cases of
-			       ;; bug 145 e.g. when TYPE is
-			       ;;   (OR (AND INTEGER (SATISFIES ODDP))
-			       ;;       (AND FLOAT (SATISFIES FOO))
-			       ;; and not even report the problem very well.
-			       (mapcar #'complex1
-				       (union-type-types ctype))))
-	    ;; MEMBER-TYPE is almost the same as UNION-TYPE, but
-	    ;; there's a gotcha: (COMPLEX (EQL 0)) is, according to
-	    ;; ANSI, equal to type NIL, the empty set.
-	    (member-type (apply #'type-union
-				(mapcar #'complex-union
-					(member-type-members ctype))))
+	  (cond
+	    ((eq ctype *empty-type*) *empty-type*)
+	    ((eq ctype *universal-type*) (not-real))
+	    ((typep ctype 'numeric-type) (complex1 ctype))
+	    ((typep ctype 'union-type)
+	     (apply #'type-union
+		    ;; FIXME: This code could suffer from (admittedly
+		    ;; very obscure) cases of bug 145 e.g. when TYPE
+		    ;; is
+		    ;;   (OR (AND INTEGER (SATISFIES ODDP))
+		    ;;       (AND FLOAT (SATISFIES FOO))
+		    ;; and not even report the problem very well.
+		    (mapcar #'complex1 (union-type-types ctype))))
+	    ((typep ctype 'member-type)
+	     (apply #'type-union
+		    (mapcar (lambda (x) (complex1 (ctype-of x)))
+			    (member-type-members ctype))))
 	    (t
 	     (multiple-value-bind (subtypep certainly)
 		 (csubtypep ctype (specifier-type 'real))
@@ -2414,7 +2384,7 @@
 	    (float (if (zerop m)
 		       (push m ms)
 		       (push (ctype-of m) numbers)))
-	    (number (push (ctype-of m) numbers))
+	    (real (push (ctype-of m) numbers))
 	    (t (push m ms))))
 	(apply #'type-union
 	       (if ms
@@ -2591,6 +2561,7 @@
     ((type= type (specifier-type 'bignum)) 'bignum)
     ((type= type (specifier-type 'simple-string)) 'simple-string)
     ((type= type (specifier-type 'string)) 'string)
+    ((type= type (specifier-type 'complex)) 'complex)
     (t `(or ,@(mapcar #'type-specifier (union-type-types type))))))
 
 ;;; Two union types are equal if they are each subtypes of each