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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5