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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (show 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 ;;; -*- 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.13 1990/10/16 19:54:05 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 (%%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
301
302 ;;; Structure-Typep -- Internal
303 ;;;
304 ;;; 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 ;;;
308 (defun structure-typep (object type)
309 (declare (optimize speed))
310 (let ((info (info type defined-structure-info type)))
311 (if info
312 (and (structurep object)
313 (let ((obj-name (c::structure-ref object 0)))
314 (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
320
321 ;;;; Equality predicates.
322
323 ;;; EQ -- public.
324 ;;;
325 ;;; Real simple, 'cause the compiler takes care of it.
326 ;;;
327
328 (defun eq (obj1 obj2)
329 "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
330 (eq obj1 obj2))
331
332
333 ;;; EQUAL -- public.
334 ;;;
335 (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 (len (c::structure-length x)))
351 ((>= i len) t)
352 (declare (fixnum i len))
353 (let ((x-el (c::structure-ref x i))
354 (y-el (c::structure-ref y i)))
355 (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 (unless (equal x-el y-el)
367 (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 ;;; EQUALP -- public.
382 ;;;
383 (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 (cond ((eq x y) t)
390 ((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 ((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 ((vectorp x)
407 (let ((length (length x)))
408 (and (vectorp y)
409 (= length (length y))
410 (dotimes (i length t)
411 (let ((x-el (aref x i))
412 (y-el (aref y i)))
413 (unless (or (eq x-el y-el)
414 (equalp x-el y-el))
415 (return nil)))))))
416 ((arrayp x)
417 (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 (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 (t nil)))

  ViewVC Help
Powered by ViewVC 1.1.5