mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 06:50:31 +02:00
Code Activity

fix `format' with %f and exact rationals

Browse source 
* module/ice-9/format.scm (format:parse-float): Accept a number, and
  when stringifying the number, first convert to inexact.

* test-suite/tests/format.test ("~f fixed-point"): Add exact rational
  test.
This commit is contained in:
Andy Wingo 2010-06-06 13:46:53 +02:00
parent f42d8bd8ff
commit 625b43acc7
2 changed files with 121 additions and 121 deletions
Download patch file Download diff file Expand all files Collapse all files

237
module/ice-9/format.scm
View file

@ -1206,8 +1206,7 @@
(format:out-inf-nan number width digits #f overch padch)) (format:out-inf-nan number width digits #f overch padch))
(digits (digits
(format:parse-float (format:parse-float number #t scale)
(if (string? number) number (number->string number)) #t scale)
(if (<= (- format:fn-len format:fn-dot) digits) (if (<= (- format:fn-len format:fn-dot) digits)
(format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
(format:fn-round digits)) (format:fn-round digits))
@ -1225,8 +1224,7 @@
(format:fn-out modifier #t))) (format:fn-out modifier #t)))
(else (else
(format:parse-float (format:parse-float number #t scale)
(if (string? number) number (number->string number)) #t scale)
(format:fn-strip) (format:fn-strip)
(if width (if width
(let ((numlen (+ format:fn-len 1))) (let ((numlen (+ format:fn-len 1)))
@ -1276,8 +1274,7 @@
(+ (- digits scale) 1) (+ (- digits scale) 1)
0) 0)
digits))) digits)))
(format:parse-float (format:parse-float number #f scale)
(if (string? number) number (number->string number)) #f scale)
(if (<= (- format:fn-len format:fn-dot) digits) (if (<= (- format:fn-len format:fn-dot) digits)
(format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
(format:fn-round digits)) (format:fn-round digits))
@ -1307,8 +1304,7 @@
(format:en-out edigits expch))))) (format:en-out edigits expch)))))
(else (else
(format:parse-float (format:parse-float number #f scale)
(if (string? number) number (number->string number)) #f scale)
(format:fn-strip) (format:fn-strip)
(if width (if width
(if (and edigits overch (> format:en-len edigits)) (if (and edigits overch (> format:en-len edigits))
@ -1364,8 +1360,7 @@
;; FIXME: this isn't right. ;; FIXME: this isn't right.
(format:out-inf-nan number width digits edigits overch padch)) (format:out-inf-nan number width digits edigits overch padch))
(else (else
(format:parse-float (format:parse-float number #t 0)
(if (string? number) number (number->string number)) #t 0)
(format:fn-strip) (format:fn-strip)
(let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm (let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm
(ww (if width (- width ee) #f)) ; see Steele's CL book p.395 (ww (if width (- width ee) #f)) ; see Steele's CL book p.395
@ -1400,8 +1395,7 @@
(format:out-inf-nan number width digits #f #f padch)) (format:out-inf-nan number width digits #f #f padch))
(else (else
(format:parse-float (format:parse-float number #t 0)
(if (string? number) number (number->string number)) #t 0)
(if (<= (- format:fn-len format:fn-dot) digits) (if (<= (- format:fn-len format:fn-dot) digits)
(format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
(format:fn-round digits)) (format:fn-round digits))
@ -1452,120 +1446,123 @@
(format:en-pos? #t) ; exponent positive? (format:en-pos? #t) ; exponent positive?
(format:parse-float (format:parse-float
(lambda (num-str fixed? scale) (lambda (num fixed? scale)
(set! format:fn-pos? #t) (let ((num-str (if (string? num)
(set! format:fn-len 0) num
(set! format:fn-dot #f) (number->string (exact->inexact num)))))
(set! format:en-pos? #t) (set! format:fn-pos? #t)
(set! format:en-len 0) (set! format:fn-len 0)
(do ((i 0 (+ i 1)) (set! format:fn-dot #f)
(left-zeros 0) (set! format:en-pos? #t)
(mantissa? #t) (set! format:en-len 0)
(all-zeros? #t) (do ((i 0 (+ i 1))
(num-len (string-length num-str)) (left-zeros 0)
(c #f)) ; current exam. character in num-str (mantissa? #t)
((= i num-len) (all-zeros? #t)
(if (not format:fn-dot) (num-len (string-length num-str))
(set! format:fn-dot format:fn-len)) (c #f)) ; current exam. character in num-str
((= i num-len)
(if (not format:fn-dot)
(set! format:fn-dot format:fn-len))
(if all-zeros? (if all-zeros?
(begin (begin
(set! left-zeros 0) (set! left-zeros 0)
(set! format:fn-dot 0) (set! format:fn-dot 0)
(set! format:fn-len 1))) (set! format:fn-len 1)))
;; now format the parsed values according to format's need ;; now format the parsed values according to format's need
(if fixed? (if fixed?
(begin ; fixed format m.nnn or .nnn (begin ; fixed format m.nnn or .nnn
(if (and (> left-zeros 0) (> format:fn-dot 0)) (if (and (> left-zeros 0) (> format:fn-dot 0))
(if (> format:fn-dot left-zeros) (if (> format:fn-dot left-zeros)
(begin ; norm 0{0}nn.mm to nn.mm (begin ; norm 0{0}nn.mm to nn.mm
(format:fn-shiftleft left-zeros) (format:fn-shiftleft left-zeros)
(set! format:fn-dot (- format:fn-dot left-zeros)) (set! format:fn-dot (- format:fn-dot left-zeros))
(set! left-zeros 0)) (set! left-zeros 0))
(begin ; normalize 0{0}.nnn to .nnn (begin ; normalize 0{0}.nnn to .nnn
(format:fn-shiftleft format:fn-dot) (format:fn-shiftleft format:fn-dot)
(set! left-zeros (- left-zeros format:fn-dot)) (set! left-zeros (- left-zeros format:fn-dot))
(set! format:fn-dot 0)))) (set! format:fn-dot 0))))
(if (or (not (= scale 0)) (> format:en-len 0)) (if (or (not (= scale 0)) (> format:en-len 0))
(let ((shift (+ scale (format:en-int)))) (let ((shift (+ scale (format:en-int))))
(cond (cond
(all-zeros? #t) (all-zeros? #t)
((> (+ format:fn-dot shift) format:fn-len) ((> (+ format:fn-dot shift) format:fn-len)
(format:fn-zfill (format:fn-zfill
#f (- shift (- format:fn-len format:fn-dot))) #f (- shift (- format:fn-len format:fn-dot)))
(set! format:fn-dot format:fn-len)) (set! format:fn-dot format:fn-len))
((< (+ format:fn-dot shift) 0) ((< (+ format:fn-dot shift) 0)
(format:fn-zfill #t (- (- shift) format:fn-dot)) (format:fn-zfill #t (- (- shift) format:fn-dot))
(set! format:fn-dot 0)) (set! format:fn-dot 0))
(else (else
(if (> left-zeros 0) (if (> left-zeros 0)
(if (<= left-zeros shift) ; shift always > 0 here (if (<= left-zeros shift) ; shift always > 0 here
(format:fn-shiftleft shift) ; shift out 0s (format:fn-shiftleft shift) ; shift out 0s
(begin (begin
(format:fn-shiftleft left-zeros) (format:fn-shiftleft left-zeros)
(set! format:fn-dot (- shift left-zeros)))) (set! format:fn-dot (- shift left-zeros))))
(set! format:fn-dot (+ format:fn-dot shift)))))))) (set! format:fn-dot (+ format:fn-dot shift))))))))
(let ((negexp ; expon format m.nnnEee (let ((negexp ; expon format m.nnnEee
(if (> left-zeros 0) (if (> left-zeros 0)
(- left-zeros format:fn-dot -1) (- left-zeros format:fn-dot -1)
(if (= format:fn-dot 0) 1 0)))) (if (= format:fn-dot 0) 1 0))))
(if (> left-zeros 0) (if (> left-zeros 0)
(begin ; normalize 0{0}.nnn to n.nn (begin ; normalize 0{0}.nnn to n.nn
(format:fn-shiftleft left-zeros) (format:fn-shiftleft left-zeros)
(set! format:fn-dot 1)) (set! format:fn-dot 1))
(if (= format:fn-dot 0) (if (= format:fn-dot 0)
(set! format:fn-dot 1))) (set! format:fn-dot 1)))
(format:en-set (- (+ (- format:fn-dot scale) (format:en-int)) (format:en-set (- (+ (- format:fn-dot scale) (format:en-int))
negexp)) negexp))
(cond (cond
(all-zeros? (all-zeros?
(format:en-set 0) (format:en-set 0)
(set! format:fn-dot 1)) (set! format:fn-dot 1))
((< scale 0) ; leading zero ((< scale 0) ; leading zero
(format:fn-zfill #t (- scale)) (format:fn-zfill #t (- scale))
(set! format:fn-dot 0)) (set! format:fn-dot 0))
((> scale format:fn-dot) ((> scale format:fn-dot)
(format:fn-zfill #f (- scale format:fn-dot)) (format:fn-zfill #f (- scale format:fn-dot))
(set! format:fn-dot scale)) (set! format:fn-dot scale))
(else (else
(set! format:fn-dot scale))))) (set! format:fn-dot scale)))))
#t) #t)
;; do body ;; do body
(set! c (string-ref num-str i)) ; parse the output of number->string (set! c (string-ref num-str i)) ; parse the output of number->string
(cond ; which can be any valid number (cond ; which can be any valid number
((char-numeric? c) ; representation of R4RS except ((char-numeric? c) ; representation of R4RS except
(if mantissa? ; complex numbers (if mantissa? ; complex numbers
(begin (begin
(if (char=? c #\0) (if (char=? c #\0)
(if all-zeros? (if all-zeros?
(set! left-zeros (+ left-zeros 1))) (set! left-zeros (+ left-zeros 1)))
(begin (begin
(set! all-zeros? #f))) (set! all-zeros? #f)))
(string-set! format:fn-str format:fn-len c) (string-set! format:fn-str format:fn-len c)
(set! format:fn-len (+ format:fn-len 1))) (set! format:fn-len (+ format:fn-len 1)))
(begin (begin
(string-set! format:en-str format:en-len c) (string-set! format:en-str format:en-len c)
(set! format:en-len (+ format:en-len 1))))) (set! format:en-len (+ format:en-len 1)))))
((or (char=? c #\-) (char=? c #\+)) ((or (char=? c #\-) (char=? c #\+))
(if mantissa? (if mantissa?
(set! format:fn-pos? (char=? c #\+)) (set! format:fn-pos? (char=? c #\+))
(set! format:en-pos? (char=? c #\+)))) (set! format:en-pos? (char=? c #\+))))
((char=? c #\.) ((char=? c #\.)
(set! format:fn-dot format:fn-len)) (set! format:fn-dot format:fn-len))
((char=? c #\e) ((char=? c #\e)
(set! mantissa? #f)) (set! mantissa? #f))
((char=? c #\E) ((char=? c #\E)
(set! mantissa? #f)) (set! mantissa? #f))
((char-whitespace? c) #t) ((char-whitespace? c) #t)
((char=? c #\d) #t) ; decimal radix prefix ((char=? c #\d) #t) ; decimal radix prefix
((char=? c #\#) #t) ((char=? c #\#) #t)
(else (else
(format:error "illegal character `~c' in number->string" c)))))) (format:error "illegal character `~c' in number->string" c)))))))
(format:en-int (format:en-int
(lambda () ; convert exponent string to integer (lambda () ; convert exponent string to integer

5
test-suite/tests/format.test
View file

@ -1,7 +1,7 @@
;;;; format.test --- test suite for Guile's CL-ish format -*- scheme -*- ;;;; format.test --- test suite for Guile's CL-ish format -*- scheme -*-
;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001 ;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001
;;;; ;;;;
;;;; Copyright (C) 2001, 2003, 2004, 2006 Free Software Foundation, Inc. ;;;; Copyright (C) 2001, 2003, 2004, 2006, 2010 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -82,6 +82,9 @@
(pass-if "1.5" (pass-if "1.5"
(string=? "1.5" (format #f "~f" 1.5))) (string=? "1.5" (format #f "~f" 1.5)))
(pass-if "3/2"
(string=? "1.5" (format #f "~f" 3/2)))
;; in guile prior to 1.6.9 and 1.8.1, leading zeros were incorrectly ;; in guile prior to 1.6.9 and 1.8.1, leading zeros were incorrectly
;; stripped, moving the decimal point and giving "25.0" here ;; stripped, moving the decimal point and giving "25.0" here
(pass-if "string 02.5" (pass-if "string 02.5"