Re: [patch, fortran] PR38398 g0.w edit descriptor: Update for F2008 Tokyo meeting changes

[Jerry DeLisle <jvdelisle at verizon dot net>]

Jerry DeLisle wrote:
> Tobias Burnus wrote:
> > Jerry,
> >
> > thanks for your patch. However, if I read
> > http://www.j3-fortran.org/doc/year/08/08-296r2.txt
> > correctly, also for "g0" and not only for "g0.d one needs
> > to remove the trailing/heading spaces:

With this patch, I have fixed all of Tobias' comments.  Leading and trailing 
blanks are not printed and we use basic G editing rather than ES.  This is now 
consistent with latest committee comments.

The patch also finds the locus within the format string for errors.

Thanks to Dominique for additional review and checking.

Regression tested on x86-64 (-m32, -m64).  Test case updated in patch.

I plan to commit later today.

Regards,

Jerry

2008-12-21  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/38398
	* io.c: Add error checks for g0 formatting and provide adjustment of
	error loci for improved error messages.

2008-12-21  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libfortran/38398
	* io/io.h (st_parameter_dt): Add new bit to keep track of when to
	suppress blanks for g0 formatting.
	* io/transfer.c (formatted_transfer_scalar): Always call write_real_g0
	for g0 formatting.
	* io.c (write.c): Do not use ES formatting and use new bit to suppress
	blanks.
	* io/write_float.def (output_float): Adjust the location of setting the
	width so that it can be adjusted when suppressing blanks.  Set number of
	blanks to zero when dtp->u.p.g0_no_blanks is set. Do some minor code
	clean-up and add some white space for readability.

Index: gcc/testsuite/gfortran.dg/fmt_g0_1.f08
===================================================================
--- gcc/testsuite/gfortran.dg/fmt_g0_1.f08	(revision 142848)
+++ gcc/testsuite/gfortran.dg/fmt_g0_1.f08	(working copy)
@@ -8,13 +8,13 @@
     write(buffer, string) ':',0,':'
     if (buffer.ne.":0:") call abort
     write(buffer, string) ':',1.0/3.0,':'
-    if (buffer.ne.": 0.33333334    :") call abort
+    if (buffer.ne.":.33333334:") call abort
     write(buffer, '(1x,a,g0,a)') ':',1.0/3.0,':'
-    if (buffer.ne." : 0.33333334    :") call abort
+    if (buffer.ne." :.33333334:") call abort
     write(buffer, string) ':',"hello",':'
     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
+    if (buffer.ne."(1.2345001,2.4567001)") call abort
 end
Index: gcc/fortran/io.c
===================================================================
--- gcc/fortran/io.c	(revision 142848)
+++ gcc/fortran/io.c	(working copy)
@@ -118,6 +118,7 @@ format_token;
    used to back up by a single format token during the parsing
    process.  */
 static gfc_char_t *format_string;
+static int format_string_pos;
 static int format_length, use_last_char;
 static char error_element;
 static locus format_locus;
@@ -169,6 +170,7 @@ next_char (int in_string)
 
   if (mode != MODE_STRING)
     format_locus = gfc_current_locus;
+  format_string_pos++;
 
   c = gfc_wide_toupper (c);
   return c;
@@ -503,6 +505,7 @@ check_format (bool is_input)
   level = 0;
   repeat = 0;
   rv = SUCCESS;
+  format_string_pos = 0;
 
   t = format_lex ();
   if (t == FMT_ERROR)
@@ -729,15 +732,19 @@ data_desc:
 	      saved_token = u;
 	      break;
 	    }
-
 	  u = format_lex ();
-	  if (u == FMT_ERROR)
-	    goto fail;
 	  if (u != FMT_POSINT)
 	    {
 	      error = posint_required;
 	      goto syntax;
 	    }
+	  u = format_lex ();
+	  if (u == FMT_E)
+	    {
+	      error = _("E specifier not allowed with g0 descriptor");
+	      goto syntax;
+	    }
+	  saved_token = u;
 	  break;
 	}
 
@@ -983,6 +990,8 @@ extension_optional_comma:
   goto format_item;
 
 syntax:
+  if (mode != MODE_FORMAT)
+    format_locus.nextc += format_string_pos;
   if (error == unexpected_element)
     gfc_error (error, error_element, &format_locus);
   else
Index: libgfortran/io/io.h
===================================================================
--- libgfortran/io/io.h	(revision 142848)
+++ libgfortran/io/io.h	(working copy)
@@ -444,7 +444,9 @@ typedef struct st_parameter_dt
 	  /* An internal unit specific flag to signify an EOF condition for list
 	     directed read.  */
 	  unsigned at_eof : 1;
