NJF DOLIST/MACROLET patch for vmtran (sbcl-devel 2002-01-07,

[sbcl.git] / src / code / late-type.lisp

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 0b9ae5f..5950822 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -31,9 +31,9 @@
 ;;;
 ;;; RATIO and BIGNUM are not recognized as numeric types.
 
 ;;;
 ;;; RATIO and BIGNUM are not recognized as numeric types.
 

-;;; FIXME: It seems to me that this should be set to NIL by default,
-;;; and perhaps not even optionally set to T.
-(defvar *use-implementation-types* t
+;;; FIXME: This really should go away. Alas, it doesn't seem to be so
+;;; simple to make it go away.. (See bug 123 in BUGS file.)
+(defvar *use-implementation-types* t ; actually initialized in cold init

   #!+sb-doc
   "*USE-IMPLEMENTATION-TYPES* is a semi-public flag which determines how
    restrictive we are in determining type membership. If two types are the
   #!+sb-doc
   "*USE-IMPLEMENTATION-TYPES* is a semi-public flag which determines how
    restrictive we are in determining type membership. If two types are the

@@ -41,7 +41,6 @@
    this switch is on. When it is off, we try to be as restrictive as the
    language allows, allowing us to detect more errors. Currently, this only
    affects array types.")
    this switch is on. When it is off, we try to be as restrictive as the
    language allows, allowing us to detect more errors. Currently, this only
    affects array types.")

-

 (!cold-init-forms (setq *use-implementation-types* t))
 
 ;;; These functions are used as method for types which need a complex
 (!cold-init-forms (setq *use-implementation-types* t))
 
 ;;; These functions are used as method for types which need a complex

@@ -132,10 +131,10 @@
 ;;; the description of a &KEY argument
 (defstruct (key-info #-sb-xc-host (:pure t)
                     (:copier nil))
 ;;; the description of a &KEY argument
 (defstruct (key-info #-sb-xc-host (:pure t)
                     (:copier nil))

-  ;; the key (not necessarily a keyword in ANSI)
-  (name (required-argument) :type symbol)
+  ;; the key (not necessarily a keyword in ANSI Common Lisp)
+  (name (missing-arg) :type symbol)

   ;; the type of the argument value
   ;; the type of the argument value

-  (type (required-argument) :type ctype))
+  (type (missing-arg) :type ctype))

 
 (!define-type-method (values :simple-subtypep :complex-subtypep-arg1)
                     (type1 type2)
 
 (!define-type-method (values :simple-subtypep :complex-subtypep-arg1)
                     (type1 type2)

@@ -193,18 +192,18 @@
 ;;; a flag that we can bind to cause complex function types to be
 ;;; unparsed as FUNCTION. This is useful when we want a type that we
 ;;; can pass to TYPEP.
 ;;; a flag that we can bind to cause complex function types to be
 ;;; unparsed as FUNCTION. This is useful when we want a type that we
 ;;; can pass to TYPEP.

-(defvar *unparse-function-type-simplify*)
-(!cold-init-forms (setq *unparse-function-type-simplify* nil))
+(defvar *unparse-fun-type-simplify*)
+(!cold-init-forms (setq *unparse-fun-type-simplify* nil))

 
 (!define-type-method (function :unparse) (type)
 
 (!define-type-method (function :unparse) (type)

-  (if *unparse-function-type-simplify*
+  (if *unparse-fun-type-simplify*

       'function
       (list 'function
       'function
       (list 'function

-           (if (function-type-wild-args type)
+           (if (fun-type-wild-args type)

                '*
                (unparse-args-types type))
            (type-specifier
                '*
                (unparse-args-types type))
            (type-specifier

-            (function-type-returns type)))))
+            (fun-type-returns type)))))

 
 ;;; Since all function types are equivalent to FUNCTION, they are all
 ;;; subtypes of each other.
 
 ;;; Since all function types are equivalent to FUNCTION, they are all
 ;;; subtypes of each other.

@@ -215,7 +214,7 @@
 (!define-superclasses function ((function)) !cold-init-forms)
 
 ;;; The union or intersection of two FUNCTION types is FUNCTION.
 (!define-superclasses function ((function)) !cold-init-forms)
 
 ;;; The union or intersection of two FUNCTION types is FUNCTION.

-(!define-type-method (function :simple-union) (type1 type2)
+(!define-type-method (function :simple-union2) (type1 type2)

   (declare (ignore type1 type2))
   (specifier-type 'function))
 (!define-type-method (function :simple-intersection2) (type1 type2)
   (declare (ignore type1 type2))
   (specifier-type 'function))
 (!define-type-method (function :simple-intersection2) (type1 type2)

@@ -295,10 +294,9 @@
     (result)))
 
 (!def-type-translator function (&optional (args '*) (result '*))
     (result)))
 
 (!def-type-translator function (&optional (args '*) (result '*))

-  (let ((res (make-function-type
-             :returns (values-specifier-type result))))
+  (let ((res (make-fun-type :returns (values-specifier-type result))))

     (if (eq args '*)
     (if (eq args '*)

-       (setf (function-type-wild-args res) t)
+       (setf (fun-type-wild-args res) t)

        (parse-args-types args res))
     res))
 
        (parse-args-types args res))
     res))
 

@@ -330,12 +328,12 @@
        (t
         type)))
 
        (t
         type)))
 

-;;; Return the minmum number of arguments that a function can be
+;;; Return the minimum number of arguments that a function can be

 ;;; called with, and the maximum number or NIL. If not a function
 ;;; type, return NIL, NIL.
 ;;; called with, and the maximum number or NIL. If not a function
 ;;; type, return NIL, NIL.

-(defun function-type-nargs (type)
+(defun fun-type-nargs (type)

   (declare (type ctype type))
   (declare (type ctype type))

-  (if (function-type-p type)
+  (if (fun-type-p type)

       (let ((fixed (length (args-type-required type))))
        (if (or (args-type-rest type)
                (args-type-keyp type)
       (let ((fixed (length (args-type-required type))))
        (if (or (args-type-rest type)
                (args-type-keyp type)

@@ -414,7 +412,7 @@
 ;;; This has the virtue of always keeping the VALUES type specifier
 ;;; outermost, and retains all of the information that is really
 ;;; useful for static type analysis. We want to know what is always
 ;;; This has the virtue of always keeping the VALUES type specifier
 ;;; outermost, and retains all of the information that is really
 ;;; useful for static type analysis. We want to know what is always

-;;; true of each value independently. It is worthless to know that IF
+;;; true of each value independently. It is worthless to know that if

 ;;; the first value is B0 then the second will be B1.
 ;;;
 ;;; If the VALUES count signatures differ, then we produce a result with
 ;;; the first value is B0 then the second will be B1.
 ;;;
 ;;; If the VALUES count signatures differ, then we produce a result with

@@ -466,7 +464,7 @@
 ;;; than the precise result.
 ;;;
 ;;; The return convention seems to be analogous to
 ;;; than the precise result.
 ;;;
 ;;; The return convention seems to be analogous to

-;;; TYPES-INTERSECT. -- WHN 19990910.
+;;; TYPES-EQUAL-OR-INTERSECT. -- WHN 19990910.

 (defun-cached (values-type-union :hash-function type-cache-hash
                                 :hash-bits 8
                                 :default nil
 (defun-cached (values-type-union :hash-function type-cache-hash
                                 :hash-bits 8
                                 :default nil

@@ -493,22 +491,19 @@
                       #'max
                       (specifier-type 'null)))))
 
                       #'max
                       (specifier-type 'null)))))
 

-;;; This is like TYPES-INTERSECT, except that it sort of works on
-;;; VALUES types. Note that due to the semantics of
+;;; This is like TYPES-EQUAL-OR-INTERSECT, except that it sort of
+;;; works on VALUES types. Note that due to the semantics of

 ;;; VALUES-TYPE-INTERSECTION, this might return (VALUES T T) when
 ;;; VALUES-TYPE-INTERSECTION, this might return (VALUES T T) when

-;;; there isn't really any intersection (?).
-;;;
-;;; The return convention seems to be analogous to
-;;; TYPES-INTERSECT. -- WHN 19990910.
-(defun values-types-intersect (type1 type2)
+;;; there isn't really any intersection.
+(defun values-types-equal-or-intersect (type1 type2)

   (cond ((or (eq type1 *empty-type*) (eq type2 *empty-type*))
   (cond ((or (eq type1 *empty-type*) (eq type2 *empty-type*))

-        (values 't t))
+        (values t t))

        ((or (values-type-p type1) (values-type-p type2))
         (multiple-value-bind (res win) (values-type-intersection type1 type2)
           (values (not (eq res *empty-type*))
                   win)))
        (t
        ((or (values-type-p type1) (values-type-p type2))
         (multiple-value-bind (res win) (values-type-intersection type1 type2)
           (values (not (eq res *empty-type*))
                   win)))
        (t

-        (types-intersect type1 type2))))
+        (types-equal-or-intersect type1 type2))))

 
 ;;; a SUBTYPEP-like operation that can be used on any types, including
 ;;; VALUES types
 
 ;;; a SUBTYPEP-like operation that can be used on any types, including
 ;;; VALUES types

@@ -522,7 +517,7 @@
   (cond ((eq type2 *wild-type*) (values t t))
        ((eq type1 *wild-type*)
         (values (eq type2 *universal-type*) t))
   (cond ((eq type2 *wild-type*) (values t t))
        ((eq type1 *wild-type*)
         (values (eq type2 *universal-type*) t))

-       ((not (values-types-intersect type1 type2))
+       ((not (values-types-equal-or-intersect type1 type2))

         (values nil t))
        (t
         (if (or (values-type-p type1) (values-type-p type2))
         (values nil t))
        (t
         (if (or (values-type-p type1) (values-type-p type2))

@@ -606,27 +601,47 @@
        (values (not res) t)
        (values nil nil))))
 
        (values (not res) t)
        (values nil nil))))
 

+;;; the type method dispatch case of TYPE-UNION2
+(defun %type-union2 (type1 type2)
+  ;; As in %TYPE-INTERSECTION2, it seems to be a good idea to give
+  ;; both argument orders a chance at COMPLEX-INTERSECTION2. Unlike
+  ;; %TYPE-INTERSECTION2, though, I don't have a specific case which
+  ;; demonstrates this is actually necessary. Also unlike
+  ;; %TYPE-INTERSECTION2, there seems to be no need to distinguish
+  ;; between not finding a method and having a method return NIL.
+  (flet ((1way (x y)
+          (!invoke-type-method :simple-union2 :complex-union2
+                               x y
+                               :default nil)))
+    (declare (inline 1way))
+    (or (1way type1 type2)
+       (1way type2 type1))))
+

 ;;; Find a type which includes both types. Any inexactness is
 ;;; represented by the fuzzy element types; we return a single value
 ;;; that is precise to the best of our knowledge. This result is
 ;;; Find a type which includes both types. Any inexactness is
 ;;; represented by the fuzzy element types; we return a single value
 ;;; that is precise to the best of our knowledge. This result is

-;;; simplified into the canonical form, thus is not a UNION type
-;;; unless there is no other way to represent the result.
-(defun-cached (type-union :hash-function type-cache-hash
-                         :hash-bits 8
-                         :init-wrapper !cold-init-forms)
+;;; simplified into the canonical form, thus is not a UNION-TYPE
+;;; unless we find no other way to represent the result.
+(defun-cached (type-union2 :hash-function type-cache-hash
+                          :hash-bits 8
+                          :init-wrapper !cold-init-forms)

              ((type1 eq) (type2 eq))
              ((type1 eq) (type2 eq))

+  ;; KLUDGE: This was generated from TYPE-INTERSECTION2 by Ye Olde Cut And
+  ;; Paste technique of programming. If it stays around (as opposed to
+  ;; e.g. fading away in favor of some CLOS solution) the shared logic
+  ;; should probably become shared code. -- WHN 2001-03-16

   (declare (type ctype type1 type2))
   (declare (type ctype type1 type2))

-  (if (eq type1 type2)
-      type1
-      (let ((res (!invoke-type-method :simple-union :complex-union
-                                     type1 type2
-                                     :default :vanilla)))
-       (cond ((eq res :vanilla)
-              (or (vanilla-union type1 type2)
-                  (make-union-type-or-something (list type1 type2))))
-             (res)
-             (t
-              (make-union-type-or-something (list type1 type2)))))))
+  (cond ((eq type1 type2)
+        type1)
+       ((or (union-type-p type1)
+            (union-type-p type2))
+        ;; Unions of UNION-TYPE should have the UNION-TYPE-TYPES
+        ;; values broken out and united separately. The full TYPE-UNION
+        ;; function knows how to do this, so let it handle it.
+        (type-union type1 type2))
+       (t
+        ;; the ordinary case: we dispatch to type methods
+        (%type-union2 type1 type2))))

 
 ;;; the type method dispatch case of TYPE-INTERSECTION2
 (defun %type-intersection2 (type1 type2)
 
 ;;; the type method dispatch case of TYPE-INTERSECTION2
 (defun %type-intersection2 (type1 type2)

@@ -659,7 +674,7 @@
                            (eql yx :no-type-method-found))
                       *empty-type*)
                      (t
                            (eql yx :no-type-method-found))
                       *empty-type*)
                      (t

-                      (assert (and (not xy) (not yx))) ; else handled above
+                      (aver (and (not xy) (not yx))) ; else handled above

                       nil))))))))
 
 (defun-cached (type-intersection2 :hash-function type-cache-hash
                       nil))))))))
 
 (defun-cached (type-intersection2 :hash-function type-cache-hash

@@ -674,7 +689,7 @@
        ((or (intersection-type-p type1)
             (intersection-type-p type2))
         ;; Intersections of INTERSECTION-TYPE should have the
        ((or (intersection-type-p type1)
             (intersection-type-p type2))
         ;; Intersections of INTERSECTION-TYPE should have the

-        ;; INTERSECTION-TYPE-TYPES objects broken out and intersected
+        ;; INTERSECTION-TYPE-TYPES values broken out and intersected

         ;; separately. The full TYPE-INTERSECTION function knows how
         ;; to do that, so let it handle it.
         (type-intersection type1 type2))
         ;; separately. The full TYPE-INTERSECTION function knows how
         ;; to do that, so let it handle it.
         (type-intersection type1 type2))

@@ -691,15 +706,15 @@
        ((hairy-type-p type1) type2)
        (t type1)))
 
        ((hairy-type-p type1) type2)
        (t type1)))
 

-;;; The first value is true unless the types don't intersect. The
-;;; second value is true if the first value is definitely correct. NIL
-;;; is considered to intersect with any type. If T is a subtype of
-;;; either type, then we also return T, T. This way we recognize
-;;; that hairy types might intersect with T.
+;;; a test useful for checking whether a derived type matches a
+;;; declared type

 ;;;
 ;;;

-;;; FIXME: It would be more accurate to call this TYPES-MIGHT-INTERSECT,
-;;; and rename VALUES-TYPES-INTERSECT the same way.
-(defun types-intersect (type1 type2)
+;;; The first value is true unless the types don't intersect and
+;;; aren't equal. The second value is true if the first value is
+;;; definitely correct. NIL is considered to intersect with any type.
+;;; If T is a subtype of either type, then we also return T, T. This
+;;; way we recognize that hairy types might intersect with T.
+(defun types-equal-or-intersect (type1 type2)

   (declare (type ctype type1 type2))
   (if (or (eq type1 *empty-type*) (eq type2 *empty-type*))
       (values t t)
   (declare (type ctype type1 type2))
   (if (or (eq type1 *empty-type*) (eq type2 *empty-type*))
       (values t t)

@@ -739,64 +754,118 @@
 
 ;;; shared logic for unions and intersections: Stuff TYPE into the
 ;;; vector TYPES, finding pairs of types which can be simplified by
 
 ;;; shared logic for unions and intersections: Stuff TYPE into the
 ;;; vector TYPES, finding pairs of types which can be simplified by

-;;; SIMPLIFY2 and replacing them by their simplified forms.
-(defun accumulate-compound-type (type types simplify2)
+;;; SIMPLIFY2 (TYPE-UNION2 or TYPE-INTERSECTION2) and replacing them
+;;; by their simplified forms.
+(defun accumulate1-compound-type (type types %compound-type-p simplify2)

   (declare (type ctype type))
   (declare (type ctype type))

-  (declare (type (vector t) types))
+  (declare (type (vector ctype) types))

   (declare (type function simplify2))
   (declare (type function simplify2))

+  ;; Any input object satisfying %COMPOUND-TYPE-P should've been
+  ;; broken into components before it reached us.
+  (aver (not (funcall %compound-type-p type)))

   (dotimes (i (length types) (vector-push-extend type types))
     (let ((simplified2 (funcall simplify2 type (aref types i))))
       (when simplified2
        ;; Discard the old (AREF TYPES I).
        (setf (aref types i) (vector-pop types))
   (dotimes (i (length types) (vector-push-extend type types))
     (let ((simplified2 (funcall simplify2 type (aref types i))))
       (when simplified2
        ;; Discard the old (AREF TYPES I).
        (setf (aref types i) (vector-pop types))

-       ;; Add the new SIMPLIFIED2 to TYPES, by tail recursing.
+       ;; Merge the new SIMPLIFIED2 into TYPES, by tail recursing.
+       ;; (Note that the tail recursion is indirect: we go through
+       ;; ACCUMULATE, not ACCUMULATE1, so that if SIMPLIFIED2 is
+       ;; handled properly if it satisfies %COMPOUND-TYPE-P.)

        (return (accumulate-compound-type simplified2
                                          types
        (return (accumulate-compound-type simplified2
                                          types

+                                         %compound-type-p

                                          simplify2)))))
                                          simplify2)))))

+  ;; Voila.

   (values))
 
   (values))
 

+;;; shared logic for unions and intersections: Use
+;;; ACCUMULATE1-COMPOUND-TYPE to merge TYPE into TYPES, either
+;;; all in one step or, if %COMPOUND-TYPE-P is satisfied,
+;;; component by component.
+(defun accumulate-compound-type (type types %compound-type-p simplify2)
+  (declare (type function %compound-type-p simplify2))
+  (flet ((accumulate1 (x)
+          (accumulate1-compound-type x types %compound-type-p simplify2)))
+    (declare (inline accumulate1))
+    (if (funcall %compound-type-p type)
+       (map nil #'accumulate1 (compound-type-types type))
+       (accumulate1 type)))
+  (values))
+
+;;; shared logic for unions and intersections: Return a vector of
+;;; types representing the same types as INPUT-TYPES, but with 
+;;; COMPOUND-TYPEs satisfying %COMPOUND-TYPE-P broken up into their
+;;; component types, and with any SIMPLY2 simplifications applied.
+(defun simplified-compound-types (input-types %compound-type-p simplify2)
+  (let ((simplified-types (make-array (length input-types)
+                                     :fill-pointer 0
+                                     :element-type 'ctype
+                                     ;; (This INITIAL-ELEMENT shouldn't
+                                     ;; matter, but helps avoid type
+                                     ;; warnings at compile time.)
+                                     :initial-element *empty-type*)))
+    (dolist (input-type input-types)
+      (accumulate-compound-type input-type
+                               simplified-types
+                               %compound-type-p
+                               simplify2))
+    simplified-types))
+

 ;;; shared logic for unions and intersections: Make a COMPOUND-TYPE
 ;;; shared logic for unions and intersections: Make a COMPOUND-TYPE

-;;; object whose components are the types in TYPES, or skip to
-;;; special cases when TYPES-VECTOR is short.
+;;; object whose components are the types in TYPES, or skip to special
+;;; cases when TYPES is short.

 (defun make-compound-type-or-something (constructor types enumerable identity)
   (declare (type function constructor))
 (defun make-compound-type-or-something (constructor types enumerable identity)
   (declare (type function constructor))

-  (declare (type (vector t) types))
+  (declare (type (vector ctype) types))

   (declare (type ctype identity))
   (case (length types)
     (0 identity)
   (declare (type ctype identity))
   (case (length types)
     (0 identity)

-    (1 (the ctype (aref types 0)))
-    (t (funcall constructor enumerable (coerce types 'list)))))
+    (1 (aref types 0))
+    (t (funcall constructor
+               enumerable
+               ;; FIXME: This should be just (COERCE TYPES 'LIST), but as
+               ;; of sbcl-0.6.11.17 the COERCE optimizer is really
+               ;; brain-dead, so that would generate a full call to
+               ;; SPECIFIER-TYPE at runtime, so we get into bootstrap
+               ;; problems in cold init because 'LIST is a compound
+               ;; type, so we need to MAKE-COMPOUND-TYPE-OR-SOMETHING
+               ;; before we know what 'LIST is. Once the COERCE
+               ;; optimizer is less brain-dead, we can make this
+               ;; (COERCE TYPES 'LIST) again.
+               #+sb-xc-host (coerce types 'list)
+               #-sb-xc-host (coerce-to-list types)))))

 
 (defun type-intersection (&rest input-types)
 
 (defun type-intersection (&rest input-types)

-  (let (;; components of our result, accumulated as a vector
-       (simplified-types (make-array (length input-types) :fill-pointer 0)))
-    (flet ((accumulate (type)
-            (accumulate-compound-type type
-                                      simplified-types
-                                      #'type-intersection2)))
-      (declare (inline accumulate))
-      (dolist (type input-types)
-       (if (intersection-type-p type)
-           (map nil #'accumulate (intersection-type-types type))
-           (accumulate type)))
-      ;; We want to have a canonical representation of types (or failing
-      ;; that, punt to HAIRY-TYPE). Canonical representation would have
-      ;; intersections inside unions but not vice versa, since you can
-      ;; always achieve that by the distributive rule. But we don't want
-      ;; to just apply the distributive rule, since it would be too easy
-      ;; to end up with unreasonably huge type expressions. So instead
-      ;; we punt to HAIRY-TYPE when this comes up.
-      (if (and (> (length simplified-types) 1)
-              (some #'union-type-p simplified-types))
-         (make-hairy-type
-          :specifier `(and ,@(map 'list #'type-specifier simplified-types)))
-         (make-compound-type-or-something #'%make-intersection-type
-                                          simplified-types
-                                          (some #'type-enumerable
-                                                simplified-types)
-                                          *universal-type*)))))
-
-;;; FIXME: Define TYPE-UNION similar to TYPE-INTERSECTION.
+  (let ((simplified-types (simplified-compound-types input-types
+                                                    #'intersection-type-p
+                                                    #'type-intersection2)))
+    (declare (type (vector ctype) simplified-types))
+    ;; We want to have a canonical representation of types (or failing
+    ;; that, punt to HAIRY-TYPE). Canonical representation would have
+    ;; intersections inside unions but not vice versa, since you can
+    ;; always achieve that by the distributive rule. But we don't want
+    ;; to just apply the distributive rule, since it would be too easy
+    ;; to end up with unreasonably huge type expressions. So instead
+    ;; we punt to HAIRY-TYPE when this comes up.
+    (if (and (> (length simplified-types) 1)
+            (some #'union-type-p simplified-types))
+       (make-hairy-type
+        :specifier `(and ,@(map 'list #'type-specifier simplified-types)))
+       (make-compound-type-or-something #'%make-intersection-type
+                                        simplified-types
+                                        (some #'type-enumerable
+                                              simplified-types)
+                                        *universal-type*))))
+
+(defun type-union (&rest input-types)
+  (let ((simplified-types (simplified-compound-types input-types
+                                                    #'union-type-p
+                                                    #'type-union2)))
+    (make-compound-type-or-something #'%make-union-type
+                                    simplified-types
+                                    (every #'type-enumerable simplified-types)
+                                    *empty-type*)))

 \f
 ;;;; built-in types
 
 \f
 ;;;; built-in types
 

@@ -805,7 +874,7 @@
 (defvar *wild-type*)
 (defvar *empty-type*)
 (defvar *universal-type*)
 (defvar *wild-type*)
 (defvar *empty-type*)
 (defvar *universal-type*)

-
+(defvar *universal-fun-type*)

 (!cold-init-forms
  (macrolet ((frob (name var)
              `(progn
 (!cold-init-forms
  (macrolet ((frob (name var)
              `(progn

@@ -820,36 +889,39 @@
    ;; Ts and *UNIVERSAL-TYPE*s.
    (frob * *wild-type*)
    (frob nil *empty-type*)
    ;; Ts and *UNIVERSAL-TYPE*s.
    (frob * *wild-type*)
    (frob nil *empty-type*)

-   (frob t *universal-type*)))
+   (frob t *universal-type*))
+ (setf *universal-fun-type*
+       (make-fun-type :wild-args t
+                          :returns *wild-type*)))

 
 (!define-type-method (named :simple-=) (type1 type2)
   ;; FIXME: BUG 85: This assertion failed when I added it in
   ;; sbcl-0.6.11.13. It probably shouldn't fail; but for now it's
   ;; just commented out.
 
 (!define-type-method (named :simple-=) (type1 type2)
   ;; FIXME: BUG 85: This assertion failed when I added it in
   ;; sbcl-0.6.11.13. It probably shouldn't fail; but for now it's
   ;; just commented out.

-  ;;(assert (not (eq type1 *wild-type*))) ; * isn't really a type.
+  ;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type.

   (values (eq type1 type2) t))
 
 (!define-type-method (named :simple-subtypep) (type1 type2)
   (values (eq type1 type2) t))
 
 (!define-type-method (named :simple-subtypep) (type1 type2)

-  (assert (not (eq type1 *wild-type*))) ; * isn't really a type.
+  (aver (not (eq type1 *wild-type*))) ; * isn't really a type.

   (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t))
 
 (!define-type-method (named :complex-subtypep-arg1) (type1 type2)
   (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t))
 
 (!define-type-method (named :complex-subtypep-arg1) (type1 type2)

-  (assert (not (eq type1 *wild-type*))) ; * isn't really a type.
+  (aver (not (eq type1 *wild-type*))) ; * isn't really a type.

   ;; FIXME: Why does this (old CMU CL) assertion hold? Perhaps 'cause
   ;; the HAIRY-TYPE COMPLEX-SUBTYPEP-ARG2 method takes precedence over
   ;; this COMPLEX-SUBTYPE-ARG1 method? (I miss CLOS..)
   ;; FIXME: Why does this (old CMU CL) assertion hold? Perhaps 'cause
   ;; the HAIRY-TYPE COMPLEX-SUBTYPEP-ARG2 method takes precedence over
   ;; this COMPLEX-SUBTYPE-ARG1 method? (I miss CLOS..)

-  (assert (not (hairy-type-p type2))) 
+  (aver (not (hairy-type-p type2))) 

   ;; Besides the old CMU CL assertion above, we also need to avoid
   ;; compound types, else we could get into trouble with
   ;; Besides the old CMU CL assertion above, we also need to avoid
   ;; compound types, else we could get into trouble with

-  ;;   (SUBTYPEP 'T '(OR (SATISFIES FOO) (SATISFIES BAR)))
+  ;;   (SUBTYPEP T '(OR (SATISFIES FOO) (SATISFIES BAR)))

   ;; or
   ;; or

-  ;;   (SUBTYPEP 'T '(AND (SATISFIES FOO) (SATISFIES BAR))).
-  (assert (not (compound-type-p type2))) 
+  ;;   (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR))).
+  (aver (not (compound-type-p type2))) 

   ;; Then, since TYPE2 is reasonably tractable, we're good to go.
   (values (eq type1 *empty-type*) t))
 
 (!define-type-method (named :complex-subtypep-arg2) (type1 type2)
   ;; Then, since TYPE2 is reasonably tractable, we're good to go.
   (values (eq type1 *empty-type*) t))
 
 (!define-type-method (named :complex-subtypep-arg2) (type1 type2)

-  (assert (not (eq type2 *wild-type*))) ; * isn't really a type.
+  (aver (not (eq type2 *wild-type*))) ; * isn't really a type.

   (cond ((eq type2 *universal-type*)
         (values t t))
        ((hairy-type-p type1)
   (cond ((eq type2 *universal-type*)
         (values t t))
        ((hairy-type-p type1)

@@ -864,9 +936,14 @@
 (!define-type-method (named :complex-intersection2) (type1 type2)
   ;; FIXME: This assertion failed when I added it in sbcl-0.6.11.13.
   ;; Perhaps when bug 85 is fixed it can be reenabled.
 (!define-type-method (named :complex-intersection2) (type1 type2)
   ;; FIXME: This assertion failed when I added it in sbcl-0.6.11.13.
   ;; Perhaps when bug 85 is fixed it can be reenabled.

-  ;;(assert (not (eq type2 *wild-type*))) ; * isn't really a type.
+  ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.

   (hierarchical-intersection2 type1 type2))
 
   (hierarchical-intersection2 type1 type2))
 

+(!define-type-method (named :complex-union2) (type1 type2)
+  ;; Perhaps when bug 85 is fixed this can be reenabled.
+  ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
+  (hierarchical-union2 type1 type2))
+

 (!define-type-method (named :unparse) (x)
   (named-type-name x))
 \f
 (!define-type-method (named :unparse) (x)
   (named-type-name x))
 \f

@@ -907,9 +984,6 @@
   (declare (ignore type1 type2))
   nil)
 
   (declare (ignore type1 type2))
   nil)
 

-(!define-type-method (hairy :complex-union) (type1 type2)
-  (make-union-type-or-something (list type1 type2)))
-

 (!define-type-method (hairy :simple-=) (type1 type2)
   (if (equal (hairy-type-specifier type1)
             (hairy-type-specifier type2))
 (!define-type-method (hairy :simple-=) (type1 type2)
   (if (equal (hairy-type-specifier type1)
             (hairy-type-specifier type2))

@@ -927,41 +1001,20 @@
 
 (!def-type-translator satisfies (&whole whole fun)
   (declare (ignore fun))
 
 (!def-type-translator satisfies (&whole whole fun)
   (declare (ignore fun))

-  ;; Check legality of arguments of arguments.
+  ;; Check legality of arguments.

   (destructuring-bind (satisfies predicate-name) whole
     (declare (ignore satisfies))
     (unless (symbolp predicate-name)
       (error 'simple-type-error
             :datum predicate-name
   (destructuring-bind (satisfies predicate-name) whole
     (declare (ignore satisfies))
     (unless (symbolp predicate-name)
       (error 'simple-type-error
             :datum predicate-name

-            :expected-type symbol
+            :expected-type 'symbol

             :format-control "~S is not a symbol."
             :format-arguments (list predicate-name))))
             :format-control "~S is not a symbol."
             :format-arguments (list predicate-name))))

+  ;; Create object.

   (make-hairy-type :specifier whole))
 \f
 ;;;; numeric types
 
   (make-hairy-type :specifier whole))
 \f
 ;;;; numeric types
 

-#!+negative-zero-is-not-zero
-(defun make-numeric-type (&key class format (complexp :real) low high
-                              enumerable)
-  (flet ((canonicalise-low-bound (x)
-          ;; Canonicalise a low bound of (-0.0) to 0.0.
-          (if (and (consp x) (floatp (car x)) (zerop (car x))
-                   (minusp (float-sign (car x))))
-              (float 0.0 (car x))
-              x))
-        (canonicalise-high-bound (x)
-          ;; Canonicalise a high bound of (+0.0) to -0.0.
-          (if (and (consp x) (floatp (car x)) (zerop (car x))
-                   (plusp (float-sign (car x))))
-              (float -0.0 (car x))
-              x)))
-    (%make-numeric-type :class class
-                       :format format
-                       :complexp complexp
-                       :low (canonicalise-low-bound low)
-                       :high (canonicalise-high-bound high)
-                       :enumerable enumerable)))
-

 (!define-type-class number)
 
 (!define-type-method (number :simple-=) (type1 type2)
 (!define-type-class number)
 
 (!define-type-method (number :simple-=) (type1 type2)

@@ -1017,7 +1070,7 @@
             'complex
             `(complex ,base+bounds)))
        ((nil)
             'complex
             `(complex ,base+bounds)))
        ((nil)

-        (assert (eq base+bounds 'real))
+        (aver (eq base+bounds 'real))

         'number)))))
 
 ;;; Return true if X is "less than or equal" to Y, taking open bounds
         'number)))))
 
 ;;; Return true if X is "less than or equal" to Y, taking open bounds

@@ -1187,7 +1240,7 @@
 ;;;
 ;;; ### Note: we give up early to keep from dropping lots of information on
 ;;; the floor by returning overly general types.
 ;;;
 ;;; ### Note: we give up early to keep from dropping lots of information on
 ;;; the floor by returning overly general types.

-(!define-type-method (number :simple-union) (type1 type2)
+(!define-type-method (number :simple-union2) (type1 type2)

   (declare (type numeric-type type1 type2))
   (cond ((csubtypep type1 type2) type2)
        ((csubtypep type2 type1) type1)
   (declare (type numeric-type type1 type2))
   (cond ((csubtypep type1 type2) type2)
        ((csubtypep type2 type1) type1)

@@ -1220,17 +1273,38 @@
   (setf (info :type :builtin 'number)
        (make-numeric-type :complexp nil)))
 
   (setf (info :type :builtin 'number)
        (make-numeric-type :complexp nil)))
 

-(!def-type-translator complex (&optional (spec '*))
-  (if (eq spec '*)
+(!def-type-translator complex (&optional (typespec '*))
+  (if (eq typespec '*)

       (make-numeric-type :complexp :complex)
       (make-numeric-type :complexp :complex)

-      (let ((type (specifier-type spec)))
-       (unless (numeric-type-p type)
-         (error "Component type for Complex is not numeric: ~S." spec))
-       (when (eq (numeric-type-complexp type) :complex)
-         (error "Component type for Complex is complex: ~S." spec))
-       (let ((res (copy-numeric-type type)))
-         (setf (numeric-type-complexp res) :complex)
-         res))))
+      (labels ((not-numeric ()
+                 ;; FIXME: should probably be TYPE-ERROR
+                (error "The component type for COMPLEX is not numeric: ~S"
+                       typespec))
+              (complex1 (component-type)
+                (unless (numeric-type-p component-type)
+                  ;; FIXME: As per the FIXME below, ANSI says we're
+                  ;; supposed to handle any subtype of REAL, not only
+                  ;; those which can be represented as NUMERIC-TYPE.
+                  (not-numeric))
+                (when (eq (numeric-type-complexp component-type) :complex)
+                  (error "The component type for COMPLEX is complex: ~S"
+                         typespec))
+                (modified-numeric-type component-type :complexp :complex)))
+       (let ((type (specifier-type typespec)))
+         (typecase type
+           ;; This is all that CMU CL handled.
+           (numeric-type (complex1 type))
+           ;; We need to handle UNION-TYPEs in order to deal with
+           ;; REAL and FLOAT being represented as UNION-TYPEs of more
+           ;; primitive types.
+           (union-type (apply #'type-union
+                              (mapcar #'complex1
+                                      (union-type-types type))))
+           ;; FIXME: ANSI just says that TYPESPEC is a subtype of type
+           ;; REAL, not necessarily a NUMERIC-TYPE. E.g. TYPESPEC could
+           ;; legally be (AND REAL (SATISFIES ODDP))! But like the old
+           ;; CMU CL code, we're still not nearly that general.
+           (t (not-numeric)))))))

 
 ;;; If X is *, return NIL, otherwise return the bound, which must be a
 ;;; member of TYPE or a one-element list of a member of TYPE.
 
 ;;; If X is *, return NIL, otherwise return the bound, which must be a
 ;;; member of TYPE or a one-element list of a member of TYPE.

@@ -1271,8 +1345,66 @@
        (make-numeric-type :class ',class :format ',format :low lb :high hb))))
 
 (!def-bounded-type rational rational nil)
        (make-numeric-type :class ',class :format ',format :low lb :high hb))))
 
 (!def-bounded-type rational rational nil)

-(!def-bounded-type float float nil)
-(!def-bounded-type real nil nil)
+
+;;; Unlike CMU CL, we represent the types FLOAT and REAL as
+;;; UNION-TYPEs of more primitive types, in order to make
+;;; type representation more unique, avoiding problems in the
+;;; simplification of things like
+;;;   (subtypep '(or (single-float -1.0 1.0) (single-float 0.1))
+;;;             '(or (real -1 7) (single-float 0.1) (single-float -1.0 1.0)))
+;;; When we allowed REAL to remain as a separate NUMERIC-TYPE,
+;;; it was too easy for the first argument to be simplified to
+;;; '(SINGLE-FLOAT -1.0), and for the second argument to be simplified
+;;; to '(OR (REAL -1 7) (SINGLE-FLOAT 0.1)) and then for the
+;;; SUBTYPEP to fail (returning NIL,T instead of T,T) because
+;;; the first argument can't be seen to be a subtype of any of the
+;;; terms in the second argument.
+;;;
+;;; The old CMU CL way was:
+;;;   (!def-bounded-type float float nil)
+;;;   (!def-bounded-type real nil nil)
+;;;
+;;; FIXME: If this new way works for a while with no weird new
+;;; problems, we can go back and rip out support for separate FLOAT
+;;; and REAL flavors of NUMERIC-TYPE. The new way was added in
+;;; sbcl-0.6.11.22, 2001-03-21.
+;;;
+;;; FIXME: It's probably necessary to do something to fix the
+;;; analogous problem with INTEGER and RATIONAL types. Perhaps
+;;; bounded RATIONAL types should be represented as (OR RATIO INTEGER).
+(defun coerce-bound (bound type inner-coerce-bound-fun)
+  (declare (type function inner-coerce-bound-fun))
+  (cond ((eql bound '*)
+        bound)
+       ((consp bound)
+        (destructuring-bind (inner-bound) bound
+          (list (funcall inner-coerce-bound-fun inner-bound type))))
+       (t
+        (funcall inner-coerce-bound-fun bound type))))
+(defun inner-coerce-real-bound (bound type)
+  (ecase type
+    (rational (rationalize bound))
+    (float (if (floatp bound)
+              bound
+              ;; Coerce to the widest float format available, to
+              ;; avoid unnecessary loss of precision:
+              (coerce bound 'long-float)))))
+(defun coerced-real-bound (bound type)
+  (coerce-bound bound type #'inner-coerce-real-bound))
+(defun coerced-float-bound (bound type)
+  (coerce-bound bound type #'coerce))
+(!def-type-translator real (&optional (low '*) (high '*))
+  (specifier-type `(or (float ,(coerced-real-bound  low 'float)
+                             ,(coerced-real-bound high 'float))
+                      (rational ,(coerced-real-bound  low 'rational)
+                                ,(coerced-real-bound high 'rational)))))
+(!def-type-translator float (&optional (low '*) (high '*))
+  (specifier-type 
+   `(or (single-float ,(coerced-float-bound  low 'single-float)
+                     ,(coerced-float-bound high 'single-float))
+       (double-float ,(coerced-float-bound  low 'double-float)
+                     ,(coerced-float-bound high 'double-float))
+       #!+long-float ,(error "stub: no long float support yet"))))

 
 (defmacro !define-float-format (f)
   `(!def-bounded-type ,f float ,f))
 
 (defmacro !define-float-format (f)
   `(!def-bounded-type ,f float ,f))

@@ -1358,7 +1490,7 @@
       nil))
 
 ;;; Handle the case of type intersection on two numeric types. We use
       nil))
 
 ;;; Handle the case of type intersection on two numeric types. We use

-;;; TYPES-INTERSECT to throw out the case of types with no
+;;; TYPES-EQUAL-OR-INTERSECT to throw out the case of types with no

 ;;; intersection. If an attribute in TYPE1 is unspecified, then we use
 ;;; TYPE2's attribute, which must be at least as restrictive. If the
 ;;; types intersect, then the only attributes that can be specified
 ;;; intersection. If an attribute in TYPE1 is unspecified, then we use
 ;;; TYPE2's attribute, which must be at least as restrictive. If the
 ;;; types intersect, then the only attributes that can be specified

@@ -1670,7 +1802,7 @@
 ;;; subtype of the MEMBER type.
 (!define-type-method (member :complex-subtypep-arg2) (type1 type2)
   (cond ((not (type-enumerable type1)) (values nil t))
 ;;; subtype of the MEMBER type.
 (!define-type-method (member :complex-subtypep-arg2) (type1 type2)
   (cond ((not (type-enumerable type1)) (values nil t))

-       ((types-intersect type1 type2) (values nil nil))
+       ((types-equal-or-intersect type1 type2) (values nil nil))

        (t (values nil t))))
 
 (!define-type-method (member :simple-intersection2) (type1 type2)
        (t (values nil t))))
 
 (!define-type-method (member :simple-intersection2) (type1 type2)

@@ -1698,10 +1830,10 @@
              (t
               (make-member-type :members (members))))))))
 
              (t
               (make-member-type :members (members))))))))
 

-;;; We don't need a :COMPLEX-UNION, since the only interesting case is
+;;; We don't need a :COMPLEX-UNION2, since the only interesting case is

 ;;; a union type, and the member/union interaction is handled by the
 ;;; union type method.
 ;;; a union type, and the member/union interaction is handled by the
 ;;; union type method.

-(!define-type-method (member :simple-union) (type1 type2)
+(!define-type-method (member :simple-union2) (type1 type2)

   (let ((mem1 (member-type-members type1))
        (mem2 (member-type-members type2)))
     (cond ((subsetp mem1 mem2) type2)
   (let ((mem1 (member-type-members type1))
        (mem2 (member-type-members type2)))
     (cond ((subsetp mem1 mem2) type2)

@@ -1738,7 +1870,7 @@
 ;;;;    ;; reasonable definition
 ;;;;    (DEFTYPE KEYWORD () '(AND SYMBOL (SATISFIES KEYWORDP)))
 ;;;;    ;; reasonable behavior
 ;;;;    ;; reasonable definition
 ;;;;    (DEFTYPE KEYWORD () '(AND SYMBOL (SATISFIES KEYWORDP)))
 ;;;;    ;; reasonable behavior

-;;;;    (ASSERT (SUBTYPEP 'KEYWORD 'SYMBOL))
+;;;;    (AVER (SUBTYPEP 'KEYWORD 'SYMBOL))

 ;;;; Without understanding a little about the semantics of AND, we'd
 ;;;; get (SUBTYPEP 'KEYWORD 'SYMBOL)=>NIL,NIL and, for entirely
 ;;;; parallel reasons, (SUBTYPEP 'RATIO 'NUMBER)=>NIL,NIL. That's
 ;;;; Without understanding a little about the semantics of AND, we'd
 ;;;; get (SUBTYPEP 'KEYWORD 'SYMBOL)=>NIL,NIL and, for entirely
 ;;;; parallel reasons, (SUBTYPEP 'RATIO 'NUMBER)=>NIL,NIL. That's

@@ -1781,25 +1913,21 @@
   (type=-set (intersection-type-types type1)
             (intersection-type-types type2)))
 
   (type=-set (intersection-type-types type1)
             (intersection-type-types type2)))
 

-(!define-type-method (intersection :simple-subtypep) (type1 type2)
-  (let ((certain? t))
-    (dolist (t1 (intersection-type-types type1) (values nil certain?))
-      (multiple-value-bind (subtypep validp)
-         (intersection-complex-subtypep-arg2 t1 type2)
-       (cond ((not validp)
-              (setf certain? nil))
-             (subtypep
-              (return (values t t))))))))
-
-(!define-type-method (intersection :complex-subtypep-arg1) (type1 type2)
+(defun %intersection-complex-subtypep-arg1 (type1 type2)

   (any/type (swapped-args-fun #'csubtypep)
            type2
            (intersection-type-types type1)))
 
   (any/type (swapped-args-fun #'csubtypep)
            type2
            (intersection-type-types type1)))
 

-(defun intersection-complex-subtypep-arg2 (type1 type2)
-  (every/type #'csubtypep type1 (intersection-type-types type2)))
+(!define-type-method (intersection :simple-subtypep) (type1 type2)
+  (every/type #'%intersection-complex-subtypep-arg1
+             type1
+             (intersection-type-types type2)))
+
+(!define-type-method (intersection :complex-subtypep-arg1) (type1 type2)
+  (%intersection-complex-subtypep-arg1 type1 type2))
+

 (!define-type-method (intersection :complex-subtypep-arg2) (type1 type2)
 (!define-type-method (intersection :complex-subtypep-arg2) (type1 type2)

-  (intersection-complex-subtypep-arg2 type1 type2))
+  (every/type #'csubtypep type1 (intersection-type-types type2)))

 
 (!def-type-translator and (&whole whole &rest type-specifiers)
   (apply #'type-intersection
 
 (!def-type-translator and (&whole whole &rest type-specifiers)
   (apply #'type-intersection

@@ -1808,18 +1936,6 @@
 \f
 ;;;; union types
 
 \f
 ;;;; union types
 

-;;; Make a union type from the specifier types, setting ENUMERABLE in
-;;; the result if all are enumerable; or take the easy way out if we
-;;; recognize a special case which can be represented more simply.
-(defun make-union-type-or-something (types)
-  (declare (list types))
-  (cond ((null types)
-        *empty-type*)
-       ((null (cdr types))
-        (first types))
-       (t
-        (%make-union-type (every #'type-enumerable types) types))))
-

 (!define-type-class union)
 
 ;;; The LIST type has a special name. Other union types just get
 (!define-type-class union)
 
 ;;; The LIST type has a special name. Other union types just get

@@ -1837,23 +1953,10 @@
 
 ;;; Similarly, a union type is a subtype of another if every element
 ;;; of TYPE1 is a subtype of some element of TYPE2.
 
 ;;; Similarly, a union type is a subtype of another if every element
 ;;; of TYPE1 is a subtype of some element of TYPE2.

-;;;
-;;; KLUDGE: This definition seems redundant, here in UNION-TYPE and
-;;; similarly in INTERSECTION-TYPE, with the logic in the
-;;; corresponding :COMPLEX-SUBTYPEP-ARG1 and :COMPLEX-SUBTYPEP-ARG2
-;;; methods. Ideally there's probably some way to make the
-;;; :SIMPLE-SUBTYPEP method default to the :COMPLEX-SUBTYPEP-FOO
-;;; methods in such a way that this definition could go away, but I
-;;; don't grok the system well enough to tell whether it's simple to
-;;; arrange this. -- WHN 2000-02-03

 (!define-type-method (union :simple-subtypep) (type1 type2)
 (!define-type-method (union :simple-subtypep) (type1 type2)

-  (dolist (t1 (union-type-types type1) (values t t))
-    (multiple-value-bind (subtypep validp)
-       (union-complex-subtypep-arg2 t1 type2)
-      (cond ((not validp)
-            (return (values nil nil)))
-           ((not subtypep)
-            (return (values nil t)))))))
+  (every/type (swapped-args-fun #'union-complex-subtypep-arg2)
+             type2
+             (union-type-types type1)))

 
 (defun union-complex-subtypep-arg1 (type1 type2)
   (every/type (swapped-args-fun #'csubtypep)
 
 (defun union-complex-subtypep-arg1 (type1 type2)
   (every/type (swapped-args-fun #'csubtypep)

@@ -1867,32 +1970,6 @@
 (!define-type-method (union :complex-subtypep-arg2) (type1 type2)
   (union-complex-subtypep-arg2 type1 type2))
 
 (!define-type-method (union :complex-subtypep-arg2) (type1 type2)
   (union-complex-subtypep-arg2 type1 type2))
 

-(!define-type-method (union :complex-union) (type1 type2)
-  (let ((class1 (type-class-info type1)))
-    (collect ((res))
-      (let ((this-type type1))
-       (dolist (type (union-type-types type2)
-                     (if (res)
-                         (make-union-type-or-something (cons this-type (res)))
-                         this-type))
-         (cond ((eq (type-class-info type) class1)
-                (let ((union (funcall (type-class-simple-union class1)
-                                      this-type type)))
-                  (if union
-                      (setq this-type union)
-                      (res type))))
-               ((csubtypep type this-type))
-               ((csubtypep type1 type) (return type2))
-               (t
-                (res type))))))))
-
-;;; For the union of union types, we let the :COMPLEX-UNION method do
-;;; the work.
-(!define-type-method (union :simple-union) (type1 type2)
-  (let ((res type1))
-    (dolist (t2 (union-type-types type2) res)
-      (setq res (type-union res t2)))))
-

 (!define-type-method (union :simple-intersection2 :complex-intersection2)
                     (type1 type2)
   ;; The CSUBTYPEP clauses here let us simplify e.g.
 (!define-type-method (union :simple-intersection2 :complex-intersection2)
                     (type1 type2)
   ;; The CSUBTYPEP clauses here let us simplify e.g.

@@ -1912,19 +1989,32 @@
        ((union-complex-subtypep-arg1 type2 type1)
         type2)
        (t 
        ((union-complex-subtypep-arg1 type2 type1)
         type2)
        (t 

-        (let (;; a component of TYPE2 whose intersection with TYPE1
-              ;; is nonempty
-              (nontriv-t2 nil))
-          (dolist (t2 (union-type-types type2) (or nontriv-t2 *empty-type*))
-            (unless (eq *empty-type* (type-intersection type1 t2))
-              (if nontriv-t2 ; if this is second nonempty intersection
-                  (return nil) ; too many: can't find nice result
-                  (setf nontriv-t2 t2))))))))
+        ;; KLUDGE: This code accumulates a sequence of TYPE-UNION2
+        ;; operations in a particular order, and gives up if any of
+        ;; the sub-unions turn out not to be simple. In other cases
+        ;; ca. sbcl-0.6.11.15, that approach to taking a union was a
+        ;; bad idea, since it can overlook simplifications which
+        ;; might occur if the terms were accumulated in a different
+        ;; order. It's possible that that will be a problem here too.
+        ;; However, I can't think of a good example to demonstrate
+        ;; it, and without an example to demonstrate it I can't write
+        ;; test cases, and without test cases I don't want to
+        ;; complicate the code to address what's still a hypothetical
+        ;; problem. So I punted. -- WHN 2001-03-20
+        (let ((accumulator *empty-type*))
+          (dolist (t2 (union-type-types type2) accumulator)
+            (setf accumulator
+                  (type-union2 accumulator
+                               (type-intersection type1 t2)))
+            ;; When our result isn't simple any more (because
+            ;; TYPE-UNION2 was unable to give us a simple result)
+            (unless accumulator
+              (return nil)))))))

 
 (!def-type-translator or (&rest type-specifiers)
 
 (!def-type-translator or (&rest type-specifiers)

-  (reduce #'type-union
-         (mapcar #'specifier-type type-specifiers)
-         :initial-value *empty-type*))
+  (apply #'type-union
+        (mapcar #'specifier-type
+                type-specifiers)))

 \f
 ;;;; CONS types
 
 \f
 ;;;; CONS types
 

@@ -1959,7 +2049,7 @@
  
 ;;; Give up if a precise type is not possible, to avoid returning
 ;;; overly general types.
  
 ;;; Give up if a precise type is not possible, to avoid returning
 ;;; overly general types.

-(!define-type-method (cons :simple-union) (type1 type2)
+(!define-type-method (cons :simple-union2) (type1 type2)

   (declare (type cons-type type1 type2))
   (let ((car-type1 (cons-type-car-type type1))
        (car-type2 (cons-type-car-type type2))
   (declare (type cons-type type1 type2))
   (let ((car-type1 (cons-type-car-type type1))
        (car-type2 (cons-type-car-type type2))

@@ -2017,9 +2107,8 @@
              (multiple-value-bind (val win) (csubtypep x-type y-type)
                (unless win (return-from type-difference nil))
                (when val (return))
              (multiple-value-bind (val win) (csubtypep x-type y-type)
                (unless win (return-from type-difference nil))
                (when val (return))

-               (when (types-intersect x-type y-type)
+               (when (types-equal-or-intersect x-type y-type)

                  (return-from type-difference nil))))))
                  (return-from type-difference nil))))))

-

       (let ((y-mem (find-if #'member-type-p y-types)))
        (when y-mem
          (let ((members (member-type-members y-mem)))
       (let ((y-mem (find-if #'member-type-p y-types)))
        (when y-mem
          (let ((members (member-type-members y-mem)))

@@ -2029,11 +2118,7 @@
                  (multiple-value-bind (val win) (ctypep member x-type)
                    (when (or (not win) val)
                      (return-from type-difference nil)))))))))
                  (multiple-value-bind (val win) (ctypep member x-type)
                    (when (or (not win) val)
                      (return-from type-difference nil)))))))))

-
-      (cond ((null (res)) *empty-type*)
-           ((null (rest (res))) (first (res)))
-           (t
-            (make-union-type-or-something (res)))))))
+      (apply #'type-union (res)))))

 \f
 (!def-type-translator array (&optional (element-type '*)
                                       (dimensions '*))
 \f
 (!def-type-translator array (&optional (element-type '*)
                                       (dimensions '*))

@@ -2048,6 +2133,70 @@
                    :element-type (specifier-type element-type)
                    :complexp nil)))
 \f
                    :element-type (specifier-type element-type)
                    :complexp nil)))
 \f

-(!defun-from-collected-cold-init-forms !late-type-cold-init)
+;;;; utilities shared between cross-compiler and target system
+
+;;; Does the type derived from compilation of an actual function
+;;; definition satisfy declarations of a function's type?
+(defun defined-ftype-matches-declared-ftype-p (defined-ftype declared-ftype)
+  (declare (type ctype defined-ftype declared-ftype))
+  (flet ((is-built-in-class-function-p (ctype)
+          (and (built-in-class-p ctype)
+               (eq (built-in-class-%name ctype) 'function))))
+    (cond (;; DECLARED-FTYPE could certainly be #<BUILT-IN-CLASS FUNCTION>;
+          ;; that's what happens when we (DECLAIM (FTYPE FUNCTION FOO)).
+          (is-built-in-class-function-p declared-ftype)
+          ;; In that case, any definition satisfies the declaration.
+          t)
+         (;; It's not clear whether or how DEFINED-FTYPE might be
+          ;; #<BUILT-IN-CLASS FUNCTION>, but it's not obviously
+          ;; invalid, so let's handle that case too, just in case.
+          (is-built-in-class-function-p defined-ftype)
+          ;; No matter what DECLARED-FTYPE might be, we can't prove
+          ;; that an object of type FUNCTION doesn't satisfy it, so
+          ;; we return success no matter what.
+          t)
+         (;; Otherwise both of them must be FUN-TYPE objects.
+          t
+          ;; FIXME: For now we only check compatibility of the return
+          ;; type, not argument types, and we don't even check the
+          ;; return type very precisely (as per bug 94a). It would be
+          ;; good to do a better job. Perhaps to check the
+          ;; compatibility of the arguments, we should (1) redo
+          ;; VALUES-TYPES-EQUAL-OR-INTERSECT as
+          ;; ARGS-TYPES-EQUAL-OR-INTERSECT, and then (2) apply it to
+          ;; the ARGS-TYPE slices of the FUN-TYPEs. (ARGS-TYPE
+          ;; is a base class both of VALUES-TYPE and of FUN-TYPE.)
+          (values-types-equal-or-intersect
+           (fun-type-returns defined-ftype)
+           (fun-type-returns declared-ftype))))))
+          
+;;; This messy case of CTYPE for NUMBER is shared between the
+;;; cross-compiler and the target system.
+(defun ctype-of-number (x)
+  (let ((num (if (complexp x) (realpart x) x)))
+    (multiple-value-bind (complexp low high)
+       (if (complexp x)
+           (let ((imag (imagpart x)))
+             (values :complex (min num imag) (max num imag)))
+           (values :real num num))
+      (make-numeric-type :class (etypecase num
+                                 (integer 'integer)
+                                 (rational 'rational)
+                                 (float 'float))
+                        :format (and (floatp num) (float-format-name num))
+                        :complexp complexp
+                        :low low
+                        :high high))))
+\f
+(locally
+  ;; Why SAFETY 0? To suppress the is-it-the-right-structure-type
+  ;; checking for declarations in structure accessors. Otherwise we
+  ;; can get caught in a chicken-and-egg bootstrapping problem, whose
+  ;; symptom on x86 OpenBSD sbcl-0.pre7.37.flaky5.22 is an illegal
+  ;; instruction trap. I haven't tracked it down, but I'm guessing it
+  ;; has to do with setting LAYOUTs when the LAYOUT hasn't been set
+  ;; yet. -- WHN
+  (declare (optimize (safety 0)))
+  (!defun-from-collected-cold-init-forms !late-type-cold-init))

 
 (/show0 "late-type.lisp end of file")
 
 (/show0 "late-type.lisp end of file")