0.pre7.71:

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

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

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

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

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

@@ -2132,6 +2135,41 @@
 \f
 ;;;; utilities shared between cross-compiler and target system
 
 \f
 ;;;; 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)
 ;;; This messy case of CTYPE for NUMBER is shared between the
 ;;; cross-compiler and the target system.
 (defun ctype-of-number (x)

@@ -2150,6 +2188,15 @@
                         :low low
                         :high high))))
 \f
                         :low low
                         :high high))))
 \f

-(!defun-from-collected-cold-init-forms !late-type-cold-init)
+(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")