2011-04-16 Tobias Burnus <burnus@net-b.de>
PR fortran/18918
* iresolve.c (gfc_resolve_image_index): Set ts.type.
* simplify.c (gfc_simplify_image_index): Don't abort if the bounds
are not known at compile time and handle -fcoarray=lib.
* trans-intrinsics.c (gfc_conv_intrinsic_function): Handle
IMAGE_INDEX.
(conv_intrinsic_cobound): Fix comment typo.
(trans_this_image): New function.
* trans-array.c (gfc_unlikely): Move to trans.c.
* trans.c (gfc_unlikely): Function moved from trans-array.c.
(gfc_trans_runtime_check): Use it.
* trans-io.c (gfc_trans_io_runtime_check): Ditto.
* trans.h (gfc_unlikely): Add prototype.
2011-04-16 Tobias Burnus <burnus@net-b.de>
PR fortran/18918
* gfortran.dg/coarray_16.f90: New.
@@ -2547,9 +2547,10 @@ void
gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
gfc_expr *sub ATTRIBUTE_UNUSED)
{
- static char this_image[] = "__image_index";
+ static char image_index[] = "__image_index";
+ f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
- f->value.function.name = this_image;
+ f->value.function.name = image_index;
}
@@ -6189,7 +6189,7 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
int d;
if (!is_constant_array_expr (sub))
- goto not_implemented; /* return NULL;*/
+ return NULL;
/* Follow any component references. */
as = coarray->symtree->n.sym->as;
@@ -6198,7 +6198,7 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
as = ref->u.ar.as;
if (as->type == AS_DEFERRED)
- goto not_implemented; /* return NULL;*/
+ return NULL;
/* "valid sequence of cosubscripts" are required; thus, return 0 unless
the cosubscript addresses the first image. */
@@ -6221,7 +6221,7 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
NULL, true);
if (ca_bound == NULL)
- goto not_implemented; /* return NULL */
+ return NULL;
if (ca_bound == &gfc_bad_expr)
return ca_bound;
@@ -6285,6 +6285,10 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
return &gfc_bad_expr;
}
+
+ if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && !first_image)
+ return NULL;
+
result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
&gfc_current_locus);
if (first_image)
@@ -6293,11 +6297,6 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
mpz_set_si (result->value.integer, 0);
return result;
-
-not_implemented:
- gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant "
- "cobounds at %L", &coarray->where);
- return &gfc_bad_expr;
}
@@ -4111,21 +4111,6 @@ gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
}
-/* Helper function for marking a boolean expression tree as unlikely. */
-
-static tree
-gfc_unlikely (tree cond)
-{
- tree tmp;
-
- cond = fold_convert (long_integer_type_node, cond);
- tmp = build_zero_cst (long_integer_type_node);
- cond = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
- cond = fold_convert (boolean_type_node, cond);
- return cond;
-}
-
/* Fills in an array descriptor, and returns the size of the array.
The size will be a simple_val, ie a variable or a constant. Also
calculates the offset of the base. The pointer argument overflow,
@@ -921,6 +921,7 @@ gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
se->expr = fold_convert (type, res);
}
+
static void
trans_this_image (gfc_se * se, gfc_expr *expr ATTRIBUTE_UNUSED)
{
@@ -928,6 +929,133 @@ trans_this_image (gfc_se * se, gfc_expr *expr ATTRIBUTE_UNUSED)
se->expr = gfort_gvar_caf_this_image;
}
+
+static void
+trans_image_index (gfc_se * se, gfc_expr *expr)
+{
+ tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
+ tmp, invalid_bound;
+ gfc_se argse, subse;
+ gfc_ss *ss, *subss;
+ int rank, corank, codim;
+
+ 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;
+
+ /* Obtain a handle to the SUB argument. */
+ gfc_init_se (&subse, NULL);
+ subss = gfc_walk_expr (expr->value.function.actual->next->expr);
+ gcc_assert (subss != gfc_ss_terminator);
+ gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr,
+ subss);
+ gfc_add_block_to_block (&se->pre, &subse.pre);
+ gfc_add_block_to_block (&se->post, &subse.post);
+ subdesc = build_fold_indirect_ref_loc (input_location,
+ gfc_conv_descriptor_data_get (subse.expr));
+
+ /* Fortran 2008 does not require that the values remain in the cobounds,
+ thus we need explicitly check this - and return 0 if they are exceeded. */
+
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
+ tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
+ invalid_bound = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ fold_convert (gfc_array_index_type, tmp),
+ lbound);
+
+ for (codim = corank + rank - 2; codim >= rank; codim--)
+ {
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
+ ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
+ tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
+ cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ fold_convert (gfc_array_index_type, tmp),
+ lbound);
+ invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ boolean_type_node, invalid_bound, cond);
+ cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ fold_convert (gfc_array_index_type, tmp),
+ ubound);
+ invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ boolean_type_node, invalid_bound, cond);
+ }
+
+ invalid_bound = gfc_unlikely (invalid_bound);
+
+
+ /* See Fortran 2008, C.10 for the following algorithm. */
+
+ /* coindex = sub(corank) - lcobound(n). */
+ coindex = fold_convert (gfc_array_index_type,
+ gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
+ NULL));
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
+ coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ fold_convert (gfc_array_index_type, coindex),
+ lbound);
+
+ for (codim = corank + rank - 2; codim >= rank; codim--)
+ {
+ tree extent, ubound;
+
+ /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
+ ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
+ extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+
+ /* coindex *= extent. */
+ coindex = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, coindex, extent);
+
+ /* coindex += sub(codim). */
+ tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
+ coindex = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, coindex,
+ fold_convert (gfc_array_index_type, tmp));
+
+ /* coindex -= lbound(codim). */
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
+ coindex = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, coindex, lbound);
+ }
+
+ coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
+ fold_convert(type, coindex),
+ build_int_cst (type, 1));
+
+ /* Return 0 if "coindex" exceeds num_images(). */
+
+ if (gfc_option.coarray == GFC_FCOARRAY_SINGLE)
+ num_images = build_int_cst (type, 1);
+ else
+ {
+ gfc_init_coarray_decl ();
+ num_images = gfort_gvar_caf_num_images;
+ }
+
+ tmp = gfc_create_var (type, NULL);
+ gfc_add_modify (&se->pre, tmp, coindex);
+
+ cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
+ num_images);
+ cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
+ cond,
+ fold_convert (boolean_type_node, invalid_bound));
+ se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
+ build_int_cst (type, 0), tmp);
+}
+
+
static void
trans_num_images (gfc_se * se)
{
@@ -1233,7 +1361,7 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
ceiling (real (num_images ()) / real (size)) - 1
= (num_images () + size - 1) / size - 1
= (num_images - 1) / size(),
- where size is the product of the extend of all but the last
+ where size is the product of the extent of all but the last
codimension. */
if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && corank > 1)
@@ -6312,6 +6440,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
trans_this_image (se, expr);
break;
+ case GFC_ISYM_IMAGE_INDEX:
+ trans_image_index (se, expr);
+ break;
+
case GFC_ISYM_NUM_IMAGES:
trans_num_images (se);
break;
@@ -267,13 +267,7 @@ gfc_trans_io_runtime_check (tree cond, tree var, int error_code,
}
else
{
- /* Tell the compiler that this isn't likely. */
- cond = fold_convert (long_integer_type_node, cond);
- tmp = build_int_cst (long_integer_type_node, 0);
- cond = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
- cond = fold_convert (boolean_type_node, cond);
-
+ cond = gfc_unlikely (cond);
tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
gfc_add_expr_to_block (pblock, tmp);
}
@@ -505,11 +505,7 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
else
cond = fold_convert (long_integer_type_node, cond);
- tmp = build_int_cst (long_integer_type_node, 0);
- cond = build_call_expr_loc (where->lb->location,
- built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
- cond = fold_convert (boolean_type_node, cond);
-
+ cond = gfc_unlikely (cond);
tmp = fold_build3_loc (where->lb->location, COND_EXPR, void_type_node,
cond, body,
build_empty_stmt (where->lb->location));
@@ -1565,3 +1561,19 @@ gfc_finish_wrapped_block (gfc_wrapped_block* block)
return result;
}
+
+
+/* Helper function for marking a boolean expression tree as unlikely. */
+
+tree
+gfc_unlikely (tree cond)
+{
+ tree tmp;
+
+ cond = fold_convert (long_integer_type_node, cond);
+ tmp = build_zero_cst (long_integer_type_node);
+ cond = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
+ cond = fold_convert (boolean_type_node, cond);
+ return cond;
+}
@@ -512,6 +512,9 @@ void gfc_generate_constructors (void);
/* Get the string length of an array constructor. */
bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor_base, tree *);
+/* Mark a condition as unlikely. */
+tree gfc_unlikely (tree);
+
/* Generate a runtime error call. */
tree gfc_trans_runtime_error (bool, locus*, const char*, ...);
@@ -0,0 +1,100 @@
+! { dg-do run }
+! { dg-options "-fcoarray=single" }
+!
+! Run-time test for IMAGE_INDEX with cobounds only known at
+! the compile time, suitable for any number of NUM_IMAGES()
+! For compile-time cobounds, the -fcoarray=lib version still
+! needs to run-time evalulation if image_index returns > 1
+! as image_index is 0 if the index would exceed num_images().
+!
+! Please set num_images() to >= 13, if possible.
+!
+! PR fortran/18918
+!
+
+program test_image_index
+implicit none
+integer :: index1, index2, index3
+logical :: one
+
+integer, allocatable :: a(:)[:,:,:], b(:)[:,:], c(:,:)[:]
+integer, save :: d(2)[-1:3, *]
+integer, save :: e(2)[-1:-1, 3:*]
+
+one = num_images() == 1
+
+allocate(a(1)[3:3, -4:-3, 88:*])
+allocate(b(2)[-1:0,0:*])
+allocate(c(3,3)[*])
+
+index1 = image_index(a, [3, -4, 88] )
+index2 = image_index(b, [-1, 0] )
+index3 = image_index(c, [1] )
+if (index1 /= 1 .or. index2 /= 1 .or. index3 /= 1) call abort()
+
+
+index1 = image_index(a, [3, -3, 88] )
+index2 = image_index(b, [0, 0] )
+index3 = image_index(c, [2] )
+
+if (one .and. (index1 /= 0 .or. index2 /= 0 .or. index3 /= 0)) &
+ call abort()
+if (.not. one .and. (index1 /= 2 .or. index2 /= 2 .or. index3 /= 2)) &
+ call abort()
+
+
+index1 = image_index(d, [-1, 1] )
+index2 = image_index(d, [0, 1] )
+
+if (one .and. (index1 /= 1 .or. index2 /= 0)) &
+ call abort()
+if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) &
+ call abort()
+
+index1 = image_index(e, [-1, 3] )
+index2 = image_index(e, [-1, 4] )
+
+if (one .and. (index1 /= 1 .or. index2 /= 0)) &
+ call abort()
+if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) &
+ call abort()
+
+call test(1, a,b,c)
+
+! The following test is in honour of the F2008 standard:
+deallocate(a)
+allocate(a (10) [10, 0:9, 0:*])
+
+index1 = image_index(a, [1, 0, 0] )
+index2 = image_index(a, [3, 1, 2] ) ! = 213, yeah!
+index3 = image_index(a, [3, 1, 0] ) ! = 13
+
+if (num_images() < 13 .and. (index1 /= 1 .or. index2 /= 0 .or. index3 /= 0)) &
+ call abort()
+if (num_images() >= 213 .and. (index1 /= 1 .or. index2 /= 213 .or. index3 /= 13)) &
+ call abort()
+if (num_images() >= 13 .and. (index1 /= 1 .or. index2 /= 0 .or. index3 /= 13)) &
+ call abort()
+
+
+contains
+subroutine test(n, a, b, c)
+ integer :: n
+ integer :: a(1)[3*n:3*n, -4*n:-3*n, 88*n:*], b(2)[-1*n:0*n,0*n:*], c(3*n,3*n)[*]
+
+ index1 = image_index(a, [3, -4, 88] )
+ index2 = image_index(b, [-1, 0] )
+ index3 = image_index(c, [1] )
+ if (index1 /= 1 .or. index2 /= 1 .or. index3 /= 1) call abort()
+
+
+ index1 = image_index(a, [3, -3, 88] )
+ index2 = image_index(b, [0, 0] )
+ index3 = image_index(c, [2] )
+
+ if (one .and. (index1 /= 0 .or. index2 /= 0 .or. index3 /= 0)) &
+ call abort()
+ if (.not. one .and. (index1 /= 2 .or. index2 /= 2 .or. index3 /= 2)) &
+ call abort()
+end subroutine test
+end program test_image_index