[gcc r12-3871] Fortran: Diagnose default-initialized pointer/allocatable dummies

[Sandra Loosemore]

https://gcc.gnu.org/g:2646d0e06b170569be1da28fce1d6e2f03a15f60

commit r12-3871-g2646d0e06b170569be1da28fce1d6e2f03a15f60
Author: Sandra Loosemore <sandra@codesourcery.com>
Date:   Thu Sep 23 08:03:52 2021 -0700

    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:
---
 gcc/fortran/decl.c                           | 14 +++++++++
 gcc/testsuite/gfortran.dg/c-interop/c516.f90 | 46 ++++++++++++++++++++++++++--
 2 files changed, 58 insertions(+), 2 deletions(-)

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index f2e8896b562..b3c65b7175b 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 208eb846ea5..d6a65affdb2 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