}
else
{
- /* If has_vector, pass descriptor for whole array and the
- vector bounds separately. */
- gfc_array_ref *ar, ar2;
- bool has_vector = false;
+ bool has_vector = gfc_has_vector_subscript (lhs_expr);
- if (gfc_is_coindexed (lhs_expr) && gfc_has_vector_subscript (lhs_expr))
+ if (gfc_is_coindexed (lhs_expr) || !has_vector)
{
- has_vector = true;
- ar = gfc_find_array_ref (lhs_expr);
- ar2 = *ar;
- memset (ar, '\0', sizeof (*ar));
- ar->as = ar2.as;
- ar->type = AR_FULL;
+ /* If has_vector, pass descriptor for whole array and the
+ vector bounds separately. */
+ gfc_array_ref *ar, ar2;
+ bool has_tmp_lhs_array = false;
+ if (has_vector)
+ {
+ has_tmp_lhs_array = true;
+ ar = gfc_find_array_ref (lhs_expr);
+ ar2 = *ar;
+ memset (ar, '\0', sizeof (*ar));
+ ar->as = ar2.as;
+ ar->type = AR_FULL;
+ }
+ lhs_se.want_pointer = 1;
+ gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
+ /* Using gfc_conv_expr_descriptor, we only get the descriptor, but
+ that has the wrong type if component references are done. */
+ lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
+ tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
+ gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
+ gfc_get_dtype_rank_type (has_vector ? ar2.dimen
+ : lhs_expr->rank,
+ lhs_type));
+ if (has_tmp_lhs_array)
+ {
+ vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2);
+ *ar = ar2;
+ }
}
- lhs_se.want_pointer = 1;
- gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
- /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
- has the wrong type if component references are done. */
- lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
- tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
- gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
- gfc_get_dtype_rank_type (has_vector ? ar2.dimen
- : lhs_expr->rank,
- lhs_type));
- if (has_vector)
+ else
{
- vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2);
- *ar = ar2;
+ /* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to
+ indexed array expression. This is rewritten to:
+
+ tmp_array = arr2[...]
+ arr1 ([...]) = tmp_array
+
+ because using the standard gfc_conv_expr (lhs_expr) did the
+ assignment with lhs and rhs exchanged. */
+
+ gfc_ss *lss_for_tmparray, *lss_real;
+ gfc_loopinfo loop;
+ gfc_se se;
+ stmtblock_t body;
+ tree tmparr_desc, src;
+ tree index = gfc_index_zero_node;
+ tree stride = gfc_index_zero_node;
+ int n;
+
+ /* Walk both sides of the assignment, once to get the shape of the
+ temporary array to create right. */
+ lss_for_tmparray = gfc_walk_expr (lhs_expr);
+ /* And a second time to be able to create an assignment of the
+ temporary to the lhs_expr. gfc_trans_create_temp_array replaces
+ the tree in the descriptor with the one for the temporary
+ array. */
+ lss_real = gfc_walk_expr (lhs_expr);
+ gfc_init_loopinfo (&loop);
+ gfc_add_ss_to_loop (&loop, lss_for_tmparray);
+ gfc_add_ss_to_loop (&loop, lss_real);
+ gfc_conv_ss_startstride (&loop);
+ gfc_conv_loop_setup (&loop, &lhs_expr->where);
+ lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
+ gfc_trans_create_temp_array (&lhs_se.pre, &lhs_se.post,
+ lss_for_tmparray, lhs_type, NULL_TREE,
+ false, true, false,
+ &lhs_expr->where);
+ tmparr_desc = lss_for_tmparray->info->data.array.descriptor;
+ gfc_start_scalarized_body (&loop, &body);
+ gfc_init_se (&se, NULL);
+ gfc_copy_loopinfo_to_se (&se, &loop);
+ se.ss = lss_real;
+ gfc_conv_expr (&se, lhs_expr);
+ gfc_add_block_to_block (&body, &se.pre);
+
+ /* Walk over all indexes of the loop. */
+ for (n = loop.dimen - 1; n > 0; --n)
+ {
+ tmp = loop.loopvar[n];
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, tmp, loop.from[n]);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, tmp, index);
+
+ stride = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ loop.to[n - 1], loop.from[n - 1]);
+ stride = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ stride, gfc_index_one_node);
+
+ index = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, tmp, stride);
+ }
+
+ index = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ index, loop.from[0]);
+
+ index = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ loop.loopvar[0], index);
+
+ src = build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc));
+ src = gfc_build_array_ref (src, index, NULL);
+ /* Now create the assignment of lhs_expr = tmp_array. */
+ gfc_add_modify (&body, se.expr, src);
+ gfc_add_block_to_block (&body, &se.post);
+ lhs_se.expr = gfc_build_addr_expr (NULL_TREE, tmparr_desc);
+ gfc_trans_scalarizing_loops (&loop, &body);
+ gfc_add_block_to_block (&loop.pre, &loop.post);
+ gfc_add_expr_to_block (&lhs_se.post, gfc_finish_block (&loop.pre));
+ gfc_free_ss (lss_for_tmparray);
+ gfc_free_ss (lss_real);
}
}
--- /dev/null
+! { dg-do run }
+
+! Test that index vector on lhs of caf-expression works correctly.
+
+program pr81773
+
+ integer, parameter :: ndim = 5
+ integer :: i
+ integer :: vec(ndim) = -1
+ integer :: res(ndim)[*] = [ (i, i=1, ndim) ]
+ type T
+ integer :: padding
+ integer :: dest(ndim)
+ integer :: src(ndim)
+ end type
+
+ type(T) :: dest
+ type(T), allocatable :: caf[:]
+
+ vec([ndim, 3, 1]) = res(1:3)[1]
+ if (any (vec /= [ 3, -1, 2, -1, 1])) stop 1
+
+ dest = T(42, [ ( -1, i = 1, ndim ) ], [ ( i - 2, i = ndim, 1, -1) ] )
+ dest%dest([ 4,3,2 ]) = res(3:5)[1]
+ if (any (dest%dest /= [-1, 5, 4, 3, -1])) stop 2
+
+ vec(:) = -1
+ allocate(caf[*], source = T(42, [ ( -1, i = 1, ndim ) ], [ ( i - 2, i = ndim, 1, -1) ] ))
+ vec([ 5,3,2 ]) = caf[1]%src(2:4)
+ if (any (vec /= [ -1, 0, 1, -1, 2])) stop 3
+end
+
projects / gcc.git / commitdiff