(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 &optional environment)
+ #!+sb-doc
+ "Is OBJECT of type TYPE?"
+ (declare (ignore environment))
+ ;; 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)
((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))
(error "unknown type specifier: ~S"
(unknown-type-specifier reparse))
(%%typep object reparse))))
+ (negation-type
+ (not (%%typep object (negation-type-type type))))
(hairy-type
;; Now the tricky stuff.
(let* ((hairy-spec (hairy-type-specifier type))
(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)))))
(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))
(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)