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.

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..8bb7ea158c9
--- /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;