Fortran: F2008 passing of internal procs to a proc pointer [PR117434]

2024-11-06  Paul Thomas  <pault@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 --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 69519fe3168e9642b4452b4c06b4182c99e38512..61c506bfdb5dbdc4dcf7f5aa8bf5872fe9d25749 100644 (file)
--- 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 (file)
index 0000000..e03ecb5
--- /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 (file)
index 0000000..7028634
--- /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 (file)
index 0000000..ca5bed7
--- /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