Patchwork [libgfortran] PR47285 G format outputs wrong number of characters when decimal supplied in literal

login
register
mail settings
Submitter Jerry DeLisle
Date Jan. 26, 2011, 3:49 a.m.
Message ID <4D3F99AC.7060105@frontier.com>
Download mbox | patch
Permalink /patch/80444/
State New
Headers show

Comments

Jerry DeLisle - Jan. 26, 2011, 3:49 a.m.
Hi,

As far as I can tell.  ;)

This patch fixes the problem.  I have added a try return type to output_float so 
that the OUTPUT_FLOAT_FMT_G routines will know when the field width is too 
small. This enables padding with '*' instead of ' ' in those cases.

Also in F2008 R7 draft, we have at the very end of 10.7.5.2.2 Generalized real 
and complex editing

"The value of w − n shall be positive."

This is now fixed with:

+  nb = nb >= w ? 0 : nb;\

test case attached.  Regression tested on x86-64.  OK for trunk?

Regards,

Jerry

2011-01-25  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libgfortran/47285
	* io/write_float.def (output_float): Return SUCCESS or FAILURE and use
	the result to set the padding.
! { dg-do run }
! PR47285 G format outputs wrong number of characters.
! Test case prepared by Jerry DeLisle <jvdelisle@gcc.gnu.org>
       PROGRAM FOO
       character(len=50) :: buffer

       WRITE(buffer,"(G0.5,'<')") -10000.
       if (buffer.ne."-10000.<") call abort
       WRITE(buffer,"(G1.5E5,'<')") -10000.
       if (buffer.ne."*<") call abort
       WRITE(buffer,"(G2.5E5,'<')") -10000.
       if (buffer.ne."**<") call abort
       WRITE(buffer,"(G3.5E5,'<')") -10000.
       if (buffer.ne."***<") call abort
       WRITE(buffer,"(G4.5E5,'<')") -10000.
       if (buffer.ne."****<") call abort
       WRITE(buffer,"(G5.5E5,'<')") -10000.
       if (buffer.ne."*****<") call abort
       WRITE(buffer,"(G6.5E5,'<')") -10000.
       if (buffer.ne."******<") call abort
       WRITE(buffer,"(G7.5E5,'<')") -10000.
       if (buffer.ne."*******<") call abort
       WRITE(buffer,"(G8.5E5,'<')") -10000.
       if (buffer.ne."********<") call abort
       WRITE(buffer,"(G9.5E5,'<')") -10000.
       if (buffer.ne."*********<") call abort
       WRITE(buffer,"(G10.5E5,'<')") -10000.
       if (buffer.ne."**********<") call abort
       WRITE(buffer,"(G11.5E5,'<')") -10000.
       if (buffer.ne."***********<") call abort
       WRITE(buffer,"(G12.5E5,'<')") -10000.
       if (buffer.ne."************<") call abort
       WRITE(buffer,"(G13.5E5,'<')") -10000.
       if (buffer.ne."-10000.      <") call abort
       WRITE(buffer,"(G14.5E5,'<')") -10000.
       if (buffer.ne." -10000.      <") call abort
       WRITE(buffer,"(G15.5E5,'<')") -10000.
       if (buffer.ne."  -10000.      <") call abort
       WRITE(buffer,"(G16.5E5,'<')") -10000.
       if (buffer.ne."   -10000.      <") call abort

       STOP
       END
Janne Blomqvist - Jan. 26, 2011, 2:43 p.m.
On Wed, Jan 26, 2011 at 05:49, Jerry DeLisle <jvdelisle@frontier.com> wrote:
> Hi,
>
> As far as I can tell.  ;)
>
> This patch fixes the problem.  I have added a try return type to
> output_float so that the OUTPUT_FLOAT_FMT_G routines will know when the
> field width is too small. This enables padding with '*' instead of ' ' in
> those cases.
>
> Also in F2008 R7 draft, we have at the very end of 10.7.5.2.2 Generalized
> real and complex editing
>
> "The value of w − n shall be positive."
>
> This is now fixed with:
>
> +  nb = nb >= w ? 0 : nb;\
>
> test case attached.  Regression tested on x86-64.  OK for trunk?

Ok, thanks; remember to create a ChangeLog entry for the testcase too.

Patch

