Fortran: Simplify len_trim with array ref and fix mapping bug[PR84868].

2024-07-16  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/84868
	* simplify.cc (gfc_simplify_len_trim): If the argument is an
	element of a parameter array, simplify all the elements and
	build a new parameter array to hold the result, after checking
	that it doesn't already exist.
	* trans-expr.cc (gfc_get_interface_mapping_array) if a string
	length is available, use it for the typespec.
	(gfc_add_interface_mapping): Supply the se string length.

gcc/testsuite/
	PR fortran/84868
	* gfortran.dg/pr84868.f90: New test.

2 files changed, 87 insertions, 6 deletions

diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 7a5d31c..60b717f 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -4637,6 +4637,81 @@ gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
   if (k == -1)
     return &gfc_bad_expr;
 
+  /* If the expression is either an array element or section, an array
+     parameter must be built so that the reference can be applied. Constant
+     references should have already been simplified away. All other cases
+     can proceed to translation, where kind conversion will occur silently.  */
+  if (e->expr_type == EXPR_VARIABLE
+      && e->ts.type == BT_CHARACTER
+      && e->symtree->n.sym->attr.flavor == FL_PARAMETER
+      && e->ref && e->ref->type == REF_ARRAY
+      && e->ref->u.ar.type != AR_FULL
+      && e->symtree->n.sym->value)
+    {
+      char name[2*GFC_MAX_SYMBOL_LEN + 12];
+      gfc_namespace *ns = e->symtree->n.sym->ns;
+      gfc_symtree *st;
+      gfc_expr *expr;
+      gfc_expr *p;
+      gfc_constructor *c;
+      int cnt = 0;
+
+      sprintf (name, "_len_trim_%s_%s", e->symtree->n.sym->name,
+	       ns->proc_name->name);
+      st = gfc_find_symtree (ns->sym_root, name);
+      if (st)
+	goto already_built;
+
+      /* Recursively call this fcn to simplify the constructor elements.  */
+      expr = gfc_copy_expr (e->symtree->n.sym->value);
+      expr->ts.type = BT_INTEGER;
+      expr->ts.kind = k;
+      expr->ts.u.cl = NULL;
+      c = gfc_constructor_first (expr->value.constructor);
+      for (; c; c = gfc_constructor_next (c))
+	{
+	  if (c->iterator)
+	    continue;
+
+	  if (c->expr && c->expr->ts.type == BT_CHARACTER)
+	    {
+	      p = gfc_simplify_len_trim (c->expr, kind);
+	      if (p == NULL)
+		goto clean_up;
+	      gfc_replace_expr (c->expr, p);
+	      cnt++;
+	    }
+	}
+
+      if (cnt)
+	{
+	  /* Build a new parameter to take the result.  */
+	  st = gfc_new_symtree (&ns->sym_root, name);
+	  st->n.sym = gfc_new_symbol (st->name, ns);
+	  st->n.sym->value = expr;
+	  st->n.sym->ts = expr->ts;
+	  st->n.sym->attr.dimension = 1;
+	  st->n.sym->attr.save = SAVE_IMPLICIT;
+	  st->n.sym->attr.flavor = FL_PARAMETER;
+	  st->n.sym->as = gfc_copy_array_spec (e->symtree->n.sym->as);
+	  gfc_set_sym_referenced (st->n.sym);
+	  st->n.sym->refs++;
+	  gfc_commit_symbol (st->n.sym);
+
+already_built:
+	  /* Build a return expression.  */
+	  expr = gfc_copy_expr (e);
+	  expr->ts = st->n.sym->ts;
+	  expr->symtree = st;
+	  gfc_expression_rank (expr);
+	  return expr;
+	}
+
+clean_up:
+      gfc_free_expr (expr);
+      return NULL;
+    }
+
   if (e->expr_type != EXPR_CONSTANT)
     return NULL;
 
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index fc23fb1..4102567 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -4474,12 +4474,15 @@ gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
 
 static tree
 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
-				 gfc_packed packed, tree data)
+				 gfc_packed packed, tree data, tree len)
 {
   tree type;
   tree var;
 
-  type = gfc_typenode_for_spec (&sym->ts);
+  if (len != NULL_TREE && (TREE_CONSTANT (len) || VAR_P (len)))
+    type = gfc_get_character_type_len (sym->ts.kind, len);
+  else
+    type = gfc_typenode_for_spec (&sym->ts);
   type = gfc_get_nodesc_array_type (type, sym->as, packed,
 				    !sym->attr.target && !sym->attr.pointer
 				    && !sym->attr.proc_pointer);
@@ -4626,7 +4629,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
      convert it to a boundless character type.  */
   else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
     {
-      tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
+      se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
+      tmp = gfc_get_character_type_len (sym->ts.kind, se->string_length);
       tmp = build_pointer_type (tmp);
       if (sym->attr.pointer)
         value = build_fold_indirect_ref_loc (input_location,
@@ -4645,7 +4649,7 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
   /* For character(*), use the actual argument's descriptor.  */
   else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
     value = build_fold_indirect_ref_loc (input_location,
-				     se->expr);
+					 se->expr);
 
   /* If the argument is an array descriptor, use it to determine
      information about the actual argument's shape.  */
@@ -4659,7 +4663,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
       /* Create the replacement variable.  */
       tmp = gfc_conv_descriptor_data_get (desc);
       value = gfc_get_interface_mapping_array (&se->pre, sym,
-					       PACKED_NO, tmp);
+					       PACKED_NO, tmp,
+					       se->string_length);
 
       /* Use DESC to work out the upper bounds, strides and offset.  */
       gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
@@ -4667,7 +4672,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
   else
     /* Otherwise we have a packed array.  */
     value = gfc_get_interface_mapping_array (&se->pre, sym,
-					     PACKED_FULL, se->expr);
+					     PACKED_FULL, se->expr,
+					     se->string_length);
 
   new_sym->backend_decl = value;
 }