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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.55.2.1 - (show annotations)
Wed Mar 19 16:45:31 2003 UTC (11 years, 1 month ago) by gerd
Branch: cold-pcl
Changes since 1.55: +5 -5 lines
* code/defstruct.lisp, code/describe.lisp, code/error.lisp:
* code/exports.lisp, code/hash-new.lisp, code/hash.lisp
* code/macros.lisp, code/misc.lisp, code/package.lisp
* code/pred.lisp, code/sharpm.lisp, code/type.lisp:
Changes for lisp:class = pcl:class.

* compiler/dump.lisp, compiler/fndb.lisp, compiler/globaldb.lisp:
* compiler/ir1tran.lisp, compiler/ir1util.lisp:
* compiler/node.lisp, compiler/proclaim.lisp, compiler/typetran.lisp:
* compiler/xref.lisp, compiler/generic/primtype.lisp:
* compiler/generic/vm-type.lisp:
Likewise.

* code/class.lisp (toplevel): Shadow class, built-in-class etc.
(class): Give it conc-name %class-.
(toplevel) [#-lisp-class-is-pcl-class]: Define old accessors.
(everywhere): Use new class accessors.

* code/byte-interp.lisp (load-type-predicate):
Use kernel::structure-class instead of structure-class.
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.55.2.1 2003/03/19 16:45:31 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 (if (typep object '(or function array complex))
134 (type-specifier (ctype-of object))
135 (let* ((class (layout-class (layout-of object)))
136 (name (%class-name class)))
137 (if (%instancep object)
138 (case name
139 (alien-internals:alien-value
140 `(alien:alien
141 ,(alien-internals:unparse-alien-type
142 (alien-internals:alien-value-type object))))
143 (t
144 (class-proper-name class)))
145 name))))
146
147
148 ;;;; UPGRADED-ARRAY-ELEMENT-TYPE -- public
149 ;;;
150 (defun upgraded-array-element-type (spec &optional environment)
151 "Return the element type that will actually be used to implement an array
152 with the specifier :ELEMENT-TYPE Spec."
153 ;; Type expansion (TYPE-EXPAND) currently doesn't handle environments.
154 (declare (ignore environment))
155 (type-specifier
156 (array-type-specialized-element-type
157 (specifier-type `(array ,spec)))))
158
159 ;;;; SUBTYPEP -- public.
160 ;;;
161 ;;; Just parse the type specifiers and call csubtype.
162 ;;;
163 (defun subtypep (type1 type2 &optional environment)
164 "Return two values indicating the relationship between type1 and type2:
165 T and T: type1 definitely is a subtype of type2.
166 NIL and T: type1 definitely is not a subtype of type2.
167 NIL and NIL: who knows?"
168 (declare (ignore environment))
169 (csubtypep (specifier-type type1) (specifier-type type2)))
170
171
172 ;;;; TYPEP:
173
174 (declaim (start-block typep %typep class-cell-typep))
175
176 ;;; TYPEP -- public.
177 ;;;
178 ;;; Just call %typep
179 ;;;
180 (defun typep (object type &optional environment)
181 "Return T iff OBJECT is of type TYPE."
182 (declare (ignore environment))
183 (%typep object type))
184
185
186 ;;; %TYPEP -- internal.
187 ;;;
188 ;;; The actual typep engine. The compiler only generates calls to this
189 ;;; function when it can't figure out anything more intelligent to do.
190 ;;;
191 (defun %typep (object specifier)
192 (%%typep object
193 (if (ctype-p specifier)
194 specifier
195 (specifier-type specifier))))
196 ;;;
197 (defun %%typep (object type)
198 (declare (type ctype type))
199 (etypecase type
200 (named-type
201 (ecase (named-type-name type)
202 ((* t) t)
203 ((nil) nil)))
204 (numeric-type
205 (and (numberp object)
206 (let ((num (if (complexp object) (realpart object) object)))
207 (ecase (numeric-type-class type)
208 (integer (integerp num))
209 (rational (rationalp num))
210 (float
211 (ecase (numeric-type-format type)
212 (short-float (typep num 'short-float))
213 (single-float (typep num 'single-float))
214 (double-float (typep num 'double-float))
215 (long-float (typep num 'long-float))
216 ((nil) (floatp num))))
217 ((nil) t)))
218 #-negative-zero-is-not-zero
219 (flet ((bound-test (val)
220 (let ((low (numeric-type-low type))
221 (high (numeric-type-high type)))
222 (and (cond ((null low) t)
223 ((listp low) (> val (car low)))
224 (t (>= val low)))
225 (cond ((null high) t)
226 ((listp high) (< val (car high)))
227 (t (<= val high)))))))
228 (ecase (numeric-type-complexp type)
229 ((nil) t)
230 (:complex
231 (and (complexp object)
232 (bound-test (realpart object))
233 (bound-test (imagpart object))))
234 (:real
235 (and (not (complexp object))
236 (bound-test object)))))
237 #+negative-zero-is-not-zero
238 (labels ((signed-> (x y)
239 (if (and (zerop x) (zerop y) (floatp x) (floatp y))
240 (> (float-sign x) (float-sign y))
241 (> x y)))
242 (signed->= (x y)
243 (if (and (zerop x) (zerop y) (floatp x) (floatp y))
244 (>= (float-sign x) (float-sign y))
245 (>= x y)))
246 (bound-test (val)
247 (let ((low (numeric-type-low type))
248 (high (numeric-type-high type)))
249 (and (cond ((null low) t)
250 ((listp low)
251 (signed-> val (car low)))
252 (t
253 (signed->= val low)))
254 (cond ((null high) t)
255 ((listp high)
256 (signed-> (car high) val))
257 (t
258 (signed->= high val)))))))
259 (ecase (numeric-type-complexp type)
260 ((nil) t)
261 (:complex
262 (and (complexp object)
263 (bound-test (realpart object))
264 (bound-test (imagpart object))))
265 (:real
266 (and (not (complexp object))
267 (bound-test object)))))))
268 (array-type
269 (and (arrayp object)
270 (ecase (array-type-complexp type)
271 ((t) (not (typep object 'simple-array)))
272 ((nil) (typep object 'simple-array))
273 (* t))
274 (or (eq (array-type-dimensions type) '*)
275 (do ((want (array-type-dimensions type) (cdr want))
276 (got (array-dimensions object) (cdr got)))
277 ((and (null want) (null got)) t)
278 (unless (and want got
279 (or (eq (car want) '*)
280 (= (car want) (car got))))
281 (return nil))))
282 (or (eq (array-type-element-type type) *wild-type*)
283 (values
284 (type= (array-type-specialized-element-type type)
285 (specifier-type (array-element-type object)))))))
286 (member-type
287 (if (member object (member-type-members type)) t))
288 (kernel::class
289 (class-typep (layout-of object) type object))
290 (union-type
291 (dolist (type (union-type-types type))
292 (when (%%typep object type)
293 (return t))))
294 (cons-type
295 (and (consp object)
296 (%%typep (car object) (cons-type-car-type type))
297 (%%typep (cdr object) (cons-type-cdr-type type))))
298 (unknown-type
299 ;; Parse it again to make sure it's really undefined.
300 (let ((reparse (specifier-type (unknown-type-specifier type))))
301 (if (typep reparse 'unknown-type)
302 (error "Unknown type specifier: ~S"
303 (unknown-type-specifier reparse))
304 (%%typep object reparse))))
305 (hairy-type
306 ;; Now the tricky stuff.
307 (let* ((hairy-spec (hairy-type-specifier type))
308 (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
309 (ecase symbol
310 (and
311 (or (atom hairy-spec)
312 (dolist (spec (cdr hairy-spec) t)
313 (unless (%%typep object (specifier-type spec))
314 (return nil)))))
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