Le 28/05/2015 17:29, Andre Vehreschild a écrit :
> *************** resolve_allocate_expr (gfc_expr *e, gfc_
> *** 7103,7112 ****
> --- 7103,7123 ----
> if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
> || (dimension && ref2->u.ar.dimen == 0))
> {
> + /* F08:C633. */
> + if (code->expr3)
> + {
> + if (!gfc_notify_std (GFC_STD_F2008, "Array specification required "
> + "in ALLOCATE statement at %L", &e->where))
> + goto failure;
> + *array_alloc_wo_spec = true;
> + }
> + else
> + {
> gfc_error ("Array specification required in ALLOCATE statement "
> "at %L", &e->where);
> goto failure;
> }
> + }
>
> /* Make sure that the array section reference makes sense in the
> context of an ALLOCATE specification. */
I think we can be a little be more user friendly with the gfc_notify_std
error message.
Something like:
ALLOCATE without array spec at %L
ALLOCATE with array bounds determined from SOURCE or MOLD at %L
> *************** gfc_array_init_size (tree descriptor, in
> *** 5044,5053 ****
> lower == NULL => lbound = 1, ubound = upper[n]
> upper[n] = NULL => lbound = 1, ubound = lower[n]
> upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
> - ubound = upper[n];
>
> /* Set lower bound. */
> gfc_init_se (&se, NULL);
> if (lower == NULL)
> se.expr = gfc_index_one_node;
> else
> --- 5050,5063 ----
> lower == NULL => lbound = 1, ubound = upper[n]
> upper[n] = NULL => lbound = 1, ubound = lower[n]
> upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
>
> /* Set lower bound. */
> gfc_init_se (&se, NULL);
> + if (expr3_desc != NULL_TREE)
> + se.expr = gfc_index_one_node;
> + else
> + {
> + ubound = upper[n];
> if (lower == NULL)
> se.expr = gfc_index_one_node;
> else
> *************** gfc_array_init_size (tree descriptor, in
> *** 5064,5069 ****
> --- 5074,5080 ----
> ubound = lower[n];
> }
> }
> + }
> gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
> gfc_rank_cst[n], se.expr);
> conv_lbound = se.expr;
You can avoid reindenting if the ubound = upper[n] statement is kept at
its original place.
> *************** gfc_array_init_size (tree descriptor, in
> *** 5076,5085 ****
>
> /* Set upper bound. */
> 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;
> --- 5087,5111 ----
>
> /* Set upper bound. */
> gfc_init_se (&se, NULL);
> + if (expr3_desc != NULL_TREE)
> + {
> + /* Set the upper bound to be (desc.ubound - desc.lbound)+ 1. */
> + tmp = fold_build2_loc (input_location, MINUS_EXPR,
> + gfc_array_index_type,
> + gfc_conv_descriptor_ubound_get (
> + expr3_desc, gfc_rank_cst[n]),
> + gfc_conv_descriptor_lbound_get (
> + expr3_desc, gfc_rank_cst[n]));
> + se.expr = fold_build2_loc (input_location, PLUS_EXPR,
> + gfc_array_index_type, tmp,
> + gfc_index_one_node);
> + }
> + else
> + {
> 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;
Your one-based-ness problem was here, wasn't it?
I would rather copy directly lbound and ubound from expr3_desc to
descriptor.
If the source has non-one-based bounds, the above would produce wrong
bounds.
> *************** gfc_trans_allocate (gfc_code * code)
> *** 5174,5185 ****
> {
> if (!code->expr3->mold
> || code->expr3->ts.type == BT_CHARACTER
> ! || vtab_needed)
> {
> /* Convert expr3 to a tree. */
> gfc_init_se (&se, NULL);
> ! /* For all "simple" expression just get the descriptor or the
> ! reference, respectively, depending on the rank of the expr. */
> if (code->expr3->rank != 0)
> gfc_conv_expr_descriptor (&se, code->expr3);
> else
> --- 5175,5195 ----
> {
> if (!code->expr3->mold
> || code->expr3->ts.type == BT_CHARACTER
> ! || vtab_needed
> ! || code->ext.alloc.arr_spec_from_expr3)
> {
> /* Convert expr3 to a tree. */
> gfc_init_se (&se, NULL);
> ! if (code->ext.alloc.arr_spec_from_expr3)
> ! {
> ! gfc_conv_expr_descriptor (&se, code->expr3);
> ! expr3_desc = se.expr;
> ! }
> ! else
> ! {
> ! /* For all "simple" expression just get the descriptor
> ! or the reference, respectively, depending on the
> ! rank of the expr. */
> if (code->expr3->rank != 0)
> gfc_conv_expr_descriptor (&se, code->expr3);
> else
> *************** gfc_trans_allocate (gfc_code * code)
> *** 5189,5194 ****
> --- 5199,5205 ----
> else
> expr3_tmp = se.expr;
> expr3_len = se.string_length;
> + }
> gfc_add_block_to_block (&block, &se.pre);
> gfc_add_block_to_block (&post, &se.post);
> }
This is skipping over setting expr3_len, is it on purpose?
Would it make sense to merge the two calls to gfc_conv_expr_descriptor?
> *************** gfc_trans_allocate (gfc_code * code)
> *** 5229,5235 ****
> }
> else
> tmp = se.expr;
> ! if (!code->expr3->mold)
> expr3 = tmp;
> else
> expr3_tmp = tmp;
> --- 5240,5248 ----
> }
> else
> tmp = se.expr;
> ! if (code->ext.alloc.arr_spec_from_expr3)
> ! expr3_desc = tmp;
> ! else if (!code->expr3->mold)
> expr3 = tmp;
> else
> expr3_tmp = tmp;
Couldn't expr3 be reused?
We had code->expr3, expr3, expr3rhs, and now this is adding expr3_desc,
and (below) inexpr3. :-(
> *************** gfc_trans_allocate (gfc_code * code)
> *** 5291,5296 ****
> --- 5304,5310 ----
> }
> else
> {
> + tree inexpr3;
> /* When the object to allocate is polymorphic type, then it
> needs its vtab set correctly, so deduce the required _vtab
> and _len from the source expression. */
> *************** gfc_trans_allocate (gfc_code * code)
> *** 5339,5345 ****
> don't have to take care about scalar to array treatment and
> will benefit of every enhancements gfc_trans_assignment ()
> gets. */
> ! if (expr3 != NULL_TREE && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
> {
> /* Build a temporary symtree and symbol. Do not add it to
> the current namespace to prevent accidently modifying
> --- 5353,5361 ----
> don't have to take care about scalar to array treatment and
> will benefit of every enhancements gfc_trans_assignment ()
> gets. */
> ! inexpr3 = expr3_desc ? expr3_desc : expr3;
> ! if (inexpr3 != NULL_TREE && DECL_P (inexpr3)
> ! && DECL_ARTIFICIAL (inexpr3))
> {
> /* Build a temporary symtree and symbol. Do not add it to
> the current namespace to prevent accidently modifying
>
[...]
>>> + if (source_ref->type == AR_FULL)
>>> + {
>>> + /* For full array refs copy the bounds. */
>>> + for (; dim < dataref->u.c.component->as->rank;
>>> dim++)
>>> + {
>>> + ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
>>> + ref->u.ar.start[dim] =
>>> + gfc_copy_expr
>>> (source_ref->as->lower[dim]);
>>> + ref->u.ar.end[dim] =
>>> + gfc_copy_expr
>>> (source_ref->as->upper[dim]);
>>> + }
>> This won't work. Consider this:
>> block
>> integer :: a(n)
>> n = n+1
>> allocate(b, source=a)
>> end block
>>
>> You have to use a full array ref. In fact you can use a full array ref
>> everywhere, I think.
>
> I don't get you there. Using a full array ref produces numerous regressions.
> Have a look at the current patch. The full array ref is in the
> #if-#else-#endif's #else block. Any ideas?
>
The attached patch seems to work. It is basically the same as your
#else branch.
I think the problem was gfc_get_full_arrayspec_from_expr can return NULL
in some cases.
Mikael
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index a2f8216..b3d3ddc 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5759,86 +5759,15 @@ gfc_trans_allocate (gfc_code * code)
if (dataref && dataref->u.c.component->as)
{
-#if 1
- int dim = 0;
- gfc_expr *temp;
- gfc_ref *ref = dataref->next;
- ref->u.ar.type = AR_SECTION;
- if (code->ext.alloc.arr_spec_from_expr3)
- {
- /* Take the array dimensions from the
- source=-expression. */
- gfc_array_ref *source_ref =
- gfc_find_array_ref (e3rhs ? e3rhs : code->expr3);
- if (source_ref->type == AR_FULL)
- {
- /* For full array refs copy the bounds. */
- for (; dim < dataref->u.c.component->as->rank; dim++)
- {
- ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
- ref->u.ar.start[dim] =
- gfc_copy_expr (source_ref->as->lower[dim]);
- ref->u.ar.end[dim] =
- gfc_copy_expr (source_ref->as->upper[dim]);
- }
- }
- else
- {
- int sdim = 0;
- /* For partial array refs, the partials. */
- for (; dim < dataref->u.c.component->as->rank;
- dim++, sdim++)
- {
- ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
- ref->u.ar.start[dim] =
- gfc_get_int_expr (gfc_default_integer_kind,
- &al->expr->where, 1);
- /* Skip over element dimensions. */
- while (source_ref->dimen_type[sdim]
- == DIMEN_ELEMENT)
- ++sdim;
- temp = gfc_subtract (gfc_copy_expr (
- source_ref->end[sdim]),
- gfc_copy_expr (
- source_ref->start[sdim]));
- ref->u.ar.end[dim] = gfc_add (temp,
- gfc_get_int_expr (gfc_default_integer_kind,
- &al->expr->where, 1));
- }
- }
- }
- else
- {
- /* We have to set up the array reference to give ranges
- in all dimensions and ensure that the end and stride
- are set so that the copy can be scalarized. */
- for (; dim < dataref->u.c.component->as->rank; dim++)
- {
- ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
- if (ref->u.ar.end[dim] == NULL)
- {
- ref->u.ar.end[dim] = ref->u.ar.start[dim];
- temp = gfc_get_int_expr (gfc_default_integer_kind,
- &al->expr->where, 1);
- ref->u.ar.start[dim] = temp;
- }
- temp = gfc_subtract (gfc_copy_expr (
- ref->u.ar.end[dim]),
- gfc_copy_expr (
- ref->u.ar.start[dim]));
- temp = gfc_add (gfc_get_int_expr (
- gfc_default_integer_kind,
- &al->expr->where, 1),
- temp);
- }
- }
-#else
+ gfc_array_spec *as = dataref->u.c.component->as;
+
gfc_free_ref_list (dataref->next);
dataref->next = NULL;
- gfc_add_full_array_ref (last_arg->expr,
- gfc_get_full_arrayspec_from_expr (e3rhs ? e3rhs
- : code->expr3));
-#endif
+ gfc_add_full_array_ref (last_arg->expr, as);
+ gfc_resolve_expr (last_arg->expr);
+ gcc_assert (last_arg->expr->ts.type == BT_CLASS
+ || last_arg->expr->ts.type == BT_DERIVED);
+ last_arg->expr->ts.type = BT_CLASS;
}
if (rhs->ts.type == BT_CLASS)
{
