re PR fortran/66709 (ICE on formatted io with parameter array specifier fmt)

2018-03-26  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/66709
	* io.c: Include constructor.h.
	(resolve_tag_format): For a constant character array, concatenate
	into a single character expression.

2018-03-26  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/66709
	* gfortran.dg/parameter_array_format.f90: New test.

From-SVN: r258850

4 files changed, 69 insertions, 1 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 4d93c55..0f07e0a 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2018-03-26  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/66709
+	* io.c: Include constructor.h.
+	(resolve_tag_format): For a constant character array, concatenate
+	into a single character expression.
+
 2018-03-25  Seth Johnson <johnsonsr@ornl.gov>
 	Dominique d'Humieres  <dominiq@gcc.gnu.org>
 
diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index d9f0fb1..10b7e82 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -25,6 +25,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "gfortran.h"
 #include "match.h"
 #include "parse.h"
+#include "constructor.h"
 
 gfc_st_label
 format_asterisk = {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL,
@@ -1606,7 +1607,7 @@ match_dec_ftag (const io_tag *tag, gfc_open *o)
 /* Resolution of the FORMAT tag, to be called from resolve_tag.  */
 
 static bool
-resolve_tag_format (const gfc_expr *e)
+resolve_tag_format (gfc_expr *e)
 {
   if (e->expr_type == EXPR_CONSTANT
       && (e->ts.type != BT_CHARACTER
@@ -1617,6 +1618,47 @@ resolve_tag_format (const gfc_expr *e)
       return false;
     }
 
+  /* Concatenate a constant character array into a single character
+     expression.  */
+
+  if ((e->expr_type == EXPR_ARRAY || e->rank > 0)
+      && e->ts.type == BT_CHARACTER
+      && gfc_is_constant_expr (e))
+    {
+      if (e->expr_type == EXPR_VARIABLE
+	  && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
+	gfc_simplify_expr (e, 1);
+
+      if (e->expr_type == EXPR_ARRAY)
+	{
+	  gfc_constructor *c;
+	  gfc_charlen_t n, len;
+	  gfc_expr *r;
+	  gfc_char_t *dest, *src;
+
+	  n = 0;
+	  c = gfc_constructor_first (e->value.constructor);
+	  len = c->expr->value.character.length;
+	  
+	  for ( ; c; c = gfc_constructor_next (c))
+	    n += len;
+
+	  r = gfc_get_character_expr (e->ts.kind, &e->where, NULL, n);
+	  dest = r->value.character.string;
+
+	  for (c = gfc_constructor_first (e->value.constructor);
+	     c; c = gfc_constructor_next (c))
+	    {
+	      src = c->expr->value.character.string;
+	      for (gfc_charlen_t i = 0 ; i < len; i++)
+		*dest++ = *src++;
+	    }
+
+	  gfc_replace_expr (e, r);
+	  return true;
+	}
+    }
+
   /* If e's rank is zero and e is not an element of an array, it should be
      of integer or character type.  The integer variable should be
      ASSIGNED.  */
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index cbd5efc..4b7fc36 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2018-03-26  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/66709
+	* gfortran.dg/parameter_array_format.f90: New test.
+
 2018-03-25  Thomas Koenig  <tkoenig@gcc.gnu.org>
 	Neil Carlson <neil.n.carlson@gmail.com>
 
diff --git a/gcc/testsuite/gfortran.dg/parameter_array_format.f90 b/gcc/testsuite/gfortran.dg/parameter_array_format.f90
new file mode 100644
index 0000000..d4ae9da
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/parameter_array_format.f90
@@ -0,0 +1,14 @@
+! { dg-do  run }
+! PR fortran/66709
+! Check that parameter formats are handled correctly.
+! Original test case by Gerhard Steinmetz.
+program main
+  character(len=2), dimension(9), parameter :: f = ['("','He','ll','lo',', ','wo','rl','d!','")']
+  character(len=2), dimension(9) :: g = ['("','He','ll','lo',', ','wo','rl','d!','")']
+  character (len=20) :: line
+  write (unit=line,fmt=f)
+  if (line /= "Helllo, world!") STOP 1
+  line = " "
+  write (unit=line,fmt=g)
+  if (line /= "Helllo, world!") STOP 2
+end program main