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

  ViewVC Help
Powered by ViewVC 1.1.5