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 326f744..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.

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

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

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

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

@@ -894,7 +889,10 @@
    ;; 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
 
 (!define-type-method (named :simple-=) (type1 type2)
   ;; FIXME: BUG 85: This assertion failed when I added it in

@@ -915,9 +913,9 @@
   (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
   (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

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

   ;; or
   ;; or

-  ;;   (SUBTYPEP 'T '(AND (SATISFIES FOO) (SATISFIES BAR))).
+  ;;   (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))
   (aver (not (compound-type-p type2))) 
   ;; Then, since TYPE2 is reasonably tractable, we're good to go.
   (values (eq type1 *empty-type*) t))

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

@@ -1313,9 +1289,7 @@
                 (when (eq (numeric-type-complexp component-type) :complex)
                   (error "The component type for COMPLEX is complex: ~S"
                          typespec))
                 (when (eq (numeric-type-complexp component-type) :complex)
                   (error "The component type for COMPLEX is complex: ~S"
                          typespec))

-                (let ((result (copy-numeric-type component-type)))
-                  (setf (numeric-type-complexp result) :complex)
-                  result)))
+                (modified-numeric-type component-type :complexp :complex)))

        (let ((type (specifier-type typespec)))
          (typecase type
            ;; This is all that CMU CL handled.
        (let ((type (specifier-type typespec)))
          (typecase type
            ;; This is all that CMU CL handled.

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

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

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

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

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