0.pre7.141:

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

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index ecf460a..eec991e 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.

@@ -230,12 +229,12 @@
 (!define-type-class constant :inherits values)
 
 (!define-type-method (constant :unparse) (type)
 (!define-type-class constant :inherits values)
 
 (!define-type-method (constant :unparse) (type)

-  `(constant-argument ,(type-specifier (constant-type-type type))))
+  `(constant-arg ,(type-specifier (constant-type-type type))))

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

-(!def-type-translator constant-argument (type)
+(!def-type-translator constant-arg (type)

   (make-constant-type :type (specifier-type type)))
 
 ;;; Given a LAMBDA-LIST-like values type specification and an ARGS-TYPE
   (make-constant-type :type (specifier-type type)))
 
 ;;; Given a LAMBDA-LIST-like values type specification and an ARGS-TYPE

@@ -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))
 

@@ -333,9 +331,9 @@
 ;;; 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.
 ;;; 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.

-(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)

@@ -383,12 +381,12 @@
 (defun fixed-values-op (types1 types2 rest2 operation)
   (declare (list types1 types2) (type ctype rest2) (type function operation))
   (let ((exact t))
 (defun fixed-values-op (types1 types2 rest2 operation)
   (declare (list types1 types2) (type ctype rest2) (type function operation))
   (let ((exact t))

-    (values (mapcar #'(lambda (t1 t2)
-                       (multiple-value-bind (res win)
-                           (funcall operation t1 t2)
-                         (unless win
-                           (setq exact nil))
-                         res))
+    (values (mapcar (lambda (t1 t2)
+                     (multiple-value-bind (res win)
+                         (funcall operation t1 t2)
+                       (unless win
+                         (setq exact nil))
+                       res))

                    types1
                    (append types2
                            (make-list (- (length types1) (length types2))
                    types1
                    (append types2
                            (make-list (- (length types1) (length types2))

@@ -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))

@@ -615,17 +610,9 @@
   ;; %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)
   ;; %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)

-          (let ((result (!invoke-type-method :simple-union2 :complex-union2
-                                             x y
-                                             :default nil)))
-            ;; UNION2 type methods are supposed to return results
-            ;; which are better than just brute-forcibly smashing the
-            ;; terms together into UNION-TYPEs. But they're derived
-            ;; from old CMU CL UNION type methods which played by
-            ;; somewhat different rules. Here we check to make sure
-            ;; we don't get ambushed by diehard old-style code.
-            (assert (not (union-type-p result)))
-            result)))
+          (!invoke-type-method :simple-union2 :complex-union2
+                               x y
+                               :default nil)))

     (declare (inline 1way))
     (or (1way type1 type2)
        (1way type2 type1))))
     (declare (inline 1way))
     (or (1way type1 type2)
        (1way type2 type1))))

@@ -675,20 +662,9 @@
   ;;
   ;; (Why yes, CLOS probably *would* be nicer..)
   (flet ((1way (x y)
   ;;
   ;; (Why yes, CLOS probably *would* be nicer..)
   (flet ((1way (x y)

-          (let ((result
-                 (!invoke-type-method :simple-intersection2
-                                      :complex-intersection2
-                                      x y
-                                      :default :no-type-method-found)))
-            ;; INTERSECTION2 type methods are supposed to return
-            ;; results which are better than just brute-forcibly
-            ;; smashing the terms together into INTERSECTION-TYPEs.
-            ;; But they're derived from old CMU CL INTERSECTION type
-            ;; methods which played by somewhat different rules. Here
-            ;; we check to make sure we don't get ambushed by diehard
-            ;; old-style code.
-            (assert (not (intersection-type-p result)))
-            result)))
+          (!invoke-type-method :simple-intersection2 :complex-intersection2
+                               x y
+                               :default :no-type-method-found)))

     (declare (inline 1way))
     (let ((xy (1way type1 type2)))
       (or (and (not (eql xy :no-type-method-found)) xy)
     (declare (inline 1way))
     (let ((xy (1way type1 type2)))
       (or (and (not (eql xy :no-type-method-found)) xy)

@@ -698,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

@@ -730,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)

@@ -778,20 +754,43 @@
 
 ;;; 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 (vector ctype) types))
   (declare (type function simplify2))
   (declare (type ctype type))
   (declare (type (vector ctype) types))
   (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))
+
+;;; 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
   (values))
 
 ;;; shared logic for unions and intersections: Return a vector of

@@ -806,13 +805,11 @@
                                      ;; matter, but helps avoid type
                                      ;; warnings at compile time.)
                                      :initial-element *empty-type*)))
                                      ;; matter, but helps avoid type
                                      ;; warnings at compile time.)
                                      :initial-element *empty-type*)))

