Mercurial > hg > xemacs-beta
diff tests/automated/lisp-tests.el @ 4678:b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
lisp/ChangeLog addition:
2009-08-11 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (ceiling*, floor*, round*, truncate*):
Implement these in terms of the C functions; mark them as
obsolete.
(mod*, rem*): Use #'nth-value with the C functions, not #'nth with
the CL emulation functions.
man/ChangeLog addition:
2009-08-11 Aidan Kehoe <kehoea@parhasard.net>
* lispref/numbers.texi (Bigfloat Basics):
Correct this documentation (ignoring for the moment that it breaks
off in mid-sentence).
tests/ChangeLog addition:
2009-08-11 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el:
Test the new Common Lisp-compatible rounding functions available in
C.
(generate-rounding-output): Provide a function useful for
generating the data for the rounding functions tests.
src/ChangeLog addition:
2009-08-11 Aidan Kehoe <kehoea@parhasard.net>
* floatfns.c (ROUNDING_CONVERT, CONVERT_WITH_NUMBER_TYPES)
(CONVERT_WITHOUT_NUMBER_TYPES, MAYBE_TWO_ARGS_BIGNUM)
(MAYBE_ONE_ARG_BIGNUM, MAYBE_TWO_ARGS_RATIO)
(MAYBE_ONE_ARG_RATIO, MAYBE_TWO_ARGS_BIGFLOAT)
(MAYBE_ONE_ARG_BIGFLOAT, MAYBE_EFF, MAYBE_CHAR_OR_MARKER):
New macros, used in the implementation of the rounding functions.
(ceiling_two_fixnum, ceiling_two_bignum, ceiling_two_ratio)
(ceiling_two_bigfloat, ceiling_one_ratio, ceiling_one_bigfloat)
(ceiling_two_float, ceiling_one_float, ceiling_one_mundane_arg)
(floor_two_fixnum, floor_two_bignum, floor_two_ratio)
(floor_two_bigfloat, floor_one_ratio, floor_one_bigfloat)
(floor_two_float, floor_one_mundane_arg, round_two_fixnum)
(round_two_bignum_1, round_two_bignum, round_two_ratio)
(round_one_bigfloat_1, round_two_bigfloat, round_one_ratio)
(round_one_bigfloat, round_two_float, round_one_float)
(round_one_mundane_arg, truncate_two_fixnum)
(truncate_two_bignum, truncate_two_ratio, truncate_two_bigfloat)
(truncate_one_ratio, truncate_one_bigfloat, truncate_two_float)
(truncate_one_float, truncate_one_mundane_arg):
New functions, used in the implementation of the rounding
functions.
(Fceiling, Ffloor, Fround, Ftruncate, Ffceiling, Fffloor)
(Ffround, Fftruncate):
Revise to fully support Common Lisp conventions. This means:
-- All functions have optional DIVISOR arguments
-- All functions return multiple values; see #'values
-- All functions do their arithmetic with the correct number types
according to the contamination rules.
-- #'round and #'fround always round towards the even number
in ambiguous cases.
* doprnt.c (emacs_doprnt_1):
* number.c (internal_coerce_number):
Call Ftruncate with two arguments, not one.
* floatfns.c (Ffloat):
Correct this, if NUMBER is a bignum.
* lisp.h:
Declare Ftruncate as taking two arguments.
* number.c:
Provide scratch_ratio2, init it appropriately.
* number.h:
Make scratch_ratio2 available.
* number.h (BIGFLOAT_ARITH_RETURN):
* number.h (BIGFLOAT_ARITH_RETURN1):
Correct these functions.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Tue, 11 Aug 2009 17:59:23 +0100 |
| parents | 1e3cf11fa27d |
| children | 2c64d2bbb316 |
line wrap: on
line diff
--- a/tests/automated/lisp-tests.el Sun Aug 16 20:55:49 2009 +0100 +++ b/tests/automated/lisp-tests.el Tue Aug 11 17:59:23 2009 +0100 @@ -1368,5 +1368,574 @@ (load test-file-name nil t nil) (delete-file test-file-name)) +(flet ((cl-floor (x &optional y) + (let ((q (floor x y))) + (list q (- x (if y (* y q) q))))) + (cl-ceiling (x &optional y) + (let ((res (cl-floor x y))) + (if (= (car (cdr res)) 0) res + (list (1+ (car res)) (- (car (cdr res)) (or y 1)))))) + (cl-truncate (x &optional y) + (if (eq (>= x 0) (or (null y) (>= y 0))) + (cl-floor x y) (cl-ceiling x y))) + (cl-round (x &optional y) + (if y + (if (and (integerp x) (integerp y)) + (let* ((hy (/ y 2)) + (res (cl-floor (+ x hy) y))) + (if (and (= (car (cdr res)) 0) + (= (+ hy hy) y) + (/= (% (car res) 2) 0)) + (list (1- (car res)) hy) + (list (car res) (- (car (cdr res)) hy)))) + (let ((q (round (/ x y)))) + (list q (- x (* q y))))) + (if (integerp x) (list x 0) + (let ((q (round x))) + (list q (- x q)))))) + (Assert-rounding (first second &key + one-floor-result two-floor-result + one-ffloor-result two-ffloor-result + one-ceiling-result two-ceiling-result + one-fceiling-result two-fceiling-result + one-round-result two-round-result + one-fround-result two-fround-result + one-truncate-result two-truncate-result + one-ftruncate-result two-ftruncate-result) + (Assert (equal one-floor-result (multiple-value-list + (floor first))) + (format "checking (floor %S) gives %S" + first one-floor-result)) + (Assert (equal one-floor-result (multiple-value-list + (floor first 1))) + (format "checking (floor %S 1) gives %S" + first one-floor-result)) + (Check-Error arith-error (floor first 0)) + (Check-Error arith-error (floor first 0.0)) + (Assert (equal two-floor-result (multiple-value-list + (floor first second))) + (format + "checking (floor %S %S) gives %S" + first second two-floor-result)) + (Assert (equal (cl-floor first second) + (multiple-value-list (floor first second))) + (format + "checking (floor %S %S) gives the same as the old code" + first second)) + (Assert (equal one-ffloor-result (multiple-value-list + (ffloor first))) + (format "checking (ffloor %S) gives %S" + first one-ffloor-result)) + (Assert (equal one-ffloor-result (multiple-value-list + (ffloor first 1))) + (format "checking (ffloor %S 1) gives %S" + first one-ffloor-result)) + (Check-Error arith-error (ffloor first 0)) + (Check-Error arith-error (ffloor first 0.0)) + (Assert (equal two-ffloor-result (multiple-value-list + (ffloor first second))) + (format "checking (ffloor %S %S) gives %S" + first second two-ffloor-result)) + (Assert (equal one-ceiling-result (multiple-value-list + (ceiling first))) + (format "checking (ceiling %S) gives %S" + first one-ceiling-result)) + (Assert (equal one-ceiling-result (multiple-value-list + (ceiling first 1))) + (format "checking (ceiling %S 1) gives %S" + first one-ceiling-result)) + (Check-Error arith-error (ceiling first 0)) + (Check-Error arith-error (ceiling first 0.0)) + (Assert (equal two-ceiling-result (multiple-value-list + (ceiling first second))) + (format "checking (ceiling %S %S) gives %S" + first second two-ceiling-result)) + (Assert (equal (cl-ceiling first second) + (multiple-value-list (ceiling first second))) + (format + "checking (ceiling %S %S) gives the same as the old code" + first second)) + (Assert (equal one-fceiling-result (multiple-value-list + (fceiling first))) + (format "checking (fceiling %S) gives %S" + first one-fceiling-result)) + (Assert (equal one-fceiling-result (multiple-value-list + (fceiling first 1))) + (format "checking (fceiling %S 1) gives %S" + first one-fceiling-result)) + (Check-Error arith-error (fceiling first 0)) + (Check-Error arith-error (fceiling first 0.0)) + (Assert (equal two-fceiling-result (multiple-value-list + (fceiling first second))) + (format "checking (fceiling %S %S) gives %S" + first second two-fceiling-result)) + (Assert (equal one-round-result (multiple-value-list + (round first))) + (format "checking (round %S) gives %S" + first one-round-result)) + (Assert (equal one-round-result (multiple-value-list + (round first 1))) + (format "checking (round %S 1) gives %S, types %S, actual %S, types %S" + first one-round-result (mapcar #'type-of one-round-result) + (multiple-value-list (round first 1)) + (mapcar #'type-of (multiple-value-list (round first 1))))) + (Check-Error arith-error (round first 0)) + (Check-Error arith-error (round first 0.0)) + (Assert (equal two-round-result (multiple-value-list + (round first second))) + (format "checking (round %S %S) gives %S" + first second two-round-result)) + (Assert (equal one-fround-result (multiple-value-list + (fround first))) + (format "checking (fround %S) gives %S" + first one-fround-result)) + (Assert (equal one-fround-result (multiple-value-list + (fround first 1))) + (format "checking (fround %S 1) gives %S" + first one-fround-result)) + (Check-Error arith-error (fround first 0)) + (Check-Error arith-error (fround first 0.0)) + (Assert (equal two-fround-result (multiple-value-list + (fround first second))) + (format "checking (fround %S %S) gives %S" + first second two-fround-result)) + (Assert (equal (cl-round first second) + (multiple-value-list (round first second))) + (format + "checking (round %S %S) gives the same as the old code" + first second)) + (Assert (equal one-truncate-result (multiple-value-list + (truncate first))) + (format "checking (truncate %S) gives %S" + first one-truncate-result)) + (Assert (equal one-truncate-result (multiple-value-list + (truncate first 1))) + (format "checking (truncate %S 1) gives %S" + first one-truncate-result)) + (Check-Error arith-error (truncate first 0)) + (Check-Error arith-error (truncate first 0.0)) + (Assert (equal two-truncate-result (multiple-value-list + (truncate first second))) + (format "checking (truncate %S %S) gives %S" + first second two-truncate-result)) + (Assert (equal (cl-truncate first second) + (multiple-value-list (truncate first second))) + (format + "checking (truncate %S %S) gives the same as the old code" + first second)) + (Assert (equal one-ftruncate-result (multiple-value-list + (ftruncate first))) + (format "checking (ftruncate %S) gives %S" + first one-ftruncate-result)) + (Assert (equal one-ftruncate-result (multiple-value-list + (ftruncate first 1))) + (format "checking (ftruncate %S 1) gives %S" + first one-ftruncate-result)) + (Check-Error arith-error (ftruncate first 0)) + (Check-Error arith-error (ftruncate first 0.0)) + (Assert (equal two-ftruncate-result (multiple-value-list + (ftruncate first second))) + (format "checking (ftruncate %S %S) gives %S" + first second two-ftruncate-result))) + (Assert-rounding-floating (pie ee) + (let ((pie-type (type-of pie))) + (assert (eq pie-type (type-of ee)) t + "This code assumes the two arguments have the same type.") + (Assert-rounding pie ee + :one-floor-result (list 3 (- pie 3)) + :two-floor-result (list 1 (- pie (* 1 ee))) + :one-ffloor-result (list (coerce 3 pie-type) (- pie 3.0)) + :two-ffloor-result (list (coerce 1 pie-type) (- pie (* 1.0 ee))) + :one-ceiling-result (list 4 (- pie 4)) + :two-ceiling-result (list 2 (- pie (* 2 ee))) + :one-fceiling-result (list (coerce 4 pie-type) (- pie 4.0)) + :two-fceiling-result (list (coerce 2 pie-type) (- pie (* 2.0 ee))) + :one-round-result (list 3 (- pie 3)) + :two-round-result (list 1 (- pie (* 1 ee))) + :one-fround-result (list (coerce 3 pie-type) (- pie 3.0)) + :two-fround-result (list (coerce 1 pie-type) (- pie (* 1.0 ee))) + :one-truncate-result (list 3 (- pie 3)) + :two-truncate-result (list 1 (- pie (* 1 ee))) + :one-ftruncate-result (list (coerce 3 pie-type) (- pie 3.0)) + :two-ftruncate-result (list (coerce 1 pie-type) + (- pie (* 1.0 ee)))) + (Assert-rounding pie (- ee) + :one-floor-result (list 3 (- pie 3)) + :two-floor-result (list -2 (- pie (* -2 (- ee)))) + :one-ffloor-result (list (coerce 3 pie-type) (- pie 3.0)) + :two-ffloor-result (list (coerce -2 pie-type) + (- pie (* -2.0 (- ee)))) + :one-ceiling-result (list 4 (- pie 4)) + :two-ceiling-result (list -1 (- pie (* -1 (- ee)))) + :one-fceiling-result (list (coerce 4 pie-type) (- pie 4.0)) + :two-fceiling-result (list (coerce -1 pie-type) + (- pie (* -1.0 (- ee)))) + :one-round-result (list 3 (- pie 3)) + :two-round-result (list -1 (- pie (* -1 (- ee)))) + :one-fround-result (list (coerce 3 pie-type) (- pie 3.0)) + :two-fround-result (list (coerce -1 pie-type) + (- pie (* -1.0 (- ee)))) + :one-truncate-result (list 3 (- pie 3)) + :two-truncate-result (list -1 (- pie (* -1 (- ee)))) + :one-ftruncate-result (list (coerce 3 pie-type) (- pie 3.0)) + :two-ftruncate-result (list (coerce -1 pie-type) + (- pie (* -1.0 (- ee))))) + (Assert-rounding (- pie) ee + :one-floor-result (list -4 (- (- pie) -4)) + :two-floor-result (list -2 (- (- pie) (* -2 ee))) + :one-ffloor-result (list (coerce -4 pie-type) (- (- pie) -4.0)) + :two-ffloor-result (list (coerce -2 pie-type) + (- (- pie) (* -2.0 ee))) + :one-ceiling-result (list -3 (- (- pie) -3)) + :two-ceiling-result (list -1 (- (- pie) (* -1 ee))) + :one-fceiling-result (list (coerce -3 pie-type) (- (- pie) -3.0)) + :two-fceiling-result (list (coerce -1 pie-type) + (- (- pie) (* -1.0 ee))) + :one-round-result (list -3 (- (- pie) -3)) + :two-round-result (list -1 (- (- pie) (* -1 ee))) + :one-fround-result (list (coerce -3 pie-type) (- (- pie) -3.0)) + :two-fround-result (list (coerce -1 pie-type) + (- (- pie) (* -1.0 ee))) + :one-truncate-result (list -3 (- (- pie) -3)) + :two-truncate-result (list -1 (- (- pie) (* -1 ee))) + :one-ftruncate-result (list (coerce -3 pie-type) (- (- pie) -3.0)) + :two-ftruncate-result (list (coerce -1 pie-type) + (- (- pie) (* -1.0 ee)))) + (Assert-rounding (- pie) (- ee) + :one-floor-result (list -4 (- (- pie) -4)) + :two-floor-result (list 1 (- (- pie) (* 1 (- ee)))) + :one-ffloor-result (list (coerce -4 pie-type) (- (- pie) -4.0)) + :two-ffloor-result (list (coerce 1 pie-type) + (- (- pie) (* 1.0 (- ee)))) + :one-ceiling-result (list -3 (- (- pie) -3)) + :two-ceiling-result (list 2 (- (- pie) (* 2 (- ee)))) + :one-fceiling-result (list (coerce -3 pie-type) (- (- pie) -3.0)) + :two-fceiling-result (list (coerce 2 pie-type) + (- (- pie) (* 2.0 (- ee)))) + :one-round-result (list -3 (- (- pie) -3)) + :two-round-result (list 1 (- (- pie) (* 1 (- ee)))) + :one-fround-result (list (coerce -3 pie-type) (- (- pie) -3.0)) + :two-fround-result (list (coerce 1 pie-type) + (- (- pie) (* 1.0 (- ee)))) + :one-truncate-result (list -3 (- (- pie) -3)) + :two-truncate-result (list 1 (- (- pie) (* 1 (- ee)))) + :one-ftruncate-result (list (coerce -3 pie-type) (- (- pie) -3.0)) + :two-ftruncate-result (list (coerce 1 pie-type) + (- (- pie) (* 1.0 (- ee))))) + (Assert-rounding ee pie + :one-floor-result (list 2 (- ee 2)) + :two-floor-result (list 0 ee) + :one-ffloor-result (list (coerce 2 pie-type) (- ee 2.0)) + :two-ffloor-result (list (coerce 0 pie-type) ee) + :one-ceiling-result (list 3 (- ee 3)) + :two-ceiling-result (list 1 (- ee pie)) + :one-fceiling-result (list (coerce 3 pie-type) (- ee 3.0)) + :two-fceiling-result (list (coerce 1 pie-type) (- ee pie)) + :one-round-result (list 3 (- ee 3)) + :two-round-result (list 1 (- ee (* 1 pie))) + :one-fround-result (list (coerce 3 pie-type) (- ee 3.0)) + :two-fround-result (list (coerce 1 pie-type) (- ee (* 1.0 pie))) + :one-truncate-result (list 2 (- ee 2)) + :two-truncate-result (list 0 ee) + :one-ftruncate-result (list (coerce 2 pie-type) (- ee 2.0)) + :two-ftruncate-result (list (coerce 0 pie-type) ee)) + (Assert-rounding ee (- pie) + :one-floor-result (list 2 (- ee 2)) + :two-floor-result (list -1 (- ee (* -1 (- pie)))) + :one-ffloor-result (list (coerce 2 pie-type) (- ee 2.0)) + :two-ffloor-result (list (coerce -1 pie-type) + (- ee (* -1.0 (- pie)))) + :one-ceiling-result (list 3 (- ee 3)) + :two-ceiling-result (list 0 ee) + :one-fceiling-result (list (coerce 3 pie-type) (- ee 3.0)) + :two-fceiling-result (list (coerce 0 pie-type) ee) + :one-round-result (list 3 (- ee 3)) + :two-round-result (list -1 (- ee (* -1 (- pie)))) + :one-fround-result (list (coerce 3 pie-type) (- ee 3.0)) + :two-fround-result (list (coerce -1 pie-type) + (- ee (* -1.0 (- pie)))) + :one-truncate-result (list 2 (- ee 2)) + :two-truncate-result (list 0 ee) + :one-ftruncate-result (list (coerce 2 pie-type) (- ee 2.0)) + :two-ftruncate-result (list (coerce 0 pie-type) ee))))) + ;; First, two integers: + (Assert-rounding 27 8 :one-floor-result '(27 0) :two-floor-result '(3 3) + :one-ffloor-result '(27.0 0) :two-ffloor-result '(3.0 3) + :one-ceiling-result '(27 0) :two-ceiling-result '(4 -5) + :one-fceiling-result '(27.0 0) :two-fceiling-result '(4.0 -5) + :one-round-result '(27 0) :two-round-result '(3 3) + :one-fround-result '(27.0 0) :two-fround-result '(3.0 3) + :one-truncate-result '(27 0) :two-truncate-result '(3 3) + :one-ftruncate-result '(27.0 0) :two-ftruncate-result '(3.0 3)) + (Assert-rounding 27 -8 :one-floor-result '(27 0) :two-floor-result '(-4 -5) + :one-ffloor-result '(27.0 0) :two-ffloor-result '(-4.0 -5) + :one-ceiling-result '(27 0) :two-ceiling-result '(-3 3) + :one-fceiling-result '(27.0 0) :two-fceiling-result '(-3.0 3) + :one-round-result '(27 0) :two-round-result '(-3 3) + :one-fround-result '(27.0 0) :two-fround-result '(-3.0 3) + :one-truncate-result '(27 0) :two-truncate-result '(-3 3) + :one-ftruncate-result '(27.0 0) :two-ftruncate-result '(-3.0 3)) + (Assert-rounding -27 8 + :one-floor-result '(-27 0) :two-floor-result '(-4 5) + :one-ffloor-result '(-27.0 0) :two-ffloor-result '(-4.0 5) + :one-ceiling-result '(-27 0) :two-ceiling-result '(-3 -3) + :one-fceiling-result '(-27.0 0) :two-fceiling-result '(-3.0 -3) + :one-round-result '(-27 0) :two-round-result '(-3 -3) + :one-fround-result '(-27.0 0) :two-fround-result '(-3.0 -3) + :one-truncate-result '(-27 0) :two-truncate-result '(-3 -3) + :one-ftruncate-result '(-27.0 0) :two-ftruncate-result '(-3.0 -3)) + (Assert-rounding -27 -8 + :one-floor-result '(-27 0) :two-floor-result '(3 -3) + :one-ffloor-result '(-27.0 0) :two-ffloor-result '(3.0 -3) + :one-ceiling-result '(-27 0) :two-ceiling-result '(4 5) + :one-fceiling-result '(-27.0 0) :two-fceiling-result '(4.0 5) + :one-round-result '(-27 0) :two-round-result '(3 -3) + :one-fround-result '(-27.0 0) :two-fround-result '(3.0 -3) + :one-truncate-result '(-27 0) :two-truncate-result '(3 -3) + :one-ftruncate-result '(-27.0 0) :two-ftruncate-result '(3.0 -3)) + (Assert-rounding 8 27 + :one-floor-result '(8 0) :two-floor-result '(0 8) + :one-ffloor-result '(8.0 0) :two-ffloor-result '(0.0 8) + :one-ceiling-result '(8 0) :two-ceiling-result '(1 -19) + :one-fceiling-result '(8.0 0) :two-fceiling-result '(1.0 -19) + :one-round-result '(8 0) :two-round-result '(0 8) + :one-fround-result '(8.0 0) :two-fround-result '(0.0 8) + :one-truncate-result '(8 0) :two-truncate-result '(0 8) + :one-ftruncate-result '(8.0 0) :two-ftruncate-result '(0.0 8)) + (Assert-rounding 8 -27 + :one-floor-result '(8 0) :two-floor-result '(-1 -19) + :one-ffloor-result '(8.0 0) :two-ffloor-result '(-1.0 -19) + :one-ceiling-result '(8 0) :two-ceiling-result '(0 8) + :one-fceiling-result '(8.0 0) :two-fceiling-result '(0.0 8) + :one-round-result '(8 0) :two-round-result '(0 8) + :one-fround-result '(8.0 0) :two-fround-result '(0.0 8) + :one-truncate-result '(8 0) :two-truncate-result '(0 8) + :one-ftruncate-result '(8.0 0) :two-ftruncate-result '(0.0 8)) + (Assert-rounding -8 27 + :one-floor-result '(-8 0) :two-floor-result '(-1 19) + :one-ffloor-result '(-8.0 0) :two-ffloor-result '(-1.0 19) + :one-ceiling-result '(-8 0) :two-ceiling-result '(0 -8) + :one-fceiling-result '(-8.0 0) :two-fceiling-result '(0.0 -8) + :one-round-result '(-8 0) :two-round-result '(0 -8) + :one-fround-result '(-8.0 0) :two-fround-result '(0.0 -8) + :one-truncate-result '(-8 0) :two-truncate-result '(0 -8) + :one-ftruncate-result '(-8.0 0) :two-ftruncate-result '(0.0 -8)) + (Assert-rounding -8 -27 + :one-floor-result '(-8 0) :two-floor-result '(0 -8) + :one-ffloor-result '(-8.0 0) :two-ffloor-result '(0.0 -8) + :one-ceiling-result '(-8 0) :two-ceiling-result '(1 19) + :one-fceiling-result '(-8.0 0) :two-fceiling-result '(1.0 19) + :one-round-result '(-8 0) :two-round-result '(0 -8) + :one-fround-result '(-8.0 0) :two-fround-result '(0.0 -8) + :one-truncate-result '(-8 0) :two-truncate-result '(0 -8) + :one-ftruncate-result '(-8.0 0) :two-ftruncate-result '(0.0 -8)) + (Assert-rounding 32 4 + :one-floor-result '(32 0) :two-floor-result '(8 0) + :one-ffloor-result '(32.0 0) :two-ffloor-result '(8.0 0) + :one-ceiling-result '(32 0) :two-ceiling-result '(8 0) + :one-fceiling-result '(32.0 0) :two-fceiling-result '(8.0 0) + :one-round-result '(32 0) :two-round-result '(8 0) + :one-fround-result '(32.0 0) :two-fround-result '(8.0 0) + :one-truncate-result '(32 0) :two-truncate-result '(8 0) + :one-ftruncate-result '(32.0 0) :two-ftruncate-result '(8.0 0)) + (Assert-rounding 32 -4 + :one-floor-result '(32 0) :two-floor-result '(-8 0) + :one-ffloor-result '(32.0 0) :two-ffloor-result '(-8.0 0) + :one-ceiling-result '(32 0) :two-ceiling-result '(-8 0) + :one-fceiling-result '(32.0 0) :two-fceiling-result '(-8.0 0) + :one-round-result '(32 0) :two-round-result '(-8 0) + :one-fround-result '(32.0 0) :two-fround-result '(-8.0 0) + :one-truncate-result '(32 0) :two-truncate-result '(-8 0) + :one-ftruncate-result '(32.0 0) :two-ftruncate-result '(-8.0 0)) + (Assert-rounding 12 9 + :one-floor-result '(12 0) :two-floor-result '(1 3) + :one-ffloor-result '(12.0 0) :two-ffloor-result '(1.0 3) + :one-ceiling-result '(12 0) :two-ceiling-result '(2 -6) + :one-fceiling-result '(12.0 0) :two-fceiling-result '(2.0 -6) + :one-round-result '(12 0) :two-round-result '(1 3) + :one-fround-result '(12.0 0) :two-fround-result '(1.0 3) + :one-truncate-result '(12 0) :two-truncate-result '(1 3) + :one-ftruncate-result '(12.0 0) :two-ftruncate-result '(1.0 3)) + (Assert-rounding 10 4 + :one-floor-result '(10 0) :two-floor-result '(2 2) + :one-ffloor-result '(10.0 0) :two-ffloor-result '(2.0 2) + :one-ceiling-result '(10 0) :two-ceiling-result '(3 -2) + :one-fceiling-result '(10.0 0) :two-fceiling-result '(3.0 -2) + :one-round-result '(10 0) :two-round-result '(2 2) + :one-fround-result '(10.0 0) :two-fround-result '(2.0 2) + :one-truncate-result '(10 0) :two-truncate-result '(2 2) + :one-ftruncate-result '(10.0 0) :two-ftruncate-result '(2.0 2)) + (Assert-rounding 14 4 + :one-floor-result '(14 0) :two-floor-result '(3 2) + :one-ffloor-result '(14.0 0) :two-ffloor-result '(3.0 2) + :one-ceiling-result '(14 0) :two-ceiling-result '(4 -2) + :one-fceiling-result '(14.0 0) :two-fceiling-result '(4.0 -2) + :one-round-result '(14 0) :two-round-result '(4 -2) + :one-fround-result '(14.0 0) :two-fround-result '(4.0 -2) + :one-truncate-result '(14 0) :two-truncate-result '(3 2) + :one-ftruncate-result '(14.0 0) :two-ftruncate-result '(3.0 2)) + ;; Now, two floats: + (Assert-rounding-floating pi e) + (when (featurep 'bigfloat) + (Assert-rounding-floating (coerce pi 'bigfloat) (coerce e 'bigfloat))) + (when (featurep 'bignum) + (assert (not (evenp most-positive-fixnum)) t + "In the unlikely event that most-positive-fixnum is even, rewrite this.") + (Assert-rounding (1+ most-positive-fixnum) (* 2 most-positive-fixnum) + :one-floor-result `(,(1+ most-positive-fixnum) 0) + :two-floor-result `(0 ,(1+ most-positive-fixnum)) + :one-ffloor-result `(,(float (1+ most-positive-fixnum)) 0) + :two-ffloor-result `(0.0 ,(1+ most-positive-fixnum)) + :one-ceiling-result `(,(1+ most-positive-fixnum) 0) + :two-ceiling-result `(1 ,(1+ (- most-positive-fixnum))) + :one-fceiling-result `(,(float (1+ most-positive-fixnum)) 0) + :two-fceiling-result `(1.0 ,(1+ (- most-positive-fixnum))) + :one-round-result `(,(1+ most-positive-fixnum) 0) + :two-round-result `(1 ,(1+ (- most-positive-fixnum))) + :one-fround-result `(,(float (1+ most-positive-fixnum)) 0) + :two-fround-result `(1.0 ,(1+ (- most-positive-fixnum))) + :one-truncate-result `(,(1+ most-positive-fixnum) 0) + :two-truncate-result `(0 ,(1+ most-positive-fixnum)) + :one-ftruncate-result `(,(float (1+ most-positive-fixnum)) 0) + :two-ftruncate-result `(0.0 ,(1+ most-positive-fixnum))) + (Assert-rounding (1+ most-positive-fixnum) (- (* 2 most-positive-fixnum)) + :one-floor-result `(,(1+ most-positive-fixnum) 0) + :two-floor-result `(-1 ,(1+ (- most-positive-fixnum))) + :one-ffloor-result `(,(float (1+ most-positive-fixnum)) 0) + :two-ffloor-result `(-1.0 ,(1+ (- most-positive-fixnum))) + :one-ceiling-result `(,(1+ most-positive-fixnum) 0) + :two-ceiling-result `(0 ,(1+ most-positive-fixnum)) + :one-fceiling-result `(,(float (1+ most-positive-fixnum)) 0) + :two-fceiling-result `(0.0 ,(1+ most-positive-fixnum)) + :one-round-result `(,(1+ most-positive-fixnum) 0) + :two-round-result `(-1 ,(1+ (- most-positive-fixnum))) + :one-fround-result `(,(float (1+ most-positive-fixnum)) 0) + :two-fround-result `(-1.0 ,(1+ (- most-positive-fixnum))) + :one-truncate-result `(,(1+ most-positive-fixnum) 0) + :two-truncate-result `(0 ,(1+ most-positive-fixnum)) + :one-ftruncate-result `(,(float (1+ most-positive-fixnum)) 0) + :two-ftruncate-result `(0.0 ,(1+ most-positive-fixnum))) + (Assert-rounding (- (1+ most-positive-fixnum)) (* 2 most-positive-fixnum) + :one-floor-result `(,(- (1+ most-positive-fixnum)) 0) + :two-floor-result `(-1 ,(1- most-positive-fixnum)) + :one-ffloor-result `(,(float (- (1+ most-positive-fixnum))) 0) + :two-ffloor-result `(-1.0 ,(1- most-positive-fixnum)) + :one-ceiling-result `(,(- (1+ most-positive-fixnum)) 0) + :two-ceiling-result `(0 ,(- (1+ most-positive-fixnum))) + :one-fceiling-result `(,(float (- (1+ most-positive-fixnum))) 0) + :two-fceiling-result `(0.0 ,(- (1+ most-positive-fixnum))) + :one-round-result `(,(- (1+ most-positive-fixnum)) 0) + :two-round-result `(-1 ,(1- most-positive-fixnum)) + :one-fround-result `(,(float (- (1+ most-positive-fixnum))) 0) + :two-fround-result `(-1.0 ,(1- most-positive-fixnum)) + :one-truncate-result `(,(- (1+ most-positive-fixnum)) 0) + :two-truncate-result `(0 ,(- (1+ most-positive-fixnum))) + :one-ftruncate-result `(,(float (- (1+ most-positive-fixnum))) 0) + :two-ftruncate-result `(0.0 ,(- (1+ most-positive-fixnum)))) + ;; Test the handling of values with .5: + (Assert-rounding (1+ (* 2 most-positive-fixnum)) 2 + :one-floor-result `(,(1+ (* 2 most-positive-fixnum)) 0) + :two-floor-result `(,most-positive-fixnum 1) + :one-ffloor-result `(,(float (1+ (* 2 most-positive-fixnum))) 0) + ;; We can't just call #'float here; we must use code that converts a + ;; bignum with value most-positive-fixnum (the creation of which is + ;; not directly possible in Lisp) to a float, not code that converts + ;; the fixnum with value most-positive-fixnum to a float. The eval is + ;; to avoid compile-time optimisation that can break this. + :two-ffloor-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) 1) + :one-ceiling-result `(,(1+ (* 2 most-positive-fixnum)) 0) + :two-ceiling-result `(,(1+ most-positive-fixnum) -1) + :one-fceiling-result `(,(float (1+ (* 2 most-positive-fixnum))) 0) + :two-fceiling-result `(,(float (1+ most-positive-fixnum)) -1) + :one-round-result `(,(1+ (* 2 most-positive-fixnum)) 0) + :two-round-result `(,(1+ most-positive-fixnum) -1) + :one-fround-result `(,(float (1+ (* 2 most-positive-fixnum))) 0) + :two-fround-result `(,(float (1+ most-positive-fixnum)) -1) + :one-truncate-result `(,(1+ (* 2 most-positive-fixnum)) 0) + :two-truncate-result `(,most-positive-fixnum 1) + :one-ftruncate-result `(,(float (1+ (* 2 most-positive-fixnum))) 0) + ;; See the comment above on :two-ffloor-result: + :two-ftruncate-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) 1)) + (Assert-rounding (1+ (* 2 (1- most-positive-fixnum))) 2 + :one-floor-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0) + :two-floor-result `(,(1- most-positive-fixnum) 1) + :one-ffloor-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0) + ;; See commentary above on float conversions. + :two-ffloor-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) 1) + :one-ceiling-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0) + :two-ceiling-result `(,most-positive-fixnum -1) + :one-fceiling-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0) + :two-fceiling-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) -1) + :one-round-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0) + :two-round-result `(,(1- most-positive-fixnum) 1) + :one-fround-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0) + :two-fround-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) 1) + :one-truncate-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0) + :two-truncate-result `(,(1- most-positive-fixnum) 1) + :one-ftruncate-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0) + ;; See commentary above + :two-ftruncate-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) + 1))) + (when (featurep 'ratio) + (Assert-rounding (read "4/3") (read "8/7") + :one-floor-result '(1 1/3) :two-floor-result '(1 4/21) + :one-ffloor-result '(1.0 1/3) :two-ffloor-result '(1.0 4/21) + :one-ceiling-result '(2 -2/3) :two-ceiling-result '(2 -20/21) + :one-fceiling-result '(2.0 -2/3) :two-fceiling-result '(2.0 -20/21) + :one-round-result '(1 1/3) :two-round-result '(1 4/21) + :one-fround-result '(1.0 1/3) :two-fround-result '(1.0 4/21) + :one-truncate-result '(1 1/3) :two-truncate-result '(1 4/21) + :one-ftruncate-result '(1.0 1/3) :two-ftruncate-result '(1.0 4/21)) + (Assert-rounding (read "-4/3") (read "8/7") + :one-floor-result '(-2 2/3) :two-floor-result '(-2 20/21) + :one-ffloor-result '(-2.0 2/3) :two-ffloor-result '(-2.0 20/21) + :one-ceiling-result '(-1 -1/3) :two-ceiling-result '(-1 -4/21) + :one-fceiling-result '(-1.0 -1/3) :two-fceiling-result '(-1.0 -4/21) + :one-round-result '(-1 -1/3) :two-round-result '(-1 -4/21) + :one-fround-result '(-1.0 -1/3) :two-fround-result '(-1.0 -4/21) + :one-truncate-result '(-1 -1/3) :two-truncate-result '(-1 -4/21) + :one-ftruncate-result '(-1.0 -1/3) :two-ftruncate-result '(-1.0 -4/21)))) +;; Run this function in a Common Lisp with two arguments to get results that +;; we should compare against, above. Though note the dancing-around with the +;; bigfloats and bignums above, too; you can't necessarily just use the +;; output here. + +(defun generate-rounding-output (first second) + (let ((print-readably t)) + (princ first) + (princ " ") + (princ second) + (princ " :one-floor-result ") + (princ (list 'quote (multiple-value-list (floor first)))) + (princ " :two-floor-result ") + (princ (list 'quote (multiple-value-list (floor first second)))) + (princ " :one-ffloor-result ") + (princ (list 'quote (multiple-value-list (ffloor first)))) + (princ " :two-ffloor-result ") + (princ (list 'quote (multiple-value-list (ffloor first second)))) + (princ " :one-ceiling-result ") + (princ (list 'quote (multiple-value-list (ceiling first)))) + (princ " :two-ceiling-result ") + (princ (list 'quote (multiple-value-list (ceiling first second)))) + (princ " :one-fceiling-result ") + (princ (list 'quote (multiple-value-list (fceiling first)))) + (princ " :two-fceiling-result ") + (princ (list 'quote (multiple-value-list (fceiling first second)))) + (princ " :one-round-result ") + (princ (list 'quote (multiple-value-list (round first)))) + (princ " :two-round-result ") + (princ (list 'quote (multiple-value-list (round first second)))) + (princ " :one-fround-result ") + (princ (list 'quote (multiple-value-list (fround first)))) + (princ " :two-fround-result ") + (princ (list 'quote (multiple-value-list (fround first second)))) + (princ " :one-truncate-result ") + (princ (list 'quote (multiple-value-list (truncate first)))) + (princ " :two-truncate-result ") + (princ (list 'quote (multiple-value-list (truncate first second)))) + (princ " :one-ftruncate-result ") + (princ (list 'quote (multiple-value-list (ftruncate first)))) + (princ " :two-ftruncate-result ") + (princ (list 'quote (multiple-value-list (ftruncate first second))))))