Adding tests and fixing exactness issues in division operators per issue #102.

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
+;; We handle both cases by the use of the cond-expand form in
-;; be removed.
+;; 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)

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"))

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