diff mbox series

[fortran] PR68155 - ICE on initializing character array in type (len_lhs <> len_rhs)

Message ID CAGkQGiJW7-4N-CkL5mH2K+RQomL9pYmZVZvDUjYdMUHHd+5UBA@mail.gmail.com
State Accepted
Headers
Series [fortran] PR68155 - ICE on initializing character array in type (len_lhs <> len_rhs) |

Checks

Context Check Description
snail/gcc-patch-check success Github commit url

Commit Message

Paul Richard Thomas Sept. 20, 2023, 7:03 a.m. UTC 
  Hi All,

This is a straightforward patch that is adequately explained by the ChangeLog.

Regtests fine - OK for trunk?

Cheers

Paul

Fortran: Pad mismatched charlens in component initializers [PR68155]

2023-09-20  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
PR fortran/68155
* decl.cc (fix_initializer_charlen): New function broken out of
add_init_expr_to_sym.
(add_init_expr_to_sym, build_struct): Call the new function.

gcc/testsuite/
PR fortran/68155
* gfortran.dg/pr68155.f90: New test.

Comments

Harald Anlauf Sept. 20, 2023, 5:36 p.m. UTC | #1 
Hi Paul,

On 9/20/23 09:03, Paul Richard Thomas wrote:
> Hi All,
>
> This is a straightforward patch that is adequately explained by the ChangeLog.
>
> Regtests fine - OK for trunk?

this looks good to me.  OK for trunk.

As it is an almost obvious fix for sort of wrong code, I'd consider
it backportable if you have intentions in that direction.

Thanks,
Harald

> Cheers
>
> Paul
>
> Fortran: Pad mismatched charlens in component initializers [PR68155]
>
> 2023-09-20  Paul Thomas  <pault@gcc.gnu.org>
>
> gcc/fortran
> PR fortran/68155
> * decl.cc (fix_initializer_charlen): New function broken out of
> add_init_expr_to_sym.
> (add_init_expr_to_sym, build_struct): Call the new function.
>
> gcc/testsuite/
> PR fortran/68155
> * gfortran.dg/pr68155.f90: New test.
diff mbox series

Patch

diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 8182ef29f43..4a3c5b86de0 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -1960,6 +1960,45 @@  gfc_free_enum_history (void)
 }
 
 
+/* Function to fix initializer character length if the length of the
+   symbol or component is constant.  */
+
+static bool
+fix_initializer_charlen (gfc_typespec *ts, gfc_expr *init)
+{
+  if (!gfc_specification_expr (ts->u.cl->length))
+    return false;
+
+  int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
+
+  /* resolve_charlen will complain later on if the length
+     is too large.  Just skip the initialization in that case.  */
+  if (mpz_cmp (ts->u.cl->length->value.integer,
+	       gfc_integer_kinds[k].huge) <= 0)
+    {
+      HOST_WIDE_INT len
+		= gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
+
+      if (init->expr_type == EXPR_CONSTANT)
+	gfc_set_constant_character_len (len, init, -1);
+      else if (init->expr_type == EXPR_ARRAY)
+	{
+	  gfc_constructor *cons;
+
+	  /* Build a new charlen to prevent simplification from
+	     deleting the length before it is resolved.  */
+	  init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+	  init->ts.u.cl->length = gfc_copy_expr (ts->u.cl->length);
+	  cons = gfc_constructor_first (init->value.constructor);
+	  for (; cons; cons = gfc_constructor_next (cons))
+	    gfc_set_constant_character_len (len, cons->expr, -1);
+	}
+    }
+
+  return true;
+}
+
+
 /* Function called by variable_decl() that adds an initialization
    expression to a symbol.  */
 
@@ -2073,40 +2112,10 @@  add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
 				gfc_copy_expr (init->ts.u.cl->length);
 		}
 	    }
-	  /* Update initializer character length according symbol.  */
-	  else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
-	    {
-	      if (!gfc_specification_expr (sym->ts.u.cl->length))
-		return false;
-
-	      int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind,
-					 false);
-	      /* resolve_charlen will complain later on if the length
-		 is too large.  Just skeep the initialization in that case.  */
-	      if (mpz_cmp (sym->ts.u.cl->length->value.integer,
-			   gfc_integer_kinds[k].huge) <= 0)
-		{
-		  HOST_WIDE_INT len
-		    = gfc_mpz_get_hwi (sym->ts.u.cl->length->value.integer);
-
-		  if (init->expr_type == EXPR_CONSTANT)
-		    gfc_set_constant_character_len (len, init, -1);
-		  else if (init->expr_type == EXPR_ARRAY)
-		    {
-		      gfc_constructor *c;
-
-		      /* Build a new charlen to prevent simplification from
-			 deleting the length before it is resolved.  */
-		      init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
-		      init->ts.u.cl->length
-			= gfc_copy_expr (sym->ts.u.cl->length);
-
-		      for (c = gfc_constructor_first (init->value.constructor);
-			   c; c = gfc_constructor_next (c))
-			gfc_set_constant_character_len (len, c->expr, -1);
-		    }
-		}
-	    }
+	  /* Update initializer character length according to symbol.  */
+	  else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
+		   && !fix_initializer_charlen (&sym->ts, init))
+	    return false;
 	}
 
       if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension && sym->as
@@ -2369,6 +2378,13 @@  build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
   c->initializer = *init;
   *init = NULL;
 
+  /* Update initializer character length according to component.  */
+  if (c->ts.type == BT_CHARACTER && c->ts.u.cl->length
+      && c->ts.u.cl->length->expr_type == EXPR_CONSTANT
+      && c->initializer && c->initializer->ts.type == BT_CHARACTER
+      && !fix_initializer_charlen (&c->ts, c->initializer))
+    return false;
+
   c->as = *as;
   if (c->as != NULL)
     {