1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
10 (in-package "SB!KERNEL")
12 ;;; (Note that when cross-compiling, SB!XC:TYPEP is interpreted as a
13 ;;; test that the host Lisp object OBJECT translates to a target SBCL
14 ;;; type TYPE. This behavior is needed e.g. to test for the validity
15 ;;; of numeric subtype bounds read when cross-compiling.)
16 (defun typep (object type
&optional environment
)
18 "Is OBJECT of type TYPE?"
19 (declare (type lexenv-designator environment
) (ignore environment
))
20 (declare (explicit-check))
21 ;; Actually interpreting types at runtime is done by %TYPEP. The
22 ;; cost of the extra function call here should be negligible
23 ;; compared to the cost of interpreting types. (And the compiler
24 ;; tries hard to optimize away the interpretation of types at
25 ;; runtime, and when it succeeds, we never get here anyway.)
26 (%%typep object
(specifier-type type
)))
28 ;;; the actual TYPEP engine. The compiler only generates calls to this
29 ;;; function when it can't figure out anything more intelligent to do.
30 (defun %typep
(object specifier
)
31 ;; Checking CTYPE-P on the specifier, as used to be done, is not right.
32 ;; If the specifier were a CTYPE we shouldn't have gotten here.
33 (declare (explicit-check))
34 (%%typep object
(specifier-type specifier
)))
36 (defun %%typep
(object type
&optional
(strict t
))
37 (declare (type ctype type
))
40 (ecase (named-type-name type
)
42 ((instance) (%instancep object
))
43 ((funcallable-instance) (funcallable-instance-p object
))
44 ((extended-sequence) (extended-sequence-p object
))
48 (let (;; I think this works because of an invariant of the
49 ;; two components of a COMPLEX are always coerced to
50 ;; be the same, e.g. (COMPLEX 1.0 3/2) => #C(1.0 1.5).
51 ;; Dunno why that holds, though -- ANSI? Python
52 ;; tradition? marsh faerie spirits? -- WHN 2001-10-27
53 (num (if (complexp object
)
56 (ecase (numeric-type-class type
)
57 (integer (integerp num
))
58 (rational (rationalp num
))
60 (ecase (numeric-type-format type
)
61 (short-float (typep num
'short-float
))
62 (single-float (typep num
'single-float
))
63 (double-float (typep num
'double-float
))
64 (long-float (typep num
'long-float
))
65 ((nil) (floatp num
))))
67 (flet ((bound-test (val)
68 (let ((low (numeric-type-low type
))
69 (high (numeric-type-high type
)))
70 (and (cond ((null low
) t
)
71 ((listp low
) (> val
(car low
)))
74 ((listp high
) (< val
(car high
)))
75 (t (<= val high
)))))))
76 (ecase (numeric-type-complexp type
)
79 (and (complexp object
)
80 (bound-test (realpart object
))
81 (bound-test (imagpart object
))))
83 (and (not (complexp object
))
84 (bound-test object
)))))))
87 (or (eq (array-type-complexp type
) :maybe
)
88 (eq (not (simple-array-p object
))
89 (array-type-complexp type
)))
90 (let ((want (array-type-dimensions type
)))
92 (if (array-header-p object
)
93 (do ((rank (array-rank object
))
95 (want want
(cdr want
)))
96 ((= axis rank
) (null want
))
97 (let ((dim (car want
)))
98 (unless (or (eq dim
'*)
99 (eq dim
(%array-dimension object axis
)))
101 (let ((dim (car want
)))
102 (and (or (eq dim
'*) (eq dim
(length object
)))
103 (not (cdr want
)))))))
104 ;; FIXME: treatment of compound types involving unknown types
105 ;; is generally bogus throughout the system, e.g.
106 ;; (TYPEP MY-ARRAY '(ARRAY (OR BAD1 BAD2) *)) => T
107 ;; because (OR BAD1 BAD2) is not represented as an UNKNOWN-TYPE,
108 ;; and has specialized type '*.
109 ;; One way to fix this is that every CTYPE needs a bit to indicate
110 ;; whether any subpart of it is unknown, or else when parsing,
111 ;; we should always return an UNKNOWN if any subpart is unknown,
112 ;; or else any time we use a CTYPE, we do a deep traversal
113 ;; to detect embedded UNKNOWNs (which seems bad for performance).
114 (if (unknown-type-p (array-type-element-type type
))
115 ;; better to fail this way than to get bogosities like
116 ;; (TYPEP (MAKE-ARRAY 11) '(ARRAY SOME-UNDEFINED-TYPE)) => T
117 (error "~@<unknown element type in array type: ~2I~_~S~:>"
118 (type-specifier type
))
120 (or (eq (array-type-specialized-element-type type
) *wild-type
*)
121 (values (type= (array-type-specialized-element-type type
)
122 ;; FIXME: not the most efficient.
123 (specifier-type (array-element-type
126 (when (member-type-member-p object type
)
129 #+sb-xc-host
(ctypep object type
)
130 ;; It might be more efficient to check that OBJECT is either INSTANCEP
131 ;; or FUNCALLABLE-INSTANCE-P before making this call.
132 ;; But doing that would change the behavior if %%TYPEP were ever called
133 ;; with a built-in classoid whose members are not instances.
134 ;; e.g. (%%typep (find-fdefn 'car) (specifier-type 'fdefn))
135 ;; I'm not sure if that can happen.
136 #-sb-xc-host
(classoid-typep (layout-of object
) type object
))
138 (some (lambda (union-type-type) (%%typep object union-type-type strict
))
139 (union-type-types type
)))
141 (every (lambda (intersection-type-type)
142 (%%typep object intersection-type-type strict
))
143 (intersection-type-types type
)))
146 (%%typep
(car object
) (cons-type-car-type type
) strict
)
147 (%%typep
(cdr object
) (cons-type-cdr-type type
) strict
)))
150 (and (simd-pack-p object
)
151 (let* ((tag (%simd-pack-tag object
))
152 (name (nth tag
*simd-pack-element-types
*)))
153 (not (not (member name
(simd-pack-type-element-type type
)))))))
155 (and (characterp object
)
156 (let ((code (char-code object
))
157 (pairs (character-set-type-pairs type
)))
158 (dolist (pair pairs nil
)
159 (destructuring-bind (low . high
) pair
160 (when (<= low code high
)
163 ;; dunno how to do this ANSIly -- WHN 19990413
164 #+sb-xc-host
(error "stub: %%TYPEP UNKNOWN-TYPE in xcompilation host")
165 ;; Parse it again to make sure it's really undefined.
166 (let ((reparse (specifier-type (unknown-type-specifier type
))))
167 (if (typep reparse
'unknown-type
)
168 (error "unknown type specifier: ~S"
169 (unknown-type-specifier reparse
))
170 (%%typep object reparse strict
))))
172 (not (%%typep object
(negation-type-type type
) strict
)))
174 ;; Now the tricky stuff.
175 (let* ((hairy-spec (hairy-type-specifier type
))
176 (symbol (car hairy-spec
)))
179 (every (lambda (spec) (%%typep object
(specifier-type spec
) strict
))
181 ;; Note: it should be safe to skip OR here, because union
182 ;; types can always be represented as UNION-TYPE in general
183 ;; or other CTYPEs in special cases; we never need to use
184 ;; HAIRY-TYPE for them.
186 (unless (proper-list-of-length-p hairy-spec
2)
187 (error "invalid type specifier: ~S" hairy-spec
))
188 (not (%%typep object
(specifier-type (cadr hairy-spec
)) strict
)))
190 (unless (proper-list-of-length-p hairy-spec
2)
191 (error "invalid type specifier: ~S" hairy-spec
))
192 (values (funcall (symbol-function (cadr hairy-spec
)) object
))))))
194 (sb!alien-internals
:alien-typep object
(alien-type-type-alien-type type
)))
197 (error "Function types are not a legal argument to TYPEP:~% ~S"
198 (type-specifier type
))
199 (and (functionp object
)
200 (csubtypep (specifier-type (sb!impl
::%fun-type object
)) type
))))))
202 ;;; Do a type test from a class cell, allowing forward reference and
204 (defun classoid-cell-typep (obj-layout cell object
)
205 (let ((classoid (classoid-cell-classoid cell
)))
207 (error "The class ~S has not yet been defined."
208 (classoid-cell-name cell
)))
209 (classoid-typep obj-layout classoid object
)))
211 ;;; Test whether OBJ-LAYOUT is from an instance of CLASSOID.
212 (defun classoid-typep (obj-layout classoid object
)
213 (declare (optimize speed
))
214 ;; FIXME & KLUDGE: We could like to grab the *WORLD-LOCK* here (to ensure that
215 ;; class graph doesn't change while we're doing the typep test), but in
216 ;; pratice that causes trouble -- deadlocking against the compiler
217 ;; if compiler output (or macro, or compiler-macro expansion) causes
218 ;; another thread to do stuff. Not locking is a shoddy bandaid as it is remains
219 ;; easy to trigger the same problem using a different code path -- but in practice
220 ;; locking here makes Slime unusable with :SPAWN in post *WORLD-LOCK* world. So...
222 (multiple-value-bind (obj-layout layout
)
223 (do ((layout (classoid-layout classoid
) (classoid-layout classoid
))
225 (obj-layout obj-layout
))
226 ((and (not (layout-invalid obj-layout
))
227 (not (layout-invalid layout
)))
228 (values obj-layout layout
))
230 (when (layout-invalid obj-layout
)
231 (setq obj-layout
(update-object-layout-or-invalid object layout
)))
232 (%ensure-classoid-valid classoid layout
"typep"))
233 (let ((obj-inherits (layout-inherits obj-layout
)))
234 (or (eq obj-layout layout
)
235 (dotimes (i (length obj-inherits
) nil
)
236 (when (eq (svref obj-inherits i
) layout
)