[PATCH, Fortran] Fixes for F2018 C838 (PR fortran/101334)

[PATCH, Fortran] Fixes for F2018 C838 (PR fortran/101334)

[Sandra Loosemore]

[-- Attachment #1: Type: text/plain, Size: 445 bytes --]

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

[-- Attachment #2: pr101334.patch --]
[-- Type: text/x-patch, Size: 5407 bytes --]

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.

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
 

Re: [PATCH, Fortran] Fixes for F2018 C838 (PR fortran/101334)

[Tobias Burnus]

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

Re: [PATCH, Fortran] Fixes for F2018 C838 (PR fortran/101334)

[Thomas Koenig]

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

[Patch] Fortran: Fix associated intrinsic with assumed rank [PR101334] [was: [PATCH, Fortran] Fixes for F2018 C838 (PR fortran/101334)]

[Tobias Burnus]

[-- Attachment #1: Type: text/plain, Size: 1584 bytes --]

On 20.09.21 09:58, Tobias Burnus wrote:

> 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, ... giving a bogus error when
>> passing one as the first argument to the ASSOCIATED intrinsic.  ...
>
> ...  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.

I fixed that issue + extended the testcase.

OK for mainline?

Tobias

PS: Sorry for the testcase, it should have used a separate function for
scalar vs. array target, but it somehow evolved like that.

PPS: Pending patches: (1) this one, (2) "Fortran: Improve file-reading
error diagnostic [PR55534]" (third in the series), (3) "[Patch] Fortran:
Fix assumed-size to assumed-rank passing [PR94070]" – plus (4) GFC<->CFI
array-descriptor conversion patch, but I will repost an
extended/cleaned-up version soon.

-----------------
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

[-- Attachment #2: assumed-rank-assoc.diff --]
[-- Type: text/x-patch, Size: 7699 bytes --]

Fortran: Fix associated intrinsic with assumed rank [PR101334]

ASSOCIATE (ptr, tgt) takes as first argument also an assumed-rank array;
however, using it together with a tgt (required to be non assumed rank)
had issues for both scalar and nonscalar tgt.

	PR fortran/101334
gcc/fortran/ChangeLog:

	* trans-intrinsic.c (gfc_conv_associated): Support assumed-rank
	'pointer' with scalar/array 'target' argument.

libgfortran/ChangeLog:

	* intrinsics/associated.c (associated): Also check for same rank.

gcc/testsuite/ChangeLog:

	* gfortran.dg/associated_assumed_rank.f90: New test.

 gcc/fortran/trans-intrinsic.c                      |  30 +++--
 .../gfortran.dg/associated_assumed_rank.f90        | 126 +++++++++++++++++++++
 libgfortran/intrinsics/associated.c                |   3 +-
 3 files changed, 149 insertions(+), 10 deletions(-)

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 612ca41a016..60e94f0bdc2 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -8974,7 +8974,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
   gfc_se arg2se;
   tree tmp2;
   tree tmp;
-  tree nonzero_arraylen;
+  tree nonzero_arraylen = NULL_TREE;
   gfc_ss *ss;
   bool scalar;
 
@@ -9074,14 +9074,16 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
 	    {
 	      tmp = gfc_conv_descriptor_rank (arg1se.expr);
 	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
-				     TREE_TYPE (tmp), tmp, gfc_index_one_node);
+				     TREE_TYPE (tmp), tmp,
+				     build_int_cst (TREE_TYPE (tmp), 1));
 	    }
 	  else
 	    tmp = gfc_rank_cst[arg1->expr->rank - 1];
 	  tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
-	  nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
-					      logical_type_node, tmp,
-					      build_int_cst (TREE_TYPE (tmp), 0));
+	  if (arg2->expr->rank != 0)
+	    nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
+						logical_type_node, tmp,
+						build_int_cst (TREE_TYPE (tmp), 0));
 
 	  /* A pointer to an array, call library function _gfor_associated.  */
 	  arg1se.want_pointer = 1;
