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.

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;
 

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,15 +4663,17 @@ 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);
     }
   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;
 }

gcc/testsuite/gfortran.dg/pr84868.f90

@@ -0,0 +1,84 @@
+! { dg-do run }
+!
+! Test the fix for PR84868. Module 'orig' and the call to 'f_orig' is the
+! original bug. The rest tests variants and the fix for a gimplifier ICE.
+!
+! Subroutine 'h' and calls to it were introduced to check the corrections
+! needed to fix additional problems, noted in the review of the patch by
+! Harald Anlauf
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+module orig
+   character(:), allocatable :: c
+   integer :: ans1(3,3), ans2(3), ans3(2)
+contains
+   function f_orig(n) result(z)
+      character(2), parameter :: c(3) = ['x1', 'y ', 'z2']
+      integer, intent(in) :: n
+      character(len_trim(c(n))) :: z
+      z = c(n)
+   end
+   function h(n) result(z)
+     integer,  intent(in) :: n
+     character(2), parameter :: c(3,3) = &
+           reshape (['ab','c ','de','f ','gh','i ','jk','l ','mn'],[3,3])
+     character(4), parameter :: chr(3) = ['ab  ','  cd','e f ']
+     character(len_trim(c(n,n)))  :: z
+     z = c(n,n)
+! Make sure that full arrays are correctly scalarized both having been previously
+! used with an array reference and not previously referenced.
+     ans1 = len_trim (c)
+     ans2 = len_trim (chr)
+! Finally check a slightly more complicated array reference
+     ans3 = len_trim (c(1:n+1:2,n-1))
+   end
+end module orig
+
+module m
+   character(:), allocatable :: c
+contains
+   function f(n, c) result(z)
+      character (2) :: c(:)
+      integer, intent(in) :: n
+      character(len_trim(c(n))) :: z
+      z = c(n)
+   end
+   subroutine foo (pc)
+     character(2) :: pc(:)
+     if (any ([(len (f(i, pc)), i = 1,3)] .ne. [2,1,2])) stop 1
+   end
+end
+program p
+   use m
+   use orig
+   character (2) :: pc(3) = ['x1', 'y ', 'z2']
+   integer :: i
+
+   if (any ([(len (f_orig(i)), i = 1,3)] .ne. [2,1,2])) stop 2 ! ICE
+
+   call foo (pc)
+   if (any ([(len (g(i, pc)), i = 1,3)] .ne. [2,1,2])) stop 3
+   if (any ([(bar1(i), i = 1,3)] .ne. [2,1,2])) stop 4
+   if (any ([(bar2(i), i = 1,3)] .ne. [2,1,2])) stop 5
+
+   if (h(2) .ne. 'gh') stop 6
+   if (any (ans1 .ne. reshape ([2,1,2,1,2,1,2,1,2],[3,3]))) stop 7
+   if (any (ans2 .ne. [2,4,3])) stop 8
+   if (any (ans3 .ne. [2,2])) stop 9
+contains
+   function g(n, c) result(z)
+      character (2) :: c(:)
+      integer, intent(in) :: n
+      character(len_trim(c(n))) :: z
+      z = c(n)
+   end
+   integer function bar1 (i)
+     integer :: i
+     bar1 = len (f(i, pc))  ! ICE in is_gimple_min_invariant
+   end
+   integer function bar2 (i)
+     integer :: i
+     bar2 = len (g(i, pc))
+   end
+end