diff --git a/scheme/ikarus.numerics.ss b/scheme/ikarus.numerics.ss index 81ca0b5..e7e0361 100644 --- a/scheme/ikarus.numerics.ss +++ b/scheme/ikarus.numerics.ss @@ -92,11 +92,39 @@ (\$fx= (\$flonum-u8-ref x 1) 0))] [(\$fx< be (\$fx+ 1075 -52)) ;;; too small to be an integer #f] - [else (\$fl= x (\$flround x))]))) + [else (\$fl= x (\$\$flround x))]))) + (define (\$\$flround x) + (foreign-call "ikrt_fl_round" x (\$make-flonum))) + (define (\$flround x) - (foreign-call "ikrt_fl_round" x (\$make-flonum))) + ;;; optimize for integer flonums case + (define (ratnum-round n nbe) + (let ([d (sll 1 nbe)]) + (let ([q (sra n nbe)] + [r (bitwise-and n (sub1 d))]) + (let ([r2 (+ r r)]) + (cond + [(< r2 d) q] + [(> r2 d) (+ q 1)] + [else (if (even? q) q (+ q 1))]))))) + (let ([sbe (\$flonum-sbe x)]) + (let ([be (\$fxlogand sbe #x7FF)]) + (cond + ;;; nans/infs/magnitude large enough to be an integer + [(\$fx>= be 1075) x] + [else + ;;; this really needs to get optimized. + (let-values ([(pos? be m) (flonum-parts x)]) + (cond + [(= be 0) ;;; denormalized + (if pos? +0.0 -0.0)] + [else ; normalized flonum + (let ([r + (inexact + (ratnum-round (+ m (expt 2 52)) (- 1075 be)))]) + (if pos? r (\$fl* r -1.0)))]))])))) (define (flround x) (if (flonum? x) diff --git a/scheme/last-revision b/scheme/last-revision index a8c5937..2a81cfe 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1745 +1746 diff --git a/scheme/tests/numerics.ss b/scheme/tests/numerics.ss index 69d90e0..f8d5f97 100644 --- a/scheme/tests/numerics.ss +++ b/scheme/tests/numerics.ss @@ -35,7 +35,38 @@ (test-round -349/100) (test-round +351/100) (test-round +350/100) - (test-round +349/100)) + (test-round +349/100) + + (test-round +0.00) + (test-round -0.00) + (test-round +0.49) + (test-round -0.49) + (test-round +1.49) + (test-round -1.49) + (test-round +2.49) + (test-round -2.49) + (test-round +3.49) + (test-round -3.49) + (test-round +0.51) + (test-round -0.51) + (test-round +1.51) + (test-round -1.51) + (test-round +2.51) + (test-round -2.51) + (test-round +3.51) + (test-round -3.51) + (test-round +0.50) + (test-round -0.50) + (test-round +1.50) + (test-round -1.50) + (test-round +2.50) + (test-round -2.50) + (test-round +3.50) + (test-round -3.50) + + + + ) (define (test-eqv) (define (test-eqv x y result)