[Fortran] PR90374 Support d0.d, e0.d, es0.d, en0.d, g0.d
diff mbox series

Message ID 4da10faf-23d7-18be-0fb1-be55b3acac56@charter.net
State New
Headers show
Series
  • [Fortran] PR90374 Support d0.d, e0.d, es0.d, en0.d, g0.d
Related show

Commit Message

Jerry DeLisle Nov. 1, 2019, 10:48 p.m. UTC
Hi all,

The attached patch provides frontend and runtime modifications to allow the 
subject format specifiers. These are allowed as default behavior and under 
-std=f2018.

It does not implement the ew.de0 specifier. I decided to do that part 
separarately since it involves different places in the code.

I will to a Changlog for the testsuite changes. In summary:

modified: fmt_error_10.f to allow it to pass.
modified: fmt_error_7.f likewise.
modified: fmt_error_9.f likewise.
new file: fmt_zero_width.f90 to test the new features.

Regression tested on x86_64-pc-linux-gnu.

OK for trunk?

Jerry

2019-11-01  Jerry DeLisle  <jvdelisle@gcc.ngu.org>

	PR fortran/90374
	* io.c (check_format): Allow zero width for D, E, EN, and ES
	specifiers as default and when -std=F2018 is given. Retain
	existing errors when using the -fdec family of flags.


2019-11-01  Jerry DeLisle  <jvdelisle@gcc.ngu.org>

	PR fortran/90374
	io/format.c (parse_format_list): Relax format checking for
	zero width as default and when -std=f2018.
	io/format.h (format_token): Move definition to io.h.
	io/io.h (format_token): Add definition here to allow access to
	this definition at higher levels. Rename the declaration of
	write_real_g0 to write_real_w0 and add a new format_token
	argumanet so that higher level functions can pass to it the
	token so that handling of g0 vs the other zero width specifiers
	can be differentiated.
	io/transfer.c (formatted_transfer_scalar_write): Add checks for
	zero width and call write_real_w0 to handle it.
	io/write.c (write_real_g0): Remove.
	(write_real_w0): Add new, same as previous write_real_g0 except
	check format token to handle the g0 case.

Comments

Steve Kargl Nov. 3, 2019, 7:55 p.m. UTC | #1
On Fri, Nov 01, 2019 at 03:48:04PM -0700, Jerry DeLisle wrote:
> 
> The attached patch provides frontend and runtime modifications to allow the 
> subject format specifiers. These are allowed as default behavior and under 
> -std=f2018.
> 
> It does not implement the ew.de0 specifier. I decided to do that part 
> separarately since it involves different places in the code.
> 
> I will to a Changlog for the testsuite changes. In summary:
> 
> modified: fmt_error_10.f to allow it to pass.
> modified: fmt_error_7.f likewise.
> modified: fmt_error_9.f likewise.
> new file: fmt_zero_width.f90 to test the new features.
> 
> Regression tested on x86_64-pc-linux-gnu.
> 
> OK for trunk?
> 

OK.

--

Patch
diff mbox series

diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index b969a1a4738..57a3fdd5152 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -922,19 +922,38 @@  data_desc:
 
       if (u != FMT_POSINT)
 	{
+	  if (flag_dec)
+	    {
+	      if (flag_dec_format_defaults)
+		{
+		  /* Assume a default width based on the variable size.  */
+		  saved_token = u;
+		  break;
+		}
+	      else
+		{
+		  gfc_error ("Positive width required in format "
+			     "specifier %s at %L", token_to_string (t),
+			     &format_locus);
+		  saved_token = u;
+		  goto fail;
+		}
+	    }
+
+	  format_locus.nextc += format_string_pos;
+	  if (!gfc_notify_std (GFC_STD_F2018,
+			       "positive width required at %L",
+			       &format_locus))
+	    {
+	      saved_token = u;
+	      goto fail;
+	    }
 	  if (flag_dec_format_defaults)
 	    {
 	      /* Assume a default width based on the variable size.  */
 	      saved_token = u;
 	      break;
 	    }
-
-	  format_locus.nextc += format_string_pos;
-	  gfc_error ("Positive width required in format "
-			 "specifier %s at %L", token_to_string (t),
-			 &format_locus);
-	  saved_token = u;
-	  goto fail;
 	}
 
       u = format_lex ();
diff --git a/gcc/testsuite/gfortran.dg/fmt_error_10.f b/gcc/testsuite/gfortran.dg/fmt_error_10.f
index 7ea6aec1220..6e1a5f60bea 100644
--- a/gcc/testsuite/gfortran.dg/fmt_error_10.f
+++ b/gcc/testsuite/gfortran.dg/fmt_error_10.f
@@ -18,9 +18,9 @@ 
 
       str = '(1pd0.15)'
       write (line,str,iostat=istat, iomsg=msg) 1.0d0
-      if (istat.ne.5006 .or. msg(1:15).ne."Positive width ") STOP 5
+      if (line.ne."1.000000000000000") STOP 5
       read (*,str,iostat=istat, iomsg=msg) x
