added two aux libraries for parsing and formatting floating point

numbers.
This commit is contained in:
Abdulaziz Ghuloum 2009-06-30 19:01:20 +03:00
parent b324709e86
commit 0cc2aae7dc
5 changed files with 247 additions and 3 deletions

View File

@ -1,5 +1,7 @@
libikarusdir=$(pkglibdir)/ikarus libikarusdir=$(pkglibdir)/ikarus
dist_libikarus_DATA=ikarus/foreign.ss ikarus/ipc.ss ikarus/include.ss dist_libikarus_DATA= ikarus/foreign.ss ikarus/ipc.ss \
ikarus/include.ss \
ikarus/flonum-parser.sls ikarus/flonum-formatter.sls
libCocoadir=$(pkglibdir)/Cocoa libCocoadir=$(pkglibdir)/Cocoa
dist_libCocoa_DATA=Cocoa/helpers.ss dist_libCocoa_DATA=Cocoa/helpers.ss

View File

@ -162,7 +162,10 @@ top_build_prefix = @top_build_prefix@
top_builddir = @top_builddir@ top_builddir = @top_builddir@
top_srcdir = @top_srcdir@ top_srcdir = @top_srcdir@
libikarusdir = $(pkglibdir)/ikarus libikarusdir = $(pkglibdir)/ikarus
dist_libikarus_DATA = ikarus/foreign.ss ikarus/ipc.ss ikarus/include.ss dist_libikarus_DATA = ikarus/foreign.ss ikarus/ipc.ss \
ikarus/include.ss \
ikarus/flonum-parser.sls ikarus/flonum-formatter.sls
libCocoadir = $(pkglibdir)/Cocoa libCocoadir = $(pkglibdir)/Cocoa
dist_libCocoa_DATA = Cocoa/helpers.ss dist_libCocoa_DATA = Cocoa/helpers.ss
dist_pkglib_DATA = match.ss gl.ss glut.ss \ dist_pkglib_DATA = match.ss gl.ss glut.ss \

View File

@ -0,0 +1,72 @@
;;; Copyright (c) 2009 Abdulaziz Ghuloum
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a
;;; copy of this software and associated documentation files (the "Software"),
;;; to deal in the Software without restriction, including without limitation
;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;;; and/or sell copies of the Software, and to permit persons to whom the
;;; Software is furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(library (ikarus flonum-formatter)
(export ikarus-format-flonum)
(import (rnrs))
(define (ikarus-format-flonum pos? digits expt)
(define fixnum->string number->string)
(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))
(if (= expt 0)
(if pos?
(string #\0 #\. d0)
(string #\- #\0 #\. d0))
(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? (cons* #\0 #\. (format-flonum-no-expt/neg expt digits)))]
[else
(string-append
(if pos? "" "-")
(string d0) "." (list->string d*)
"e" (fixnum->string (- expt 1)))]))))

View File

@ -0,0 +1,167 @@
;;; The code here is extracted from
;;; ``Printing Floating-Point Numbers Quickly and Accurately''
;;; http://www.cs.indiana.edu/~burger/FP-Printing-PLDI96.pdf
;;; It is believed to be in the public domain.
;;; The copyright below is for the R6RS implementation not part
;;; of the original work.
;;; Copyright (c) 2009 Abdulaziz Ghuloum
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a
;;; copy of this software and associated documentation files (the "Software"),
;;; to deal in the Software without restriction, including without limitation
;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;;; and/or sell copies of the Software, and to permit persons to whom the
;;; Software is furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;; (parse-flonum <fl>
;;; (lambda (positive? digits:list-of-chars exponent:int)
;;; ---)
;;; (lambda (inf/nan:string)
;;; ---))
;;; calls one of the two procedures depending on whether the
;;; number has a real value or not.
(library (ikarus flonum-parser)
(export parse-flonum)
(import (rnrs))
(define fxsll fxarithmetic-shift-left)
(define fxsra fxarithmetic-shift-right)
(define (flonum-bytes f k)
(let ([bv (make-bytevector 8)])
(bytevector-ieee-double-set! bv 0 f (endianness big))
(k (bytevector-u8-ref bv 0)
(bytevector-u8-ref bv 1)
(bytevector-u8-ref bv 2)
(bytevector-u8-ref bv 3)
(bytevector-u8-ref bv 4)
(bytevector-u8-ref bv 5)
(bytevector-u8-ref bv 6)
(bytevector-u8-ref bv 7))))
(define (flonum-parts x)
(flonum-bytes x
(lambda (b0 b1 b2 b3 b4 b5 b6 b7)
(values
(zero? (fxand b0 128))
(+ (fxsll (fxand b0 127) 4)
(fxsra b1 4))
(+ (+ b7 (fxsll b6 8) (fxsll b5 16))
(* (+ b4
(fxsll b3 8)
(fxsll b2 16)
(fxsll (fxand b1 #b1111) 24))
(expt 2 24)))))))
(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 (div n 2) (+ i 1))])))
(define scale
(lambda (r s m+ m- k B round? f e)
(let ([est (exact
(ceiling
(- (* (+ e (len f) -1) (invlog2of B))
1e-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) (div-and-mod 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 (convert-real-flonum pos? m e p k)
(let-values ([(expt digits) (flonum->digits m e 10 p 2 10)])
(k pos? digits expt)))
(define (parse-flonum x k0 k1)
(assert (flonum? x))
(assert (procedure? k0))
(assert (procedure? k1))
(let-values ([(pos? be m) (flonum-parts x)])
(cond
[(<= 1 be 2046) ; normalized flonum
(convert-real-flonum pos? (+ m (expt 2 52)) (- be 1075) 53 k0)]
[(= be 0)
(convert-real-flonum pos? m -1074 52 k0)]
[(= be 2047)
(k1 (if (= m 0) (if pos? "+inf.0" "-inf.0") "+nan.0"))]
[else (error 'flonum->string "cannot happen")]))))

View File

@ -1 +1 @@
1819 1820