Fortran: fix issue with impure elemental subroutine and interface [PR119656]

	PR fortran/119656

gcc/fortran/ChangeLog:

	* interface.cc (gfc_compare_actual_formal): Fix front-end memleak
	when searching for matching interfaces.
	* trans-expr.cc (gfc_conv_procedure_call): If there is a formal
	dummy corresponding to an absent argument, use its type, and only
	fall back to inferred type otherwise.

gcc/testsuite/ChangeLog:

	* gfortran.dg/optional_absent_13.f90: New test.

(cherry picked from commit 334545194d9023fb9b2f72ee0dcde8af94930f25)

diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 0c4cd385d56a74dc18c1816088a0016e127529a1..29a6a027b5d24e2acfebc0bc06129b947c294ffa 100644 (file)
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -3226,7 +3226,11 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
          return false;
        }
       else
-       a->associated_dummy = get_nonintrinsic_dummy_arg (f);
+       {
+         if (a->associated_dummy)
+           free (a->associated_dummy);
+         a->associated_dummy = get_nonintrinsic_dummy_arg (f);
+       }
 
       if (a->expr == NULL)
        {

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 7a7a7be17930cf2cd7f691bb8c98b070e5d68243..42c4f100603109d28ee46cf79f1632d35e5d0b38 100644 (file)
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6195,10 +6195,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                {
                  /* Pass a NULL pointer for an absent arg.  */
                  parmse.expr = null_pointer_node;
+
+                 /* Is it an absent character dummy?  */
+                 bool absent_char = false;
                  gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
-                 if (dummy_arg
-                     && gfc_dummy_arg_get_typespec (*dummy_arg).type
-                        == BT_CHARACTER)
+
+                 /* Fall back to inferred type only if no formal.  */
+                 if (fsym)
+                   absent_char = (fsym->ts.type == BT_CHARACTER);
+                 else if (dummy_arg)
+                   absent_char = (gfc_dummy_arg_get_typespec (*dummy_arg).type
+                                  == BT_CHARACTER);
+                 if (absent_char)
                    parmse.string_length = build_int_cst (gfc_charlen_type_node,
                                                          0);
                }
@@ -6215,9 +6223,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                          || !CLASS_DATA (fsym)->attr.allocatable));
          gfc_init_se (&parmse, NULL);
          parmse.expr = null_pointer_node;
-         if (arg->associated_dummy
-             && gfc_dummy_arg_get_typespec (*arg->associated_dummy).type
-                == BT_CHARACTER)
+         if (fsym->ts.type == BT_CHARACTER)
            parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
        }
       else if (fsym && fsym->ts.type == BT_CLASS

diff --git a/gcc/testsuite/gfortran.dg/optional_absent_13.f90 b/gcc/testsuite/gfortran.dg/optional_absent_13.f90
new file mode 100644 (file)
index 0000000..9c2039b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/optional_absent_13.f90
@@ -0,0 +1,48 @@
+! { dg-do run }
+! PR fortran/119656 - wrong code with impure elemental subroutine and interface
+!
+! Derived from testcase at:
+!   https://fortran-lang.discourse.group/t/
+!     problem-with-impure-elemental-subroutine-in-interface-with-gfortran/9545
+
+module m2
+  implicit none
+  interface foo
+     module procedure foo_mat
+     module procedure foo_df
+     module procedure foo_cmat
+  end interface foo
+contains
+
+  subroutine foo_mat(x, nacf, label)
+    real,             intent(in)           :: x(:,:)
+    integer,          intent(in)           :: nacf
+    character(len=*), intent(in), optional :: label
+  end subroutine foo_mat
+
+  impure elemental subroutine foo_df(nacf, outu, xstr)
+    integer         , intent(in)           :: nacf
+    integer         , intent(in), optional :: outu
+    character(len=*), intent(in), optional :: xstr
+    if (present(xstr)) then
+       if (len (xstr) /= 2) then
+          print *,"nacf, len(xstr) =", nacf, len(xstr)
+          stop nacf
+       end if
+    end if
+  end subroutine foo_df
+
+  subroutine foo_cmat(x, nacf, label)
+    complex,          intent(in)           :: x(:,:)
+    integer,          intent(in)           :: nacf
+    character(len=*), intent(in), optional :: label
+  end subroutine foo_cmat
+
+end module m2
+
+program main
+  use m2, only: foo, foo_df
+  implicit none
+  call foo_df(nacf = 1, xstr="ab")
+  call foo   (nacf = 2, xstr="ab")
+end program main