Index: write_float.def
===================================================================
--- write_float.def	(revision 168831)
+++ write_float.def	(working copy)
@@ -61,7 +61,7 @@  calculate_sign (st_parameter_dt *dtp, int negative
 
 /* Output a real number according to its format which is FMT_G free.  */
 
-static void
+static try
 output_float (st_parameter_dt *dtp, const fnode *f, char *buffer, size_t size, 
 	      int sign_bit, bool zero_flag, int ndigits, int edigits)
 {
@@ -126,17 +126,17 @@  output_float (st_parameter_dt *dtp, const fnode *f
 	{
 	  out = write_block (dtp, w);
 	  if (out == NULL)
-	    return;
+	    return FAILURE;
 
 	  if (unlikely (is_char4_unit (dtp)))
 	    {
 	      gfc_char4_t *out4 = (gfc_char4_t *) out;
 	      *out4 = '0';
-	      return;
+	      return SUCCESS;
 	    }
 
 	  *out = '0';
-	  return;
+	  return SUCCESS;
 	}
 	      
     }
@@ -181,13 +181,13 @@  output_float (st_parameter_dt *dtp, const fnode *f
 	{
 	  generate_error (&dtp->common, LIBERROR_FORMAT, "Precision not "
 			  "greater than zero in format specifier 'E' or 'D'");
-	  return;
+	  return FAILURE;
 	}
       if (i <= -d || i >= d + 2)
 	{
 	  generate_error (&dtp->common, LIBERROR_FORMAT, "Scale factor "
 			  "out of range in format specifier 'E' or 'D'");
-	  return;
+	  return FAILURE;
 	}
 
       if (!zero_flag)
@@ -433,7 +433,7 @@  output_float (st_parameter_dt *dtp, const fnode *f
   /* Create the ouput buffer.  */
   out = write_block (dtp, w);
   if (out == NULL)
-    return;
+    return FAILURE;
 
   /* Check the value fits in the specified field width.  */
   if (nblanks < 0 || edigits == -1)
@@ -442,10 +442,10 @@  output_float (st_parameter_dt *dtp, const fnode *f
 	{
 	  gfc_char4_t *out4 = (gfc_char4_t *) out;
 	  memset4 (out4, '*', w);
-	  return;
+	  return FAILURE;
 	}
       star_fill (out, w);
-      return;
+      return FAILURE;
     }
 
   /* See if we have space for a zero before the decimal point.  */
@@ -553,7 +553,7 @@  output_float (st_parameter_dt *dtp, const fnode *f
 	  memset4 (out4, ' ' , nblanks);
 	  dtp->u.p.no_leading_blank = 0;
 	}
-      return;
+      return SUCCESS;
     } /* End of character(kind=4) internal unit code.  */
 
   /* Pad to full field width.  */
@@ -649,6 +649,7 @@  output_float (st_parameter_dt *dtp, const fnode *f
 #undef STR
 #undef STR1
 #undef MIN_FIELD_WIDTH
+  return SUCCESS;
 }
 
 
@@ -821,8 +822,9 @@  output_float_FMT_G_ ## x (st_parameter_dt *dtp, co
   GFC_REAL_ ## x rexp_d;\
   int low, high, mid;\
   int ubound, lbound;\
-  char *p;\
+  char *p, pad = ' ';\
   int save_scale_factor, nb = 0;\
+  try result;\
 \
   save_scale_factor = dtp->u.p.scale_factor;\
   newf = (fnode *) get_mem (sizeof (fnode));\
@@ -876,11 +878,14 @@  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;\
   newf->format = FMT_F;\
   newf->u.real.w = f->u.real.w - nb;\
 \
@@ -892,8 +897,8 @@  output_float_FMT_G_ ## x (st_parameter_dt *dtp, co
   dtp->u.p.scale_factor = 0;\
 \
  finish:\
-  output_float (dtp, newf, buffer, size, sign_bit, zero_flag, ndigits, \
-		edigits);\
+  result = output_float (dtp, newf, buffer, size, sign_bit, zero_flag, \
+			 ndigits, edigits);\
   dtp->u.p.scale_factor = save_scale_factor;\
 \
   free (newf);\
@@ -903,13 +908,15 @@  output_float_FMT_G_ ## x (st_parameter_dt *dtp, co
       p = write_block (dtp, nb);\
       if (p == NULL)\
 	return;\
+      if (result == FAILURE)\
+        pad = '*';\
       if (unlikely (is_char4_unit (dtp)))\
 	{\
 	  gfc_char4_t *p4 = (gfc_char4_t *) p;\
-	  memset4 (p4, ' ', nb);\
+	  memset4 (p4, pad, nb);\
 	}\
       else\
-	memset (p, ' ', nb);\
+	memset (p, pad, nb);\
     }\
 }\