* reverted to previous broken version of ratnum->flonum.
This commit is contained in:
Abdulaziz Ghuloum
parent
7e1c6001eb
commit
87d1cd5ad1
|
|
@ -27,18 +27,19 @@
|
||||||
flsin flcos fltan flasin flacos flatan fleven? flodd?
|
flsin flcos fltan flasin flacos flatan fleven? flodd?
|
||||||
flfloor flceiling flnumerator fldenominator flexp fllog
|
flfloor flceiling flnumerator fldenominator flexp fllog
|
||||||
flinteger? flonum-bytes flnan? flfinite? flinfinite?
|
flinteger? flonum-bytes flnan? flfinite? flinfinite?
|
||||||
flexpt)
|
flexpt $flround flround)
|
||||||
(import
|
(import
|
||||||
(ikarus system $bytevectors)
|
(ikarus system $bytevectors)
|
||||||
(ikarus system $fx)
|
(ikarus system $fx)
|
||||||
(only (ikarus system $flonums) $fl>= $flonum-sbe)
|
(only (ikarus system $flonums) $fl>= $flonum-sbe)
|
||||||
(ikarus system $bignums)
|
(ikarus system $bignums)
|
||||||
(except (ikarus system $flonums) $flonum-rational? $flonum-integer?)
|
(except (ikarus system $flonums) $flonum-rational?
|
||||||
|
$flonum-integer? $flround)
|
||||||
(except (ikarus) inexact->exact exact flpositive? flabs fixnum->flonum
|
(except (ikarus) inexact->exact exact flpositive? flabs fixnum->flonum
|
||||||
flsin flcos fltan flasin flacos flatan fleven? flodd?
|
flsin flcos fltan flasin flacos flatan fleven? flodd?
|
||||||
flfloor flceiling flnumerator fldenominator flexp fllog
|
flfloor flceiling flnumerator fldenominator flexp fllog
|
||||||
flexpt flinteger? flonum-parts flonum-bytes flnan? flfinite?
|
flexpt flinteger? flonum-parts flonum-bytes flnan? flfinite?
|
||||||
flinfinite?))
|
flinfinite? flround))
|
||||||
|
|
||||||
(define (flonum-bytes f)
|
(define (flonum-bytes f)
|
||||||
(unless (flonum? f)
|
(unless (flonum? f)
|
||||||
|
|
@ -100,6 +101,15 @@
|
||||||
#f]
|
#f]
|
||||||
[else ($fl= x ($flround x))])))
|
[else ($fl= x ($flround x))])))
|
||||||
|
|
||||||
|
|
||||||
|
(define ($flround x)
|
||||||
|
(foreign-call "ikrt_fl_round" x ($make-flonum)))
|
||||||
|
|
||||||
|
(define (flround x)
|
||||||
|
(if (flonum? x)
|
||||||
|
($flround x)
|
||||||
|
(error 'flround "not a flonum" x)))
|
||||||
|
|
||||||
(module ($flonum->integer $flonum->exact)
|
(module ($flonum->integer $flonum->exact)
|
||||||
(define ($flonum-signed-mantissa x)
|
(define ($flonum-signed-mantissa x)
|
||||||
(let ([b0 ($flonum-u8-ref x 0)])
|
(let ([b0 ($flonum-u8-ref x 0)])
|
||||||
|
|
@ -129,10 +139,16 @@
|
||||||
($flonum-signed-mantissa x)
|
($flonum-signed-mantissa x)
|
||||||
(- be 1075))]
|
(- be 1075))]
|
||||||
[else
|
[else
|
||||||
(let ([x0 ($fl* x 5e-324)])
|
(let-values ([(pos? be m) (flonum-parts x)])
|
||||||
(cond
|
(cond
|
||||||
[($fl= x ($fl/ x0 5e-324)) ;;; x == round(x)
|
[(<= 1 be 2046) ; normalized flonum
|
||||||
($flonum-signed-mantissa x0)]
|
(let ([n (+ m (expt 2 52))]
|
||||||
|
[d (expt 2 (- be 1075))])
|
||||||
|
(let-values ([(q r) (quotient+remainder n d)])
|
||||||
|
(if (= r 0)
|
||||||
|
(if pos? q (- q))
|
||||||
|
#f)))]
|
||||||
|
[(= be 0) (if (= m 0) 0 #f)]
|
||||||
[else #f]))]))))
|
[else #f]))]))))
|
||||||
(define ($flonum->exact x)
|
(define ($flonum->exact x)
|
||||||
(let ([sbe ($flonum-sbe x)])
|
(let ([sbe ($flonum-sbe x)])
|
||||||
|
|
@ -144,34 +160,34 @@
|
||||||
($flonum-signed-mantissa x)
|
($flonum-signed-mantissa x)
|
||||||
(- be 1075))]
|
(- be 1075))]
|
||||||
[else
|
[else
|
||||||
(let* ([x0 ($fl* x 5e-324)]
|
;;; this really needs to get optimized.
|
||||||
[x1 ($fl/ x0 5e-324)])
|
(let-values ([(pos? be m) (flonum-parts x)])
|
||||||
(cond
|
(cond
|
||||||
[($fl= x x1) ;;; x == round(x)
|
[(<= 1 be 2046) ; normalized flonum
|
||||||
($flonum-signed-mantissa x0)]
|
(* (if pos? 1 -1)
|
||||||
[($fx= be 0) ;;; denormal
|
(* (+ m (expt 2 52)) (expt 2 (- be 1075))))]
|
||||||
(/ ($flonum-signed-mantissa x)
|
[(= be 0)
|
||||||
(bitwise-arithmetic-shift-left 1 1074))]
|
(* (if pos? 1 -1)
|
||||||
[else ;;; x has a fraction
|
(* m (expt 2 -1074)))]
|
||||||
(let ([v ($flonum-signed-mantissa x)])
|
[else #f]))])))))
|
||||||
(let ([bits (- 1075 be)])
|
|
||||||
(let ([int (bitwise-arithmetic-shift-right v bits)]
|
|
||||||
[frac
|
|
||||||
(let ([e (bitwise-arithmetic-shift-left 1 bits)])
|
|
||||||
(/ (bitwise-and v (- e 1)) e))])
|
|
||||||
(+ int frac))))]))])))))
|
|
||||||
|
|
||||||
;;;OLD (define ($flonum->exact x)
|
;;; INCORRECT (define ($flonum->exact x)
|
||||||
;;;OLD ;;; this really needs to get optimized.
|
;;; INCORRECT (let* ([x0 ($fl* x 5e-324)]
|
||||||
;;;OLD (let-values ([(pos? be m) (flonum-parts x)])
|
;;; INCORRECT [x1 ($fl/ x0 5e-324)])
|
||||||
;;;OLD (cond
|
;;; INCORRECT (cond
|
||||||
;;;OLD [(<= 1 be 2046) ; normalized flonum
|
;;; INCORRECT [($fl= x x1) ;;; x == round(x)
|
||||||
;;;OLD (* (if pos? 1 -1)
|
;;; INCORRECT ($flonum-signed-mantissa x0)]
|
||||||
;;;OLD (* (+ m (expt 2 52)) (expt 2 (- be 1075))))]
|
;;; INCORRECT [($fx= be 0) ;;; denormal
|
||||||
;;;OLD [(= be 0)
|
;;; INCORRECT (/ ($flonum-signed-mantissa x)
|
||||||
;;;OLD (* (if pos? 1 -1)
|
;;; INCORRECT (bitwise-arithmetic-shift-left 1 1074))]
|
||||||
;;;OLD (* m (expt 2 -1074)))]
|
;;; INCORRECT [else ;;; x has a fraction
|
||||||
;;;OLD [else #f])))
|
;;; INCORRECT (let ([v ($flonum-signed-mantissa x)])
|
||||||
|
;;; INCORRECT (let ([bits (- 1075 be)])
|
||||||
|
;;; INCORRECT (let ([int (bitwise-arithmetic-shift-right v bits)]
|
||||||
|
;;; INCORRECT [frac
|
||||||
|
;;; INCORRECT (let ([e (bitwise-arithmetic-shift-left 1 bits)])
|
||||||
|
;;; INCORRECT (/ (bitwise-and v (- e 1)) e))])
|
||||||
|
;;; INCORRECT (+ int frac))))])))
|
||||||
|
|
||||||
(define (flnumerator x)
|
(define (flnumerator x)
|
||||||
(unless (flonum? x)
|
(unless (flonum? x)
|
||||||
|
|
@ -395,7 +411,7 @@
|
||||||
exact->inexact inexact floor ceiling round log fl=? fl<? fl<=? fl>?
|
exact->inexact 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 tan asin acos atan sqrt exp
|
sin cos tan asin acos atan sqrt exp
|
||||||
flround flmax random)
|
flmax random)
|
||||||
(import
|
(import
|
||||||
(ikarus system $fx)
|
(ikarus system $fx)
|
||||||
(ikarus system $flonums)
|
(ikarus system $flonums)
|
||||||
|
|
@ -404,7 +420,7 @@
|
||||||
(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)
|
$flonum->integer $flround)
|
||||||
(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
|
||||||
|
|
@ -416,7 +432,7 @@
|
||||||
fl=? fl<? fl<=? fl>? fl>=? fl+ fl- fl* fl/ flsqrt flmin
|
fl=? fl<? fl<=? fl>? fl>=? fl+ fl- fl* fl/ flsqrt flmin
|
||||||
flzero? flnegative? sra sll exp
|
flzero? flnegative? sra sll exp
|
||||||
sin cos tan asin acos atan sqrt truncate fltruncate
|
sin cos tan asin acos atan sqrt truncate fltruncate
|
||||||
flround flmax random))
|
flmax random))
|
||||||
|
|
||||||
|
|
||||||
(module (bignum->flonum)
|
(module (bignum->flonum)
|
||||||
|
|
@ -615,32 +631,32 @@
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(define (ratnum->flonum x)
|
;;; (define (ratnum->flonum x)
|
||||||
(define (->flonum n d)
|
;;; (define (->flonum n d)
|
||||||
|
;;; (let-values ([(q r) (quotient+remainder n d)])
|
||||||
|
;;; (if (= r 0)
|
||||||
|
;;; (inexact q)
|
||||||
|
;;; (if (= q 0)
|
||||||
|
;;; (/ (->flonum d n))
|
||||||
|
;;; (+ q (->flonum r d))))))
|
||||||
|
;;; (let ([n (numerator x)] [d (denominator x)])
|
||||||
|
;;; (let ([b (bitwise-first-bit-set n)])
|
||||||
|
;;; (if (eqv? b 0)
|
||||||
|
;;; (let ([b (bitwise-first-bit-set d)])
|
||||||
|
;;; (if (eqv? b 0)
|
||||||
|
;;; (->flonum n d)
|
||||||
|
;;; (/ (->flonum n (bitwise-arithmetic-shift-right d b))
|
||||||
|
;;; (expt 2.0 b))))
|
||||||
|
;;; (* (->flonum (bitwise-arithmetic-shift-right n b) d)
|
||||||
|
;;; (expt 2.0 b))))))
|
||||||
|
(define (ratnum->flonum x)
|
||||||
|
(let f ([n ($ratnum-n x)] [d ($ratnum-d x)])
|
||||||
(let-values ([(q r) (quotient+remainder n d)])
|
(let-values ([(q r) (quotient+remainder n d)])
|
||||||
(if (= r 0)
|
(if (= q 0)
|
||||||
(inexact q)
|
(/ 1.0 (f d n))
|
||||||
(if (= q 0)
|
(if (= r 0)
|
||||||
(/ (->flonum d n))
|
(inexact q)
|
||||||
(+ q (->flonum r d))))))
|
(+ q (f r d)))))))
|
||||||
(let ([n (numerator x)] [d (denominator x)])
|
|
||||||
(let ([b (bitwise-first-bit-set n)])
|
|
||||||
(if (eqv? b 0)
|
|
||||||
(let ([b (bitwise-first-bit-set d)])
|
|
||||||
(if (eqv? b 0)
|
|
||||||
(->flonum n d)
|
|
||||||
(/ (->flonum n (bitwise-arithmetic-shift-right d b))
|
|
||||||
(expt 2.0 b))))
|
|
||||||
(* (->flonum (bitwise-arithmetic-shift-right n b) d)
|
|
||||||
(expt 2.0 b))))))
|
|
||||||
;;; (define (ratnum->flonum x)
|
|
||||||
;;; (let f ([n ($ratnum-n x)] [d ($ratnum-d x)])
|
|
||||||
;;; (let-values ([(q r) (quotient+remainder n d)])
|
|
||||||
;;; (if (= q 0)
|
|
||||||
;;; (/ 1.0 (f d n))
|
|
||||||
;;; (if (= r 0)
|
|
||||||
;;; (inexact q)
|
|
||||||
;;; (+ q (f r d)))))))
|
|
||||||
|
|
||||||
(define binary+
|
(define binary+
|
||||||
(lambda (x y)
|
(lambda (x y)
|
||||||
|
|
@ -2120,10 +2136,6 @@
|
||||||
(let ([n ($ratnum-n x)] [d ($ratnum-d x)])
|
(let ([n ($ratnum-n x)] [d ($ratnum-d x)])
|
||||||
(quotient n d)))
|
(quotient n d)))
|
||||||
|
|
||||||
(define (flround x)
|
|
||||||
(if (flonum? x)
|
|
||||||
($flround x)
|
|
||||||
(error 'flround "not a flonum" x)))
|
|
||||||
|
|
||||||
(define (round x)
|
(define (round x)
|
||||||
(cond
|
(cond
|
||||||
|
|
|
||||||
|
|
@ -431,7 +431,7 @@
|
||||||
[$fl<= $flonums]
|
[$fl<= $flonums]
|
||||||
[$fl> $flonums]
|
[$fl> $flonums]
|
||||||
[$fl>= $flonums]
|
[$fl>= $flonums]
|
||||||
[$flround $flonums]
|
;[$flround $flonums]
|
||||||
[$fixnum->flonum $flonums]
|
[$fixnum->flonum $flonums]
|
||||||
[$flonum-sbe $flonums]
|
[$flonum-sbe $flonums]
|
||||||
[$make-bignum $bignums]
|
[$make-bignum $bignums]
|
||||||
|
|
|
||||||
|
|
@ -987,19 +987,6 @@
|
||||||
[(P x y) (check-flonums (list x y) ($flcmp-aux 'fl:>= x y))]
|
[(P x y) (check-flonums (list x y) ($flcmp-aux 'fl:>= x y))]
|
||||||
[(E x y) (check-flonums (list x y) (nop))])
|
[(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))])
|
|
||||||
|
|
||||||
(define-primop $flonum-sbe unsafe
|
(define-primop $flonum-sbe unsafe
|
||||||
[(V x)
|
[(V x)
|
||||||
(prm 'sll
|
(prm 'sll
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue