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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5