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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.59 - (show annotations)
Fri Jun 6 12:22:33 2003 UTC (10 years, 10 months ago) by gerd
Branch: MAIN
CVS Tags: release-19b-pre1, release-19b-pre2, double-double-base, ppc_gencgc_snap_2006-01-06, snapshot-2003-10, snapshot-2004-10, snapshot-2004-08, snapshot-2004-09, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19c, dynamic-extent-base, release-19c-base, mod-arith-base, sparc_gencgc_merge, snapshot-2004-12, snapshot-2004-11, amd64-merge-start, ppc_gencgc_snap_2005-12-17, prm-before-macosx-merge-tag, snapshot-2003-11, snapshot-2005-07, release-19a-base, sparc_gencgc, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, release-19a, snapshot-2005-03, release-19b-base, snapshot-2005-11, snapshot-2004-04, snapshot-2005-10, snapshot-2005-12, snapshot-2005-01, release-19c-pre1, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2006-02, snapshot-2006-03, snapshot-2006-01, snapshot-2006-06, snapshot-2006-04, snapshot-2006-05
Branch point for: release-19b-branch, mod-arith-branch, sparc_gencgc_branch, dynamic-extent, ppc_gencgc_branch, lisp-executable, double-double-branch, release-19a-branch, release-19c-branch
Changes since 1.58: +24 -14 lines
	Various problems with TYPE-OF found by Paul Dietz.

	* src/pcl/methods.lisp (setf class-name) <before>: New method
	setting the kernel class' name.

	* src/code/pred.lisp (type-of): Don't return list function types.
	Return boolean for t, (integer n n) for integers, keyword for
	keywords, standard-char for standard characters.  Return
	the CLOS class for classes not having a proper name.
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.59 2003/06/06 12:22:33 gerd 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 )))
108
109 (macrolet
110 ((frob ()
111 `(progn
112 ,@(mapcar #'(lambda (pred)
113 `(defun ,pred (object)
114 ,(format nil
115 "Return T if OBJECT is a~:[~;n~] ~(~A~) ~
116 and NIL otherwise."
117 (find (schar (string pred) 0) "AEIOUaeiou")
118 (string pred))
119 (,pred object)))
120 primitive-predicates))))
121 (frob))
122
123
124 ;;;; TYPE-OF -- public.
125 ;;;
126 ;;; Return the specifier for the type of object. This is not simply
127 ;;; (type-specifier (ctype-of object)) because ctype-of has different goals
128 ;;; than type-of. In particular, speed is more important than precision, and
129 ;;; it is not permitted to return member types.
130 ;;;
131 (defun type-of (object)
132 "Return the type of OBJECT."
133 (typecase object
134 ((or array complex)
135 (type-specifier (ctype-of object)))
136 (integer
137 `(integer ,object ,object))
138 ((member t)
139 'boolean)
140 (keyword
141 'keyword)
142 (standard-char
143 'standard-char)
144 (t
145 (let* ((class (layout-class (layout-of object)))
146 (name (%class-name class)))
147 (if (%instancep object)
148 (if (eq name 'alien-internals:alien-value)
149 `(alien:alien ,(alien-internals:unparse-alien-type
150 (alien-internals:alien-value-type object)))
151 (let ((proper-name (class-proper-name class)))
152 (if (kernel::class-p proper-name)
153 (%class-pcl-class proper-name)
154 proper-name)))
155 name)))))
156
157
158 ;;;; UPGRADED-ARRAY-ELEMENT-TYPE -- public
159 ;;;
160 (defun upgraded-array-element-type (spec &optional environment)
161 "Return the element type that will actually be used to implement an array
162 with the specifier :ELEMENT-TYPE Spec."
163 ;; Type expansion (TYPE-EXPAND) currently doesn't handle environments.
164 (declare (ignore environment))
165 (type-specifier
166 (array-type-specialized-element-type
167 (specifier-type `(array ,spec)))))
168
169 ;;;; SUBTYPEP -- public.
170 ;;;
171 ;;; Just parse the type specifiers and call csubtype.
172 ;;;
173 (defun subtypep (type1 type2 &optional environment)
174 "Return two values indicating the relationship between type1 and type2:
175 T and T: type1 definitely is a subtype of type2.
176 NIL and T: type1 definitely is not a subtype of type2.
177 NIL and NIL: who knows?"
178 (declare (ignore environment))
179 (csubtypep (specifier-type type1) (specifier-type type2)))
180
181
182 ;;;; TYPEP:
183
184 (declaim (start-block typep %typep class-cell-typep))
185
186 ;;; TYPEP -- public.
187 ;;;
188 ;;; Just call %typep
189 ;;;
190 (defun typep (object type &optional environment)
191 "Return T iff OBJECT is of type TYPE."
192 (declare (ignore environment))
193 (%typep object type))
194
195
196 ;;; %TYPEP -- internal.
197 ;;;
198 ;;; The actual typep engine. The compiler only generates calls to this
199 ;;; function when it can't figure out anything more intelligent to do.
200 ;;;
201 (defun %typep (object specifier)
202 (%%typep object
203 (if (ctype-p specifier)
204 specifier
205 (specifier-type specifier))))
206 ;;;
207 (defun %%typep (object type)
208 (declare (type ctype type))
209 (etypecase type
210 (named-type
211 (ecase (named-type-name type)
212 ((* t) t)
213 ((nil) nil)))
214 (numeric-type
215 (and (numberp object)
216 (let ((num (if (complexp object) (realpart object) object)))
217 (ecase (numeric-type-class type)
218 (integer (integerp num))
219 (rational (rationalp num))
220 (float
221 (ecase (numeric-type-format type)
222 (short-float (typep num 'short-float))
223 (single-float (typep num 'single-float))
224 (double-float (typep num 'double-float))
225 (long-float (typep num 'long-float))
226 ((nil) (floatp num))))
227 ((nil) t)))
228 (flet ((bound-test (val)
229 (let ((low (numeric-type-low type))
230 (high (numeric-type-high type)))
231 (and (cond ((null low) t)
232 ((listp low) (> val (car low)))
233 (t (>= val low)))
234 (cond ((null high) t)
235 ((listp high) (< val (car high)))
236 (t (<= val high)))))))
237 (ecase (numeric-type-complexp type)
238 ((nil) t)
239 (:complex
240 (and (complexp object)
241 (bound-test (realpart object))
242 (bound-test (imagpart object))))
243 (:real
244 (and (not (complexp object))
245 (bound-test object)))))))
246 (array-type
247 (and (arrayp object)
248 (ecase (array-type-complexp type)
249 ((t) (not (typep object 'simple-array)))
250 ((nil) (typep object 'simple-array))
251 ((* :maybe) t))
252 (or (eq (array-type-dimensions type) '*)
253 (do ((want (array-type-dimensions type) (cdr want))
254 (got (array-dimensions object) (cdr got)))
255 ((and (null want) (null got)) t)
256 (unless (and want got
257 (or (eq (car want) '*)
258 (= (car want) (car got))))
259 (return nil))))
260 (if (unknown-type-p (array-type-element-type type))
261 ;; better to fail this way than to get bogosities like
262 ;; (TYPEP (MAKE-ARRAY 11) '(ARRAY SOME-UNDEFINED-TYPE)) => T
263 (error "~@<unknown element type in array type: ~2I~_~S~:>"
264 (type-specifier type))
265 t)
266 (or (eq (array-type-element-type type) *wild-type*)
267 (values (type= (array-type-specialized-element-type type)
268 (specifier-type (array-element-type
269 object)))))))
270 (member-type
271 (if (member object (member-type-members type)) t))
272 (kernel::class
273 (class-typep (layout-of object) type object))
274 (union-type
275 (some (lambda (type) (%%typep object type))
276 (union-type-types type)))
277 (intersection-type
278 (every (lambda (type) (%%typep object type))
279 (intersection-type-types type)))
280 (cons-type
281 (and (consp object)
282 (%%typep (car object) (cons-type-car-type type))
283 (%%typep (cdr object) (cons-type-cdr-type type))))
284 (unknown-type
285 ;; Parse it again to make sure it's really undefined.
286 (let ((reparse (specifier-type (unknown-type-specifier type))))
287 (if (typep reparse 'unknown-type)
288 (error "Unknown type specifier: ~S"
289 (unknown-type-specifier reparse))
290 (%%typep object reparse))))
291 (negation-type
292 (not (%%typep object (negation-type-type type))))
293 (hairy-type
294 ;; Now the tricky stuff.
295 (let* ((hairy-spec (hairy-type-specifier type))
296 (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
297 (ecase symbol
298 (and
299 (every (lambda (spec) (%%typep object (specifier-type spec)))
300 (rest hairy-spec)))
301 ;; Note: it should be safe to skip OR here, because union
302 ;; types can always be represented as UNION-TYPE in general
303 ;; or other CTYPEs in special cases; we never need to use
304 ;; HAIRY-TYPE for them.
305 (not
306 (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
307 (error "Invalid type specifier: ~S" hairy-spec))
308 (not (%%typep object (specifier-type (cadr hairy-spec)))))
309 (satisfies
310 (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
311 (error "Invalid type specifier: ~S" hairy-spec))
312 (let ((fn (cadr hairy-spec)))
313 (if (funcall (typecase fn
314 (function fn)
315 (symbol (symbol-function fn))
316 (t
317 (coerce fn 'function)))
318 object)
319 t
320 nil))))))
321 (alien-type-type
322 (alien-internals:alien-typep object (alien-type-type-alien-type type)))
323 (function-type
324 (error "Function types are not a legal argument to TYPEP:~% ~S"
325 (type-specifier type)))))
326
327
328 ;;; CLASS-CELL-TYPEP -- Interface
329 ;;;
330 ;;; Do type test from a class cell, allowing forward reference and
331 ;;; redefinition.
332 ;;;
333 (defun class-cell-typep (obj-layout cell object)
334 (let ((class (class-cell-class cell)))
335 (unless class
336 (error "Class has not yet been defined: ~S" (class-cell-name cell)))
337 (class-typep obj-layout class object)))
338
339
340 ;;; CLASS-TYPEP -- Internal
341 ;;;
342 ;;; Test whether Obj-Layout is from an instance of Class.
343 ;;;
344 (defun class-typep (obj-layout class object)
345 (declare (optimize speed))
346 (when (layout-invalid obj-layout)
347 (if (and (typep (kernel::class-of object) 'kernel::standard-class) object)
348 (setq obj-layout (pcl::check-wrapper-validity object))
349 (error "TYPEP on obsolete object (was class ~S)."
350 (class-proper-name (layout-class obj-layout)))))
351 (let ((layout (%class-layout class))
352 (obj-inherits (layout-inherits obj-layout)))
353 (when (layout-invalid layout)
354 (error "Class is currently invalid: ~S" class))
355 (or (eq obj-layout layout)
356 (dotimes (i (length obj-inherits) nil)
357 (when (eq (svref obj-inherits i) layout)
358 (return t))))))
359
360 (declaim (end-block))
361
362
363 ;;;; Equality predicates.
364
365 ;;; EQ -- public.
366 ;;;
367 ;;; Real simple, 'cause the compiler takes care of it.
368 ;;;
369
370 (defun eq (obj1 obj2)
371 "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
372 (eq obj1 obj2))
373
374
375 ;;; EQUAL -- public.
376 ;;;
377 (defun equal (x y)
378 "Returns T if X and Y are EQL or if they are structured components
379 whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
380 are the same length and have indentical components. Other arrays must be
381 EQ to be EQUAL."
382 (cond ((eql x y) t)
383 ((consp x)
384 (and (consp y)
385 (equal (car x) (car y))
386 (equal (cdr x) (cdr y))))
387 ((stringp x)
388 (and (stringp y) (string= x y)))
389 ((pathnamep x)
390 (and (pathnamep y) (pathname= x y)))
391 ((bit-vector-p x)
392 (and (bit-vector-p y)
393 (= (the fixnum (length x))
394 (the fixnum (length y)))
395 (do ((i 0 (1+ i))
396 (length (length x)))
397 ((= i length) t)
398 (declare (fixnum i))
399 (or (= (the fixnum (bit x i))
400 (the fixnum (bit y i)))
401 (return nil)))))
402 (t nil)))
403
404 ;;; EQUALP -- public.
405 ;;;
406 (defun equalp (x y)
407 "Just like EQUAL, but more liberal in several respects.
408 Numbers may be of different types, as long as the values are identical
409 after coercion. Characters may differ in alphabetic case. Vectors and
410 arrays must have identical dimensions and EQUALP elements, but may differ
411 in their type restriction."
412 (cond ((eq x y) t)
413 ((characterp x) (and (characterp y) (char-equal x y)))
414 ((numberp x) (and (numberp y) (= x y)))
415 ((consp x)
416 (and (consp y)
417 (equalp (car x) (car y))
418 (equalp (cdr x) (cdr y))))
419 ((pathnamep x)
420 (and (pathnamep y) (pathname= x y)))
421 ((hash-table-p x)
422 (and (hash-table-p y)
423 (eql (hash-table-count x) (hash-table-count y))
424 (eql (hash-table-test x) (hash-table-test y))
425 (with-hash-table-iterator (next x)
426 (loop
427 (multiple-value-bind (more x-key x-value)
428 (next)
429 (cond (more
430 (multiple-value-bind (y-value foundp)
431 (gethash x-key y)
432 (unless (and foundp (equalp x-value y-value))
433 (return nil))))
434 (t
435 (return t))))))))
436 ((%instancep x)
437 (let* ((layout-x (%instance-layout x))
438 (len (layout-length layout-x)))
439 (and (%instancep y)
440 (eq layout-x (%instance-layout y))
441 (structure-class-p (layout-class layout-x))
442 (do ((i 1 (1+ i)))
443 ((= i len) t)
444 (declare (fixnum i))
445 (let ((x-el (%instance-ref x i))
446 (y-el (%instance-ref y i)))
447 (unless (or (eq x-el y-el)
448 (equalp x-el y-el))
449 (return nil)))))))
450 ((vectorp x)
451 (let ((length (length x)))
452 (and (vectorp y)
453 (= length (length y))
454 (dotimes (i length t)
455 (let ((x-el (aref x i))
456 (y-el (aref y i)))
457 (unless (or (eq x-el y-el)
458 (equalp x-el y-el))
459 (return nil)))))))
460 ((arrayp x)
461 (and (arrayp y)
462 (= (array-rank x) (array-rank y))
463 (dotimes (axis (array-rank x) t)
464 (unless (= (array-dimension x axis)
465 (array-dimension y axis))
466 (return nil)))
467 (dotimes (index (array-total-size x) t)
468 (let ((x-el (row-major-aref x index))
469 (y-el (row-major-aref y index)))
470 (unless (or (eq x-el y-el)
471 (equalp x-el y-el))
472 (return nil))))))
473 (t nil)))

  ViewVC Help
Powered by ViewVC 1.1.5