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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.20 - (hide annotations)
Fri Dec 20 02:29:00 1991 UTC (22 years, 4 months ago) by ram
Branch: MAIN
Changes since 1.19: +19 -38 lines
Changed EQUAL and EQUALP to compare pathnames with PATHNAME=.  Deleted some
unnecessary C:: qualifiers.
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.20 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/pred.lisp,v 1.20 1991/12/20 02:29:00 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     (in-package "EXTENSIONS")
20     (export '(structurep fixnump bignump bitp ratiop realp weak-pointer-p))
21    
22     (in-package "SYSTEM")
23     (export '(system-area-pointer system-area-pointer-p))
24    
25     (in-package "LISP" :use "KERNEL")
26    
27 ram 1.1 (export '(typep null symbolp atom consp listp numberp integerp rationalp
28     floatp complexp characterp stringp bit-vector-p vectorp
29     simple-vector-p simple-string-p simple-bit-vector-p arrayp
30     functionp compiled-function-p commonp eq eql equal equalp not
31     type-of
32     ;; Names of types...
33     array atom bignum bit bit-vector character common
34     compiled-function complex cons double-float
35     fixnum float function integer keyword list long-float nil
36 wlott 1.7 null number ratio rational real sequence short-float signed-byte
37 ram 1.1 simple-array simple-bit-vector simple-string simple-vector
38     single-float standard-char string string-char symbol t
39     unsigned-byte vector structure satisfies))
40    
41    
42 wlott 1.7
43     ;;;; Primitive predicates. These must be supported by the compiler.
44 ram 1.1
45 wlott 1.7 (eval-when (compile eval)
46     (defparameter primitive-predicates
47     '(array-header-p
48     arrayp
49     atom
50     base-char-p
51     bignump
52     bit-vector-p
53     characterp
54 wlott 1.18 code-component-p
55 wlott 1.7 consp
56     compiled-function-p
57     complexp
58     double-float-p
59     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 wlott 1.9 structurep
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.7 )))
95 ram 1.1
96 wlott 1.7 (macrolet
97     ((frob ()
98     `(progn
99     ,@(mapcar #'(lambda (pred)
100     `(defun ,pred (object)
101     ,(format nil
102     "Return T if OBJECT is a~:[~;n~] ~(~A~) ~
103     and NIL otherwise."
104     (find (schar (string pred) 0) "AEIOUaeiou")
105     (string pred))
106     (,pred object)))
107     primitive-predicates))))
108     (frob))
109 ram 1.1
110    
111 wlott 1.7 ;;;; TYPE-OF -- public.
112     ;;;
113     ;;; Return the specifier for the type of object. This is not simply
114     ;;; (type-specifier (ctype-of object)) because ctype-of has different goals
115     ;;; than type-of.
116     ;;;
117 ram 1.1 (defun type-of (object)
118 wlott 1.7 "Return the type of OBJECT."
119     (typecase object
120 wlott 1.8 ;; First the ones that we can tell by testing the lowtag
121     (fixnum 'fixnum)
122     (function (type-specifier (ctype-of object)))
123 wlott 1.7 (null 'null)
124 wlott 1.8 (list 'cons)
125    
126     ;; Any other immediates.
127 wlott 1.7 (character
128     (typecase object
129     (standard-char 'standard-char)
130 wlott 1.19 (base-char 'base-char)
131 wlott 1.7 (t 'character)))
132 wlott 1.8
133     ;; And now for the complicated ones.
134 wlott 1.7 (number
135     (etypecase object
136     (fixnum 'fixnum)
137     (bignum 'bignum)
138     (float
139     (etypecase object
140     (double-float 'double-float)
141     (single-float 'single-float)
142     (short-float 'short-float)
143     (long-float 'long-float)))
144     (ratio 'ratio)
145     (complex 'complex)))
146 wlott 1.8 (symbol
147     (if (eq (symbol-package object)
148     (symbol-package :foo))
149     'keyword
150     'symbol))
151 ram 1.20 (structure (structure-ref object 0))
152 wlott 1.8 (array (type-specifier (ctype-of object)))
153     (system-area-pointer 'system-area-pointer)
154     (weak-pointer 'weak-pointer)
155 wlott 1.18 (code-component 'code-component)
156     (lra 'lra)
157     (scavenger-hook 'scavenger-hook)
158 wlott 1.7 (t
159     (warn "Can't figure out the type of ~S" object)
160     t)))
161 ram 1.1
162 wlott 1.7
163     ;;;; SUBTYPEP -- public.
164 ram 1.1 ;;;
165 wlott 1.7 ;;; Just parse the type specifiers and call csubtype.
166     ;;;
167     (defun subtypep (type1 type2)
168     "Return two values indicating the relationship between type1 and type2:
169     T and T: type1 definatly is a subtype of type2.
170     NIL and T: type1 definatly is not a subtype of type2.
171     NIL and NIL: who knows?"
172     (csubtypep (specifier-type type1) (specifier-type type2)))
173 ram 1.1
174    
175 wlott 1.7 ;;;; TYPEP -- public.
176     ;;;
177     ;;; Just call %typep
178     ;;;
179     (defun typep (object type)
180     "Return T iff OBJECT is of type TYPE."
181     (declare (type (or list symbol) type))
182     (%typep object type))
183 ram 1.1
184 wlott 1.7 ;;; %TYPEP -- internal.
185 ram 1.1 ;;;
186 wlott 1.7 ;;; The actual typep engine. The compiler only generates calls to this
187     ;;; function when it can't figure out anything more intelligent to do.
188     ;;;
189     (defun %typep (object specifier)
190 wlott 1.13 (%%typep object
191     (if (ctype-p specifier)
192     specifier
193     (specifier-type specifier))))
194     ;;;
195     (defun %%typep (object type)
196     (declare (type ctype type))
197     (etypecase type
198     (named-type
199     (ecase (named-type-name type)
200     ((* t)
201     t)
202     ((nil)
203     nil)
204     (character (characterp object))
205 wlott 1.19 (base-char (base-char-p object))
206 wlott 1.13 (standard-char (and (characterp object) (standard-char-p object)))
207 wlott 1.19 (extended-char
208 wlott 1.13 (and (characterp object) (not (base-char-p object))))
209     (function (functionp object))
210     (cons (consp object))
211     (symbol (symbolp object))
212     (keyword
213     (and (symbolp object)
214     (eq (symbol-package object)
215     (symbol-package :foo))))
216     (system-area-pointer (system-area-pointer-p object))
217     (weak-pointer (weak-pointer-p object))
218 wlott 1.18 (code-component (code-component-p object))
219     (lra (lra-p object))
220     (scavenger-hook (scavenger-hook-p object))
221 wlott 1.13 (structure (structurep object))))
222     (numeric-type
223     (and (numberp object)
224     (let ((num (if (complexp object) (realpart object) object)))
225     (ecase (numeric-type-class type)
226     (integer (integerp num))
227     (rational (rationalp num))
228     (float
229     (ecase (numeric-type-format type)
230     (short-float (typep object 'short-float))
231     (single-float (typep object 'single-float))
232     (double-float (typep object 'double-float))
233     (long-float (typep object 'long-float))
234     ((nil) (floatp num))))
235     ((nil) t)))
236     (flet ((bound-test (val)
237     (let ((low (numeric-type-low type))
238     (high (numeric-type-high type)))
239     (and (cond ((null low) t)
240     ((listp low) (> val (car low)))
241     (t (>= val low)))
242     (cond ((null high) t)
243     ((listp high) (< val (car high)))
244     (t (<= val high)))))))
245     (ecase (numeric-type-complexp type)
246     ((nil) t)
247     (:complex
248     (and (complexp object)
249     (let ((re (realpart object))
250     (im (imagpart object)))
251     (and (bound-test (min re im))
252     (bound-test (max re im))))))
253     (:real
254     (and (not (complexp object))
255     (bound-test object)))))))
256     (array-type
257     (and (arrayp object)
258     (ecase (array-type-complexp type)
259     ((t) (not (typep object 'simple-array)))
260     ((nil) (typep object 'simple-array))
261     (* t))
262     (or (eq (array-type-dimensions type) '*)
263     (do ((want (array-type-dimensions type) (cdr want))
264     (got (array-dimensions object) (cdr got)))
265     ((and (null want) (null got)) t)
266     (unless (and want got
267     (or (eq (car want) '*)
268     (= (car want) (car got))))
269     (return nil))))
270     (or (eq (array-type-element-type type) *wild-type*)
271     (type= (array-type-specialized-element-type type)
272     (specifier-type (array-element-type object))))))
273     (member-type
274     (if (member object (member-type-members type)) t))
275     (structure-type
276     (structure-typep object (structure-type-name type)))
277     (union-type
278     (dolist (type (union-type-types type))
279     (when (%%typep object type)
280     (return t))))
281     (unknown-type
282     ;; Type may be unknown to the compiler (and SPECIFIER-TYPE), yet be
283     ;; a defined structure in the core.
284     (let ((orig-spec (unknown-type-specifier type)))
285     (if (and (symbolp orig-spec)
286     (info type defined-structure-info orig-spec))
287     (structure-typep object orig-spec)
288     (error "Unknown type specifier: ~S" orig-spec))))
289     (hairy-type
290     ;; Now the tricky stuff.
291     (let* ((hairy-spec (hairy-type-specifier type))
292     (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
293     (ecase symbol
294     (and
295     (or (atom hairy-spec)
296     (dolist (spec (cdr hairy-spec))
297 wlott 1.14 (unless (%%typep object (specifier-type spec))
298 wlott 1.13 (return nil)))))
299     (not
300     (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
301     (error "Invalid type specifier: ~S" hairy-spec))
302 wlott 1.15 (not (%%typep object (specifier-type (cadr hairy-spec)))))
303 wlott 1.13 (satisfies
304     (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
305     (error "Invalid type specifier: ~S" hairy-spec))
306 wlott 1.17 (let ((fn (cadr hairy-spec)))
307     (if (funcall (typecase fn
308     (function fn)
309     (symbol (symbol-function fn))
310     (t
311     (coerce fn 'function)))
312     object)
313     t
314     nil))))))
315 wlott 1.13 (function-type
316     (error "Function types are not a legal argument to TYPEP:~% ~S"
317     (type-specifier type)))))
318    
319 ram 1.1
320    
321     ;;; Structure-Typep -- Internal
322     ;;;
323 wlott 1.7 ;;; This is called by %typep when it tries to match against a structure type,
324     ;;; and typep of types that are known to be structure types at compile time
325     ;;; are converted to this.
326 ram 1.1 ;;;
327     (defun structure-typep (object type)
328     (declare (optimize speed))
329 wlott 1.7 (let ((info (info type defined-structure-info type)))
330     (if info
331     (and (structurep object)
332 ram 1.20 (let ((obj-name (structure-ref object 0)))
333 wlott 1.7 (or (eq obj-name type)
334     (if (member obj-name (c::dd-included-by info)
335     :test #'eq)
336     t nil))))
337     (error "~S is an unknown structure type specifier." type))))
338 ram 1.1
339    
340 wlott 1.7 ;;;; Equality predicates.
341 ram 1.1
342 wlott 1.7 ;;; EQ -- public.
343     ;;;
344     ;;; Real simple, 'cause the compiler takes care of it.
345     ;;;
346 ram 1.1
347 wlott 1.7 (defun eq (obj1 obj2)
348     "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
349     (eq obj1 obj2))
350 ram 1.1
351    
352 wlott 1.7 ;;; EQUAL -- public.
353     ;;;
354 ram 1.1 (defun equal (x y)
355     "Returns T if X and Y are EQL or if they are structured components
356     whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
357     are the same length and have indentical components. Other arrays must be
358     EQ to be EQUAL."
359     (cond ((eql x y) t)
360     ((consp x)
361     (and (consp y)
362     (equal (car x) (car y))
363     (equal (cdr x) (cdr y))))
364     ((stringp x)
365     (and (stringp y) (string= x y)))
366     ((pathnamep x)
367 ram 1.20 (and (pathnamep y) (pathname= x y)))
368 ram 1.1 ((bit-vector-p x)
369     (and (bit-vector-p y)
370     (= (the fixnum (length x))
371     (the fixnum (length y)))
372     (do ((i 0 (1+ i))
373     (length (length x)))
374     ((= i length) t)
375     (declare (fixnum i))
376     (or (= (the fixnum (bit x i))
377     (the fixnum (bit y i)))
378     (return nil)))))
379     (t nil)))
380    
381 wlott 1.7 ;;; EQUALP -- public.
382     ;;;
383 ram 1.1 (defun equalp (x y)
384     "Just like EQUAL, but more liberal in several respects.
385     Numbers may be of different types, as long as the values are identical
386     after coercion. Characters may differ in alphabetic case. Vectors and
387     arrays must have identical dimensions and EQUALP elements, but may differ
388     in their type restriction."
389 wlott 1.12 (cond ((eq x y) t)
390 ram 1.1 ((characterp x) (char-equal x y))
391     ((numberp x) (and (numberp y) (= x y)))
392     ((consp x)
393     (and (consp y)
394     (equalp (car x) (car y))
395     (equalp (cdr x) (cdr y))))
396 ram 1.20 ((pathnamep x)
397     (and (pathnamep y) (pathname= x y)))
398 wlott 1.12 ((structurep x)
399 ram 1.20 (let ((length (structure-length x)))
400 wlott 1.12 (and (structurep y)
401 ram 1.20 (= length (structure-length y))
402 wlott 1.12 (dotimes (i length t)
403 ram 1.20 (let ((x-el (structure-ref x i))
404     (y-el (structure-ref y i)))
405 wlott 1.12 (unless (or (eq x-el y-el)
406     (equalp x-el y-el))
407     (return nil)))))))
408 ram 1.1 ((vectorp x)
409     (let ((length (length x)))
410     (and (vectorp y)
411 wlott 1.7 (= length (length y))
412 ram 1.1 (dotimes (i length t)
413     (let ((x-el (aref x i))
414     (y-el (aref y i)))
415 wlott 1.12 (unless (or (eq x-el y-el)
416 ram 1.1 (equalp x-el y-el))
417     (return nil)))))))
418     ((arrayp x)
419 wlott 1.7 (and (arrayp y)
420     (= (array-rank x) (array-rank y))
421     (dotimes (axis (array-rank x) t)
422     (unless (= (array-dimension x axis)
423     (array-dimension y axis))
424     (return nil)))
425     (dotimes (index (array-total-size x) t)
426 wlott 1.12 (let ((x-el (row-major-aref x index))
427     (y-el (row-major-aref y index)))
428     (unless (or (eq x-el y-el)
429     (equalp x-el y-el))
430     (return nil))))))
431 ram 1.1 (t nil)))

  ViewVC Help
Powered by ViewVC 1.1.5