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

* Added fldiv0, flmod0, and fldiv0-and-mod0, completing the 

(rnrs arithmetic flonums) library.
This commit is contained in:
Abdulaziz Ghuloum 2007-11-11 20:04:09 -05:00
parent 05fef19307
commit 0d2e1f4246
5 changed files with 138 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

76
scheme/ikarus.numerics.ss
View File

@ -2738,11 +2738,12 @@
(library (ikarus flonums div-and-mod)
(export fldiv flmod fldiv-and-mod)
(export fldiv flmod fldiv-and-mod fldiv0 flmod0 fldiv0-and-mod0)
(import
(ikarus system $flonums)
(ikarus system $fx)
(except (ikarus) fldiv flmod fldiv-and-mod))
(except (ikarus)
fldiv flmod fldiv-and-mod fldiv0 flmod0 fldiv0-and-mod0))
(define ($flmod n m)
(let ([d0 (fltruncate ($fl/ n m))])
@ -2789,5 +2790,74 @@
(if (flonum? m)
($fldiv-and-mod n m)
(error 'fldiv-and-mod "not a flonum" m))
(error 'fldiv-and-mod "not a flonum" n))))
(error 'fldiv-and-mod "not a flonum" n)))
(define ($fldiv0-and-mod0 n m)
(let ([d0 (fltruncate ($fl/ n m))])
(let ([m0 ($fl- n ($fl* d0 m))])
(if ($fl>= m 0.0)
(if ($fl< m0 ($fl/ m 2.0))
(if ($fl>= m0 ($fl/ m -2.0))
(values d0 m0)
(values ($fl- d0 1.0) ($fl+ m0 m)))
(values ($fl+ d0 1.0) ($fl- m0 m)))
(if ($fl< m0 ($fl/ m -2.0))
(if ($fl>= m0 ($fl/ m 2.0))
(values d0 m0)
(values ($fl+ d0 1.0) ($fl- m0 m)))
(values ($fl- d0 1.0) ($fl+ m0 m)))))))
(define ($fldiv0 n m)
(let ([d0 (fltruncate ($fl/ n m))])
(let ([m0 ($fl- n ($fl* d0 m))])
(if ($fl>= m 0.0)
(if ($fl< m0 ($fl/ m 2.0))
(if ($fl>= m0 ($fl/ m -2.0))
d0
($fl- d0 1.0))
($fl+ d0 1.0))
(if ($fl< m0 ($fl/ m -2.0))
(if ($fl>= m0 ($fl/ m 2.0))
d0
($fl+ d0 1.0))
($fl- d0 1.0))))))
(define ($flmod0 n m)
(let ([d0 (fltruncate ($fl/ n m))])
(let ([m0 ($fl- n ($fl* d0 m))])
(if ($fl>= m 0.0)
(if ($fl< m0 ($fl/ m 2.0))
(if ($fl>= m0 ($fl/ m -2.0))
m0
($fl+ m0 m))
($fl- m0 m))
(if ($fl< m0 ($fl/ m -2.0))
(if ($fl>= m0 ($fl/ m 2.0))
m0
($fl- m0 m))
($fl+ m0 m))))))
(define (fldiv0 n m)
(if (flonum? n)
(if (flonum? m)
($fldiv0 n m)
(error 'fldiv0 "not a flonum" m))
(error 'fldiv0 "not a flonum" n)))
(define (flmod0 n m)
(if (flonum? n)
(if (flonum? m)
($flmod0 n m)
(error 'flmod0 "not a flonum" m))
(error 'flmod0 "not a flonum" n)))
(define (fldiv0-and-mod0 n m)
(if (flonum? n)
(if (flonum? m)
($fldiv0-and-mod0 n m)
(error 'fldiv0-and-mod0 "not a flonum" m))
(error 'fldiv0-and-mod0 "not a flonum" n))))

6
scheme/makefile.ss
View File

@ -828,8 +828,8 @@
[fldenominator i r fl]
[fldiv i r fl]
[fldiv-and-mod i r fl]
[fldiv0 r fl]
[fldiv0-and-mod0 r fl]
[fldiv0 i r fl]
[fldiv0-and-mod0 i r fl]
[fleven? i r fl]
[flexp i r fl]
[flexpt i r fl]
@ -841,7 +841,7 @@
[flmax i r fl]
[flmin i r fl]
[flmod i r fl]
[flmod0 r fl]
[flmod0 i r fl]
[flnan? i r fl]
[flnegative? i r fl]
[flnumerator i r fl]

1
scheme/run-tests.ss
View File

@ -59,4 +59,5 @@
(test-input-ports)
(test-bignum-conversion)
(test-fldiv-and-mod)
(test-fldiv0-and-mod0)
(printf "Happy Happy Joy Joy\n")

68
scheme/tests/fldiv-and-mod.ss
View File

@ -1,19 +1,19 @@
(library (tests fldiv-and-mod)
(export test-fldiv-and-mod)
(export test-fldiv-and-mod test-fldiv0-and-mod0)
(import (ikarus))
(define (test x1 x2 verify?)
(let-values ([(d m) (fldiv-and-mod x1 x2)])
(printf "(fldiv-and-mod ~s ~s) = ~s ~s\n" x1 x2 d m)
(when verify?
(assert (= d (fldiv x1 x2)))
(assert (= m (flmod x1 x2)))
(assert (<= 0.0 m))
(assert (< m (abs x2)))
(assert (= x1 (+ (* d x2) m))))))
(define (test-fldiv-and-mod)
(define (test x1 x2 verify?)
(let-values ([(d m) (fldiv-and-mod x1 x2)])
(printf "(fldiv-and-mod ~s ~s) = ~s ~s\n" x1 x2 d m)
(when verify?
(assert (= d (fldiv x1 x2)))
(assert (= m (flmod x1 x2)))
(assert (<= 0.0 m))
(assert (< m (abs x2)))
(assert (= x1 (+ (* d x2) m))))))
(test +17.0 +3.0 #t)
(test +17.0 -3.0 #t)
(test -17.0 +3.0 #t)
@ -43,4 +43,50 @@
(test +17.0 +inf.0 #f)
(test +17.0 -inf.0 #f)
(test -17.0 +inf.0 #f)
(test -17.0 -inf.0 #f)))
(test -17.0 -inf.0 #f))
(define (test-fldiv0-and-mod0)
(define (test x1 x2 verify?)
(let-values ([(d m) (fldiv0-and-mod0 x1 x2)])
(printf "(fldiv0-and-mod0 ~s ~s) = ~s ~s\n" x1 x2 d m)
(when verify?
(assert (= d (fldiv0 x1 x2)))
(assert (= m (flmod0 x1 x2)))
(assert (<= (fl- (flabs (fl/ x2 2.0))) m))
(assert (< m (flabs (fl/ x2 2.0))))
(assert (= x1 (+ (* d x2) m))))))
(test +17.0 +3.0 #t)
(test +17.0 -3.0 #t)
(test -17.0 +3.0 #t)
(test -17.0 -3.0 #t)
(test +16.0 +3.0 #t)
(test +16.0 -3.0 #t)
(test -16.0 +3.0 #t)
(test -16.0 -3.0 #t)
(test +15.0 +3.0 #t)
(test +15.0 -3.0 #t)
(test -15.0 +3.0 #t)
(test -15.0 -3.0 #t)
(test +17.0 +3.5 #t)
(test +17.0 -3.5 #t)
(test -17.0 +3.5 #t)
(test -17.0 -3.5 #t)
(test +16.0 +3.5 #t)
(test +16.0 -3.5 #t)
(test -16.0 +3.5 #t)
(test -16.0 -3.5 #t)
(test +15.0 +3.5 #t)
(test +15.0 -3.5 #t)
(test -15.0 +3.5 #t)
(test -15.0 -3.5 #t)
(test +10.0 +4.0 #t)
(test +10.0 -4.0 #t)
(test -10.0 +4.0 #t)
(test -10.0 -4.0 #t)
(test +17.0 +nan.0 #f)
(test -17.0 +nan.0 #f)
(test +17.0 +inf.0 #f)
(test +17.0 -inf.0 #f)
(test -17.0 +inf.0 #f)
(test -17.0 -inf.0 #f))
)

8
scheme/todo-r6rs.ss
View File

@ -40,12 +40,12 @@
[co (rnrs conditions (6))]
[en (rnrs enums (6))]
[is (rnrs io simple (6))]
[fl (rnrs arithmetic flonums (6))]
[ba (rnrs base (6))]
[bv (rnrs bytevectors (6))]
[uc (rnrs unicode (6))]
[bw (rnrs arithmetic bitwise (6))]
[fx (rnrs arithmetic fixnums (6))]
[fl (rnrs arithmetic flonums (6))]
[ht (rnrs hashtables (6))]
[ip (rnrs io ports (6))]
))
@ -334,8 +334,8 @@
[fldenominator C fl]
[fldiv C fl]
[fldiv-and-mod C fl]
[fldiv0 S fl]
[fldiv0-and-mod0 S fl]
[fldiv0 C fl]
[fldiv0-and-mod0 C fl]
[fleven? C fl]
[flexp C fl]
[flexpt C fl]
@ -347,7 +347,7 @@
[flmax C fl]
[flmin C fl]
[flmod C fl]
[flmod0 S fl]
[flmod0 C fl]
[flnan? C fl]
[flnegative? C fl]
[flnumerator C fl]