* Added flonum->string using dybvig's algorithm.
This commit is contained in:
parent
a596550e97
commit
cccdd1122c
BIN
bin/ikarus
BIN
bin/ikarus
Binary file not shown.
|
@ -186,17 +186,13 @@ ikrt_bignum_to_flonum(ikp x, ikpcb* pcb){
|
||||||
ref(r, -vector_tag) = (ikp)flonum_tag;
|
ref(r, -vector_tag) = (ikp)flonum_tag;
|
||||||
unsigned int fst = (unsigned int) ref(x, -vector_tag);
|
unsigned int fst = (unsigned int) ref(x, -vector_tag);
|
||||||
int limbs = (fst >> bignum_length_shift);
|
int limbs = (fst >> bignum_length_shift);
|
||||||
fprintf(stderr, "limbs=%d\n", limbs);
|
|
||||||
double fl;
|
double fl;
|
||||||
if(limbs == 1){
|
if(limbs == 1){
|
||||||
fl = ((unsigned int)ref(x, disp_bignum_data - vector_tag));
|
fl = ((unsigned int)ref(x, disp_bignum_data - vector_tag));
|
||||||
} else if(limbs == 2){
|
} else if(limbs == 2){
|
||||||
fl = ((unsigned int)ref(x, wordsize+disp_bignum_data - vector_tag));
|
fl = ((unsigned int)ref(x, wordsize+disp_bignum_data - vector_tag));
|
||||||
fprintf(stderr, "fl=%f\t", fl);
|
|
||||||
fl *= exp2(32);
|
fl *= exp2(32);
|
||||||
fprintf(stderr, "fl=%f\t", fl);
|
|
||||||
fl += ((unsigned int)ref(x, disp_bignum_data - vector_tag));
|
fl += ((unsigned int)ref(x, disp_bignum_data - vector_tag));
|
||||||
fprintf(stderr, "fl=%f\n", fl);
|
|
||||||
} else {
|
} else {
|
||||||
fl =
|
fl =
|
||||||
((unsigned int)ref(x, limbs * wordsize - wordsize +
|
((unsigned int)ref(x, limbs * wordsize - wordsize +
|
||||||
|
@ -213,6 +209,7 @@ ikrt_bignum_to_flonum(ikp x, ikpcb* pcb){
|
||||||
fl = -fl;
|
fl = -fl;
|
||||||
}
|
}
|
||||||
flonum_data(r) = fl;
|
flonum_data(r) = fl;
|
||||||
|
#if 0
|
||||||
{
|
{
|
||||||
int i;
|
int i;
|
||||||
unsigned char* p = (unsigned char*)(r+disp_flonum_data-vector_tag);
|
unsigned char* p = (unsigned char*)(r+disp_flonum_data-vector_tag);
|
||||||
|
@ -221,6 +218,7 @@ ikrt_bignum_to_flonum(ikp x, ikpcb* pcb){
|
||||||
}
|
}
|
||||||
fprintf(stderr, "\n");
|
fprintf(stderr, "\n");
|
||||||
}
|
}
|
||||||
|
#endif
|
||||||
return r;
|
return r;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
@ -4,27 +4,13 @@
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(library (ikarus flonums)
|
(library (ikarus flonums)
|
||||||
(export string->flonum flonum->string $flonum->exact
|
(export $flonum->exact flonum-parts inexact->exact)
|
||||||
inexact->exact)
|
|
||||||
(import
|
(import
|
||||||
(ikarus system $bytevectors)
|
(ikarus system $bytevectors)
|
||||||
(ikarus system $flonums)
|
(ikarus system $flonums)
|
||||||
(except (ikarus) flonum->string string->flonum inexact->exact))
|
(except (ikarus) inexact->exact))
|
||||||
|
|
||||||
(define (flonum->string x)
|
|
||||||
(utf8-bytevector->string
|
|
||||||
(or (foreign-call "ikrt_flonum_to_bytevector" x
|
|
||||||
($make-bytevector 80))
|
|
||||||
(error 'flonum->string "~s is not a flonum" x))))
|
|
||||||
|
|
||||||
(define (string->flonum x)
|
|
||||||
(cond
|
|
||||||
[(string? x)
|
|
||||||
(foreign-call "ikrt_bytevector_to_flonum"
|
|
||||||
(string->utf8-bytevector x))]
|
|
||||||
[else
|
|
||||||
(error 'string->flonum "~s is not a string" x)]))
|
|
||||||
|
|
||||||
(define (flonum-bytes f)
|
(define (flonum-bytes f)
|
||||||
(unless (flonum? f)
|
(unless (flonum? f)
|
||||||
|
@ -38,7 +24,6 @@
|
||||||
($flonum-u8-ref f 5)
|
($flonum-u8-ref f 5)
|
||||||
($flonum-u8-ref f 6)
|
($flonum-u8-ref f 6)
|
||||||
($flonum-u8-ref f 7)))
|
($flonum-u8-ref f 7)))
|
||||||
|
|
||||||
(define (flonum-parts x)
|
(define (flonum-parts x)
|
||||||
(unless (flonum? x)
|
(unless (flonum? x)
|
||||||
(error 'flonum-parts "~s is not a flonum" x))
|
(error 'flonum-parts "~s is not a flonum" x))
|
||||||
|
@ -1300,3 +1285,162 @@
|
||||||
(convert-sign x ($string-length x))]
|
(convert-sign x ($string-length x))]
|
||||||
[else (error 'string->number "~s is not a string" x)])))
|
[else (error 'string->number "~s is not a string" x)])))
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
||||||
|
(library (ikarus flonum-conversion)
|
||||||
|
(export string->flonum flonum->string)
|
||||||
|
(import
|
||||||
|
(ikarus system $bytevectors)
|
||||||
|
(ikarus system $flonums)
|
||||||
|
(only (ikarus flonums) flonum-parts)
|
||||||
|
(except (ikarus) flonum->string string->flonum ))
|
||||||
|
|
||||||
|
;(define (flonum->string x)
|
||||||
|
; (utf8-bytevector->string
|
||||||
|
; (or (foreign-call "ikrt_flonum_to_bytevector" x
|
||||||
|
; ($make-bytevector 80))
|
||||||
|
; (error 'flonum->string "~s is not a flonum" x))))
|
||||||
|
|
||||||
|
(define (even? n)
|
||||||
|
(= (remainder n 2) 0))
|
||||||
|
|
||||||
|
(module (flonum->string)
|
||||||
|
(module (flonum->digits)
|
||||||
|
(define flonum->digits
|
||||||
|
(lambda (f e min-e p b B)
|
||||||
|
;;; flonum v = f * b^e
|
||||||
|
;;; p = precision (p >= 1)
|
||||||
|
(let ([round? (even? f)])
|
||||||
|
(if (>= e 0)
|
||||||
|
(if (not (= f (expt b (- p 1))))
|
||||||
|
(let ([be (expt b e)])
|
||||||
|
(scale (* f be 2) 2 be be 0 B round? f e))
|
||||||
|
(let* ([be (expt b e)] [be1 (* be b)])
|
||||||
|
(scale (* f be1 2) (* b 2) be1 be 0 B round? f e)))
|
||||||
|
(if (or (= e min-e) (not (= f (expt b (- p 1)))))
|
||||||
|
(scale (* f 2) (* (expt b (- e)) 2) 1 1 0 B round? f e)
|
||||||
|
(scale (* f b 2) (* (expt b (- 1 e)) 2) b 1 0 B round? f e))))))
|
||||||
|
(define (len n)
|
||||||
|
(let f ([n n] [i 0])
|
||||||
|
(cond
|
||||||
|
[(zero? n) i]
|
||||||
|
[else (f (quotient n 2) (+ i 1))])))
|
||||||
|
(define scale
|
||||||
|
(lambda (r s m+ m- k B round? f e)
|
||||||
|
(let ([est (inexact->exact
|
||||||
|
(ceiling
|
||||||
|
(- (* (+ e (len f) -1) (invlog2of B))
|
||||||
|
(exact->inexact (expt 10 -10)))))])
|
||||||
|
(if (>= est 0)
|
||||||
|
(fixup r (* s (exptt B est)) m+ m- est B round?)
|
||||||
|
(let ([scale (exptt B (- est))])
|
||||||
|
(fixup (* r scale) s (* m+ scale) (* m- scale) est B round?))))))
|
||||||
|
(define fixup
|
||||||
|
(lambda (r s m+ m- k B round?)
|
||||||
|
(if ((if round? >= >) (+ r m+) s) ; too low?
|
||||||
|
(values (+ k 1) (generate r s m+ m- B round?))
|
||||||
|
(values k (generate (* r B) s (* m+ B) (* m- B) B round?)))))
|
||||||
|
(define (chr x)
|
||||||
|
(vector-ref '#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) x))
|
||||||
|
(define generate
|
||||||
|
(lambda (r s m+ m- B round?)
|
||||||
|
(let-values ([(q r) (quotient+remainder r s)])
|
||||||
|
(let ([tc1 ((if round? <= <) r m-)]
|
||||||
|
[tc2 ((if round? >= >) (+ r m+) s)])
|
||||||
|
(if (not tc1)
|
||||||
|
(if (not tc2)
|
||||||
|
(cons (chr q) (generate (* r B) s (* m+ B) (* m- B) B round?))
|
||||||
|
(list (chr (+ q 1))))
|
||||||
|
(if (not tc2)
|
||||||
|
(list (chr q))
|
||||||
|
(if (< (* r 2) s)
|
||||||
|
(list (chr q))
|
||||||
|
(list (chr (+ q 1))))))))))
|
||||||
|
(define invlog2of
|
||||||
|
(let ([table (make-vector 37)]
|
||||||
|
[log2 (log 2)])
|
||||||
|
(do ([B 2 (+ B 1)])
|
||||||
|
((= B 37))
|
||||||
|
(vector-set! table B (/ log2 (log B))))
|
||||||
|
(lambda (B)
|
||||||
|
(if (<= 2 B 36)
|
||||||
|
(vector-ref table B)
|
||||||
|
(/ log2 (log B))))))
|
||||||
|
(define exptt
|
||||||
|
(let ([table (make-vector 326)])
|
||||||
|
(do ([k 0 (+ k 1)] [v 1 (* v 10)])
|
||||||
|
((= k 326))
|
||||||
|
(vector-set! table k v))
|
||||||
|
(lambda (B k)
|
||||||
|
(if (and (= B 10) (<= 0 k 325))
|
||||||
|
(vector-ref table k)
|
||||||
|
(expt B k))))))
|
||||||
|
(define (format-flonum pos? expt digits)
|
||||||
|
(define (next x)
|
||||||
|
(if (null? x)
|
||||||
|
(values #\0 '())
|
||||||
|
(values (car x) (cdr x))))
|
||||||
|
(define (format-flonum-no-expt expt d0 d*)
|
||||||
|
(cond
|
||||||
|
[(= expt 1)
|
||||||
|
(cons d0 (if (null? d*) '(#\. #\0) (cons #\. d*)))]
|
||||||
|
[else
|
||||||
|
(cons d0
|
||||||
|
(let-values ([(d0 d*) (next d*)])
|
||||||
|
(format-flonum-no-expt (- expt 1) d0 d*)))]))
|
||||||
|
(define (format-flonum-no-expt/neg expt d*)
|
||||||
|
(cond
|
||||||
|
[(= expt 0) d*]
|
||||||
|
[else (cons #\0 (format-flonum-no-expt/neg (+ expt 1) d*))]))
|
||||||
|
(define (sign pos? ls)
|
||||||
|
(if pos?
|
||||||
|
(list->string ls)
|
||||||
|
(list->string (cons #\- ls))))
|
||||||
|
(let ([d0 (car digits)] [d* (cdr digits)])
|
||||||
|
(cond
|
||||||
|
[(null? d*)
|
||||||
|
(if (char=? d0 #\0)
|
||||||
|
(if pos? "0.0" "-0.0")
|
||||||
|
(if (= expt 1)
|
||||||
|
(if pos?
|
||||||
|
(string d0 #\. #\0)
|
||||||
|
(string #\- d0 #\. #\0))
|
||||||
|
(string-append
|
||||||
|
(if pos? "" "-")
|
||||||
|
(string d0) "e" (fixnum->string (- expt 1)))))]
|
||||||
|
[(and (null? d*) (char=? d0 #\0)) (if pos? "0.0" "-0.0")]
|
||||||
|
[(<= 1 expt 9)
|
||||||
|
(sign pos? (format-flonum-no-expt expt d0 d*))]
|
||||||
|
[(<= -3 expt 0)
|
||||||
|
(sign pos? (list* #\0 #\. (format-flonum-no-expt/neg expt digits)))]
|
||||||
|
[else
|
||||||
|
(string-append
|
||||||
|
(if pos? "" "-")
|
||||||
|
(string d0) "." (list->string d*)
|
||||||
|
"e" (fixnum->string (- expt 1)))])))
|
||||||
|
(define (flo->string pos? m e p)
|
||||||
|
; (printf "compo: ~s ~s ~s\n" m e p)
|
||||||
|
(let-values ([(expt digits) (flonum->digits m e 10 p 2 10)])
|
||||||
|
(format-flonum pos? expt digits)))
|
||||||
|
(define (flonum->string x)
|
||||||
|
(let-values ([(pos? be m) (flonum-parts x)])
|
||||||
|
(cond
|
||||||
|
[(<= 1 be 2046) ; normalized flonum
|
||||||
|
(flo->string pos? (+ m (expt 2 52)) (- be 1075) 53)]
|
||||||
|
[(= be 0)
|
||||||
|
(flo->string pos? m -1074 52)]
|
||||||
|
[(= be 2047)
|
||||||
|
(if (= m 0)
|
||||||
|
(if pos? "+inf.0" "-inf.0")
|
||||||
|
(if pos? "+nan.0" "-nan.0"))]
|
||||||
|
[else (error 'flonum->string "cannot happen")]))))
|
||||||
|
|
||||||
|
(define (string->flonum x)
|
||||||
|
(cond
|
||||||
|
[(string? x)
|
||||||
|
(foreign-call "ikrt_bytevector_to_flonum"
|
||||||
|
(string->utf8-bytevector x))]
|
||||||
|
[else
|
||||||
|
(error 'string->flonum "~s is not a string" x)]))
|
||||||
|
|
||||||
|
)
|
||||||
|
|
Loading…
Reference in New Issue