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

5 files changed, 80 insertions, 23 deletions

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 8670d46..1e65eb1 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,5 +1,19 @@
 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>
diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c
index 02ce291..667797f 100644
--- a/libgfortran/io/format.c
+++ b/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)
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index cb7147d..228372a 100644
--- a/libgfortran/io/io.h
+++ b/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);
 
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index fd63139..c810f4d 100644
--- a/libgfortran/io/transfer.c
+++ b/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;
diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c
index 65210bc..414a69e 100644
--- a/libgfortran/io/write.c
+++ b/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;
 }