0.7.9.1:

[sbcl.git] / src / code / typep.lisp

diff --git a/src/code/typep.lisp b/src/code/typep.lisp
index f46a25c..6807198 100644 (file)
--- a/src/code/typep.lisp
+++ b/src/code/typep.lisp
@@ -9,6 +9,20 @@
 
 (in-package "SB!KERNEL")
 
+;;; (Note that when cross-compiling, SB!XC:TYPEP is interpreted as a
+;;; test that the host Lisp object OBJECT translates to a target SBCL
+;;; type TYPE. This behavior is needed e.g. to test for the validity
+;;; of numeric subtype bounds read when cross-compiling.)
+(defun typep (object type)
+  #!+sb-doc
+  "Is OBJECT of type TYPE?"
+  ;; Actually interpreting types at runtime is done by %TYPEP. The
+  ;; cost of the extra function call here should be negligible
+  ;; compared to the cost of interpreting types. (And the compiler
+  ;; tries hard to optimize away the interpretation of types at
+  ;; runtime, and when it succeeds, we never get here anyway.)
+  (%typep object type))
+
 ;;; the actual TYPEP engine. The compiler only generates calls to this
 ;;; function when it can't figure out anything more intelligent to do.
 (defun %typep (object specifier)
@@ -25,7 +39,14 @@
        ((nil) nil)))
     (numeric-type
      (and (numberp object)
-         (let ((num (if (complexp object) (realpart object) object)))
+         (let (;; I think this works because of an invariant of the
+               ;; two components of a COMPLEX are always coerced to
+               ;; be the same, e.g. (COMPLEX 1.0 3/2) => #C(1.0 1.5).
+               ;; Dunno why that holds, though -- ANSI? Python
+               ;; tradition? marsh faerie spirits? -- WHN 2001-10-27
+               (num (if (complexp object)
+                        (realpart object)
+                        object)))
            (ecase (numeric-type-class type)
              (integer (integerp num))
              (rational (rationalp num))
@@ -117,10 +138,11 @@
      #+sb-xc-host (ctypep object type)
      #-sb-xc-host (class-typep (layout-of object) type object))
     (union-type
-     (some (lambda (typ) (%%typep object typ))
+     (some (lambda (union-type-type) (%%typep object union-type-type))
           (union-type-types type)))
     (intersection-type
-     (every (lambda (typ) (%%typep object typ))
+     (every (lambda (intersection-type-type)
+             (%%typep object intersection-type-type))
            (intersection-type-types type)))
     (cons-type
      (and (consp object)
@@ -157,7 +179,7 @@
          (values (funcall (symbol-function (cadr hairy-spec)) object))))))
     (alien-type-type
      (sb!alien-internals:alien-typep object (alien-type-type-alien-type type)))
-    (function-type
+    (fun-type
      (error "Function types are not a legal argument to TYPEP:~%  ~S"
            (type-specifier type)))))
 
@@ -174,7 +196,7 @@
   (declare (optimize speed))
   (when (layout-invalid obj-layout)
     (if (and (typep (sb!xc:class-of object) 'sb!xc:standard-class) object)
-       (setq obj-layout (pcl-check-wrapper-validity-hook object))
+       (setq obj-layout (sb!pcl::check-wrapper-validity object))
        (error "TYPEP was called on an obsolete object (was class ~S)."
               (class-proper-name (layout-class obj-layout)))))
   (let ((layout (class-layout class))
@@ -186,8 +208,7 @@
          (when (eq (svref obj-inherits i) layout)
            (return t))))))
 
-;;; to be redefined as PCL::CHECK-WRAPPER-VALIDITY when PCL is loaded
-;;;
-;;; FIXME: should probably be renamed SB!PCL:CHECK-WRAPPER-VALIDITY
-(defun pcl-check-wrapper-validity-hook (object)
+;;; This implementation is a placeholder to use until PCL is set up,
+;;; at which time it will be overwritten by a real implementation.
+(defun sb!pcl::check-wrapper-validity (object)
   object)