static void
-trans_this_image (gfc_se * se, gfc_expr *expr ATTRIBUTE_UNUSED)
+trans_this_image (gfc_se * se, gfc_expr *expr)
{
+ stmtblock_t loop;
+ tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
+ lbound, ubound, extent, ml;
+ gfc_se argse;
+ gfc_ss *ss;
+ int rank, corank;
+
+ /* The case -fcoarray=single is handled elsewhere. */
+ gcc_assert (gfc_option.coarray != GFC_FCOARRAY_SINGLE);
+
gfc_init_coarray_decl ();
- se->expr = gfort_gvar_caf_this_image;
+
+ /* Argument-free version: THIS_IMAGE(). */
+ if (expr->value.function.actual->expr == NULL)
+ {
+ se->expr = gfort_gvar_caf_this_image;
+ return;
+ }
+
+ /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
+
+ type = gfc_get_int_type (gfc_default_integer_kind);
+ corank = gfc_get_corank (expr->value.function.actual->expr);
+ rank = expr->value.function.actual->expr->rank;
+
+ /* Obtain the descriptor of the COARRAY. */
+ gfc_init_se (&argse, NULL);
+ ss = gfc_walk_expr (expr->value.function.actual->expr);
+ gcc_assert (ss != gfc_ss_terminator);
+ ss->data.info.codimen = corank;
+ gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&se->post, &argse.post);
+ desc = argse.expr;
+
+ if (se->ss)
+ {
+ /* Create an implicit second parameter from the loop variable. */
+ gcc_assert (!expr->value.function.actual->next->expr);
+ gcc_assert (corank > 0);
+ gcc_assert (se->loop->dimen == 1);
+ gcc_assert (se->ss->expr == expr);
+
+ dim_arg = se->loop->loopvar[0];
+ dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, dim_arg,
+ gfc_rank_cst[rank]);
+ gfc_advance_se_ss_chain (se);
+ }
+ else
+ {
+ /* Use the passed DIM= argument. */
+ gcc_assert (expr->value.function.actual->next->expr);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
+ gfc_array_index_type);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ dim_arg = argse.expr;
+
+ if (INTEGER_CST_P (dim_arg))
+ {
+ int hi, co_dim;
+
+ hi = TREE_INT_CST_HIGH (dim_arg);
+ co_dim = TREE_INT_CST_LOW (dim_arg);
+ if (hi || co_dim < 1
+ || co_dim > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))
+ gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
+ "dimension index", expr->value.function.isym->name,
+ &expr->where);
+ }
+ else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+ {
+ dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
+ cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ dim_arg,
+ build_int_cst (TREE_TYPE (dim_arg), 1));
+ tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
+ tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ dim_arg, tmp);
+ cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+ boolean_type_node, cond, tmp);
+ gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
+ gfc_msg_fault);
+ }
+ }
+
+ /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
+ one always has a dim_arg argument.
+
+ m = this_images() - 1
+ i = rank
+ min_var = min (corank - 2, dim_arg)
+ for (;;)
+ {
+ extent = gfc_extent(i)
+ ml = m
+ m = m/extent
+ if (i >= min_var)
+ goto exit_label
+ i++
+ }
+ exit_label:
+ sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
+ : m + lcobound(corank)
+ */
+
+ m = gfc_create_var (type, NULL);
+ ml = gfc_create_var (type, NULL);
+ loop_var = gfc_create_var (integer_type_node, NULL);
+ min_var = gfc_create_var (integer_type_node, NULL);
+
+ /* m = this_image () - 1. */
+ tmp = fold_convert (type, gfort_gvar_caf_this_image);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, type, tmp,
+ build_int_cst (type, 1));
+ gfc_add_modify (&se->pre, m, tmp);
+
+ /* min_var = min (rank+corank-2, dim_arg). */
+ tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
+ build_int_cst (integer_type_node, rank + corank - 2),
+ fold_convert (integer_type_node, dim_arg));
+ gfc_add_modify (&se->pre, min_var, tmp);
+
+ /* i = rank. */
+ tmp = build_int_cst (integer_type_node, rank);
+ gfc_add_modify (&se->pre, loop_var, tmp);
+
+ exit_label = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (exit_label) = 1;
+
+ /* Loop body. */
+ gfc_init_block (&loop);
+
+ /* ml = m. */
+ gfc_add_modify (&loop, ml, m);
+
+ /* extent = ... */
+ lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
+ ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
+ extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ extent = fold_convert (type, extent);
+
+ /* m = m/extent. */
+ gfc_add_modify (&loop, m,
+ fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
+ m, extent));
+
+ /* Exit condition: if (i >= min_var) goto exit_label. */
+ cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, loop_var,
+ min_var);
+ tmp = build1_v (GOTO_EXPR, exit_label);
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&loop, tmp);
+
+ /* Increment loop variable: i++. */
+ gfc_add_modify (&loop, loop_var,
+ fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+ loop_var,
+ build_int_cst (integer_type_node, 1)));
+
+ /* Making the loop... actually loop! */
+ tmp = gfc_finish_block (&loop);
+ tmp = build1_v (LOOP_EXPR, tmp);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* The exit label. */
+ tmp = build1_v (LABEL_EXPR, exit_label);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
+ : m + lcobound(corank) */
+
+ cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, dim_arg,
+ build_int_cst (TREE_TYPE (dim_arg), corank));
+
+ lbound = gfc_conv_descriptor_lbound_get (desc,
+ fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, dim_arg,
+ gfc_rank_cst[rank - 1]));
+ lbound = fold_convert (type, lbound);
+
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
+ fold_build2_loc (input_location, MULT_EXPR, type,
+ m, extent));
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
+
+ se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
+ fold_build2_loc (input_location, PLUS_EXPR, type,
+ m, lbound));
}
if (se->ss)
{
- mpz_t mpz_rank;
- tree tree_rank;
-
/* Create an implicit second parameter from the loop variable. */
gcc_assert (!arg2->expr);
gcc_assert (corank > 0);
gcc_assert (se->loop->dimen == 1);
gcc_assert (se->ss->expr == expr);
- mpz_init_set_ui (mpz_rank, arg->expr->rank);
- tree_rank = gfc_conv_mpz_to_tree (mpz_rank, gfc_index_integer_kind);
-
bound = se->loop->loopvar[0];
bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- bound, se->ss->data.info.delta[0]);
- bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- bound, tree_rank);
+ bound, gfc_rank_cst[arg->expr->rank]);
gfc_advance_se_ss_chain (se);
}
else
break;
case GFC_ISYM_THIS_IMAGE:
- if (expr->value.function.actual->expr)
+ /* For num_images() == 1, handle as LCOBOUND. */
+ if (expr->value.function.actual->expr
+ && gfc_option.coarray == GFC_FCOARRAY_SINGLE)
conv_intrinsic_cobound (se, expr);
else
trans_this_image (se, expr);
--- /dev/null
+! { dg-do run }
+! { dg-options "-fcoarray=lib -lcaf_single" }
+!
+! PR fortran/18918
+!
+! this_image(coarray) run test,
+! expecially for num_images > 1
+!
+! Tested are values up to num_images == 8,
+! higher values are OK, but not tested for
+!
+implicit none
+integer :: a(1)[2:2, 3:4, 7:*]
+integer :: b(:)[:, :,:]
+allocatable :: b
+integer :: i
+
+if (this_image(A, dim=1) /= 2) call abort()
+i = 1
+if (this_image(A, dim=i) /= 2) call abort()
+
+select case (this_image())
+ case (1)
+ if (this_image(A, dim=2) /= 3) call abort()
+ if (this_image(A, dim=3) /= 7) call abort()
+ i = 2
+ if (this_image(A, dim=i) /= 3) call abort()
+ i = 3
+ if (this_image(A, dim=i) /= 7) call abort()
+ if (any (this_image(A) /= [2,3,7])) call abort()
+
+ case (2)
+ if (this_image(A, dim=2) /= 4) call abort()
+ if (this_image(A, dim=3) /= 7) call abort()
+ i = 2
+ if (this_image(A, dim=i) /= 4) call abort()
+ i = 3
+ if (this_image(A, dim=i) /= 7) call abort()
+ if (any (this_image(A) /= [2,4,7])) call abort()
+
+ case (3)
+ if (this_image(A, dim=2) /= 3) call abort()
+ if (this_image(A, dim=3) /= 8) call abort()
+ i = 2
+ if (this_image(A, dim=i) /= 3) call abort()
+ i = 3
+ if (this_image(A, dim=i) /= 8) call abort()
+ if (any (this_image(A) /= [2,3,8])) call abort()
+
+ case (4)
+ if (this_image(A, dim=2) /= 4) call abort()
+ if (this_image(A, dim=3) /= 8) call abort()
+ i = 2
+ if (this_image(A, dim=i) /= 4) call abort()
+ i = 3
+ if (this_image(A, dim=i) /= 8) call abort()
+ if (any (this_image(A) /= [2,4,8])) call abort()
+
+ case (5)
+ if (this_image(A, dim=2) /= 3) call abort()
+ if (this_image(A, dim=3) /= 9) call abort()
+ i = 2
+ if (this_image(A, dim=i) /= 3) call abort()
+ i = 3
+ if (this_image(A, dim=i) /= 9) call abort()
+ if (any (this_image(A) /= [2,3,9])) call abort()
+
+ case (6)
+ if (this_image(A, dim=2) /= 4) call abort()
+ if (this_image(A, dim=3) /= 9) call abort()
+ i = 2
+ if (this_image(A, dim=i) /= 4) call abort()
+ i = 3
+ if (this_image(A, dim=i) /= 9) call abort()
+ if (any (this_image(A) /= [2,4,9])) call abort()
+
+ case (7)
+ if (this_image(A, dim=2) /= 3) call abort()
+ if (this_image(A, dim=3) /= 10) call abort()
+ i = 2
+ if (this_image(A, dim=i) /= 3) call abort()
+ i = 3
+ if (this_image(A, dim=i) /= 10) call abort()
+ if (any (this_image(A) /= [2,3,10])) call abort()
+
+ case (8)
+ if (this_image(A, dim=2) /= 4) call abort()
+ if (this_image(A, dim=3) /= 10) call abort()
+ i = 2
+ if (this_image(A, dim=i) /= 4) call abort()
+ i = 3
+ if (this_image(A, dim=i) /= 10) call abort()
+ if (any (this_image(A) /= [2,4,10])) call abort()
+end select
+
+
+allocate (b(3)[-1:0,2:4,*])
+
+select case (this_image())
+ case (1)
+ if (this_image(B, dim=1) /= -1) call abort()
+ if (this_image(B, dim=2) /= 2) call abort()
+ if (this_image(B, dim=3) /= 1) call abort()
+ i = 1
+ if (this_image(B, dim=i) /= -1) call abort()
+ i = 2
+ if (this_image(B, dim=i) /= 2) call abort()
+ i = 3
+ if (this_image(B, dim=i) /= 1) call abort()
+ if (any (this_image(B) /= [-1,2,1])) call abort()
+
+ case (2)
+ if (this_image(B, dim=1) /= 0) call abort()
+ if (this_image(B, dim=2) /= 2) call abort()
+ if (this_image(B, dim=3) /= 1) call abort()
+ i = 1
+ if (this_image(B, dim=i) /= 0) call abort()
+ i = 2
+ if (this_image(B, dim=i) /= 2) call abort()
+ i = 3
+ if (this_image(B, dim=i) /= 1) call abort()
+ if (any (this_image(B) /= [0,2,1])) call abort()
+
+ case (3)
+ if (this_image(B, dim=1) /= -1) call abort()
+ if (this_image(B, dim=2) /= 3) call abort()
+ if (this_image(B, dim=3) /= 1) call abort()
+ i = 1
+ if (this_image(B, dim=i) /= -1) call abort()
+ i = 2
+ if (this_image(B, dim=i) /= 3) call abort()
+ i = 3
+ if (this_image(B, dim=i) /= 1) call abort()
+ if (any (this_image(B) /= [-1,3,1])) call abort()
+
+ case (4)
+ if (this_image(B, dim=1) /= 0) call abort()
+ if (this_image(B, dim=2) /= 3) call abort()
+ if (this_image(B, dim=3) /= 1) call abort()
+ i = 1
+ if (this_image(B, dim=i) /= 0) call abort()
+ i = 2
+ if (this_image(B, dim=i) /= 3) call abort()
+ i = 3
+ if (this_image(B, dim=i) /= 1) call abort()
+ if (any (this_image(B) /= [0,3,1])) call abort()
+
+ case (5)
+ if (this_image(B, dim=1) /= -1) call abort()
+ if (this_image(B, dim=2) /= 4) call abort()
+ if (this_image(B, dim=3) /= 1) call abort()
+ i = 1
+ if (this_image(B, dim=i) /= -1) call abort()
+ i = 2
+ if (this_image(B, dim=i) /= 4) call abort()
+ i = 3
+ if (this_image(B, dim=i) /= 1) call abort()
+ if (any (this_image(B) /= [-1,4,1])) call abort()
+
+ case (6)
+ if (this_image(B, dim=1) /= 0) call abort()
+ if (this_image(B, dim=2) /= 4) call abort()
+ if (this_image(B, dim=3) /= 1) call abort()
+ i = 1
+ if (this_image(B, dim=i) /= 0) call abort()
+ i = 2
+ if (this_image(B, dim=i) /= 4) call abort()
+ i = 3
+ if (this_image(B, dim=i) /= 1) call abort()
+ if (any (this_image(B) /= [0,4,1])) call abort()
+
+ case (7)
+ if (this_image(B, dim=1) /= -1) call abort()
+ if (this_image(B, dim=2) /= 2) call abort()
+ if (this_image(B, dim=3) /= 2) call abort()
+ i = 1
+ if (this_image(B, dim=i) /= -1) call abort()
+ i = 2
+ if (this_image(B, dim=i) /= 2) call abort()
+ i = 3
+ if (this_image(B, dim=i) /= 2) call abort()
+ if (any (this_image(B) /= [-1,2,2])) call abort()
+
+ case (8)
+ if (this_image(B, dim=1) /= 0) call abort()
+ if (this_image(B, dim=2) /= 2) call abort()
+ if (this_image(B, dim=3) /= 2) call abort()
+ i = 1
+ if (this_image(B, dim=i) /= 0) call abort()
+ i = 2
+ if (this_image(B, dim=i) /= 2) call abort()
+ i = 3
+ if (this_image(B, dim=i) /= 2) call abort()
+ if (any (this_image(B) /= [0,2,2])) call abort()
+end select
+
+end
projects / gcc.git / commitdiff