-	  /* 16 unused bits.  */
+	  /* Used for g0 floating point output.  */
+	  unsigned g0_no_blanks : 1;
+	  /* 15 unused bits.  */
 
 	  char last_char;
 	  char nml_delim;
Index: libgfortran/io/transfer.c
===================================================================
--- libgfortran/io/transfer.c	(revision 142848)
+++ libgfortran/io/transfer.c	(working copy)
@@ -1221,12 +1221,7 @@ formatted_transfer_scalar (st_parameter_
 		break;
 	      case BT_REAL:
 		if (f->u.real.w == 0)
-		  {
-		    if (f->u.real.d == 0)
-		      write_real (dtp, p, kind);
-		    else
-		      write_real_g0 (dtp, p, kind, f->u.real.d);
-		  }
+		  write_real_g0 (dtp, p, kind, f->u.real.d);
 		else
 		  write_d (dtp, f, p, kind);
 		break;
Index: libgfortran/io/write.c
===================================================================
--- libgfortran/io/write.c	(revision 142848)
+++ libgfortran/io/write.c	(working copy)
@@ -1010,13 +1010,12 @@ void
 write_real_g0 (st_parameter_dt *dtp, const char *source, int length, int d)
 {
   fnode f ;
-  int org_scale = dtp->u.p.scale_factor;
-  dtp->u.p.scale_factor = 1;
   set_fnode_default (dtp, &f, length);
-  f.format = FMT_ES;
-  f.u.real.d = d;
+  if (d > 0)
+    f.u.real.d = d;
+  dtp->u.p.g0_no_blanks = 1;
   write_float (dtp, &f, source , length);
-  dtp->u.p.scale_factor = org_scale;
+  dtp->u.p.g0_no_blanks = 0;
 }
 
 
Index: libgfortran/io/write_float.def
===================================================================
--- libgfortran/io/write_float.def	(revision 142848)
+++ libgfortran/io/write_float.def	(working copy)
@@ -333,15 +333,6 @@ output_float (st_parameter_dt *dtp, cons
   else
     edigits = 0;
 
-  /* Pick a field size if none was specified.  */
-  if (w <= 0)
-    w = nbefore + nzero + nafter + (sign != S_NONE ? 2 : 1);
-
-  /* Create the ouput buffer.  */
-  out = write_block (dtp, w);
-  if (out == NULL)
-    return;
-
   /* Zero values always output as positive, even if the value was negative
      before rounding.  */
   for (i = 0; i < ndigits; i++)
@@ -359,11 +350,26 @@ output_float (st_parameter_dt *dtp, cons
 	sign = calculate_sign (dtp, 0);
     }
 
+  /* Pick a field size if none was specified.  */
+  if (w <= 0)
+    w = nbefore + nzero + nafter + (sign != S_NONE ? 2 : 1);
+  
   /* Work out how much padding is needed.  */
   nblanks = w - (nbefore + nzero + nafter + edigits + 1);
   if (sign != S_NONE)
     nblanks--;
 
+  if (dtp->u.p.g0_no_blanks)
+    {
+      w -= nblanks;
+      nblanks = 0;
+    }
+
+  /* Create the ouput buffer.  */
+  out = write_block (dtp, w);
+  if (out == NULL)
+    return;
+
   /* Check the value fits in the specified field width.  */
   if (nblanks < 0 || edigits == -1)
     {
@@ -419,6 +425,7 @@ output_float (st_parameter_dt *dtp, cons
       digits += i;
       out += nbefore;
     }
+
   /* Output the decimal point.  */
   *(out++) = dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? '.' : ',';
 
@@ -461,12 +468,14 @@ output_float (st_parameter_dt *dtp, cons
 #endif
       memcpy (out, buffer, edigits);
     }
+
   if (dtp->u.p.no_leading_blank)
     {
       out += edigits;
       memset( out , ' ' , nblanks );
       dtp->u.p.no_leading_blank = 0;
     }
+
 #undef STR
 #undef STR1
 #undef MIN_FIELD_WIDTH
@@ -606,7 +615,7 @@ output_float_FMT_G_ ## x (st_parameter_d
   int save_scale_factor, nb = 0;\
 \
   save_scale_factor = dtp->u.p.scale_factor;\
-  newf = get_mem (sizeof (fnode));\
+  newf = (fnode *) get_mem (sizeof (fnode));\
 \
   exp_d = calculate_exp_ ## x (d);\
   if ((m > 0.0 && m < 0.1 - 0.05 / exp_d) || (m >= exp_d - 0.5 ) ||\
@@ -680,7 +689,7 @@ output_float_FMT_G_ ## x (st_parameter_d
 \
   free_mem(newf);\
 \
-  if (nb > 0)\
+  if (nb > 0 && !dtp->u.p.g0_no_blanks)\
     { \
       p = write_block (dtp, nb);\
       if (p == NULL)\