/[cmucl]/src/code/pred.lisp
ViewVC logotype

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.41 - (show annotations)
Fri Nov 7 17:11:19 1997 UTC (16 years, 5 months ago) by dtc
Branch: MAIN
Changes since 1.40: +2 -1 lines
Add a complex-float-p predicate to the backend which can be handled
efficiently inline with the complex-float support.
1 ;;; -*- Mode: Lisp; Package: LISP; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/pred.lisp,v 1.41 1997/11/07 17:11:19 dtc Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Predicate functions for CMU Common Lisp.
13 ;;;
14 ;;; Written by William Lott.
15 ;;;
16
17 (in-package "KERNEL")
18 (export '(%instancep instance fixnump bignump bitp ratiop weak-pointer-p
19 %typep class-cell-typep))
20
21 (in-package "SYSTEM")
22 (export '(system-area-pointer system-area-pointer-p))
23
24 (in-package "LISP")
25
26 (export '(typep null symbolp atom consp listp numberp integerp rationalp
27 floatp complexp characterp stringp bit-vector-p vectorp
28 simple-vector-p simple-string-p simple-bit-vector-p arrayp
29 functionp compiled-function-p eq eql equal equalp not
30 type-of upgraded-array-element-type realp
31 ;; Names of types...
32 array atom bignum bit bit-vector character common
33 compiled-function complex cons double-float
34 fixnum float function integer keyword list long-float nil
35 null number ratio rational real sequence short-float signed-byte
36 simple-array simple-bit-vector simple-string simple-vector
37 single-float standard-char string string-char symbol t
38 unsigned-byte vector satisfies))
39
40
41
42 ;;;; Primitive predicates. These must be supported by the compiler.
43
44 (eval-when (compile eval)
45 (defparameter primitive-predicates
46 '(array-header-p
47 arrayp
48 atom
49 base-char-p
50 bignump
51 bit-vector-p
52 characterp
53 code-component-p
54 consp
55 compiled-function-p
56 complexp
57 #+complex-float complex-float-p
58 #+complex-float complex-single-float-p
59 #+complex-float complex-double-float-p
60 double-float-p
61 fdefn-p
62 fixnump
63 floatp
64 functionp
65 integerp
66 listp
67 long-float-p
68 lra-p
69 not
70 null
71 numberp
72 rationalp
73 ratiop
74 realp
75 scavenger-hook-p
76 short-float-p
77 simple-array-p
78 simple-bit-vector-p
79 simple-string-p
80 simple-vector-p
81 single-float-p
82 stringp
83 %instancep
84 symbolp
85 system-area-pointer-p
86 weak-pointer-p
87 vectorp
88 unsigned-byte-32-p
89 signed-byte-32-p
90 simple-array-unsigned-byte-2-p
91 simple-array-unsigned-byte-4-p
92 simple-array-unsigned-byte-8-p
93 simple-array-unsigned-byte-16-p
94 simple-array-unsigned-byte-32-p
95 #+signed-array simple-array-signed-byte-8-p
96 #+signed-array simple-array-signed-byte-16-p
97 #+signed-array simple-array-signed-byte-30-p
98 #+signed-array simple-array-signed-byte-32-p
99 simple-array-single-float-p
100 simple-array-double-float-p
101 #+complex-float simple-array-complex-single-float-p
102 #+complex-float simple-array-complex-double-float-p
103 dylan::dylan-function-p
104 )))
105
106 (macrolet
107 ((frob ()
108 `(progn
109 ,@(mapcar #'(lambda (pred)
110 `(defun ,pred (object)
111 ,(format nil
112 "Return T if OBJECT is a~:[~;n~] ~(~A~) ~
113 and NIL otherwise."
114 (find (schar (string pred) 0) "AEIOUaeiou")
115 (string pred))
116 (,pred object)))
117 primitive-predicates))))
118 (frob))
119
120
121 ;;;; TYPE-OF -- public.
122 ;;;
123 ;;; Return the specifier for the type of object. This is not simply
124 ;;; (type-specifier (ctype-of object)) because ctype-of has different goals
125 ;;; than type-of. In particular, speed is more important than precision, and
126 ;;; it is not permitted to return member types.
127 ;;;
128 (defun type-of (object)
129 "Return the type of OBJECT."
130 (if (typep object '(or function array))
131 (type-specifier (ctype-of object))
132 (let* ((class (layout-class (layout-of object)))
133 (name (class-name class)))
134 (if (%instancep object)
135 (case name
136 (alien-internals:alien-value
137 `(alien:alien
138 ,(alien-internals:unparse-alien-type
139 (alien-internals:alien-value-type object))))
140 (t
141 (class-proper-name class)))
142 name))))
143
144
145 ;;;; UPGRADED-ARRAY-ELEMENT-TYPE -- public
146 ;;;
147 (defun upgraded-array-element-type (spec)
148 "Return the element type that will actually be used to implement an array
149 with the specifier :ELEMENT-TYPE Spec."
150 (type-specifier
151 (array-type-specialized-element-type
152 (specifier-type `(array ,spec)))))
153
154 ;;;; SUBTYPEP -- public.
155 ;;;
156 ;;; Just parse the type specifiers and call csubtype.
157 ;;;
158 (defun subtypep (type1 type2)
159 "Return two values indicating the relationship between type1 and type2:
160 T and T: type1 definitely is a subtype of type2.
161 NIL and T: type1 definitely is not a subtype of type2.
162 NIL and NIL: who knows?"
163 (csubtypep (specifier-type type1) (specifier-type type2)))
164
165
166 ;;;; TYPEP:
167
168 (declaim (start-block typep %typep class-cell-typep))
169
170 ;;; TYPEP -- public.
171 ;;;
172 ;;; Just call %typep
173 ;;;
174 (defun typep (object type)
175 "Return T iff OBJECT is of type TYPE."
176 (%typep object type))
177
178
179 ;;; %TYPEP -- internal.
180 ;;;
181 ;;; The actual typep engine. The compiler only generates calls to this
182 ;;; function when it can't figure out anything more intelligent to do.
183 ;;;
184 (defun %typep (object specifier)
185 (%%typep object
186 (if (ctype-p specifier)
187 specifier
188 (specifier-type specifier))))
189 ;;;
190 (defun %%typep (object type)
191 (declare (type ctype type))
192 (etypecase type
193 (named-type
194 (ecase (named-type-name type)
195 ((* t) t)
196 ((nil) nil)))
197 (numeric-type
198 (and (numberp object)
199 (let ((num (if (complexp object) (realpart object) object)))
200 (ecase (numeric-type-class type)
201 (integer (integerp num))
202 (rational (rationalp num))
203 (float
204 (ecase (numeric-type-format type)
205 (short-float (typep num 'short-float))
206 (single-float (typep num 'single-float))
207 (double-float (typep num 'double-float))
208 (long-float (typep num 'long-float))
209 ((nil) (floatp num))))
210 ((nil) t)))
211 (flet ((bound-test (val)
212 (let ((low (numeric-type-low type))
213 (high (numeric-type-high type)))
214 (and (cond ((null low) t)
215 ((listp low) (> val (car low)))
216 (t (>= val low)))
217 (cond ((null high) t)
218 ((listp high) (< val (car high)))
219 (t (<= val high)))))))
220 (ecase (numeric-type-complexp type)
221 ((nil) t)
222 (:complex
223 (and (complexp object)
224 (bound-test (realpart object))
225 (bound-test (imagpart object))))
226 (:real
227 (and (not (complexp object))
228 (bound-test object)))))))
229 (array-type
230 (and (arrayp object)
231 (ecase (array-type-complexp type)
232 ((t) (not (typep object 'simple-array)))
233 ((nil) (typep object 'simple-array))
234 (* t))
235 (or (eq (array-type-dimensions type) '*)
236 (do ((want (array-type-dimensions type) (cdr want))
237 (got (array-dimensions object) (cdr got)))
238 ((and (null want) (null got)) t)
239 (unless (and want got
240 (or (eq (car want) '*)
241 (= (car want) (car got))))
242 (return nil))))
243 (or (eq (array-type-element-type type) *wild-type*)
244 (type= (array-type-specialized-element-type type)
245 (specifier-type (array-element-type object))))))
246 (member-type
247 (if (member object (member-type-members type)) t))
248 (class
249 (class-typep (layout-of object) type object))
250 (union-type
251 (dolist (type (union-type-types type))
252 (when (%%typep object type)
253 (return t))))
254 (unknown-type
255 ;; Parse it again to make sure it's really undefined.
256 (let ((reparse (specifier-type (unknown-type-specifier type))))
257 (if (typep reparse 'unknown-type)
258 (error "Unknown type specifier: ~S"
259 (unknown-type-specifier reparse))
260 (%%typep object reparse))))
261 (hairy-type
262 ;; Now the tricky stuff.
263 (let* ((hairy-spec (hairy-type-specifier type))
264 (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
265 (ecase symbol
266 (and
267 (or (atom hairy-spec)
268 (dolist (spec (cdr hairy-spec) t)
269 (unless (%%typep object (specifier-type spec))
270 (return nil)))))
271 (not
272 (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
273 (error "Invalid type specifier: ~S" hairy-spec))
274 (not (%%typep object (specifier-type (cadr hairy-spec)))))
275 (satisfies
276 (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
277 (error "Invalid type specifier: ~S" hairy-spec))
278 (let ((fn (cadr hairy-spec)))
279 (if (funcall (typecase fn
280 (function fn)
281 (symbol (symbol-function fn))
282 (t
283 (coerce fn 'function)))
284 object)
285 t
286 nil))))))
287 (alien-type-type
288 (alien-internals:alien-typep object (alien-type-type-alien-type type)))
289 (function-type
290 (error "Function types are not a legal argument to TYPEP:~% ~S"
291 (type-specifier type)))))
292
293
294 ;;; CLASS-CELL-TYPEP -- Interface
295 ;;;
296 ;;; Do type test from a class cell, allowing forward reference and
297 ;;; redefinition.
298 ;;;
299 ;;; 2-Feb-97 add third arg optional for back compatibility and boot
300 (defun class-cell-typep (obj-layout cell &optional object)
301 (let ((class (class-cell-class cell)))
302 (unless class
303 (error "Class has not yet been defined: ~S" (class-cell-name cell)))
304 (class-typep obj-layout class object)))
305
306
307 ;;; CLASS-TYPEP -- Internal
308 ;;;
309 ;;; Test whether Obj-Layout is from an instance of Class.
310 ;;;
311 (defun class-typep (obj-layout class object)
312 (declare (optimize speed))
313 (when (layout-invalid obj-layout)
314 (if (and (typep (class-of object) 'standard-class) object)
315 (setq obj-layout (pcl::check-wrapper-validity object))
316 (error "TYPEP on obsolete object (was class ~S)."
317 (class-proper-name (layout-class obj-layout)))))
318 (let ((layout (class-layout class))
319 (obj-inherits (layout-inherits obj-layout)))
320 (when (layout-invalid layout)
321 (error "Class is currently invalid: ~S" class))
322 (or (eq obj-layout layout)
323 (dotimes (i (length obj-inherits) nil)
324 (when (eq (svref obj-inherits i) layout)
325 (return t))))))
326
327 (declaim (end-block))
328
329
330 ;;;; Equality predicates.
331
332 ;;; EQ -- public.
333 ;;;
334 ;;; Real simple, 'cause the compiler takes care of it.
335 ;;;
336
337 (defun eq (obj1 obj2)
338 "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
339 (eq obj1 obj2))
340
341
342 ;;; EQUAL -- public.
343 ;;;
344 (defun equal (x y)
345 "Returns T if X and Y are EQL or if they are structured components
346 whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
347 are the same length and have indentical components. Other arrays must be
348 EQ to be EQUAL."
349 (cond ((eql x y) t)
350 ((consp x)
351 (and (consp y)
352 (equal (car x) (car y))
353 (equal (cdr x) (cdr y))))
354 ((stringp x)
355 (and (stringp y) (string= x y)))
356 ((pathnamep x)
357 (and (pathnamep y) (pathname= x y)))
358 ((bit-vector-p x)
359 (and (bit-vector-p y)
360 (= (the fixnum (length x))
361 (the fixnum (length y)))
362 (do ((i 0 (1+ i))
363 (length (length x)))
364 ((= i length) t)
365 (declare (fixnum i))
366 (or (= (the fixnum (bit x i))
367 (the fixnum (bit y i)))
368 (return nil)))))
369 (t nil)))
370
371 ;;; EQUALP -- public.
372 ;;;
373 (defun equalp (x y)
374 "Just like EQUAL, but more liberal in several respects.
375 Numbers may be of different types, as long as the values are identical
376 after coercion. Characters may differ in alphabetic case. Vectors and
377 arrays must have identical dimensions and EQUALP elements, but may differ
378 in their type restriction."
379 (cond ((eq x y) t)
380 ((characterp x) (char-equal x y))
381 ((numberp x) (and (numberp y) (= x y)))
382 ((consp x)
383 (and (consp y)
384 (equalp (car x) (car y))
385 (equalp (cdr x) (cdr y))))
386 ((pathnamep x)
387 (and (pathnamep y) (pathname= x y)))
388 ((%instancep x)
389 (let* ((layout-x (%instance-layout x))
390 (len (layout-length layout-x)))
391 (and (%instancep y)
392 (eq layout-x (%instance-layout y))
393 (structure-class-p (layout-class layout-x))
394 (do ((i 1 (1+ i)))
395 ((= i len) t)
396 (declare (fixnum i))
397 (let ((x-el (%instance-ref x i))
398 (y-el (%instance-ref y i)))
399 (unless (or (eq x-el y-el)
400 (equalp x-el y-el))
401 (return nil)))))))
402 ((vectorp x)
403 (let ((length (length x)))
404 (and (vectorp y)
405 (= length (length y))
406 (dotimes (i length t)
407 (let ((x-el (aref x i))
408 (y-el (aref y i)))
409 (unless (or (eq x-el y-el)
410 (equalp x-el y-el))
411 (return nil)))))))
412 ((arrayp x)
413 (and (arrayp y)
414 (= (array-rank x) (array-rank y))
415 (dotimes (axis (array-rank x) t)
416 (unless (= (array-dimension x axis)
417 (array-dimension y axis))
418 (return nil)))
419 (dotimes (index (array-total-size x) t)
420 (let ((x-el (row-major-aref x index))
421 (y-el (row-major-aref y index)))
422 (unless (or (eq x-el y-el)
423 (equalp x-el y-el))
424 (return nil))))))
425 (t nil)))

  ViewVC Help
Powered by ViewVC 1.1.5