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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.22.1.1 - (hide annotations) (vendor branch)
Thu Feb 13 00:43:08 1992 UTC (22 years, 2 months ago) by wlott
Changes since 1.22: +3 -1 lines
new alien changes.
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 wlott 1.22.1.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/pred.lisp,v 1.22.1.1 1992/02/13 00:43:08 wlott 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 ram 1.22 type-of upgraded-array-element-type
32 ram 1.1 ;; 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.22
162     ;;;; UPGRADED-ARRAY-ELEMENT-TYPE -- public
163     ;;;
164     (defun upgraded-array-element-type (spec)
165     "Return the element type that will actually be used to implement an array
166     with the specifier :ELEMENT-TYPE Spec."
167     (type-specifier
168     (array-type-specialized-element-type
169     (specifier-type `(array ,spec)))))
170 wlott 1.7
171     ;;;; SUBTYPEP -- public.
172 ram 1.1 ;;;
173 wlott 1.7 ;;; Just parse the type specifiers and call csubtype.
174     ;;;
175     (defun subtypep (type1 type2)
176     "Return two values indicating the relationship between type1 and type2:
177     T and T: type1 definatly is a subtype of type2.
178     NIL and T: type1 definatly is not a subtype of type2.
179     NIL and NIL: who knows?"
180     (csubtypep (specifier-type type1) (specifier-type type2)))
181 ram 1.1
182    
183 wlott 1.7 ;;;; TYPEP -- public.
184     ;;;
185     ;;; Just call %typep
186     ;;;
187     (defun typep (object type)
188     "Return T iff OBJECT is of type TYPE."
189     (declare (type (or list symbol) type))
190     (%typep object type))
191 ram 1.1
192 wlott 1.7 ;;; %TYPEP -- internal.
193 ram 1.1 ;;;
194 wlott 1.7 ;;; The actual typep engine. The compiler only generates calls to this
195     ;;; function when it can't figure out anything more intelligent to do.
196     ;;;
197     (defun %typep (object specifier)
198 wlott 1.13 (%%typep object
199     (if (ctype-p specifier)
200     specifier
201     (specifier-type specifier))))
202     ;;;
203     (defun %%typep (object type)
204     (declare (type ctype type))
205     (etypecase type
206     (named-type
207     (ecase (named-type-name type)
208     ((* t)
209     t)
210     ((nil)
211     nil)
212     (character (characterp object))
213 wlott 1.19 (base-char (base-char-p object))
214 wlott 1.13 (standard-char (and (characterp object) (standard-char-p object)))
215 wlott 1.19 (extended-char
216 wlott 1.13 (and (characterp object) (not (base-char-p object))))
217     (function (functionp object))
218     (cons (consp object))
219     (symbol (symbolp object))
220     (keyword
221     (and (symbolp object)
222     (eq (symbol-package object)
223     (symbol-package :foo))))
224     (system-area-pointer (system-area-pointer-p object))
225     (weak-pointer (weak-pointer-p object))
226 wlott 1.18 (code-component (code-component-p object))
227     (lra (lra-p object))
228     (scavenger-hook (scavenger-hook-p object))
229 wlott 1.13 (structure (structurep object))))
230     (numeric-type
231     (and (numberp object)
232     (let ((num (if (complexp object) (realpart object) object)))
233     (ecase (numeric-type-class type)
234     (integer (integerp num))
235     (rational (rationalp num))
236     (float
237     (ecase (numeric-type-format type)
238     (short-float (typep object 'short-float))
239     (single-float (typep object 'single-float))
240     (double-float (typep object 'double-float))
241     (long-float (typep object 'long-float))
242     ((nil) (floatp num))))
243     ((nil) t)))
244     (flet ((bound-test (val)
245     (let ((low (numeric-type-low type))
246     (high (numeric-type-high type)))
247     (and (cond ((null low) t)
248     ((listp low) (> val (car low)))
249     (t (>= val low)))
250     (cond ((null high) t)
251     ((listp high) (< val (car high)))
252     (t (<= val high)))))))
253     (ecase (numeric-type-complexp type)
254     ((nil) t)
255     (:complex
256     (and (complexp object)
257     (let ((re (realpart object))
258     (im (imagpart object)))
259     (and (bound-test (min re im))
260     (bound-test (max re im))))))
261     (:real
262     (and (not (complexp object))
263     (bound-test object)))))))
264     (array-type
265     (and (arrayp object)
266     (ecase (array-type-complexp type)
267     ((t) (not (typep object 'simple-array)))
268     ((nil) (typep object 'simple-array))
269     (* t))
270     (or (eq (array-type-dimensions type) '*)
271     (do ((want (array-type-dimensions type) (cdr want))
272     (got (array-dimensions object) (cdr got)))
273     ((and (null want) (null got)) t)
274     (unless (and want got
275     (or (eq (car want) '*)
276     (= (car want) (car got))))
277     (return nil))))
278     (or (eq (array-type-element-type type) *wild-type*)
279     (type= (array-type-specialized-element-type type)
280     (specifier-type (array-element-type object))))))
281     (member-type
282     (if (member object (member-type-members type)) t))
283     (structure-type
284     (structure-typep object (structure-type-name type)))
285     (union-type
286     (dolist (type (union-type-types type))
287     (when (%%typep object type)
288     (return t))))
289     (unknown-type
290     ;; Type may be unknown to the compiler (and SPECIFIER-TYPE), yet be
291     ;; a defined structure in the core.
292     (let ((orig-spec (unknown-type-specifier type)))
293     (if (and (symbolp orig-spec)
294     (info type defined-structure-info orig-spec))
295     (structure-typep object orig-spec)
296     (error "Unknown type specifier: ~S" orig-spec))))
297     (hairy-type
298     ;; Now the tricky stuff.
299     (let* ((hairy-spec (hairy-type-specifier type))
300     (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
301     (ecase symbol
302     (and
303     (or (atom hairy-spec)
304 ram 1.21 (dolist (spec (cdr hairy-spec) t)
305 wlott 1.14 (unless (%%typep object (specifier-type spec))
306 wlott 1.13 (return nil)))))
307     (not
308     (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
309     (error "Invalid type specifier: ~S" hairy-spec))
310 wlott 1.15 (not (%%typep object (specifier-type (cadr hairy-spec)))))
311 wlott 1.13 (satisfies
312     (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
313     (error "Invalid type specifier: ~S" hairy-spec))
314 wlott 1.17 (let ((fn (cadr hairy-spec)))
315     (if (funcall (typecase fn
316     (function fn)
317     (symbol (symbol-function fn))
318     (t
319     (coerce fn 'function)))
320     object)
321     t
322     nil))))))
323 wlott 1.22.1.1 (alien-type-type
324     (alien-internals:alien-typep object (alien-type-type-alien-type type)))
325 wlott 1.13 (function-type
326     (error "Function types are not a legal argument to TYPEP:~% ~S"
327     (type-specifier type)))))
328    
329 ram 1.1
330    
331     ;;; Structure-Typep -- Internal
332     ;;;
333 wlott 1.7 ;;; This is called by %typep when it tries to match against a structure type,
334     ;;; and typep of types that are known to be structure types at compile time
335     ;;; are converted to this.
336 ram 1.1 ;;;
337     (defun structure-typep (object type)
338     (declare (optimize speed))
339 wlott 1.7 (let ((info (info type defined-structure-info type)))
340     (if info
341     (and (structurep object)
342 ram 1.20 (let ((obj-name (structure-ref object 0)))
343 wlott 1.7 (or (eq obj-name type)
344     (if (member obj-name (c::dd-included-by info)
345     :test #'eq)
346     t nil))))
347     (error "~S is an unknown structure type specifier." type))))
348 ram 1.1
349    
350 wlott 1.7 ;;;; Equality predicates.
351 ram 1.1
352 wlott 1.7 ;;; EQ -- public.
353     ;;;
354     ;;; Real simple, 'cause the compiler takes care of it.
355     ;;;
356 ram 1.1
357 wlott 1.7 (defun eq (obj1 obj2)
358     "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
359     (eq obj1 obj2))
360 ram 1.1
361    
362 wlott 1.7 ;;; EQUAL -- public.
363     ;;;
364 ram 1.1 (defun equal (x y)
365     "Returns T if X and Y are EQL or if they are structured components
366     whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
367     are the same length and have indentical components. Other arrays must be
368     EQ to be EQUAL."
369     (cond ((eql x y) t)
370     ((consp x)
371     (and (consp y)
372     (equal (car x) (car y))
373     (equal (cdr x) (cdr y))))
374     ((stringp x)
375     (and (stringp y) (string= x y)))
376     ((pathnamep x)
377 ram 1.20 (and (pathnamep y) (pathname= x y)))
378 ram 1.1 ((bit-vector-p x)
379     (and (bit-vector-p y)
380     (= (the fixnum (length x))
381     (the fixnum (length y)))
382     (do ((i 0 (1+ i))
383     (length (length x)))
384     ((= i length) t)
385     (declare (fixnum i))
386     (or (= (the fixnum (bit x i))
387     (the fixnum (bit y i)))
388     (return nil)))))
389     (t nil)))
390    
391 wlott 1.7 ;;; EQUALP -- public.
392     ;;;
393 ram 1.1 (defun equalp (x y)
394     "Just like EQUAL, but more liberal in several respects.
395     Numbers may be of different types, as long as the values are identical
396     after coercion. Characters may differ in alphabetic case. Vectors and
397     arrays must have identical dimensions and EQUALP elements, but may differ
398     in their type restriction."
399 wlott 1.12 (cond ((eq x y) t)
400 ram 1.1 ((characterp x) (char-equal x y))
401     ((numberp x) (and (numberp y) (= x y)))
402     ((consp x)
403     (and (consp y)
404     (equalp (car x) (car y))
405     (equalp (cdr x) (cdr y))))
406 ram 1.20 ((pathnamep x)
407     (and (pathnamep y) (pathname= x y)))
408 wlott 1.12 ((structurep x)
409 ram 1.20 (let ((length (structure-length x)))
410 wlott 1.12 (and (structurep y)
411 ram 1.20 (= length (structure-length y))
412 wlott 1.12 (dotimes (i length t)
413 ram 1.20 (let ((x-el (structure-ref x i))
414     (y-el (structure-ref y i)))
415 wlott 1.12 (unless (or (eq x-el y-el)
416     (equalp x-el y-el))
417     (return nil)))))))
418 ram 1.1 ((vectorp x)
419     (let ((length (length x)))
420     (and (vectorp y)
421 wlott 1.7 (= length (length y))
422 ram 1.1 (dotimes (i length t)
423     (let ((x-el (aref x i))
424     (y-el (aref y i)))
425 wlott 1.12 (unless (or (eq x-el y-el)
426 ram 1.1 (equalp x-el y-el))
427     (return nil)))))))
428     ((arrayp x)
429 wlott 1.7 (and (arrayp y)
430     (= (array-rank x) (array-rank y))
431     (dotimes (axis (array-rank x) t)
432     (unless (= (array-dimension x axis)
433     (array-dimension y axis))
434     (return nil)))
435     (dotimes (index (array-total-size x) t)
436 wlott 1.12 (let ((x-el (row-major-aref x index))
437     (y-el (row-major-aref y index)))
438     (unless (or (eq x-el y-el)
439     (equalp x-el y-el))
440     (return nil))))))
441 ram 1.1 (t nil)))

  ViewVC Help
Powered by ViewVC 1.1.5