Small patch update: The patch now includes also primary.c changes, which
fix the DEALLOCATE issue with polymorphic scalar coarrays.
OK for the trunk?
Tobias
On 12/13/2011 06:30 PM, Tobias Burnus wrote:
Two small fixes:
a) There was an ICE when simplifying "THIS_IMAGE(caf)" (for
-fcoarray=single); solution: Simply use internally lcobound(), which
is identically (for a single image).
b) There was an segfault of the compiled program when running
"this_image(caf)" where "caf" is a corank-1 coarray. Calculating the
extend of an assumed size array should be avoided ...
The patch has been build and regtested on x86-64-linux.
OK for the trunk?
Tobias
PS: There are still some other issues with polymorphic coarrays, see
"Next steps" in
http://users.physik.fu-berlin.de/~tburnus/coarray/README.txt for a
list. For instance, there is an ICE if one tries to explicitly
deallocate scalar polymorphic coarrays.
2011-12-15 Tobias Burnus <bur...@net-b.de>
* primary.c (gfc_match_varspec): Match array spec for
polymorphic coarrays.
(gfc_match_rvalue): If a symbol of unknown flavor has a
codimension, mark it as a variable.
* simplify.c (gfc_simplify_image_index): Directly call
simplify_cobound.
* trans-intrinsic.c (trans_this_image): Fix handling of
corank = 1 arrays.
2011-12-15 Tobias Burnus <bur...@net-b.de>
* gfortran.dg/coarray/poly_run_3.f90: New.
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 75c7e13..afc4684 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1821,7 +1821,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
&& !(gfc_matching_procptr_assignment
&& sym->attr.flavor == FL_PROCEDURE))
|| (sym->ts.type == BT_CLASS && sym->attr.class_ok
- && CLASS_DATA (sym)->attr.dimension))
+ && (CLASS_DATA (sym)->attr.dimension
+ || CLASS_DATA (sym)->attr.codimension)))
{
/* In EQUIVALENCE, we don't know yet whether we are seeing
an array, character variable or array of character
@@ -2894,10 +2895,10 @@ gfc_match_rvalue (gfc_expr **result)
&& gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
gfc_set_default_type (sym, 0, sym->ns);
- /* If the symbol has a dimension attribute, the expression is a
+ /* If the symbol has a (co)dimension attribute, the expression is a
variable. */
- if (sym->attr.dimension)
+ if (sym->attr.dimension || sym->attr.codimension)
{
if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
sym->name, NULL) == FAILURE)
@@ -2913,7 +2914,9 @@ gfc_match_rvalue (gfc_expr **result)
break;
}
- if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
+ if (sym->ts.type == BT_CLASS
+ && (CLASS_DATA (sym)->attr.dimension
+ || CLASS_DATA (sym)->attr.codimension))
{
if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
sym->name, NULL) == FAILURE)
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index e82753a..282d88d 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -6227,10 +6227,6 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
gfc_expr *
gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
{
- gfc_ref *ref;
- gfc_array_spec *as;
- int d;
-
if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
return NULL;
@@ -6244,74 +6240,8 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
return result;
}
- gcc_assert (coarray->expr_type == EXPR_VARIABLE);
-
- /* Follow any component references. */
- as = coarray->symtree->n.sym->as;
- for (ref = coarray->ref; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT)
- as = ref->u.ar.as;
-
- if (as->type == AS_DEFERRED)
- return NULL;
-
- if (dim == NULL)
- {
- /* Multi-dimensional bounds. */
- gfc_expr *bounds[GFC_MAX_DIMENSIONS];
- gfc_expr *e;
-
- /* Simplify the bounds for each dimension. */
- for (d = 0; d < as->corank; d++)
- {
- bounds[d] = simplify_bound_dim (coarray, NULL, d + as->rank + 1, 0,
- as, NULL, true);
- if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
- {
- int j;
-
- for (j = 0; j < d; j++)
- gfc_free_expr (bounds[j]);
-
- return bounds[d];
- }
- }
-
- /* Allocate the result expression. */
- e = gfc_get_expr ();
- e->where = coarray->where;
- e->expr_type = EXPR_ARRAY;
- e->ts.type = BT_INTEGER;
- e->ts.kind = gfc_default_integer_kind;
-
- e->rank = 1;
- e->shape = gfc_get_shape (1);
- mpz_init_set_ui (e->shape[0], as->corank);
-
- /* Create the constructor for this array. */
- for (d = 0; d < as->corank; d++)
- gfc_constructor_append_expr (&e->value.constructor,
- bounds[d], &e->where);
-
- return e;
- }
- else
- {
- /* A DIM argument is specified. */
- if (dim->expr_type != EXPR_CONSTANT)
- return NULL;
-
- d = mpz_get_si (dim->value.integer);
-
- if (d < 1 || d > as->corank)
- {
- gfc_error ("DIM argument at %L is out of bounds", &dim->where);
- return &gfc_bad_expr;
- }
-
- return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL,
- true);
- }
+ /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
+ return simplify_cobound (coarray, dim, NULL, 0);
}
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 58112e3..5c964c1 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1054,6 +1054,11 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
one always has a dim_arg argument.
m = this_images() - 1
+ if (corank == 1)
+ {
+ sub(1) = m + lcobound(corank)
+ return;
+ }
i = rank
min_var = min (rank + corank - 2, rank + dim_arg - 1)
for (;;)
@@ -1070,15 +1075,29 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
: m + lcobound(corank)
*/
+ /* 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));
+ if (corank == 1)
+ {
+ /* sub(1) = m + lcobound(corank). */
+ lbound = gfc_conv_descriptor_lbound_get (desc,
+ build_int_cst (TREE_TYPE (gfc_array_index_type),
+ corank+rank-1));
+ lbound = fold_convert (type, lbound);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
+
+ se->expr = tmp;
+ return;
+ }
+
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, rank + dim_arg - 1). */
--- /dev/null 2011-12-14 20:10:08.555534201 +0100
+++ gcc/gcc/testsuite/gfortran.dg/coarray/poly_run_3.f90 2011-12-15 14:36:46.000000000 +0100
@@ -0,0 +1,39 @@
+! { dg-do run }
+!
+! Check that the bounds of polymorphic coarrays is
+! properly handled.
+!
+type t
+end type t
+class(t), allocatable :: a(:)[:]
+class(t), allocatable :: b[:], d[:]
+
+allocate(a(1)[*])
+if (this_image() == 1 .and. any (this_image(a) /= lcobound(a))) &
+ call abort ()
+if (any (lcobound(a) /= 1)) call abort()
+if (any (ucobound(a) /= this_image())) call abort ()
+deallocate(a)
+
+allocate(b[*])
+if (this_image() == 1 .and. any (this_image(b) /= lcobound(b))) &
+ call abort ()
+if (any (lcobound(b) /= 1)) call abort()
+if (any (ucobound(b) /= this_image())) call abort ()
+deallocate(b)
+
+allocate(a(1)[-10:*])
+if (this_image() == 1 .and. any (this_image(a) /= lcobound(a))) &
+ call abort ()
+if (any (lcobound(a) /= -10)) call abort()
+if (any (ucobound(a) /= -11+this_image())) call abort ()
+deallocate(a)
+
+allocate(d[23:*])
+if (this_image() == 1 .and. any (this_image(d) /= lcobound(d))) &
+ call abort ()
+if (any (lcobound(d) /= 23)) call abort()
+if (any (ucobound(d) /= 22+this_image())) call abort ()
+deallocate(d)
+
+end
