diff mbox series

[fortran] Fix character parameter arrays as formats

Message ID f3da85e4-5a69-e80a-b0d7-71bb83aa36b2@netcologne.de
State New
Headers show
Series [fortran] Fix character parameter arrays as formats | expand

Commit Message

Thomas Koenig March 25, 2018, 4:11 p.m. UTC
Hello world,

the attached pach fixes the PR by creating one single big string
from a parameter array.

OK for trunk?

Regards

	Thomas

2018-03-25  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  Thomas Koenig  <tkoenig@gcc.gnu.org>

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

Comments

Jerry DeLisle March 25, 2018, 7:12 p.m. UTC | #1
On 03/25/2018 09:11 AM, Thomas Koenig wrote:
> Hello world,
> 
> the attached pach fixes the PR by creating one single big string
> from a parameter array.
> 
> OK for trunk?

Nice, you put it right where I thought it should go in resolution.

Yes, OK,

Thanks

Jerry
diff mbox series

Patch

Index: io.c
===================================================================
--- io.c	(Revision 258845)
+++ io.c	(Arbeitskopie)
@@ -25,6 +25,7 @@ 
 #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 @@ 
 /* 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 @@ 
       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.  */