On 04/27/2011 12:57 PM, Janne Blomqvist wrote:
On Wed, Apr 27, 2011 at 08:53, Janne Blomqvist
<blomqvist.ja...@gmail.com> wrote:
On Wed, Apr 27, 2011 at 07:09, Jerry DeLisle<jvdeli...@frontier.com> wrote:
On 04/25/2011 07:36 AM, Janne Blomqvist wrote:
On Mon, Apr 25, 2011 at 14:44, Jerry DeLisle<jvdeli...@frontier.com>
wrote:
On 04/25/2011 03:48 AM, Janne Blomqvist wrote:
Now, for one of the testcase changes:
--- gcc/testsuite/gfortran.dg/char4_iunit_1.f03 (revision 172909)
+++ gcc/testsuite/gfortran.dg/char4_iunit_1.f03 (working copy)
@@ -24,11 +24,11 @@ program char4_iunit_1
write(string, *) .true., .false. , .true.
if (string .ne. 4_" T F T ") call
abort
write(string, *) 1.2345e-06, 4.2846e+10_8
- if (string .ne. 4_" 1.23450002E-06 42846000000.000000 ") call
abort
+ if (string .ne. 4_" 1.234500019E-06 42846000000.000000 ") call
abort
This looks wrong. For correctly rounded REAL(4) output, we need 9
significant digits, but here we print 10.
Well, I bumped it up for defaults based on pr48488 comment #2 shown
below.
Yes, that comment in the PR is correct; to guarantee that a
binary->ascii->binary roundtrip preserves the original binary value
(with the default "round to nearest, break on even" rounding mode),
one must output at least {9, 17, 21, 36} significant digits for real
kinds 4, 8, 10, and 16, respectively (yes, I double-checked IEEE
754-2008 that this is indeed correct).
Since for the G edit descriptor d is equivalent to the number of
significant digits, AFAICS the write.c patch below is correct and the
bug must be elsewhere, no?
No.
Look at this example:
program t4
implicit none
character(len=44) :: string
write(*,*) 1.2345e-06, 4.2846e+10_8
write(*,'(1x,1pG16.9e2,1x,1pG25.17e3)') 1.2345e-06, 4.2846e+10_8
write(*,'(1x,1pG15.8e2,1x,1pG25.17e3)') 1.2345e-06, 4.2846e+10_8
end program t4
This gives with the patch:
1.234500019E-06 42846000000.000000
1.234500019E-06 42846000000.000000
1.23450002E-06 42846000000.000000
And without the patch:
1.23450002E-06 42846000000.000000
1.234500019E-06 42846000000.000000
1.23450002E-06 42846000000.000000
d is the number of digits after the decimal point, not the number of
significant digits.
I stand corrected. Or well, I still stand by my previous statement
that with the G edit descriptor d corresponds to the number of
significant digits. However, only when not using the scale factor.
Since we use a scale factor of 1, when the magnitude of the number is
such that the E edit descriptor is used, according to F2008 10.7.2.3.3
paragraph 6 for 0< k< d+2 we must print k significant digits to the
left of the decimal point and d-k+1 to the right. That is, with k=1 we
print one digit to the left of the decimal point and d-1+1=d to the
right which has the effect of increasing the number of significant
digits by one!
However, when the magnitude of the value is such that F editing is
used, the scale factor has no effect and we thus print d significant
digits.
So in order to guarantee an exact binary<->ascii roundtrip we must
accept an extra digit in some cases. Or then do something which would
make list formatted (and perhaps G0 as well?) write differ from 1PGw.d
(effectively, reduce d by one when the magnitude is such that E
editing is used)?
That is, what about something like the attached patch on top of your
patch. With the patch, the test program
program t4
implicit none
character(len=44) :: string
write(*,*) 1.2345e-06, 4.2846e+10_8, 1.1
write(*,'(1x,1pG16.9e2,1x,1pG25.17e3)') 1.2345e-06, 4.2846e+10_8
write(*,'(1x,1pG15.8e2,1x,1pG25.17e3)') 1.2345e-06, 4.2846e+10_8
write(*,'(1x,1pG0,1x,1pG0)') 1.2345e-06, 1.1
write(*,'(1x,1pG0.9,1x,1pG0.9)') 1.2345e-06, 1.1
end program t4
outputs
1.23450002E-06 42846000000.000000 1.10000002
1.234500019E-06 42846000000.000000
1.23450002E-06 42846000000.000000
1.23450002E-06 1.10000002
1.234500019E-06 1.10000002
So the change is that now it prints the same number of significant
digits in E and F mode, both for list formatted output and kPG0 when
k>=0. For list formatted we can do pretty much what we want, and for
G0 the standard only says the processor can choose appropriate values
for w, d, and e. So far we have chosen d and e only based on the kind,
but AFAICS nothing prevents taking into account the magnitude as well.
I haven't modified any of the testcases so I expect some number of
regressions due to that, but I'm asking for opinions on the approach
itself before doing that.
Actually only saw one test case failure which I have adjusted. The attached
patch applies Janne's patch to my patch and the fix for pr48787. Regression
tested on x86-64.
OK for trunk? I sure would like to get this in so I can move on to other
things.
Jerry
Index: gcc/testsuite/gfortran.dg/fmt_g.f
===================================================================
--- gcc/testsuite/gfortran.dg/fmt_g.f (revision 172909)
+++ gcc/testsuite/gfortran.dg/fmt_g.f (working copy)
@@ -31,13 +31,13 @@
WRITE(buffer,"(G12.5E5,'<')") -10000.
if (buffer.ne."************<") call abort
WRITE(buffer,"(G13.5E5,'<')") -10000.
- if (buffer.ne."-10000. <") call abort
+ if (buffer.ne."*************<") call abort
WRITE(buffer,"(G14.5E5,'<')") -10000.
- if (buffer.ne." -10000. <") call abort
+ if (buffer.ne."-10000. <") call abort
WRITE(buffer,"(G15.5E5,'<')") -10000.
- if (buffer.ne." -10000. <") call abort
+ if (buffer.ne." -10000. <") call abort
WRITE(buffer,"(G16.5E5,'<')") -10000.
- if (buffer.ne." -10000. <") call abort
+ if (buffer.ne." -10000. <") call abort
STOP
END
Index: gcc/testsuite/gfortran.dg/fmt_g0_1.f08
===================================================================
--- gcc/testsuite/gfortran.dg/fmt_g0_1.f08 (revision 172909)
+++ gcc/testsuite/gfortran.dg/fmt_g0_1.f08 (working copy)
@@ -2,19 +2,19 @@
! PR36420 Fortran 2008: g0 edit descriptor
! Test case provided by Jerry DeLisle <jvdeli...@gcc.gnu.org>
character(25) :: string = "(g0,g0,g0)"
- character(33) :: buffer
+ character(50) :: buffer
write(buffer, '(g0,g0,g0)') ':',12340,':'
if (buffer.ne.":12340:") call abort
write(buffer, string) ':',0,':'
if (buffer.ne.":0:") call abort
- write(buffer, string) ':',1.0/3.0,':'
- if (buffer.ne.":.33333334:") call abort
- write(buffer, '(1x,a,g0,a)') ':',1.0/3.0,':'
- if (buffer.ne." :.33333334:") call abort
+ write(buffer, string) ':',1.0_8/3.0_8,':'
+ if (buffer.ne.":.33333333333333331:") call abort
+ write(buffer, '(1x,a,g0,a)') ':',1.0_8/3.0_8,':'
+ if (buffer.ne." :.33333333333333331:") call abort
write(buffer, string) ':',"hello",':'
- if (buffer.ne.":hello:") call abort
+ if (buffer.ne.":hello:") call abort
write(buffer, "(g0,g0,g0,g0)") ':',.true.,.false.,':'
if (buffer.ne.":TF:") call abort
- write(buffer, "(g0,g0,',',g0,g0)") '(',( 1.2345, 2.4567 ),')'
- if (buffer.ne."(1.2345001,2.4567001)") call abort
+ write(buffer, "(g0,g0,',',g0,g0)") '(',( 1.2345_8, 2.4567_8 ),')'
+ if (buffer.ne."(1.2344999999999999,2.4567000000000001)") call abort
end
Index: gcc/testsuite/gfortran.dg/round_3.f08
===================================================================
--- gcc/testsuite/gfortran.dg/round_3.f08 (revision 0)
+++ gcc/testsuite/gfortran.dg/round_3.f08 (revision 0)
@@ -0,0 +1,75 @@
+! { dg-do run }
+! PR48615 Invalid UP/DOWN rounding with E and ES descriptors
+! Test case provided by Thomas Henlich.
+program pr48615
+ call checkfmt("(RU,F17.0)", 2.5, " 3.")
+ call checkfmt("(RU,-1P,F17.1)", 2.5, " 0.3")
+ call checkfmt("(RU,E17.1)", 2.5, " 0.3E+01") ! 0.2E+01
+ call checkfmt("(RU,1P,E17.0)", 2.5, " 3.E+00")
+ call checkfmt("(RU,ES17.0)", 2.5, " 3.E+00") ! 2.E+00
+ call checkfmt("(RU,EN17.0)", 2.5, " 3.E+00")
+
+ call checkfmt("(RD,F17.0)", 2.5, " 2.")
+ call checkfmt("(RD,-1P,F17.1)", 2.5, " 0.2")
+ call checkfmt("(RD,E17.1)", 2.5, " 0.2E+01")
+ call checkfmt("(RD,1P,E17.0)", 2.5, " 2.E+00")
+ call checkfmt("(RD,ES17.0)", 2.5, " 2.E+00")
+ call checkfmt("(RD,EN17.0)", 2.5, " 2.E+00")
+
+ call checkfmt("(RC,F17.0)", 2.5, " 3.")
+ call checkfmt("(RC,-1P,F17.1)", 2.5, " 0.3")
+ call checkfmt("(RC,E17.1)", 2.5, " 0.3E+01") ! 0.2E+01
+ call checkfmt("(RC,1P,E17.0)", 2.5, " 3.E+00")
+ call checkfmt("(RC,ES17.0)", 2.5, " 3.E+00") ! 2.E+00
+ call checkfmt("(RC,EN17.0)", 2.5, " 3.E+00")
+
+ call checkfmt("(RN,F17.0)", 2.5, " 2.")
+ call checkfmt("(RN,-1P,F17.1)", 2.5, " 0.2")
+ call checkfmt("(RN,E17.1)", 2.5, " 0.2E+01")
+ call checkfmt("(RN,1P,E17.0)", 2.5, " 2.E+00")
+ call checkfmt("(RN,ES17.0)", 2.5, " 2.E+00")
+ call checkfmt("(RN,EN17.0)", 2.5, " 2.E+00")
+
+ call checkfmt("(RZ,F17.0)", 2.5, " 2.")
+ call checkfmt("(RZ,-1P,F17.1)", 2.5, " 0.2")
+ call checkfmt("(RZ,E17.1)", 2.5, " 0.2E+01")
+ call checkfmt("(RZ,1P,E17.0)", 2.5, " 2.E+00")
+ call checkfmt("(RZ,ES17.0)", 2.5, " 2.E+00")
+ call checkfmt("(RZ,EN17.0)", 2.5, " 2.E+00")
+
+ call checkfmt("(RZ,F17.0)", -2.5, " -2.")
+ call checkfmt("(RZ,-1P,F17.1)", -2.5, " -0.2")
+ call checkfmt("(RZ,E17.1)", -2.5, " -0.2E+01")
+ call checkfmt("(RZ,1P,E17.0)", -2.5, " -2.E+00")
+ call checkfmt("(RZ,ES17.0)", -2.5, " -2.E+00")
+ call checkfmt("(RZ,EN17.0)", -2.5, " -2.E+00")
+
+ call checkfmt("(RN,F17.0)", -2.5, " -2.")
+ call checkfmt("(RN,-1P,F17.1)", -2.5, " -0.2")
+ call checkfmt("(RN,E17.1)", -2.5, " -0.2E+01")
+ call checkfmt("(RN,1P,E17.0)", -2.5, " -2.E+00")
+ call checkfmt("(RN,ES17.0)", -2.5, " -2.E+00")
+ call checkfmt("(RN,EN17.0)", -2.5, " -2.E+00")
+
+ call checkfmt("(RC,F17.0)", -2.5, " -3.")
+ call checkfmt("(RC,-1P,F17.1)", -2.5, " -0.3")
+ call checkfmt("(RC,E17.1)", -2.5, " -0.3E+01") ! -0.2E+01
+ call checkfmt("(RC,1P,E17.0)", -2.5, " -3.E+00")
+ call checkfmt("(RC,ES17.0)", -2.5, " -3.E+00") ! -2.E+00
+ call checkfmt("(RC,EN17.0)", -2.5, " -3.E+00")
+
+ call checkfmt("(RU,E17.1)", nearest(2.0, 1.0), " 0.3E+01") ! 0.2E+01
+ call checkfmt("(RD,E17.1)", nearest(3.0, -1.0), " 0.2E+01") ! 0.3E+01
+
+contains
+ subroutine checkfmt(fmt, x, cmp)
+ character(len=*), intent(in) :: fmt
+ real, intent(in) :: x
+ character(len=*), intent(in) :: cmp
+ character(len=40) :: s
+
+ write(s, fmt) x
+ if (s /= cmp) call abort
+ !if (s /= cmp) print "(a,1x,a,' expected: ',1x)", fmt, s, cmp
+ end subroutine
+end program
Index: gcc/testsuite/gfortran.dg/namelist_print_1.f
===================================================================
--- gcc/testsuite/gfortran.dg/namelist_print_1.f (revision 172909)
+++ gcc/testsuite/gfortran.dg/namelist_print_1.f (working copy)
@@ -9,5 +9,5 @@
namelist /mynml/ x
x = 1
! ( dg-output "^" }
- print mynml ! { dg-output "&MYNML(\n|\r\n|\r) X= 1.0000000 ,(\n|\r\n|\r) /(\n|\r\n|\r)" }
+ print mynml ! { dg-output "&MYNML(\n|\r\n|\r) X= 1.00000000 ,(\n|\r\n|\r) /(\n|\r\n|\r)" }
end
Index: gcc/testsuite/gfortran.dg/char4_iunit_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/char4_iunit_1.f03 (revision 172909)
+++ gcc/testsuite/gfortran.dg/char4_iunit_1.f03 (working copy)
@@ -5,7 +5,7 @@
! Test case prepared by Jerry DeLisle <jvdeli...@gcc.gnu.org>
program char4_iunit_1
implicit none
- character(kind=4,len=42) :: string
+ character(kind=4,len=44) :: string
integer(kind=4) :: i,j
real(kind=4) :: inf, nan, large
@@ -24,11 +24,11 @@ program char4_iunit_1
write(string, *) .true., .false. , .true.
if (string .ne. 4_" T F T ") call abort
write(string, *) 1.2345e-06, 4.2846e+10_8
- if (string .ne. 4_" 1.23450002E-06 42846000000.000000 ") call abort
+ if (string .ne. 4_" 1.23450002E-06 42846000000.000000 ") call abort
write(string, *) nan, inf
- if (string .ne. 4_" NaN Infinity ") call abort
+ if (string .ne. 4_" NaN Infinity ") call abort
write(string, '(10x,f3.1,3x,f9.1)') nan, inf
- if (string .ne. 4_" NaN Infinity ") call abort
+ if (string .ne. 4_" NaN Infinity ") call abort
write(string, *) (1.2, 3.4 )
- if (string .ne. 4_" ( 1.2000000 , 3.4000001 ) ") call abort
+ if (string .ne. 4_" ( 1.20000005 , 3.40000010 ) ") call abort
end program char4_iunit_1
Index: gcc/testsuite/gfortran.dg/f2003_io_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/f2003_io_5.f03 (revision 172909)
+++ gcc/testsuite/gfortran.dg/f2003_io_5.f03 (working copy)
@@ -5,7 +5,7 @@ integer :: i
real :: a(10) = [ (i*1.3, i=1,10) ]
real :: b(10)
complex :: c
-character(34) :: complex
+character(36) :: complex
namelist /nm/ a
open(99,file="mynml",form="formatted",decimal="point",status="replace")
@@ -18,9 +18,9 @@ close(99, status="delete")
c = (3.123,4.456)
write(complex,*,decimal="comma") c
-if (complex.ne." ( 3,1229999 ; 4,4559999 )") call abort
+if (complex.ne." ( 3,12299991 ; 4,45599985 )") call abort
c = (0.0, 0.0)
read(complex,*,decimal="comma") c
-if (complex.ne." ( 3,1229999 ; 4,4559999 )") call abort
+if (complex.ne." ( 3,12299991 ; 4,45599985 )") call abort
end
Index: gcc/testsuite/gfortran.dg/coarray_15.f90
===================================================================
--- gcc/testsuite/gfortran.dg/coarray_15.f90 (revision 172909)
+++ gcc/testsuite/gfortran.dg/coarray_15.f90 (working copy)
@@ -9,7 +9,7 @@ program ex2
implicit none
real, allocatable :: z(:)[:]
integer :: image
- character(len=80) :: str
+ character(len=128) :: str
allocate(z(3)[*])
write(*,*) 'z allocated on image',this_image()
@@ -25,18 +25,18 @@ program ex2
str = repeat('X', len(str))
write(str,*) 'z=',z(:),' on image',this_image()
- if (str /= " z= 1.2000000 1.2000000 1.2000000 on image 1") &
- call abort ()
+ if (str /= " z= 1.20000005 1.20000005 1.20000005 on image 1") &
+ call abort
str = repeat('X', len(str))
write(str,*) 'z=',z,' on image',this_image()
- if (str /= " z= 1.2000000 1.2000000 1.2000000 on image 1") &
- call abort ()
+ if (str /= " z= 1.20000005 1.20000005 1.20000005 on image 1") &
+ call abort
str = repeat('X', len(str))
write(str,*) 'z=',z(1:3)[this_image()],' on image',this_image()
- if (str /= " z= 1.2000000 1.2000000 1.2000000 on image 1") &
- call abort ()
+ if (str /= " z= 1.20000005 1.20000005 1.20000005 on image 1") &
+ call abort
call ex2a()
call ex5()
@@ -46,7 +46,7 @@ subroutine ex2a()
implicit none
real, allocatable :: z(:,:)[:,:]
integer :: image
- character(len=100) :: str
+ character(len=128) :: str
allocate(z(2,2)[1,*])
write(*,*) 'z allocated on image',this_image()
@@ -62,38 +62,38 @@ subroutine ex2a()
str = repeat('X', len(str))
write(str,*) 'z=',z(:,:),' on image',this_image()
- if (str /= " z= 1.2000000 1.2000000 1.2000000 1.2000000 on image 1") &
- call abort ()
+ if (str /= " z= 1.20000005 1.20000005 1.20000005 1.20000005 on image 1") &
+ call abort
str = repeat('X', len(str))
write(str,*) 'z=',z,' on image',this_image()
- if (str /= " z= 1.2000000 1.2000000 1.2000000 1.2000000 on image 1") &
- call abort ()
+ if (str /= " z= 1.20000005 1.20000005 1.20000005 1.20000005 on image 1") &
+ call abort
end subroutine ex2a
subroutine ex5
implicit none
integer :: me
real, save :: w(4)[*]
- character(len=100) :: str
+ character(len=128) :: str
me = this_image()
w = me
str = repeat('X', len(str))
write(str,*) 'In main on image',this_image(), 'w= ',w
- if (str /= " In main on image 1 w= 1.0000000 1.0000000 1.0000000 1.0000000") &
- call abort ()
+ if (str /= " In main on image 1 w= 1.00000000 1.00000000 1.00000000 1.00000000") &
+ call abort
str = repeat('X', len(str))
write(str,*) 'In main on image',this_image(), 'w= ',w(1:4)
- if (str /= " In main on image 1 w= 1.0000000 1.0000000 1.0000000 1.0000000") &
- call abort ()
+ if (str /= " In main on image 1 w= 1.00000000 1.00000000 1.00000000 1.00000000") &
+ call abort
str = repeat('X', len(str))
write(str,*) 'In main on image',this_image(), 'w= ',w(:)[1]
- if (str /= " In main on image 1 w= 1.0000000 1.0000000 1.0000000 1.0000000") &
- call abort ()
+ if (str /= " In main on image 1 w= 1.00000000 1.00000000 1.00000000 1.00000000") &
+ call abort
sync all
call ex5_sub(me,w)
@@ -103,10 +103,10 @@ subroutine ex5_sub(n,w)
implicit none
integer :: n
real :: w(n)
- character(len=50) :: str
+ character(len=75) :: str
str = repeat('X', len(str))
write(str,*) 'In sub on image',this_image(), 'w= ',w
- if (str /= " In sub on image 1 w= 1.0000000") &
- call abort ()
+ if (str /= " In sub on image 1 w= 1.00000000") &
+ call abort
end subroutine ex5_sub
Index: gcc/testsuite/gfortran.dg/namelist_65.f90
===================================================================
--- gcc/testsuite/gfortran.dg/namelist_65.f90 (revision 172909)
+++ gcc/testsuite/gfortran.dg/namelist_65.f90 (working copy)
@@ -14,9 +14,9 @@ enddo
write(out,nl1)
if (out(1).ne."&NL1") call abort
-if (out(2).ne." A= 1.0000000 ,") call abort
-if (out(3).ne." B= 2.0000000 ,") call abort
-if (out(4).ne." C= 3.0000000 ,") call abort
+if (out(2).ne." A= 1.00000000 ,") call abort
+if (out(3).ne." B= 2.00000000 ,") call abort
+if (out(4).ne." C= 3.00000000 ,") call abort
if (out(5).ne." /") call abort
end program oneline
Index: gcc/testsuite/gfortran.dg/fmt_cache_1.f
===================================================================
--- gcc/testsuite/gfortran.dg/fmt_cache_1.f (revision 172909)
+++ gcc/testsuite/gfortran.dg/fmt_cache_1.f (working copy)
@@ -3,9 +3,10 @@
! pr40330 incorrect io.
! test case derived from pr40662, <jvdeli...@gcc.gnu.org>
program astap
- character(40) teststring
- arlxca = 0.0
- open(10, status="scratch")
+ implicit none
+ character(34) :: teststring
+ real(4) :: arlxca = 0.0
+ open(10)
write(10,40) arlxca
write(10,40) arlxca
40 format(t4,"arlxca = ",1pg13.6,t27,"arlxcc = ",g13.6,t53,
@@ -21,13 +22,12 @@
. "ebalnc = ",g13.6,t79,"ebalsa = ",g13.6,t105,
. "ebalsc = ",g13.6)
rewind 10
- rewind 10
teststring = ""
read(10,'(a)') teststring
- if (teststring.ne." arlxca = 0.00000 arlxcc = ")call abort
+ if (teststring.ne." arlxca = 0.00000 arlxcc =")call abort
teststring = ""
read(10,'(a)') teststring
- if (teststring.ne." arlxca = 0.00000 arlxcc = ")call abort
+ if (teststring.ne." arlxca = 0.00000 arlxcc =")call abort
end program astap
Index: gcc/testsuite/gfortran.dg/char4_iunit_2.f03
===================================================================
--- gcc/testsuite/gfortran.dg/char4_iunit_2.f03 (revision 172909)
+++ gcc/testsuite/gfortran.dg/char4_iunit_2.f03 (working copy)
@@ -43,5 +43,5 @@ program char4_iunit_2
write(widestring,*)"test",i, x, str_default,&
trim(str_char4)
if (widestring .ne. &
- k_" test 345 52.542999 0 hijklmnp qwertyuiopasd") call abort
+ k_" test 345 52.5429993 0 hijklmnp qwertyuiopasd") call abort
end program char4_iunit_2
Index: gcc/testsuite/gfortran.dg/real_const_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/real_const_3.f90 (revision 172909)
+++ gcc/testsuite/gfortran.dg/real_const_3.f90 (working copy)
@@ -42,15 +42,15 @@ program main
if (trim(adjustl(str)) .ne. 'NaN') call abort
write(str,*) z
- if (trim(adjustl(str)) .ne. '( NaN, NaN)') call abort
+ if (trim(adjustl(str)) .ne. '( NaN, NaN)') call abort
write(str,*) z2
- if (trim(adjustl(str)) .ne. '( NaN, NaN)') call abort
+ if (trim(adjustl(str)) .ne. '( NaN, NaN)') call abort
write(str,*) z3
- if (trim(adjustl(str)) .ne. '( Infinity, -Infinity)') call abort
+ if (trim(adjustl(str)) .ne. '( Infinity, -Infinity)') call abort
write(str,*) z4
- if (trim(adjustl(str)) .ne. '( 0.0000000 , -0.0000000 )') call abort
+ if (trim(adjustl(str)) .ne. '( 0.00000000 , -0.00000000 )') call abort
end program main
Index: libgfortran/io/write.c
===================================================================
--- libgfortran/io/write.c (revision 172909)
+++ libgfortran/io/write.c (working copy)
@@ -1155,35 +1155,35 @@ write_z (st_parameter_dt *dtp, const fnode *f, con
void
write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
- write_float (dtp, f, p, len);
+ write_float (dtp, f, p, len, 0);
}
void
write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
- write_float (dtp, f, p, len);
+ write_float (dtp, f, p, len, 0);
}
void
write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
- write_float (dtp, f, p, len);
+ write_float (dtp, f, p, len, 0);
}
void
write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
- write_float (dtp, f, p, len);
+ write_float (dtp, f, p, len, 0);
}
void
write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
- write_float (dtp, f, p, len);
+ write_float (dtp, f, p, len, 0);
}
@@ -1432,8 +1432,8 @@ set_fnode_default (st_parameter_dt *dtp, fnode *f,
switch (length)
{
case 4:
- f->u.real.w = 15;
- f->u.real.d = 8;
+ f->u.real.w = 16;
+ f->u.real.d = 9;
f->u.real.e = 2;
break;
case 8:
@@ -1442,13 +1442,13 @@ set_fnode_default (st_parameter_dt *dtp, fnode *f,
f->u.real.e = 3;
break;
case 10:
- f->u.real.w = 29;
- f->u.real.d = 20;
+ f->u.real.w = 30;
+ f->u.real.d = 21;
f->u.real.e = 4;
break;
case 16:
- f->u.real.w = 44;
- f->u.real.d = 35;
+ f->u.real.w = 45;
+ f->u.real.d = 36;
f->u.real.e = 4;
break;
default:
@@ -1468,7 +1468,7 @@ write_real (st_parameter_dt *dtp, const char *sour
int org_scale = dtp->u.p.scale_factor;
dtp->u.p.scale_factor = 1;
set_fnode_default (dtp, &f, length);
- write_float (dtp, &f, source , length);
+ write_float (dtp, &f, source , length, 1);
dtp->u.p.scale_factor = org_scale;
}
@@ -1476,12 +1476,20 @@ write_real (st_parameter_dt *dtp, const char *sour
void
write_real_g0 (st_parameter_dt *dtp, const char *source, int length, int d)
{
- fnode f ;
+ fnode f;
+ int comp_d;
set_fnode_default (dtp, &f, length);
if (d > 0)
f.u.real.d = d;
+
+ /* Compensate for extra digits when using scale factor, d is not
+ specified, and the magnitude is such that E editing is used. */
+ if (dtp->u.p.scale_factor > 0 && d == 0)
+ comp_d = 1;
+ else
+ comp_d = 0;
dtp->u.p.g0_no_blanks = 1;
- write_float (dtp, &f, source , length);
+ write_float (dtp, &f, source , length, comp_d);
dtp->u.p.g0_no_blanks = 0;
}
Index: libgfortran/io/write_float.def
===================================================================
--- libgfortran/io/write_float.def (revision 172909)
+++ libgfortran/io/write_float.def (working copy)
@@ -289,8 +289,9 @@ output_float (st_parameter_dt *dtp, const fnode *f
}
else if (nbefore + nafter < ndigits)
{
- ndigits = nbefore + nafter;
- i = ndigits;
+ i = ndigits = nbefore + nafter;
+ if (d == 0 && digits[1] == '0')
+ goto skip;
if (digits[i] >= rchar)
{
/* Propagate the carry. */
@@ -812,7 +813,8 @@ CALCULATE_EXP(16)
static void \
output_float_FMT_G_ ## x (st_parameter_dt *dtp, const fnode *f, \
GFC_REAL_ ## x m, char *buffer, size_t size, \
- int sign_bit, bool zero_flag, int ndigits, int edigits) \
+ int sign_bit, bool zero_flag, int ndigits, \
+ int edigits, int comp_d) \
{ \
int e = f->u.real.e;\
int d = f->u.real.d;\
@@ -850,7 +852,7 @@ output_float_FMT_G_ ## x (st_parameter_dt *dtp, co
{ \
newf->format = FMT_E;\
newf->u.real.w = w;\
- newf->u.real.d = d;\
+ newf->u.real.d = d - comp_d;\
newf->u.real.e = e;\
nb = 0;\
goto finish;\
@@ -864,11 +866,10 @@ output_float_FMT_G_ ## x (st_parameter_dt *dtp, co
\
while (low <= high)\
{ \
- GFC_REAL_ ## x temp;\
+ volatile GFC_REAL_ ## x temp;\
mid = (low + high) / 2;\
\
temp = (calculate_exp_ ## x (mid - 1) * (1 - r * rexp_d));\
- asm volatile ("" : "+m" (temp));\
\
if (m < temp)\
{ \
@@ -894,22 +895,11 @@ output_float_FMT_G_ ## x (st_parameter_dt *dtp, co
}\
}\
\
- if (e > 4)\
- e = 4;\
- if (e < 0)\
- nb = 4;\
- else\
- nb = e + 2;\
-\
- nb = nb >= w ? 0 : nb;\
+ nb = e <= 0 ? 4 : e + 2;\
+ nb = nb >= w ? w - 1 : nb;\
newf->format = FMT_F;\
- newf->u.real.w = f->u.real.w - nb;\
-\
- if (m == 0.0)\
- newf->u.real.d = d - 1;\
- else\
- newf->u.real.d = - (mid - d - 1);\
-\
+ newf->u.real.w = w - nb;\
+ newf->u.real.d = m == 0.0 ? d - 1 : -(mid - d - 1) ;\
dtp->u.p.scale_factor = 0;\
\
finish:\
@@ -931,7 +921,7 @@ output_float_FMT_G_ ## x (st_parameter_dt *dtp, co
gfc_char4_t *p4 = (gfc_char4_t *) p;\
memset4 (p4, pad, nb);\
}\
- else\
+ else \
memset (p, pad, nb);\
}\
}\
@@ -1010,19 +1000,20 @@ __qmath_(quadmath_snprintf) (buffer, sizeof buffer
edigits);\
else \
output_float_FMT_G_ ## x (dtp, f, tmp, buffer, size, sign_bit, \
- zero_flag, ndigits, edigits);\
+ zero_flag, ndigits, edigits, comp_d);\
}\
/* Output a real number according to its format. */
static void
-write_float (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
+write_float (st_parameter_dt *dtp, const fnode *f, const char *source, \
+ int len, int comp_d)
{
#if defined(HAVE_GFC_REAL_16) || __LDBL_DIG__ > 18
-# define MIN_FIELD_WIDTH 48
+# define MIN_FIELD_WIDTH 49
#else
-# define MIN_FIELD_WIDTH 31
+# define MIN_FIELD_WIDTH 32
#endif
#define STR(x) STR1(x)
#define STR1(x) #x
@@ -1039,23 +1030,8 @@ static void
to handle the largest number of exponent digits expected. */
edigits=4;
- if (f->format == FMT_F || f->format == FMT_EN || f->format == FMT_G
- || ((f->format == FMT_D || f->format == FMT_E)
- && dtp->u.p.scale_factor != 0))
- {
- /* Always convert at full precision to avoid double rounding. */
- ndigits = MIN_FIELD_WIDTH - 4 - edigits;
- }
- else
- {
- /* The number of digits is known, so let printf do the rounding. */
- if (f->format == FMT_ES)
- ndigits = f->u.real.d + 1;
- else
- ndigits = f->u.real.d;
- if (ndigits > MIN_FIELD_WIDTH - 4 - edigits)
- ndigits = MIN_FIELD_WIDTH - 4 - edigits;
- }
+ /* Always convert at full precision to avoid double rounding. */
+ ndigits = MIN_FIELD_WIDTH - 4 - edigits;
switch (len)
{
