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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28.1.5 - (hide annotations) (vendor branch)
Wed Feb 10 23:40:13 1993 UTC (21 years, 2 months ago) by ram
Branch: new_struct
Changes since 1.28.1.4: +3 -3 lines
export class-typep, fix typo in equalp.
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.28.1.5 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/pred.lisp,v 1.28.1.5 1993/02/10 23:40:13 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.28.1.1 (in-package "KERNEL")
20 ram 1.28.1.3 (export '(%instancep instance fixnump bignump bitp ratiop weak-pointer-p
21 ram 1.28.1.5 %typep class-typep))
22 wlott 1.7
23     (in-package "SYSTEM")
24     (export '(system-area-pointer system-area-pointer-p))
25    
26     (in-package "LISP" :use "KERNEL")
27    
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.28.1.1 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.28.1.1 %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.28.1.3 ;;; 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.28.1.3 #-reload
122 ram 1.1 (defun type-of (object)
123 wlott 1.7 "Return the type of OBJECT."
124 ram 1.28.1.3 (if (typep object '(or function array))
125     (type-specifier (ctype-of object))
126     (let* ((class (layout-class (layout-of object)))
127     (name (class-name class)))
128     (if #-ns-boot(%instancep object)
129     #+ns-boot(structurep object)
130     (case name
131     (alien-internals:alien-value
132     `(alien:alien
133     ,(alien-internals:unparse-alien-type
134     (alien-internals:alien-value-type object))))
135     (t
136     (class-proper-name class)))
137     name))))
138 wlott 1.8
139 ram 1.22
140     ;;;; UPGRADED-ARRAY-ELEMENT-TYPE -- public
141     ;;;
142     (defun upgraded-array-element-type (spec)
143     "Return the element type that will actually be used to implement an array
144     with the specifier :ELEMENT-TYPE Spec."
145     (type-specifier
146     (array-type-specialized-element-type
147     (specifier-type `(array ,spec)))))
148 wlott 1.7
149     ;;;; SUBTYPEP -- public.
150 ram 1.1 ;;;
151 wlott 1.7 ;;; Just parse the type specifiers and call csubtype.
152     ;;;
153     (defun subtypep (type1 type2)
154     "Return two values indicating the relationship between type1 and type2:
155     T and T: type1 definatly is a subtype of type2.
156     NIL and T: type1 definatly is not a subtype of type2.
157     NIL and NIL: who knows?"
158     (csubtypep (specifier-type type1) (specifier-type type2)))
159 ram 1.1
160    
161 wlott 1.7 ;;;; TYPEP -- public.
162     ;;;
163     ;;; Just call %typep
164     ;;;
165     (defun typep (object type)
166     "Return T iff OBJECT is of type TYPE."
167     (declare (type (or list symbol) type))
168     (%typep object type))
169 ram 1.1
170 wlott 1.28 (eval-when (compile eval)
171     (defmacro only-if-bound (name object)
172     `(and (fboundp ',name)
173     (let ((object ,object))
174     (declare (optimize (inhibit-warnings 3)))
175     (,name object)))))
176    
177 wlott 1.7 ;;; %TYPEP -- internal.
178 ram 1.1 ;;;
179 wlott 1.7 ;;; The actual typep engine. The compiler only generates calls to this
180     ;;; function when it can't figure out anything more intelligent to do.
181     ;;;
182     (defun %typep (object specifier)
183 wlott 1.13 (%%typep object
184     (if (ctype-p specifier)
185     specifier
186     (specifier-type specifier))))
187     ;;;
188     (defun %%typep (object type)
189     (declare (type ctype type))
190     (etypecase type
191     (named-type
192 ram 1.28.1.1 (ecase (named-type-name type)
193 ram 1.28.1.4 ((* t) t)
194 ram 1.28.1.1 ((nil) nil)))
195 wlott 1.13 (numeric-type
196     (and (numberp object)
197     (let ((num (if (complexp object) (realpart object) object)))
198     (ecase (numeric-type-class type)
199     (integer (integerp num))
200     (rational (rationalp num))
201     (float
202     (ecase (numeric-type-format type)
203     (short-float (typep object 'short-float))
204     (single-float (typep object 'single-float))
205     (double-float (typep object 'double-float))
206     (long-float (typep object 'long-float))
207     ((nil) (floatp num))))
208 wlott 1.27 ((nil) t)))
209 wlott 1.13 (flet ((bound-test (val)
210     (let ((low (numeric-type-low type))
211     (high (numeric-type-high type)))
212     (and (cond ((null low) t)
213     ((listp low) (> val (car low)))
214     (t (>= val low)))
215     (cond ((null high) t)
216     ((listp high) (< val (car high)))
217     (t (<= val high)))))))
218     (ecase (numeric-type-complexp type)
219     ((nil) t)
220     (:complex
221     (and (complexp object)
222 wlott 1.26 (bound-test (realpart object))
223     (bound-test (imagpart object))))
224 wlott 1.13 (:real
225     (and (not (complexp object))
226     (bound-test object)))))))
227     (array-type
228     (and (arrayp object)
229     (ecase (array-type-complexp type)
230     ((t) (not (typep object 'simple-array)))
231     ((nil) (typep object 'simple-array))
232     (* t))
233     (or (eq (array-type-dimensions type) '*)
234     (do ((want (array-type-dimensions type) (cdr want))
235     (got (array-dimensions object) (cdr got)))
236     ((and (null want) (null got)) t)
237     (unless (and want got
238     (or (eq (car want) '*)
239     (= (car want) (car got))))
240     (return nil))))
241     (or (eq (array-type-element-type type) *wild-type*)
242     (type= (array-type-specialized-element-type type)
243     (specifier-type (array-element-type object))))))
244     (member-type
245     (if (member object (member-type-members type)) t))
246 ram 1.28.1.1 (class
247 ram 1.28.1.3 (class-typep (layout-of object) type))
248 wlott 1.13 (union-type
249     (dolist (type (union-type-types type))
250     (when (%%typep object type)
251     (return t))))
252     (unknown-type
253 ram 1.28.1.2 ;; Parse it again to make sure it's really undefined.
254     (let ((reparse (specifier-type (unknown-type-specifier type))))
255     (if (typep reparse 'unknown-type)
256     (error "Unknown type specifier: ~S"
257     (unknown-type-specifier reparse))
258     (%%typep object reparse))))
259 wlott 1.13 (hairy-type
260     ;; Now the tricky stuff.
261     (let* ((hairy-spec (hairy-type-specifier type))
262     (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
263     (ecase symbol
264     (and
265     (or (atom hairy-spec)
266 ram 1.21 (dolist (spec (cdr hairy-spec) t)
267 wlott 1.14 (unless (%%typep object (specifier-type spec))
268 wlott 1.13 (return nil)))))
269     (not
270     (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
271     (error "Invalid type specifier: ~S" hairy-spec))
272 wlott 1.15 (not (%%typep object (specifier-type (cadr hairy-spec)))))
273 wlott 1.13 (satisfies
274     (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
275     (error "Invalid type specifier: ~S" hairy-spec))
276 wlott 1.17 (let ((fn (cadr hairy-spec)))
277     (if (funcall (typecase fn
278     (function fn)
279     (symbol (symbol-function fn))
280     (t
281     (coerce fn 'function)))
282     object)
283     t
284     nil))))))
285 wlott 1.23 (alien-type-type
286     (alien-internals:alien-typep object (alien-type-type-alien-type type)))
287 wlott 1.13 (function-type
288     (error "Function types are not a legal argument to TYPEP:~% ~S"
289     (type-specifier type)))))
290    
291 ram 1.1
292    
293 ram 1.28.1.1 ;;; CLASS-TYPEP -- Internal
294 ram 1.1 ;;;
295 ram 1.28.1.1 ;;; Test whether Obj-Layout is from an instance of Class.
296 ram 1.1 ;;;
297 ram 1.28.1.1 (defun class-typep (obj-layout class)
298 ram 1.1 (declare (optimize speed))
299 ram 1.28.1.1 (when (layout-invalid obj-layout)
300     (error "TYPEP on obsolete object (was class ~S)."
301     (class-proper-name (layout-class obj-layout))))
302     (let* ((layout (class-layout class))
303 ram 1.28.1.3 (subclasses (class-subclasses class)))
304 ram 1.28.1.1 (when (layout-invalid layout)
305     (error "Class is currently invalid: ~S" class))
306     (if (or (eq obj-layout layout)
307     (and subclasses
308     (gethash (layout-class obj-layout) subclasses)))
309     t
310     nil)))
311 ram 1.1
312    
313 wlott 1.7 ;;;; Equality predicates.
314 ram 1.1
315 wlott 1.7 ;;; EQ -- public.
316     ;;;
317     ;;; Real simple, 'cause the compiler takes care of it.
318     ;;;
319 ram 1.1
320 wlott 1.7 (defun eq (obj1 obj2)
321     "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
322     (eq obj1 obj2))
323 ram 1.1
324    
325 wlott 1.7 ;;; EQUAL -- public.
326     ;;;
327 ram 1.1 (defun equal (x y)
328     "Returns T if X and Y are EQL or if they are structured components
329     whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
330     are the same length and have indentical components. Other arrays must be
331     EQ to be EQUAL."
332     (cond ((eql x y) t)
333     ((consp x)
334     (and (consp y)
335     (equal (car x) (car y))
336     (equal (cdr x) (cdr y))))
337     ((stringp x)
338     (and (stringp y) (string= x y)))
339     ((pathnamep x)
340 ram 1.20 (and (pathnamep y) (pathname= x y)))
341 ram 1.1 ((bit-vector-p x)
342     (and (bit-vector-p y)
343     (= (the fixnum (length x))
344     (the fixnum (length y)))
345     (do ((i 0 (1+ i))
346     (length (length x)))
347     ((= i length) t)
348     (declare (fixnum i))
349     (or (= (the fixnum (bit x i))
350     (the fixnum (bit y i)))
351     (return nil)))))
352     (t nil)))
353    
354 wlott 1.7 ;;; EQUALP -- public.
355     ;;;
356 ram 1.1 (defun equalp (x y)
357     "Just like EQUAL, but more liberal in several respects.
358     Numbers may be of different types, as long as the values are identical
359     after coercion. Characters may differ in alphabetic case. Vectors and
360     arrays must have identical dimensions and EQUALP elements, but may differ
361     in their type restriction."
362 wlott 1.12 (cond ((eq x y) t)
363 ram 1.1 ((characterp x) (char-equal x y))
364     ((numberp x) (and (numberp y) (= x y)))
365     ((consp x)
366     (and (consp y)
367     (equalp (car x) (car y))
368     (equalp (cdr x) (cdr y))))
369 ram 1.20 ((pathnamep x)
370     (and (pathnamep y) (pathname= x y)))
371 ram 1.28.1.3 #-ns-boot
372 ram 1.28.1.1 ((%instancep x)
373     (let* ((layout-x (%instance-layout x))
374 ram 1.28.1.5 (len (layout-length layout-x)))
375 ram 1.28.1.1 (and (%instancep y)
376     (eq layout-x (%instance-layout y))
377     (structure-class-p (layout-class layout-x))
378     (do ((i 1 (1+ i)))
379     ((= i len) t)
380     (declare (fixnum i))
381     (let ((x-el (%instance-ref x i))
382     (y-el (%instance-ref y i)))
383 wlott 1.12 (unless (or (eq x-el y-el)
384     (equalp x-el y-el))
385     (return nil)))))))
386 ram 1.28.1.3 #+ns-boot
387     ((structurep x)
388     (let ((length (structure-length x)))
389     (and (structurep y)
390     (= length (structure-length y))
391     (dotimes (i length t)
392     (let ((x-el (structure-ref x i))
393     (y-el (structure-ref y i)))
394     (unless (or (eq x-el y-el)
395     (equalp x-el y-el))
396     (return nil)))))))
397 ram 1.1 ((vectorp x)
398     (let ((length (length x)))
399     (and (vectorp y)
400 wlott 1.7 (= length (length y))
401 ram 1.1 (dotimes (i length t)
402     (let ((x-el (aref x i))
403     (y-el (aref y i)))
404 wlott 1.12 (unless (or (eq x-el y-el)
405 ram 1.1 (equalp x-el y-el))
406     (return nil)))))))
407     ((arrayp x)
408 wlott 1.7 (and (arrayp y)
409     (= (array-rank x) (array-rank y))
410     (dotimes (axis (array-rank x) t)
411     (unless (= (array-dimension x axis)
412     (array-dimension y axis))
413     (return nil)))
414     (dotimes (index (array-total-size x) t)
415 wlott 1.12 (let ((x-el (row-major-aref x index))
416     (y-el (row-major-aref y index)))
417     (unless (or (eq x-el y-el)
418     (equalp x-el y-el))
419     (return nil))))))
420 ram 1.1 (t nil)))

  ViewVC Help
Powered by ViewVC 1.1.5