Hi all, please find attached an updated version of the patch. This patch simplifies some cases and ensures more straight line code. Furthermore was a bug in the interfacing routine for the _vptr->_copy() routine removed, where not the third and fourth arguments translated to be passed be value but the fourth and fifth (cs start counting at zero...).
Bootstraps and regtests fine on x86_64-linux-gnu/f21.
Ok for trunk?
Regards,
Andre
On Fri, 5 Jun 2015 13:04:01 +0200
Andre Vehreschild <ve...@gmx.de> wrote:
> Hi all,
>
> attached is the most recent version of the patch. It addresses the standard
> violation of allocate(foo, source=[bar(something)]), where foo after the
> allocate was a zero-based array instead of a one-based. Furthermore does this
> patch fix calling _vptr->_copy () routines, which come without an interface
> specification leading to pass all arguments by reference. When copying a
> deferred length string this is hazardous, because a __copy_character_* ()
> routines third and fourth arguments are passed by value. This is fixed by
> simply counting the actual arguments and using pass by value for third and
> fourth to _copy routine.
>
> Bootstraps and regtests ok on x86_64-linux-gnu/f21.
>
> Ok for trunk?
>
> - Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
pr44672_10.clog
Description: Binary data
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 8e4ca42..4b07ddb 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2395,6 +2395,9 @@ typedef struct gfc_code
{
gfc_typespec ts;
gfc_alloc *list;
+ /* Take the array specification from expr3 to allocate arrays
+ without an explicit array specification. */
+ unsigned arr_spec_from_expr3:1;
}
alloc;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 52dc109..f365e8f 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6805,7 +6805,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
have a trailing array reference that gives the size of the array. */
static bool
-resolve_allocate_expr (gfc_expr *e, gfc_code *code)
+resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
{
int i, pointer, allocatable, dimension, is_abstract;
int codimension;
@@ -7104,13 +7104,24 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
|| (dimension && ref2->u.ar.dimen == 0))
{
- gfc_error ("Array specification required in ALLOCATE statement "
- "at %L", &e->where);
- goto failure;
+ /* 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. */
+ context of an ALLOCATE specification. */
ar = &ref2->u.ar;
@@ -7125,7 +7136,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
for (i = 0; i < ar->dimen; i++)
{
- if (ref2->u.ar.type == AR_ELEMENT)
+ if (ar->type == AR_ELEMENT || ar->type == AR_FULL)
goto check_symbols;
switch (ar->dimen_type[i])
@@ -7202,6 +7213,7 @@ failure:
return false;
}
+
static void
resolve_allocate_deallocate (gfc_code *code, const char *fcn)
{
@@ -7376,8 +7388,16 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
if (strcmp (fcn, "ALLOCATE") == 0)
{
+ bool arr_alloc_wo_spec = false;
for (a = code->ext.alloc.list; a; a = a->next)
- resolve_allocate_expr (a->expr, code);
+ resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec);
+
+ if (arr_alloc_wo_spec && code->expr3)
+ {
+ /* Mark the allocate to have to take the array specification
+ from the expr3. */
+ code->ext.alloc.arr_spec_from_expr3 = 1;
+ }
}
else
{
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 5ea9aec..e9174ae 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4998,7 +4998,8 @@ static tree
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
stmtblock_t * descriptor_block, tree * overflow,
- tree expr3_elem_size, tree *nelems, gfc_expr *expr3)
+ tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
+ tree expr3_desc, bool e3_is_array_constr)
{
tree type;
tree tmp;
@@ -5041,7 +5042,18 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set lower bound. */
gfc_init_se (&se, NULL);
- if (lower == NULL)
+ if (expr3_desc != NULL_TREE)
+ {
+ if (e3_is_array_constr)
+ /* The lbound of a constant array [] starts at zero, but when
+ allocating it, the standard expects the array to start at
+ one. */
+ se.expr = gfc_index_one_node;
+ else
+ se.expr = gfc_conv_descriptor_lbound_get (expr3_desc,
+ gfc_rank_cst[n]);
+ }
+ else if (lower == NULL)
se.expr = gfc_index_one_node;
else
{
@@ -5069,10 +5081,35 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* 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);
-
+ if (expr3_desc != NULL_TREE)
+ {
+ if (e3_is_array_constr)
+ {
+ /* The lbound of a constant array [] starts at zero, but when
+ allocating it, the standard expects the array to start at
+ one. Therefore fix 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]));
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, tmp,
+ gfc_index_one_node);
+ se.expr = gfc_evaluate_now (tmp, pblock);
+ }
+ else
+ se.expr = gfc_conv_descriptor_ubound_get (expr3_desc,
+ gfc_rank_cst[n]);
+ }
+ 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;
@@ -5242,6 +5279,33 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
}
+/* Retrieve the last ref from the chain. This routine is specific to
+ gfc_array_allocate ()'s needs. */
+
+bool
+retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
+{
+ gfc_ref *ref, *prev_ref;
+
+ ref = *ref_in;
+ /* Prevent warnings for uninitialized variables. */
+ prev_ref = *prev_ref_in;
+ while (ref && ref->next != NULL)
+ {
+ gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
+ || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
+ prev_ref = ref;
+ ref = ref->next;
+ }
+
+ if (ref == NULL || ref->type != REF_ARRAY)
+ return false;
+
+ *ref_in = ref;
+ *prev_ref_in = prev_ref;
+ return true;
+}
+
/* Initializes the descriptor and generates a call to _gfor_allocate. Does
the work for an ALLOCATE statement. */
/*GCC ARRAYS*/
@@ -5249,7 +5313,8 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
tree errlen, tree label_finish, tree expr3_elem_size,
- tree *nelems, gfc_expr *expr3)
+ tree *nelems, gfc_expr *expr3, tree e3_arr_desc,
+ bool e3_is_array_constr)
{
tree tmp;
tree pointer;
@@ -5267,21 +5332,24 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
gfc_expr **lower;
gfc_expr **upper;
gfc_ref *ref, *prev_ref = NULL;
- bool allocatable, coarray, dimension;
+ bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false;
ref = expr->ref;
/* Find the last reference in the chain. */
- while (ref && ref->next != NULL)
+ if (!retrieve_last_ref (&ref, &prev_ref))
+ return false;
+
+ if (ref->u.ar.type == AR_FULL && expr3 != NULL)
{
- gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
- || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
- prev_ref = ref;
- ref = ref->next;
- }
+ /* F08:C633: Array shape from expr3. */
+ ref = expr3->ref;
- if (ref == NULL || ref->type != REF_ARRAY)
- return false;
+ /* Find the last reference in the chain. */
+ if (!retrieve_last_ref (&ref, &prev_ref))
+ return false;
+ alloc_w_e3_arr_spec = true;
+ }
if (!prev_ref)
{
@@ -5317,7 +5385,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
break;
case AR_FULL:
- gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
+ gcc_assert (ref->u.ar.as->type == AS_EXPLICIT
+ || alloc_w_e3_arr_spec);
lower = ref->u.ar.as->lower;
upper = ref->u.ar.as->upper;
@@ -5331,10 +5400,12 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
overflow = integer_zero_node;
gfc_init_block (&set_descriptor_block);
- size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
+ size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
+ : ref->u.ar.as->rank,
ref->u.ar.as->corank, &offset, lower, upper,
&se->pre, &set_descriptor_block, &overflow,
- expr3_elem_size, nelems, expr3);
+ expr3_elem_size, nelems, expr3, e3_arr_desc,
+ e3_is_array_constr);
if (dimension)
{
@@ -7073,6 +7144,16 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
desc = parm;
}
+ /* For class arrays add the class tree into the saved descriptor to
+ enable getting of _vptr and the like. */
+ if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
+ && IS_CLASS_ARRAY (expr->symtree->n.sym)
+ && DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl))
+ {
+ gfc_allocate_lang_decl (desc);
+ GFC_DECL_SAVED_DESCRIPTOR (desc) =
+ GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl);
+ }
if (!se->direct_byref || se->byref_noassign)
{
/* Get a pointer to the new descriptor. */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 2155b58..52f1c9a 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -24,7 +24,7 @@ tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*);
/* Generate code to initialize and allocate an array. Statements are added to
se, which should contain an expression for the array descriptor. */
bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
- tree, tree *, gfc_expr *);
+ tree, tree *, gfc_expr *, tree, bool);
/* Allow the bounds of a loop to be set from a callee's array spec. */
void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 1c880bc..e75577e 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4561,6 +4561,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
int has_alternate_specifier = 0;
bool need_interface_mapping;
bool callee_alloc;
+ bool ulim_copy;
gfc_typespec ts;
gfc_charlen cl;
gfc_expr *e;
@@ -4569,6 +4570,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
gfc_component *comp = NULL;
int arglen;
+ unsigned int argc;
arglist = NULL;
retargs = NULL;
@@ -4624,10 +4626,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
base_object = NULL_TREE;
+ /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
+ is the third and fourth argument to such a function call a value
+ denoting the number of elements to copy (i.e., most of the time the
+ length of a deferred length string). */
+ ulim_copy = formal == NULL && UNLIMITED_POLY (sym)
+ && strcmp ("_copy", comp->name) == 0;
/* Evaluate the arguments. */
- for (arg = args; arg != NULL;
- arg = arg->next, formal = formal ? formal->next : NULL)
+ for (arg = args, argc = 0; arg != NULL;
+ arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
{
e = arg->expr;
fsym = formal ? formal->sym : NULL;
@@ -4729,7 +4737,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_init_se (&parmse, se);
parm_kind = ELEMENTAL;
- if (fsym && fsym->attr.value)
+ /* When no fsym is present, ulim_copy is set and this is a third or
+ fourth argument, use call-by-value instead of by reference to
+ hand the length properties to the copy routine (i.e., most of the
+ time this will be a call to a __copy_character_* routine where the
+ third and fourth arguments are the lengths of a deferred length
+ char array). */
+ if ((fsym && fsym->attr.value)
+ || (ulim_copy && (argc == 2 || argc == 3)))
gfc_conv_expr (&parmse, e);
else
gfc_conv_expr_reference (&parmse, e);
@@ -5322,7 +5337,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
&& e->ts.u.derived->attr.alloc_comp
&& !(e->symtree && e->symtree->n.sym->attr.pointer)
- && (e->expr_type != EXPR_VARIABLE && !e->rank))
+ && e->expr_type != EXPR_VARIABLE && !e->rank)
{
int parm_rank;
tmp = build_fold_indirect_ref_loc (input_location,
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index a7f39d0..0277d42 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5098,6 +5098,8 @@ gfc_trans_allocate (gfc_code * code)
the trees may be the NULL_TREE indicating that this is not
available for expr3's type. */
tree expr3, expr3_vptr, expr3_len, expr3_esize;
+ /* Classify what expr3 stores. */
+ enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is;
stmtblock_t block;
stmtblock_t post;
tree nelems;
@@ -5110,6 +5112,7 @@ gfc_trans_allocate (gfc_code * code)
stat = tmp = memsz = al_vptr = al_len = NULL_TREE;
expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE;
label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
+ e3_is = E3_UNSET;
gfc_init_block (&block);
gfc_init_block (&post);
@@ -5149,16 +5152,14 @@ gfc_trans_allocate (gfc_code * code)
expression. */
if (code->expr3)
{
- bool vtab_needed = false;
- /* expr3_tmp gets the tree when code->expr3.mold is set, i.e.,
- the expression is only needed to get the _vptr, _len a.s.o. */
- tree expr3_tmp = NULL_TREE;
+ bool vtab_needed = false, temp_var_needed = false;
/* Figure whether we need the vtab from expr3. */
for (al = code->ext.alloc.list; !vtab_needed && al != NULL;
al = al->next)
vtab_needed = (al->expr->ts.type == BT_CLASS);
+ gfc_init_se (&se, NULL);
/* When expr3 is a variable, i.e., a very simple expression,
then convert it once here. */
if (code->expr3->expr_type == EXPR_VARIABLE
@@ -5167,31 +5168,25 @@ gfc_trans_allocate (gfc_code * code)
{
if (!code->expr3->mold
|| code->expr3->ts.type == BT_CHARACTER
- || vtab_needed)
+ || vtab_needed
+ || code->ext.alloc.arr_spec_from_expr3)
{
- /* 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)
+ /* Convert expr3 to a tree. For all "simple" expression just
+ get the descriptor or the reference, respectively, depending
+ on the rank of the expr. */
+ if (code->ext.alloc.arr_spec_from_expr3 || code->expr3->rank != 0)
gfc_conv_expr_descriptor (&se, code->expr3);
else
gfc_conv_expr_reference (&se, code->expr3);
- if (!code->expr3->mold)
- expr3 = se.expr;
- 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);
+ /* Create a temp variable only for component refs to prevent
+ having to go through the full deref-chain each time and to
+ simplfy computation of array properties. */
+ temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF;
}
- /* else expr3 = NULL_TREE set above. */
}
else
{
- /* In all other cases evaluate the expr3 and create a
- temporary. */
- gfc_init_se (&se, NULL);
+ /* In all other cases evaluate the expr3. */
symbol_attribute attr;
/* Get the descriptor for all arrays, that are not allocatable or
pointer, because the latter are descriptors already. */
@@ -5205,32 +5200,43 @@ gfc_trans_allocate (gfc_code * code)
code->expr3->ts,
false, true,
false, false);
- gfc_add_block_to_block (&block, &se.pre);
- gfc_add_block_to_block (&post, &se.post);
- /* Prevent aliasing, i.e., se.expr may be already a
- variable declaration. */
- if (!VAR_P (se.expr))
+ temp_var_needed = !VAR_P (se.expr);
+ }
+ gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_block_to_block (&post, &se.post);
+ /* Prevent aliasing, i.e., se.expr may be already a
+ variable declaration. */
+ if (se.expr != NULL_TREE && temp_var_needed)
+ {
+ tree var;
+ tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) ?
+ se.expr
+ : build_fold_indirect_ref_loc (input_location, se.expr);
+ /* We need a regular (non-UID) symbol here, therefore give a
+ prefix. */
+ var = gfc_create_var (TREE_TYPE (tmp), "source");
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
{
- tree var;
- tmp = build_fold_indirect_ref_loc (input_location,
- se.expr);
- /* We need a regular (non-UID) symbol here, therefore give a
- prefix. */
- var = gfc_create_var (TREE_TYPE (tmp), "atmp");
- gfc_add_modify_loc (input_location, &block, var, tmp);
- tmp = var;
+ gfc_allocate_lang_decl (var);
+ GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr;
}
- else
- tmp = se.expr;
- if (!code->expr3->mold)
- expr3 = tmp;
- else
- expr3_tmp = tmp;
- /* When he length of a char array is easily available
- here, fix it for future use. */
+ gfc_add_modify_loc (input_location, &block, var, tmp);
+ expr3 = var;
if (se.string_length)
+ /* Evaluate it assuming that it also is complicated like expr3. */
expr3_len = gfc_evaluate_now (se.string_length, &block);
}
+ else
+ {
+ expr3 = se.expr;
+ expr3_len = se.string_length;
+ }
+ /* Store what the expr3 is to be used for. */
+ e3_is = expr3 != NULL_TREE ?
+ (code->ext.alloc.arr_spec_from_expr3 ?
+ E3_DESC
+ : (code->expr3->mold ? E3_MOLD : E3_SOURCE))
+ : E3_UNSET;
/* Figure how to get the _vtab entry. This also obtains the tree
expression for accessing the _len component, because only
@@ -5245,10 +5251,6 @@ gfc_trans_allocate (gfc_code * code)
if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3))
&& (VAR_P (expr3) || !code->expr3->ref))
tmp = gfc_class_vptr_get (expr3);
- else if (expr3_tmp != NULL_TREE
- && GFC_CLASS_TYPE_P (TREE_TYPE (expr3_tmp))
- && (VAR_P (expr3_tmp) || !code->expr3->ref))
- tmp = gfc_class_vptr_get (expr3_tmp);
else
{
rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
@@ -5268,9 +5270,7 @@ gfc_trans_allocate (gfc_code * code)
{
/* Same like for retrieving the _vptr. */
if (expr3 != NULL_TREE && !code->expr3->ref)
- expr3_len = gfc_class_len_get (expr3);
- else if (expr3_tmp != NULL_TREE && !code->expr3->ref)
- expr3_len = gfc_class_len_get (expr3_tmp);
+ expr3_len = gfc_class_len_get (expr3);
else
{
rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
@@ -5331,8 +5331,11 @@ gfc_trans_allocate (gfc_code * code)
advantage is, that we get scalarizer support for free,
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))
+ gets.
+ No need to check whether e3_is is E3_UNSET, because that is
+ done by expr3 != NULL_TREE. */
+ if (e3_is != E3_MOLD && 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
@@ -5384,6 +5387,12 @@ gfc_trans_allocate (gfc_code * code)
}
gcc_assert (expr3_esize);
expr3_esize = fold_convert (sizetype, expr3_esize);
+ if (e3_is == E3_MOLD)
+ {
+ /* The expr3 is no longer valid after this point. */
+ expr3 = NULL_TREE;
+ e3_is = E3_UNSET;
+ }
}
else if (code->ext.alloc.ts.type != BT_UNKNOWN)
{
@@ -5483,7 +5492,11 @@ gfc_trans_allocate (gfc_code * code)
else
tmp = expr3_esize;
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
- label_finish, tmp, &nelems, code->expr3))
+ label_finish, tmp, &nelems,
+ e3rhs ? e3rhs : code->expr3,
+ e3_is == E3_DESC ? expr3 : NULL_TREE,
+ code->expr3 != NULL && e3_is == E3_DESC
+ && code->expr3->expr_type == EXPR_ARRAY))
{
/* A scalar or derived type. First compute the size to
allocate.
@@ -5689,11 +5702,15 @@ gfc_trans_allocate (gfc_code * code)
if (expr3 != NULL_TREE
&& ((POINTER_TYPE_P (TREE_TYPE (expr3))
&& TREE_CODE (expr3) != POINTER_PLUS_EXPR)
- || (VAR_P (expr3) && GFC_CLASS_TYPE_P (TREE_TYPE (expr3))))
+ || (VAR_P (expr3) && GFC_CLASS_TYPE_P (
+ TREE_TYPE (expr3))))
&& code->expr3->ts.type == BT_CLASS
&& (expr->ts.type == BT_CLASS
|| expr->ts.type == BT_DERIVED))
{
+ /* copy_class_to_class can be used for class arrays, too.
+ It just needs to be ensured, that the decl_saved_descriptor
+ has a way to get to the vptr. */
tree to;
to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0);
tmp = gfc_copy_class_to_class (expr3, to,
@@ -5727,30 +5744,14 @@ gfc_trans_allocate (gfc_code * code)
if (dataref && dataref->u.c.component->as)
{
- int dim;
- gfc_expr *temp;
- gfc_ref *ref = dataref->next;
- ref->u.ar.type = AR_SECTION;
- /* 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. */
- dim = 0;
- 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);
- }
+ 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, 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)
{
@@ -5832,7 +5833,7 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_expr_to_block (&block, tmp);
}
else if (code->expr3 && code->expr3->mold
- && code->expr3->ts.type == BT_CLASS)
+ && code->expr3->ts.type == BT_CLASS)
{
/* Since the _vptr has already been assigned to the allocate
object, we can use gfc_copy_class_to_class in its
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
index f7e0109..93f6edb 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
@@ -21,7 +21,7 @@ program assumed_shape_01
type(cstruct), pointer :: u(:)
! The following is VALID Fortran 2008 but NOT YET supported
- allocate(u, source=[cstruct( 4, [1.1,2.2] ) ]) ! { dg-error "Array specification required in ALLOCATE statement" }
+ allocate(u, source=[cstruct( 4, [1.1,2.2] ) ])
call psub(t, u)
deallocate (u)
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08
new file mode 100644
index 0000000..86df531
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08
@@ -0,0 +1,79 @@
+! { dg-do run }
+!
+! Check that allocate with source for arrays without array-spec
+! works.
+! PR fortran/44672
+! Contributed by Tobias Burnus <bur...@gcc.gnu.org>
+! Antony Lewis <ant...@cosmologist.info>
+! Andre Vehreschild <ve...@gcc.gnu.org>
+!
+
+program allocate_with_source_6
+
+ type P
+ class(*), allocatable :: X(:,:)
+ end type
+
+ type t
+ end type t
+
+ type(t), allocatable :: a(:), b, c(:)
+ integer :: num_params_used = 6
+ integer, allocatable :: m(:)
+
+ allocate(b,c(5))
+ allocate(a(5), source=b)
+ deallocate(a)
+ allocate(a, source=c)
+ allocate(m, source=[(I, I=1, num_params_used)])
+ if (any(m /= [(I, I=1, num_params_used)])) call abort()
+ deallocate(a,b,m)
+ call testArrays()
+
+contains
+ subroutine testArrays()
+ type L
+ class(*), allocatable :: v(:)
+ end type
+ Type(P) Y
+ type(L) o
+ real arr(3,5)
+ real, allocatable :: v(:)
+
+ arr = 5
+ allocate(Y%X, source=arr)
+ select type (R => Y%X)
+ type is (real)
+ if (any(reshape(R, [15]) /= [5,5,5,5,5, 5,5,5,5,5, 5,5,5,5,5])) &
+ call abort()
+ class default
+ call abort()
+ end select
+ deallocate(Y%X)
+
+ allocate(Y%X, source=arr(2:3,3:4))
+ select type (R => Y%X)
+ type is (real)
+ if (any(reshape(R, [4]) /= [5,5,5,5])) &
+ call abort()
+ class default
+ call abort()
+ end select
+ deallocate(Y%X)
+
+ allocate(o%v, source=arr(2,3:4))
+ select type (R => o%v)
+ type is (real)
+ if (any(R /= [5,5])) &
+ call abort()
+ class default
+ call abort()
+ end select
+ deallocate(o%v)
+
+ allocate(v, source=arr(2,1:5))
+ if (any(v /= [5,5,5,5,5])) call abort()
+ deallocate(v)
+ end subroutine testArrays
+end
+
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_8.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_8.f08
new file mode 100644
index 0000000..b331866
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_8.f08
@@ -0,0 +1,110 @@
+! { dg-do run }
+!
+! Contributed by Reinhold Bader
+!
+program assumed_shape_01
+ implicit none
+ type :: cstruct
+ integer :: i
+ real :: r(2)
+ end type cstruct
+
+ type(cstruct), pointer :: u(:)
+ integer, allocatable :: iv(:), iv2(:)
+ integer, allocatable :: im(:,:)
+ integer, parameter :: cim(2,3) = reshape([1,2,3, 2,3,4], [2,3])
+ integer :: i
+ integer, parameter :: lcim(2,10) = reshape([(i, i=1,10),(i,i=1,10)], [2,10])
+
+ allocate(iv, source= [ 1, 2, 3, 4])
+ if (any(iv /= [ 1, 2, 3, 4])) call abort()
+ deallocate(iv)
+
+ allocate(iv, source=(/(i, i=1,10)/))
+ if (any(iv /= (/(i, i=1,10)/))) call abort()
+
+ ! Now 2D
+ allocate(im, source= cim)
+ if (any(im /= cim)) call abort()
+ deallocate(im)
+
+ allocate(im, source= reshape([iv, iv], [2, size(iv, 1)]))
+ if (any(im /= lcim)) call abort()
+ deallocate(im)
+ deallocate(iv)
+
+ allocate(u, source=[cstruct( 4, [1.1,2.2] )] )
+ if (any(u(:)%i /= 4) .or. any(abs(u(1)%r(:) - [1.1,2.2]) > 1E-6)) call abort()
+ deallocate (u)
+
+ allocate(iv, source= arrval())
+ if (any(iv /= [ 1, 2, 4, 5, 6])) call abort()
+ ! Check simple array assign
+ allocate(iv2, source=iv)
+ if (any(iv2 /= [ 1, 2, 4, 5, 6])) call abort()
+ deallocate(iv, iv2)
+
+ ! Now check for mold=
+ allocate(iv, mold= [ 1, 2, 3, 4])
+ if (any(shape(iv) /= [4])) call abort()
+ deallocate(iv)
+
+ allocate(iv, mold=(/(i, i=1,10)/))
+ if (any(shape(iv) /= [10])) call abort()
+
+ ! Now 2D
+ allocate(im, mold= cim)
+ if (any(shape(im) /= shape(cim))) call abort()
+ deallocate(im)
+
+ allocate(im, mold= reshape([iv, iv], [2, size(iv, 1)]))
+ if (any(shape(im) /= shape(lcim))) call abort()
+ deallocate(im)
+ deallocate(iv)
+
+ allocate(u, mold=[cstruct( 4, [1.1,2.2] )] )
+ if (any(shape(u(1)%r(:)) /= 2)) call abort()
+ deallocate (u)
+
+ allocate(iv, mold= arrval())
+ if (any(shape(iv) /= [5])) call abort()
+ ! Check simple array assign
+ allocate(iv2, mold=iv)
+ if (any(shape(iv2) /= [5])) call abort()
+ deallocate(iv, iv2)
+
+ call addData([4, 5])
+ call addData(["foo", "bar"])
+contains
+ function arrval()
+ integer, dimension(5) :: arrval
+ arrval = [ 1, 2, 4, 5, 6]
+ end function
+
+ subroutine addData(P)
+ class(*), intent(in) :: P(:)
+ class(*), allocatable :: cP(:)
+ allocate (cP, source= P)
+ select type (cP)
+ type is (integer)
+ if (any(cP /= [4,5])) call abort()
+ type is (character(*))
+ if (len(cP) /= 3) call abort()
+ if (any(cP /= ["foo", "bar"])) call abort()
+ class default
+ call abort()
+ end select
+ deallocate (cP)
+ allocate (cP, mold= P)
+ select type (cP)
+ type is (integer)
+ if (any(size(cP) /= [2])) call abort()
+ type is (character(*))
+ if (len(cP) /= 3) call abort()
+ if (any(size(cP) /= [2])) call abort()
+ class default
+ call abort()
+ end select
+ deallocate (cP)
+ end subroutine
+end program assumed_shape_01
