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

* Added flceiling, flfloor, and fixed rounding bug in flround and 

round
This commit is contained in:
Abdulaziz Ghuloum 2007-09-10 23:17:06 -04:00
parent cb94cf88b2
commit 1c86a105c5
4 changed files with 47 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

46
src/ikarus.numerics.ss
View File

@ -10,6 +10,7 @@
inexact->exact exact $flonum-rational? $flonum-integer? $flzero?
$flnegative? flpositive? flabs fixnum->flonum
flsin flcos fltan flasin flacos flatan fleven? flodd?
flfloor flceiling
flinteger? flonum-bytes flnan? flfinite? flinfinite?)
(import
(ikarus system $bytevectors)
@ -19,6 +20,7 @@
$flonum-rational? $flonum-integer?)
(except (ikarus) inexact->exact exact flpositive? flabs fixnum->flonum
flsin flcos fltan flasin flacos flatan fleven? flodd?
flfloor flceiling
flinteger? flonum-parts flonum-bytes flnan? flfinite? flinfinite?))
(define (flonum-bytes f)
@ -227,10 +229,38 @@
(if (flonum? x)
(foreign-call "ikrt_fl_atan" x)
(error 'flatan "~s is not a flonum" x)))
(define (flfloor x)
(define (ratnum-floor x)
(let ([n (numerator x)] [d (denominator x)])
(let ([q (quotient n d)])
(if (>= n 0) q (- q 1)))))
(cond
[(flonum? x)
(let ([e ($flonum->exact x)])
(cond
[(ratnum? e)
(exact->inexact (ratnum-floor e))]
[else x]))]
[else (error 'flfloor "~s is not a flonum" x)]))
(define (flceiling x)
(cond
[(flonum? x)
(let ([e ($flonum->exact x)])
(cond
[(ratnum? e)
(exact->inexact (ceiling e))]
[else x]))]
[else (error 'flceiling "~s is not a flonum" x)]))
)
(library (ikarus generic-arithmetic)
(export + - * / zero? = < <= > >= add1 sub1 quotient remainder
modulo even? odd?
@ -1796,8 +1826,8 @@
[else
(if (even? q) q (- q 1))])))))))
(define ($flround x)
(foreign-call "ikrt_fl_round" x ($make-flonum)))
;(define ($flround x)
; (foreign-call "ikrt_fl_round" x ($make-flonum)))
; (let ([e ($flonum->exact x)])
; (cond
@ -1807,12 +1837,20 @@
(define (flround x)
(if (flonum? x)
($flround x)
(let ([e ($flonum->exact x)])
(cond
[(ratnum? e) (exact->inexact ($ratnum-round e))]
[else x]))
(error 'flround "~s is not a flonum" x)))
(define (round x)
(cond
[(flonum? x) ($flround x)]
[(flonum? x)
(let ([e (or ($flonum->exact x)
(error 'round "~s has no real value" x))])
(cond
[(ratnum? e) (exact->inexact ($ratnum-round e))]
[else x]))]
[(ratnum? x) ($ratnum-round x)]
[(or (fixnum? x) (bignum? x)) x]
[else (error 'round "~s is not a number" x)]))

4
src/makefile.ss
View File

@ -469,13 +469,15 @@
[flpositive? i rfl]
[flabs i rfl]
[flmax i rfl]
[flround i rfl]
[flsin i rfl]
[flcos i rfl]
[fltan i rfl]
[flasin i rfl]
[flacos i rfl]
[flatan i rfl]
[flfloor i rfl]
[flround i rfl]
[flceiling i rfl]
[fixnum->string i]
[string->flonum i]
[- i r]

4
src/todo-r6rs.ss
View File

@ -312,7 +312,7 @@
[flacos C fl]
[flasin C fl]
[flatan C fl]
[flceiling S fl]
[flceiling C fl]
[flcos C fl]
[fldenominator S fl]
[fldiv S fl]
@ -323,7 +323,7 @@
[flexp S fl]
[flexpt S fl]
[flfinite? C fl]
[flfloor S fl]
[flfloor C fl]
[flinfinite? C fl]
[flinteger? C fl]
[fllog S fl]