[libfortran] Fortran 2018: Support d0.d, e0.d, es0.d, en0.d, g0.d and ew.d e0 edit descriptors

Message ID 23b329d1-0fd6-0dc4-427c-5cec1e46c680@charter.net
State New
Headers show
Series
  • [libfortran] Fortran 2018: Support d0.d, e0.d, es0.d, en0.d, g0.d and ew.d e0 edit descriptors
Related show

Commit Message

Jerry Dec. 30, 2019, 4:33 a.m.
Hi all,

The attached patch includes adjustments to the test case.

The Fortran Standard states the exponent width when using the e0 
exponent specfier results in the smallest possible exponent width.  This 
patch implements that case.

I got frustrated with trying to re-understand this code segment and even 
found some dead code in there.  As a result I did some major refactoring 
of the code and separated out the zero width, positive width, and no 
width DEC extensions into their own chunks.  I also added comments in 
hopes of helping others follow what this is doing and how it works.

This patch resolves some parsing issues currently on trunk where a 
format specifier following the e0.d.e specifier would result in an error 
(comments 12 and 20 of the PR). These are fixed.

The patch, as it is, passes regression testing but I must confess I may 
not have all the DEC stuff right yet and I propose we commit the patch 
here and address any DEC stuff as a follow up. (I will be looking at the 
DEC stuff in the next few days.)

OK for trunk?

Regards,

Jerry

Comments

Thomas Koenig Dec. 31, 2019, 10:17 a.m. | #1
Hi Jerry,

> OK for trunk?


Looks good. I also think that your approach that DEC stuff should
be checked later is good.  If it passes the testsuite, that's good
enough for a commit.

Thanks for the patch!

Regards

	Thomas
Jerry Jan. 2, 2020, 1 a.m. | #2
On 12/31/19 2:17 AM, Thomas Koenig wrote:
> Hi Jerry,

> 

>> OK for trunk?

> 

> Looks good. I also think that your approach that DEC stuff should

> be checked later is good.  If it passes the testsuite, that's good

> enough for a commit.

> 

> Thanks for the patch!

> 

> Regards

> 

>      Thomas

> 


Committed r279828

After looking at the pre-patch DEC code, the only thing I could see was 
to add a check that it only applies when the mode is WRITING, so I added 
that and did full regression testing again before commiting.

Thanks,

Jerry

Patch

diff --git a/gcc/testsuite/gfortran.dg/fmt_zero_width.f90 b/gcc/testsuite/gfortran.dg/fmt_zero_width.f90
index 640b6735c65..db2cca6e28a 100644
--- a/gcc/testsuite/gfortran.dg/fmt_zero_width.f90
+++ b/gcc/testsuite/gfortran.dg/fmt_zero_width.f90
@@ -9,32 +9,34 @@  program pr90374
   rn = 0.00314_4
   afmt = "(D0.3)"
   write (aresult,fmt=afmt) rn
-  if (aresult /= "0.314D-02") stop 12
+  if (aresult /= "0.314D-2") stop 12
   afmt = "(E0.10)"
   write (aresult,fmt=afmt) rn
-  if (aresult /= "0.3139999928E-02") stop 15
+  if (aresult /= "0.3139999928E-2") stop 15
   afmt = "(ES0.10)"
   write (aresult,fmt=afmt) rn
-  if (aresult /= "3.1399999280E-03") stop 18
+  if (aresult /= "3.1399999280E-3") stop 18
   afmt = "(EN0.10)"
   write (aresult,fmt=afmt) rn
-  if (aresult /= "3.1399999280E-03") stop 21
+  if (aresult /= "3.1399999280E-3") stop 21
   afmt = "(G0.10)"
   write (aresult,fmt=afmt) rn
-  if (aresult /= "0.3139999928E-02") stop 24
+  if (aresult /= "0.3139999928E-2") stop 24
   afmt = "(E0.10e0)"
   write (aresult,fmt=afmt) rn
-  if (aresult /= "0.3139999928E-02") stop 27
+  if (aresult /= "0.3139999928E-2") stop 27
   write (aresult,fmt="(D0.3)") rn
-  if (aresult /= "0.314D-02") stop 29
+  if (aresult /= "0.314D-2") stop 29
   write (aresult,fmt="(E0.10)") rn
-  if (aresult /= "0.3139999928E-02") stop 31
+  if (aresult /= "0.3139999928E-2") stop 31
   write (aresult,fmt="(ES0.10)") rn
-  if (aresult /= "3.1399999280E-03") stop 33
+  if (aresult /= "3.1399999280E-3") stop 33
   write (aresult,fmt="(EN0.10)") rn
-  if (aresult /= "3.1399999280E-03") stop 35
+  if (aresult /= "3.1399999280E-3") stop 35
   write (aresult,fmt="(G0.10)") rn
-  if (aresult /= "0.3139999928E-02") stop 37
+  if (aresult /= "0.3139999928E-2") stop 37
   write (aresult,fmt="(E0.10e0)") rn
-  if (aresult /= "0.3139999928E-02") stop 39
+  if (aresult /= "0.3139999928E-2") stop 39
+  write (aresult,fmt="(E0.10e3)") rn
+  if (aresult /= ".3139999928E-002") stop 41
 end
diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c
index 0b23721c055..1406e46693a 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,6 +925,8 @@  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;
@@ -935,6 +937,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 +946,120 @@  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)
+	  *seen_dd = true;
+	  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)
-		{
-		  notify_std (&dtp->common, GFC_STD_F2018,
-			      "Positive exponent width required");
-		}
-	      else
+	      u = format_lex (fmt);
+	      if (u != FMT_POSINT)
 		{
-		  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->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 5b89d47e613..33cd537c8a8 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 43b22bf5f8d..f63a77507fa 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 5ebe83b0dbd..0a5e5ed6f65 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 ce6aec83114..42ecf64ea68 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.  */