-      if (istat.ne.5006 .or. msg(1:15).ne."Positive width ") STOP 6
+      if (istat.ne.5006 .or. msg(1:10).ne."Zero width") STOP 6
       if (x.ne.555.25) STOP 7
       
       write (line,'(1pd24.15e11.3)') 1.0d0, 1.234
diff --git a/gcc/testsuite/gfortran.dg/fmt_error_7.f b/gcc/testsuite/gfortran.dg/fmt_error_7.f
index 9b5fba97e25..3937c8fe750 100644
--- a/gcc/testsuite/gfortran.dg/fmt_error_7.f
+++ b/gcc/testsuite/gfortran.dg/fmt_error_7.f
@@ -1,7 +1,9 @@ 
 ! { dg-do compile }
+! { dg-options "-std=f95" }
+
 ! PR37446 Diagnostic of edit descriptors, esp. EN
       character(40) :: fmt_string
       write(*, '(1P,2E12.4)') 1.0
-      write(*,'(EN)') 5.0 ! { dg-error "Positive width required" }
+      write(*,'(EN)') 5.0 ! { dg-error "positive width required" }
       write(*,'("abcdefg",EN6,"hjjklmnop")') 5.0 ! { dg-error "Period required" }
       end
diff --git a/gcc/testsuite/gfortran.dg/fmt_error_9.f b/gcc/testsuite/gfortran.dg/fmt_error_9.f
index 1d677509e37..40c73599ac8 100644
--- a/gcc/testsuite/gfortran.dg/fmt_error_9.f
+++ b/gcc/testsuite/gfortran.dg/fmt_error_9.f
@@ -16,7 +16,7 @@ 
       write (line,str,iostat=istat, iomsg=msg) 1.0d0
       if (istat.ne.0) STOP 3
       read (*,str,iostat=istat, iomsg=msg) x
-      if (istat.ne.5006 .or. msg(1:15).ne."Positive width ") STOP 4
+      if (istat.ne.5006 .or. msg(1:10).ne."Zero width") STOP 4
       if (x.ne.555.25) STOP 5
       
       write (line,'(1pd24.15e11.3)') 1.0d0, 1.234
diff --git a/gcc/testsuite/gfortran.dg/fmt_zero_width.f90 b/gcc/testsuite/gfortran.dg/fmt_zero_width.f90
new file mode 100644
index 00000000000..093c0a44c34
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/fmt_zero_width.f90
@@ -0,0 +1,36 @@ 
+! { dg-do run }
+! PR90374 "5.5 d0.d, e0.d, es0.d, en0.d, g0.d and ew.d edit descriptors
+program pr90374
+  real(4) :: rn
+  character(32) :: afmt, aresult
+  real(8) :: one = 1.0D0, zero = 0.0D0, nan, pinf, minf
+
+  nan = zero/zero
+  rn = 0.00314_4
+  afmt = "(D0.3)"
+  write (aresult,fmt=afmt) rn
+  if (aresult /= "0.314D-02") stop 12
+  afmt = "(E0.10)"
+  write (aresult,fmt=afmt) rn
+  if (aresult /= "0.3139999928E-02") stop 15
+  afmt = "(ES0.10)"
+  write (aresult,fmt=afmt) rn
+  if (aresult /= "3.1399999280E-03") stop 18
+  afmt = "(EN0.10)"
+  write (aresult,fmt=afmt) rn
+  if (aresult /= "3.1399999280E-03") stop 21
+  afmt = "(G0.10)"
+  write (aresult,fmt=afmt) rn
+  if (aresult /= "0.3139999928E-02") stop 24
+  write (aresult,fmt="(D0.3)") rn
+  if (aresult /= "0.314D-02") stop 26
+  write (aresult,fmt="(E0.10)") rn
+  if (aresult /= "0.3139999928E-02") stop 28
+  write (aresult,fmt="(ES0.10)") rn
+  if (aresult /= "3.1399999280E-03") stop 30
+  write (aresult,fmt="(EN0.10)") rn
+  if (aresult /= "3.1399999280E-03") stop 32
+  write (aresult,fmt="(G0.10)") rn
+  if (aresult /= "0.3139999928E-02") stop 34
+
+end
diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c
index e798d9bda87..b33620815d5 100644
--- a/libgfortran/io/format.c
+++ b/libgfortran/io/format.c
@@ -925,7 +925,7 @@  parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
       tail->repeat = repeat;
 
       u = format_lex (fmt);
