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

* Added fxdiv0, fxmod0, and fxdiv0-and-mod0

This commit is contained in:
Abdulaziz Ghuloum 2007-11-11 21:52:27 -05:00
parent e48c2e17c1
commit 9c8bf4f5c7
6 changed files with 153 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

91
scheme/ikarus.fixnums.ss
View File

@ -419,10 +419,10 @@
) )
(library (ikarus fixnums div-and-mod) (library (ikarus fixnums div-and-mod)
(export fxdiv fxmod fxdiv-and-mod) (export fxdiv fxmod fxdiv-and-mod fxdiv0 fxmod0 fxdiv0-and-mod0)
(import (import
(ikarus system $fx) (ikarus system $fx)
(except (ikarus) fxdiv fxmod fxdiv-and-mod)) (except (ikarus) fxdiv fxmod fxdiv-and-mod fxdiv0 fxmod0 fxdiv0-and-mod0))
(define ($fxdiv-and-mod n m) (define ($fxdiv-and-mod n m)
(let ([d0 ($fxquotient n m)]) (let ([d0 ($fxquotient n m)])
@ -476,5 +476,92 @@
($fxmod x y)) ($fxmod x y))
(error 'fxmod "not a fixnum" y)) (error 'fxmod "not a fixnum" y))
(error 'fxmod "not a fixnum" x))) (error 'fxmod "not a fixnum" x)))
(define ($fxdiv0-and-mod0 n m)
(let ([d0 (quotient n m)])
(let ([m0 (- n (* d0 m))])
(if (>= m 0)
(if (< (* m0 2) m)
(if (<= (* m0 -2) m)
(values d0 m0)
(values (- d0 1) (+ m0 m)))
(values (+ d0 1) (- m0 m)))
(if (> (* m0 -2) m)
(if (>= (* m0 2) m)
(values d0 m0)
(values (+ d0 1) (- m0 m)))
(values (- d0 1) (+ m0 m)))))))
(define ($fxdiv0 n m)
(let ([d0 (quotient n m)])
(let ([m0 (- n (* d0 m))])
(if (>= m 0)
(if (< (* m0 2) m)
(if (<= (* m0 -2) m)
d0
(- d0 1))
(+ d0 1))
(if (> (* m0 -2) m)
(if (>= (* m0 2) m)
d0
(+ d0 1))
(- d0 1))))))
(define ($fxmod0 n m)
(let ([d0 (quotient n m)])
(let ([m0 (- n (* d0 m))])
(if (>= m 0)
(if (< (* m0 2) m)
(if (<= (* m0 -2) m)
m0
(+ m0 m))
(- m0 m))
(if (> (* m0 -2) m)
(if (>= (* m0 2) m)
m0
(- m0 m))
(+ m0 m))))))
(define (fxdiv0-and-mod0 x y)
(if (fixnum? x)
(if (fixnum? y)
(if ($fx= y 0)
(error 'fxdiv0-and-mod0 "division by 0")
(let-values ([(d m) ($fxdiv0-and-mod0 x y)])
(if (and (fixnum? d) (fixnum? m))
(values d m)
(error 'fxdiv0-and-mod0
"results not representable as fixnums"
x y))))
(error 'fxdiv0-and-mod0 "not a fixnum" y))
(error 'fxdiv0-and-mod0 "not a fixnum" x)))
(define (fxdiv0 x y)
(if (fixnum? x)
(if (fixnum? y)
(if ($fx= y 0)
(error 'fxdiv0 "division by 0")
(let ([d ($fxdiv0 x y)])
(if (fixnum? d)
d
(error 'fxdiv0
"result not representable as fixnum"
x y))))
(error 'fxdiv0 "not a fixnum" y))
(error 'fxdiv0 "not a fixnum" x)))
(define (fxmod0 x y)
(if (fixnum? x)
(if (fixnum? y)
(if ($fx= y 0)
(error 'fxmod0 "division by 0")
(let ([d ($fxmod0 x y)])
(if (fixnum? d)
d
(error 'fxmod0
"result not representable as fixnum"
x y))))
(error 'fxmod0 "not a fixnum" y))
(error 'fxmod0 "not a fixnum" x)))
) )

6
scheme/makefile.ss
View File

@ -790,8 +790,8 @@
[fxcopy-bit-field r fx] [fxcopy-bit-field r fx]
[fxdiv i r fx] [fxdiv i r fx]
[fxdiv-and-mod i r fx] [fxdiv-and-mod i r fx]
[fxdiv0 r fx] [fxdiv0 i r fx]
[fxdiv0-and-mod0 r fx] [fxdiv0-and-mod0 i r fx]
[fxeven? i r fx] [fxeven? i r fx]
[fxfirst-bit-set r fx] [fxfirst-bit-set r fx]
[fxif i r fx] [fxif i r fx]
@ -800,7 +800,7 @@
[fxmax i r fx] [fxmax i r fx]
[fxmin i r fx] [fxmin i r fx]
[fxmod i r fx] [fxmod i r fx]
[fxmod0 r fx] [fxmod0 i r fx]
[fxnegative? i r fx] [fxnegative? i r fx]
[fxnot i r fx] [fxnot i r fx]
[fxodd? i r fx] [fxodd? i r fx]

1
scheme/run-tests.ss
View File

@ -62,4 +62,5 @@
(test-fldiv-and-mod) (test-fldiv-and-mod)
(test-fldiv0-and-mod0) (test-fldiv0-and-mod0)
(test-fxdiv-and-mod) (test-fxdiv-and-mod)
(test-fxdiv0-and-mod0)
(printf "Happy Happy Joy Joy\n") (printf "Happy Happy Joy Joy\n")

58
scheme/tests/fixnums.ss
View File

@ -1,6 +1,6 @@
(library (tests fixnums) (library (tests fixnums)
(export test-fxdiv-and-mod) (export test-fxdiv-and-mod test-fxdiv0-and-mod0)
(import (ikarus)) (import (ikarus))
(define (test-fxdiv-and-mod) (define (test-fxdiv-and-mod)
@ -28,5 +28,59 @@
(test +10 +4) (test +10 +4)
(test +10 -4) (test +10 -4)
(test -10 +4) (test -10 +4)
(test -10 -4))) (test -10 -4))
(define (test-fxdiv0-and-mod0)
(define (test x1 x2)
(let-values ([(d m) (fxdiv0-and-mod0 x1 x2)])
(printf "(fxdiv0-and-mod0 ~s ~s) = ~s ~s\n" x1 x2 d m)
(assert (= d (fxdiv0 x1 x2)))
(assert (= m (fxmod0 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)))
)

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

@ -44,7 +44,7 @@
(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)) (test -17.0 -inf.0 #f))
(define (test-fldiv0-and-mod0) (define (test-fldiv0-and-mod0)
(define (test x1 x2 verify?) (define (test x1 x2 verify?)
(let-values ([(d m) (fldiv0-and-mod0 x1 x2)]) (let-values ([(d m) (fldiv0-and-mod0 x1 x2)])

6
scheme/todo-r6rs.ss
View File

@ -295,8 +295,8 @@
[fxcopy-bit-field S fx] [fxcopy-bit-field S fx]
[fxdiv C fx] [fxdiv C fx]
[fxdiv-and-mod C fx] [fxdiv-and-mod C fx]
[fxdiv0 S fx] [fxdiv0 C fx]
[fxdiv0-and-mod0 S fx] [fxdiv0-and-mod0 C fx]
[fxeven? C fx] [fxeven? C fx]
[fxfirst-bit-set S fx] [fxfirst-bit-set S fx]
[fxif C fx] [fxif C fx]
@ -305,7 +305,7 @@
[fxmax C fx] [fxmax C fx]
[fxmin C fx] [fxmin C fx]
[fxmod C fx] [fxmod C fx]
[fxmod0 S fx] [fxmod0 C fx]
[fxnegative? C fx] [fxnegative? C fx]
[fxnot C fx] [fxnot C fx]
[fxodd? C fx] [fxodd? C fx]