re PR fortran/37228 (F2008: Support g0.<d> edit descriptor)

2008-09-01  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/37228
	* io.c (check_format): Allow specifying precision with g0 format.

2008-09-01  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libfortran/37301
	PR libfortran/37228
	* io/io.h (write_real_g0): Declare new function to handle g0.d format.
	* io/transfer.c (formatted_transfer_scalar): Use new function.
	* io/format.c (parse_format_list): Enable g0.d.
	* io/write.c (write_a_char4): Delete unused var.
	(set_fnode_default): New function to set the default fnode w, d, and e
	factored from write_real. (write_real): Use new factored function.
	(write_real_g0): New function that sets d to that passed by g0.d format
	specifier and set format to ES.  Default values for w and e are used
	from the new function, set_fnode_default.

2008-09-01  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/37228
	* gfortran.dg/fmt_g0_4.f08: Revised test.

From-SVN: r139886

gcc/fortran/ChangeLog

+2008-09-01  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/37228
+	* io.c (check_format): Allow specifying precision with g0 format.
+
 2008-09-02  Daniel Kraft  <d@domob.eu>
 
 	* gfortran.h (struct gfc_namespace): New member `implicit_loc'.

gcc/fortran/io.c

@@ -483,7 +483,6 @@ check_format (bool is_input)
 				      " at %L");
   const char *unexpected_end	  = _("Unexpected end of format string");
   const char *zero_width	  = _("Zero width in format descriptor");
-  const char *g0_precision	= _("Specifying precision with G0 not allowed");
 
   const char *error;
   format_token t, u;
@@ -701,27 +700,25 @@ data_desc:
 	      error = zero_width;
 	      goto syntax;
 	    }
-
 	  if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: 'G0' in "
 			      "format at %C") == FAILURE)
 	    return FAILURE;
+	  u = format_lex ();
+	  if (u != FMT_PERIOD)
+	    {
+	      saved_token = u;
+	      break;
+	    }
 
 	  u = format_lex ();
-          if (u == FMT_PERIOD)
+	  if (u == FMT_ERROR)
+	    goto fail;
+	  if (u != FMT_POSINT)
 	    {
-	      error = g0_precision;
+	      error = posint_required;
 	      goto syntax;
 	    }
-	  saved_token = u;
-	  goto between_desc;
-	}
-
-      if (u == FMT_ERROR)
-	goto fail;
-      if (u != FMT_POSINT)
-	{
-	  error = posint_required;
-	  goto syntax;
+	  break;
 	}
 
       u = format_lex ();

gcc/testsuite/ChangeLog

+2008-09-01  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/37228
+	* gfortran.dg/fmt_g0_4.f08: Revised test.
+
 2008-09-02  Daniel Kraft  <d@domob.eu>
 
 	* gfortran.dg/abstract_type_1.f90: New test.

gcc/testsuite/gfortran.dg/fmt_g0_4.f08

 ! { dg-do compile }
 ! { dg-options "-std=f2008" }
 ! PR36725 Compile time error for g0 edit descriptor
-print '(g0.9)', 0.1 ! { dg-error "Specifying precision" }
+character(30) :: line
+write(line, '(g0.3)') 0.1
+if (line.ne."      1.000E-01") call abort
+write(line, '(g0.9)') 1.0
+if (line.ne."1.000000000E+00") call abort
+write(line, '(g0.5)') 29.23
+if (line.ne."    2.92300E+01") call abort
+write(line, '(g0.8)') -28.4
+if (line.ne."-2.83999996E+01") call abort
+write(line, '(g0.8)') -0.0001
+if (line.ne."-9.99999975E-05") call abort
 end

libgfortran/ChangeLog

 2008-09-01  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
+	PR libfortran/37301
+	PR libfortran/37228
+	* io/io.h (write_real_g0): Declare new function to handle g0.d format.
+	* io/transfer.c (formatted_transfer_scalar): Use new function.
+	* io/format.c (parse_format_list): Enable g0.d.
+	* io/write.c (write_a_char4): Delete unused var.
+	(set_fnode_default): New function to set the default fnode w, d, and e
+	factored from write_real. (write_real): Use new factored function.
+	(write_real_g0): New function that sets d to that passed by g0.d format
+	specifier and set format to ES.  Default values for w and e are used
+	from the new function, set_fnode_default.
+
+2008-09-01  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
 	* runtime/error.c: Fix cast for printf.
 
 2008-08-30  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

libgfortran/io/format.c

@@ -735,6 +735,20 @@ parse_format_list (st_parameter_dt *dtp)
 	      goto finished;
 	    }
 	  tail->u.real.w = 0;
+	  u = format_lex (fmt);
+	  if (u != FMT_PERIOD)
+	    {
+	      fmt->saved_token = u;
+	      break;
+	    }
+
+	  u = format_lex (fmt);
+	  if (u != FMT_POSINT)
+	    {
+	      fmt->error = posint_required;
+	      goto finished;
+	    }
+	  tail->u.real.d = fmt->value;
 	  break;
 	}
       if (t == FMT_F || dtp->u.p.mode == WRITING)

libgfortran/io/io.h

@@ -940,6 +940,9 @@ internal_proto(write_o);
 extern void write_real (st_parameter_dt *, const char *, int);
 internal_proto(write_real);
 
+extern void write_real_g0 (st_parameter_dt *, const char *, int, int);
+internal_proto(write_real_g0);
+
 extern void write_x (st_parameter_dt *, int, int);
 internal_proto(write_x);
 

libgfortran/io/transfer.c

@@ -1213,7 +1213,12 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
 		break;
 	      case BT_REAL:
 		if (f->u.real.w == 0)
-		  write_real (dtp, p, kind);
+		  {
+		    if (f->u.real.d == 0)
+		      write_real (dtp, p, kind);
+		    else
+		      write_real_g0 (dtp, p, kind, f->u.real.d);
+		  }
 		else
 		  write_d (dtp, f, p, kind);
 		break;

libgfortran/io/write.c

@@ -301,7 +301,7 @@ write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, int len
   if (is_stream_io (dtp))
     {
       const char crlf[] = "\r\n";
-      int i, j, bytes;
+      int i, bytes;
       gfc_char4_t *qq;
       bytes = 0;
 
@@ -952,43 +952,64 @@ write_character (st_parameter_dt *dtp, const char *source, int kind, int length)
 }
 
 
-/* Output a real number with default format.
-   This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
-   1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16).  */
+/* Set an fnode to default format.  */
 
-void
-write_real (st_parameter_dt *dtp, const char *source, int length)
+static void
+set_fnode_default (st_parameter_dt *dtp, fnode *f, int length)
 {
-  fnode f ;
-  int org_scale = dtp->u.p.scale_factor;
-  f.format = FMT_G;
-  dtp->u.p.scale_factor = 1;
+  f->format = FMT_G;
   switch (length)
     {
     case 4:
-      f.u.real.w = 15;
-      f.u.real.d = 8;
-      f.u.real.e = 2;
+      f->u.real.w = 15;
+      f->u.real.d = 8;
+      f->u.real.e = 2;
       break;
     case 8:
-      f.u.real.w = 25;
-      f.u.real.d = 17;
-      f.u.real.e = 3;
+      f->u.real.w = 25;
+      f->u.real.d = 17;
+      f->u.real.e = 3;
       break;
     case 10:
-      f.u.real.w = 29;
-      f.u.real.d = 20;
-      f.u.real.e = 4;
+      f->u.real.w = 29;
+      f->u.real.d = 20;
+      f->u.real.e = 4;
       break;
     case 16:
-      f.u.real.w = 44;
-      f.u.real.d = 35;
-      f.u.real.e = 4;
+      f->u.real.w = 44;
+      f->u.real.d = 35;
+      f->u.real.e = 4;
       break;
     default:
       internal_error (&dtp->common, "bad real kind");
       break;
     }
+}
+/* Output a real number with default format.
+   This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
+   1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16).  */
+
+void
+write_real (st_parameter_dt *dtp, const char *source, int length)
+{
+  fnode f ;
+  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);
+  dtp->u.p.scale_factor = org_scale;
+}
+
+
+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;
   write_float (dtp, &f, source , length);
   dtp->u.p.scale_factor = org_scale;
 }