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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.46 - (hide annotations)
Sat Mar 21 08:12:02 1998 UTC (16 years, 1 month ago) by dtc
Branch: MAIN
Changes since 1.45: +6 -3 lines
Long-float support.
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.46 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/pred.lisp,v 1.46 1998/03/21 08:12:02 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     array atom bignum bit bit-vector character common
33     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.46 #+complex-float complex-double-float-p
58     #+complex-float complex-float-p
59     #+(and complex-float long-float) complex-long-float-p
60 dtc 1.42 #+complex-float complex-rational-p
61 dtc 1.40 #+complex-float 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.39 #+signed-array simple-array-signed-byte-8-p
98     #+signed-array simple-array-signed-byte-16-p
99     #+signed-array simple-array-signed-byte-30-p
100     #+signed-array 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.40 #+complex-float simple-array-complex-single-float-p
105     #+complex-float simple-array-complex-double-float-p
106 dtc 1.46 #+(and complex-float long-float) simple-array-complex-long-float-p
107 wlott 1.28 dylan::dylan-function-p
108 wlott 1.7 )))
109 ram 1.1
110 wlott 1.7 (macrolet
111     ((frob ()
112     `(progn
113     ,@(mapcar #'(lambda (pred)
114     `(defun ,pred (object)
115     ,(format nil
116     "Return T if OBJECT is a~:[~;n~] ~(~A~) ~
117     and NIL otherwise."
118     (find (schar (string pred) 0) "AEIOUaeiou")
119     (string pred))
120     (,pred object)))
121     primitive-predicates))))
122     (frob))
123 ram 1.1
124    
125 wlott 1.7 ;;;; TYPE-OF -- public.
126     ;;;
127     ;;; Return the specifier for the type of object. This is not simply
128     ;;; (type-specifier (ctype-of object)) because ctype-of has different goals
129 ram 1.29 ;;; than type-of. In particular, speed is more important than precision, and
130     ;;; it is not permitted to return member types.
131 wlott 1.7 ;;;
132 ram 1.1 (defun type-of (object)
133 wlott 1.7 "Return the type of OBJECT."
134 dtc 1.43 (if (typep object '(or function array #+complex-float complex))
135 ram 1.29 (type-specifier (ctype-of object))
136     (let* ((class (layout-class (layout-of object)))
137     (name (class-name class)))
138 ram 1.30 (if (%instancep object)
139 ram 1.29 (case name
140     (alien-internals:alien-value
141     `(alien:alien
142     ,(alien-internals:unparse-alien-type
143     (alien-internals:alien-value-type object))))
144     (t
145     (class-proper-name class)))
146     name))))
147 wlott 1.8
148 ram 1.22
149     ;;;; UPGRADED-ARRAY-ELEMENT-TYPE -- public
150     ;;;
151     (defun upgraded-array-element-type (spec)
152     "Return the element type that will actually be used to implement an array
153     with the specifier :ELEMENT-TYPE Spec."
154     (type-specifier
155     (array-type-specialized-element-type
156     (specifier-type `(array ,spec)))))
157 wlott 1.7
158     ;;;; SUBTYPEP -- public.
159 ram 1.1 ;;;
160 wlott 1.7 ;;; Just parse the type specifiers and call csubtype.
161     ;;;
162     (defun subtypep (type1 type2)
163     "Return two values indicating the relationship between type1 and type2:
164 ram 1.33 T and T: type1 definitely is a subtype of type2.
165     NIL and T: type1 definitely is not a subtype of type2.
166 wlott 1.7 NIL and NIL: who knows?"
167     (csubtypep (specifier-type type1) (specifier-type type2)))
168 ram 1.1
169    
170 ram 1.33 ;;;; TYPEP:
171    
172     (declaim (start-block typep %typep class-cell-typep))
173    
174     ;;; TYPEP -- public.
175 wlott 1.7 ;;;
176     ;;; Just call %typep
177     ;;;
178     (defun typep (object type)
179     "Return T iff OBJECT is of type TYPE."
180     (%typep object type))
181 ram 1.1
182 wlott 1.28
183 wlott 1.7 ;;; %TYPEP -- internal.
184 ram 1.1 ;;;
185 wlott 1.7 ;;; The actual typep engine. The compiler only generates calls to this
186     ;;; function when it can't figure out anything more intelligent to do.
187     ;;;
188     (defun %typep (object specifier)
189 wlott 1.13 (%%typep object
190     (if (ctype-p specifier)
191     specifier
192     (specifier-type specifier))))
193     ;;;
194     (defun %%typep (object type)
195     (declare (type ctype type))
196     (etypecase type
197     (named-type
198 ram 1.29 (ecase (named-type-name type)
199     ((* t) t)
200     ((nil) nil)))
201 wlott 1.13 (numeric-type
202     (and (numberp object)
203     (let ((num (if (complexp object) (realpart object) object)))
204     (ecase (numeric-type-class type)
205     (integer (integerp num))
206     (rational (rationalp num))
207     (float
208     (ecase (numeric-type-format type)
209 ram 1.35 (short-float (typep num 'short-float))
210     (single-float (typep num 'single-float))
211     (double-float (typep num 'double-float))
212     (long-float (typep num 'long-float))
213 wlott 1.13 ((nil) (floatp num))))
214 wlott 1.27 ((nil) t)))
215 dtc 1.44 #-negative-zero-is-not-zero
216 wlott 1.13 (flet ((bound-test (val)
217 ram 1.33 (let ((low (numeric-type-low type))
218     (high (numeric-type-high type)))
219     (and (cond ((null low) t)
220     ((listp low) (> val (car low)))
221     (t (>= val low)))
222     (cond ((null high) t)
223     ((listp high) (< val (car high)))
224     (t (<= val high)))))))
225 dtc 1.44 (ecase (numeric-type-complexp type)
226     ((nil) t)
227     (:complex
228     (and (complexp object)
229     (bound-test (realpart object))
230     (bound-test (imagpart object))))
231     (:real
232     (and (not (complexp object))
233     (bound-test object)))))
234     #+negative-zero-is-not-zero
235     (labels ((signed-> (x y)
236     (if (and (zerop x) (zerop y) (floatp x) (floatp y))
237     (> (float-sign x) (float-sign y))
238     (> x y)))
239     (signed->= (x y)
240     (if (and (zerop x) (zerop y) (floatp x) (floatp y))
241     (>= (float-sign x) (float-sign y))
242     (>= x y)))
243     (bound-test (val)
244     (let ((low (numeric-type-low type))
245     (high (numeric-type-high type)))
246     (and (cond ((null low) t)
247     ((listp low)
248     (signed-> val (car low)))
249     (t
250     (signed->= val low)))
251     (cond ((null high) t)
252     ((listp high)
253     (signed-> (car high) val))
254     (t
255     (signed->= high val)))))))
256 wlott 1.13 (ecase (numeric-type-complexp type)
257     ((nil) t)
258     (:complex
259     (and (complexp object)
260 wlott 1.26 (bound-test (realpart object))
261     (bound-test (imagpart object))))
262 wlott 1.13 (:real
263     (and (not (complexp object))
264     (bound-test object)))))))
265     (array-type
266     (and (arrayp object)
267     (ecase (array-type-complexp type)
268     ((t) (not (typep object 'simple-array)))
269     ((nil) (typep object 'simple-array))
270     (* t))
271     (or (eq (array-type-dimensions type) '*)
272     (do ((want (array-type-dimensions type) (cdr want))
273     (got (array-dimensions object) (cdr got)))
274     ((and (null want) (null got)) t)
275     (unless (and want got
276     (or (eq (car want) '*)
277     (= (car want) (car got))))
278     (return nil))))
279     (or (eq (array-type-element-type type) *wild-type*)
280     (type= (array-type-specialized-element-type type)
281     (specifier-type (array-element-type object))))))
282     (member-type
283     (if (member object (member-type-members type)) t))
284 ram 1.29 (class
285 pw 1.37 (class-typep (layout-of object) type object))
286 wlott 1.13 (union-type
287     (dolist (type (union-type-types type))
288     (when (%%typep object type)
289     (return t))))
290     (unknown-type
291 ram 1.29 ;; Parse it again to make sure it's really undefined.
292     (let ((reparse (specifier-type (unknown-type-specifier type))))
293     (if (typep reparse 'unknown-type)
294     (error "Unknown type specifier: ~S"
295     (unknown-type-specifier reparse))
296     (%%typep object reparse))))
297 wlott 1.13 (hairy-type
298     ;; Now the tricky stuff.
299     (let* ((hairy-spec (hairy-type-specifier type))
300     (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
301     (ecase symbol
302     (and
303     (or (atom hairy-spec)
304 ram 1.21 (dolist (spec (cdr hairy-spec) t)
305 wlott 1.14 (unless (%%typep object (specifier-type spec))
306 wlott 1.13 (return nil)))))
307     (not
308     (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
309     (error "Invalid type specifier: ~S" hairy-spec))
310 wlott 1.15 (not (%%typep object (specifier-type (cadr hairy-spec)))))
311 wlott 1.13 (satisfies
312     (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
313     (error "Invalid type specifier: ~S" hairy-spec))
314 wlott 1.17 (let ((fn (cadr hairy-spec)))
315     (if (funcall (typecase fn
316     (function fn)
317     (symbol (symbol-function fn))
318     (t
319     (coerce fn 'function)))
320     object)
321     t
322     nil))))))
323 wlott 1.23 (alien-type-type
324     (alien-internals:alien-typep object (alien-type-type-alien-type type)))
325 wlott 1.13 (function-type
326     (error "Function types are not a legal argument to TYPEP:~% ~S"
327     (type-specifier type)))))
328    
329 ram 1.1
330 ram 1.33 ;;; CLASS-CELL-TYPEP -- Interface
331     ;;;
332     ;;; Do type test from a class cell, allowing forward reference and
333     ;;; redefinition.
334     ;;;
335 pw 1.37 ;;; 2-Feb-97 add third arg optional for back compatibility and boot
336     (defun class-cell-typep (obj-layout cell &optional object)
337 ram 1.33 (let ((class (class-cell-class cell)))
338     (unless class
339     (error "Class has not yet been defined: ~S" (class-cell-name cell)))
340 pw 1.37 (class-typep obj-layout class object)))
341 ram 1.1
342 ram 1.33
343 ram 1.29 ;;; CLASS-TYPEP -- Internal
344 ram 1.1 ;;;
345 ram 1.29 ;;; Test whether Obj-Layout is from an instance of Class.
346 ram 1.1 ;;;
347 pw 1.37 (defun class-typep (obj-layout class object)
348 ram 1.1 (declare (optimize speed))
349 ram 1.29 (when (layout-invalid obj-layout)
350 pw 1.38 (if (and (typep (class-of object) 'standard-class) object)
351 pw 1.37 (setq obj-layout (pcl::check-wrapper-validity object))
352     (error "TYPEP on obsolete object (was class ~S)."
353     (class-proper-name (layout-class obj-layout)))))
354 ram 1.33 (let ((layout (class-layout class))
355     (obj-inherits (layout-inherits obj-layout)))
356 ram 1.29 (when (layout-invalid layout)
357     (error "Class is currently invalid: ~S" class))
358 ram 1.33 (or (eq obj-layout layout)
359     (dotimes (i (length obj-inherits) nil)
360     (when (eq (svref obj-inherits i) layout)
361     (return t))))))
362    
363     (declaim (end-block))
364 ram 1.1
365    
366 wlott 1.7 ;;;; Equality predicates.
367 ram 1.1
368 wlott 1.7 ;;; EQ -- public.
369     ;;;
370     ;;; Real simple, 'cause the compiler takes care of it.
371     ;;;
372 ram 1.1
373 wlott 1.7 (defun eq (obj1 obj2)
374     "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
375     (eq obj1 obj2))
376 ram 1.1
377    
378 wlott 1.7 ;;; EQUAL -- public.
379     ;;;
380 ram 1.1 (defun equal (x y)
381     "Returns T if X and Y are EQL or if they are structured components
382     whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
383     are the same length and have indentical components. Other arrays must be
384     EQ to be EQUAL."
385     (cond ((eql x y) t)
386     ((consp x)
387     (and (consp y)
388     (equal (car x) (car y))
389     (equal (cdr x) (cdr y))))
390     ((stringp x)
391     (and (stringp y) (string= x y)))
392     ((pathnamep x)
393 ram 1.20 (and (pathnamep y) (pathname= x y)))
394 ram 1.1 ((bit-vector-p x)
395     (and (bit-vector-p y)
396     (= (the fixnum (length x))
397     (the fixnum (length y)))
398     (do ((i 0 (1+ i))
399     (length (length x)))
400     ((= i length) t)
401     (declare (fixnum i))
402     (or (= (the fixnum (bit x i))
403     (the fixnum (bit y i)))
404     (return nil)))))
405     (t nil)))
406    
407 wlott 1.7 ;;; EQUALP -- public.
408     ;;;
409 ram 1.1 (defun equalp (x y)
410     "Just like EQUAL, but more liberal in several respects.
411     Numbers may be of different types, as long as the values are identical
412     after coercion. Characters may differ in alphabetic case. Vectors and
413     arrays must have identical dimensions and EQUALP elements, but may differ
414     in their type restriction."
415 wlott 1.12 (cond ((eq x y) t)
416 ram 1.1 ((characterp x) (char-equal x y))
417     ((numberp x) (and (numberp y) (= x y)))
418     ((consp x)
419     (and (consp y)
420     (equalp (car x) (car y))
421     (equalp (cdr x) (cdr y))))
422 ram 1.20 ((pathnamep x)
423     (and (pathnamep y) (pathname= x y)))
424 ram 1.29 ((%instancep x)
425     (let* ((layout-x (%instance-layout x))
426     (len (layout-length layout-x)))
427     (and (%instancep y)
428     (eq layout-x (%instance-layout y))
429     (structure-class-p (layout-class layout-x))
430     (do ((i 1 (1+ i)))
431     ((= i len) t)
432     (declare (fixnum i))
433     (let ((x-el (%instance-ref x i))
434     (y-el (%instance-ref y i)))
435     (unless (or (eq x-el y-el)
436     (equalp x-el y-el))
437     (return nil)))))))
438 ram 1.1 ((vectorp x)
439     (let ((length (length x)))
440     (and (vectorp y)
441 wlott 1.7 (= length (length y))
442 ram 1.1 (dotimes (i length t)
443     (let ((x-el (aref x i))
444     (y-el (aref y i)))
445 wlott 1.12 (unless (or (eq x-el y-el)
446 ram 1.1 (equalp x-el y-el))
447     (return nil)))))))
448     ((arrayp x)
449 wlott 1.7 (and (arrayp y)
450     (= (array-rank x) (array-rank y))
451     (dotimes (axis (array-rank x) t)
452     (unless (= (array-dimension x axis)
453     (array-dimension y axis))
454     (return nil)))
455     (dotimes (index (array-total-size x) t)
456 wlott 1.12 (let ((x-el (row-major-aref x index))
457     (y-el (row-major-aref y index)))
458     (unless (or (eq x-el y-el)
459     (equalp x-el y-el))
460     (return nil))))))
461 ram 1.1 (t nil)))

  ViewVC Help
Powered by ViewVC 1.1.5