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

* Added flround.

This commit is contained in:
Abdulaziz Ghuloum 2007-06-18 13:01:45 +03:00
parent baafbed761
commit d04b4f4be8
5 changed files with 37 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
benchmarks/BUGS
View File

@ -2,7 +2,7 @@
* ray needs many fl procedures * ray needs many fl procedures
* quicksort needs bignum modulo. * quicksort needs bignum modulo.
* scheme needs complex? and other stuff. * scheme needs complex? and other stuff.
* slatex needs string-ci=? * slatex needs char-alphabetic?
* compiler needs string-downcase * compiler needs string-downcase
* ctak crashes with a bus error. * ctak crashes with a bus error.

1
benchmarks/r6rs-benchmarks/slatex.ss
View File

@ -10,6 +10,7 @@
(r6rs) (r6rs)
(r6rs unicode) (r6rs unicode)
(r6rs mutable-pairs) (r6rs mutable-pairs)
(r6rs i/o simple)
(r6rs-benchmarks)) (r6rs-benchmarks))
(define *op-sys* 'unix) (define *op-sys* 'unix)

BIN
src/ikarus.boot
View File

Binary file not shown.

29
src/ikarus.numerics.ss
View File

@ -132,7 +132,8 @@
abs abs
exact->inexact floor ceiling round log fl=? fl<? fl<=? fl>? exact->inexact floor ceiling round log fl=? fl<? fl<=? fl>?
fl>=? fl+ fl- fl* fl/ flsqrt flmin flzero? flnegative? fl>=? fl+ fl- fl* fl/ flsqrt flmin flzero? flnegative?
sin cos atan sqrt) sin cos atan sqrt
flround)
(import (import
(ikarus system $fx) (ikarus system $fx)
(ikarus system $flonums) (ikarus system $flonums)
@ -148,7 +149,8 @@
exact-integer-sqrt min max abs exact-integer-sqrt min max abs
fl=? fl<? fl<=? fl>? fl>=? fl+ fl- fl* fl/ flsqrt flmin fl=? fl<? fl<=? fl>? fl>=? fl+ fl- fl* fl/ flsqrt flmin
flzero? flnegative? flzero? flnegative?
sin cos atan sqrt)) sin cos atan sqrt
flround))
(define (fixnum->flonum x) (define (fixnum->flonum x)
(foreign-call "ikrt_fixnum_to_flonum" x)) (foreign-call "ikrt_fixnum_to_flonum" x))
@ -1618,8 +1620,8 @@
[(or (fixnum? x) (bignum? x)) x] [(or (fixnum? x) (bignum? x)) x]
[else (error 'ceiling "~s is not a number" x)])) [else (error 'ceiling "~s is not a number" x)]))
(define (round x)
(define (ratnum-round x) (define ($ratnum-round x)
(let ([n ($ratnum-n x)] [d ($ratnum-d x)]) (let ([n ($ratnum-n x)] [d ($ratnum-d x)])
(let-values ([(q r) (quotient+remainder n d)]) (let-values ([(q r) (quotient+remainder n d)])
(let ([r2 (+ r r)]) (let ([r2 (+ r r)])
@ -1635,14 +1637,23 @@
[(< r2 d) (- q 1)] [(< r2 d) (- q 1)]
[else [else
(if (even? q) q (- q 1))]))))))) (if (even? q) q (- q 1))])))))))
(cond
[(flonum? x) (define ($flround x)
(let ([e ($flonum->exact x)]) (let ([e ($flonum->exact x)])
(cond (cond
[(not e) x] ;;; infs and nans round to themselves [(not e) x] ;;; infs and nans round to themselves
[(ratnum? e) (exact->inexact (ratnum-round e))] [(ratnum? e) (exact->inexact ($ratnum-round e))]
[else (exact->inexact e)]))] [else (exact->inexact e)])))
[(ratnum? x) (ratnum-round x)]
(define (flround x)
(if (flonum? x)
($flround x)
(error 'flround "~s is not a flonum" x)))
(define (round x)
(cond
[(flonum? x) ($flround x)]
[(ratnum? x) ($ratnum-round x)]
[(or (fixnum? x) (bignum? x)) x] [(or (fixnum? x) (bignum? x)) x]
[else (error 'round "~s is not a number" x)])) [else (error 'round "~s is not a number" x)]))

1
src/makefile.ss
View File

@ -398,6 +398,7 @@
[flnegative? i rfl] [flnegative? i rfl]
[flpositive? i rfl] [flpositive? i rfl]
[flabs i rfl] [flabs i rfl]
[flround i rfl]
[fixnum->string i] [fixnum->string i]
[string->flonum i] [string->flonum i]
[- i r] [- i r]