fortran/89100: Default widths with -fdec-format-defaults

gcc/fortran ChangeLog:

2019-05-22  Jeff Law  <law@redhat.com>
            Mark Eggleston  <mark.eggleston@codethink.com>

        PR fortran/89100
        * gfortran.texi: Add Default widths for F, G and I format
        descriptors to Extensions section.
        * invoke.texi: Add -fdec-format-defaults
        * io.c (check_format): Use default widths for i, f and g when
        flag_dec_format_defaults is enabled.
        * lang.opt: Add new option.
        * options.c (set_dec_flags): Add SET_BITFLAG for
        flag_dec_format_defaults.


gcc/testsuite ChangeLog:

2019-05-22  Mark Eggleston  <mark.eggleston@codethink.com>

        PR fortran/89100
        * gfortran.dg/fmt_f_default_field_width_1.f90: New test.
        * gfortran.dg/fmt_f_default_field_width_2.f90: New test.
        * gfortran.dg/fmt_f_default_field_width_3.f90: New test.
        * gfortran.dg/fmt_g_default_field_width_1.f90: New test.
        * gfortran.dg/fmt_g_default_field_width_2.f90: New test.
        * gfortran.dg/fmt_g_default_field_width_3.f90: New test.
        * gfortran.dg/fmt_i_default_field_width_1.f90: New test.
        * gfortran.dg/fmt_i_default_field_width_2.f90: New test.
        * gfortran.dg/fmt_i_default_field_width_3.f90: New test.


libgfortran ChangeLog:

2019-05-22  Jeff Law  <law@redhat.com>

        PR fortran/89100
        * io/format.c (parse_format_list): set default width when the
        IOPARM_DT_DEC_EXT flag is set for i, f and g.
        * io/io.h: add default_width_for_integer, default_width_for_float
        and default_precision_for_float.
        * io/write.c (write_boz): extra parameter giving length of data
        corresponding to the type's kind.
        (write_b): pass data length as extra parameter in calls to
        write_boz.
        (write_o): pass data length as extra parameter in calls to
        write_boz.
        (write_z): pass data length as extra parameter in calls to
        write_boz.
        (size_from_kind): also set size is default width is set.
        * io/write_float.def (build_float_string): new paramter inserted
        before result parameter. If default width use values passed
        instead of the values in fnode.
        (FORMAT_FLOAT): macro modified to check for default width and
        calls to build_float_string to pass in default width.
        (get_float_string): set width and precision to defaults when
        needed.

From-SVN: r271511

5 files changed, 136 insertions, 14 deletions

diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c
index 6887647..e798d9b 100644
--- a/libgfortran/io/format.c
+++ b/libgfortran/io/format.c
@@ -956,12 +956,33 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
 	  *seen_dd = true;
 	  if (u != FMT_POSINT && u != FMT_ZERO)
 	    {
+	      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;
+		}
 	      fmt->error = nonneg_required;
 	      goto finished;
 	    }
 	}
+      else if (u == FMT_ZERO)
+	{
+	  fmt->error = posint_required;
+	  goto finished;
+	}
       else if (u != FMT_POSINT)
 	{
+	  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;
+	    }
 	  fmt->error = posint_required;
 	  goto finished;
 	}
