diff --git a/scheme/ikarus.fixnums.ss b/scheme/ikarus.fixnums.ss index 212b4ec..ff386c1 100644 --- a/scheme/ikarus.fixnums.ss +++ b/scheme/ikarus.fixnums.ss @@ -419,10 +419,10 @@ ) (library (ikarus fixnums div-and-mod) - (export fxdiv fxmod fxdiv-and-mod) + (export fxdiv fxmod fxdiv-and-mod fxdiv0 fxmod0 fxdiv0-and-mod0) (import (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) (let ([d0 ($fxquotient n m)]) @@ -476,5 +476,92 @@ ($fxmod x y)) (error 'fxmod "not a fixnum" y)) (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))) ) diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 7e604ad..c91ec43 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -790,8 +790,8 @@ [fxcopy-bit-field r fx] [fxdiv i r fx] [fxdiv-and-mod i r fx] - [fxdiv0 r fx] - [fxdiv0-and-mod0 r fx] + [fxdiv0 i r fx] + [fxdiv0-and-mod0 i r fx] [fxeven? i r fx] [fxfirst-bit-set r fx] [fxif i r fx] @@ -800,7 +800,7 @@ [fxmax i r fx] [fxmin i r fx] [fxmod i r fx] - [fxmod0 r fx] + [fxmod0 i r fx] [fxnegative? i r fx] [fxnot i r fx] [fxodd? i r fx] diff --git a/scheme/run-tests.ss b/scheme/run-tests.ss index 94e54cd..911286e 100755 --- a/scheme/run-tests.ss +++ b/scheme/run-tests.ss @@ -62,4 +62,5 @@ (test-fldiv-and-mod) (test-fldiv0-and-mod0) (test-fxdiv-and-mod) +(test-fxdiv0-and-mod0) (printf "Happy Happy Joy Joy\n") diff --git a/scheme/tests/fixnums.ss b/scheme/tests/fixnums.ss index bf484da..af84466 100644 --- a/scheme/tests/fixnums.ss +++ b/scheme/tests/fixnums.ss @@ -1,6 +1,6 @@ (library (tests fixnums) - (export test-fxdiv-and-mod) + (export test-fxdiv-and-mod test-fxdiv0-and-mod0) (import (ikarus)) (define (test-fxdiv-and-mod) @@ -28,5 +28,59 @@ (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))) + + ) diff --git a/scheme/tests/fldiv-and-mod.ss b/scheme/tests/fldiv-and-mod.ss index 8f8a380..c1eddda 100755 --- a/scheme/tests/fldiv-and-mod.ss +++ b/scheme/tests/fldiv-and-mod.ss @@ -44,7 +44,7 @@ (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)]) diff --git a/scheme/todo-r6rs.ss b/scheme/todo-r6rs.ss index 821837c..0bc5b48 100755 --- a/scheme/todo-r6rs.ss +++ b/scheme/todo-r6rs.ss @@ -295,8 +295,8 @@ [fxcopy-bit-field S fx] [fxdiv C fx] [fxdiv-and-mod C fx] - [fxdiv0 S fx] - [fxdiv0-and-mod0 S fx] + [fxdiv0 C fx] + [fxdiv0-and-mod0 C fx] [fxeven? C fx] [fxfirst-bit-set S fx] [fxif C fx] @@ -305,7 +305,7 @@ [fxmax C fx] [fxmin C fx] [fxmod C fx] - [fxmod0 S fx] + [fxmod0 C fx] [fxnegative? C fx] [fxnot C fx] [fxodd? C fx]