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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5