@@ -9091,16 +9093,26 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
 
 	  arg2se.want_pointer = 1;
 	  arg2se.force_no_tmp = 1;
-	  gfc_conv_expr_descriptor (&arg2se, arg2->expr);
+	  if (arg2->expr->rank != 0)
+	    gfc_conv_expr_descriptor (&arg2se, arg2->expr);
+	  else
+	    {
+	      gfc_conv_expr (&arg2se, arg2->expr);
+	      arg2se.expr
+		= gfc_conv_scalar_to_descriptor (&arg2se, arg2se.expr,
+						 gfc_expr_attr (arg2->expr));
+	      arg2se.expr = gfc_build_addr_expr (NULL_TREE, arg2se.expr);
+	    }
 	  gfc_add_block_to_block (&se->pre, &arg2se.pre);
 	  gfc_add_block_to_block (&se->post, &arg2se.post);
 	  se->expr = build_call_expr_loc (input_location,
 				      gfor_fndecl_associated, 2,
 				      arg1se.expr, arg2se.expr);
 	  se->expr = convert (logical_type_node, se->expr);
-	  se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
-				      logical_type_node, se->expr,
-				      nonzero_arraylen);
+	  if (arg2->expr->rank != 0)
+	    se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+					logical_type_node, se->expr,
+					nonzero_arraylen);
         }
 
       /* If target is present zero character length pointers cannot
diff --git a/gcc/testsuite/gfortran.dg/associated_assumed_rank.f90 b/gcc/testsuite/gfortran.dg/associated_assumed_rank.f90
new file mode 100644
index 00000000000..f1b91998006
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associated_assumed_rank.f90
@@ -0,0 +1,126 @@
+! { dg-do run }
+
+! PR fortran/101334
+
+implicit none (type, external)
+real, target :: AT(10,10), BT
+real, contiguous, pointer :: A(:,:)
+real, pointer :: B
+real, pointer :: AP(:,:), BP
+real, pointer :: CP(:), DP(:,:), D, EP(:)
+
+call test_char()
+
+A => AT
+B => BT
+
+AP => A
+BP => B
+call foo(AP,B, A, 1) ! OK - associated
+call foo(BP,B, A, 2) !  OK - associated
+
+! Those are all not associated:
+
+AP => null()
+BP => null()
+call foo(AP, B, A, 3) ! LHS not associated
+call foo(BP, B, A, 4) ! LHS not associated
+
+DP => null()
+D => null()
+call foo(AP, B, DP, 5) ! LHS+RHS not associated
+call foo(BP, D, A, 6)  ! LHS+RHS not associated
+
+AP => A
+BP => B
+call foo(AP, B, DP, 7) ! RHS not associated
+call foo(BP, D, A, 8)  ! RHS not associated
+
+CP(1:size(A)) => A
+call foo(CP, B, A, 9)  ! Shape (rank) differs
+
+AP => A(2:,:)
+call foo(AP, B, A, 10)  ! Shape differs
+
+AP => A(:,2:)
+call foo(AP, B, A, 11)  ! Shape differs
+
+AP(10:,10:) => A
+call foo(AP, B, A, 12)  ! OK - bounds different, shape same
+
+CP => AT(1:-1, 5)
+EP => AT(1:-1, 5)        ! Case(i) + case(iv)
+call foo2(CP, EP)  ! CP associated - but CP not associated with EP
+contains
+subroutine foo2(p, lpd)
+  implicit none (type, external)
+  real, pointer :: p(..)    ! "pointer"
+  real, pointer :: lpd(:) ! array "target"
+  if (.not.associated(p)) stop 18 ! OK - associated 
+  if (associated(p, lpd)) stop 19 ! .. but for zero-sized array
+end
+
+subroutine foo(p, lp, lpd, cnt)
+  implicit none (type, external)
+  real, pointer :: p(..)    ! "pointer"
+  real, pointer :: lp       ! scalar "target"
+  real, pointer :: lpd(:,:) ! array "target"
+  integer, value :: cnt
+
+  if (cnt == 1) then
+    if (.not. associated(p, lpd)) stop 1  ! OK
+  elseif (cnt == 2) then
+    if (.not. associated(p, lp)) stop 2   ! OK
+  elseif (cnt == 3) then
+    if (associated(p, lpd)) stop 3 ! LHS NULL ptr
+    if (associated(p)) stop 4      ! LHS NULL ptr
+  elseif (cnt == 4) then
+    if (associated(p, lp)) stop 5  ! LHS NULL ptr
+    if (associated(p)) stop 6      ! LHS NULL ptr
+  elseif (cnt == 5) then
+    if (associated(p, lpd)) stop 7 ! LHS+RHS NULL ptr
+    if (associated(p)) stop 8      ! LHS+RHS NULL ptr
+  elseif (cnt == 6) then
+    if (associated(p, lp)) stop 9  ! LHS+RHS NULL ptr
+    if (associated(p)) stop 10      ! LHS+RHS NULL ptr
+  elseif (cnt == 7) then
+    if (associated(p, lpd)) stop 11 ! RHS NULL ptr
+  elseif (cnt == 8) then
+    if (associated(p, lp)) stop 12  ! RHS NULL ptr
+  elseif (cnt == 9) then
+    if (associated(p, lpd)) stop 13 ! rank differs
+    if (associated(p, lp)) stop 14  ! rank differs
+  elseif (cnt == 10) then
+    if (associated(p, lpd)) stop 15 ! shape differs
+  elseif (cnt == 11) then
+    if (associated(p, lpd)) stop 16 ! shape differs
+  elseif (cnt == 12) then
+    if (.not.associated(p, lpd)) stop 17 ! OK - shape same, lbound different
+  else
+    stop 99
+  endif
+end 
+subroutine test_char()
+  character(len=0), target :: str0
+  character(len=2), target :: str2
+  character(len=:), pointer :: ptr
+  ptr => str0
+  call test_char2(ptr, str0)
+  ptr => str2
+  call test_char2(ptr, str2)
+end
+subroutine test_char2(x,y)
+  character(len=:), pointer :: x
+  character(len=*), target :: y
+  if (len(y) == 0) then
+    if (len(x) /= 0) stop 20
+    if (.not. associated(x)) stop 21
+    if (associated(x, y)) stop 22
+  else
+    if (len(y) /= 2) stop 23
+    if (len(x) /= 2) stop 24
+    if (.not. associated(x)) stop 25
+    if (.not. associated(x, y)) stop 26
+  end if
+end
+end
diff --git a/libgfortran/intrinsics/associated.c b/libgfortran/intrinsics/associated.c
index 943fc69ed47..60c88ff9021 100644
--- a/libgfortran/intrinsics/associated.c
+++ b/libgfortran/intrinsics/associated.c
@@ -41,8 +41,9 @@ associated (const gfc_array_void *pointer, const gfc_array_void *target)
     return 0;
   if (GFC_DESCRIPTOR_DTYPE (pointer).type != GFC_DESCRIPTOR_DTYPE (target).type)
     return 0;
-
   rank = GFC_DESCRIPTOR_RANK (pointer);
+  if (rank != GFC_DESCRIPTOR_RANK (target))
+    return 0;
   for (n = 0; n < rank; n++)
     {
       long extent;

Re: [Patch] Fortran: Fix associated intrinsic with assumed rank [PR101334] [was: [PATCH, Fortran] Fixes for F2018 C838 (PR fortran/101334)]

[Thomas Koenig]

On 23.09.21 21:13, Tobias Burnus wrote:
> On 20.09.21 09:58, Tobias Burnus wrote:
> 
>> 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, ... giving a bogus error when
>>> passing one as the first argument to the ASSOCIATED intrinsic.  ...
>>
>> ...  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.
> 
> I fixed that issue + extended the testcase.
> 
> OK for mainline?

Hi Tobias,

looks good to me.

Thanks for the patch!

Best regards

	Thomas