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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5