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

* open-coded $flround.

This commit is contained in:
Abdulaziz Ghuloum 2007-11-13 03:41:54 -05:00
parent 47f7016b18
commit 820d1716be
4 changed files with 13 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.orig
View File

Binary file not shown.

45
scheme/ikarus.numerics.ss
View File

@ -110,48 +110,6 @@
(let ([v ($flonum->exact x)])
(or (fixnum? v) (bignum? v)))])))
;;;X (define ($fltruncate x)
;;;X ;(define bv
;;;X ; '#vu8(127 255 255 255 63 255 255 255 31 255 255 255 15 255 255 255
;;;X ; 7 255 255 255 3 255 255 255 1 255 255 255 0 255 255 255
;;;X ; 0 127 255 255 0 63 255 255 0 31 255 255 0 15 255 255
;;;X ; 0 7 255 255 0 3 255 255 0 1 255 255 0 0 255 255
;;;X ; 0 0 127 255 0 0 63 255 0 0 31 255 0 0 15 255
;;;X ; 0 0 7 255 0 0 3 255 0 0 1 255 0 0 0 255
;;;X ; 0 0 0 127 0 0 0 63 0 0 0 31 0 0 0 15
;;;X ; 0 0 0 7 0 0 0 3 0 0 0 1 0 0 0 0))
;;;X ;(define bv
;;;X ; '#vu8(255 255 255 255 255 255 255 255 0 0 0 0 0 0 0 0
;;;X ; 255 255 255 255 255 255 255 254 0 0 0 0 0 0 0 0
;;;X ; 255 255 255 255 255 255 255 252 0 0 0 0 0 0 0 0
;;;X ; 255 255 255 255 255 255 255 248 0 0 0 0 0 0 0 0
;;;X ; 255 255 255 255 255 255 255 240 0 0 0 0 0 0 0 0
;;;X ; 255 255 255 255 255 255 255 224 0 0 0 0 0 0 0 0
;;;X ; 255 255 255 255 255 255 255 192 0 0 0 0 0 0 0 0
;;;X ; 255 255 255 255 255 255 255 128 0 0 0 0 0 0 0 0
;;;X
;;;X (let ([sbe ($flonum-signed-biased-exponent x)])
;;;X (let ([be ($fxlogand sbe ($fxsub1 ($fxsll 1 11)))])
;;;X (cond
;;;X [($fx= be 2047) ;;; nans and infs
;;;X x]
;;;X [($fx>= be 1075) ;;; magnitue large enough
;;;X x]
;;;X [($fx= be 0) ;;; denormalized double
;;;X (if ($fxzero? sbe) 0.0 -0.0)]
;;;X [($fx< be ($fx+ 1075 -52)) ;;; too small to be an integer
;;;X (if ($fxzero? ($fxlogand sbe ($fxsll 1 11))) 0.0 -0.0)]
;;;X [else
;;;X (let ([v ($make-flonum)])
;;;X
;;;X
;;;X (let ([v ($flonum->exact x)])
;;;X (or (fixnum? v) (bignum? v)))]))))
;;;X
(define (flnumerator x)
(unless (flonum? x)
(error 'flnumerator "not a flonum" x))
@ -2104,9 +2062,6 @@
(let ([n ($ratnum-n x)] [d ($ratnum-d x)])
(quotient n d)))
(define ($flround x)
($fl/ ($fl* x 5e-324) 5e-324))
(define (flround x)
(if (flonum? x)
($flround x)

1
scheme/makefile.ss
View File

@ -431,6 +431,7 @@
[$fl<= $flonums]
[$fl> $flonums]
[$fl>= $flonums]
[$flround $flonums]
[$fixnum->flonum $flonums]
[$make-bignum $bignums]
[$bignum-positive? $bignums]

12
scheme/pass-specify-rep-primops.ss
View File

@ -967,6 +967,18 @@
[(P x y) (check-flonums (list x y) ($flcmp-aux 'fl:>= x y))]
[(E x y) (check-flonums (list x y) (nop))])
(define-primop $flround unsafe
[(V fl)
(let ([bv #vu8(1 0 0 0 0 0 0 0)])
(with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
(prm 'mset x (K (- vector-tag)) (K flonum-tag))
(prm 'fl:load (T fl) (K (- disp-flonum-data vector-tag)))
(prm 'fl:mul! (K (make-object bv))
(K (- disp-bytevector-data bytevector-tag)))
(prm 'fl:div! (K (make-object bv))
(K (- disp-bytevector-data bytevector-tag)))
(prm 'fl:store x (K (- disp-flonum-data vector-tag)))
x))])
/section)