(if (ctype-p specifier)
specifier
(specifier-type specifier))))
-(defun %%typep (object type)
+(defun %%typep (object type &optional (strict t))
(declare (type ctype type))
(etypecase type
(named-type
(ecase (named-type-name type)
((* t) t)
+ ((instance) (%instancep object))
+ ((funcallable-instance) (funcallable-instance-p object))
+ ((extended-sequence) (extended-sequence-p object))
((nil) nil)))
(numeric-type
(and (numberp object)
(specifier-type (array-element-type
object)))))))
(member-type
- (if (member object (member-type-members type)) t))
+ (when (member-type-member-p object type)
+ t))
(classoid
#+sb-xc-host (ctypep object type)
#-sb-xc-host (classoid-typep (layout-of object) type object))
(union-type
- (some (lambda (union-type-type) (%%typep object union-type-type))
+ (some (lambda (union-type-type) (%%typep object union-type-type strict))
(union-type-types type)))
(intersection-type
(every (lambda (intersection-type-type)
- (%%typep object intersection-type-type))
+ (%%typep object intersection-type-type strict))
(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))))
+ (%%typep (car object) (cons-type-car-type type) strict)
+ (%%typep (cdr object) (cons-type-cdr-type type) strict)))
+ #!+sb-simd-pack
+ (simd-pack-type
+ (and (simd-pack-p object)
+ (let* ((tag (%simd-pack-tag object))
+ (name (nth tag *simd-pack-element-types*)))
+ (not (not (member name (simd-pack-type-element-type type)))))))
(character-set-type
(and (characterp object)
(let ((code (char-code object))
(if (typep reparse 'unknown-type)
(error "unknown type specifier: ~S"
(unknown-type-specifier reparse))
- (%%typep object reparse))))
+ (%%typep object reparse strict))))
(negation-type
- (not (%%typep object (negation-type-type type))))
+ (not (%%typep object (negation-type-type type) strict)))
(hairy-type
;; Now the tricky stuff.
(let* ((hairy-spec (hairy-type-specifier type))
(symbol (car hairy-spec)))
(ecase symbol
(and
- (every (lambda (spec) (%%typep object (specifier-type spec)))
+ (every (lambda (spec) (%%typep object (specifier-type spec) strict))
(rest hairy-spec)))
;; Note: it should be safe to skip OR here, because union
;; types can always be represented as UNION-TYPE in general
(not
(unless (proper-list-of-length-p hairy-spec 2)
(error "invalid type specifier: ~S" hairy-spec))
- (not (%%typep object (specifier-type (cadr hairy-spec)))))
+ (not (%%typep object (specifier-type (cadr hairy-spec)) strict)))
(satisfies
(unless (proper-list-of-length-p hairy-spec 2)
(error "invalid type specifier: ~S" hairy-spec))
(alien-type-type
(sb!alien-internals:alien-typep object (alien-type-type-alien-type type)))
(fun-type
- (error "Function types are not a legal argument to TYPEP:~% ~S"
- (type-specifier type)))))
+ (if strict
+ (error "Function types are not a legal argument to TYPEP:~% ~S"
+ (type-specifier type))
+ (and (functionp object)
+ (csubtypep (specifier-type (sb!impl::%fun-type object)) type))))))
;;; Do a type test from a class cell, allowing forward reference and
;;; redefinition.
;;; Test whether OBJ-LAYOUT is from an instance of CLASSOID.
(defun classoid-typep (obj-layout classoid object)
(declare (optimize speed))
- (when (layout-invalid obj-layout)
- (if (and (typep (classoid-of object) 'standard-classoid) object)
- (setq obj-layout (sb!pcl::check-wrapper-validity object))
- (error "TYPEP was called on an obsolete object (was class ~S)."
- (classoid-proper-name (layout-classoid obj-layout)))))
- (let ((layout (classoid-layout classoid))
- (obj-inherits (layout-inherits obj-layout)))
- (when (layout-invalid layout)
- (error "The class ~S is currently invalid." classoid))
- (or (eq obj-layout layout)
- (dotimes (i (length obj-inherits) nil)
- (when (eq (svref obj-inherits i) layout)
- (return t))))))
-
-;;; 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)
+ ;; FIXME & KLUDGE: We could like to grab the *WORLD-LOCK* here (to ensure that
+ ;; class graph doesn't change while we're doing the typep test), but in
+ ;; pratice that causes trouble -- deadlocking against the compiler
+ ;; if compiler output (or macro, or compiler-macro expansion) causes
+ ;; another thread to do stuff. Not locking is a shoddy bandaid as it is remains
+ ;; easy to trigger the same problem using a different code path -- but in practice
+ ;; locking here makes Slime unusable with :SPAWN in post *WORLD-LOCK* world. So...
+ ;; -- NS 2008-12-16
+ (multiple-value-bind (obj-layout layout)
+ (do ((layout (classoid-layout classoid) (classoid-layout classoid))
+ (i 0 (+ i 1))
+ (obj-layout obj-layout))
+ ((and (not (layout-invalid obj-layout))
+ (not (layout-invalid layout)))
+ (values obj-layout layout))
+ (aver (< i 2))
+ (when (layout-invalid obj-layout)
+ (setq obj-layout (update-object-layout-or-invalid object layout)))
+ (%ensure-classoid-valid classoid layout "typep"))
+ (let ((obj-inherits (layout-inherits obj-layout)))
+ (or (eq obj-layout layout)
+ (dotimes (i (length obj-inherits) nil)
+ (when (eq (svref obj-inherits i) layout)
+ (return t)))))))
projects / sbcl.git / blobdiff