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) {