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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.53 - (hide annotations)
Sun May 14 03:58:01 2000 UTC (13 years, 11 months ago) by dtc
Branch: MAIN
CVS Tags: LINKAGE_TABLE, PRE_LINKAGE_TABLE, UNICODE-BASE
Branch point for: UNICODE-BRANCH
Changes since 1.52: +16 -1 lines
Special case the handling of hash tables within equalp. This brings
equalp in line with the CL spec. and is necessary because the new hash
implementation maintains a reference back to the hash table within the
hash vector (for the garbage collector) which could cause infinite
recursion by equalp. Based on some good spotting and a patch from
Raymond Toy.
1 wlott 1.7 ;;; -*- Mode: Lisp; Package: LISP; Log: code.log -*-
2 ram 1.1 ;;;
3     ;;; **********************************************************************
4 ram 1.16 ;;; 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 dtc 1.53 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/pred.lisp,v 1.53 2000/05/14 03:58:01 dtc Exp $")
9 ram 1.16 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12 wlott 1.7 ;;; Predicate functions for CMU Common Lisp.
13 ram 1.1 ;;;
14 wlott 1.7 ;;; Written by William Lott.
15     ;;;
16    
17 ram 1.29 (in-package "KERNEL")
18     (export '(%instancep instance fixnump bignump bitp ratiop weak-pointer-p
19 ram 1.33 %typep class-cell-typep))
20 wlott 1.7
21     (in-package "SYSTEM")
22     (export '(system-area-pointer system-area-pointer-p))
23    
24 ram 1.33 (in-package "LISP")
25 wlott 1.7
26 ram 1.1 (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 pw 1.36 functionp compiled-function-p eq eql equal equalp not
30 wlott 1.26 type-of upgraded-array-element-type realp
31 ram 1.1 ;; Names of types...
32 dtc 1.48 array atom bignum bit bit-vector character
33 ram 1.1 compiled-function complex cons double-float
34     fixnum float function integer keyword list long-float nil
35 wlott 1.7 null number ratio rational real sequence short-float signed-byte
36 ram 1.1 simple-array simple-bit-vector simple-string simple-vector
37 dtc 1.45 single-float standard-char base-char string symbol t
38 ram 1.29 unsigned-byte vector satisfies))
39 ram 1.1
40    
41 wlott 1.7
42     ;;;; Primitive predicates. These must be supported by the compiler.
43 ram 1.1
44 wlott 1.7 (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 wlott 1.18 code-component-p
54 wlott 1.7 consp
55     compiled-function-p
56     complexp
57 dtc 1.49 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 wlott 1.7 double-float-p
63 wlott 1.25 fdefn-p
64 wlott 1.7 fixnump
65     floatp
66     functionp
67     integerp
68     listp
69 wlott 1.10 long-float-p
70 wlott 1.18 lra-p
71 wlott 1.7 not
72     null
73     numberp
74     rationalp
75     ratiop
76     realp
77 wlott 1.18 scavenger-hook-p
78 wlott 1.10 short-float-p
79 wlott 1.7 simple-array-p
80     simple-bit-vector-p
81     simple-string-p
82     simple-vector-p
83     single-float-p
84     stringp
85 ram 1.29 %instancep
86 wlott 1.7 symbolp
87     system-area-pointer-p
88     weak-pointer-p
89     vectorp
90 ram 1.20 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 dtc 1.49 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 ram 1.20 simple-array-single-float-p
102     simple-array-double-float-p
103 dtc 1.46 #+long-float simple-array-long-float-p
104 dtc 1.49 simple-array-complex-single-float-p
105     simple-array-complex-double-float-p
106     #+long-float simple-array-complex-long-float-p
107 wlott 1.7 )))
108 ram 1.1
109 wlott 1.7 (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 ram 1.1
123    
124 wlott 1.7 ;;;; 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 ram 1.29 ;;; than type-of. In particular, speed is more important than precision, and
129     ;;; it is not permitted to return member types.
130 wlott 1.7 ;;;
131 ram 1.1 (defun type-of (object)
132 wlott 1.7 "Return the type of OBJECT."
133 dtc 1.49 (if (typep object '(or function array complex))
134 ram 1.29 (type-specifier (ctype-of object))
135     (let* ((class (layout-class (layout-of object)))
136     (name (class-name class)))
137 ram 1.30 (if (%instancep object)
138 ram 1.29 (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 wlott 1.8
147 ram 1.22
148     ;;;; UPGRADED-ARRAY-ELEMENT-TYPE -- public
149     ;;;
150     (defun upgraded-array-element-type (spec)
151     "Return the element type that will actually be used to implement an array
152     with the specifier :ELEMENT-TYPE Spec."
153     (type-specifier
154     (array-type-specialized-element-type
155     (specifier-type `(array ,spec)))))
156 wlott 1.7
157     ;;;; SUBTYPEP -- public.
158 ram 1.1 ;;;
159 wlott 1.7 ;;; Just parse the type specifiers and call csubtype.
160     ;;;
161     (defun subtypep (type1 type2)
162     "Return two values indicating the relationship between type1 and type2:
163 ram 1.33 T and T: type1 definitely is a subtype of type2.
164     NIL and T: type1 definitely is not a subtype of type2.
165 wlott 1.7 NIL and NIL: who knows?"
166     (csubtypep (specifier-type type1) (specifier-type type2)))
167 ram 1.1
168    
169 ram 1.33 ;;;; TYPEP:
170    
171     (declaim (start-block typep %typep class-cell-typep))
172    
173     ;;; TYPEP -- public.
174 wlott 1.7 ;;;
175     ;;; Just call %typep
176     ;;;
177     (defun typep (object type)
178     "Return T iff OBJECT is of type TYPE."
179     (%typep object type))
180 ram 1.1
181 wlott 1.28
182 wlott 1.7 ;;; %TYPEP -- internal.
183 ram 1.1 ;;;
184 wlott 1.7 ;;; The actual typep engine. The compiler only generates calls to this
185     ;;; function when it can't figure out anything more intelligent to do.
186     ;;;
187     (defun %typep (object specifier)
188 wlott 1.13 (%%typep object
189     (if (ctype-p specifier)
190     specifier
191     (specifier-type specifier))))
192     ;;;
193     (defun %%typep (object type)
194     (declare (type ctype type))
195     (etypecase type
196     (named-type
197 ram 1.29 (ecase (named-type-name type)
198     ((* t) t)
199     ((nil) nil)))
200 wlott 1.13 (numeric-type
201     (and (numberp object)
202     (let ((num (if (complexp object) (realpart object) object)))
203     (ecase (numeric-type-class type)
204     (integer (integerp num))
205     (rational (rationalp num))
206     (float
207     (ecase (numeric-type-format type)
208 ram 1.35 (short-float (typep num 'short-float))
209     (single-float (typep num 'single-float))
210     (double-float (typep num 'double-float))
211     (long-float (typep num 'long-float))
212 wlott 1.13 ((nil) (floatp num))))
213 wlott 1.27 ((nil) t)))
214 dtc 1.44 #-negative-zero-is-not-zero
215 wlott 1.13 (flet ((bound-test (val)
216 ram 1.33 (let ((low (numeric-type-low type))
217     (high (numeric-type-high type)))
218     (and (cond ((null low) t)
219     ((listp low) (> val (car low)))
220     (t (>= val low)))
221     (cond ((null high) t)
222     ((listp high) (< val (car high)))
223     (t (<= val high)))))))
224 dtc 1.44 (ecase (numeric-type-complexp type)
225     ((nil) t)
226     (:complex
227     (and (complexp object)
228     (bound-test (realpart object))
229     (bound-test (imagpart object))))
230     (:real
231     (and (not (complexp object))
232     (bound-test object)))))
233     #+negative-zero-is-not-zero
234     (labels ((signed-> (x y)
235     (if (and (zerop x) (zerop y) (floatp x) (floatp y))
236     (> (float-sign x) (float-sign y))
237     (> x y)))
238     (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     (bound-test (val)
243     (let ((low (numeric-type-low type))
244     (high (numeric-type-high type)))
245     (and (cond ((null low) t)
246     ((listp low)
247     (signed-> val (car low)))
248     (t
249     (signed->= val low)))
250     (cond ((null high) t)
251     ((listp high)
252     (signed-> (car high) val))
253     (t
254     (signed->= high val)))))))
255 wlott 1.13 (ecase (numeric-type-complexp type)
256     ((nil) t)
257     (:complex
258     (and (complexp object)
259 wlott 1.26 (bound-test (realpart object))
260     (bound-test (imagpart object))))
261 wlott 1.13 (:real
262     (and (not (complexp object))
263     (bound-test object)))))))
264     (array-type
265     (and (arrayp object)
266     (ecase (array-type-complexp type)
267     ((t) (not (typep object 'simple-array)))
268     ((nil) (typep object 'simple-array))
269     (* t))
270     (or (eq (array-type-dimensions type) '*)
271     (do ((want (array-type-dimensions type) (cdr want))
272     (got (array-dimensions object) (cdr got)))
273     ((and (null want) (null got)) t)
274     (unless (and want got
275     (or (eq (car want) '*)
276     (= (car want) (car got))))
277     (return nil))))
278     (or (eq (array-type-element-type type) *wild-type*)
279     (type= (array-type-specialized-element-type type)
280     (specifier-type (array-element-type object))))))
281     (member-type
282     (if (member object (member-type-members type)) t))
283 ram 1.29 (class
284 pw 1.37 (class-typep (layout-of object) type object))
285 wlott 1.13 (union-type
286     (dolist (type (union-type-types type))
287     (when (%%typep object type)
288     (return t))))
289 dtc 1.52 (cons-type
290     (and (consp object)
291     (%%typep (car object) (cons-type-car-type type))
292     (%%typep (cdr object) (cons-type-cdr-type type))))
293 wlott 1.13 (unknown-type
294 ram 1.29 ;; Parse it again to make sure it's really undefined.
295     (let ((reparse (specifier-type (unknown-type-specifier type))))
296     (if (typep reparse 'unknown-type)
297     (error "Unknown type specifier: ~S"
298     (unknown-type-specifier reparse))
299     (%%typep object reparse))))
300 wlott 1.13 (hairy-type
301     ;; Now the tricky stuff.
302     (let* ((hairy-spec (hairy-type-specifier type))
303     (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
304     (ecase symbol
305     (and
306     (or (atom hairy-spec)
307 ram 1.21 (dolist (spec (cdr hairy-spec) t)
308 wlott 1.14 (unless (%%typep object (specifier-type spec))
309 wlott 1.13 (return nil)))))
310     (not
311     (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
312     (error "Invalid type specifier: ~S" hairy-spec))
313 wlott 1.15 (not (%%typep object (specifier-type (cadr hairy-spec)))))
314 wlott 1.13 (satisfies
315     (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
316     (error "Invalid type specifier: ~S" hairy-spec))
317 wlott 1.17 (let ((fn (cadr hairy-spec)))
318     (if (funcall (typecase fn
319     (function fn)
320     (symbol (symbol-function fn))
321     (t
322     (coerce fn 'function)))
323     object)
324     t
325     nil))))))
326 wlott 1.23 (alien-type-type
327     (alien-internals:alien-typep object (alien-type-type-alien-type type)))
328 wlott 1.13 (function-type
329     (error "Function types are not a legal argument to TYPEP:~% ~S"
330     (type-specifier type)))))
331    
332 ram 1.1
333 ram 1.33 ;;; CLASS-CELL-TYPEP -- Interface
334     ;;;
335     ;;; Do type test from a class cell, allowing forward reference and
336     ;;; redefinition.
337     ;;;
338 dtc 1.47 (defun class-cell-typep (obj-layout cell object)
339 ram 1.33 (let ((class (class-cell-class cell)))
340     (unless class
341     (error "Class has not yet been defined: ~S" (class-cell-name cell)))
342 pw 1.37 (class-typep obj-layout class object)))
343 ram 1.1
344 ram 1.33
345 ram 1.29 ;;; CLASS-TYPEP -- Internal
346 ram 1.1 ;;;
347 ram 1.29 ;;; Test whether Obj-Layout is from an instance of Class.
348 ram 1.1 ;;;
349 pw 1.37 (defun class-typep (obj-layout class object)
350 ram 1.1 (declare (optimize speed))
351 ram 1.29 (when (layout-invalid obj-layout)
352 pw 1.38 (if (and (typep (class-of object) 'standard-class) object)
353 pw 1.37 (setq obj-layout (pcl::check-wrapper-validity object))
354     (error "TYPEP on obsolete object (was class ~S)."
355     (class-proper-name (layout-class obj-layout)))))
356 ram 1.33 (let ((layout (class-layout class))
357     (obj-inherits (layout-inherits obj-layout)))
358 ram 1.29 (when (layout-invalid layout)
359     (error "Class is currently invalid: ~S" class))
360 ram 1.33 (or (eq obj-layout layout)
361     (dotimes (i (length obj-inherits) nil)
362     (when (eq (svref obj-inherits i) layout)
363     (return t))))))
364    
365     (declaim (end-block))
366 ram 1.1
367    
368 wlott 1.7 ;;;; Equality predicates.
369 ram 1.1
370 wlott 1.7 ;;; EQ -- public.
371     ;;;
372     ;;; Real simple, 'cause the compiler takes care of it.
373     ;;;
374 ram 1.1
375 wlott 1.7 (defun eq (obj1 obj2)
376     "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
377     (eq obj1 obj2))
378 ram 1.1
379    
380 wlott 1.7 ;;; EQUAL -- public.
381     ;;;
382 ram 1.1 (defun equal (x y)
383     "Returns T if X and Y are EQL or if they are structured components
384     whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
385     are the same length and have indentical components. Other arrays must be
386     EQ to be EQUAL."
387     (cond ((eql x y) t)
388     ((consp x)
389     (and (consp y)
390     (equal (car x) (car y))
391     (equal (cdr x) (cdr y))))
392     ((stringp x)
393     (and (stringp y) (string= x y)))
394     ((pathnamep x)
395 ram 1.20 (and (pathnamep y) (pathname= x y)))
396 ram 1.1 ((bit-vector-p x)
397     (and (bit-vector-p y)
398     (= (the fixnum (length x))
399     (the fixnum (length y)))
400     (do ((i 0 (1+ i))
401     (length (length x)))
402     ((= i length) t)
403     (declare (fixnum i))
404     (or (= (the fixnum (bit x i))
405     (the fixnum (bit y i)))
406     (return nil)))))
407     (t nil)))
408    
409 wlott 1.7 ;;; EQUALP -- public.
410     ;;;
411 ram 1.1 (defun equalp (x y)
412     "Just like EQUAL, but more liberal in several respects.
413     Numbers may be of different types, as long as the values are identical
414     after coercion. Characters may differ in alphabetic case. Vectors and
415     arrays must have identical dimensions and EQUALP elements, but may differ
416     in their type restriction."
417 wlott 1.12 (cond ((eq x y) t)
418 dtc 1.51 ((characterp x) (and (characterp y) (char-equal x y)))
419 ram 1.1 ((numberp x) (and (numberp y) (= x y)))
420     ((consp x)
421     (and (consp y)
422     (equalp (car x) (car y))
423     (equalp (cdr x) (cdr y))))
424 ram 1.20 ((pathnamep x)
425     (and (pathnamep y) (pathname= x y)))
426 dtc 1.53 ((hash-table-p x)
427     (and (hash-table-p y)
428     (eql (hash-table-count x) (hash-table-count y))
429     (eql (hash-table-test x) (hash-table-test y))
430     (with-hash-table-iterator (next x)
431     (loop
432     (multiple-value-bind (more x-key x-value)
433     (next)
434     (cond (more
435     (multiple-value-bind (y-value foundp)
436     (gethash x-key y)
437     (unless (and foundp (equalp x-value y-value))
438     (return nil))))
439     (t
440     (return t))))))))
441 ram 1.29 ((%instancep x)
442     (let* ((layout-x (%instance-layout x))
443     (len (layout-length layout-x)))
444     (and (%instancep y)
445     (eq layout-x (%instance-layout y))
446     (structure-class-p (layout-class layout-x))
447     (do ((i 1 (1+ i)))
448     ((= i len) t)
449     (declare (fixnum i))
450     (let ((x-el (%instance-ref x i))
451     (y-el (%instance-ref y i)))
452     (unless (or (eq x-el y-el)
453     (equalp x-el y-el))
454     (return nil)))))))
455 ram 1.1 ((vectorp x)
456     (let ((length (length x)))
457     (and (vectorp y)
458 wlott 1.7 (= length (length y))
459 ram 1.1 (dotimes (i length t)
460     (let ((x-el (aref x i))
461     (y-el (aref y i)))
462 wlott 1.12 (unless (or (eq x-el y-el)
463 ram 1.1 (equalp x-el y-el))
464     (return nil)))))))
465     ((arrayp x)
466 wlott 1.7 (and (arrayp y)
467     (= (array-rank x) (array-rank y))
468     (dotimes (axis (array-rank x) t)
469     (unless (= (array-dimension x axis)
470     (array-dimension y axis))
471     (return nil)))
472     (dotimes (index (array-total-size x) t)
473 wlott 1.12 (let ((x-el (row-major-aref x index))
474     (y-el (row-major-aref y index)))
475     (unless (or (eq x-el y-el)
476     (equalp x-el y-el))
477     (return nil))))))
478 ram 1.1 (t nil)))

  ViewVC Help
Powered by ViewVC 1.1.5