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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5