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

* Added an implementation of $flonum->integer which takes a flonum 

and returns the integer representation of it (if it's an integer
  flonum), or #f otherwise.
This commit is contained in:
Abdulaziz Ghuloum 2007-11-14 18:45:49 -05:00
parent 25aa8d7072
commit f3e412ae9c
1 changed files with 58 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
scheme/ikarus.numerics.ss
View File

@ -21,7 +21,7 @@
(library (ikarus flonums) (library (ikarus flonums)
(export $flonum->exact flonum-parts (export $flonum->exact $flonum->integer flonum-parts
inexact->exact exact $flonum-rational? $flonum-integer? $flzero? inexact->exact exact $flonum-rational? $flonum-integer? $flzero?
$flnegative? flpositive? flabs fixnum->flonum $flnegative? flpositive? flabs fixnum->flonum
flsin flcos fltan flasin flacos flatan fleven? flodd? flsin flcos fltan flasin flacos flatan fleven? flodd?
@ -98,9 +98,42 @@
($fx= ($flonum-u8-ref x 1) 0))] ($fx= ($flonum-u8-ref x 1) 0))]
[($fx< be ($fx+ 1075 -52)) ;;; too small to be an integer [($fx< be ($fx+ 1075 -52)) ;;; too small to be an integer
#f] #f]
[else [else ($fl= x ($flround x))])))
(let ([v ($flonum->exact x)])
(or (fixnum? v) (bignum? v)))]))) (define ($flonum->integer x)
(define ($flonum-signed-mantissa x)
(let ([b0 ($flonum-u8-ref x 0)])
(let ([m0 ($fx+ ($flonum-u8-ref x 7)
($fx+ ($fxsll ($flonum-u8-ref x 6) 8)
($fxsll ($flonum-u8-ref x 5) 16)))]
[m1 ($fx+ ($flonum-u8-ref x 4)
($fx+ ($fxsll ($flonum-u8-ref x 3) 8)
($fxsll ($flonum-u8-ref x 2) 16)))]
[m2 (let ([b1 ($flonum-u8-ref x 1)])
(if (and ($fx= ($fxlogand b0 #x7F) 0)
($fx= ($fxsra b1 4) 0))
($fxlogand b1 #xF)
($fxlogor ($fxlogand b1 #xF) #x10)))])
(if ($fx= 0 ($fxlogand #x80 b0))
(+ (bitwise-arithmetic-shift-left ($fxlogor m1 ($fxsll m2 24)) 24) m0)
(+ (bitwise-arithmetic-shift-left
($fx- 0 ($fxlogor m1 ($fxsll m2 24))) 24)
($fx- 0 m0))))))
(let ([sbe ($flonum-sbe x)])
(let ([be ($fxlogand sbe #x7FF)])
(cond
[($fx= be 2047) #f] ;;; nans/infs
[($fx>= be 1075) ;;; magnitude large enough to be an integer
(bitwise-arithmetic-shift-left
($flonum-signed-mantissa x)
(- be 1075))]
[else
(let ([x0 ($fl* x 5e-324)])
(cond
[($fl= x ($fl/ x0 5e-324)) ;;; x == round(x)
($flonum-signed-mantissa x0)]
[else #f]))]))))
(define (flnumerator x) (define (flnumerator x)
(unless (flonum? x) (unless (flonum? x)
@ -122,6 +155,7 @@
[else 1.0])) [else 1.0]))
(define (fleven? x) (define (fleven? x)
;;; FIXME: optimize
(unless (flonum? x) (unless (flonum? x)
(error 'fleven? "not a flonum" x)) (error 'fleven? "not a flonum" x))
(let ([v ($flonum->exact x)]) (let ([v ($flonum->exact x)])
@ -134,6 +168,7 @@
(define (flodd? x) (define (flodd? x)
(unless (flonum? x) (unless (flonum? x)
(error 'flodd? "not a flonum" x)) (error 'flodd? "not a flonum" x))
;;; FIXME: optimize
(let ([v ($flonum->exact x)]) (let ([v ($flonum->exact x)])
(cond (cond
[(fixnum? v) ($fx= ($fxlogand v 1) 1)] [(fixnum? v) ($fx= ($fxlogand v 1) 1)]
@ -197,7 +232,6 @@
(define (inexact->exact x) (define (inexact->exact x)
(cond (cond
[(flonum? x) [(flonum? x)
@ -272,6 +306,7 @@
(if (>= n 0) q (- q 1))))) (if (>= n 0) q (- q 1)))))
(cond (cond
[(flonum? x) [(flonum? x)
;;; optimize for integer flonums case
(let ([e ($flonum->exact x)]) (let ([e ($flonum->exact x)])
(cond (cond
[(ratnum? e) [(ratnum? e)
@ -282,6 +317,7 @@
(define (flceiling x) (define (flceiling x)
(cond (cond
[(flonum? x) [(flonum? x)
;;; optimize for integer flonums case
(let ([e ($flonum->exact x)]) (let ([e ($flonum->exact x)])
(cond (cond
[(ratnum? e) [(ratnum? e)
@ -340,7 +376,8 @@
(ikarus system $bignums) (ikarus system $bignums)
(ikarus system $chars) (ikarus system $chars)
(ikarus system $strings) (ikarus system $strings)
(only (ikarus flonums) $flonum->exact $flzero? $flnegative?) (only (ikarus flonums) $flonum->exact $flzero? $flnegative?
$flonum->integer)
(except (ikarus) + - * / zero? = < <= > >= add1 sub1 quotient (except (ikarus) + - * / zero? = < <= > >= add1 sub1 quotient
remainder modulo even? odd? quotient+remainder number->string remainder modulo even? odd? quotient+remainder number->string
bitwise-arithmetic-shift-right bitwise-arithmetic-shift-left bitwise-arithmetic-shift-right bitwise-arithmetic-shift-left
@ -1315,10 +1352,9 @@
n n
(foreign-call "ikrt_fxbnplus" n m)))] (foreign-call "ikrt_fxbnplus" n m)))]
[(flonum? m) [(flonum? m)
(let ([v ($flonum->exact m)]) (let ([v ($flonum->integer m)])
(cond (cond
[(or (fixnum? v) (bignum? v)) [v (inexact (modulo n v))]
(inexact (modulo n v))]
[else [else
(error 'modulo "not an integer" m)]))] (error 'modulo "not an integer" m)]))]
[(ratnum? m) (error 'modulo "not an integer" m)] [(ratnum? m) (error 'modulo "not an integer" m)]
@ -1336,19 +1372,17 @@
(+ m (remainder n m)) (+ m (remainder n m))
(remainder n m)))] (remainder n m)))]
[(flonum? m) [(flonum? m)
(let ([v ($flonum->exact m)]) (let ([v ($flonum->integer m)])
(cond (cond
[(or (fixnum? v) (bignum? v)) [v (inexact (modulo n v))]
(inexact (modulo n v))]
[else [else
(error 'modulo "not an integer" m)]))] (error 'modulo "not an integer" m)]))]
[(ratnum? m) (error 'modulo "not an integer" m)] [(ratnum? m) (error 'modulo "not an integer" m)]
[else (error 'modulo "not a number" m)])] [else (error 'modulo "not a number" m)])]
[(flonum? n) [(flonum? n)
(let ([v ($flonum->exact n)]) (let ([v ($flonum->integer n)])
(cond (cond
[(or (fixnum? v) (bignum? v)) [v (inexact (modulo v m))]
(inexact (modulo v m))]
[else [else
(error 'modulo "not an integer" n)]))] (error 'modulo "not an integer" n)]))]
[(ratnum? n) (error 'modulo "not an integer" n)] [(ratnum? n) (error 'modulo "not an integer" n)]
@ -1829,9 +1863,9 @@
(fxremainder x y))] (fxremainder x y))]
[(bignum? y) (values 0 x)] [(bignum? y) (values 0 x)]
[(flonum? y) [(flonum? y)
(let ([v ($flonum->exact y)]) (let ([v ($flonum->integer y)])
(cond (cond
[(or (fixnum? v) (bignum? v)) [v
(let-values ([(q r) (quotient+remainder x v)]) (let-values ([(q r) (quotient+remainder x v)])
(values (inexact q) (inexact r)))] (values (inexact q) (inexact r)))]
[else [else
@ -1846,18 +1880,18 @@
(let ([p (foreign-call "ikrt_bnbndivrem" x y)]) (let ([p (foreign-call "ikrt_bnbndivrem" x y)])
(values (car p) (cdr p)))] (values (car p) (cdr p)))]
[(flonum? y) [(flonum? y)
(let ([v ($flonum->exact y)]) (let ([v ($flonum->integer y)])
(cond (cond
[(or (fixnum? v) (bignum? v)) [v
(let-values ([(q r) (quotient+remainder x v)]) (let-values ([(q r) (quotient+remainder x v)])
(values (inexact q) (inexact r)))] (values (inexact q) (inexact r)))]
[else [else
(error 'quotient+remainder "not an integer" y)]))] (error 'quotient+remainder "not an integer" y)]))]
[else (error 'quotient+remainder "not a number" y)])] [else (error 'quotient+remainder "not a number" y)])]
[(flonum? x) [(flonum? x)
(let ([v ($flonum->exact x)]) (let ([v ($flonum->integer x)])
(cond (cond
[(or (fixnum? v) (bignum? v)) [v
(let-values ([(q r) (quotient+remainder v y)]) (let-values ([(q r) (quotient+remainder v y)])
(values (inexact q) (inexact r)))] (values (inexact q) (inexact r)))]
[else (error 'quotient+remainder "not an integer" x)]))] [else (error 'quotient+remainder "not an integer" x)]))]
@ -2010,6 +2044,7 @@
(if (>= n 0) q (- q 1))))) (if (>= n 0) q (- q 1)))))
(cond (cond
[(flonum? x) [(flonum? x)
;;; optimize for integer flonums
(let ([e (or ($flonum->exact x) (let ([e (or ($flonum->exact x)
(error 'floor "number has no real value" x))]) (error 'floor "number has no real value" x))])
(cond (cond
@ -2027,6 +2062,7 @@
(if (< n 0) q (+ q 1))))) (if (< n 0) q (+ q 1)))))
(cond (cond
[(flonum? x) [(flonum? x)
;;; optimize for integer flonums
(let ([e (or ($flonum->exact x) (let ([e (or ($flonum->exact x)
(error 'ceiling "number has no real value" x))]) (error 'ceiling "number has no real value" x))])
(cond (cond
@ -2063,15 +2099,6 @@
($flround x) ($flround x)
(error 'flround "not a flonum" x))) (error 'flround "not a flonum" x)))
;(define (flround x)
; ;;; FIXME: flround should preserve the sign of -0.0.
; (if (flonum? x)
; (let ([e ($flonum->exact x)])
; (cond
; [(ratnum? e) (exact->inexact ($ratnum-round e))]
; [else x]))
; (error 'flround "not a flonum" x)))
(define (round x) (define (round x)
(cond (cond
[(flonum? x) ($flround x)] [(flonum? x) ($flround x)]
@ -2081,6 +2108,7 @@
(define (truncate x) (define (truncate x)
;;; FIXME: fltruncate should preserve the sign of -0.0. ;;; FIXME: fltruncate should preserve the sign of -0.0.
;;;
(cond (cond
[(flonum? x) [(flonum? x)
(let ([e (or ($flonum->exact x) (let ([e (or ($flonum->exact x)