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.

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 612ca41a0169c6e62054b0226ad104ee589248e1..60e94f0bdc242514075bbb449b61527900b732aa 100644 (file)
--- 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 (file)
index 0000000..8bb7ea1
--- /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 943fc69ed47732363d684bf365e2dcbef0825ff5..60c88ff902178d876260327a74f02d9996194374 100644 (file)
--- 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;