conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Fixed div-and-mod

This commit is contained in:
Abdulaziz Ghuloum 2007-11-29 20:04:28 -05:00
parent c00f006164
commit 05bc37fe57
4 changed files with 130 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
scheme/ikarus.numerics.ss
View File

@ -2728,27 +2728,48 @@
(except (ikarus)
div mod div-and-mod div0 mod0 div0-and-mod0))
(define (div-and-mod x y)
(define (div-and-mod n m)
(define who 'div-and-mod)
(unless (integer? x)
(error who "not an integer" x))
(unless (and (integer? y) (not (= y 0)))
(error who "not an integer" y))
(if (>= x 0)
(quotient+remainder x y)
(if (> y 0)
(let-values ([(q r) (quotient+remainder (- x y) y)])
(values q (+ r y)))
(let-values ([(q r) (quotient+remainder (+ x y) y)])
(values q (- r y))))))
(unless (integer? n)
(error who "not an integer" n))
(unless (and (integer? m) (not (= m 0)))
(error who "not an integer" m))
(let ([d0 (quotient n m)])
(let ([m0 (- n (* d0 m))])
(if (>= m0 0)
(values d0 m0)
(if (>= m 0)
(values (- d0 1) (+ m0 m))
(values (+ d0 1) (- m0 m)))))))
(define (div n m)
(define who 'div)
(unless (integer? n)
(error who "not an integer" n))
(unless (and (integer? m) (not (= m 0)))
(error who "not an integer" m))
(let ([d0 (quotient n m)])
(let ([m0 (- n (* d0 m))])
(if (>= m0 0)
d0
(if (>= m 0)
(- d0 1)
(+ d0 1))))))
(define (div x y)
(let-values ([(n m) (div-and-mod x y)])
n))
(define (mod x y)
(let-values ([(n m) (div-and-mod x y)])
m))
(define (mod n m)
(define who 'mod)
(unless (integer? n)
(error who "not an integer" n))
(unless (and (integer? m) (not (= m 0)))
(error who "not an integer" m))
(let ([d0 (quotient n m)])
(let ([m0 (- n (* d0 m))])
(if (>= m0 0)
m0
(if (>= m 0)
(+ m0 m)
(- m0 m))))))
(define (div0-and-mod0 x y)
(define who 'div0-and-mod0)

2
scheme/last-revision
View File

@ -1 +1 @@
1143
1144

3
scheme/run-tests.ss
View File

@ -25,6 +25,7 @@
;(tests numbers)
(tests bignums)
(tests fixnums)
(tests div-and-mod)
(tests fxcarry)
(tests bignum-to-flonum)
(tests string-to-number)
@ -55,7 +56,7 @@
(test-exact-integer-sqrt)
(test-bignum-to-flonum)
(test-string-to-number)
;(test-div-and-mod)
(test-div-and-mod)
(test-bignums)
(test-fxcarry)
(test-lists)

87
scheme/tests/div-and-mod.ss Normal file
View File

@ -0,0 +1,87 @@
(library (tests div-and-mod)
(export test-div-and-mod test-div0-and-mod0)
(import (ikarus))
(define (test-div-and-mod)
(define (test x1 x2)
(let-values ([(d m) (div-and-mod x1 x2)])
(printf "(div-and-mod ~s ~s) = ~s ~s\n" x1 x2 d m)
(assert (= d (div x1 x2)))
(assert (= m (mod x1 x2)))
(assert (<= 0 m))
(assert (< m (abs x2)))
(assert (= x1 (+ (* d x2) m)))))
(test +17 +3)
(test +17 -3)
(test -17 +3)
(test -17 -3)
(test +16 +3)
(test +16 -3)
(test -16 +3)
(test -16 -3)
(test +15 +3)
(test +15 -3)
(test -15 +3)
(test -15 -3)
(test +10 +4)
(test +10 -4)
(test -10 +4)
(test -10 -4))
(define (test-div0-and-mod0)
(define (test x1 x2)
(let-values ([(d m) (div0-and-mod0 x1 x2)])
(printf "(div0-and-mod0 ~s ~s) = ~s ~s\n" x1 x2 d m)
(assert (= d (div0 x1 x2)))
(assert (= m (mod0 x1 x2)))
(assert (<= (- (abs (/ x2 2))) m))
(assert (< m (abs (/ x2 2))))
(assert (= x1 (+ (* d x2) m)))))
(test +17 +3)
(test +17 -3)
(test -17 +3)
(test -17 -3)
(test +16 +3)
(test +16 -3)
(test -16 +3)
(test -16 -3)
(test +15 +3)
(test +15 -3)
(test -15 +3)
(test -15 -3)
(test +10 +4)
(test +10 -4)
(test -10 +4)
(test -10 -4)
(test (least-fixnum) +1)
(test (least-fixnum) -1) ;; overflows
(test (greatest-fixnum) +1)
(test (greatest-fixnum) -1)
(test (least-fixnum) +2)
(test (least-fixnum) -2)
(test (greatest-fixnum) +2)
(test (greatest-fixnum) -2)
(test 0 (least-fixnum))
(test 0 (greatest-fixnum))
(test +1 (least-fixnum))
(test +1 (greatest-fixnum))
(test -1 (least-fixnum))
(test -1 (greatest-fixnum))
(test +2 (least-fixnum))
(test +2 (greatest-fixnum))
(test -2 (least-fixnum))
(test -2 (greatest-fixnum))
(test (least-fixnum) (least-fixnum))
(test (greatest-fixnum) (least-fixnum))
(test (least-fixnum) (greatest-fixnum))
(test (greatest-fixnum) (greatest-fixnum)))
)