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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5