[gcc r16-2453] Fortran: fix passing of character length of function to procedure [PR121203]

[Harald Anlauf via Gcc-cvs]

https://gcc.gnu.org/g:53b64337ef325c4e47ae96ea8dea86031a3a0602

commit r16-2453-g53b64337ef325c4e47ae96ea8dea86031a3a0602
Author: Harald Anlauf <anl...@gmx.de>
Date:   Tue Jul 22 20:16:16 2025 +0200

    Fortran: fix passing of character length of function to procedure [PR121203]
    
            PR fortran/121203
    
    gcc/fortran/ChangeLog:
    
            * trans-expr.cc (gfc_conv_procedure_call): Obtain the character
            length of an assumed character length procedure from the typespec
            of the actual argument even if there is no explicit interface.
    
    gcc/testsuite/ChangeLog:
    
            * gfortran.dg/function_charlen_4.f90: New test.

Diff:
---
 gcc/fortran/trans-expr.cc                        | 26 +++++++++---------
 gcc/testsuite/gfortran.dg/function_charlen_4.f90 | 34 ++++++++++++++++++++++++
 2 files changed, 47 insertions(+), 13 deletions(-)

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 6fa52d0ffef3..7c7621571ad0 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -7909,21 +7909,21 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
          se->ss->info->class_container = arg1_cntnr;
        }
 
-      if (fsym && e)
+      /* Obtain the character length of an assumed character length procedure
+        from the typespec of the actual argument.  */
+      if (e
+         && parmse.string_length == NULL_TREE
+         && e->ts.type == BT_PROCEDURE
+         && e->symtree->n.sym->ts.type == BT_CHARACTER
+         && e->symtree->n.sym->ts.u.cl->length != NULL
+         && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
        {
-         /* Obtain the character length of an assumed character length
-            length procedure from the typespec.  */
-         if (fsym->ts.type == BT_CHARACTER
-             && parmse.string_length == NULL_TREE
-             && e->ts.type == BT_PROCEDURE
-             && e->symtree->n.sym->ts.type == BT_CHARACTER
-             && e->symtree->n.sym->ts.u.cl->length != NULL
-             && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
-           {
-             gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
-             parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
-           }
+         gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
+         parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
+       }
 
+      if (fsym && e)
+       {
          /* Obtain the character length for a NULL() actual with a character
             MOLD argument.  Otherwise substitute a suitable dummy length.
             Here we handle non-optional dummies of non-bind(c) procedures.  */
diff --git a/gcc/testsuite/gfortran.dg/function_charlen_4.f90 
b/gcc/testsuite/gfortran.dg/function_charlen_4.f90
new file mode 100644
index 000000000000..ed39aca4f42f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/function_charlen_4.f90
@@ -0,0 +1,34 @@
+! { dg-do run }
+! { dg-options "-O2 -std=legacy -fdump-tree-optimized" }
+!
+! PR fortran/121203 - fix passing of character length of function to procedure
+
+program p
+  character(10), external :: f
+  call eval (f,"abc")
+  call eval2(f,"abc")
+contains
+  subroutine eval2(func,c_arg)
+    character(*) c_arg
+    character(*) func
+    external func
+    ! These tests should get optimized:
+    if (len      (c_arg)  /=  3) stop 1
+    if (len (func(c_arg)) /= 10) stop 2
+  end subroutine
+end
+
+character(10) function f(arg)
+  character(*) arg
+  f=arg
+end
+
+subroutine eval(func,c_arg)
+  character(*) c_arg
+  character(*) func
+  external func
+  if (len      (c_arg)  /=  3) error stop 3
+  if (len (func(c_arg)) /= 10) error stop 4
+end subroutine
+
+! { dg-final { scan-tree-dump-not "_gfortran_stop_numeric" "optimized" } }