[Fortran] Fixes for F2018 C838 (PR fortran/101334)
Commit Message
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
Comments
On 20.09.21 06:01, Sandra Loosemore wrote:
> 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?
OK - however, I think you should first commit your follow-up/second patch (fix testsuite)
to avoid intermittent test-suite fails.
Additionally, if I try the following testcase, which is now permitted, I get
two ICEs. Can you check?
* The first one seems to be a bug in gfc_conv_intrinsic_function, which
assumes also for assumed rank that if the first argument is an array,
the second argument must also be an array.
* For the second one, I see in the dump:
p->dim[p->dtype.rank + -1].stride
is seems as '-1' is gfc_array_index_type while 'dtype.rank' is signed_char_type_node.
(Disclaimer: I don't have a clean tree, but I think this issue not affected
by my patches.)
subroutine foo(p, lp, lpd)
use iso_c_binding
implicit none (type, external)
real, pointer :: p(..)
real, pointer :: lp
real, pointer :: lpd(:,:)
! gfc_conv_expr_descriptor, at fortran/trans-array.c:7324
if (associated(p, lp)) stop 1
! verify_gimple: type mismatch in binary expression - signed char, signed char, integer(kind=8), _4 = _3 + -1;
if (associated(p, lpd)) stop 1
end
Tobias
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
Hi Sandra,
> 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?
OK.
Thanks for the patch!
Best regards
Thomas
commit b967fe5f88a5245163f235cfa6a5808aa41e88f4
Author: Sandra Loosemore <sandra@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 <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/
* testsuite/gfortran.dg/c-interop/c535b-2.f90: Remove xfails.
* testsuite/gfortran.dg/c-interop/c535b-3.f90: Likewise.
@@ -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)
{
@@ -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
@@ -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
@@ -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