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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5