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

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.59.18.1.4.1 - (show annotations)
Fri Jun 16 03:46:58 2006 UTC (7 years, 10 months ago) by rtoy
Branch: double-double-array-branch
Changes since 1.59.18.1: +2 -1 lines
Add support for new unboxed primitive type (simple-array
double-double-float (*)).

bootfiles/19c/boot-2006-06-2-cross-dd-ppc.lisp:
o Cross-compile script for PPC for new array type.

code/array.lisp:
o Add simple-array double-double-float to the vector types.
o Add support for double-double-float arrays to data-vector-ref and
  data-vector-set.

code/class.lisp:
o Tell compiler about the new array type.

code/exports.lisp:
o Export necessary symbols for the new array.

code/kernel.lisp:
o The args to MAKE-DOUBLE-DOUBLE-FLOAT are double-floats.

code/pred.lisp:
o Tell type system about new primitive type.

compiler/array-tran.lisp:
o Tell compiler about the new array type.

compiler/generic/objedef.lisp:
o Add new type code

compiler/generic/primtype.lisp:
o Tell compiler about new primitive array type.

compiler/generic/vm-fndb.lisp:
o Tell compiler about known function for type test function.

compiler/generic/vm-type.lisp:
o Tell compiler about new specialized array type.

compiler/generic/vm-typetran.lisp:
o Define type predicate.

compiler/ppc/array.lisp:
o Add vops to read and write an element of a double-double-float
  simple array.

compiler/ppc/type-vops.lisp:
compiler/sparc/type-vops.lisp:
o Add type vop for new array type.
o Tell compiler about the where the new array type fits in the type
  hierarchy.

lisp/gencgc.c:
o Add GC support for new array type.

