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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.65 - (hide annotations)
Tue Apr 20 17:57:45 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.64: +9 -9 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
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 rtoy 1.65 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/pred.lisp,v 1.65 2010/04/20 17:57:45 rtoy Rel $")
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 rtoy 1.63 (intl:textdomain "cmucl")
19    
20 ram 1.29 (export '(%instancep instance fixnump bignump bitp ratiop weak-pointer-p
21 rtoy 1.60 %typep class-cell-typep))
22    
23     #+double-double
24     (export '(double-double-float-p))
25 wlott 1.7
26     (in-package "SYSTEM")
27     (export '(system-area-pointer system-area-pointer-p))
28    
29 ram 1.33 (in-package "LISP")
30 wlott 1.7
31 ram 1.1 (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 pw 1.36 functionp compiled-function-p eq eql equal equalp not
35 wlott 1.26 type-of upgraded-array-element-type realp
36 ram 1.1 ;; Names of types...
37 dtc 1.48 array atom bignum bit bit-vector character
38 ram 1.1 compiled-function complex cons double-float
39     fixnum float function integer keyword list long-float nil
40 wlott 1.7 null number ratio rational real sequence short-float signed-byte
41 ram 1.1 simple-array simple-bit-vector simple-string simple-vector
42 dtc 1.45 single-float standard-char base-char string symbol t
43 ram 1.29 unsigned-byte vector satisfies))
44 ram 1.1
45    
46 wlott 1.7
47     ;;;; Primitive predicates. These must be supported by the compiler.
48 ram 1.1
49 wlott 1.7 (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 wlott 1.18 code-component-p
59 wlott 1.7 consp
60     compiled-function-p
61     complexp
62 dtc 1.49 complex-double-float-p
63     complex-float-p
64     #+long-float complex-long-float-p
65 rtoy 1.60 #+double-double complex-double-double-float-p
66 dtc 1.49 complex-rational-p
67     complex-single-float-p
68 rtoy 1.60 #+double-double double-double-float-p
69 wlott 1.7 double-float-p
70 wlott 1.25 fdefn-p
71 wlott 1.7 fixnump
72     floatp
73     functionp
74     integerp
75     listp
76 wlott 1.10 long-float-p
77 wlott 1.18 lra-p
78 wlott 1.7 not
79     null
80     numberp
81     rationalp
82     ratiop
83     realp
84 wlott 1.18 scavenger-hook-p
85 wlott 1.10 short-float-p
86 wlott 1.7 simple-array-p
87     simple-bit-vector-p
88     simple-string-p
89     simple-vector-p
90     single-float-p
91     stringp
92 ram 1.29 %instancep
93 wlott 1.7 symbolp
94     system-area-pointer-p
95     weak-pointer-p
96     vectorp
97 ram 1.20 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 dtc 1.49 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 ram 1.20 simple-array-single-float-p
109     simple-array-double-float-p
110 dtc 1.46 #+long-float simple-array-long-float-p
111 rtoy 1.60 #+double-double simple-array-double-double-float-p
112 dtc 1.49 simple-array-complex-single-float-p
113     simple-array-complex-double-float-p
114     #+long-float simple-array-complex-long-float-p
115 rtoy 1.60 #+double-double simple-array-complex-double-double-float-p
116 wlott 1.7 )))
117 ram 1.1
118 wlott 1.7 (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 ram 1.1
132    
133 wlott 1.7 ;;;; 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 ram 1.29 ;;; than type-of. In particular, speed is more important than precision, and
138     ;;; it is not permitted to return member types.
139 wlott 1.7 ;;;
140 ram 1.1 (defun type-of (object)
141 rtoy 1.64 "Return the type of OBJECT."
142 gerd 1.59 (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 wlott 1.8
166 ram 1.22
167     ;;;; UPGRADED-ARRAY-ELEMENT-TYPE -- public
168     ;;;
169 toy 1.55 (defun upgraded-array-element-type (spec &optional environment)
170 rtoy 1.64 "Return the element type that will actually be used to implement an array
171 ram 1.22 with the specifier :ELEMENT-TYPE Spec."
172 toy 1.55 ;; Type expansion (TYPE-EXPAND) currently doesn't handle environments.
173     (declare (ignore environment))
174 ram 1.22 (type-specifier
175     (array-type-specialized-element-type
176     (specifier-type `(array ,spec)))))
177 wlott 1.7
178     ;;;; SUBTYPEP -- public.
179 ram 1.1 ;;;
180 wlott 1.7 ;;; Just parse the type specifiers and call csubtype.
181     ;;;
182 toy 1.55 (defun subtypep (type1 type2 &optional environment)
183 rtoy 1.64 "Return two values indicating the relationship between type1 and type2:
184 ram 1.33 T and T: type1 definitely is a subtype of type2.
185     NIL and T: type1 definitely is not a subtype of type2.
186 wlott 1.7 NIL and NIL: who knows?"
187 toy 1.55 (declare (ignore environment))
188 wlott 1.7 (csubtypep (specifier-type type1) (specifier-type type2)))
189 ram 1.1
190    
191 ram 1.33 ;;;; TYPEP:
192    
193     (declaim (start-block typep %typep class-cell-typep))
194    
195     ;;; TYPEP -- public.
196 wlott 1.7 ;;;
197     ;;; Just call %typep
198     ;;;
199 toy 1.55 (defun typep (object type &optional environment)
200 rtoy 1.64 "Return T iff OBJECT is of type TYPE."
201 toy 1.55 (declare (ignore environment))
202 wlott 1.7 (%typep object type))
203 ram 1.1
204 wlott 1.28
205 wlott 1.7 ;;; %TYPEP -- internal.
206 ram 1.1 ;;;
207 wlott 1.7 ;;; 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 wlott 1.13 (%%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 ram 1.29 (ecase (named-type-name type)
221     ((* t) t)
222     ((nil) nil)))
223 wlott 1.13 (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 ram 1.35 (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 rtoy 1.60 (double-double-float (typep num 'double-double-float))
236 wlott 1.13 ((nil) (floatp num))))
237 wlott 1.27 ((nil) t)))
238 wlott 1.13 (flet ((bound-test (val)
239 ram 1.33 (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 wlott 1.13 (ecase (numeric-type-complexp type)
248     ((nil) t)
249     (:complex
250     (and (complexp object)
251 wlott 1.26 (bound-test (realpart object))
252     (bound-test (imagpart object))))
253 wlott 1.13 (: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 gerd 1.57 ((* :maybe) t))
262 wlott 1.13 (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 gerd 1.57 (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 rtoy 1.65 (error (intl:gettext "~@<unknown element type in array type: ~2I~_~S~:>")
274 gerd 1.57 (type-specifier type))
275     t)
276 wlott 1.13 (or (eq (array-type-element-type type) *wild-type*)
277 gerd 1.57 (values (type= (array-type-specialized-element-type type)
278     (specifier-type (array-element-type
279     object)))))))
280 wlott 1.13 (member-type
281     (if (member object (member-type-members type)) t))
282 gerd 1.56 (kernel::class
283 pw 1.37 (class-typep (layout-of object) type object))
284 wlott 1.13 (union-type
285 gerd 1.57 (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 dtc 1.52 (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 wlott 1.13 (unknown-type
295 ram 1.29 ;; 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 rtoy 1.65 (error (intl:gettext "Unknown type specifier: ~S")
299 ram 1.29 (unknown-type-specifier reparse))
300     (%%typep object reparse))))
301 gerd 1.57 (negation-type
302     (not (%%typep object (negation-type-type type))))
303 wlott 1.13 (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 gerd 1.57 (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 wlott 1.13 (not
316     (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
317 rtoy 1.65 (error (intl:gettext "Invalid type specifier: ~S") hairy-spec))
318 wlott 1.15 (not (%%typep object (specifier-type (cadr hairy-spec)))))
319 wlott 1.13 (satisfies
320     (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
321 rtoy 1.65 (error (intl:gettext "Invalid type specifier: ~S") hairy-spec))
322 wlott 1.17 (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 wlott 1.23 (alien-type-type
332     (alien-internals:alien-typep object (alien-type-type-alien-type type)))
333 wlott 1.13 (function-type
334 rtoy 1.65 (error (intl:gettext "Function types are not a legal argument to TYPEP:~% ~S")
335 wlott 1.13 (type-specifier type)))))
336    
337 ram 1.1
338 ram 1.33 ;;; CLASS-CELL-TYPEP -- Interface
339     ;;;
340     ;;; Do type test from a class cell, allowing forward reference and
341     ;;; redefinition.
342     ;;;
343 dtc 1.47 (defun class-cell-typep (obj-layout cell object)
344 ram 1.33 (let ((class (class-cell-class cell)))
345     (unless class
346 rtoy 1.65 (error (intl:gettext "Class has not yet been defined: ~S") (class-cell-name cell)))
347 pw 1.37 (class-typep obj-layout class object)))
348 ram 1.1
349 ram 1.33
350 ram 1.29 ;;; CLASS-TYPEP -- Internal
351 ram 1.1 ;;;
352 ram 1.29 ;;; Test whether Obj-Layout is from an instance of Class.
353 ram 1.1 ;;;
354 pw 1.37 (defun class-typep (obj-layout class object)
355 ram 1.1 (declare (optimize speed))
356 ram 1.29 (when (layout-invalid obj-layout)
357 gerd 1.56 (if (and (typep (kernel::class-of object) 'kernel::standard-class) object)
358 pw 1.37 (setq obj-layout (pcl::check-wrapper-validity object))
359 rtoy 1.65 (error (intl:gettext "TYPEP on obsolete object (was class ~S).")
360 pw 1.37 (class-proper-name (layout-class obj-layout)))))
361 gerd 1.56 (let ((layout (%class-layout class))
362 ram 1.33 (obj-inherits (layout-inherits obj-layout)))
363 ram 1.29 (when (layout-invalid layout)
364 rtoy 1.65 (error (intl:gettext "Class is currently invalid: ~S") class))
365 ram 1.33 (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 ram 1.1
372    
373 wlott 1.7 ;;;; Equality predicates.
374 ram 1.1
375 wlott 1.7 ;;; EQ -- public.
376     ;;;
377     ;;; Real simple, 'cause the compiler takes care of it.
378     ;;;
379 ram 1.1
380 wlott 1.7 (defun eq (obj1 obj2)
381 rtoy 1.64 "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
382 wlott 1.7 (eq obj1 obj2))
383 ram 1.1
384    
385 wlott 1.7 ;;; EQUAL -- public.
386     ;;;
387 ram 1.1 (defun equal (x y)
388 rtoy 1.64 "Returns T if X and Y are EQL or if they are structured components
389 ram 1.1 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 ram 1.20 (and (pathnamep y) (pathname= x y)))
401 ram 1.1 ((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 wlott 1.7 ;;; EQUALP -- public.
415     ;;;
416 ram 1.1 (defun equalp (x y)
417 rtoy 1.64 "Just like EQUAL, but more liberal in several respects.
418 ram 1.1 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 wlott 1.12 (cond ((eq x y) t)
423 dtc 1.51 ((characterp x) (and (characterp y) (char-equal x y)))
424 ram 1.1 ((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 ram 1.20 ((pathnamep x)
430     (and (pathnamep y) (pathname= x y)))
431 dtc 1.53 ((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 ram 1.29 ((%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 ram 1.1 ((vectorp x)
461     (let ((length (length x)))
462     (and (vectorp y)
463 wlott 1.7 (= length (length y))
464 ram 1.1 (dotimes (i length t)
465     (let ((x-el (aref x i))
466     (y-el (aref y i)))
467 wlott 1.12 (unless (or (eq x-el y-el)
468 ram 1.1 (equalp x-el y-el))
469     (return nil)))))))
470     ((arrayp x)
471 wlott 1.7 (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 wlott 1.12 (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 ram 1.1 (t nil)))

  ViewVC Help
Powered by ViewVC 1.1.5