@@ -1100,6 +1121,13 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
 	{
 	  if (t != FMT_POSINT)
 	    {
+	      if (dtp->common.flags & IOPARM_DT_DEC_EXT)
+		{
+		  tail->u.integer.w = DEFAULT_WIDTH;
+		  tail->u.integer.m = -1;
+		  fmt->saved_token = t;
+		  break;
+		}
 	      fmt->error = posint_required;
 	      goto finished;
 	    }
@@ -1108,6 +1136,13 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
 	{
 	  if (t != FMT_ZERO && t != FMT_POSINT)
 	    {
+	      if (dtp->common.flags & IOPARM_DT_DEC_EXT)
+		{
+		  tail->u.integer.w = DEFAULT_WIDTH;
+		  tail->u.integer.m = -1;
+		  fmt->saved_token = t;
+		  break;
+		}
 	      fmt->error = nonneg_required;
 	      goto finished;
 	    }
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index 5caaea2..f5e6379 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -1011,6 +1011,56 @@ memset4 (gfc_char4_t *p, gfc_char4_t c, int k)
     *p++ = c;
 }
 
+/* Used in width fields to indicate that the default should be used */
+#define DEFAULT_WIDTH -1
+
+/* Defaults for certain format field descriptors. These are decided based on
+ * the type of the value being formatted.
+ *
+ * The behaviour here is modelled on the Oracle Fortran compiler. At the time
+ * of writing, the details were available at this URL:
+ *
+ *   https://docs.oracle.com/cd/E19957-01/805-4939/6j4m0vnc3/index.html#z4000743746d
+ */
+
+static inline int
+default_width_for_integer (int kind)
+{
+  switch (kind)
+    {
+    case 1:
+    case 2:  return  7;
+    case 4:  return 12;
+    case 8:  return 23;
+    case 16: return 44;
+    default: return  0;
+    }
+}
+
+static inline int
+default_width_for_float (int kind)
+{
+  switch (kind)
+    {
+    case 4:  return 15;
+    case 8:  return 25;
+    case 16: return 42;
+    default: return  0;
+    }
+}
+
+static inline int
+default_precision_for_float (int kind)
+{
+  switch (kind)
+    {
+    case 4:  return 7;
+    case 8:  return 16;
+    case 16: return 33;
+    default: return 0;
+    }
+}
+
 #endif
 
 extern void
diff --git a/libgfortran/io/read.c b/libgfortran/io/read.c
index 52ffb46..be9f6cb 100644
--- a/libgfortran/io/read.c
+++ b/libgfortran/io/read.c
@@ -635,6 +635,12 @@ read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 
   w = f->u.w;
 
+  /* This is a legacy extension, and the frontend will only allow such cases
+   * through when -fdec-format-defaults is passed.
+   */
+  if (w == DEFAULT_WIDTH)
+    w = default_width_for_integer (length);
+
   p = read_block_form (dtp, &w);
 
   if (p == NULL)
diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c
index c8811e2..4ef3556 100644
--- a/libgfortran/io/write.c
+++ b/libgfortran/io/write.c
@@ -685,9 +685,8 @@ write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
   p[wlen - 1] = (n) ? 'T' : 'F';
 }
 
-
 static void
-write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n)
+write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n, int len)
 {
   int w, m, digits, nzero, nblank;
   char *p;
@@ -720,6 +719,9 @@ write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n)
   /* Select a width if none was specified.  The idea here is to always
      print something.  */
 
+  if (w == DEFAULT_WIDTH)
+    w = default_width_for_integer (len);
+
   if (w == 0)
     w = ((digits < m) ? m : digits);
 
@@ -846,6 +848,8 @@ write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
 
   /* Select a width if none was specified.  The idea here is to always
      print something.  */
+  if (w == DEFAULT_WIDTH)
+    w = default_width_for_integer (len);
 
   if (w == 0)
     w = ((digits < m) ? m : digits) + nsign;
@@ -1206,13 +1210,13 @@ write_b (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
   if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
     {
       p = btoa_big (source, itoa_buf, len, &n);
-      write_boz (dtp, f, p, n);
+      write_boz (dtp, f, p, n, len);
     }
   else
     {
       n = extract_uint (source, len);
       p = btoa (n, itoa_buf, sizeof (itoa_buf));
-      write_boz (dtp, f, p, n);
+      write_boz (dtp, f, p, n, len);
     }
 }
 
@@ -1227,13 +1231,13 @@ write_o (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
   if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
     {
       p = otoa_big (source, itoa_buf, len, &n);
-      write_boz (dtp, f, p, n);
+      write_boz (dtp, f, p, n, len);
     }
   else
     {
       n = extract_uint (source, len);
       p = otoa (n, itoa_buf, sizeof (itoa_buf));
-      write_boz (dtp, f, p, n);
+      write_boz (dtp, f, p, n, len);
     }
 }
 