-      if (t == FMT_G && u == FMT_ZERO)
+      if (u == FMT_ZERO)
 	{
 	  *seen_dd = true;
 	  if (notification_std (GFC_STD_F2008) == NOTIFICATION_ERROR
@@ -944,10 +944,8 @@  parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
 
 	  u = format_lex (fmt);
 	  if (u != FMT_POSINT)
-	    {
-	      fmt->error = posint_required;
-	      goto finished;
-	    }
+	    notify_std (&dtp->common, GFC_STD_F2003,
+			"Positive width required");
 	  tail->u.real.d = fmt->value;
 	  break;
 	}
diff --git a/libgfortran/io/format.h b/libgfortran/io/format.h
index 84169e95d91..a0899736aea 100644
--- a/libgfortran/io/format.h
+++ b/libgfortran/io/format.h
@@ -27,22 +27,6 @@  see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 
 #include "io.h"
 
-
-/* Format tokens.  Only about half of these can be stored in the
-   format nodes.  */
-
-typedef enum
-{
-  FMT_NONE = 0, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD,
-  FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_T, FMT_TR, FMT_TL,
-  FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING,
-  FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F,
-  FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC,
-  FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT
-}
-format_token;
-
-
 /* Format nodes.  A format string is converted into a tree of these
    structures, which is traversed as part of a data transfer statement.  */
 
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index bcd6dde9a5b..5b89d47e613 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -132,6 +132,20 @@  typedef struct format_hash_entry
 }
 format_hash_entry;
 
+/* Format tokens.  Only about half of these can be stored in the
+   format nodes.  */
+
+typedef enum
+{
+  FMT_NONE = 0, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD,
+  FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_T, FMT_TR, FMT_TL,
+  FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING,
+  FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F,
+  FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC,
+  FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT
+}
+format_token;
+
 /* Representation of a namelist object in libgfortran
 
    Namelist Records
@@ -928,8 +942,8 @@  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_real_w0 (st_parameter_dt *, const char *, int, format_token, int);
+internal_proto(write_real_w0);
 
 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 4c5e210ce5a..6382d0dad09 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -2008,7 +2008,10 @@  formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
 	    goto need_data;
 	  if (require_type (dtp, BT_REAL, type, f))
 	    return;
-	  write_d (dtp, f, p, kind);
+	  if (f->u.real.w == 0)
+	    write_real_w0 (dtp, p, kind, FMT_D, f->u.real.d);
+	  else
+	    write_d (dtp, f, p, kind);
 	  break;
 
 	case FMT_DT:
@@ -2071,7 +2074,10 @@  formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
 	    goto need_data;
 	  if (require_type (dtp, BT_REAL, type, f))
 	    return;
-	  write_e (dtp, f, p, kind);
+	  if (f->u.real.w == 0)
+	    write_real_w0 (dtp, p, kind, FMT_E, f->u.real.d);
+	  else
+	    write_e (dtp, f, p, kind);
 	  break;
 
 	case FMT_EN:
@@ -2079,7 +2085,10 @@  formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
 	    goto need_data;
 	  if (require_type (dtp, BT_REAL, type, f))
 	    return;
-	  write_en (dtp, f, p, kind);
+	  if (f->u.real.w == 0)
+	    write_real_w0 (dtp, p, kind, FMT_EN, f->u.real.d);
+	  else
+	    write_en (dtp, f, p, kind);
 	  break;
 
 	case FMT_ES:
@@ -2087,7 +2096,10 @@  formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
 	    goto need_data;
 	  if (require_type (dtp, BT_REAL, type, f))
 	    return;
-	  write_es (dtp, f, p, kind);
+	  if (f->u.real.w == 0)
+	    write_real_w0 (dtp, p, kind, FMT_ES, f->u.real.d);
+	  else
+	    write_es (dtp, f, p, kind);
 	  break;
 
 	case FMT_F:
@@ -2117,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_g0 (dtp, p, kind, f->u.real.d);
+		  write_real_w0 (dtp, p, kind, FMT_G, 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 eacd1f79715..5ebe83b0dbd 100644
--- a/libgfortran/io/write.c
+++ b/libgfortran/io/write.c
@@ -1720,25 +1720,32 @@  write_real (st_parameter_dt *dtp, const char *source, int kind)
    compensate for the extra digit.  */
 
 void
-write_real_g0 (st_parameter_dt *dtp, const char *source, int kind, int d)
+write_real_w0 (st_parameter_dt *dtp, const char *source, int kind,
+	       format_token fmt, int d)
 {
   fnode f;
   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;
+  int comp_d = 0;
   set_fnode_default (dtp, &f, kind);
 
   if (d > 0)
     f.u.real.d = d;
+  f.format = fmt;
+
+  /* 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 (dtp->u.p.scale_factor > 0 && d == 0)
+	comp_d = 1;
+      else
+	comp_d = 0;
+    }
 
-  /* Compensate for extra digits when using scale factor, d is not
-     specified, and the magnitude is such that E editing is used.  */
-  if (dtp->u.p.scale_factor > 0 && d == 0)
-    comp_d = 1;
-  else
-    comp_d = 0;
   dtp->u.p.g0_no_blanks = 1;
 
   /* Precision for snprintf call.  */
@@ -1750,7 +1757,7 @@  write_real_g0 (st_parameter_dt *dtp, const char *source, int kind, int d)
   buffer = select_buffer (dtp, &f, precision, buf_stack, &buf_size, kind);
 
   get_float_string (dtp, &f, source , kind, comp_d, buffer,
-                           precision, buf_size, result, &flt_str_len);
+		    precision, buf_size, result, &flt_str_len);
   write_float_string (dtp, result, flt_str_len);
 
   dtp->u.p.g0_no_blanks = 0;