On 21/07/2012 13:08, Tobias Burnus wrote:
> Only failing are:
> lbound(x) / ubound(x) / shape(x)
>
Here is a draft for those.
Lightly tested with print *, ...
Mikael
Index: trans-array.c
===================================================================
--- trans-array.c (révision 189883)
+++ trans-array.c (copie de travail)
@@ -249,6 +249,20 @@ gfc_conv_descriptor_dtype (tree desc)
tree
+gfc_conv_descriptor_rank (tree desc)
+{
+ tree tmp;
+ tree dtype;
+
+ dtype = gfc_conv_descriptor_dtype (desc);
+ tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK);
+ tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype),
+ dtype, tmp);
+ return fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
+}
+
+
+tree
gfc_get_descriptor_dimension (tree desc)
{
tree type, field;
@@ -3794,6 +3808,40 @@ done:
/* Fall through to supply start and stride. */
case GFC_ISYM_LBOUND:
case GFC_ISYM_UBOUND:
+ {
+ gfc_expr *arg;
+
+ /* This is the variant without DIM=... */
+ gcc_assert (expr->value.function.actual->next->expr == NULL);
+
+ arg = expr->value.function.actual->expr;
+ if (arg->rank == -1)
+ {
+ gfc_se se;
+ tree rank, tmp;
+
+ /* The rank (hence the return value's shape) is unknown,
+ we have to retrieve it. */
+ gfc_init_se (&se, NULL);
+ se.descriptor_only = 1;
+ gfc_conv_expr (&se, arg);
+ /* This is a bare variable, so there is no preliminary
+ or cleanup code. */
+ gcc_assert (se.pre.head == NULL_TREE
+ && se.post.head == NULL_TREE);
+ rank = gfc_conv_descriptor_rank (se.expr);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ fold_convert (gfc_array_index_type,
+ rank),
+ gfc_index_one_node);
+ info->end[0] = gfc_evaluate_now (tmp, &loop->pre);
+ info->start[0] = gfc_index_zero_node;
+ info->stride[0] = gfc_index_one_node;
+ continue;
+ }
+ /* Otherwise fall through GFC_SS_FUNCTION. */
+ }
case GFC_ISYM_LCOBOUND:
case GFC_ISYM_UCOBOUND:
case GFC_ISYM_THIS_IMAGE:
@@ -4430,22 +4478,11 @@ set_loop_bounds (gfc_loopinfo *loop)
continue;
}
- /* TODO: Pick the best bound if we have a choice between a
- function and something else. */
- if (ss_type == GFC_SS_FUNCTION)
- {
- loopspec[n] = ss;
- continue;
- }
-
/* Avoid using an allocatable lhs in an assignment, since
there might be a reallocation coming. */
if (loopspec[n] && ss->is_alloc_lhs)
continue;
- if (ss_type != GFC_SS_SECTION)
- continue;
-
if (!loopspec[n])
loopspec[n] = ss;
/* Criteria for choosing a loop specifier (most important first):
@@ -4520,6 +4557,20 @@ set_loop_bounds (gfc_loopinfo *loop)
gcc_assert (loop->to[n] == NULL_TREE);
break;
+ case GFC_SS_INTRINSIC:
+ {
+ gfc_expr *expr = loopspec[n]->info->expr;
+
+ /* The {l,u}bound of an assumed rank. */
+ gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
+ || expr->value.function.isym->id == GFC_ISYM_UBOUND)
+ && expr->value.function.actual->next->expr == NULL
+ && expr->value.function.actual->expr->rank == -1);
+
+ loop->to[n] = info->end[dim];
+ break;
+ }
+
default:
gcc_unreachable ();
}
Index: trans-array.h
===================================================================
--- trans-array.h (révision 189881)
+++ trans-array.h (copie de travail)
@@ -154,6 +154,7 @@ tree gfc_conv_descriptor_data_get (tree);
tree gfc_conv_descriptor_data_addr (tree);
tree gfc_conv_descriptor_offset_get (tree);
tree gfc_conv_descriptor_dtype (tree);
+tree gfc_conv_descriptor_rank (tree);
tree gfc_get_descriptor_dimension (tree);
tree gfc_conv_descriptor_stride_get (tree, tree);
tree gfc_conv_descriptor_lbound_get (tree, tree);
Index: iresolve.c
===================================================================
--- iresolve.c (révision 189881)
+++ iresolve.c (copie de travail)
@@ -134,9 +134,12 @@ resolve_bound (gfc_expr *f, gfc_expr *array, gfc_e
if (dim == NULL)
{
f->rank = 1;
- f->shape = gfc_get_shape (1);
- mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array)
- : array->rank);
+ if (array->rank != -1)
+ {
+ f->shape = gfc_get_shape (1);
+ mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array)
+ : array->rank);
+ }
}
f->value.function.name = xstrdup (name);
@@ -2225,8 +2228,12 @@ gfc_resolve_shape (gfc_expr *f, gfc_expr *array, g
f->ts.kind = gfc_default_integer_kind;
f->rank = 1;
- f->shape = gfc_get_shape (1);
- mpz_init_set_ui (f->shape[0], array->rank);
+ if (array->rank != -1)
+ {
+ f->shape = gfc_get_shape (1);
+ mpz_init_set_ui (f->shape[0], array->rank);
+ }
+
f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind);
}
Index: trans-intrinsic.c
===================================================================
--- trans-intrinsic.c (révision 189881)
+++ trans-intrinsic.c (copie de travail)
@@ -1315,20 +1315,6 @@ trans_num_images (gfc_se * se)
}
-static tree
-get_rank_from_desc (tree desc)
-{
- tree tmp;
- tree dtype;
-
- dtype = gfc_conv_descriptor_dtype (desc);
- tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK);
- tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype),
- dtype, tmp);
- return fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
-}
-
-
static void
gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
{
@@ -1345,7 +1331,7 @@ gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *exp
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
- se->expr = get_rank_from_desc (argse.expr);
+ se->expr = gfc_conv_descriptor_rank (argse.expr);
}
@@ -1434,7 +1420,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr *
cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
bound, build_int_cst (TREE_TYPE (bound), 0));
if (as && as->type == AS_ASSUMED_RANK)
- tmp = get_rank_from_desc (desc);
+ tmp = gfc_conv_descriptor_rank (desc);
else
tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
@@ -5895,7 +5881,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
gfc_conv_expr_lhs (&arg1se, arg1->expr);
if (arg1->expr->rank == -1)
{
- tmp = get_rank_from_desc (arg1se.expr);
+ tmp = gfc_conv_descriptor_rank (arg1se.expr);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
TREE_TYPE (tmp), tmp, gfc_index_one_node);
}
Index: simplify.c
===================================================================
--- simplify.c (révision 189881)
+++ simplify.c (copie de travail)
@@ -5470,6 +5470,9 @@ gfc_simplify_shape (gfc_expr *source, gfc_expr *ki
gfc_try t;
int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind);
+ if (source->rank == -1)
+ return NULL;
+
result = gfc_get_array_expr (BT_INTEGER, k, &source->where);
if (source->rank == 0)
