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

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 9a25ecd5cee05da32ef6d3291d1c84f001851565..dff8dc8a78348d136735a38e466a4eb9c0559ae4 100644 (file)
--- 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 734b633de0667a4ec4c5aaac3412d7ebd16d50ab..cf299c161a4032a482973fe50191e4ab1c0bcc77 100644 (file)
--- 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 7f9f38f80c0194264a2965224f00f30ae3b67047..ea75bdbc405ff203aa01cdead0adaddb368a325e 100644 (file)
--- 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 ff7e651016eafb1dd3c81c4fa886f058f62e8095..36181f6fc0593ddc048d4ecdfaa5136b89d2f756 100644 (file)
--- 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 ea8ad94b8ca9f9d43029cd528d52859bcc80858e..6135d60fe5d40866efdd90613ff41d09dc98a4cd 100644 (file)
--- 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 ;