/[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 - (show annotations)
Fri Jun 9 16:04:57 2006 UTC (7 years, 10 months ago) by rtoy
Branch: double-double-branch
CVS Tags: double-double-array-base, double-double-init-sparc-2, double-double-init-sparc, double-double-init-ppc, double-double-init-%make-sparc, double-double-reader-checkpoint-1, double-double-init-checkpoint-1, double-double-reader-base, double-double-init-x86
Branch point for: double-double-reader-branch, double-double-array-branch
Changes since 1.59: +7 -2 lines
Add basic support for kernel:double-double-float type.  The primitive
type is there, and basic arithmetic operations work as well as PRINT.
But many things do not work: No reader, formatted output, many mixed
type arithmetic operations, special functions are just double-float
values, coerced to double-double-float.

compiler/generic/interr.lisp:
o Add new error

compiler/generic/new-genesis.lisp:
o Dump double-double-float objects (barely tested)

compiler/generic/primtype.lisp:
o Tell compiler about the new primitive type double-double-float.

compiler/generic/vm-fndb.lisp:
o Make double-double-float-p a known function.

compiler/generic/vm-type.lisp:
o Update FLOAT-FORMAT-NAME to include double-double-float

compiler/generic/vm-typetran.lisp:
o Tell compiler about double-double-float type predicate.

compiler/sparc/float.lisp:
o Add necessary vops to move double-double-float args, store and load
  double-double-floats to/from the double-double-stack,
  double-double-reg moves, box and unbox double-double-floats, move
  double-double-floats to and from args
o Add necessary vops to create a double-double-float and to extract
  the high and low parts out of a double-double-float.

compiler/sparc/parms.lisp:
o Define double-double-float-digits

compiler/sparc/type-vops.lisp:
o Define double-double-float type vop
o Adjust number hierarchy to include double-double-float

compiler/sparc/vm.lisp:
o Define the necessary storage class and storage base for the
  double-double-reg and double-double-stack.

lisp/gencgc.c:
o Tell GC about double-double-float objects.

lisp/purify.c:
o Tell purify about double-double-float objects.

code/class.lisp:
o Add the new double-double-float class.

code/exports.lisp:
o Add the necessary symbols to the various packages.  (This is
  important to get right otherwise there's confusion on what symbol
  really represents double-double-float stuff.)

code/float.lisp:
o Implement some of the necessary functions to support
  double-double-float.

code/hash-new.lisp:
o Hash double-double-floats by xor'ing the hashes of each double-float
  part.  (Is that good enough?)

code/irrat.lisp:
o Implement the special functions by calling the double-float versions
  and coercing the result to a double-double-float.  This is needed to
  get type-derivation working, but the precise value isn't that
  important right now.  We'll have to implement them later.

code/kernel.lisp:
o Make make-double-double-float, double-double-hi, and
  double-double-lo known functions.

code/lispinit.lisp:
o Register the :double-double float feature.

code/load.lisp:
o Add FOP for reading double-double-float values from fasls.  (Barely
  tested, if at all.)

code/numbers.lisp:
o Implement basic arithmetic operations for double-double-floats.
  This needs quite a bit of work to clean up, but most things work.

code/pred.lisp:
o Tell the type system about double-double-float type.

code/print.lisp:
o Add very rudimentary printing for double-double-float.  Basically
  copied from code written by Richard Fateman, with permission.

code/seq.lisp:
o Tell coerce how to coerce things to a double-double-float.

code/type.lisp:
o Tell type system about the new float format double-double-float and
  how numeric contagion works with double-double-float.

code/dump.lisp:
o Tell dumper how to dump double-double-float values to a fasl.

compiler/float-tran.lisp:
o Add appropriate deftransforms to handle conversion of things to
  double-double-float and from from double-double-float to other float
  types.
o The basic implmentation of double-double-float arithmetic is also
  here.
o Add deftransforms to tell the compiler how to do basic arithmetic
  and comparisions on double-double-float numbers.

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

  ViewVC Help
Powered by ViewVC 1.1.5