diff --git a/lib/scheme/division.scm b/lib/scheme/division.scm index 0963f030..6e2ec3ae 100644 --- a/lib/scheme/division.scm +++ b/lib/scheme/division.scm @@ -10,8 +10,10 @@ ;; In the intermediate case where you have bignums but no ratios there ;; will be a loss of precision for large values. ;; -;; In case 1) the calls to inexact->exact below are unecessary and can -;; be removed. +;; We handle both cases by the use of the cond-expand form in +;; division.sld to conditionally define copy-exactness2. In case 1, +;; no adjustment is needed, whereas in case 2 we want to convert the +;; intermediate result back to exact if both inputs were exact. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -28,21 +30,21 @@ ;; from that. (define (floor-quotient n m) - (inexact->exact (floor (/ n m)))) + (copy-exactness2 n m (floor (/ n m)))) (define (floor-remainder n m) (- n (* m (floor-quotient n m)))) (define (floor/ n m) (values (floor-quotient n m) (floor-remainder n m))) (define (ceiling-quotient n m) - (inexact->exact (ceiling (/ n m)))) + (copy-exactness2 n m (ceiling (/ n m)))) (define (ceiling-remainder n m) (- n (* m (ceiling-quotient n m)))) (define (ceiling/ n m) (values (ceiling-quotient n m) (ceiling-remainder n m))) (define (round-quotient n m) - (inexact->exact (round (/ n m)))) + (copy-exactness2 n m (round (/ n m)))) (define (round-remainder n m) (- n (* m (round-quotient n m)))) (define (round/ n m) diff --git a/lib/scheme/division.sld b/lib/scheme/division.sld index 9d228d06..738f714a 100644 --- a/lib/scheme/division.sld +++ b/lib/scheme/division.sld @@ -7,4 +7,23 @@ floor-quotient floor-remainder floor/ round-quotient round-remainder round/ truncate-quotient truncate-remainder truncate/) + ;; The second definition is always valid, but the first is simpler + ;; and faster if exact ratios are supported and handled correctly + ;; but floor/ceil/round. + (cond-expand + (ratios + (begin + (define-syntax copy-exactness2 + (syntax-rules () + ((copy-exactness2 src1 src2 expr) + expr))))) + (else + (begin + (define-syntax copy-exactness2 + (syntax-rules () + ((copy-exactness2 src1 src2 expr) + (let ((tmp expr)) + (if (and (exact? src1) (exact? src2)) + (inexact->exact tmp) + tmp)))))))) (include "division.scm")) diff --git a/tests/division-tests.scm b/tests/division-tests.scm index 5966c4c0..41cf6d43 100644 --- a/tests/division-tests.scm +++ b/tests/division-tests.scm @@ -293,6 +293,86 @@ (test-end) +(test-begin "exactness") + +(define-syntax values->list + (syntax-rules () + ((values->list expr) (call-with-values (lambda () expr) list)))) + +(test '(4.0 -3.0) (values->list (ceiling/ 13.0 4))) +(test '(4.0 -3.0) (values->list (ceiling/ 13 4.0))) +(test '(4.0 -3.0) (values->list (ceiling/ 13.0 4.0))) + +(test 4.0 (ceiling-quotient 13.0 4)) +(test 4.0 (ceiling-quotient 13 4.0)) +(test 4.0 (ceiling-quotient 13.0 4.0)) + +(test -3.0 (ceiling-remainder 13.0 4)) +(test -3.0 (ceiling-remainder 13 4.0)) +(test -3.0 (ceiling-remainder 13.0 4.0)) + +(test '(3.0 1.0) (values->list (floor/ 13.0 4))) +(test '(3.0 1.0) (values->list (floor/ 13 4.0))) +(test '(3.0 1.0) (values->list (floor/ 13.0 4.0))) + +(test 3.0 (floor-quotient 13.0 4)) +(test 3.0 (floor-quotient 13 4.0)) +(test 3.0 (floor-quotient 13.0 4.0)) + +(test 1.0 (floor-remainder 13.0 4)) +(test 1.0 (floor-remainder 13 4.0)) +(test 1.0 (floor-remainder 13.0 4.0)) + +(test '(3.0 1.0) (values->list (truncate/ 13.0 4))) +(test '(3.0 1.0) (values->list (truncate/ 13 4.0))) +(test '(3.0 1.0) (values->list (truncate/ 13.0 4.0))) + +(test 3.0 (truncate-quotient 13.0 4)) +(test 3.0 (truncate-quotient 13 4.0)) +(test 3.0 (truncate-quotient 13.0 4.0)) + +(test 1.0 (truncate-remainder 13.0 4)) +(test 1.0 (truncate-remainder 13 4.0)) +(test 1.0 (truncate-remainder 13.0 4.0)) + +(test '(3.0 1.0) (values->list (round/ 13.0 4))) +(test '(3.0 1.0) (values->list (round/ 13 4.0))) +(test '(3.0 1.0) (values->list (round/ 13.0 4.0))) + +(test 3.0 (round-quotient 13.0 4)) +(test 3.0 (round-quotient 13 4.0)) +(test 3.0 (round-quotient 13.0 4.0)) + +(test 1.0 (round-remainder 13.0 4)) +(test 1.0 (round-remainder 13 4.0)) +(test 1.0 (round-remainder 13.0 4.0)) + +(test '(3.0 1.0) (values->list (euclidean/ 13.0 4))) +(test '(3.0 1.0) (values->list (euclidean/ 13 4.0))) +(test '(3.0 1.0) (values->list (euclidean/ 13.0 4.0))) + +(test 3.0 (euclidean-quotient 13.0 4)) +(test 3.0 (euclidean-quotient 13 4.0)) +(test 3.0 (euclidean-quotient 13.0 4.0)) + +(test 1.0 (euclidean-remainder 13.0 4)) +(test 1.0 (euclidean-remainder 13 4.0)) +(test 1.0 (euclidean-remainder 13.0 4.0)) + +(test '(3.0 1.0) (values->list (centered/ 13.0 4))) +(test '(3.0 1.0) (values->list (centered/ 13 4.0))) +(test '(3.0 1.0) (values->list (centered/ 13.0 4.0))) + +(test 3.0 (centered-quotient 13.0 4)) +(test 3.0 (centered-quotient 13 4.0)) +(test 3.0 (centered-quotient 13.0 4.0)) + +(test 1.0 (centered-remainder 13.0 4)) +(test 1.0 (centered-remainder 13 4.0)) +(test 1.0 (centered-remainder 13.0 4.0)) + +(test-end) + (test-begin "bignum division") ;; A repeat of the fixnum division tests above, using bignums to test