Fortran: F2018 extensions to interoperability of procedures [PR113338]

	PR fortran/113338

gcc/fortran/ChangeLog:

	* decl.cc (gfc_verify_c_interop_param): Allow further types of
	dummy argument without the VALUE attribute as specified in
	F2018 18.3.6 item (5).

gcc/testsuite/ChangeLog:

	* gfortran.dg/c-interop/pr113338-c.c: New test.
	* gfortran.dg/c-interop/pr113338.f90: New test.

diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 96ee6bf7b686104e0d512007b30ee74a4998d788..03134f39a404f7bfdbdfe87a60d168d53b86c912 100644 (file)
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -1537,9 +1537,47 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
     {
       if (sym->ns->proc_name->attr.is_bind_c == 1)
        {
+         bool f2018_allowed = gfc_option.allow_std & ~GFC_STD_OPT_F08;
+         bool f2018_added = false;
+
          is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0);
 
-         if (is_c_interop != 1)
+         /* F2018:18.3.6 has the following text:
+            "(5) any dummy argument without the VALUE attribute corresponds to
+            a formal parameter of the prototype that is of a pointer type, and
+            either
+            • the dummy argument is interoperable with an entity of the
+            referenced type (ISO/IEC 9899:2011, 6.2.5, 7.19, and 7.20.1) of
+            the formal parameter (this is equivalent to the F2008 text),
+            • the dummy argument is a nonallocatable nonpointer variable of
+            type CHARACTER with assumed character length and the formal
+            parameter is a pointer to CFI_cdesc_t,
+            • the dummy argument is allocatable, assumed-shape, assumed-rank,
+            or a pointer without the CONTIGUOUS attribute, and the formal
+            parameter is a pointer to CFI_cdesc_t, or
+            • the dummy argument is assumed-type and not allocatable,
+            assumed-shape, assumed-rank, or a pointer, and the formal
+            parameter is a pointer to void,"  */
+         if (is_c_interop == 0 && !sym->attr.value && f2018_allowed)
+           {
+             bool as_ar = (sym->as
+                           && (sym->as->type == AS_ASSUMED_SHAPE
+                               || sym->as->type == AS_ASSUMED_RANK));
+             bool cond1 = (sym->ts.type == BT_CHARACTER
+                           && !(sym->ts.u.cl && sym->ts.u.cl->length)
+                           && !sym->attr.allocatable
+                           && !sym->attr.pointer);
+             bool cond2 = (sym->attr.allocatable
+                           || as_ar
+                           || (IS_POINTER (sym) && !sym->attr.contiguous));
+             bool cond3 = (sym->ts.type == BT_ASSUMED
+                           && !sym->attr.allocatable
+                           && !sym->attr.pointer
+                           && !as_ar);
+             f2018_added = cond1 || cond2 || cond3;
+           }
+
+         if (is_c_interop != 1 && !f2018_added)
            {
              /* Make personalized messages to give better feedback.  */
              if (sym->ts.type == BT_DERIVED)

diff --git a/gcc/testsuite/gfortran.dg/c-interop/pr113338-c.c b/gcc/testsuite/gfortran.dg/c-interop/pr113338-c.c
new file mode 100644 (file)
index 0000000..21a6b7a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/pr113338-c.c
@@ -0,0 +1,10 @@
+/* PR fortran/113338.  */
+
+#include <ISO_Fortran_binding.h>
+
+extern void f_proc(CFI_cdesc_t* x);
+
+extern void c_proc(CFI_cdesc_t* x)
+{
+    f_proc(x);
+}

diff --git a/gcc/testsuite/gfortran.dg/c-interop/pr113338.f90 b/gcc/testsuite/gfortran.dg/c-interop/pr113338.f90
new file mode 100644 (file)
index 0000000..a83c3ca
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/pr113338.f90
@@ -0,0 +1,80 @@
+! { dg-do run }
+! { dg-additional-sources pr113338-c.c }
+! { dg-additional-options "-Wno-error -O2 -std=f2018" }
+! { dg-warning "command-line option '-std=f2018' is valid for Fortran but not for C" "" { target *-*-* } 0 }
+!
+! PR fortran/113338 - F2018 extensions to interoperability of procedures
+
+program example
+  use iso_c_binding
+  implicit none
+
+  type :: t
+     integer :: i
+  end type
+
+  interface
+     subroutine c_proc(x) bind(c)
+       import t
+       type(t), pointer, intent(in) :: x
+     end subroutine c_proc
+  end interface
+
+  type(t), target :: x
+
+  x%i = 42
+  call c_proc(x)
+end program
+
+! pointer
+subroutine f_proc(x) bind(c)
+  type :: t
+     integer :: i
+  end type t
+  type(t), pointer, intent(in) :: x
+  if (.not. associated (x)) stop 1
+! print *, x%i
+  if (x%i /= 42) stop 2
+end subroutine f_proc
+
+!-----------------------------------------------------------------------
+! Further cases some of which are also tested elsewhere in the testsuite
+!-----------------------------------------------------------------------
+
+! character: length 1 or assumed character length -> *CFI_cdesc_t
+subroutine f_char(c, s) bind(c)
+  character    :: c(:)
+  character(*) :: s(:)
+end subroutine f_char
+
+! allocatable: scalar, assumed-shape, assumed-rank -> *CFI_cdesc_t
+subroutine f_a(x, y, z) bind(c)
+  type :: t
+     integer :: i
+  end type t
+  type(t), allocatable :: x
+  type(t), allocatable :: y(:)
+  type(t), allocatable :: z(..)
+end subroutine f_a
+
+! pointer: scalar, assumed-shape, assumed-rank -> *CFI_cdesc_t
+subroutine f_p(x, y, z) bind(c)
+  type :: t
+     integer :: i
+  end type t
+  type(t), pointer :: x
+  type(t), pointer :: y(:)
+  type(t), pointer :: z(..)
+end subroutine f_p
+
+! assumed-type: assumed shape, assumed rank -> *CFI_cdesc_t
+subroutine f_at_cfi(z, w) bind(c)
+  type(*) :: z(:)
+  type(*) :: w(..)
+end subroutine f_at_cfi
+
+! assumed-type: scalar, assumed-size -> *void
+subroutine f_at_void(x, y) bind(c)
+  type(*) :: x
+  type(*) :: y(*)
+end subroutine f_at_void