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.

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 082987f9cb84faae5faee3876027db255b654a8f..6fa52d0ffef32dfa94b7dd2f4762a3d4aa04ab41 100644 (file)
--- 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 (file)
index 0000000..13c6820
--- /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" } }