diff --git a/src/ikarus.boot b/src/ikarus.boot index 223183e..ca0e1d0 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.numerics.ss b/src/ikarus.numerics.ss index eaffe45..b26e5e8 100644 --- a/src/ikarus.numerics.ss +++ b/src/ikarus.numerics.ss @@ -297,7 +297,7 @@ modulo even? odd? positive? negative? expt gcd lcm numerator denominator exact-integer-sqrt quotient+remainder number->string string->number min max - abs + abs truncate fltruncate exact->inexact inexact floor ceiling round log fl=? fl? fl>=? fl+ fl- fl* fl/ flsqrt flmin flzero? flnegative? sin cos tan asin acos atan sqrt @@ -318,7 +318,7 @@ exact-integer-sqrt min max abs fl=? fl? fl>=? fl+ fl- fl* fl/ flsqrt flmin flzero? flnegative? - sin cos tan asin acos atan sqrt + sin cos tan asin acos atan sqrt truncate fltruncate flround flmax random)) ; (foreign-call "ikrt_fixnum_to_flonum" x)) @@ -1857,6 +1857,11 @@ [else (if (even? q) q (- q 1))]))))))) + + (define ($ratnum-truncate x) + (let ([n ($ratnum-n x)] [d ($ratnum-d x)]) + (quotient n d))) + ;(define ($flround x) ; (foreign-call "ikrt_fl_round" x ($make-flonum))) @@ -1874,8 +1879,6 @@ [else x])) (error 'flround "~s is not a flonum" x))) - - (define (round x) (cond [(flonum? x) @@ -1888,6 +1891,26 @@ [(or (fixnum? x) (bignum? x)) x] [else (error 'round "~s is not a number" x)])) + (define (truncate x) + (cond + [(flonum? x) + (let ([e (or ($flonum->exact x) + (error 'truncate "~s has no real value" x))]) + (cond + [(ratnum? e) (exact->inexact ($ratnum-truncate e))] + [else x]))] + [(ratnum? x) ($ratnum-truncate x)] + [(or (fixnum? x) (bignum? x)) x] + [else (error 'truncate "~s is not a number" x)])) + + (define (fltruncate x) + (unless (flonum? x) + (error 'fltruncate "~s is not a flonum" x)) + (let ([v ($flonum->exact x)]) + (cond + [(ratnum? v) (exact->inexact ($ratnum-truncate x))] + [else x]))) + (define log (lambda (x) (cond diff --git a/src/makefile.ss b/src/makefile.ss index 5e1bf55..bdb2b0f 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -478,6 +478,7 @@ [flfloor i rfl] [flround i rfl] [flceiling i rfl] + [fltruncate i rfl] [flnumerator i rfl] [fldenominator i rfl] [flexp i rfl] @@ -543,6 +544,7 @@ [floor i r] [ceiling i r] [round i r] + [truncate i r] [exact-integer-sqrt i r] [exact->inexact i r] [inexact->exact i r] diff --git a/src/todo-r6rs.ss b/src/todo-r6rs.ss index 1e6d669..5eb337c 100755 --- a/src/todo-r6rs.ss +++ b/src/todo-r6rs.ss @@ -220,7 +220,7 @@ [symbol=? C ba] [symbol? C ba se] [tan C ba se] - [truncate S ba se] + [truncate C ba se] [values C ba se] [vector C ba se] [vector->list C ba se] @@ -341,7 +341,7 @@ [flsin C fl] [flsqrt C fl] [fltan C fl] - [fltruncate S fl] + [fltruncate C fl] [flzero? C fl] [real->flonum D fl] [make-no-infinities-violation D fl]