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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5