This patch fixes some bugs in handling of assumed-rank arguments
revealed by the TS29113 testsuite, allowing xfails to be removed from
those testcases. It was previously failing to diagnose an error when
passing an assumed-rank argument to a procedure via a non-assumed-rank
dummy, and giving a bogus error when passing one as the first argument
to the ASSOCIATED intrinsic. Both fixes turned out to be 1-liners. OK
to commit?
-Sandra
commit b967fe5f88a5245163f235cfa6a5808aa41e88f4
Author: Sandra Loosemore <san...@codesourcery.com>
Date: Sun Sep 19 17:32:03 2021 -0700
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 <san...@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/
* testsuite/gfortran.dg/c-interop/c535b-2.f90: Remove xfails.
* testsuite/gfortran.dg/c-interop/c535b-3.f90: Likewise.
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
