Fortran: Fixes for F2018 C838 (PR fortran/101334)

The compiler was failing to diagnose the error required by F2018 C838
when passing an assumed-rank array argument to a non-assumed-rank dummy.
It was also incorrectly giving an error for calls to the 2-argument form
of the ASSOCIATED intrinsic, which is supposed to be permitted by C838.

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

	PR fortran/101334

gcc/fortran/
	* check.c (gfc_check_associated): Allow an assumed-rank
	array for the pointer argument.
	* interface.c (compare_parameter): Also give rank mismatch
	error on assumed-rank array.

gcc/testsuite/
	* gfortran.dg/c-interop/c535b-2.f90: Remove xfails.
	* gfortran.dg/c-interop/c535b-3.f90: Likewise.

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 851af1b30dc18cad6f8074130ff13395a73a04a9..f31ad68053b36c1920f8a225d5628c9699182c6f 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -1520,7 +1520,9 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
   t = true;
   if (!same_type_check (pointer, 0, target, 1, true))
     t = false;
-  if (!rank_check (target, 0, pointer->rank))
+  /* F2018 C838 explicitly allows an assumed-rank variable as the first
+     argument of intrinsic inquiry functions.  */
+  if (pointer->rank != -1 && !rank_check (target, 0, pointer->rank))
     t = false;
   if (target->rank > 0)
     {

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 9e3e8aa9da9e66d7d7da2522d38dfa1d873264bc..f9a7c9ca6f8c73b6ecd16e0c4574e2dbaabb6a15 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2634,7 +2634,9 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
                   && formal->as->type == AS_ASSUMED_SHAPE))
          && actual->expr_type != EXPR_NULL)
       || (actual->rank == 0 && formal->attr.dimension
-         && gfc_is_coindexed (actual)))
+         && gfc_is_coindexed (actual))
+      /* Assumed-rank actual argument; F2018 C838.  */
+      || actual->rank == -1)
     {
       if (where
          && (!formal->attr.artificial || (!formal->maybe_array

diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535b-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535b-2.f90
index 7bff14fe9efe842baf603ed5556d809552c290df..2dafd4490c3bf357674102d03aea2ab954ddd4ae 100644 (file)
--- a/gcc/testsuite/gfortran.dg/c-interop/c535b-2.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/c535b-2.f90
@@ -61,15 +61,14 @@ subroutine test_calls (x, y)
   ! assumed-rank dummies
   call g (x, y)  ! OK
   ! assumed-size dummies
-  call h (x, &  ! { dg-error "(A|a)ssumed.rank" "pr101334" { xfail *-*-* } }
+  call h (x, &  ! { dg-error "(A|a)ssumed.rank" "pr101334" }
           y)  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
   ! assumed-shape dummies
   call i (x, &  ! { dg-error "(A|a)ssumed.rank" }
           y)  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
  ! fixed-size array dummies
-  call j (x, &  ! { dg-error "(A|a)ssumed.rank" "pr101334" { xfail *-*-* } }
+  call j (x, &  ! { dg-error "(A|a)ssumed.rank" "pr101334" }
           y)  ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
- ! { dg-bogus "Actual argument contains too few elements" "pr101334" { xfail *-*-* } .-2 }
 end subroutine
 
 ! Check that you can't use an assumed-rank array variable in an array

diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535b-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535b-3.f90
index 6427bd658035ca8429133fe97853de3393bf70a4..23862e54d748d53bdec65d6a25f058e85cb2e39c 100644 (file)
--- a/gcc/testsuite/gfortran.dg/c-interop/c535b-3.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/c535b-3.f90
@@ -29,7 +29,7 @@ function test_associated3 (a, b)
   integer, target :: b
   logical :: test_associated3
 
-  test_associated3 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" { xfail *-*-* } }
+  test_associated3 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" }
 end function
 
 function test_associated4 (a, b)
@@ -38,7 +38,7 @@ function test_associated4 (a, b)
   integer, target :: b(:)
   logical :: test_associated4
 
-  test_associated4 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" { xfail *-*-* } }
+  test_associated4 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" }
 end function
 
 function test_associated5 (a, b)
@@ -47,7 +47,7 @@ function test_associated5 (a, b)
   integer, target :: b(20)
   logical :: test_associated5
 
-  test_associated5 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" { xfail *-*-* } }
+  test_associated5 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" }
 end function
 
 function test_associated6 (a, b)
@@ -65,7 +65,7 @@ function test_associated7 (a, b)
   integer, pointer :: b
   logical :: test_associated7
 
-  test_associated7 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" { xfail *-*-* } }
+  test_associated7 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" }
 end function
 
 function test_associated8 (a, b)
@@ -74,6 +74,6 @@ function test_associated8 (a, b)
   integer, pointer :: b(:)
   logical :: test_associated8
 
-  test_associated8 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" { xfail *-*-* } }
+  test_associated8 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" }
 end function