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)
18 "Is OBJECT of type TYPE?"
19 ;; Actually interpreting types at runtime is done by %TYPEP. The
20 ;; cost of the extra function call here should be negligible
21 ;; compared to the cost of interpreting types. (And the compiler
22 ;; tries hard to optimize away the interpretation of types at
23 ;; runtime, and when it succeeds, we never get here anyway.)
26 ;;; the actual TYPEP engine. The compiler only generates calls to this
27 ;;; function when it can't figure out anything more intelligent to do.
28 (defun %typep (object specifier)
30 (if (ctype-p specifier)
32 (specifier-type specifier))))
33 (defun %%typep (object type)
34 (declare (type ctype type))
37 (ecase (named-type-name type)
42 (let (;; I think this works because of an invariant of the
43 ;; two components of a COMPLEX are always coerced to
44 ;; be the same, e.g. (COMPLEX 1.0 3/2) => #C(1.0 1.5).
45 ;; Dunno why that holds, though -- ANSI? Python
46 ;; tradition? marsh faerie spirits? -- WHN 2001-10-27
47 (num (if (complexp object)
50 (ecase (numeric-type-class type)
51 (integer (integerp num))
52 (rational (rationalp num))
54 (ecase (numeric-type-format type)
55 (short-float (typep num 'short-float))
56 (single-float (typep num 'single-float))
57 (double-float (typep num 'double-float))
58 (long-float (typep num 'long-float))
59 ((nil) (floatp num))))
61 #!-negative-zero-is-not-zero
62 (flet ((bound-test (val)
63 (let ((low (numeric-type-low type))
64 (high (numeric-type-high type)))
65 (and (cond ((null low) t)
66 ((listp low) (> val (car low)))
69 ((listp high) (< val (car high)))
70 (t (<= val high)))))))
71 (ecase (numeric-type-complexp type)
74 (and (complexp object)
75 (bound-test (realpart object))
76 (bound-test (imagpart object))))
78 (and (not (complexp object))
79 (bound-test object)))))
80 #!+negative-zero-is-not-zero
81 (labels ((signed-> (x y)
82 (if (and (zerop x) (zerop y) (floatp x) (floatp y))
83 (> (float-sign x) (float-sign y))
86 (if (and (zerop x) (zerop y) (floatp x) (floatp y))
87 (>= (float-sign x) (float-sign y))
90 (let ((low (numeric-type-low type))
91 (high (numeric-type-high type)))
92 (and (cond ((null low) t)
94 (signed-> val (car low)))
99 (signed-> (car high) val))
101 (signed->= high val)))))))
102 (ecase (numeric-type-complexp type)
105 (and (complexp object)
106 (bound-test (realpart object))
107 (bound-test (imagpart object))))
109 (and (not (complexp object))
110 (bound-test object)))))))
113 (ecase (array-type-complexp type)
114 ((t) (not (typep object 'simple-array)))
115 ((nil) (typep object 'simple-array))
117 (or (eq (array-type-dimensions type) '*)
118 (do ((want (array-type-dimensions type) (cdr want))
119 (got (array-dimensions object) (cdr got)))
120 ((and (null want) (null got)) t)
121 (unless (and want got
122 (or (eq (car want) '*)
123 (= (car want) (car got))))
125 (if (unknown-type-p (array-type-element-type type))
126 ;; better to fail this way than to get bogosities like
127 ;; (TYPEP (MAKE-ARRAY 11) '(ARRAY SOME-UNDEFINED-TYPE)) => T
128 (error "~@<unknown element type in array type: ~2I~_~S~:>"
129 (type-specifier type))
131 (or (eq (array-type-element-type type) *wild-type*)
132 (values (type= (array-type-specialized-element-type type)
133 (specifier-type (array-element-type
136 (if (member object (member-type-members type)) t))
138 #+sb-xc-host (ctypep object type)
139 #-sb-xc-host (class-typep (layout-of object) type object))
141 (some (lambda (union-type-type) (%%typep object union-type-type))
142 (union-type-types type)))
144 (every (lambda (intersection-type-type)
145 (%%typep object intersection-type-type))
146 (intersection-type-types type)))
149 (%%typep (car object) (cons-type-car-type type))
150 (%%typep (cdr object) (cons-type-cdr-type type))))
152 ;; dunno how to do this ANSIly -- WHN 19990413
153 #+sb-xc-host (error "stub: %%TYPEP UNKNOWN-TYPE in xcompilation host")
154 ;; Parse it again to make sure it's really undefined.
155 (let ((reparse (specifier-type (unknown-type-specifier type))))
156 (if (typep reparse 'unknown-type)
157 (error "unknown type specifier: ~S"
158 (unknown-type-specifier reparse))
159 (%%typep object reparse))))
161 ;; Now the tricky stuff.
162 (let* ((hairy-spec (hairy-type-specifier type))
163 (symbol (car hairy-spec)))
166 (every (lambda (spec) (%%typep object (specifier-type spec)))
168 ;; Note: it should be safe to skip OR here, because union
169 ;; types can always be represented as UNION-TYPE in general
170 ;; or other CTYPEs in special cases; we never need to use
171 ;; HAIRY-TYPE for them.
173 (unless (proper-list-of-length-p hairy-spec 2)
174 (error "invalid type specifier: ~S" hairy-spec))
175 (not (%%typep object (specifier-type (cadr hairy-spec)))))
177 (unless (proper-list-of-length-p hairy-spec 2)
178 (error "invalid type specifier: ~S" hairy-spec))
179 (values (funcall (symbol-function (cadr hairy-spec)) object))))))
181 (sb!alien-internals:alien-typep object (alien-type-type-alien-type type)))
183 (error "Function types are not a legal argument to TYPEP:~% ~S"
184 (type-specifier type)))))
186 ;;; Do a type test from a class cell, allowing forward reference and
188 (defun class-cell-typep (obj-layout cell object)
189 (let ((class (class-cell-class cell)))
191 (error "The class ~S has not yet been defined." (class-cell-name cell)))
192 (class-typep obj-layout class object)))
194 ;;; Test whether OBJ-LAYOUT is from an instance of CLASS.
195 (defun class-typep (obj-layout class object)
196 (declare (optimize speed))
197 (when (layout-invalid obj-layout)
198 (if (and (typep (sb!xc:class-of object) 'sb!xc:standard-class) object)
199 (setq obj-layout (pcl-check-wrapper-validity-hook object))
200 (error "TYPEP was called on an obsolete object (was class ~S)."
201 (class-proper-name (layout-class obj-layout)))))
202 (let ((layout (class-layout class))
203 (obj-inherits (layout-inherits obj-layout)))
204 (when (layout-invalid layout)
205 (error "The class ~S is currently invalid." class))
206 (or (eq obj-layout layout)
207 (dotimes (i (length obj-inherits) nil)
208 (when (eq (svref obj-inherits i) layout)
211 ;;; to be redefined as PCL::CHECK-WRAPPER-VALIDITY when PCL is loaded
213 ;;; FIXME: should probably be renamed SB!PCL:CHECK-WRAPPER-VALIDITY
214 (defun pcl-check-wrapper-validity-hook (object)