X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=fc14309929ce584460c52356cf2b465fe7902cfd;hb=b6cb3d5b2e2a0d6e6c92a2f3d852051540660fef;hp=5d05e7bb3fe64b1d2cd4807a9ae0f19d2ebb4385;hpb=a8fa26a6e9804d3548f5bca9361a91345a689099;p=sbcl.git

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 5d05e7b..fc14309 100644
--- 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.
 
-;;; 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
@@ -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.")
-
 (!cold-init-forms (setq *use-implementation-types* t))
 
 ;;; These functions are used as method for types which need a complex
@@ -876,7 +875,7 @@
 (defvar *wild-type*)
 (defvar *empty-type*)
 (defvar *universal-type*)
-
+(defvar *universal-function-type*)
 (!cold-init-forms
  (macrolet ((frob (name var)
 	      `(progn
@@ -891,7 +890,10 @@
    ;; Ts and *UNIVERSAL-TYPE*s.
    (frob * *wild-type*)
    (frob nil *empty-type*)
-   (frob t *universal-type*)))
+   (frob t *universal-type*))
+ (setf *universal-function-type*
+       (make-function-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
@@ -1912,16 +1914,18 @@
   (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)))
@@ -2132,6 +2136,41 @@
 
 ;;;; 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 FUNCTION-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 FUNCTION-TYPEs. (ARGS-TYPE
+	   ;; is a base class both of VALUES-TYPE and of FUNCTION-TYPE.)
+	   (values-types-equal-or-intersect
+	    (function-type-returns defined-ftype)
+	    (function-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)
@@ -2150,6 +2189,15 @@
 			 :low low
 			 :high high))))
 
-(!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")