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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.55 - (hide annotations)
Wed Jan 29 02:16:30 2003 UTC (11 years, 2 months ago) by toy
Branch: MAIN
CVS Tags: release-18e-base, release-18e-pre2, cold-pcl-base, release-18e, release-18e-pre1
Branch point for: release-18e-branch, cold-pcl
Changes since 1.54: +8 -4 lines
From Gerd Moellmann:


o Entomotomy bug optional-environment-arg-mistakes:

  Recognize the optional environment argument for typep, subtypep,
  upgraded-array-element-type, upgraded-complex-part-type, and various
  other functions that take an optional environment arg.  Currently,
  all we do with the environment is ignore it.

o Entomotomy bug defknowns-for-bit-array-setters-wrong

  Defknowns for %bitset and %sbitset was only allowing vectors, not
  multidimensional arrays.
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 toy 1.55 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/pred.lisp,v 1.55 2003/01/29 02:16:30 toy 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 toy 1.55 (defun upgraded-array-element-type (spec &optional environment)
151 ram 1.22 "Return the element type that will actually be used to implement an array
152     with the specifier :ELEMENT-TYPE Spec."
153 toy 1.55 ;; Type expansion (TYPE-EXPAND) currently doesn't handle environments.
154     (declare (ignore environment))
155 ram 1.22 (type-specifier
156     (array-type-specialized-element-type
157     (specifier-type `(array ,spec)))))
158 wlott 1.7
159     ;;;; SUBTYPEP -- public.
160 ram 1.1 ;;;
161 wlott 1.7 ;;; Just parse the type specifiers and call csubtype.
162     ;;;
163 toy 1.55 (defun subtypep (type1 type2 &optional environment)
164 wlott 1.7 "Return two values indicating the relationship between type1 and type2:
165 ram 1.33 T and T: type1 definitely is a subtype of type2.
166     NIL and T: type1 definitely is not a subtype of type2.
167 wlott 1.7 NIL and NIL: who knows?"
168 toy 1.55 (declare (ignore environment))
169 wlott 1.7 (csubtypep (specifier-type type1) (specifier-type type2)))
170 ram 1.1
171    
172 ram 1.33 ;;;; TYPEP:
173    
174     (declaim (start-block typep %typep class-cell-typep))
175    
176     ;;; TYPEP -- public.
177 wlott 1.7 ;;;
178     ;;; Just call %typep
179     ;;;
180 toy 1.55 (defun typep (object type &optional environment)
181 wlott 1.7 "Return T iff OBJECT is of type TYPE."
182 toy 1.55 (declare (ignore environment))
183 wlott 1.7 (%typep object type))
184 ram 1.1
185 wlott 1.28
186 wlott 1.7 ;;; %TYPEP -- internal.
187 ram 1.1 ;;;
188 wlott 1.7 ;;; 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 wlott 1.13 (%%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 ram 1.29 (ecase (named-type-name type)
202     ((* t) t)
203     ((nil) nil)))
204 wlott 1.13 (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 ram 1.35 (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 wlott 1.13 ((nil) (floatp num))))
217 wlott 1.27 ((nil) t)))
218 dtc 1.44 #-negative-zero-is-not-zero
219 wlott 1.13 (flet ((bound-test (val)
220 ram 1.33 (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 dtc 1.44 (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 wlott 1.13 (ecase (numeric-type-complexp type)
260     ((nil) t)
261     (:complex
262     (and (complexp object)
263 wlott 1.26 (bound-test (realpart object))
264     (bound-test (imagpart object))))
265 wlott 1.13 (: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 pmai 1.54 (values
284     (type= (array-type-specialized-element-type type)
285     (specifier-type (array-element-type object)))))))
286 wlott 1.13 (member-type
287     (if (member object (member-type-members type)) t))
288 ram 1.29 (class
289 pw 1.37 (class-typep (layout-of object) type object))
290 wlott 1.13 (union-type
291     (dolist (type (union-type-types type))
292     (when (%%typep object type)
293     (return t))))
294 dtc 1.52 (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 wlott 1.13 (unknown-type
299 ram 1.29 ;; 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 wlott 1.13 (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 ram 1.21 (dolist (spec (cdr hairy-spec) t)
313 wlott 1.14 (unless (%%typep object (specifier-type spec))
314 wlott 1.13 (return nil)))))
315     (not
316     (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
317     (error "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     (error "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     (error "Function types are not a legal argument to TYPEP:~% ~S"
335     (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     (error "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 pw 1.38 (if (and (typep (class-of object) 'standard-class) object)
358 pw 1.37 (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 ram 1.33 (let ((layout (class-layout class))
362     (obj-inherits (layout-inherits obj-layout)))
363 ram 1.29 (when (layout-invalid layout)
364     (error "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     "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
382     (eq obj1 obj2))
383 ram 1.1
384    
385 wlott 1.7 ;;; EQUAL -- public.
386     ;;;
387 ram 1.1 (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 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     "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 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