PR 90374 d0.d, e0.d, es0.d, en0.d, g0.d and ew.d edit descriptors.

        PR libfortran/90274
        * io/format.c (parse_format_list): Implement the E0 exponent
        width to provide smallest possible width for exponent fields.
        Refactor code for correct parsing and better readability of the
        code.
        * io/io.h (write_real_w0): Change interface to pass in pointer
        to fnode.
        * io/transfer.c: Update all calls to write_real_w0 to use the
        new interface.
        * io/write.c ((write_real_w0): Use the new interface with fnode
        to access both the decimal precision and exponent widths used in
        build_float_string.
        * io/write_float.def (build_float_string): Use the passed in
        exponent width to calculate the used width in the case of E0.

From-SVN: r279828

6 files changed, 142 insertions, 97 deletions

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 35cd60e7686..840642cd660 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,20 @@
+2020-01-01  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR libfortran/90374
+	* io/format.c (parse_format_list): Implement the E0 exponent
+	width to provide smallest possible width for exponent fields.
+	Refactor code for correct parsing and better readability of the
+	code.
+	* io/io.h (write_real_w0): Change interface to pass in pointer
+	to fnode.
+	* io/transfer.c: Update all calls to write_real_w0 to use the
+	new interface.
+	* io/write.c ((write_real_w0): Use the new interface with fnode
+	to access both the decimal precision and exponent widths used in
+	build_float_string.
+	* io/write_float.def (build_float_string): Use the passed in
+	exponent width to calculate the used width in the case of E0.
+
 2020-01-01  Jakub Jelinek  <jakub@redhat.com>
 
 	Update copyright years.
diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c
index 70e88aaab49..b42a5593e38 100644
--- a/libgfortran/io/format.c
+++ b/libgfortran/io/format.c
@@ -38,7 +38,7 @@ static const fnode colon_node = { FMT_COLON, 0, NULL, NULL, {{ 0, 0, 0 }}, 0,
 
 /* Error messages. */
 
-static const char posint_required[] = "Positive width required in format",
+static const char posint_required[] = "Positive integer required in format",
   period_required[] = "Period required in format",
   nonneg_required[] = "Nonnegative width required in format",
   unexpected_element[] = "Unexpected element '%c' in format\n",
@@ -925,9 +925,10 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
       tail->repeat = repeat;
 
       u = format_lex (fmt);
+      
+      /* Processing for zero width formats.  */
       if (u == FMT_ZERO)
 	{
-	  *seen_dd = true;
 	  if (notification_std (GFC_STD_F2008) == NOTIFICATION_ERROR
 	      || dtp->u.p.mode == READING)
 	    {
@@ -935,6 +936,8 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
 	      goto finished;
 	    }
 	  tail->u.real.w = 0;
+
+	  /* Look for the dot seperator.  */
 	  u = format_lex (fmt);
 	  if (u != FMT_PERIOD)
 	    {
@@ -942,108 +945,119 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
 	      break;
 	    }
 
+	  /* Look for the precision.  */
 	  u = format_lex (fmt);
-	  if (u != FMT_POSINT)
-	    notify_std (&dtp->common, GFC_STD_F2003,
-			"Positive width required");
+	  if (u != FMT_ZERO && u != FMT_POSINT)
+	    {
+	      fmt->error = nonneg_required;
+	      goto finished;
+	    }
 	  tail->u.real.d = fmt->value;
-	  break;
-	}
-      if (t == FMT_F && dtp->u.p.mode == WRITING)
-	{
-	  *seen_dd = true;
-	  if (u != FMT_POSINT && u != FMT_ZERO)
+	  
+	  /* Look for optional exponent */
+	  u = format_lex (fmt);
+	  if (u != FMT_E)
+	    fmt->saved_token = u;
+	  else
 	    {
-	      if (dtp->common.flags & IOPARM_DT_DEC_EXT)
+	      u = format_lex (fmt);
+	      if (u != FMT_POSINT)
 		{
-		  tail->u.real.w = DEFAULT_WIDTH;
-		  tail->u.real.d = 0;
-		  tail->u.real.e = -1;
-		  fmt->saved_token = u;
-		  break;
+		  if (u == FMT_ZERO)
+		    {
+		      notify_std (&dtp->common, GFC_STD_F2018,
+				  "Positive exponent width required");
+		    }
+		  else
+		    {
+		      fmt->error = "Positive exponent width required in "
+				   "format string at %L";
+		      goto finished;
+		    }
 		}
-	      fmt->error = nonneg_required;
-	      goto finished;
+	      tail->u.real.e = fmt->value;
 	    }
+	  break;
 	}
-      else if (u == FMT_ZERO)
-	{
-	  fmt->error = posint_required;
-	  goto finished;
-	}
-      else if (u != FMT_POSINT)
+
+      /* Processing for positive width formats.  */
+      if (u == FMT_POSINT)
 	{
-	  if (dtp->common.flags & IOPARM_DT_DEC_EXT)
+	  tail->u.real.w = fmt->value;
+
+	  /* Look for the dot separator. Because of legacy behaviors
+	     we do some look ahead for missing things.  */
+	  t2 = t;
+	  t = format_lex (fmt);
+	  if (t != FMT_PERIOD)
 	    {
-	      tail->u.real.w = DEFAULT_WIDTH;
+	      /* We treat a missing decimal descriptor as 0.  Note: This is only
+		 allowed if -std=legacy, otherwise an error occurs.  */
+	      if (compile_options.warn_std != 0)
+		{
+		  fmt->error = period_required;
+		  goto finished;
+		}
+	      fmt->saved_token = t;
 	      tail->u.real.d = 0;
 	      tail->u.real.e = -1;
-	      fmt->saved_token = u;
 	      break;
 	    }
-	  fmt->error = posint_required;
-	  goto finished;
-	}
 
-      tail->u.real.w = fmt->value;
-      t2 = t;
-      t = format_lex (fmt);
-      if (t != FMT_PERIOD)
-	{
-	  /* We treat a missing decimal descriptor as 0.  Note: This is only
-	     allowed if -std=legacy, otherwise an error occurs.  */
-	  if (compile_options.warn_std != 0)
+	  /* If we made it here, we should have the dot so look for the
+	     precision.  */
+	  t = format_lex (fmt);
+	  if (t != FMT_ZERO && t != FMT_POSINT)
 	    {
-	      fmt->error = period_required;
+	      fmt->error = nonneg_required;
 	      goto finished;
 	    }
-	  fmt->saved_token = t;
-	  tail->u.real.d = 0;
+	  tail->u.real.d = fmt->value;
 	  tail->u.real.e = -1;
-	  break;
-	}
-
-      t = format_lex (fmt);
-      if (t != FMT_ZERO && t != FMT_POSINT)
-	{
-	  fmt->error = nonneg_required;
-	  goto finished;
-	}
-
-      tail->u.real.d = fmt->value;
-      tail->u.real.e = -1;
 
-      if (t2 == FMT_D || t2 == FMT_F)
-	{
-	  *seen_dd = true;
-	  break;
-	}
+	  /* Done with D and F formats.  */
+	  if (t2 == FMT_D || t2 == FMT_F)
+	    {
+	      *seen_dd = true;
+	      break;
+	    }
 
-      /* Look for optional exponent */
-      t = format_lex (fmt);
-      if (t != FMT_E)
-	fmt->saved_token = t;
-      else
-	{
-	  t = format_lex (fmt);
-	  if (t != FMT_POSINT)
+	  /* Look for optional exponent */
+	  u = format_lex (fmt);
+	  if (u != FMT_E)
+	    fmt->saved_token = u;
+	  else
 	    {
-	      if (t == FMT_ZERO)
+	      u = format_lex (fmt);
+	      if (u != FMT_POSINT)
 		{
-		  notify_std (&dtp->common, GFC_STD_F2018,
-			      "Positive exponent width required");
-		}
-	      else
-		{
-		  fmt->error = "Positive exponent width required in "
-			       "format string at %L";
-		  goto finished;
+		  if (u == FMT_ZERO)
+		    {
+		      notify_std (&dtp->common, GFC_STD_F2018,
+				  "Positive exponent width required");
+		    }
+		  else
+		    {
+		      fmt->error = "Positive exponent width required in "
+				   "format string at %L";
+		      goto finished;
+		    }
 		}
+	      tail->u.real.e = fmt->value;
 	    }
-	  tail->u.real.e = fmt->value;
+	  break;
 	}
 
+      /* Old DEC codes may not have width or precision specified.  */
+      if (dtp->u.p.mode == WRITING && (dtp->common.flags & IOPARM_DT_DEC_EXT))
+	{
+	  tail->u.real.w = DEFAULT_WIDTH;
+	  tail->u.real.d = 0;
+	  tail->u.real.e = -1;
+	  fmt->saved_token = u;
+	}
       break;
+
     case FMT_DT:
       *seen_dd = true;
       get_fnode (fmt, &head, &tail, t);
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index 7296cbe4a83..ab4a103787c 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -942,7 +942,7 @@ internal_proto(write_o);
 extern void write_real (st_parameter_dt *, const char *, int);
 internal_proto(write_real);
 
-extern void write_real_w0 (st_parameter_dt *, const char *, int, format_token, int);
+extern void write_real_w0 (st_parameter_dt *, const char *, int, const fnode*);
 internal_proto(write_real_w0);
 
 extern void write_x (st_parameter_dt *, int, int);
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 5e07a5b4957..b8db47dbff9 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -2009,7 +2009,7 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
 	  if (require_type (dtp, BT_REAL, type, f))
 	    return;
 	  if (f->u.real.w == 0)
-	    write_real_w0 (dtp, p, kind, FMT_D, f->u.real.d);
+	    write_real_w0 (dtp, p, kind, f);
 	  else
 	    write_d (dtp, f, p, kind);
 	  break;
@@ -2075,7 +2075,7 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
 	  if (require_type (dtp, BT_REAL, type, f))
 	    return;
 	  if (f->u.real.w == 0)
-	    write_real_w0 (dtp, p, kind, FMT_E, f->u.real.d);
+	    write_real_w0 (dtp, p, kind, f);
 	  else
 	    write_e (dtp, f, p, kind);
 	  break;
@@ -2086,7 +2086,7 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
 	  if (require_type (dtp, BT_REAL, type, f))
 	    return;
 	  if (f->u.real.w == 0)
-	    write_real_w0 (dtp, p, kind, FMT_EN, f->u.real.d);
+	    write_real_w0 (dtp, p, kind, f);
 	  else
 	    write_en (dtp, f, p, kind);
 	  break;
@@ -2097,7 +2097,7 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
 	  if (require_type (dtp, BT_REAL, type, f))
 	    return;
 	  if (f->u.real.w == 0)
-	    write_real_w0 (dtp, p, kind, FMT_ES, f->u.real.d);
+	    write_real_w0 (dtp, p, kind, f);
 	  else
 	    write_es (dtp, f, p, kind);
 	  break;
@@ -2129,7 +2129,7 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
 		break;
 	      case BT_REAL:
 		if (f->u.real.w == 0)
-		  write_real_w0 (dtp, p, kind, FMT_G, f->u.real.d);
+		  write_real_w0 (dtp, p, kind, f);
 		else
 		  write_d (dtp, f, p, kind);
 		break;
diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c
index 1387d5fb703..9f02683a25c 100644
--- a/libgfortran/io/write.c
+++ b/libgfortran/io/write.c
@@ -1721,42 +1721,46 @@ write_real (st_parameter_dt *dtp, const char *source, int kind)
 
 void
 write_real_w0 (st_parameter_dt *dtp, const char *source, int kind,
-	       format_token fmt, int d)
+	       const fnode* f)
 {
-  fnode f;
+  fnode ff;
   char buf_stack[BUF_STACK_SZ];
   char str_buf[BUF_STACK_SZ];
   char *buffer, *result;
   size_t buf_size, res_len, flt_str_len;
   int comp_d = 0;
-  set_fnode_default (dtp, &f, kind);
 
-  if (d > 0)
-    f.u.real.d = d;
-  f.format = fmt;
+  set_fnode_default (dtp, &ff, kind);
+
+  if (f->u.real.d > 0)
+    ff.u.real.d = f->u.real.d;
+  ff.format = f->format;
 
   /* For FMT_G, Compensate for extra digits when using scale factor, d
      is not specified, and the magnitude is such that E editing
      is used.  */
-  if (fmt == FMT_G)
+  if (f->format == FMT_G)
     {
-      if (dtp->u.p.scale_factor > 0 && d == 0)
+      if (dtp->u.p.scale_factor > 0 && f->u.real.d == 0)
 	comp_d = 1;
       else
 	comp_d = 0;
     }
 
+  if (f->u.real.e >= 0)
+    ff.u.real.e = f->u.real.e;
+
   dtp->u.p.g0_no_blanks = 1;
 
   /* Precision for snprintf call.  */
-  int precision = get_precision (dtp, &f, source, kind);
+  int precision = get_precision (dtp, &ff, source, kind);
 
   /* String buffer to hold final result.  */
-  result = select_string (dtp, &f, str_buf, &res_len, kind);
+  result = select_string (dtp, &ff, str_buf, &res_len, kind);
 
-  buffer = select_buffer (dtp, &f, precision, buf_stack, &buf_size, kind);
+  buffer = select_buffer (dtp, &ff, precision, buf_stack, &buf_size, kind);
 
-  get_float_string (dtp, &f, source , kind, comp_d, buffer,
+  get_float_string (dtp, &ff, source , kind, comp_d, buffer,
 		    precision, buf_size, result, &flt_str_len);
   write_float_string (dtp, result, flt_str_len);
 
diff --git a/libgfortran/io/write_float.def b/libgfortran/io/write_float.def
index 912ad645887..75c7942c4c5 100644
--- a/libgfortran/io/write_float.def
+++ b/libgfortran/io/write_float.def
@@ -266,7 +266,7 @@ build_float_string (st_parameter_dt *dtp, const fnode *f, char *buffer,
     case FMT_E:
     case FMT_D:
       i = dtp->u.p.scale_factor;
-      if (d <= 0 && p == 0)
+      if (d < 0 && p == 0)
 	{
 	  generate_error (&dtp->common, LIBERROR_FORMAT, "Precision not "
 			  "greater than zero in format specifier 'E' or 'D'");
@@ -482,7 +482,7 @@ build_float_string (st_parameter_dt *dtp, const fnode *f, char *buffer,
       for (i = abs (e); i >= 10; i /= 10)
 	edigits++;
 
-      if (f->u.real.e <= 0)
+      if (f->u.real.e < 0)
 	{
 	  /* Width not specified.  Must be no more than 3 digits.  */
 	  if (e > 999 || e < -999)
@@ -494,6 +494,16 @@ build_float_string (st_parameter_dt *dtp, const fnode *f, char *buffer,
 		expchar = ' ';
 	    }
 	}
+      else if (f->u.real.e == 0)
+	{
+	  /* Zero width specified, no leading zeros in exponent  */
+	  if (e > 99 || e < -99)
+	    edigits = 5;
+	  else if (e > 9 || e < -9)
+	    edigits = 4;
+	  else
+	    edigits = 3;
+	}
       else
 	{
 	  /* Exponent width specified, check it is wide enough.  */