re PR fortran/36420 (Fortran 2008: g0 edit descriptor)

2008-06-07  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libfortran/36420
	PR libfortran/36421
	PR libfortran/36422
	* io/io.h: Add prototype for write_real.
	* io/transfer.c (formatted_transfer_scalar): For FMT_G and width zero,
	use write_real.
	* io/format.c: Add zero width error message. (parse_format_list): Use
	error message for FMT_A if followed by FMT_ZERO. Use zero width error
	message	for FMT_G if mode is READ or if -std=f95 or f2003. (fmormat0):
	Fix typo in comment.
	* io/write.c (write_a): Set wlen to len if FMT_G and length is zero.
	(write_l): Add wlen variable and use it if FMT_G and width is zero.
	(write_decimal): If FMT_G, set m to -1 to flag processor dependent
	formatting. (write_real): Remove static declaration.

From-SVN: r136545

5 files changed, 55 insertions, 11 deletions

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 9a25ecd..dff8dc8 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,20 @@
+2008-06-07  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR libfortran/36420
+	PR libfortran/36421
+	PR libfortran/36422
+	* io/io.h: Add prototype for write_real.
+	* io/transfer.c (formatted_transfer_scalar): For FMT_G and width zero,
+	use write_real.
+	* io/format.c: Add zero width error message. (parse_format_list): Use
+	error message for FMT_A if followed by FMT_ZERO. Use zero width error
+	message	for FMT_G if mode is READ or if -std=f95 or f2003. (fmormat0):
+	Fix typo in comment.
+	* io/write.c(write_a): Set wlen to len if FMT_G	and length is zero.
+	(write_l): Add wlen variable and use it if FMT_G and width is zero.
+	(write_decimal): If FMT_G, set m to -1 to flag processor dependent
+	formatting. (write_real): Remove static declaration.
+
 2008-05-28  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
 	PR fortran/36319
diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c
index 734b633..cf299c1 100644
--- a/libgfortran/io/format.c
+++ b/libgfortran/io/format.c
@@ -71,8 +71,8 @@ static const char posint_required[] = "Positive width required in format",
   unexpected_end[] = "Unexpected end of format string",
   bad_string[] = "Unterminated character constant in format",
   bad_hollerith[] = "Hollerith constant extends past the end of the format",
-  reversion_error[] = "Exhausted data descriptors in format";
-
+  reversion_error[] = "Exhausted data descriptors in format",
+  zero_width[] = "Zero width in format descriptor";
 
 /* next_char()-- Return the next character in the format string.
  * Returns -1 when the string is done.  If the literal flag is set,
@@ -698,6 +698,12 @@ parse_format_list (st_parameter_dt *dtp)
 
     case FMT_A:
       t = format_lex (fmt);
+      if (t == FMT_ZERO)
+	{
+	  fmt->error = zero_width;
+	  goto finished;
+	}
+
       if (t != FMT_POSINT)
 	{
 	  fmt->saved_token = t;
@@ -719,6 +725,17 @@ parse_format_list (st_parameter_dt *dtp)
       tail->repeat = repeat;
 
       u = format_lex (fmt);
+      if (t == FMT_G && u == FMT_ZERO)
+	{
+	  if (notification_std (GFC_STD_F2008) == ERROR
+	      || dtp->u.p.mode == READING)
+	    {
+	      fmt->error = zero_width;
+	      goto finished;
+	    }
+	  tail->u.real.w = 0;
+	  break;
+	}
       if (t == FMT_F || dtp->u.p.mode == WRITING)
 	{
 	  if (u != FMT_POSINT && u != FMT_ZERO)
@@ -1079,7 +1096,7 @@ next_format0 (fnode * f)
 
 /* next_format()-- Return the next format node.  If the format list
  * ends up being exhausted, we do reversion.  Reversion is only
- * allowed if the we've seen a data descriptor since the
+ * allowed if we've seen a data descriptor since the
  * initialization or the last reversion.  We return NULL if there
  * are no more data descriptors to return (which is an error
  * condition). */
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index 7f9f38f..ea75bdb 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -931,6 +931,9 @@ internal_proto(write_l);
 extern void write_o (st_parameter_dt *, const fnode *, const char *, int);
 internal_proto(write_o);
 
+extern void write_real (st_parameter_dt *, const char *, int);
+internal_proto(write_real);
+
 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 ff7e651..36181f6f 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -1175,7 +1175,10 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
 		write_a (dtp, f, p, len);
 		break;
 	      case BT_REAL:
-		write_d (dtp, f, p, len);
+		if (f->u.real.w == 0)
+		  write_real (dtp, p, len);
+		else
+		  write_d (dtp, f, p, len);
 		break;
 	      default:
 	      bad_type:
diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c
index ea8ad94..6135d60 100644
--- a/libgfortran/io/write.c
+++ b/libgfortran/io/write.c
@@ -46,7 +46,9 @@ write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
   int wlen;
   char *p;
 
-  wlen = f->u.string.length < 0 ? len : f->u.string.length;
+  wlen = f->u.string.length < 0
+	 || (f->format == FMT_G && f->u.string.length == 0)
+	 ? len : f->u.string.length;
 
 #ifdef HAVE_CRLF
   /* If this is formatted STREAM IO convert any embedded line feed characters
@@ -235,15 +237,18 @@ void
 write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
 {
   char *p;
+  int wlen;
   GFC_INTEGER_LARGEST n;
 
-  p = write_block (dtp, f->u.w);
+  wlen = (f->format == FMT_G && f->u.w == 0) ? 1 : f->u.w;
+  
+  p = write_block (dtp, wlen);
   if (p == NULL)
     return;
 
-  memset (p, ' ', f->u.w - 1);
+  memset (p, ' ', wlen - 1);
   n = extract_int (source, len);
-  p[f->u.w - 1] = (n) ? 'T' : 'F';
+  p[wlen - 1] = (n) ? 'T' : 'F';
 }
 
 
@@ -340,12 +345,11 @@ write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
   char itoa_buf[GFC_BTOA_BUF_SIZE];
 
   w = f->u.integer.w;
-  m = f->u.integer.m;
+  m = f->format == FMT_G ? -1 : f->u.integer.m;
 
   n = extract_int (source, len);
 
   /* Special case:  */
-
   if (m == 0 && n == 0)
     {
       if (w == 0)
@@ -690,7 +694,7 @@ write_character (st_parameter_dt *dtp, const char *source, int length)
    This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
    1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16).  */
 
-static void
+void
 write_real (st_parameter_dt *dtp, const char *source, int length)
 {
   fnode f ;