0.pre7.124:
[sbcl.git] / src / code / late-type.lisp
index bf6c079..1563ca5 100644 (file)
@@ -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
 ;;; 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
-  (type (required-argument) :type ctype))
+  (type (missing-arg) :type ctype))
 
 (!define-type-method (values :simple-subtypep :complex-subtypep-arg1)
                     (type1 type2)
 ;;; 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)
-  (if *unparse-function-type-simplify*
+  (if *unparse-fun-type-simplify*
       'function
       (list 'function
-           (if (function-type-wild-args type)
+           (if (fun-type-wild-args type)
                '*
                (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.
     (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 '*)
-       (setf (function-type-wild-args res) t)
+       (setf (fun-type-wild-args res) t)
        (parse-args-types args res))
     res))
 
 ;;; 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))
-  (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)
 (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))
 ;;; 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
                       #'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
-;;; 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*))
-        (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
-        (types-intersect type1 type2))))
+        (types-equal-or-intersect type1 type2))))
 
 ;;; a SUBTYPEP-like operation that can be used on any types, including
 ;;; VALUES types
   (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))
                            (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
        ((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 function simplify2))
   ;; Any input object satisfying %COMPOUND-TYPE-P should've been
   ;; broken into components before it reached us.
-  (assert (not (funcall %compound-type-p type)))
+  (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
 (defvar *wild-type*)
 (defvar *empty-type*)
 (defvar *universal-type*)
-
+(defvar *universal-fun-type*)
 (!cold-init-forms
  (macrolet ((frob (name var)
              `(progn
    ;; 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.
-  ;;(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)
-  (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)
-  (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..)
-  (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
-  ;;   (SUBTYPEP 'T '(OR (SATISFIES FOO) (SATISFIES BAR)))
+  ;;   (SUBTYPEP T '(OR (SATISFIES FOO) (SATISFIES BAR)))
   ;; 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)
-  (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)
 (!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.
-  ;;(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)
 \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)
             '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
   (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)
-      (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.
        (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))
       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
     ;; 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.
 ;;; 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)
 ;;;;    ;; 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
   (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)))
 
 ;;; 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)
-  (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)
              (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
                    :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")