Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-22 07:09:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

Browse source
This commit is contained in:
Alex Shinn 2012-03-12 23:21:11 +09:00
parent 933680a838
commit 3c3666ad68
3 changed files with 106 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
lib/scheme/division.scm
View file

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

19
lib/scheme/division.sld
View file

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

80
tests/division-tests.scm
View file

@ -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