Dear all,
the attached simple and obvious patch fixes an erroneous runtime check
with -fcheck=pointer when passing a non-associated proc-pointer to an
optional dummy.
Regtested on x86_64-pc-linux-gnu. OK for mainline / backports?
Thanks,
Harald
From 8f9450505f8244d262f8b4ff274f113f99cdc7e2 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anl...@gmx.de>
Date: Fri, 18 Jul 2025 21:12:03 +0200
Subject: [PATCH] Fortran: fix bogus runtime error with optional procedure
argument [PR121145]
PR fortran/121145
gcc/fortran/ChangeLog:
* trans-expr.cc (gfc_conv_procedure_call): Do not create pointer
check for proc-pointer actual passed to optional dummy.
gcc/testsuite/ChangeLog:
* gfortran.dg/pointer_check_15.f90: New test.
---
gcc/fortran/trans-expr.cc | 3 +-
.../gfortran.dg/pointer_check_15.f90 | 46 +++++++++++++++++++
2 files changed, 48 insertions(+), 1 deletion(-)
create mode 100644 gcc/testsuite/gfortran.dg/pointer_check_15.f90
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 082987f9cb8..6fa52d0ffef 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -8159,7 +8159,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
msg = xasprintf ("Pointer actual argument '%s' is not "
"associated", e->symtree->n.sym->name);
else if (attr.proc_pointer && !e->value.function.actual
- && (fsym == NULL || !fsym_attr.proc_pointer))
+ && (fsym == NULL
+ || (!fsym_attr.proc_pointer && !fsym_attr.optional)))
msg = xasprintf ("Proc-pointer actual argument '%s' is not "
"associated", e->symtree->n.sym->name);
else
diff --git a/gcc/testsuite/gfortran.dg/pointer_check_15.f90 b/gcc/testsuite/gfortran.dg/pointer_check_15.f90
new file mode 100644
index 00000000000..13c6820be0e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_check_15.f90
@@ -0,0 +1,46 @@
+! { dg-do run }
+! { dg-additional-options "-O -fcheck=pointer -fdump-tree-original" }
+!
+! PR fortran/121145
+! Erroneous runtime error: Proc-pointer actual argument 'ptr' is not associated
+!
+! Contributed by Federico Perini.
+
+module m
+ implicit none
+
+ abstract interface
+ subroutine fun(x)
+ real, intent(in) :: x
+ end subroutine fun
+ end interface
+
+contains
+
+ subroutine with_fun(sub)
+ procedure(fun), optional :: sub
+ if (present(sub)) stop 1
+ end subroutine
+
+ subroutine with_non_optional(sub)
+ procedure(fun) :: sub
+ end subroutine
+
+end module m
+
+program p
+ use m
+ implicit none
+
+ procedure(fun), pointer :: ptr1 => null()
+ procedure(fun), pointer :: ptr2 => null()
+
+ call with_fun()
+ call with_fun(sub=ptr1) ! no runtime check here
+
+ if (associated (ptr2)) then
+ call with_non_optional(sub=ptr2) ! runtime check here
+ end if
+end
+
+! { dg-final { scan-tree-dump-times "Proc-pointer actual argument .'ptr2.'" 1 "original" } }
--
2.43.0
