(in-package "SB!KERNEL")
-;;; The actual TYPEP engine. The compiler only generates calls to this
+;;; (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)
(%%typep object
((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))
(or (eq (car want) '*)
(= (car want) (car got))))
(return nil))))
+ (if (unknown-type-p (array-type-element-type type))
+ ;; better to fail this way than to get bogosities like
+ ;; (TYPEP (MAKE-ARRAY 11) '(ARRAY SOME-UNDEFINED-TYPE)) => T
+ (error "~@<unknown element type in array type: ~2I~_~S~:>"
+ (type-specifier type))
+ t)
(or (eq (array-type-element-type type) *wild-type*)
(values (type= (array-type-specialized-element-type type)
(specifier-type (array-element-type
#+sb-xc-host (ctypep object type)
#-sb-xc-host (class-typep (layout-of object) type object))
(union-type
- (dolist (type (union-type-types type))
- (when (%%typep object type)
- (return t))))
+ (some (lambda (union-type-type) (%%typep object union-type-type))
+ (union-type-types type)))
+ (intersection-type
+ (every (lambda (intersection-type-type)
+ (%%typep object intersection-type-type))
+ (intersection-type-types type)))
+ (cons-type
+ (and (consp object)
+ (%%typep (car object) (cons-type-car-type type))
+ (%%typep (cdr object) (cons-type-cdr-type type))))
(unknown-type
;; dunno how to do this ANSIly -- WHN 19990413
#+sb-xc-host (error "stub: %%TYPEP UNKNOWN-TYPE in xcompilation host")
(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))
- (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
+ (symbol (car hairy-spec)))
(ecase symbol
(and
- (or (atom hairy-spec)
- (dolist (spec (cdr hairy-spec) t)
- (unless (%%typep object (specifier-type spec))
- (return nil)))))
+ (every (lambda (spec) (%%typep object (specifier-type spec)))
+ (rest hairy-spec)))
+ ;; Note: it should be safe to skip OR here, because union
+ ;; types can always be represented as UNION-TYPE in general
+ ;; or other CTYPEs in special cases; we never need to use
+ ;; HAIRY-TYPE for them.
(not
(unless (proper-list-of-length-p hairy-spec 2)
(error "invalid type specifier: ~S" hairy-spec))
(satisfies
(unless (proper-list-of-length-p hairy-spec 2)
(error "invalid type specifier: ~S" hairy-spec))
- (let ((fn (cadr hairy-spec)))
- (if (funcall (typecase fn
- (function fn)
- (symbol (symbol-function fn))
- (t
- (coerce fn 'function)))
- object)
- t
- nil))))))
+ (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)))))
-;;; Do type test from a class cell, allowing forward reference and
+;;; Do a type test from a class cell, allowing forward reference and
;;; redefinition.
(defun class-cell-typep (obj-layout cell object)
(let ((class (class-cell-class cell)))
(error "The class ~S has not yet been defined." (class-cell-name cell)))
(class-typep obj-layout class object)))
-;;; Test whether Obj-Layout is from an instance of Class.
+;;; Test whether OBJ-LAYOUT is from an instance of CLASS.
(defun class-typep (obj-layout class object)
(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)
projects / sbcl.git / blobdiff