From 87d1cd5ad1285fe33c826c7eac8244d8a4b99245 Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Sat, 17 Nov 2007 02:13:44 -0500 Subject: [PATCH] * reverted to previous broken version of ratnum->flonum. --- scheme/ikarus.numerics.ss | 140 ++++++++++++++++------------- scheme/makefile.ss | 2 +- scheme/pass-specify-rep-primops.ss | 13 --- 3 files changed, 77 insertions(+), 78 deletions(-) diff --git a/scheme/ikarus.numerics.ss b/scheme/ikarus.numerics.ss index f7015d4..8b1f795 100644 --- a/scheme/ikarus.numerics.ss +++ b/scheme/ikarus.numerics.ss @@ -27,18 +27,19 @@ flsin flcos fltan flasin flacos flatan fleven? flodd? flfloor flceiling flnumerator fldenominator flexp fllog flinteger? flonum-bytes flnan? flfinite? flinfinite? - flexpt) + flexpt $flround flround) (import (ikarus system $bytevectors) (ikarus system $fx) (only (ikarus system $flonums) $fl>= $flonum-sbe) (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 flsin flcos fltan flasin flacos flatan fleven? flodd? flfloor flceiling flnumerator fldenominator flexp fllog flexpt flinteger? flonum-parts flonum-bytes flnan? flfinite? - flinfinite?)) + flinfinite? flround)) (define (flonum-bytes f) (unless (flonum? f) @@ -100,6 +101,15 @@ #f] [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) (define ($flonum-signed-mantissa x) (let ([b0 ($flonum-u8-ref x 0)]) @@ -129,10 +139,16 @@ ($flonum-signed-mantissa x) (- be 1075))] [else - (let ([x0 ($fl* x 5e-324)]) + (let-values ([(pos? be m) (flonum-parts x)]) (cond - [($fl= x ($fl/ x0 5e-324)) ;;; x == round(x) - ($flonum-signed-mantissa x0)] + [(<= 1 be 2046) ; normalized flonum + (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]))])))) (define ($flonum->exact x) (let ([sbe ($flonum-sbe x)]) @@ -144,34 +160,34 @@ ($flonum-signed-mantissa x) (- be 1075))] [else - (let* ([x0 ($fl* x 5e-324)] - [x1 ($fl/ x0 5e-324)]) + ;;; this really needs to get optimized. + (let-values ([(pos? be m) (flonum-parts x)]) (cond - [($fl= x x1) ;;; x == round(x) - ($flonum-signed-mantissa x0)] - [($fx= be 0) ;;; denormal - (/ ($flonum-signed-mantissa x) - (bitwise-arithmetic-shift-left 1 1074))] - [else ;;; x has a fraction - (let ([v ($flonum-signed-mantissa x)]) - (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))))]))]))))) + [(<= 1 be 2046) ; normalized flonum + (* (if pos? 1 -1) + (* (+ m (expt 2 52)) (expt 2 (- be 1075))))] + [(= be 0) + (* (if pos? 1 -1) + (* m (expt 2 -1074)))] + [else #f]))]))))) -;;;OLD (define ($flonum->exact x) -;;;OLD ;;; this really needs to get optimized. -;;;OLD (let-values ([(pos? be m) (flonum-parts x)]) -;;;OLD (cond -;;;OLD [(<= 1 be 2046) ; normalized flonum -;;;OLD (* (if pos? 1 -1) -;;;OLD (* (+ m (expt 2 52)) (expt 2 (- be 1075))))] -;;;OLD [(= be 0) -;;;OLD (* (if pos? 1 -1) -;;;OLD (* m (expt 2 -1074)))] -;;;OLD [else #f]))) +;;; INCORRECT (define ($flonum->exact x) +;;; INCORRECT (let* ([x0 ($fl* x 5e-324)] +;;; INCORRECT [x1 ($fl/ x0 5e-324)]) +;;; INCORRECT (cond +;;; INCORRECT [($fl= x x1) ;;; x == round(x) +;;; INCORRECT ($flonum-signed-mantissa x0)] +;;; INCORRECT [($fx= be 0) ;;; denormal +;;; INCORRECT (/ ($flonum-signed-mantissa x) +;;; INCORRECT (bitwise-arithmetic-shift-left 1 1074))] +;;; INCORRECT [else ;;; x has a fraction +;;; 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) (unless (flonum? x) @@ -395,7 +411,7 @@ 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 exp - flround flmax random) + flmax random) (import (ikarus system $fx) (ikarus system $flonums) @@ -404,7 +420,7 @@ (ikarus system $chars) (ikarus system $strings) (only (ikarus flonums) $flonum->exact $flzero? $flnegative? - $flonum->integer) + $flonum->integer $flround) (except (ikarus) + - * / zero? = < <= > >= add1 sub1 quotient remainder modulo even? odd? quotient+remainder number->string bitwise-arithmetic-shift-right bitwise-arithmetic-shift-left @@ -416,7 +432,7 @@ fl=? fl? fl>=? fl+ fl- fl* fl/ flsqrt flmin flzero? flnegative? sra sll exp sin cos tan asin acos atan sqrt truncate fltruncate - flround flmax random)) + flmax random)) (module (bignum->flonum) @@ -615,32 +631,32 @@ - (define (ratnum->flonum x) - (define (->flonum n d) + ;;; (define (ratnum->flonum x) + ;;; (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)]) - (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)]) - ;;; (if (= q 0) - ;;; (/ 1.0 (f d n)) - ;;; (if (= r 0) - ;;; (inexact q) - ;;; (+ q (f r d))))))) + (if (= q 0) + (/ 1.0 (f d n)) + (if (= r 0) + (inexact q) + (+ q (f r d))))))) (define binary+ (lambda (x y) @@ -2120,10 +2136,6 @@ (let ([n ($ratnum-n x)] [d ($ratnum-d x)]) (quotient n d))) - (define (flround x) - (if (flonum? x) - ($flround x) - (error 'flround "not a flonum" x))) (define (round x) (cond diff --git a/scheme/makefile.ss b/scheme/makefile.ss index dbf50cc..3a26eab 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -431,7 +431,7 @@ [$fl<= $flonums] [$fl> $flonums] [$fl>= $flonums] - [$flround $flonums] + ;[$flround $flonums] [$fixnum->flonum $flonums] [$flonum-sbe $flonums] [$make-bignum $bignums] diff --git a/scheme/pass-specify-rep-primops.ss b/scheme/pass-specify-rep-primops.ss index 612a6a7..b2d7dde 100644 --- a/scheme/pass-specify-rep-primops.ss +++ b/scheme/pass-specify-rep-primops.ss @@ -987,19 +987,6 @@ [(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))]) - (define-primop $flonum-sbe unsafe [(V x) (prm 'sll