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 (ignore environment))
20 ;; Actually interpreting types at runtime is done by %TYPEP. The
21 ;; cost of the extra function call here should be negligible
22 ;; compared to the cost of interpreting types. (And the compiler
23 ;; tries hard to optimize away the interpretation of types at
24 ;; runtime, and when it succeeds, we never get here anyway.)
27 ;;; the actual TYPEP engine. The compiler only generates calls to this
28 ;;; function when it can't figure out anything more intelligent to do.
29 (defun %typep (object specifier)
31 (if (ctype-p specifier)
33 (specifier-type specifier))))
34 (defun %%typep (object type)
35 (declare (type ctype type))
38 (ecase (named-type-name type)
40 ((instance) (%instancep object))
41 ((funcallable-instance) (funcallable-instance-p object))
45 (let (;; I think this works because of an invariant of the
46 ;; two components of a COMPLEX are always coerced to
47 ;; be the same, e.g. (COMPLEX 1.0 3/2) => #C(1.0 1.5).
48 ;; Dunno why that holds, though -- ANSI? Python
49 ;; tradition? marsh faerie spirits? -- WHN 2001-10-27
50 (num (if (complexp object)
53 (ecase (numeric-type-class type)
54 (integer (integerp num))
55 (rational (rationalp num))
57 (ecase (numeric-type-format type)
58 (short-float (typep num 'short-float))
59 (single-float (typep num 'single-float))
60 (double-float (typep num 'double-float))
61 (long-float (typep num 'long-float))
62 ((nil) (floatp num))))
64 (flet ((bound-test (val)
65 (let ((low (numeric-type-low type))
66 (high (numeric-type-high type)))
67 (and (cond ((null low) t)
68 ((listp low) (> val (car low)))
71 ((listp high) (< val (car high)))
72 (t (<= val high)))))))
73 (ecase (numeric-type-complexp type)
76 (and (complexp object)
77 (bound-test (realpart object))
78 (bound-test (imagpart object))))
80 (and (not (complexp object))
81 (bound-test object)))))))
84 (ecase (array-type-complexp type)
85 ((t) (not (typep object 'simple-array)))
86 ((nil) (typep object 'simple-array))
88 (or (eq (array-type-dimensions type) '*)
89 (do ((want (array-type-dimensions type) (cdr want))
90 (got (array-dimensions object) (cdr got)))
91 ((and (null want) (null got)) t)
93 (or (eq (car want) '*)
94 (= (car want) (car got))))
96 (if (unknown-type-p (array-type-element-type type))
97 ;; better to fail this way than to get bogosities like
98 ;; (TYPEP (MAKE-ARRAY 11) '(ARRAY SOME-UNDEFINED-TYPE)) => T
99 (error "~@<unknown element type in array type: ~2I~_~S~:>"
100 (type-specifier type))
102 (or (eq (array-type-element-type type) *wild-type*)
103 (values (type= (array-type-specialized-element-type type)
104 (specifier-type (array-element-type
107 (if (member object (member-type-members type)) t))
109 #+sb-xc-host (ctypep object type)
110 #-sb-xc-host (classoid-typep (layout-of object) type object))
112 (some (lambda (union-type-type) (%%typep object union-type-type))
113 (union-type-types type)))
115 (every (lambda (intersection-type-type)
116 (%%typep object intersection-type-type))
117 (intersection-type-types type)))
120 (%%typep (car object) (cons-type-car-type type))
121 (%%typep (cdr object) (cons-type-cdr-type type))))
123 (and (characterp object)
124 (let ((code (char-code object))
125 (pairs (character-set-type-pairs type)))
126 (dolist (pair pairs nil)
127 (destructuring-bind (low . high) pair
128 (when (<= low code high)
131 ;; dunno how to do this ANSIly -- WHN 19990413
132 #+sb-xc-host (error "stub: %%TYPEP UNKNOWN-TYPE in xcompilation host")
133 ;; Parse it again to make sure it's really undefined.
134 (let ((reparse (specifier-type (unknown-type-specifier type))))
135 (if (typep reparse 'unknown-type)
136 (error "unknown type specifier: ~S"
137 (unknown-type-specifier reparse))
138 (%%typep object reparse))))
140 (not (%%typep object (negation-type-type type))))
142 ;; Now the tricky stuff.
143 (let* ((hairy-spec (hairy-type-specifier type))
144 (symbol (car hairy-spec)))
147 (every (lambda (spec) (%%typep object (specifier-type spec)))
149 ;; Note: it should be safe to skip OR here, because union
150 ;; types can always be represented as UNION-TYPE in general
151 ;; or other CTYPEs in special cases; we never need to use
152 ;; HAIRY-TYPE for them.
154 (unless (proper-list-of-length-p hairy-spec 2)
155 (error "invalid type specifier: ~S" hairy-spec))
156 (not (%%typep object (specifier-type (cadr hairy-spec)))))
158 (unless (proper-list-of-length-p hairy-spec 2)
159 (error "invalid type specifier: ~S" hairy-spec))
160 (values (funcall (symbol-function (cadr hairy-spec)) object))))))
162 (sb!alien-internals:alien-typep object (alien-type-type-alien-type type)))
164 (error "Function types are not a legal argument to TYPEP:~% ~S"
165 (type-specifier type)))))
167 ;;; Do a type test from a class cell, allowing forward reference and
169 (defun classoid-cell-typep (obj-layout cell object)
170 (let ((classoid (classoid-cell-classoid cell)))
172 (error "The class ~S has not yet been defined."
173 (classoid-cell-name cell)))
174 (classoid-typep obj-layout classoid object)))
176 ;;; Test whether OBJ-LAYOUT is from an instance of CLASSOID.
177 (defun classoid-typep (obj-layout classoid object)
178 (declare (optimize speed))
179 (multiple-value-bind (obj-layout layout)
180 (do ((layout (classoid-layout classoid) (classoid-layout classoid))
182 (obj-layout obj-layout))
183 ((and (not (layout-invalid obj-layout))
184 (not (layout-invalid layout)))
185 (values obj-layout layout))
187 (when (layout-invalid obj-layout)
188 (if (typep (classoid-of object) 'standard-classoid)
189 (setq obj-layout (sb!pcl::check-wrapper-validity object))
190 (error "~S was called on an obsolete object (classoid ~S)."
192 (classoid-proper-name (layout-classoid obj-layout)))))
193 (ensure-classoid-valid classoid layout))
194 (let ((obj-inherits (layout-inherits obj-layout)))
195 (or (eq obj-layout layout)
196 (dotimes (i (length obj-inherits) nil)
197 (when (eq (svref obj-inherits i) layout)