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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5