re PR fortran/44672 ([F08] ALLOCATE with SOURCE and no array-spec)
gcc/testsuite/ChangeLog: 2015-06-15 Andre Vehreschild <vehre@gmx.de> PR fortran/44672 PR fortran/45440 PR fortran/57307 * gfortran.dg/allocate_with_source_3.f90: Removed check for unimplemented error. * gfortran.dg/allocate_with_source_7.f08: New test. * gfortran.dg/allocate_with_source_8.f08: New test. gcc/fortran/ChangeLog: 2015-06-15 Andre Vehreschild <vehre@gmx.de> PR fortran/44672 PR fortran/45440 PR fortran/57307 * gfortran.h: Extend gfc_code.ext.alloc to carry a flag indicating that the array specification has to be taken from expr3. * resolve.c (resolve_allocate_expr): Add F2008 notify and flag indicating source driven array spec. (resolve_allocate_deallocate): Check for source driven array spec, when array to allocate has no explicit array spec. * trans-array.c (gfc_array_init_size): Get lower and upper bound from a tree array descriptor, except when the source expression is an array-constructor which is fixed to be one-based. (retrieve_last_ref): Extracted from gfc_array_allocate(). (gfc_array_allocate): Enable allocate(array, source= array_expression) as specified by F2008:C633. (gfc_conv_expr_descriptor): Add class tree expression into the saved descriptor for class arrays. * trans-array.h: Add temporary array descriptor to gfc_array_allocate (). * trans-expr.c (gfc_conv_procedure_call): Special handling for _copy() routine translation, that comes without an interface. Third and fourth argument are now passed by value. * trans-stmt.c (gfc_trans_allocate): Get expr3 array descriptor for temporary arrays to allow allocate(array, source = array_expression) for array without array specification. From-SVN: r224477
This commit is contained in:
Andre Vehreschild
Andre Vehreschild
parent
cf0c27ef2b
commit
1792349b0b
|
|
@ -1,3 +1,35 @@
|
|||
2015-06-15 Andre Vehreschild <vehre@gmx.de>
|
||||
|
||||
PR fortran/44672
|
||||
PR fortran/45440
|
||||
PR fortran/57307
|
||||
* gfortran.h: Extend gfc_code.ext.alloc to carry a
|
||||
flag indicating that the array specification has to be
|
||||
taken from expr3.
|
||||
* resolve.c (resolve_allocate_expr): Add F2008 notify
|
||||
and flag indicating source driven array spec.
|
||||
(resolve_allocate_deallocate): Check for source driven
|
||||
array spec, when array to allocate has no explicit
|
||||
array spec.
|
||||
* trans-array.c (gfc_array_init_size): Get lower and
|
||||
upper bound from a tree array descriptor, except when
|
||||
the source expression is an array-constructor which is
|
||||
fixed to be one-based.
|
||||
(retrieve_last_ref): Extracted from gfc_array_allocate().
|
||||
(gfc_array_allocate): Enable allocate(array, source=
|
||||
array_expression) as specified by F2008:C633.
|
||||
(gfc_conv_expr_descriptor): Add class tree expression
|
||||
into the saved descriptor for class arrays.
|
||||
* trans-array.h: Add temporary array descriptor to
|
||||
gfc_array_allocate ().
|
||||
* trans-expr.c (gfc_conv_procedure_call): Special handling
|
||||
for _copy() routine translation, that comes without an
|
||||
interface. Third and fourth argument are now passed by value.
|
||||
* trans-stmt.c (gfc_trans_allocate): Get expr3 array
|
||||
descriptor for temporary arrays to allow allocate(array,
|
||||
source = array_expression) for array without array
|
||||
specification.
|
||||
|
||||
2015-06-14 Thomas Koenig <tkoenig@gcc.gnu.org>
|
||||
|
||||
* intrinsic.texi: Change \leq to < in descrition of imaginary
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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,22 +5332,25 @@ 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)
|
||||
{
|
||||
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)
|
||||
if (!retrieve_last_ref (&ref, &prev_ref))
|
||||
return false;
|
||||
|
||||
if (ref->u.ar.type == AR_FULL && expr3 != NULL)
|
||||
{
|
||||
/* F08:C633: Array shape from expr3. */
|
||||
ref = expr3->ref;
|
||||
|
||||
/* 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)
|
||||
{
|
||||
allocatable = expr->symtree->n.sym->attr.allocatable;
|
||||
|
|
@ -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. */
|
||||
|
|
|
|||
|
|
@ -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 *,
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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,45 +5200,55 @@ 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), "source");
|
||||
gfc_add_modify_loc (input_location, &block, var, tmp);
|
||||
|
||||
/* Deallocate any allocatable components after all the allocations
|
||||
and assignments of expr3 have been completed. */
|
||||
if (code->expr3->ts.type == BT_DERIVED
|
||||
&& code->expr3->rank == 0
|
||||
&& code->expr3->ts.u.derived->attr.alloc_comp)
|
||||
{
|
||||
tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived,
|
||||
var, 0);
|
||||
gfc_add_expr_to_block (&post, 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);
|
||||
|
||||
/* Deallocate any allocatable components after all the allocations
|
||||
and assignments of expr3 have been completed. */
|
||||
if (code->expr3->ts.type == BT_DERIVED
|
||||
&& code->expr3->rank == 0
|
||||
&& code->expr3->ts.u.derived->attr.alloc_comp)
|
||||
{
|
||||
tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived,
|
||||
var, 0);
|
||||
gfc_add_expr_to_block (&post, 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
|
||||
|
|
@ -5258,10 +5263,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);
|
||||
|
|
@ -5281,9 +5282,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);
|
||||
|
|
@ -5344,8 +5343,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
|
||||
|
|
@ -5397,6 +5399,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)
|
||||
{
|
||||
|
|
@ -5496,7 +5504,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.
|
||||
|
|
@ -5702,11 +5714,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,
|
||||
|
|
@ -5740,30 +5756,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)
|
||||
{
|
||||
|
|
@ -5845,7 +5845,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
|
||||
|
|
|
|||
|
|
@ -1,3 +1,13 @@
|
|||
2015-06-15 Andre Vehreschild <vehre@gmx.de>
|
||||
|
||||
PR fortran/44672
|
||||
PR fortran/45440
|
||||
PR fortran/57307
|
||||
* gfortran.dg/allocate_with_source_3.f90: Removed check for
|
||||
unimplemented error.
|
||||
* gfortran.dg/allocate_with_source_7.f08: New test.
|
||||
* gfortran.dg/allocate_with_source_8.f08: New test.
|
||||
|
||||
2015-06-13 Patrick Palka <ppalka@gcc.gnu.org>
|
||||
|
||||
PR c++/65168
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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 <burnus@gcc.gnu.org>
|
||||
! Antony Lewis <antony@cosmologist.info>
|
||||
! Andre Vehreschild <vehre@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
|
||||
|
||||
|
|
@ -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
|
||||
Loading…
Reference in New Issue