Hi Mikael,
thanks for the comments so far.
> I don't understand why one of your previous patches was factoring the
> source expression evaluation to a temporary in gfc_trans_allocate, and
> now with this patch you do the same thing in gfc_resolve_allocate, not
> reusing the part in gfc_trans_allocate.
When I remember correctly, then at the time of writing this patch the one
factoring out the temporary in gfc_trans_allocate() was not doing that yet. At
least it was not doing it always as needed. Therefore we are looking at a kind
of history here already.
>
> > *************** failure:
> > *** 7201,7212 ****
> > --- 7212,7229 ----
> > return false;
> > }
> >
> > +
> > static void
> > resolve_allocate_deallocate (gfc_code *code, const char *fcn)
> > {
> > gfc_expr *stat, *errmsg, *pe, *qe;
> > gfc_alloc *a, *p, *q;
> >
> > + /* When this flag is set already, then this allocate has already been
> > + resolved. Doing so again, would result in an endless loop. */
> > + if (code->ext.alloc.arr_spec_from_expr3)
> > + return;
> > +
> I expect you'll miss some error messages by doing this.
> Where is the endless loop?
This has been removed. The endless loop was triggered by gfc_resolve_code () in
line 179 of the patch, which is now in chunk that is mostly removed.
> > *************** resolve_allocate_deallocate (gfc_code *c
> > *** 7375,7382 ****
> > --- 7392,7500 ----
> >
> > 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, &arr_alloc_wo_spec);
> > !
> > ! if (arr_alloc_wo_spec && code->expr3)
> > ! {
> [...]
> > !
> > ! ass = gfc_get_code (EXEC_ASSIGN);
> This memory is not freed as far as I know.
> I think you can use a local variable for it.
Complete block removed. Therefore fixed.
> *** /tmp/PRaWHc_trans-expr.c 2015-05-25 19:54:35.056309429 +0200
> --- /tmp/7e82nd_trans-expr.c 2015-05-25 19:54:35.058309429 +0200
> *************** gfc_conv_procedure_call (gfc_se * se, gf
> *** 5328,5334 ****
> 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))
> {
> int parm_rank;
> tmp = build_fold_indirect_ref_loc (input_location,
> --- 5328,5335 ----
> 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_STRUCTURE)
> {
> int parm_rank;
> tmp = build_fold_indirect_ref_loc (input_location,
>
> Can't you remove this? It's undone by the PR58586 patch.
Removed, looks like an artefact of a long forgotten need.
> > *************** gfc_trans_allocate (gfc_code * code)
> > *** 5733,5746 ****
> >
> > 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;
> > --- 5758,5815 ----
> >
> > if (dataref && dataref->u.c.component->as)
> > {
> > ! 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 (code->expr3);
> Does this work? code->expr3 is not always a variable.
The block removed from resolve_allocate() ensured, that this was always a
variable. Therefore, yes, it had to work then. Now, we of course have far more
trouble.
>
> > + 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?
Bootstraps and regtests fine on x86_64-linux-gnu.
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 905d47c..211c781 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2396,6 +2396,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 e615cc6..315170a 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 c8fab45..014ee53 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -5005,7 +5005,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)
{
tree type;
tree tmp;
@@ -5020,7 +5021,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
tree var;
stmtblock_t thenblock;
stmtblock_t elseblock;
- gfc_expr *ubound;
+ gfc_expr *ubound = NULL;
gfc_se se;
int n;
@@ -5035,6 +5036,11 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
or_expr = boolean_false_node;
+ /* When expr3_desc is set, use its rank, because we want to allocate an
+ array with the array_spec coming from source=. */
+ if (expr3_desc != NULL_TREE)
+ rank = GFC_TYPE_ARRAY_RANK (TREE_TYPE (expr3_desc));
+
for (n = 0; n < rank; n++)
{
tree conv_lbound;
@@ -5044,24 +5050,29 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
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)
+ if (expr3_desc != NULL_TREE)
se.expr = gfc_index_one_node;
else
{
- gcc_assert (lower[n]);
- if (ubound)
- {
- gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- }
+ ubound = upper[n];
+ if (lower == NULL)
+ se.expr = gfc_index_one_node;
else
{
- se.expr = gfc_index_one_node;
- ubound = lower[n];
+ gcc_assert (lower[n]);
+ if (ubound)
+ {
+ gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ }
+ else
+ {
+ se.expr = gfc_index_one_node;
+ ubound = lower[n];
+ }
}
}
gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
@@ -5076,10 +5087,25 @@ 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)
+ {
+ /* 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;
@@ -5249,6 +5275,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*/
@@ -5256,7 +5309,7 @@ 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)
{
tree tmp;
tree pointer;
@@ -5274,21 +5327,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)
{
@@ -5324,7 +5380,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;
@@ -5338,10 +5395,11 @@ 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);
if (dimension)
{
@@ -7080,6 +7138,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..6e5378f 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);
/* 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 9be8a42..3916836 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5328,7 +5328,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 81943b0..c9c112f 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5104,7 +5104,7 @@ gfc_trans_allocate (gfc_code * code)
element size, i.e. _vptr%size, is stored in expr3_esize. Any of
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;
+ tree expr3, expr3_vptr, expr3_len, expr3_esize, expr3_desc;
stmtblock_t block;
stmtblock_t post;
tree nelems;
@@ -5117,6 +5117,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;
+ expr3_desc = NULL_TREE;
gfc_init_block (&block);
gfc_init_block (&post);
@@ -5174,21 +5175,31 @@ 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)
- gfc_conv_expr_descriptor (&se, code->expr3);
- else
- gfc_conv_expr_reference (&se, code->expr3);
- if (!code->expr3->mold)
- expr3 = se.expr;
+ if (code->ext.alloc.arr_spec_from_expr3)
+ {
+ gfc_conv_expr_descriptor (&se, code->expr3);
+ expr3_desc = se.expr;
+ }
else
- expr3_tmp = se.expr;
- expr3_len = se.string_length;
+ {
+ /* 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_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);
}
@@ -5215,7 +5226,7 @@ gfc_trans_allocate (gfc_code * code)
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. */
+ variable declaration. */
if (!VAR_P (se.expr))
{
tree var;
@@ -5229,7 +5240,9 @@ gfc_trans_allocate (gfc_code * code)
}
else
tmp = se.expr;
- if (!code->expr3->mold)
+ if (code->ext.alloc.arr_spec_from_expr3)
+ expr3_desc = tmp;
+ else if (!code->expr3->mold)
expr3 = tmp;
else
expr3_tmp = tmp;
@@ -5291,6 +5304,7 @@ gfc_trans_allocate (gfc_code * code)
}
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. */
@@ -5339,7 +5353,9 @@ gfc_trans_allocate (gfc_code * code)
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))
+ 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
@@ -5349,11 +5365,11 @@ gfc_trans_allocate (gfc_code * code)
gfc_create_var () took care about generating the
identifier. */
newsym->name = gfc_get_string (IDENTIFIER_POINTER (
- DECL_NAME (expr3)));
+ DECL_NAME (inexpr3)));
newsym->n.sym = gfc_new_symbol (newsym->name, NULL);
/* The backend_decl is known. It is expr3, which is inserted
here. */
- newsym->n.sym->backend_decl = expr3;
+ newsym->n.sym->backend_decl = inexpr3;
e3rhs = gfc_get_expr ();
e3rhs->ts = code->expr3->ts;
e3rhs->rank = code->expr3->rank;
@@ -5379,7 +5395,7 @@ gfc_trans_allocate (gfc_code * code)
newsym->n.sym->as = arr;
gfc_add_full_array_ref (e3rhs, arr);
}
- else if (POINTER_TYPE_P (TREE_TYPE (expr3)))
+ else if (POINTER_TYPE_P (TREE_TYPE (inexpr3)))
newsym->n.sym->attr.pointer = 1;
/* The string length is known to. Set it for char arrays. */
if (e3rhs->ts.type == BT_CHARACTER)
@@ -5490,7 +5506,8 @@ 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, expr3_desc))
{
/* A scalar or derived type. First compute the size to
allocate.
@@ -5693,17 +5710,26 @@ gfc_trans_allocate (gfc_code * code)
{
/* Initialization via SOURCE block (or static default initializer).
Classes need some special handling, so catch them first. */
- 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))))
+ if ((expr3_desc != NULL_TREE
+ || (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))))))
&& code->expr3->ts.type == BT_CLASS
&& (expr->ts.type == BT_CLASS
|| expr->ts.type == BT_DERIVED))
{
- tree to;
+ /* 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, from;
to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0);
- tmp = gfc_copy_class_to_class (expr3, to,
+ /* Only use the array descriptor in expr3_desc, when it is
+ set and not in a mold= expression. */
+ from = expr3_desc == NULL_TREE || code->expr3->mold ?
+ expr3 : GFC_DECL_SAVED_DESCRIPTOR (expr3_desc);
+ tmp = gfc_copy_class_to_class (from, to,
nelems, upoly_expr);
}
else if (al->expr->ts.type == BT_CLASS)
@@ -5734,30 +5760,86 @@ gfc_trans_allocate (gfc_code * code)
if (dataref && dataref->u.c.component->as)
{
- int dim;
+#if 1
+ int dim = 0;
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++)
+ 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
{
- ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
- if (ref->u.ar.end[dim] == NULL)
+ /* 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.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;
+ 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);
}
- 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_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
}
if (rhs->ts.type == BT_CLASS)
{
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
index f7e0109..59d08d6 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
@@ -1,28 +1,110 @@
-! { dg-do compile }
+! { dg-do run }
!
! Contributed by Reinhold Bader
!
program assumed_shape_01
- use, intrinsic :: iso_c_binding
implicit none
- type, bind(c) :: cstruct
- integer(c_int) :: i
- real(c_float) :: r(2)
+ type :: cstruct
+ integer :: i
+ real :: r(2)
end type cstruct
- interface
- subroutine psub(this, that) bind(c, name='Psub')
- import :: c_float, cstruct
- real(c_float) :: this(:,:)
- type(cstruct) :: that(:)
- end subroutine psub
- end interface
-
- real(c_float) :: t(3,7)
+
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 (u(1)%i /= 4 .or. any(abs(u(1)%r(:) - [1.1,2.2]) > 1E-6)) call abort()
+ deallocate (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" }
- call psub(t, 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
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_6.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_6.f08
new file mode 100644
index 0000000..86df531
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_6.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
+
