From patchwork Fri Apr 29 06:22:46 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Subject: [libgfortran] Fix numerous formatting bugs Date: Thu, 28 Apr 2011 20:22:46 -0000 From: Jerry DeLisle X-Patchwork-Id: 93390 Message-Id: <4DBA5936.7050407@frontier.com> To: Janne Blomqvist Cc: gfortran , gcc patches On 04/27/2011 12:57 PM, Janne Blomqvist wrote: > On Wed, Apr 27, 2011 at 08:53, Janne Blomqvist > wrote: >> On Wed, Apr 27, 2011 at 07:09, Jerry DeLisle wrote: >>> On 04/25/2011 07:36 AM, Janne Blomqvist wrote: >>>> >>>> On Mon, Apr 25, 2011 at 14:44, Jerry DeLisle >>>> 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 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 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, 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) {