lisp/purify.c:
o Add purify support for new array type.
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.59.18.1.4.1 2006/06/16 03:46:58 rtoy 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 #+double-double
22 (export '(double-double-float-p))
23
24 (in-package "SYSTEM")
25 (export '(system-area-pointer system-area-pointer-p))
26
27 (in-package "LISP")
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 eq eql equal equalp not
33 type-of upgraded-array-element-type realp
34 ;; Names of types...
35 array atom bignum bit bit-vector character
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 base-char string symbol t
41 unsigned-byte vector 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 complex-double-float-p
61 complex-float-p
62 #+long-float complex-long-float-p
63 complex-rational-p
64 complex-single-float-p
65 #+double-double double-double-float-p
66 double-float-p
67 fdefn-p
68 fixnump
69 floatp
70 functionp
71 integerp
72 listp
73 long-float-p
74 lra-p
75 not
76 null
77 numberp
78 rationalp
79 ratiop
80 realp
81 scavenger-hook-p
82 short-float-p
83 simple-array-p
84 simple-bit-vector-p
85 simple-string-p
86 simple-vector-p
87 single-float-p
88 stringp
89 %instancep
90 symbolp
91 system-area-pointer-p
92 weak-pointer-p
93 vectorp
94 unsigned-byte-32-p
95 signed-byte-32-p
96 simple-array-unsigned-byte-2-p
97 simple-array-unsigned-byte-4-p
98 simple-array-unsigned-byte-8-p
99 simple-array-unsigned-byte-16-p
100 simple-array-unsigned-byte-32-p
101 simple-array-signed-byte-8-p
102 simple-array-signed-byte-16-p
103 simple-array-signed-byte-30-p
104 simple-array-signed-byte-32-p
105 simple-array-single-float-p
106 simple-array-double-float-p
107 #+long-float simple-array-long-float-p
108 #+double-double simple-array-double-double-float-p
109 simple-array-complex-single-float-p
110 simple-array-complex-double-float-p
111 #+long-float simple-array-complex-long-float-p
112 )))
113
114 (macrolet
115 ((frob ()
116 `(progn
117 ,@(mapcar #'(lambda (pred)
118 `(defun ,pred (object)
119 ,(format nil
120 "Return T if OBJECT is a~:[~;n~] ~(~A~) ~
121 and NIL otherwise."
122 (find (schar (string pred) 0) "AEIOUaeiou")
123 (string pred))
124 (,pred object)))
125 primitive-predicates))))
126 (frob))
127
128
129 ;;;; TYPE-OF -- public.
130 ;;;
131 ;;; Return the specifier for the type of object. This is not simply
132 ;;; (type-specifier (ctype-of object)) because ctype-of has different goals
133 ;;; than type-of. In particular, speed is more important than precision, and
134 ;;; it is not permitted to return member types.
135 ;;;
136 (defun type-of (object)
137 "Return the type of OBJECT."
138 (typecase object
139 ((or array complex)
140 (type-specifier (ctype-of object)))
141 (integer
142 `(integer ,object ,object))
143 ((member t)
144 'boolean)
145 (keyword
146 'keyword)
147 (standard-char
148 'standard-char)
149 (t
150 (let* ((class (layout-class (layout-of object)))
151 (name (%class-name class)))
152 (if (%instancep object)
153 (if (eq name 'alien-internals:alien-value)
154 `(alien:alien ,(alien-internals:unparse-alien-type
155 (alien-internals:alien-value-type object)))
156 (let ((proper-name (class-proper-name class)))
157 (if (kernel::class-p proper-name)
158 (%class-pcl-class proper-name)
159 proper-name)))
160 name)))))
161
162
163 ;;;; UPGRADED-ARRAY-ELEMENT-TYPE -- public
164 ;;;
165 (defun upgraded-array-element-type (spec &optional environment)
166 "Return the element type that will actually be used to implement an array
167 with the specifier :ELEMENT-TYPE Spec."
168 ;; Type expansion (TYPE-EXPAND) currently doesn't handle environments.
169 (declare (ignore environment))
170 (type-specifier
171 (array-type-specialized-element-type
172 (specifier-type `(array ,spec)))))
173
174 ;;;; SUBTYPEP -- public.
175 ;;;
176 ;;; Just parse the type specifiers and call csubtype.
177 ;;;
178 (defun subtypep (type1 type2 &optional environment)
179 "Return two values indicating the relationship between type1 and type2:
180 T and T: type1 definitely is a subtype of type2.
181 NIL and T: type1 definitely is not a subtype of type2.
182 NIL and NIL: who knows?"
183 (declare (ignore environment))
184 (csubtypep (specifier-type type1) (specifier-type type2)))
185
186
187 ;;;; TYPEP:
188
189 (declaim (start-block typep %typep class-cell-typep))
190
191 ;;; TYPEP -- public.
192 ;;;
193 ;;; Just call %typep
194 ;;;
195 (defun typep (object type &optional environment)
196 "Return T iff OBJECT is of type TYPE."
197 (declare (ignore environment))
198 (%typep object type))
199
200
201 ;;; %TYPEP -- internal.
202 ;;;
203 ;;; The actual typep engine. The compiler only generates calls to this
204 ;;; function when it can't figure out anything more intelligent to do.
205 ;;;
206 (defun %typep (object specifier)
207 (%%typep object
208 (if (ctype-p specifier)
209 specifier
210 (specifier-type specifier))))
211 ;;;
212 (defun %%typep (object type)
213 (declare (type ctype type))
214 (etypecase type
215 (named-type
216 (ecase (named-type-name type)
217 ((* t) t)
218 ((nil) nil)))
219 (numeric-type
220 (and (numberp object)
221 (let ((num (if (complexp object) (realpart object) object)))
222 (ecase (numeric-type-class type)
223 (integer (integerp num))
224 (rational (rationalp num))
225 (float
226 (ecase (numeric-type-format type)
227 (short-float (typep num 'short-float))
228 (single-float (typep num 'single-float))
229 (double-float (typep num 'double-float))
230 (long-float (typep num 'long-float))
231 (double-double-float (typep num 'double-double-float))
232 ((nil) (floatp num))))
233 ((nil) t)))
234 (flet ((bound-test (val)
235 (let ((low (numeric-type-low type))
236 (high (numeric-type-high type)))
237 (and (cond ((null low) t)
238 ((listp low) (> val (car low)))
239 (t (>= val low)))
240 (cond ((null high) t)
241 ((listp high) (< val (car high)))
242 (t (<= val high)))))))
243 (ecase (numeric-type-complexp type)
244 ((nil) t)
245 (:complex
246 (and (complexp object)
247 (bound-test (realpart object))
248 (bound-test (imagpart object))))
249 (:real
250 (and (not (complexp object))
251 (bound-test object)))))))
252 (array-type
253 (and (arrayp object)
254 (ecase (array-type-complexp type)
255 ((t) (not (typep object 'simple-array)))
256 ((nil) (typep object 'simple-array))
257 ((* :maybe) t))
258 (or (eq (array-type-dimensions type) '*)
259 (do ((want (array-type-dimensions type) (cdr want))
260 (got (array-dimensions object) (cdr got)))
261 ((and (null want) (null got)) t)
262 (unless (and want got
263 (or (eq (car want) '*)
264 (= (car want) (car got))))
265 (return nil))))
266 (if (unknown-type-p (array-type-element-type type))
267 ;; better to fail this way than to get bogosities like
268 ;; (TYPEP (MAKE-ARRAY 11) '(ARRAY SOME-UNDEFINED-TYPE)) => T
269 (error "~@<unknown element type in array type: ~2I~_~S~:>"
270 (type-specifier type))
271 t)
272 (or (eq (array-type-element-type type) *wild-type*)
273 (values (type= (array-type-specialized-element-type type)
274 (specifier-type (array-element-type
275 object)))))))
276 (member-type
277 (if (member object (member-type-members type)) t))
278 (kernel::class
279 (class-typep (layout-of object) type object))
280 (union-type
281 (some (lambda (type) (%%typep object type))
282 (union-type-types type)))
283 (intersection-type
284 (every (lambda (type) (%%typep object type))
285 (intersection-type-types type)))
286 (cons-type
287 (and (consp object)
288 (%%typep (car object) (cons-type-car-type type))
289 (%%typep (cdr object) (cons-type-cdr-type type))))
290 (unknown-type
291 ;; Parse it again to make sure it's really undefined.
292 (let ((reparse (specifier-type (unknown-type-specifier type))))
293 (if (typep reparse 'unknown-type)
294 (error "Unknown type specifier: ~S"
295 (unknown-type-specifier reparse))
296 (%%typep object reparse))))
297 (negation-type
298 (not (%%typep object (negation-type-type type))))
299 (hairy-type
300 ;; Now the tricky stuff.
301 (let* ((hairy-spec (hairy-type-specifier type))
302 (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
303 (ecase symbol
304 (and
305 (every (lambda (spec) (%%typep object (specifier-type spec)))
306 (rest hairy-spec)))
307 ;; Note: it should be safe to skip OR here, because union
308 ;; types can always be represented as UNION-TYPE in general
309 ;; or other CTYPEs in special cases; we never need to use
310 ;; HAIRY-TYPE for them.
311 (not
312 (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
313 (error "Invalid type specifier: ~S" hairy-spec))
314 (not (%%typep object (specifier-type (cadr hairy-spec)))))
315 (satisfies
316 (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
317 (error "Invalid type specifier: ~S" hairy-spec))
318 (let ((fn (cadr hairy-spec)))
319 (if (funcall (typecase fn
320 (function fn)
321 (symbol (symbol-function fn))
322 (t
323 (coerce fn 'function)))
324 object)
325 t
326 nil))))))
327 (alien-type-type
328 (alien-internals:alien-typep object (alien-type-type-alien-type type)))
329 (function-type
330 (error "Function types are not a legal argument to TYPEP:~% ~S"
331 (type-specifier type)))))
332
333
334 ;;; CLASS-CELL-TYPEP -- Interface
335 ;;;
336 ;;; Do type test from a class cell, allowing forward reference and
337 ;;; redefinition.
338 ;;;
339 (defun class-cell-typep (obj-layout cell object)
340 (let ((class (class-cell-class cell)))
341 (unless class
342 (error "Class has not yet been defined: ~S" (class-cell-name cell)))
343 (class-typep obj-layout class object)))
344
345
346 ;;; CLASS-TYPEP -- Internal
347 ;;;
348 ;;; Test whether Obj-Layout is from an instance of Class.
349 ;;;
350 (defun class-typep (obj-layout class object)
351 (declare (optimize speed))
352 (when (layout-invalid obj-layout)
353 (if (and (typep (kernel::class-of object) 'kernel::standard-class) object)
354 (setq obj-layout (pcl::check-wrapper-validity object))
355 (error "TYPEP on obsolete object (was class ~S)."
356 (class-proper-name (layout-class obj-layout)))))
357 (let ((layout (%class-layout class))
358 (obj-inherits (layout-inherits obj-layout)))
359 (when (layout-invalid layout)
360 (error "Class is currently invalid: ~S" class))
361 (or (eq obj-layout layout)
362 (dotimes (i (length obj-inherits) nil)
363 (when (eq (svref obj-inherits i) layout)
364 (return t))))))
365
366 (declaim (end-block))
367
368
369 ;;;; Equality predicates.
370
371 ;;; EQ -- public.
372 ;;;
373 ;;; Real simple, 'cause the compiler takes care of it.
374 ;;;
375
376 (defun eq (obj1 obj2)
377 "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
378 (eq obj1 obj2))
379
380
381 ;;; EQUAL -- public.
382 ;;;
383 (defun equal (x y)
384 "Returns T if X and Y are EQL or if they are structured components
385 whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
386 are the same length and have indentical components. Other arrays must be
387 EQ to be EQUAL."
388 (cond ((eql x y) t)
389 ((consp x)
390 (and (consp y)
391 (equal (car x) (car y))
392 (equal (cdr x) (cdr y))))
393 ((stringp x)
394 (and (stringp y) (string= x y)))
395 ((pathnamep x)
396 (and (pathnamep y) (pathname= x y)))
397 ((bit-vector-p x)
398 (and (bit-vector-p y)
399 (= (the fixnum (length x))
400 (the fixnum (length y)))
401 (do ((i 0 (1+ i))
402 (length (length x)))
403 ((= i length) t)
404 (declare (fixnum i))
405 (or (= (the fixnum (bit x i))
406 (the fixnum (bit y i)))
407 (return nil)))))
408 (t nil)))
409
410 ;;; EQUALP -- public.
411 ;;;
412 (defun equalp (x y)
413 "Just like EQUAL, but more liberal in several respects.
414 Numbers may be of different types, as long as the values are identical
415 after coercion. Characters may differ in alphabetic case. Vectors and
416 arrays must have identical dimensions and EQUALP elements, but may differ
417 in their type restriction."
418 (cond ((eq x y) t)
419 ((characterp x) (and (characterp y) (char-equal x y)))
420 ((numberp x) (and (numberp y) (= x y)))
421 ((consp x)
422 (and (consp y)
423 (equalp (car x) (car y))
424 (equalp (cdr x) (cdr y))))
425 ((pathnamep x)
426 (and (pathnamep y) (pathname= x y)))
427 ((hash-table-p x)
428 (and (hash-table-p y)
429 (eql (hash-table-count x) (hash-table-count y))
430 (eql (hash-table-test x) (hash-table-test y))
431 (with-hash-table-iterator (next x)
432 (loop
433 (multiple-value-bind (more x-key x-value)
434 (next)
435 (cond (more
436 (multiple-value-bind (y-value foundp)
437 (gethash x-key y)
438 (unless (and foundp (equalp x-value y-value))
439 (return nil))))
440 (t
441 (return t))))))))
442 ((%instancep x)
443 (let* ((layout-x (%instance-layout x))
444 (len (layout-length layout-x)))
445 (and (%instancep y)
446 (eq layout-x (%instance-layout y))
447 (structure-class-p (layout-class layout-x))
448 (do ((i 1 (1+ i)))
449 ((= i len) t)
450 (declare (fixnum i))
451 (let ((x-el (%instance-ref x i))
452 (y-el (%instance-ref y i)))
453 (unless (or (eq x-el y-el)
454 (equalp x-el y-el))
455 (return nil)))))))
456 ((vectorp x)
457 (let ((length (length x)))
458 (and (vectorp y)
459 (= length (length y))
460 (dotimes (i length t)
461 (let ((x-el (aref x i))
462 (y-el (aref y i)))
463 (unless (or (eq x-el y-el)
464 (equalp x-el y-el))
465 (return nil)))))))
466 ((arrayp x)
467 (and (arrayp y)
468 (= (array-rank x) (array-rank y))
469 (dotimes (axis (array-rank x) t)
470 (unless (= (array-dimension x axis)
471 (array-dimension y axis))
472 (return nil)))
473 (dotimes (index (array-total-size x) t)
474 (let ((x-el (row-major-aref x index))
475 (y-el (row-major-aref y index)))
476 (unless (or (eq x-el y-el)
477 (equalp x-el y-el))
478 (return nil))))))
479 (t nil)))

  ViewVC Help
Powered by ViewVC 1.1.5