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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (show annotations)
Wed Oct 10 16:31:39 1990 UTC (23 years, 6 months ago) by wlott
Branch: MAIN
Changes since 1.11: +21 -9 lines
Hacked on equal and equalp to make them work now that structures are not
simple-vectors.
1 ;;; -*- Mode: Lisp; Package: LISP; Log: code.log -*-
2 ;;;
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 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/pred.lisp,v 1.12 1990/10/10 16:31:39 wlott Exp $
11 ;;;
12 ;;; Predicate functions for CMU Common Lisp.
13 ;;;
14 ;;; 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 (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 null number ratio rational real sequence short-float signed-byte
35 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
41 ;;;; Primitive predicates. These must be supported by the compiler.
42
43 (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 long-float-p
62 not
63 null
64 numberp
65 rationalp
66 ratiop
67 realp
68 short-float-p
69 simple-array-p
70 simple-bit-vector-p
71 simple-string-p
72 simple-vector-p
73 single-float-p
74 stringp
75 structurep
76 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
91 (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
105
106 ;;;; 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 (defun type-of (object)
113 "Return the type of OBJECT."
114 (typecase object
115 ;; First the ones that we can tell by testing the lowtag
116 (fixnum 'fixnum)
117 (function (type-specifier (ctype-of object)))
118 (null 'null)
119 (list 'cons)
120
121 ;; Any other immediates.
122 (character
123 (typecase object
124 (standard-char 'standard-char)
125 (base-character 'base-character)
126 (t 'character)))
127
128 ;; And now for the complicated ones.
129 (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 (symbol
142 (if (eq (symbol-package object)
143 (symbol-package :foo))
144 'keyword
145 'symbol))
146 (structure (c::structure-ref object 0))
147 (array (type-specifier (ctype-of object)))
148 (system-area-pointer 'system-area-pointer)
149 (weak-pointer 'weak-pointer)
150 (t
151 (warn "Can't figure out the type of ~S" object)
152 t)))
153
154
155 ;;;; SUBTYPEP -- public.
156 ;;;
157 ;;; 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
166
167 ;;;; 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
176 ;;; %TYPEP -- internal.
177 ;;;
178 ;;; 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 (declare (type (or list symbol ctype) specifier))
183 (let ((type (if (ctype-p specifier)
184 specifier
185 (specifier-type specifier))))
186 (etypecase type
187 (named-type
188 (ecase (named-type-name type)
189 ((* t)
190 t)
191 ((nil)
192 nil)
193 (character (characterp object))
194 (base-character (base-char-p object))
195 (standard-char (and (characterp object) (standard-char-p object)))
196 (extended-character
197 (and (characterp object) (not (base-char-p object))))
198 (function (functionp object))
199 (cons (consp object))
200 (symbol (symbolp object))
201 (keyword
202 (and (symbolp object)
203 (eq (symbol-package object)
204 (symbol-package :foo))))
205 (system-area-pointer (system-area-pointer-p object))
206 (weak-pointer (weak-pointer-p object))
207 (structure (structurep object))))
208 (numeric-type
209 (and (numberp object)
210 (let ((num (if (complexp object) (realpart object) object)))
211 (ecase (numeric-type-class type)
212 (integer (integerp num))
213 (rational (rationalp num))
214 (float
215 (ecase (numeric-type-format type)
216 (short-float (typep object 'short-float))
217 (single-float (typep object 'single-float))
218 (double-float (typep object 'double-float))
219 (long-float (typep object 'long-float))
220 ((nil) (floatp num))))
221 ((nil) t)))
222 (flet ((bound-test (val)
223 (let ((low (numeric-type-low type))
224 (high (numeric-type-high type)))
225 (and (cond ((null low) t)
226 ((listp low) (> val (car low)))
227 (t (>= val low)))
228 (cond ((null high) t)
229 ((listp high) (< val (car high)))
230 (t (<= val high)))))))
231 (ecase (numeric-type-complexp type)
232 ((nil) t)
233 (:complex
234 (and (complexp object)
235 (let ((re (realpart object))
236 (im (imagpart object)))
237 (and (bound-test (min re im))
238 (bound-test (max re im))))))
239 (:real
240 (and (not (complexp object))
241 (bound-test object)))))))
242 (array-type
243 (and (arrayp object)
244 (ecase (array-type-complexp type)
245 ((t) (not (typep object 'simple-array)))
246 ((nil) (typep object 'simple-array))
247 (* t))
248 (or (eq (array-type-dimensions type) '*)
249 (do ((want (array-type-dimensions type) (cdr want))
250 (got (array-dimensions object) (cdr got)))
251 ((and (null want) (null got)) t)
252 (unless (and want got
253 (or (eq (car want) '*)
254 (= (car want) (car got))))
255 (return nil))))
256 (or (eq (array-type-element-type type) *wild-type*)
257 (type= (array-type-specialized-element-type type)
258 (specifier-type (array-element-type object))))))
259 (member-type
260 (if (member object (member-type-members type)) t))
261 (structure-type
262 (structure-typep object (structure-type-name type)))
263 (union-type
264 (dolist (type (union-type-types type))
265 (when (%typep object type)
266 (return t))))
267 (unknown-type
268 (let ((orig-spec (unknown-type-specifier type)))
269 (if (eq type specifier)
270 ;; The type was unknown at compile time. Therefore, we should
271 ;; try again at runtime, 'cause it might be known now.
272 (%typep object orig-spec)
273 (error "Unknown type specifier: ~S" orig-spec))))
274 (hairy-type
275 ;; Now the tricky stuff.
276 (let* ((hairy-spec (hairy-type-specifier type))
277 (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
278 (ecase symbol
279 (and
280 (or (atom hairy-spec)
281 (dolist (spec (cdr hairy-spec))
282 (unless (%typep object spec)
283 (return nil)))))
284 (not
285 (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
286 (error "Invalid type specifier: ~S" hairy-spec))
287 (not (%typep object (cadr hairy-spec))))
288 (satisfies
289 (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
290 (error "Invalid type specifier: ~S" hairy-spec))
291 (if (funcall (cadr hairy-spec) object) t)))))
292 (function-type
293 (error "Function types are not a legal argument to TYPEP:~% ~S"
294 specifier)))))
295
296
297 ;;; Structure-Typep -- Internal
298 ;;;
299 ;;; This is called by %typep when it tries to match against a structure type,
300 ;;; and typep of types that are known to be structure types at compile time
301 ;;; are converted to this.
302 ;;;
303 (defun structure-typep (object type)
304 (declare (optimize speed))
305 (let ((info (info type defined-structure-info type)))
306 (if info
307 (and (structurep object)
308 (let ((obj-name (c::structure-ref object 0)))
309 (or (eq obj-name type)
310 (if (member obj-name (c::dd-included-by info)
311 :test #'eq)
312 t nil))))
313 (error "~S is an unknown structure type specifier." type))))
314
315
316 ;;;; Equality predicates.
317
318 ;;; EQ -- public.
319 ;;;
320 ;;; Real simple, 'cause the compiler takes care of it.
321 ;;;
322
323 (defun eq (obj1 obj2)
324 "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
325 (eq obj1 obj2))
326
327
328 ;;; EQUAL -- public.
329 ;;;
330 (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 (c::structure-length x)))
346 ((>= i len) t)
347 (declare (fixnum i len))
348 (let ((x-el (c::structure-ref x i))
349 (y-el (c::structure-ref 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 (unless (equal x-el y-el)
362 (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 ;;; EQUALP -- public.
377 ;;;
378 (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 ((eq 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 ((structurep x)
392 (let ((length (c::structure-length x)))
393 (and (structurep y)
394 (= length (c::structure-length y))
395 (dotimes (i length t)
396 (let ((x-el (c::structure-ref x i))
397 (y-el (c::structure-ref y i)))
398 (unless (or (eq x-el y-el)
399 (equalp x-el y-el))
400 (return nil)))))))
401 ((vectorp x)
402 (let ((length (length x)))
403 (and (vectorp y)
404 (= length (length y))
405 (dotimes (i length t)
406 (let ((x-el (aref x i))
407 (y-el (aref y i)))
408 (unless (or (eq x-el y-el)
409 (equalp x-el y-el))
410 (return nil)))))))
411 ((arrayp x)
412 (and (arrayp y)
413 (= (array-rank x) (array-rank y))
414 (dotimes (axis (array-rank x) t)
415 (unless (= (array-dimension x axis)
416 (array-dimension y axis))
417 (return nil)))
418 (dotimes (index (array-total-size x) t)
419 (let ((x-el (row-major-aref x index))
420 (y-el (row-major-aref y index)))
421 (unless (or (eq x-el y-el)
422 (equalp x-el y-el))
423 (return nil))))))
424 (t nil)))

  ViewVC Help
Powered by ViewVC 1.1.5