Hi All, There is not much to say about the attached patch other than it is minimal :-) The testcases are probably a bit more than is strictly needed since the interface tests (proc_ptr_55.f90) are already tested elsewhere. However, it is as well to check in this context.
OK for mainline and 14-branch after a week or two? The issue with the executable stack on some platforms should have its own PR to ensure that it has the required visibility. I can make proc_ptr_64.f90 compile-only until it is fixed. Regards Paul
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 69519fe3168..61c506bfdb5 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 00000000000..348b73b9dad
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_54.f90
@@ -0,0 +1,95 @@
+! { dg-do run }
+!
+! 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 00000000000..7028634b54e
--- /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 00000000000..7ecf87bba65
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_56.f90
@@ -0,0 +1,45 @@
+! { dg-do run }
+! { 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
