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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5