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")
15 ;;; The actual TYPEP engine. The compiler only generates calls to this
16 ;;; function when it can't figure out anything more intelligent to do.
17 (defun %typep (object specifier)
19 (if (ctype-p specifier)
21 (specifier-type specifier))))
22 (defun %%typep (object type)
23 (declare (type ctype type))
26 (ecase (named-type-name type)
31 (let ((num (if (complexp object) (realpart object) object)))
32 (ecase (numeric-type-class type)
33 (integer (integerp num))
34 (rational (rationalp num))
36 (ecase (numeric-type-format type)
37 (short-float (typep num 'short-float))
38 (single-float (typep num 'single-float))
39 (double-float (typep num 'double-float))
40 (long-float (typep num 'long-float))
41 ((nil) (floatp num))))
43 #!-negative-zero-is-not-zero
44 (flet ((bound-test (val)
45 (let ((low (numeric-type-low type))
46 (high (numeric-type-high type)))
47 (and (cond ((null low) t)
48 ((listp low) (> val (car low)))
51 ((listp high) (< val (car high)))
52 (t (<= val high)))))))
53 (ecase (numeric-type-complexp type)
56 (and (complexp object)
57 (bound-test (realpart object))
58 (bound-test (imagpart object))))
60 (and (not (complexp object))
61 (bound-test object)))))
62 #!+negative-zero-is-not-zero
63 (labels ((signed-> (x y)
64 (if (and (zerop x) (zerop y) (floatp x) (floatp y))
65 (> (float-sign x) (float-sign y))
68 (if (and (zerop x) (zerop y) (floatp x) (floatp y))
69 (>= (float-sign x) (float-sign y))
72 (let ((low (numeric-type-low type))
73 (high (numeric-type-high type)))
74 (and (cond ((null low) t)
76 (signed-> val (car low)))
81 (signed-> (car high) val))
83 (signed->= high val)))))))
84 (ecase (numeric-type-complexp type)
87 (and (complexp object)
88 (bound-test (realpart object))
89 (bound-test (imagpart object))))
91 (and (not (complexp object))
92 (bound-test object)))))))
95 (ecase (array-type-complexp type)
96 ((t) (not (typep object 'simple-array)))
97 ((nil) (typep object 'simple-array))
99 (or (eq (array-type-dimensions type) '*)
100 (do ((want (array-type-dimensions type) (cdr want))
101 (got (array-dimensions object) (cdr got)))
102 ((and (null want) (null got)) t)
103 (unless (and want got
104 (or (eq (car want) '*)
105 (= (car want) (car got))))
107 (or (eq (array-type-element-type type) *wild-type*)
108 (values (type= (array-type-specialized-element-type type)
109 (specifier-type (array-element-type
112 (if (member object (member-type-members type)) t))
114 #+sb-xc-host (ctypep object type)
115 #-sb-xc-host (class-typep (layout-of object) type object))
117 (dolist (type (union-type-types type))
118 (when (%%typep object type)
121 ;; dunno how to do this ANSIly -- WHN 19990413
122 #+sb-xc-host (error "stub: %%TYPEP UNKNOWN-TYPE in xcompilation host")
123 ;; Parse it again to make sure it's really undefined.
124 (let ((reparse (specifier-type (unknown-type-specifier type))))
125 (if (typep reparse 'unknown-type)
126 (error "unknown type specifier: ~S"
127 (unknown-type-specifier reparse))
128 (%%typep object reparse))))
130 ;; Now the tricky stuff.
131 (let* ((hairy-spec (hairy-type-specifier type))
132 (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
135 (or (atom hairy-spec)
136 (dolist (spec (cdr hairy-spec) t)
137 (unless (%%typep object (specifier-type spec))
140 (unless (proper-list-of-length-p hairy-spec 2)
141 (error "invalid type specifier: ~S" hairy-spec))
142 (not (%%typep object (specifier-type (cadr hairy-spec)))))
144 (unless (proper-list-of-length-p hairy-spec 2)
145 (error "invalid type specifier: ~S" hairy-spec))
146 (let ((fn (cadr hairy-spec)))
147 (if (funcall (typecase fn
149 (symbol (symbol-function fn))
151 (coerce fn 'function)))
156 (sb!alien-internals:alien-typep object (alien-type-type-alien-type type)))
158 (error "Function types are not a legal argument to TYPEP:~% ~S"
159 (type-specifier type)))))
161 ;;; Do type test from a class cell, allowing forward reference and
163 (defun class-cell-typep (obj-layout cell object)
164 (let ((class (class-cell-class cell)))
166 (error "The class ~S has not yet been defined." (class-cell-name cell)))
167 (class-typep obj-layout class object)))
169 ;;; Test whether Obj-Layout is from an instance of Class.
170 (defun class-typep (obj-layout class object)
171 (declare (optimize speed))
172 (when (layout-invalid obj-layout)
173 (if (and (typep (sb!xc:class-of object) 'sb!xc:standard-class) object)
174 (setq obj-layout (pcl-check-wrapper-validity-hook object))
175 (error "TYPEP was called on an obsolete object (was class ~S)."
176 (class-proper-name (layout-class obj-layout)))))
177 (let ((layout (class-layout class))
178 (obj-inherits (layout-inherits obj-layout)))
179 (when (layout-invalid layout)
180 (error "The class ~S is currently invalid." class))
181 (or (eq obj-layout layout)
182 (dotimes (i (length obj-inherits) nil)
183 (when (eq (svref obj-inherits i) layout)
186 ;;; to be redefined as PCL::CHECK-WRAPPER-VALIDITY when PCL is loaded
188 ;;; FIXME: should probably be renamed SB!PCL:CHECK-WRAPPER-VALIDITY
189 (defun pcl-check-wrapper-validity-hook (object)