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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5