X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftypep.lisp;h=374d3bcc37301920639186745c1e24238bc45966;hb=cee8ef591040db9a79cdd19297867672a9529051;hp=0844ebf06af7c08fed2d98a9010edf3d3e3344a2;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/typep.lisp b/src/code/typep.lisp index 0844ebf..374d3bc 100644 --- a/src/code/typep.lisp +++ b/src/code/typep.lisp @@ -31,12 +31,15 @@ (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) @@ -102,21 +105,28 @@ (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)) @@ -133,16 +143,16 @@ (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 @@ -151,7 +161,7 @@ (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)) @@ -159,8 +169,11 @@ (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. @@ -174,21 +187,27 @@ ;;; 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)))))))