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.

4 files changed, 13 insertions, 10 deletions

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 851af1b..f31ad68 100644
--- 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 9e3e8aa..f9a7c9c 100644
--- 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 7bff14f..2dafd44 100644
--- 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 6427bd6..23862e5 100644
--- 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