* Added flonum->string using dybvig's algorithm.
This commit is contained in:
Abdulaziz Ghuloum
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;
|
||||
unsigned int fst = (unsigned int) ref(x, -vector_tag);
|
||||
int limbs = (fst >> bignum_length_shift);
|
||||
fprintf(stderr, "limbs=%d\n", limbs);
|
||||
double fl;
|
||||
if(limbs == 1){
|
||||
fl = ((unsigned int)ref(x, disp_bignum_data - vector_tag));
|
||||
} else if(limbs == 2){
|
||||
fl = ((unsigned int)ref(x, wordsize+disp_bignum_data - vector_tag));
|
||||
fprintf(stderr, "fl=%f\t", fl);
|
||||
fl *= exp2(32);
|
||||
fprintf(stderr, "fl=%f\t", fl);
|
||||
fl += ((unsigned int)ref(x, disp_bignum_data - vector_tag));
|
||||
fprintf(stderr, "fl=%f\n", fl);
|
||||
} else {
|
||||
fl =
|
||||
((unsigned int)ref(x, limbs * wordsize - wordsize +
|
||||
|
|
@ -213,6 +209,7 @@ ikrt_bignum_to_flonum(ikp x, ikpcb* pcb){
|
|||
fl = -fl;
|
||||
}
|
||||
flonum_data(r) = fl;
|
||||
#if 0
|
||||
{
|
||||
int i;
|
||||
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");
|
||||
}
|
||||
#endif
|
||||
return r;
|
||||
}
|
||||
|
||||
|
|
|
|||
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
|
@ -4,27 +4,13 @@
|
|||
|
||||
|
||||
|
||||
|
||||
(library (ikarus flonums)
|
||||
(export string->flonum flonum->string $flonum->exact
|
||||
inexact->exact)
|
||||
(export $flonum->exact flonum-parts inexact->exact)
|
||||
(import
|
||||
(ikarus system $bytevectors)
|
||||
(ikarus system $flonums)
|
||||
(except (ikarus) flonum->string string->flonum 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)]))
|
||||
(except (ikarus) inexact->exact))
|
||||
|
||||
(define (flonum-bytes f)
|
||||
(unless (flonum? f)
|
||||
|
|
@ -38,7 +24,6 @@
|
|||
($flonum-u8-ref f 5)
|
||||
($flonum-u8-ref f 6)
|
||||
($flonum-u8-ref f 7)))
|
||||
|
||||
(define (flonum-parts x)
|
||||
(unless (flonum? x)
|
||||
(error 'flonum-parts "~s is not a flonum" x))
|
||||
|
|
@ -1300,3 +1285,162 @@
|
|||
(convert-sign x ($string-length 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