@@ -1247,13 +1251,13 @@ write_z (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
   if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
     {
       p = ztoa_big (source, itoa_buf, len, &n);
-      write_boz (dtp, f, p, n);
+      write_boz (dtp, f, p, n, len);
     }
   else
     {
       n = extract_uint (source, len);
       p = gfc_xtoa (n, itoa_buf, sizeof (itoa_buf));
-      write_boz (dtp, f, p, n);
+      write_boz (dtp, f, p, n, len);
     }
 }
 
@@ -1491,7 +1495,7 @@ size_from_kind (st_parameter_dt *dtp, const fnode *f, int kind)
 {
   int size;
 
-  if (f->format == FMT_F && f->u.real.w == 0)
+  if ((f->format == FMT_F && f->u.real.w == 0) || f->u.real.w == DEFAULT_WIDTH)
     {
       switch (kind)
       {
diff --git a/libgfortran/io/write_float.def b/libgfortran/io/write_float.def
index c63db4e..daa1667 100644
--- a/libgfortran/io/write_float.def
+++ b/libgfortran/io/write_float.def
@@ -113,7 +113,8 @@ determine_precision (st_parameter_dt * dtp, const fnode * f, int len)
 static void
 build_float_string (st_parameter_dt *dtp, const fnode *f, char *buffer,
 		    size_t size, int nprinted, int precision, int sign_bit,
-		    bool zero_flag, int npad, char *result, size_t *len)
+		    bool zero_flag, int npad, int default_width, char *result,
+		    size_t *len)
 {
   char *put;
   char *digits;
@@ -132,8 +133,17 @@ build_float_string (st_parameter_dt *dtp, const fnode *f, char *buffer,
   sign_t sign;
 
   ft = f->format;
-  w = f->u.real.w;
-  d = f->u.real.d;
+  if (f->u.real.w == DEFAULT_WIDTH)
+    /* This codepath can only be reached with -fdec-format-defaults. */
+    {
+      w = default_width;
+      d = precision;
+    }
+  else
+    {
+      w = f->u.real.w;
+      d = f->u.real.d;
+    }
   p = dtp->u.p.scale_factor;
   *len = 0;
 
@@ -960,6 +970,11 @@ determine_en_precision (st_parameter_dt *dtp, const fnode *f,
       int save_scale_factor;\
       volatile GFC_REAL_ ## x temp;\
       save_scale_factor = dtp->u.p.scale_factor;\
+      if (w == DEFAULT_WIDTH)\
+	{\
+	  w = default_width;\
+	  d = precision;\
+	}\
       switch (dtp->u.p.current_unit->round_status)\
 	{\
 	  case ROUND_ZERO:\
@@ -1035,7 +1050,8 @@ determine_en_precision (st_parameter_dt *dtp, const fnode *f,
 	  nprinted = FDTOA(y,precision,m);\
 	}\
       build_float_string (dtp, &newf, buffer, size, nprinted, precision,\
-				   sign_bit, zero_flag, npad, result, res_len);\
+				   sign_bit, zero_flag, npad, default_width,\
+				   result, res_len);\
       dtp->u.p.scale_factor = save_scale_factor;\
     }\
   else\
@@ -1045,7 +1061,8 @@ determine_en_precision (st_parameter_dt *dtp, const fnode *f,
       else\
 	nprinted = DTOA(y,precision,m);\
       build_float_string (dtp, f, buffer, size, nprinted, precision,\
-				   sign_bit, zero_flag, npad, result, res_len);\
+				   sign_bit, zero_flag, npad, default_width,\
+				   result, res_len);\
     }\
 }\
 
@@ -1059,6 +1076,16 @@ get_float_string (st_parameter_dt *dtp, const fnode *f, const char *source,
 {
   int sign_bit, nprinted;
   bool zero_flag;
+  int default_width = 0;
+
+  if (f->u.real.w == DEFAULT_WIDTH)
+    /* This codepath can only be reached with -fdec-format-defaults. The default
+     * values are based on those used in the Oracle Fortran compiler.
+     */
+    {
+      default_width = default_width_for_float (kind);
+      precision = default_precision_for_float (kind);
+    }
 
   switch (kind)
     {