https://gcc.gnu.org/g:4dbf4c0fdb188e1c348688de91e010f696cd59fc
commit r15-4974-g4dbf4c0fdb188e1c348688de91e010f696cd59fc
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Wed Nov 6 07:17:25 2024 +0000
Fortran: F2008 passing of internal procs to a proc pointer [PR117434]
2024-11-06 Paul Thomas <pa...@gcc.gnu.org>
gcc/fortran
PR fortran/117434
* interface.cc (gfc_compare_actual_formal): Skip 'Expected a
procedure pointer error' if the formal argument typespec has an
interface and the type of the actual arg is BT_PROCEDURE.
gcc/testsuite/
PR fortran/117434
* gfortran.dg/proc_ptr_54.f90: New test. This is temporarily
compile-only until one one seven four five five is fixed.
* gfortran.dg/proc_ptr_55.f90: New test.
* gfortran.dg/proc_ptr_56.f90: New test.
Diff:
---
gcc/fortran/interface.cc | 9 ++-
gcc/testsuite/gfortran.dg/proc_ptr_54.f90 | 95 +++++++++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/proc_ptr_55.f90 | 87 ++++++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/proc_ptr_56.f90 | 45 +++++++++++++++
4 files changed, 234 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 69519fe3168e..61c506bfdb5d 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -3513,12 +3513,17 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap,
gfc_formal_arglist *formal,
skip_size_check:
- /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
- argument is provided for a procedure pointer formal argument. */
+ /* Satisfy either: F03:12.4.1.3 by ensuring that a procedure pointer
+ actual argument is provided for a procedure pointer formal argument;
+ or: F08:12.5.2.9 (F18:15.5.2.10) by ensuring that the effective
+ argument shall be an external, internal, module, or dummy procedure.
+ The interfaces are checked elsewhere. */
if (f->sym->attr.proc_pointer
&& !((a->expr->expr_type == EXPR_VARIABLE
&& (a->expr->symtree->n.sym->attr.proc_pointer
|| gfc_is_proc_ptr_comp (a->expr)))
+ || (a->expr->ts.type == BT_PROCEDURE
+ && f->sym->ts.interface)
|| (a->expr->expr_type == EXPR_FUNCTION
&& is_procptr_result (a->expr))))
{
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_54.f90
b/gcc/testsuite/gfortran.dg/proc_ptr_54.f90
new file mode 100644
index 000000000000..e03ecb507400
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_54.f90
@@ -0,0 +1,95 @@
+! { dg-do compile }
+!
+! Test the fix for pr117434, in which the F2008 addition of being permitted to
+! pass an external, internal or module procedure to a dummy procedure pointer
+! gave the error "Expected a procedure pointer for argument ‘<arg_name>’ at
(1).
+!
+! This testcase checks for correct results.
+!
+! Contributed by Damian Rouson <damian@archaeologic.codes>
+!
+module julienne_test_description_m
+ implicit none
+
+ abstract interface
+ logical function test_function_i(arg)
+ integer, intent(in) :: arg
+ end function
+ end interface
+
+ type test_description_t
+ procedure(test_function_i), pointer, nopass :: test_function_
+ end type
+
+
+contains
+
+ type(test_description_t) function new_test_description(test_function)
+ procedure(test_function_i), intent(in), pointer :: test_function
+ new_test_description%test_function_ => test_function
+ end function
+
+end module
+
+module test_mod
+
+contains
+
+ logical function mod_test(arg)
+ integer, intent(in) :: arg
+ if (arg == 1) then
+ mod_test = .true.
+ else
+ mod_test = .false.
+ endif
+ end function
+
+end
+
+logical function ext_test(arg)
+ integer, intent(in) :: arg
+ if (arg == 2) then
+ ext_test = .true.
+ else
+ ext_test = .false.
+ endif
+end function
+
+ use julienne_test_description_m
+ use test_mod
+ implicit none
+ type(test_description_t) test_description
+
+ interface
+ logical function ext_test(arg)
+ integer, intent(in) :: arg
+ end function
+ end interface
+
+ test_description = new_test_description(test)
+ if (test_description%test_function_(1) &
+ .or. test_description%test_function_(2) &
+ .or. .not.test_description%test_function_(3)) stop 1
+
+ test_description = new_test_description(mod_test)
+ if (test_description%test_function_(2) &
+ .or. test_description%test_function_(3) &
+ .or. .not.test_description%test_function_(1)) stop 2
+
+ test_description = new_test_description(ext_test)
+ if (test_description%test_function_(1) &
+ .or. test_description%test_function_(3) &
+ .or. .not.test_description%test_function_(2)) stop 3
+
+contains
+
+ logical function test(arg)
+ integer, intent(in) :: arg
+ if (arg == 3) then
+ test = .true.
+ else
+ test = .false.
+ endif
+ end function
+
+end
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_55.f90
b/gcc/testsuite/gfortran.dg/proc_ptr_55.f90
new file mode 100644
index 000000000000..7028634b54ee
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_55.f90
@@ -0,0 +1,87 @@
+! { dg-do compile }
+!
+! Test the fix for pr117434, in which the F2008 addition of being permitted to
+! pass an external, internal or module procedure to a dummy procedure pointer
+! gave the error "Expected a procedure pointer for argument ‘<arg_name>’ at
(1).
+!
+! This testcase tests that interface checking is OK in this situation.
+!
+! Contributed by Damian Rouson <damian@archaeologic.codes>
+!
+module julienne_test_description_m
+ implicit none
+
+ abstract interface
+ logical function test_function_i(arg)
+ integer, intent(in) :: arg
+ end function
+ end interface
+
+ type test_description_t
+ procedure(test_function_i), pointer, nopass :: test_function_
+ end type
+
+
+contains
+
+ type(test_description_t) function new_test_description(test_function)
+ procedure(test_function_i), intent(in), pointer :: test_function
+ new_test_description%test_function_ => test_function
+ end function
+
+end module
+
+ use julienne_test_description_m
+ implicit none
+ type(test_description_t) test_description
+
+ test_description = new_test_description(test1)
+ test_description = new_test_description(test2) ! { dg-error "Type mismatch
in function" }
+ test_description = new_test_description(test3) ! { dg-error "wrong number of
arguments" }
+ test_description = new_test_description(test4) ! { dg-error "Rank mismatch
in argument" }
+ test_description = new_test_description(test5) ! { dg-error "Rank mismatch
in function result" }
+
+contains
+
+ logical function test1(arg)
+ integer, intent(in) :: arg
+ if (arg == 3) then
+ test1 = .true.
+ else
+ test1 = .false.
+ endif
+ end function
+
+ real function test2(arg)
+ integer, intent(in) :: arg
+ if (arg == 3) then
+ test2 = 1.0
+ else
+ test2 = 0.0
+ endif
+ end function
+
+ logical function test3()
+ test3 = .false.
+ end function
+
+ logical function test4(arg)
+ integer, intent(in) :: arg(:)
+ if (sum (arg) == 3) then
+ test4 = .true.
+ else
+ test4 = .false.
+ endif
+ end function
+
+ function test5(arg) result(res)
+ integer, intent(in) :: arg
+ logical :: res(2)
+ if (arg == 3) then
+ res = .true.
+ else
+ res = .false.
+ endif
+ end function
+
+end
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_56.f90
b/gcc/testsuite/gfortran.dg/proc_ptr_56.f90
new file mode 100644
index 000000000000..ca5bed7e8f0f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_56.f90
@@ -0,0 +1,45 @@
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+!
+! Test the fix for pr117434, in which the F2008 addition of being permitted to
+! pass an external, internal or module procedure to a dummy procedure pointer
+! gave the error "Expected a procedure pointer for argument ‘<arg_name>’ at
(1).
+!
+! This testcase checks that -std=f2008 or later is required..
+!
+! Contributed by Damian Rouson <damian@archaeologic.codes>
+!
+module julienne_test_description_m
+ implicit none
+
+ abstract interface
+ logical function test_function_i()
+ end function
+ end interface
+
+ type test_description_t
+ procedure(test_function_i), pointer, nopass :: test_function_
+ end type
+
+contains
+
+ type(test_description_t) function new_test_description(test_function)
+ procedure(test_function_i), intent(in), pointer :: test_function
+ new_test_description%test_function_ => test_function
+ end function
+
+end module
+
+ use julienne_test_description_m
+ implicit none
+ type(test_description_t) test_description
+
+ test_description = new_test_description(test) ! { dg-error "Fortran 2008:" }
+
+contains
+
+ logical function test()
+ test = .true.
+ end function
+
+end
