From: Sandra Loosemore <sandra@codesourcery.com>
Date: Thu, 23 Sep 2021 15:03:52 +0000 (-0700)
Subject: Fortran: Diagnose default-initialized pointer/allocatable dummies
X-Git-Tag: basepoints/gcc-13~4442
X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=2646d0e06b170569be1da28fce1d6e2f03a15f60;p=thirdparty%2Fgcc.git

Fortran: Diagnose default-initialized pointer/allocatable dummies

TS29113 changed what was then C516 in the 2010 Fortran standard (now
C1557 in F2018) from disallowing all of pointer, allocatable, and
optional attributes on dummy arguments to BIND(C) functions, to
disallowing only pointer/allocatable with default-initialization.
gfortran was previously failing to diagnose violations of this
constraint.

2021-09-23  Sandra Loosemore  <sandra@codesourcery.com>

	PR fortran/101320

gcc/fortran/
	* decl.c (gfc_verify_c_interop_param): Handle F2018 C1557,
	aka TS29113 C516.

gcc/testsuite/
	* gfortran.dg/c-interop/c516.f90: Remove xfails.  Add more
	tests.
---

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index f2e8896b5627..b3c65b7175ba 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1557,6 +1557,20 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
 		       "CONTIGUOUS attribute as procedure %qs is BIND(C)",
 		       sym->name, &sym->declared_at, sym->ns->proc_name->name);
 
+	  /* Per F2018, C1557, pointer/allocatable dummies to a bind(c)
+	     procedure that are default-initialized are not permitted.  */
+	  if ((sym->attr.pointer || sym->attr.allocatable)
+	      && sym->ts.type == BT_DERIVED
+	      && gfc_has_default_initializer (sym->ts.u.derived))
+	    {
+	      gfc_error ("Default-initialized %s dummy argument %qs "
+			 "at %L is not permitted in BIND(C) procedure %qs",
+			 (sym->attr.pointer ? "pointer" : "allocatable"),
+			 sym->name, &sym->declared_at,
+			 sym->ns->proc_name->name);
+	      retval = false;
+	    }
+
           /* Character strings are only C interoperable if they have a
 	     length of 1.  However, as an argument they are also iteroperable
 	     when passed as descriptor (which requires len=: or len=*).  */
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c516.f90 b/gcc/testsuite/gfortran.dg/c-interop/c516.f90
index 208eb846ea56..d6a65affdb2d 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/c516.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/c516.f90
@@ -27,6 +27,10 @@ module m2
 
   interface
 
+    ! First test versions with optional attributes on the argument.
+    ! TS29113 removed the constraint disallowing optional arguments
+    ! that previously used to be in C516.
+
     ! good, no default initialization, no pointer/allocatable attribute
     subroutine s1a (x) bind (c)
       use m1
@@ -52,16 +56,54 @@ module m2
     end subroutine
 
     ! bad, default initialization + allocatable
-    subroutine s2b (x) bind (c)  ! { dg-error "BIND\\(C\\)" "pr101320" { xfail *-*-* } }
+    subroutine s2b (x) bind (c)  ! { dg-error "BIND\\(C\\)" }
       use m1
       type(t2), allocatable, optional :: x
     end subroutine
 
     ! bad, default initialization + pointer
-    subroutine s2c (x) bind (c)  ! { dg-error "BIND\\(C\\)" "pr101320" { xfail *-*-* } }
+    subroutine s2c (x) bind (c)  ! { dg-error "BIND\\(C\\)" }
       use m1
       type(t2), pointer, optional :: x
     end subroutine
 
+    ! Now do all the same tests without the optional attribute.
+
+    ! good, no default initialization, no pointer/allocatable attribute
+    subroutine s3a (x) bind (c)
+      use m1
+      type(t1) :: x
+    end subroutine
+
+    ! good, no default initialization
+    subroutine s3b (x) bind (c)
+      use m1
+      type(t1), allocatable :: x
+    end subroutine
+
+    ! good, no default initialization
+    subroutine s3c (x) bind (c)
+      use m1
+      type(t1), pointer :: x
+    end subroutine
+
+    ! good, default initialization but no pointer/allocatable attribute
+    subroutine s4a (x) bind (c)
+      use m1
+      type(t2) :: x
+    end subroutine
+
+    ! bad, default initialization + allocatable
+    subroutine s4b (x) bind (c)  ! { dg-error "BIND\\(C\\)" }
+      use m1
+      type(t2), allocatable :: x
+    end subroutine
+
+    ! bad, default initialization + pointer
+    subroutine s4c (x) bind (c)  ! { dg-error "BIND\\(C\\)" }
+      use m1
+      type(t2), pointer :: x
+    end subroutine
+
   end interface
 end module