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

  ViewVC Help
Powered by ViewVC 1.1.5