2013-05-05 Tobias Burnus <burnus@net-b.de>
* trans-array.c (gfc_conv_ss_startstride, set_loop_bounds): Handle
GFC_ISYM_SHAPE in the scalarizer.
(gfc_array_init_size, gfc_conv_expr_descriptor): Ensure that
extent is never negative except for assumed size arrays.
* trans-intrinsic.c (gfc_conv_intrinsic_bound): Optimizations
of the bounds handling.
(gfc_conv_intrinsic_size): Handle SIZE and SHAPE directly without
calling the library.
(gfc_conv_intrinsic_function, gfc_add_intrinsic_ss_code,
gfc_walk_intrinsic_bound, gfc_is_intrinsic_libcall,
gfc_walk_intrinsic_function): Handle SHAPE.
2013-05-05 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/assumed_rank_13.f90: New.
* gfortran.dg/array_section_2.f90: Remove tree-dump check.
* gfortran.dg/assign_10.f90: Update dump-times.
* gfortran.dg/transpose_optimization_2.f90: Ditto.
* gfortran.dg/coarray_12.f90: Update dump pattern.
* gfortran.dg/coarray_30.f90: Ditto.
* gfortran.dg/intrinsic_size_3.f90: Ditto.
@@ -4012,6 +4012,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
case GFC_ISYM_UBOUND:
case GFC_ISYM_LCOBOUND:
case GFC_ISYM_UCOBOUND:
+ case GFC_ISYM_SHAPE:
case GFC_ISYM_THIS_IMAGE:
loop->dimen = ss->dimen;
goto done;
@@ -4062,11 +4063,13 @@ done:
/* Fall through to supply start and stride. */
case GFC_ISYM_LBOUND:
case GFC_ISYM_UBOUND:
+ case GFC_ISYM_SHAPE:
{
gfc_expr *arg;
/* This is the variant without DIM=... */
- gcc_assert (expr->value.function.actual->next->expr == NULL);
+ gcc_assert (expr->value.function.actual->next->expr == NULL
+ || expr->value.function.isym->id == GFC_ISYM_SHAPE);
arg = expr->value.function.actual->expr;
if (arg->rank == -1)
@@ -4818,10 +4821,12 @@ set_loop_bounds (gfc_loopinfo *loop)
{
gfc_expr *expr = loopspec[n]->info->expr;
- /* The {l,u}bound of an assumed rank. */
+ /* The {l,u}bound and shape 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.isym->id == GFC_ISYM_UBOUND
+ || expr->value.function.isym->id == GFC_ISYM_SHAPE)
+ && (expr->value.function.actual->next->expr == NULL
+ || expr->value.function.isym->id == GFC_ISYM_SHAPE)
&& expr->value.function.actual->expr->rank == -1);
loop->to[n] = info->end[dim];
@@ -5153,16 +5158,22 @@ gfc_array_init_size (tree descriptor, gfc_typespec *ts,
offset = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type, offset, tmp);
- /* Set upper bound. */
+ /* Set extent. */
gfc_init_se (&se, NULL);
gcc_assert (ubound);
gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
-
- gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
- gfc_rank_cst[n], se.expr);
conv_ubound = se.expr;
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ conv_ubound, conv_lbound);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
+ tmp, gfc_index_zero_node);
+ gfc_conv_descriptor_extent_set (descriptor_block, descriptor,
+ gfc_rank_cst[n], tmp);
+
/* Store the stride. */
gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
gfc_rank_cst[n], stride);
@@ -6666,6 +6677,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
tree elem_len;
int full;
bool subref_array_target = false;
+ bool assumed_size = false;
gfc_expr *arg, *ss_expr;
if (se->want_coarray)
@@ -6712,6 +6724,9 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
if (se->force_tmp)
need_tmp = 1;
+ if (info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
+ assumed_size = true;
+
if (need_tmp)
full = 0;
else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
@@ -7084,9 +7099,22 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
gfc_conv_descriptor_lbound_set (&loop.pre, parm,
gfc_rank_cst[dim], from);
- /* Set the new upper bound. */
- gfc_conv_descriptor_ubound_set (&loop.pre, parm,
- gfc_rank_cst[dim], to);
+ /* Set the new extent. */
+ if (assumed_size && dim == ndim - 1)
+ tmp = build_int_cst (gfc_array_index_type, -1);
+ else
+ {
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, to, from);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, tmp,
+ gfc_index_one_node);
+ tmp = fold_build2_loc (input_location, MAX_EXPR,
+ gfc_array_index_type, tmp,
+ gfc_index_zero_node);
+ }
+ gfc_conv_descriptor_extent_set (&loop.pre, parm,
+ gfc_rank_cst[dim], tmp);
/* Multiply the stride by the section stride to get the
total stride. */
@@ -1293,12 +1293,14 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
tree type;
tree bound;
tree tmp;
- tree cond, cond1, cond3, cond4;
+ tree cond;
tree lbound;
tree extent;
gfc_se argse;
+ gfc_ref *ref;
+ gfc_array_ref *ar;
gfc_array_spec * as;
- bool assumed_rank_lb_one;
+ bool lb_one;
arg = expr->value.function.actual;
arg2 = arg->next;
@@ -1338,7 +1340,13 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
desc = argse.expr;
- as = gfc_get_full_arrayspec_from_expr (arg->expr);
+ for (ref = arg->expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY
+ && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
+ break;
+
+ ar = ref ? &ref->u.ar : NULL;
+ as = ar ? ar->as : NULL;
if (INTEGER_CST_P (bound))
{
@@ -1376,18 +1384,22 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
}
/* Take care of the lbound shift for assumed-rank arrays, which are
- nonallocatable and nonpointers. Those has a lbound of 1. */
- assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
- && ((arg->expr->ts.type != BT_CLASS
- && !arg->expr->symtree->n.sym->attr.allocatable
- && !arg->expr->symtree->n.sym->attr.pointer)
- || (arg->expr->ts.type == BT_CLASS
- && !CLASS_DATA (arg->expr)->attr.allocatable
- && !CLASS_DATA (arg->expr)->attr.class_pointer));
+ nonallocatable and nonpointers. Those have a lbound of 1. */
+ lb_one = as && as->type == AS_ASSUMED_RANK
+ && ((arg->expr->ts.type != BT_CLASS
+ && !arg->expr->symtree->n.sym->attr.allocatable
+ && !arg->expr->symtree->n.sym->attr.pointer)
+ || (arg->expr->ts.type == BT_CLASS
+ && !CLASS_DATA (arg->expr)->attr.allocatable
+ && !CLASS_DATA (arg->expr)->attr.class_pointer));
+ lb_one = lb_one || ar == NULL || ar->type != AR_FULL;
+
+ if (ref && ref->next)
+ lb_one = true;
lbound = gfc_conv_descriptor_lbound_get (desc, bound);
extent = gfc_conv_descriptor_extent_get (desc, bound);
-
+
/* 13.14.53: Result value for LBOUND
Case (i): For an array section or for an array expression other than a
@@ -1409,76 +1421,44 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
not have size zero and has value zero if dimension DIM has
size zero. */
- if (!upper && assumed_rank_lb_one)
+ if (!upper && lb_one)
se->expr = gfc_index_one_node;
- else if (as)
+ else if (lb_one)
+ se->expr = extent;
+ else
{
- tree stride = gfc_conv_descriptor_stride_get (desc, bound);
-
- cond1 = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
- extent, gfc_index_zero_node);
- cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
- stride, gfc_index_zero_node);
- cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
- boolean_type_node, cond3, cond1);
- cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
- stride, gfc_index_zero_node);
-
- if (upper)
+ cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ extent, gfc_index_zero_node);
+ if (!upper)
{
- tree cond5;
- cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- boolean_type_node, cond3, cond4);
- cond5 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
- gfc_index_one_node, lbound);
- cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
- boolean_type_node, cond4, cond5);
-
- cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- boolean_type_node, cond, cond5);
+ tree cond2;
- if (assumed_rank_lb_one)
- tmp = extent;
+ if (as->type == AS_ASSUMED_SIZE)
+ cond2 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ bound,
+ build_int_cst (TREE_TYPE (bound),
+ arg->expr->rank - 1));
else
- {
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, extent, lbound);
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, tmp, gfc_index_one_node);
- }
+ cond2 = boolean_false_node;
+
+ cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ boolean_type_node, cond, cond2);
se->expr = fold_build3_loc (input_location, COND_EXPR,
gfc_array_index_type, cond,
- tmp, gfc_index_zero_node);
+ lbound, gfc_index_one_node);
}
else
{
- if (as->type == AS_ASSUMED_SIZE)
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
- bound, build_int_cst (TREE_TYPE (bound),
- arg->expr->rank - 1));
- else
- cond = boolean_false_node;
-
- cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- boolean_type_node, cond3, cond4);
- cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- boolean_type_node, cond, cond1);
-
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, extent, lbound);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, tmp, gfc_index_one_node);
se->expr = fold_build3_loc (input_location, COND_EXPR,
gfc_array_index_type, cond,
- lbound, gfc_index_one_node);
+ tmp, gfc_index_zero_node);
}
}
- else
- {
- if (upper)
- se->expr = fold_build2_loc (input_location, MAX_EXPR,
- gfc_array_index_type, extent,
- gfc_index_zero_node);
- else
- se->expr = gfc_index_one_node;
- }
type = gfc_typenode_for_spec (&expr->ts);
se->expr = convert (type, se->expr);
@@ -5049,91 +5029,188 @@ gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
static void
-gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
+gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr, bool shape)
{
- gfc_actual_arglist *actual;
- tree arg1;
+ gfc_actual_arglist *arg;
+ gfc_actual_arglist *arg2;
+ tree desc;
tree type;
- tree fncall0;
- tree fncall1;
+ tree exit_label, tmp, cond, extent, size;
+ tree arg2_var = NULL_TREE, present = NULL_TREE, bound = NULL_TREE;
gfc_se argse;
+ gfc_array_spec * as;
+ stmtblock_t loop;
+ bool optional;
- gfc_init_se (&argse, NULL);
- actual = expr->value.function.actual;
+ arg = expr->value.function.actual;
+ arg2 = arg->next;
- if (actual->expr->ts.type == BT_CLASS)
- gfc_add_class_array_ref (actual->expr);
+ optional = !shape && arg2->expr && arg2->expr->expr_type == EXPR_VARIABLE
+ && arg2->expr->symtree->n.sym->attr.optional && !arg2->expr->ref;
- argse.want_pointer = 1;
- argse.data_not_needed = 1;
- gfc_conv_expr_descriptor (&argse, actual->expr);
+ /* For SIZE, the dim= variable can be an optional, which requires special
+ handling. */
+
+ if (se->ss)
+ {
+ /* Create an implicit second parameter from the loop variable. */
+ gcc_assert (shape);
+ gcc_assert (se->loop->dimen == 1);
+ gcc_assert (se->ss->info->expr == expr);
+ gfc_advance_se_ss_chain (se);
+ bound = se->loop->loopvar[0];
+ bound = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, bound,
+ se->loop->from[0]);
+ }
+ else if (arg2->expr)
+ {
+ /* use the passed argument. */
+ gcc_assert (!shape);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ arg2_var = argse.expr;
+ /* Convert from one based to zero based. */
+ if (!optional)
+ bound = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, arg2_var,
+ gfc_index_one_node);
+ }
+
+ if (!se->ss && (!arg2->expr || optional))
+ {
+ /* SIZE without dim= - or with optional dim. */
+ gcc_assert (!shape);
+ bound = gfc_create_var (integer_type_node, NULL);
+
+ if (optional)
+ present = gfc_conv_expr_present (arg2->expr->symtree->n.sym);
+ }
+
+ /* TODO: don't re-evaluate the descriptor on each iteration. */
+ /* Get a descriptor for the first parameter. */
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_descriptor (&argse, arg->expr);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
- arg1 = gfc_evaluate_now (argse.expr, &se->pre);
- /* Build the call to size0. */
- fncall0 = build_call_expr_loc (input_location,
- gfor_fndecl_size0, 1, arg1);
+ desc = argse.expr;
- actual = actual->next;
+ as = gfc_get_full_arrayspec_from_expr (arg->expr);
- if (actual->expr)
+ if (arg2_var != NULL_TREE && INTEGER_CST_P (arg2_var))
{
- gfc_init_se (&argse, NULL);
- gfc_conv_expr_type (&argse, actual->expr,
- gfc_array_index_type);
- gfc_add_block_to_block (&se->pre, &argse.pre);
+ int hi, low;
- /* Unusually, for an intrinsic, size does not exclude
- an optional arg2, so we must test for it. */
- if (actual->expr->expr_type == EXPR_VARIABLE
- && actual->expr->symtree->n.sym->attr.dummy
- && actual->expr->symtree->n.sym->attr.optional)
- {
- tree tmp;
- /* Build the call to size1. */
- fncall1 = build_call_expr_loc (input_location,
- gfor_fndecl_size1, 2,
- arg1, argse.expr);
-
- gfc_init_se (&argse, NULL);
- argse.want_pointer = 1;
- argse.data_not_needed = 1;
- gfc_conv_expr (&argse, actual->expr);
- gfc_add_block_to_block (&se->pre, &argse.pre);
- tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
- argse.expr, null_pointer_node);
- tmp = gfc_evaluate_now (tmp, &se->pre);
- se->expr = fold_build3_loc (input_location, COND_EXPR,
- pvoid_type_node, tmp, fncall1, fncall0);
- }
- else
- {
- se->expr = NULL_TREE;
- argse.expr = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- argse.expr, gfc_index_one_node);
- }
+ hi = TREE_INT_CST_HIGH (arg2_var);
+ low = TREE_INT_CST_LOW (arg2_var);
+ if (hi || low < 0
+ || ((!as || as->type != AS_ASSUMED_RANK)
+ && low > GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
+ || low > GFC_MAX_DIMENSIONS)
+ gfc_error ("'dim' argument of SIZE intrinsic at %L is not a valid "
+ "dimension index", &expr->where);
}
- else if (expr->value.function.actual->expr->rank == 1)
+
+ if (arg2_var != NULL_TREE
+ && (!INTEGER_CST_P (arg2_var) || (as && as->type == AS_ASSUMED_RANK)))
{
- argse.expr = gfc_index_zero_node;
- se->expr = NULL_TREE;
+ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+ {
+ arg2_var = gfc_evaluate_now (arg2_var, &se->pre);
+ cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ arg2_var,
+ build_int_cst (TREE_TYPE (arg2_var), 1));
+ if (as && as->type == AS_ASSUMED_RANK)
+ tmp = gfc_conv_descriptor_rank (desc);
+ else
+ tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
+ tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ arg2_var,
+ fold_convert (TREE_TYPE (arg2_var), tmp));
+ cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+ boolean_type_node, cond, tmp);
+ if (optional)
+ cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+ boolean_type_node, present, cond);
+ gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
+ gfc_msg_fault);
+ }
}
- else
- se->expr = fncall0;
- if (se->expr == NULL_TREE)
+ extent = gfc_conv_descriptor_extent_get (desc, bound);
+ type = gfc_typenode_for_spec (&expr->ts);
+
+ if (shape || (arg2->expr && !optional))
{
- arg1 = build_fold_indirect_ref_loc (input_location, arg1);
- se->expr = gfc_conv_descriptor_extent_get (arg1, argse.expr);
- se->expr = fold_build2_loc (input_location, MAX_EXPR,
- gfc_array_index_type, se->expr,
- gfc_index_zero_node);
+ se->expr = convert (type, extent);
+ return;
}
- type = gfc_typenode_for_spec (&expr->ts);
- se->expr = convert (type, se->expr);
+ /* bound = 0; - or: bound = present ? arg2_var - 1 : 0;
+ size = 1;
+ for (;;)
+ {
+ if (bound >= rank) - or: if (bound >= (present ? arg2_var : rank))
+ goto exit;
+ size = size * extent[bound];
+ bound++;
+ }
+ exit: */
+
+ /* bound = 0; - or: bound = present ? arg2_var : 0; */
+ tmp = build_int_cst (integer_type_node, 0);
+ if (optional)
+ {
+ tree tmp2 = fold_build2_loc (input_location, MINUS_EXPR,
+ integer_type_node,
+ fold_convert (integer_type_node, arg2_var),
+ gfc_index_one_node);
+ tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
+ present, tmp2, tmp);
+ }
+ gfc_add_modify (&se->pre, bound, tmp);
+
+ exit_label = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (exit_label) = 1;
+
+ size = gfc_create_var (gfc_array_index_type, NULL);
+ gfc_add_modify (&se->pre, size, gfc_index_one_node);
+
+ gfc_init_block (&loop);
+
+ /* Exit condition: if (bound >= rank-1) goto exit_label. */
+ tmp = fold_convert (integer_type_node, gfc_conv_descriptor_rank (desc));
+ if (optional)
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ integer_type_node, present,
+ fold_convert (integer_type_node, arg2_var), tmp);
+ cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, bound,
+ tmp);
+ 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);
+
+ gfc_add_modify (&loop, size,
+ fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, size, extent));
+
+ gfc_add_modify (&loop, bound,
+ fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+ bound,
+ build_int_cst (integer_type_node, 1)));
+
+ 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);
+
+ se->expr = convert (type, size);
}
@@ -5185,7 +5262,7 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
se->expr = size_of_string_in_bytes (arg->ts.kind,
argse.string_length);
else
- se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type));
+ se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type));
}
else
{
@@ -5199,7 +5276,7 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
else
tmp = fold_convert (gfc_array_index_type,
- size_in_bytes (type));
+ size_in_bytes (type));
gfc_add_modify (&argse.pre, source_bytes, tmp);
/* Obtain the size of the array in bytes. */
@@ -7008,12 +7085,16 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
gfc_conv_intrinsic_scale (se, expr);
break;
+ case GFC_ISYM_SHAPE:
+ gfc_conv_intrinsic_size (se, expr, true);
+ break;
+
case GFC_ISYM_SIGN:
gfc_conv_intrinsic_sign (se, expr);
break;
case GFC_ISYM_SIZE:
- gfc_conv_intrinsic_size (se, expr);
+ gfc_conv_intrinsic_size (se, expr, false);
break;
case GFC_ISYM_SIZEOF:
@@ -7325,6 +7406,7 @@ gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
case GFC_ISYM_LBOUND:
case GFC_ISYM_UCOBOUND:
case GFC_ISYM_LCOBOUND:
+ case GFC_ISYM_SHAPE:
case GFC_ISYM_THIS_IMAGE:
break;
@@ -7343,8 +7425,9 @@ gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
if (expr->value.function.actual->expr->ts.type == BT_CLASS)
gfc_add_class_array_ref (expr->value.function.actual->expr);
- /* The two argument version returns a scalar. */
- if (expr->value.function.actual->next->expr)
+ /* The two argument version returns a scalar, except for SHAPE. */
+ if (expr->value.function.isym->id != GFC_ISYM_SHAPE
+ && expr->value.function.actual->next->expr)
return ss;
return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
@@ -7427,7 +7510,6 @@ gfc_is_intrinsic_libcall (gfc_expr * expr)
case GFC_ISYM_PARITY:
case GFC_ISYM_PRODUCT:
case GFC_ISYM_SUM:
- case GFC_ISYM_SHAPE:
case GFC_ISYM_SPREAD:
case GFC_ISYM_YN2:
/* Ignore absent optional parameters. */
@@ -7474,6 +7556,7 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
case GFC_ISYM_UBOUND:
case GFC_ISYM_UCOBOUND:
case GFC_ISYM_THIS_IMAGE:
+ case GFC_ISYM_SHAPE:
return gfc_walk_intrinsic_bound (ss, expr);
case GFC_ISYM_TRANSFER:
@@ -1,16 +1,17 @@
! { dg-do compile }
-! { dg-options "-fdump-tree-original" }
!
! PR38033 - size(a) was not stabilized correctly and so the expression was
! evaluated twice outside the loop and then within the scalarization loops.
!
! Contributed by Thomas Bruel <tmbdev@gmail.com>
!
+! Note: With the new array descriptor, which uses extent directly and inlined
+! SIZE, this is no longer simply testable in the dump.
+! (Before, the code had a -fdump-tree-original check.)
+!
program test
integer, parameter :: n = 100
real, pointer :: a(:),temp(:) ! pointer or allocatable have the same effect
allocate(a(n), temp(n))
temp(1:size(a)) = a
end program
-! { dg-final { scan-tree-dump-times "MAX_EXPR\[^\n\t\]+extent, 0" 1 "original" } }
-! { dg-final { cleanup-tree-dump "original" } }
@@ -23,6 +23,6 @@ end
! cases will all yield a temporary, so that atmp appears 18 times.
! Note that it is the kind conversion that generates the temp.
!
-! { dg-final { scan-tree-dump-times "parm" 28 "original" } }
+! { dg-final { scan-tree-dump-times "parm" 26 "original" } }
! { dg-final { scan-tree-dump-times "atmp" 26 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
@@ -46,14 +46,14 @@ end subroutine testAlloc5
! { dg-final { scan-tree-dump-times "a.dim.0..lower_bound = 1;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "a.dim.0..extent = .*nn - a.dim.0..lower_bound. \\+ 1;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "a.dim.0..extent = MAX_EXPR <.*nn, 0>;" 1 "original" } }
! { dg-final { scan-tree-dump-times "a.dim.1..lower_bound = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "a.dim.1..extent = .*mm - a.dim.1..lower_bound. \\+ 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "a.dim.2..lower_bound = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "a.dim.2..extent" 0 "original" } }
! { dg-final { scan-tree-dump-times "xxx.dim.0..lower_bound = 1;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "xxx.dim.0..extent = 2 - xxx.dim.0..lower_bound;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "xxx.dim.0..extent = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "xxx.dim.1..lower_bound = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "xxx.dim.1..extent = 8 - xxx.dim.1..lower_bound;" 1 "original" } }
! { dg-final { scan-tree-dump-times "xxx.dim.2..lower_bound = -5;" 1 "original" } }
@@ -64,7 +64,7 @@ end subroutine testAlloc5
! { dg-final { scan-tree-dump-times "xxx.dim.4..extent" 0 "original" } }
! { dg-final { scan-tree-dump-times "yyy.dim.0..lower_bound = 1;" 1 "original" } }
-! { dg-final { scan-tree-dump-times "yyy.dim.0..extent = 2 - yyy.dim.0..lower_bound;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "yyy.dim.0..extent = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "yyy.dim.1..lower_bound = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "yyy.dim.1..extent = 8 - yyy.dim.1..lower_bound;" 1 "original" } }
! { dg-final { scan-tree-dump-times "yyy.dim.2..lower_bound = -5;" 1 "original" } }
@@ -11,5 +11,5 @@ program main
write(greeting,"(a)") "z"
end
-! { dg-final { scan-tree-dump-times "greeting.data = \\(void . restrict\\) __builtin_malloc \\(25\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "greeting.base_addr = \\(void . restrict\\) __builtin_malloc \\(25\\);" 1 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
@@ -22,5 +22,5 @@ program bug
stop
end program bug
-! { dg-final { scan-tree-dump-times "iszs = \\(integer\\(kind=2\\)\\) MAX_EXPR <D.\[0-9\]+->dim.0..extent, 0>;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "iszs = \\(integer\\(kind=2\\)\\) a.dim.0..extent;" 1 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
@@ -60,6 +60,6 @@ end
!
! The check below for temporaries gave 14 and 33 for "parm" and "atmp".
!
-! { dg-final { scan-tree-dump-times "parm" 102 "original" } }
+! { dg-final { scan-tree-dump-times "parm" 90 "original" } }
! { dg-final { scan-tree-dump-times "atmp" 16 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
@@ -0,0 +1,40 @@
+! { dg-do run }
+!
+! Ensure that SIZE/SHAPE/UBOUND/LBOUND work properly with
+! assumed-rank arrays for scalars and assumed-size arrays
+!
+program main
+ implicit none
+ integer :: A(2,2)
+ integer :: B
+ call foo(A)
+ call test2(B)
+contains
+ subroutine foo(x)
+ integer :: x(2,*)
+ call bar(x)
+ end subroutine foo
+ subroutine bar(y)
+ integer :: y(..)
+! print *, rank(y) ! 2
+! print *, lbound(y) ! 1 1
+! print *, ubound(y) ! 2 -1
+! print *, shape(y) ! 2 -1
+! print *, size(y) ! -2
+ if (rank(y) /= 2) call abort ()
+ if (any (lbound(y) /= [1, 1])) call abort
+ if (any (ubound(y) /= [2,-1])) call abort
+ if (any (shape(y) /= [2,-1])) call abort
+ if (size(y,1) /= 2) call abort
+ if (size(y,2) /= -1) call abort
+ if (size(y) /= -2) call abort
+ end subroutine bar
+ subroutine test2(z)
+ integer :: z(..)
+ if (rank(z) /= 0) call abort() ! 1
+ if (size(lbound(z)) /= 0) call abort() ! zero-sized array
+ if (size(ubound(z)) /= 0) call abort() ! zero-sized array
+ if (size(shape(z)) /= 0) call abort() ! zero-sized array
+ if (size(z) /= 1) call abort() ! 1
+ end subroutine test2
+end program main