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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5