-    (flet ((accumulate (type)
-            (accumulate-compound-type type simplified-types simplify2)))
-      (declare (inline accumulate))
-      (dolist (type input-types)
-       (if (funcall %compound-type-p type)
-           (map nil #'accumulate (compound-type-types type))
-           (accumulate 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
     simplified-types))
 
 ;;; shared logic for unions and intersections: Make a COMPOUND-TYPE

@@ -843,6 +840,7 @@
   (let ((simplified-types (simplified-compound-types input-types
                                                     #'intersection-type-p
                                                     #'type-intersection2)))
   (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
     ;; 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

@@ -876,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

@@ -891,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)

@@ -935,12 +936,12 @@
 (!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))
 
 (!define-type-method (named :complex-union2) (type1 type2)
   ;; Perhaps when bug 85 is fixed this can be reenabled.
   (hierarchical-intersection2 type1 type2))
 
 (!define-type-method (named :complex-union2) (type1 type2)
   ;; Perhaps when bug 85 is fixed this 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-union2 type1 type2))
 
 (!define-type-method (named :unparse) (x)
   (hierarchical-union2 type1 type2))
 
 (!define-type-method (named :unparse) (x)

@@ -1014,28 +1015,6 @@
 \f
 ;;;; numeric types
 
 \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)

@@ -1091,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

@@ -1294,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 "The component type for COMPLEX is not numeric: ~S" spec))
-       (when (eq (numeric-type-complexp type) :complex)
-         (error "The 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.

@@ -1345,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))

@@ -1432,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

@@ -1656,8 +1714,8 @@
     ;; See whether dimensions are compatible.
     (cond ((not (or (eq dims1 '*) (eq dims2 '*)
                    (and (= (length dims1) (length dims2))
     ;; See whether dimensions are compatible.
     (cond ((not (or (eq dims1 '*) (eq dims2 '*)
                    (and (= (length dims1) (length dims2))

-                        (every #'(lambda (x y)
-                                   (or (eq x '*) (eq y '*) (= x y)))
+                        (every (lambda (x y)
+                                 (or (eq x '*) (eq y '*) (= x y)))

                                dims1 dims2))))
           (values nil t))
          ;; See whether complexpness is compatible.
                                dims1 dims2))))
           (values nil t))
          ;; See whether complexpness is compatible.

@@ -1744,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)

@@ -1812,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

@@ -1855,16 +1913,18 @@
   (type=-set (intersection-type-types type1)
             (intersection-type-types type2)))
 
   (type=-set (intersection-type-types type1)
             (intersection-type-types type2)))
 

-(flet ((intersection-complex-subtypep-arg1 (type1 type2)
-         (any/type (swapped-args-fun #'csubtypep)
-                  type2
-                  (intersection-type-types type1))))
-  (!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)))
+(defun %intersection-complex-subtypep-arg1 (type1 type2)
+  (any/type (swapped-args-fun #'csubtypep)
+           type2
+           (intersection-type-types type1)))
+
+(!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)
   (every/type #'csubtypep type1 (intersection-type-types type2)))
 
 (!define-type-method (intersection :complex-subtypep-arg2) (type1 type2)
   (every/type #'csubtypep type1 (intersection-type-types type2)))

@@ -1893,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)

@@ -1942,33 +1989,26 @@
        ((union-complex-subtypep-arg1 type2 type1)
         type2)
        (t 
        ((union-complex-subtypep-arg1 type2 type1)
         type2)
        (t 

+        ;; 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)))
         (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
-            (when (or
-                   ;; (TYPE-UNION2 couldn't find a sufficiently simple
-                   ;; result, so we can't either.)
-                   (null accumulator)
-                   ;; (A result containing an intersection isn't
-                   ;; sufficiently simple for us. FIXME: Maybe it
-                   ;; should be sufficiently simple for us?
-                   ;; UNION-TYPEs aren't supposed to be nested inside
-                   ;; INTERSECTION-TYPEs, so if we punt with NIL,
-                   ;; we're condemning the expression to become a
-                   ;; HAIRY-TYPE. If it were possible for us to
-                   ;; return an INTERSECTION-TYPE, then the
-                   ;; INTERSECTION-TYPE-TYPES could be merged into
-                   ;; the outer INTERSECTION-TYPE which may be under
-                   ;; construction. E.g. if this function could
-                   ;; return an intersection type, and the calling
-                   ;; functions were smart enough to handle it, then
-                   ;; we could simplify (AND (OR FIXNUM KEYWORD)
-                   ;; SYMBOL) to KEYWORD, even though KEYWORD
-                   ;; is an intersection type.)
-                   (intersection-type-p accumulator))
+            ;; 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)
               (return nil)))))))
 
 (!def-type-translator or (&rest type-specifiers)

@@ -2067,7 +2107,7 @@
              (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))))))
       (let ((y-mem (find-if #'member-type-p y-types)))
        (when y-mem
                  (return-from type-difference nil))))))
       (let ((y-mem (find-if #'member-type-p y-types)))
        (when y-mem

@@ -2093,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")