Skip to content

R
riscv-gcc-1
Commit 574284e9 by Andre Vehreschild
Options

re PR fortran/43366 ([OOP][F08] Intrinsic assign to polymorphic variable) 

gcc/fortran/ChangeLog:

2016-10-22  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/43366
	PR fortran/51864
	PR fortran/57117
	PR fortran/61337
	PR fortran/61376
	* primary.c (gfc_expr_attr): For transformational functions on classes
	get the attrs from the class argument.
	* resolve.c (resolve_ordinary_assign): Remove error message due to
	feature implementation.  Rewrite POINTER_ASSIGNS to ordinary ones when
	the right-hand side is scalar class object (with some restrictions).
	* trans-array.c (trans_array_constructor): Create the temporary from
	class' inner type, i.e., the derived type.
	(build_class_array_ref): Add support for class array's storage of the
	class object or the array descriptor in the decl saved descriptor.
	(gfc_conv_expr_descriptor): When creating temporaries for class objects
	add the class object's handle into the decl saved descriptor.
	(structure_alloc_comps): Use the common way to get the _data component.
	(gfc_is_reallocatable_lhs): Add notion of allocatable class objects.
	* trans-expr.c (gfc_find_and_cut_at_last_class_ref): Remove the only ref
	only when the expression's type is BT_CLASS.
	(gfc_trans_class_init_assign): Correctly handle class arrays.
	(gfc_trans_class_assign): Joined into gfc_trans_assignment_1.
	(gfc_conv_procedure_call): Support for class types as arguments.
	(trans_get_upoly_len): For unlimited polymorphics retrieve the _len
	component's tree.
	(trans_class_vptr_len_assignment): Catch all ways to assign the _vptr
	and _len components of a class object correctly.
	(pointer_assignment_is_proc_pointer): Identify assignments of
	procedure pointers.
	(gfc_trans_pointer_assignment): Enhance support for class object pointer
	assignments.
	(gfc_trans_scalar_assign): Removed assert.
	(trans_class_assignment): Assign to a class object.
	(gfc_trans_assignment_1): Treat class objects correctly.
	(gfc_trans_assignment): Propagate flags to trans_assignment_1.
	* trans-stmt.c (gfc_trans_allocate): Use gfc_trans_assignment now
	instead of copy_class_to_class.
	* trans-stmt.h: Function prototype removed.
	* trans.c (trans_code): Less special casing for class objects.
	* trans.h: Added flags to gfc_trans_assignment () prototype.

gcc/testsuite/ChangeLog:

2016-10-22  Andre Vehreschild  <vehre@gcc.gnu.org>

        Forgot to add on original commit.
        * gfortran.dg/coarray_alloc_comp_2.f08: New test.

2016-10-22  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/43366
	PR fortran/57117
	PR fortran/61337
	* gfortran.dg/alloc_comp_class_5.f03: New test.
	* gfortran.dg/class_allocate_21.f90: New test.
	* gfortran.dg/class_allocate_22.f90: New test.
	* gfortran.dg/realloc_on_assign_27.f08: New test.

From-SVN: r241439
parent 4e04812d
Showing with 837 additions and 368 deletions
gcc/fortran/ChangeLog
2016-10-22 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/43366
PR fortran/51864
PR fortran/57117
PR fortran/61337
PR fortran/61376
* primary.c (gfc_expr_attr): For transformational functions on classes
get the attrs from the class argument.
* resolve.c (resolve_ordinary_assign): Remove error message due to
feature implementation. Rewrite POINTER_ASSIGNS to ordinary ones when
the right-hand side is scalar class object (with some restrictions).
* trans-array.c (trans_array_constructor): Create the temporary from
class' inner type, i.e., the derived type.
(build_class_array_ref): Add support for class array's storage of the
class object or the array descriptor in the decl saved descriptor.
(gfc_conv_expr_descriptor): When creating temporaries for class objects
add the class object's handle into the decl saved descriptor.
(structure_alloc_comps): Use the common way to get the _data component.
(gfc_is_reallocatable_lhs): Add notion of allocatable class objects.
* trans-expr.c (gfc_find_and_cut_at_last_class_ref): Remove the only ref
only when the expression's type is BT_CLASS.
(gfc_trans_class_init_assign): Correctly handle class arrays.
(gfc_trans_class_assign): Joined into gfc_trans_assignment_1.
(gfc_conv_procedure_call): Support for class types as arguments.
(trans_get_upoly_len): For unlimited polymorphics retrieve the _len
component's tree.
(trans_class_vptr_len_assignment): Catch all ways to assign the _vptr
and _len components of a class object correctly.
(pointer_assignment_is_proc_pointer): Identify assignments of
procedure pointers.
(gfc_trans_pointer_assignment): Enhance support for class object pointer
assignments.
(gfc_trans_scalar_assign): Removed assert.
(trans_class_assignment): Assign to a class object.
(gfc_trans_assignment_1): Treat class objects correctly.
(gfc_trans_assignment): Propagate flags to trans_assignment_1.
* trans-stmt.c (gfc_trans_allocate): Use gfc_trans_assignment now
instead of copy_class_to_class.
* trans-stmt.h: Function prototype removed.
* trans.c (trans_code): Less special casing for class objects.
* trans.h: Added flags to gfc_trans_assignment () prototype.
2016-10-21 Paul Thomas <pault@gcc.gnu.org>
PR fortran/69566
......
gcc/fortran/primary.c
......@@ -2359,6 +2359,10 @@ gfc_expr_attr (gfc_expr *e)
attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
}
}
else if (e->value.function.isym
&& e->value.function.isym->transformational
&& e->ts.type == BT_CLASS)
attr = CLASS_DATA (e)->attr;
else
attr = gfc_variable_attr (e, NULL);
......
gcc/fortran/resolve.c
......@@ -9911,10 +9911,6 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
"requires %<-frealloc-lhs%>", &lhs->where);
return false;
}
/* See PR 43366. */
gfc_error ("Assignment to an allocatable polymorphic variable at %L "
"is not yet supported", &lhs->where);
return false;
}
else if (lhs->ts.type == BT_CLASS)
{
......@@ -10817,6 +10813,19 @@ start:
break;
gfc_check_pointer_assign (code->expr1, code->expr2);
/* Assigning a class object always is a regular assign. */
if (code->expr2->ts.type == BT_CLASS
&& !CLASS_DATA (code->expr2)->attr.dimension
&& !(UNLIMITED_POLY (code->expr2)
&& code->expr1->ts.type == BT_DERIVED
&& (code->expr1->ts.u.derived->attr.sequence
|| code->expr1->ts.u.derived->attr.is_bind_c))
&& !(gfc_expr_attr (code->expr1).proc_pointer
&& code->expr2->expr_type == EXPR_VARIABLE
&& code->expr2->symtree->n.sym->attr.flavor
== FL_PROCEDURE))
code->op = EXEC_ASSIGN;
break;
}
......
gcc/fortran/trans-array.c
......@@ -2292,7 +2292,8 @@ trans_array_constructor (gfc_ss * ss, locus * where)
type = build_pointer_type (type);
}
else
type = gfc_typenode_for_spec (&expr->ts);
type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
? &CLASS_DATA (expr)->ts : &expr->ts);
/* See if the constructor determines the loop bounds. */
dynamic = false;
......@@ -3036,23 +3037,29 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
tree type;
tree size;
tree offset;
tree decl;
tree decl = NULL_TREE;
tree tmp;
gfc_expr *expr = se->ss->info->expr;
gfc_ref *ref;
gfc_ref *class_ref;
gfc_ref *class_ref = NULL;
gfc_typespec *ts;
if (se->expr && DECL_P (se->expr) && DECL_LANG_SPECIFIC (se->expr)
&& GFC_DECL_SAVED_DESCRIPTOR (se->expr)
&& GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se->expr))))
decl = se->expr;
else
{
if (expr == NULL
|| (expr->ts.type != BT_CLASS
&& !gfc_is_alloc_class_array_function (expr)))
&& !gfc_is_alloc_class_array_function (expr)
&& !gfc_is_class_array_ref (expr, NULL)))
return false;
if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
ts = &expr->symtree->n.sym->ts;
else
ts = NULL;
class_ref = NULL;
for (ref = expr->ref; ref; ref = ref->next)
{
......@@ -3072,14 +3079,15 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
if (ts == NULL)
return false;
}
if (class_ref == NULL && expr->symtree->n.sym->attr.function
if (class_ref == NULL && expr && expr->symtree->n.sym->attr.function
&& expr->symtree->n.sym == expr->symtree->n.sym->result)
{
gcc_assert (expr->symtree->n.sym->backend_decl == current_function_decl);
decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0);
}
else if (gfc_is_alloc_class_array_function (expr))
else if (expr && gfc_is_alloc_class_array_function (expr))
{
size = NULL_TREE;
decl = NULL_TREE;
......@@ -3105,6 +3113,7 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
}
else if (class_ref == NULL)
{
if (decl == NULL_TREE)
decl = expr->symtree->n.sym->backend_decl;
/* For class arrays the tree containing the class is stored in
GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
......@@ -3121,6 +3130,7 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
class_ref->next = NULL;
gfc_init_se (&tmpse, NULL);
gfc_conv_expr (&tmpse, expr);
gfc_add_block_to_block (&se->pre, &tmpse.pre);
decl = tmpse.expr;
class_ref->next = ref;
}
......@@ -7094,6 +7104,28 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
loop.from, loop.to, 0,
GFC_ARRAY_UNKNOWN, false);
parm = gfc_create_var (parmtype, "parm");
/* When expression is a class object, then add the class' handle to
the parm_decl. */
if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
{
gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
gfc_se classse;
/* class_expr can be NULL, when no _class ref is in expr.
We must not fix this here with a gfc_fix_class_ref (). */
if (class_expr)
{
gfc_init_se (&classse, NULL);
gfc_conv_expr (&classse, class_expr);
gfc_free_expr (class_expr);
gcc_assert (classse.pre.head == NULL_TREE
&& classse.post.head == NULL_TREE);
gfc_allocate_lang_decl (parm);
GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
}
}
}
offset = gfc_index_zero_node;
......@@ -7255,6 +7287,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
: base;
gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
}
else if (IS_CLASS_ARRAY (expr) && !se->data_not_needed
&& (!rank_remap || se->use_offset)
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
{
gfc_conv_descriptor_offset_set (&loop.pre, parm,
gfc_conv_descriptor_offset_get (desc));
}
else if (onebased && (!rank_remap || se->use_offset)
&& expr->symtree
&& !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS
......@@ -7290,6 +7329,18 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
: expr->symtree->n.sym->backend_decl;
}
else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc)
&& IS_CLASS_ARRAY (expr))
{
tree vtype;
gfc_allocate_lang_decl (desc);
tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class");
GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp;
vtype = gfc_class_vptr_get (tmp);
gfc_add_modify (&se->pre, vtype,
gfc_build_addr_expr (TREE_TYPE (vtype),
gfc_find_vtab (&expr->ts)->backend_decl));
}
if (!se->direct_byref || se->byref_noassign)
{
/* Get a pointer to the new descriptor. */
......@@ -8200,10 +8251,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
/* Allocatable CLASS components. */
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
/* Add reference to '_data' component. */
tmp = CLASS_DATA (c)->backend_decl;
comp = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (tmp), comp, tmp, NULL_TREE);
comp = gfc_class_data_get (comp);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
else
......@@ -8541,6 +8590,14 @@ gfc_is_reallocatable_lhs (gfc_expr *expr)
if (!expr->ref)
return false;
/* An allocatable class variable with no reference. */
if (expr->symtree->n.sym->ts.type == BT_CLASS
&& CLASS_DATA (expr->symtree->n.sym)->attr.allocatable
&& expr->ref && expr->ref->type == REF_COMPONENT
&& strcmp (expr->ref->u.c.component->name, "_data") == 0
&& expr->ref->next == NULL)
return true;
/* An allocatable variable. */
if (expr->symtree->n.sym->attr.allocatable
&& expr->ref
......
gcc/fortran/trans-expr.c
......@@ -350,7 +350,7 @@ gfc_expr *
gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
{
gfc_expr *base_expr;
gfc_ref *ref, *class_ref, *tail, *array_ref;
gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
/* Find the last class reference. */
class_ref = NULL;
......@@ -383,7 +383,7 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
tail = class_ref->next;
class_ref->next = NULL;
}
else
else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
{
tail = e->ref;
e->ref = NULL;
......@@ -397,7 +397,7 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
gfc_free_ref_list (class_ref->next);
class_ref->next = tail;
}
else
else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
{
gfc_free_ref_list (e->ref);
e->ref = tail;
......@@ -1458,7 +1458,12 @@ gfc_trans_class_init_assign (gfc_code *code)
if (code->expr1->ts.type == BT_CLASS
&& CLASS_DATA (code->expr1)->attr.dimension)
{
gfc_array_spec *tmparr = gfc_get_array_spec ();
*tmparr = *CLASS_DATA (code->expr1)->as;
gfc_add_full_array_ref (lhs, tmparr);
tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
}
else
{
sz = gfc_copy_expr (code->expr1);
......@@ -1503,114 +1508,6 @@ gfc_trans_class_init_assign (gfc_code *code)
}
/* Translate an assignment to a CLASS object
(pointer or ordinary assignment). */
tree
gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
{
stmtblock_t block;
tree tmp;
gfc_expr *lhs;
gfc_expr *rhs;
gfc_ref *ref;
gfc_start_block (&block);
ref = expr1->ref;
while (ref && ref->next)
ref = ref->next;
/* Class valued proc_pointer assignments do not need any further
preparation. */
if (ref && ref->type == REF_COMPONENT
&& ref->u.c.component->attr.proc_pointer
&& expr2->expr_type == EXPR_VARIABLE
&& expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE
&& op == EXEC_POINTER_ASSIGN)
goto assign;
if (expr2->ts.type != BT_CLASS)
{
/* Insert an additional assignment which sets the '_vptr' field. */
gfc_symbol *vtab = NULL;
gfc_symtree *st;
lhs = gfc_copy_expr (expr1);
gfc_add_vptr_component (lhs);
if (UNLIMITED_POLY (expr1)
&& expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN)
{
rhs = gfc_get_null_expr (&expr2->where);
goto assign_vptr;
}
if (expr2->expr_type == EXPR_NULL)
vtab = gfc_find_vtab (&expr1->ts);
else
vtab = gfc_find_vtab (&expr2->ts);
gcc_assert (vtab);
rhs = gfc_get_expr ();
rhs->expr_type = EXPR_VARIABLE;
gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
rhs->symtree = st;
rhs->ts = vtab->ts;
assign_vptr:
tmp = gfc_trans_pointer_assignment (lhs, rhs);
gfc_add_expr_to_block (&block, tmp);
gfc_free_expr (lhs);
gfc_free_expr (rhs);
}
else if (expr1->ts.type == BT_DERIVED && UNLIMITED_POLY (expr2))
{
/* F2003:C717 only sequence and bind-C types can come here. */
gcc_assert (expr1->ts.u.derived->attr.sequence
|| expr1->ts.u.derived->attr.is_bind_c);
gfc_add_data_component (expr2);
goto assign;
}
else if (CLASS_DATA (expr2)->attr.dimension && expr2->expr_type != EXPR_FUNCTION)
{
/* Insert an additional assignment which sets the '_vptr' field. */
lhs = gfc_copy_expr (expr1);
gfc_add_vptr_component (lhs);
rhs = gfc_copy_expr (expr2);
gfc_add_vptr_component (rhs);
tmp = gfc_trans_pointer_assignment (lhs, rhs);
gfc_add_expr_to_block (&block, tmp);
gfc_free_expr (lhs);
gfc_free_expr (rhs);
}
/* Do the actual CLASS assignment. */
if (expr2->ts.type == BT_CLASS
&& !CLASS_DATA (expr2)->attr.dimension)
op = EXEC_ASSIGN;
else if (expr2->expr_type != EXPR_FUNCTION || expr2->ts.type != BT_CLASS
|| !CLASS_DATA (expr2)->attr.dimension)
gfc_add_data_component (expr1);
assign:
if (op == EXEC_ASSIGN)
tmp = gfc_trans_assignment (expr1, expr2, false, true);
else if (op == EXEC_POINTER_ASSIGN)
tmp = gfc_trans_pointer_assignment (expr1, expr2);
else
gcc_unreachable();
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}
/* End of prototype trans-class.c */
......@@ -5908,6 +5805,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (comp)
ts = comp->ts;
else if (sym->ts.type == BT_CLASS)
ts = CLASS_DATA (sym)->ts;
else
ts = sym->ts;
......@@ -6264,6 +6163,26 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
}
/* Associate the rhs class object's meta-data with the result, when the
result is a temporary. */
if (args && args->expr && args->expr->ts.type == BT_CLASS
&& sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
&& !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
{
gfc_se parmse;
gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
gfc_init_se (&parmse, NULL);
parmse.data_not_needed = 1;
gfc_conv_expr (&parmse, class_expr);
if (!DECL_LANG_SPECIFIC (result))
gfc_allocate_lang_decl (result);
GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
gfc_free_expr (class_expr);
gcc_assert (parmse.pre.head == NULL_TREE
&& parmse.post.head == NULL_TREE);
}
/* Follow the function call with the argument post block. */
if (byref)
{
......@@ -7886,6 +7805,201 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
}
/* Get the _len component for an unlimited polymorphic expression. */
static tree
trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
{
gfc_se se;
gfc_ref *ref = expr->ref;
gfc_init_se (&se, NULL);
while (ref && ref->next)
ref = ref->next;
gfc_add_len_component (expr);
gfc_conv_expr (&se, expr);
gfc_add_block_to_block (block, &se.pre);
gcc_assert (se.post.head == NULL_TREE);
if (ref)
{
gfc_free_ref_list (ref->next);
ref->next = NULL;
}
else
{
gfc_free_ref_list (expr->ref);
expr->ref = NULL;
}
return se.expr;
}
/* Assign _vptr and _len components as appropriate. BLOCK should be a
statement-list outside of the scalarizer-loop. When code is generated, that
depends on the scalarized expression, it is added to RSE.PRE.
Returns le's _vptr tree and when set the len expressions in to_lenp and
from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
expression. */
static tree
trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
gfc_expr * re, gfc_se *rse,
tree * to_lenp, tree * from_lenp)
{
gfc_se se;
gfc_expr * vptr_expr;
tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
bool set_vptr = false, temp_rhs = false;
stmtblock_t *pre = block;
/* Create a temporary for complicated expressions. */
if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
&& rse->expr != NULL_TREE && !DECL_P (rse->expr))
{
tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
pre = &rse->pre;
gfc_add_modify (&rse->pre, tmp, rse->expr);
rse->expr = tmp;
temp_rhs = true;
}
/* Get the _vptr for the left-hand side expression. */
gfc_init_se (&se, NULL);
vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
{
/* Care about _len for unlimited polymorphic entities. */
if (UNLIMITED_POLY (vptr_expr)
|| (vptr_expr->ts.type == BT_DERIVED
&& vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
to_len = trans_get_upoly_len (block, vptr_expr);
gfc_add_vptr_component (vptr_expr);
set_vptr = true;
}
else
vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
se.want_pointer = 1;
gfc_conv_expr (&se, vptr_expr);
gfc_free_expr (vptr_expr);
gfc_add_block_to_block (block, &se.pre);
gcc_assert (se.post.head == NULL_TREE);
lhs_vptr = se.expr;
STRIP_NOPS (lhs_vptr);
/* Set the _vptr only when the left-hand side of the assignment is a
class-object. */
if (set_vptr)
{
/* Get the vptr from the rhs expression only, when it is variable.
Functions are expected to be assigned to a temporary beforehand. */
vptr_expr = re->expr_type == EXPR_VARIABLE
? gfc_find_and_cut_at_last_class_ref (re)
: NULL;
if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
{
if (to_len != NULL_TREE)
{
/* Get the _len information from the rhs. */
if (UNLIMITED_POLY (vptr_expr)
|| (vptr_expr->ts.type == BT_DERIVED
&& vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
from_len = trans_get_upoly_len (block, vptr_expr);
}
gfc_add_vptr_component (vptr_expr);
}
else
{
if (re->expr_type == EXPR_VARIABLE
&& DECL_P (re->symtree->n.sym->backend_decl)
&& DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
&& GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
&& GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
re->symtree->n.sym->backend_decl))))
{
vptr_expr = NULL;
se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
re->symtree->n.sym->backend_decl));
if (to_len)
from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
re->symtree->n.sym->backend_decl));
}
else if (temp_rhs && re->ts.type == BT_CLASS)
{
vptr_expr = NULL;
se.expr = gfc_class_vptr_get (rse->expr);
}
else if (re->expr_type != EXPR_NULL)
/* Only when rhs is non-NULL use its declared type for vptr
initialisation. */
vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
else
/* When the rhs is NULL use the vtab of lhs' declared type. */
vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
}
if (vptr_expr)
{
gfc_init_se (&se, NULL);
se.want_pointer = 1;
gfc_conv_expr (&se, vptr_expr);
gfc_free_expr (vptr_expr);
gfc_add_block_to_block (block, &se.pre);
gcc_assert (se.post.head == NULL_TREE);
}
gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
se.expr));
if (to_len != NULL_TREE)
{
/* The _len component needs to be set. Figure how to get the
value of the right-hand side. */
if (from_len == NULL_TREE)
{
if (rse->string_length != NULL_TREE)
from_len = rse->string_length;
else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
{
from_len = gfc_get_expr_charlen (re);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, re->ts.u.cl->length);
gfc_add_block_to_block (block, &se.pre);
gcc_assert (se.post.head == NULL_TREE);
from_len = gfc_evaluate_now (se.expr, block);
}
else
from_len = integer_zero_node;
}
gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
from_len));
}
}
/* Return the _len trees only, when requested. */
if (to_lenp)
*to_lenp = to_len;
if (from_lenp)
*from_lenp = from_len;
return lhs_vptr;
}
/* Indentify class valued proc_pointer assignments. */
static bool
pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
{
gfc_ref * ref;
ref = expr1->ref;
while (ref && ref->next)
ref = ref->next;
return ref && ref->type == REF_COMPONENT
&& ref->u.c.component->attr.proc_pointer
&& expr2->expr_type == EXPR_VARIABLE
&& expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE;
}
tree
gfc_trans_pointer_assign (gfc_code * code)
{
......@@ -7898,20 +8012,22 @@ gfc_trans_pointer_assign (gfc_code * code)
tree
gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
{
gfc_expr *expr1_vptr = NULL;
gfc_se lse;
gfc_se rse;
stmtblock_t block;
tree desc;
tree tmp;
tree decl;
bool scalar;
bool scalar, non_proc_pointer_assign;
gfc_ss *ss;
gfc_start_block (&block);
gfc_init_se (&lse, NULL);
/* Usually testing whether this is not a proc pointer assignment. */
non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2);
/* Check whether the expression is a scalar or not; we cannot use
expr1->rank as it can be nonzero for proc pointers. */
ss = gfc_walk_expr (expr1);
......@@ -7920,7 +8036,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_free_ss_chain (ss);
if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
&& expr2->expr_type != EXPR_FUNCTION)
&& expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign)
{
gfc_add_data_component (expr2);
/* The following is required as gfc_add_data_component doesn't
......@@ -7937,6 +8053,13 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
rse.want_pointer = 1;
gfc_conv_expr (&rse, expr2);
if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
{
trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
NULL);
lse.expr = gfc_class_data_get (lse.expr);
}
if (expr1->symtree->n.sym->attr.proc_pointer
&& expr1->symtree->n.sym->attr.dummy)
lse.expr = build_fold_indirect_ref_loc (input_location,
......@@ -7950,27 +8073,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_block_to_block (&block, &rse.pre);
/* For string assignments to unlimited polymorphic pointers add an
assignment of the string_length to the _len component of the
pointer. */
if ((expr1->ts.type == BT_CLASS || expr1->ts.type == BT_DERIVED)
&& expr1->ts.u.derived->attr.unlimited_polymorphic
&& (expr2->ts.type == BT_CHARACTER ||
((expr2->ts.type == BT_DERIVED || expr2->ts.type == BT_CLASS)
&& expr2->ts.u.derived->attr.unlimited_polymorphic)))
{
gfc_expr *len_comp;
gfc_se se;
len_comp = gfc_get_len_component (expr1);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, len_comp);
/* ptr % _len = len (str) */
gfc_add_modify (&block, se.expr, rse.string_length);
lse.string_length = se.expr;
gfc_free_expr (len_comp);
}
/* Check character lengths if character expression. The test is only
really added if -fbounds-check is enabled. Exclude deferred
character length lefthand sides. */
......@@ -7997,9 +8099,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
build_int_cst (gfc_charlen_type_node, 0));
}
if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS)
rse.expr = gfc_class_data_get (rse.expr);
gfc_add_modify (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), rse.expr));
......@@ -8010,6 +8109,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
{
gfc_ref* remap;
bool rank_remap;
tree expr1_vptr = NULL_TREE;
tree strlen_lhs;
tree strlen_rhs = NULL_TREE;
......@@ -8026,9 +8126,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_init_se (&lse, NULL);
if (remap)
lse.descriptor_only = 1;
if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS
&& expr1->ts.type == BT_CLASS)
expr1_vptr = gfc_copy_expr (expr1);
gfc_conv_expr_descriptor (&lse, expr1);
strlen_lhs = lse.string_length;
desc = lse.expr;
......@@ -8054,16 +8151,15 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
rse.expr = gfc_class_data_get (rse.expr);
else
{
expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
expr2, &rse,
NULL, NULL);
gfc_add_block_to_block (&block, &rse.pre);
tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
gfc_add_modify (&lse.pre, tmp, rse.expr);
gfc_add_vptr_component (expr1_vptr);
gfc_init_se (&rse, NULL);
rse.want_pointer = 1;
gfc_conv_expr (&rse, expr1_vptr);
gfc_add_modify (&lse.pre, rse.expr,
fold_convert (TREE_TYPE (rse.expr),
gfc_add_modify (&lse.pre, expr1_vptr,
fold_convert (TREE_TYPE (expr1_vptr),
gfc_class_vptr_get (tmp)));
rse.expr = gfc_class_data_get (tmp);
}
......@@ -8091,6 +8187,10 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
{
gfc_conv_expr_descriptor (&rse, expr2);
strlen_rhs = rse.string_length;
if (expr1->ts.type == BT_CLASS)
expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
expr2, &rse,
NULL, NULL);
}
}
else if (expr2->expr_type == EXPR_VARIABLE)
......@@ -8109,12 +8209,22 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_init_se (&rse, NULL);
rse.descriptor_only = 1;
gfc_conv_expr (&rse, expr2);
if (expr1->ts.type == BT_CLASS)
trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
NULL, NULL);
tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
if (!INTEGER_CST_P (tmp))
gfc_add_block_to_block (&lse.post, &rse.pre);
gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
}
else if (expr1->ts.type == BT_CLASS)
{
rse.expr = NULL_TREE;
rse.string_length = NULL_TREE;
trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
NULL, NULL);
}
}
else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
{
......@@ -8128,16 +8238,15 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
}
else
{
expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
expr2, &rse, NULL,
NULL);
gfc_add_block_to_block (&block, &rse.pre);
tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
gfc_add_modify (&lse.pre, tmp, rse.expr);
gfc_add_vptr_component (expr1_vptr);
gfc_init_se (&rse, NULL);
rse.want_pointer = 1;
gfc_conv_expr (&rse, expr1_vptr);
gfc_add_modify (&lse.pre, rse.expr,
fold_convert (TREE_TYPE (rse.expr),
gfc_add_modify (&lse.pre, expr1_vptr,
fold_convert (TREE_TYPE (expr1_vptr),
gfc_class_vptr_get (tmp)));
rse.expr = gfc_class_data_get (tmp);
gfc_add_modify (&lse.pre, desc, rse.expr);
......@@ -8156,9 +8265,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_add_modify (&lse.pre, desc, tmp);
}
if (expr1_vptr)
gfc_free_expr (expr1_vptr);
gfc_add_block_to_block (&block, &lse.pre);
if (rank_remap)
gfc_add_block_to_block (&block, &rse.pre);
......@@ -8408,7 +8514,6 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
if (rse->string_length != NULL_TREE)
{
gcc_assert (rse->string_length != NULL_TREE);
gfc_conv_string_parameter (rse);
gfc_add_block_to_block (&block, &rse->pre);
rlen = rse->string_length;
......@@ -9364,14 +9469,101 @@ is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
return false;
}
static tree
trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
gfc_se *lse, gfc_se *rse, bool use_vptr_copy)
{
tree tmp;
tree fcn;
tree stdcopy, to_len, from_len;
vec<tree, va_gc> *args = NULL;
tmp = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
&from_len);
fcn = gfc_vptr_copy_get (tmp);
tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
? gfc_class_data_get (rse->expr) : rse->expr;
if (use_vptr_copy)
{
if (!POINTER_TYPE_P (TREE_TYPE (tmp))
|| INDIRECT_REF_P (tmp)
|| (rhs->ts.type == BT_DERIVED
&& rhs->ts.u.derived->attr.unlimited_polymorphic
&& !rhs->ts.u.derived->attr.pointer
&& !rhs->ts.u.derived->attr.allocatable)
|| (UNLIMITED_POLY (rhs)
&& !CLASS_DATA (rhs)->attr.pointer
&& !CLASS_DATA (rhs)->attr.allocatable))
vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
else
vec_safe_push (args, tmp);
tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
? gfc_class_data_get (lse->expr) : lse->expr;
if (!POINTER_TYPE_P (TREE_TYPE (tmp))
|| INDIRECT_REF_P (tmp)
|| (lhs->ts.type == BT_DERIVED
&& lhs->ts.u.derived->attr.unlimited_polymorphic
&& !lhs->ts.u.derived->attr.pointer
&& !lhs->ts.u.derived->attr.allocatable)
|| (UNLIMITED_POLY (lhs)
&& !CLASS_DATA (lhs)->attr.pointer
&& !CLASS_DATA (lhs)->attr.allocatable))
vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
else
vec_safe_push (args, tmp);
stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
if (to_len != NULL_TREE && !integer_zerop (from_len))
{
tree extcopy;
vec_safe_push (args, from_len);
vec_safe_push (args, to_len);
extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
tmp = fold_build2_loc (input_location, GT_EXPR,
boolean_type_node, from_len,
integer_zero_node);
return fold_build3_loc (input_location, COND_EXPR,
void_type_node, tmp,
extcopy, stdcopy);
}
else
return stdcopy;
}
else
{
tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
? gfc_class_data_get (lse->expr) : lse->expr;
stmtblock_t tblock;
gfc_init_block (&tblock);
if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
rhst = gfc_build_addr_expr (NULL_TREE, rhst);
/* When coming from a ptr_copy lhs and rhs are swapped. */
gfc_add_modify_loc (input_location, &tblock, rhst,
fold_convert (TREE_TYPE (rhst), tmp));
return gfc_finish_block (&tblock);
}
}
/* Subroutine of gfc_trans_assignment that actually scalarizes the
assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
init_flag indicates initialization expressions and dealloc that no
deallocate prior assignment is needed (if in doubt, set true). */
deallocate prior assignment is needed (if in doubt, set true).
When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
routine instead of a pointer assignment. Alias resolution is only done,
when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
where it is known, that newly allocated memory on the lhs can never be
an alias of the rhs. */
static tree
gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
bool dealloc)
bool dealloc, bool use_vptr_copy, bool may_alias)
{
gfc_se lse;
gfc_se rse;
......@@ -9387,7 +9579,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
tree string_length;
int n;
bool maybe_workshare = false;
symbol_attribute lhs_caf_attr, rhs_caf_attr;
symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
/* Assignment of the form lhs = rhs. */
gfc_start_block (&block);
......@@ -9408,8 +9600,13 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
|| gfc_is_alloc_class_scalar_function (expr2)))
expr2->must_finalize = 1;
/* Only analyze the expressions for coarray properties, when in coarray-lib
mode. */
if (flag_coarray == GFC_FCOARRAY_LIB)
{
lhs_caf_attr = gfc_caf_attr (expr1);
rhs_caf_attr = gfc_caf_attr (expr2);
}
if (lss != gfc_ss_terminator)
{
......@@ -9442,6 +9639,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
loop.reverse[n] = GFC_ENABLE_REVERSE;
/* Resolve any data dependencies in the statement. */
if (may_alias)
gfc_conv_resolve_dependencies (&loop, lss, rss);
/* Setup the scalarizing loops. */
gfc_conv_loop_setup (&loop, &expr2->where);
......@@ -9589,7 +9787,24 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
gfc_add_block_to_block (&loop.post, &rse.post);
}
if (flag_coarray == GFC_FCOARRAY_LIB
lhs_attr = gfc_expr_attr (expr1);
if ((use_vptr_copy || lhs_attr.pointer
|| (lhs_attr.allocatable && !lhs_attr.dimension))
&& (expr1->ts.type == BT_CLASS
|| (gfc_is_class_array_ref (expr1, NULL)
|| gfc_is_class_scalar_expr (expr1))
|| (gfc_is_class_array_ref (expr2, NULL)
|| gfc_is_class_scalar_expr (expr2))))
{
tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
use_vptr_copy || (lhs_attr.allocatable
&& !lhs_attr.dimension));
/* Modify the expr1 after the assignment, to allow the realloc below.
Therefore only needed, when realloc_lhs is enabled. */
if (flag_realloc_lhs && !lhs_attr.pointer)
gfc_add_data_component (expr1);
}
else if (flag_coarray == GFC_FCOARRAY_LIB
&& lhs_caf_attr.codimension && rhs_caf_attr.codimension
&& lhs_caf_attr.alloc_comp && rhs_caf_attr.alloc_comp)
{
......@@ -9609,7 +9824,13 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
|| scalar_to_array
|| expr2->expr_type == EXPR_ARRAY,
!(l_is_temp || init_flag) && dealloc);
/* Add the pre blocks to the body. */
gfc_add_block_to_block (&body, &rse.pre);
gfc_add_block_to_block (&body, &lse.pre);
gfc_add_expr_to_block (&body, tmp);
/* Add the post blocks to the body. */
gfc_add_block_to_block (&body, &rse.post);
gfc_add_block_to_block (&body, &lse.post);
if (lss == gfc_ss_terminator)
{
......@@ -9724,7 +9945,7 @@ copyable_array_p (gfc_expr * expr)
tree
gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
bool dealloc)
bool dealloc, bool use_vptr_copy, bool may_alias)
{
tree tmp;
......@@ -9767,7 +9988,8 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
}
/* Fallback to the scalarizer to generate explicit loops. */
return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
use_vptr_copy, may_alias);
}
tree
......
gcc/fortran/trans-stmt.c
......@@ -5439,7 +5439,10 @@ gfc_trans_allocate (gfc_code * code)
if (code->expr3->rank != 0
&& ((!attr.allocatable && !attr.pointer)
|| (code->expr3->expr_type == EXPR_FUNCTION
&& code->expr3->ts.type != BT_CLASS)))
&& (code->expr3->ts.type != BT_CLASS
|| (code->expr3->value.function.isym
&& code->expr3->value.function.isym
->transformational)))))
gfc_conv_expr_descriptor (&se, code->expr3);
else
gfc_conv_expr_reference (&se, code->expr3);
......@@ -5623,6 +5626,38 @@ gfc_trans_allocate (gfc_code * code)
else
expr3_esize = TYPE_SIZE_UNIT (
gfc_typenode_for_spec (&code->expr3->ts));
}
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;
}
else if (code->ext.alloc.ts.type != BT_UNKNOWN)
{
/* Compute the explicit typespec given only once for all objects
to allocate. */
if (code->ext.alloc.ts.type != BT_CHARACTER)
expr3_esize = TYPE_SIZE_UNIT (
gfc_typenode_for_spec (&code->ext.alloc.ts));
else
{
gfc_expr *sz;
gcc_assert (code->ext.alloc.ts.u.cl->length != NULL);
sz = gfc_copy_expr (code->ext.alloc.ts.u.cl->length);
gfc_init_se (&se_sz, NULL);
gfc_conv_expr (&se_sz, sz);
gfc_free_expr (sz);
tmp = gfc_get_char_type (code->ext.alloc.ts.kind);
tmp = TYPE_SIZE_UNIT (tmp);
tmp = fold_convert (TREE_TYPE (se_sz.expr), tmp);
gfc_add_block_to_block (&block, &se_sz.pre);
expr3_esize = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (se_sz.expr),
tmp, se_sz.expr);
expr3_esize = gfc_evaluate_now (expr3_esize, &block);
}
}
/* The routine gfc_trans_assignment () already implements all
techniques needed. Unfortunately we may have a temporary
......@@ -5639,17 +5674,18 @@ gfc_trans_allocate (gfc_code * code)
array sections. In any case, there is no harm in sending
variables to gfc_trans_assignment because there is no
evaluation of variables. */
if (code->expr3)
{
if (code->expr3->expr_type != EXPR_VARIABLE
&& 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
a colliding symbol's as. */
/* Build a temporary symtree and symbol. Do not add it to the current
namespace to prevent accidently modifying a colliding
symbol's as. */
newsym = XCNEW (gfc_symtree);
/* The name of the symtree should be unique, because
gfc_create_var () took care about generating the
identifier. */
/* The name of the symtree should be unique, because gfc_create_var ()
took care about generating the identifier. */
newsym->name = gfc_get_string (IDENTIFIER_POINTER (
DECL_NAME (expr3)));
newsym->n.sym = gfc_new_symbol (newsym->name, NULL);
......@@ -5657,15 +5693,25 @@ gfc_trans_allocate (gfc_code * code)
here. */
newsym->n.sym->backend_decl = expr3;
e3rhs = gfc_get_expr ();
e3rhs->ts = code->expr3->ts;
e3rhs->rank = code->expr3->rank;
e3rhs->symtree = newsym;
/* Mark the symbol referenced or gfc_trans_assignment will
bug. */
/* Mark the symbol referenced or gfc_trans_assignment will bug. */
newsym->n.sym->attr.referenced = 1;
e3rhs->expr_type = EXPR_VARIABLE;
e3rhs->where = code->expr3->where;
/* Set the symbols type, upto it was BT_UNKNOWN. */
if (IS_CLASS_ARRAY (code->expr3)
&& code->expr3->expr_type == EXPR_FUNCTION
&& code->expr3->value.function.isym
&& code->expr3->value.function.isym->transformational)
{
e3rhs->ts = CLASS_DATA (code->expr3)->ts;
}
else if (code->expr3->ts.type == BT_CLASS
&& !GFC_CLASS_TYPE_P (TREE_TYPE (expr3)))
e3rhs->ts = CLASS_DATA (code->expr3)->ts;
else
e3rhs->ts = code->expr3->ts;
newsym->n.sym->ts = e3rhs->ts;
/* Check whether the expr3 is array valued. */
if (e3rhs->rank)
......@@ -5679,11 +5725,21 @@ gfc_trans_allocate (gfc_code * code)
newsym->n.sym->attr.dimension = 1;
newsym->n.sym->attr.pointer = 1;
newsym->n.sym->as = arr;
if (IS_CLASS_ARRAY (code->expr3)
&& code->expr3->expr_type == EXPR_FUNCTION
&& code->expr3->value.function.isym
&& code->expr3->value.function.isym->transformational)
{
gfc_array_spec *tarr;
tarr = gfc_get_array_spec ();
*tarr = *arr;
e3rhs->ts.u.derived->as = tarr;
}
gfc_add_full_array_ref (e3rhs, arr);
}
else if (POINTER_TYPE_P (TREE_TYPE (expr3)))
newsym->n.sym->attr.pointer = 1;
/* The string length is known to. Set it for char arrays. */
/* The string length is known, too. Set it for char arrays. */
if (e3rhs->ts.type == BT_CHARACTER)
newsym->n.sym->ts.u.cl->backend_decl = expr3_len;
gfc_commit_symbol (newsym->n.sym);
......@@ -5691,37 +5747,6 @@ gfc_trans_allocate (gfc_code * code)
else
e3rhs = gfc_copy_expr (code->expr3);
}
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;
}
else if (code->ext.alloc.ts.type != BT_UNKNOWN)
{
/* Compute the explicit typespec given only once for all objects
to allocate. */
if (code->ext.alloc.ts.type != BT_CHARACTER)
expr3_esize = TYPE_SIZE_UNIT (
gfc_typenode_for_spec (&code->ext.alloc.ts));
else
{
gfc_expr *sz;
gcc_assert (code->ext.alloc.ts.u.cl->length != NULL);
sz = gfc_copy_expr (code->ext.alloc.ts.u.cl->length);
gfc_init_se (&se_sz, NULL);
gfc_conv_expr (&se_sz, sz);
gfc_free_expr (sz);
tmp = gfc_get_char_type (code->ext.alloc.ts.kind);
tmp = TYPE_SIZE_UNIT (tmp);
tmp = fold_convert (TREE_TYPE (se_sz.expr), tmp);
gfc_add_block_to_block (&block, &se_sz.pre);
expr3_esize = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (se_sz.expr),
tmp, se_sz.expr);
expr3_esize = gfc_evaluate_now (expr3_esize, &block);
}
}
/* Loop over all objects to allocate. */
for (al = code->ext.alloc.list; al != NULL; al = al->next)
......@@ -5960,8 +5985,9 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_expr_to_block (&block, tmp);
}
/* Set the vptr. */
if (al_vptr != NULL_TREE)
/* Set the vptr only when no source= is set. When source= is set, then
the trans_assignment below will set the vptr. */
if (al_vptr != NULL_TREE && (!code->expr3 || code->expr3->mold))
{
if (expr3_vptr != NULL_TREE)
/* The vtab is already known, so just assign it. */
......@@ -6046,149 +6072,30 @@ gfc_trans_allocate (gfc_code * code)
if (code->expr3 && !code->expr3->mold && e3_is != E3_MOLD)
{
/* Initialization via SOURCE block (or static default initializer).
Classes need some special handling, so catch them first. */
if (expr3 != NULL_TREE
&& TREE_CODE (expr3) != POINTER_PLUS_EXPR
&& 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,
nelems, upoly_expr);
}
else if (al->expr->ts.type == BT_CLASS)
{
gfc_actual_arglist *actual, *last_arg;
gfc_expr *ppc;
gfc_code *ppc_code;
gfc_ref *ref, *dataref;
gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
/* Do a polymorphic deep copy. */
actual = gfc_get_actual_arglist ();
actual->expr = gfc_copy_expr (rhs);
if (rhs->ts.type == BT_CLASS)
gfc_add_data_component (actual->expr);
last_arg = actual->next = gfc_get_actual_arglist ();
last_arg->expr = gfc_copy_expr (al->expr);
last_arg->expr->ts.type = BT_CLASS;
gfc_add_data_component (last_arg->expr);
dataref = NULL;
/* Make sure we go up through the reference chain to
the _data reference, where the arrayspec is found. */
for (ref = last_arg->expr->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT
&& strcmp (ref->u.c.component->name, "_data") == 0)
dataref = ref;
if (dataref && dataref->u.c.component->as)
{
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)
{
if (rhs->ref)
ppc = gfc_find_and_cut_at_last_class_ref (rhs);
else
ppc = gfc_copy_expr (rhs);
gfc_add_vptr_component (ppc);
}
else
ppc = gfc_lval_expr_from_sym (gfc_find_vtab (&rhs->ts));
gfc_add_component_ref (ppc, "_copy");
ppc_code = gfc_get_code (EXEC_CALL);
ppc_code->resolved_sym = ppc->symtree->n.sym;
ppc_code->loc = al->expr->where;
/* Although '_copy' is set to be elemental in class.c, it is
not staying that way. Find out why, sometime.... */
ppc_code->resolved_sym->attr.elemental = 1;
ppc_code->ext.actual = actual;
ppc_code->expr1 = ppc;
/* Since '_copy' is elemental, the scalarizer will take care
of arrays in gfc_trans_call. */
tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false);
/* We need to add the
if (al_len > 0)
al_vptr->copy (expr3_data, al_data, expr3_len, al_len);
else
al_vptr->copy (expr3_data, al_data);
block, because al is unlimited polymorphic or a deferred
length char array, whose copy routine needs the array lengths
as third and fourth arguments. */
if (al_len && UNLIMITED_POLY (code->expr3))
{
tree stdcopy, extcopy;
/* Add al%_len. */
last_arg->next = gfc_get_actual_arglist ();
last_arg = last_arg->next;
last_arg->expr = gfc_find_and_cut_at_last_class_ref (
al->expr);
gfc_add_len_component (last_arg->expr);
/* Add expr3's length. */
last_arg->next = gfc_get_actual_arglist ();
last_arg = last_arg->next;
if (code->expr3->ts.type == BT_CLASS)
{
last_arg->expr =
gfc_find_and_cut_at_last_class_ref (code->expr3);
gfc_add_len_component (last_arg->expr);
}
else if (code->expr3->ts.type == BT_CHARACTER)
last_arg->expr =
gfc_copy_expr (code->expr3->ts.u.cl->length);
else
gcc_unreachable ();
stdcopy = tmp;
extcopy = gfc_trans_call (ppc_code, true, NULL, NULL, false);
tmp = fold_build2_loc (input_location, GT_EXPR,
boolean_type_node, expr3_len,
integer_zero_node);
tmp = fold_build3_loc (input_location, COND_EXPR,
void_type_node, tmp, extcopy, stdcopy);
}
gfc_free_statements (ppc_code);
if (rhs != e3rhs)
gfc_free_expr (rhs);
}
else
{
/* Switch off automatic reallocation since we have just
done the ALLOCATE. */
Switch off automatic reallocation since we have just done the
ALLOCATE. */
int realloc_lhs = flag_realloc_lhs;
gfc_expr *init_expr = gfc_expr_to_initialize (expr);
gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
flag_realloc_lhs = 0;
tmp = gfc_trans_assignment (init_expr, e3rhs, false, false);
tmp = gfc_trans_assignment (init_expr, rhs, false, false, true,
false);
flag_realloc_lhs = realloc_lhs;
/* Free the expression allocated for init_expr. */
gfc_free_expr (init_expr);
}
if (rhs != e3rhs)
gfc_free_expr (rhs);
gfc_add_expr_to_block (&block, tmp);
}
else if (code->expr3 && code->expr3->mold
&& 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
initialization mode. */
tmp = TREE_OPERAND (se.expr, 0);
tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems,
upoly_expr);
/* Use class_init_assign to initialize expr. */
gfc_code *ini;
ini = gfc_get_code (EXEC_INIT_ASSIGN);
ini->expr1 = gfc_find_and_cut_at_last_class_ref (expr);
tmp = gfc_trans_class_init_assign (ini);
gfc_free_statements (ini);
gfc_add_expr_to_block (&block, tmp);
}
......
gcc/fortran/trans-stmt.h
......@@ -32,7 +32,6 @@ tree gfc_trans_assign (gfc_code *);
tree gfc_trans_pointer_assign (gfc_code *);
tree gfc_trans_init_assign (gfc_code *);
tree gfc_trans_class_init_assign (gfc_code *);
tree gfc_trans_class_assign (gfc_expr *, gfc_expr *, gfc_exec_op);
/* trans-stmt.c */
tree gfc_trans_cycle (gfc_code *);
......
gcc/fortran/trans.c
......@@ -1704,9 +1704,6 @@ trans_code (gfc_code * code, tree cond)
break;
case EXEC_ASSIGN:
if (code->expr1->ts.type == BT_CLASS)
res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
else
res = gfc_trans_assign (code);
break;
......@@ -1715,15 +1712,6 @@ trans_code (gfc_code * code, tree cond)
break;
case EXEC_POINTER_ASSIGN:
if (code->expr1->ts.type == BT_CLASS)
res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
else if (UNLIMITED_POLY (code->expr2)
&& code->expr1->ts.type == BT_DERIVED
&& (code->expr1->ts.u.derived->attr.sequence
|| code->expr1->ts.u.derived->attr.is_bind_c))
/* F2003: C717 */
res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
else
res = gfc_trans_pointer_assign (code);
break;
......
gcc/fortran/trans.h
......@@ -699,7 +699,8 @@ tree gfc_call_realloc (stmtblock_t *, tree, tree);
tree gfc_trans_structure_assign (tree, gfc_expr *, bool);
/* Generate code for an assignment, includes scalarization. */
tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool);
tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool, bool, bool p = false,
bool a = true);
/* Generate code for a pointer assignment. */
tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *);
......
gcc/testsuite/ChangeLog
2016-10-22 Andre Vehreschild <vehre@gcc.gnu.org>
Forgot to add on original commit.
* gfortran.dg/coarray_alloc_comp_2.f08: New test.
2016-10-22 Andre Vehreschild <vehre@gcc.gnu.org>
PR fortran/43366
PR fortran/57117
PR fortran/61337
* gfortran.dg/alloc_comp_class_5.f03: New test.
* gfortran.dg/class_allocate_21.f90: New test.
* gfortran.dg/class_allocate_22.f90: New test.
* gfortran.dg/realloc_on_assign_27.f08: New test.
2016-10-21 Jeff Law <law@redhat.com>
* PR tree-optimization/71947
......
gcc/testsuite/gfortran.dg/alloc_comp_class_5.f03 0 → 100644
! { dg-do run }
!
! Contributed by Vladimir Fuka
! Check that pr61337 is fixed.
module array_list
type container
class(*), allocatable :: items(:)
end type
contains
subroutine add_item(a, e)
type(container),allocatable,intent(inout) :: a(:)
class(*),intent(in) :: e(:)
type(container),allocatable :: tmp(:)
if (.not.allocated(a)) then
allocate(a(1))
allocate(a(1)%items(size(e)), source = e)
else
call move_alloc(a,tmp)
allocate(a(size(tmp)+1))
a(1:size(tmp)) = tmp
allocate(a(size(tmp)+1)%items(size(e)), source=e)
end if
end subroutine
end module
program test_pr61337
use array_list
type(container), allocatable :: a_list(:)
integer(kind = 8) :: i
call add_item(a_list, [1, 2])
call add_item(a_list, [3.0_8, 4.0_8])
call add_item(a_list, [.true., .false.])
if (size(a_list) /= 3) call abort()
do i = 1, size(a_list)
call checkarr(a_list(i))
end do
deallocate(a_list)
contains
subroutine checkarr(c)
type(container) :: c
if (allocated(c%items)) then
select type (x=>c%items)
type is (integer)
if (any(x /= [1, 2])) call abort()
type is (real(kind=8))
if (any(x /= [3.0_8, 4.0_8])) call abort()
type is (logical)
if (any(x .neqv. [.true., .false.])) call abort()
class default
call abort()
end select
else
call abort()
end if
end subroutine
end
gcc/testsuite/gfortran.dg/class_allocate_21.f90 0 → 100644
! { dg-do run }
!
! Testcase for pr57117
implicit none
type :: ti
integer :: i
end type
class(ti), allocatable :: x(:,:), z(:)
integer :: i
allocate(x(3,3))
x%i = reshape([( i, i = 1, 9 )], [3, 3])
allocate(z(9), source=reshape(x, (/ 9 /)))
if (any( z%i /= [( i, i = 1, 9 )])) call abort()
deallocate (x, z)
end
gcc/testsuite/gfortran.dg/class_allocate_22.f90 0 → 100644
! { dg-do run }
!
! Check pr57117 is fixed.
program pr57117
implicit none
type :: ti
integer :: i
end type
class(ti), allocatable :: x(:,:), y(:,:)
integer :: i
allocate(x(2,6))
select type (x)
class is (ti)
x%i = reshape([(i,i=1, 12)],[2,6])
end select
allocate(y, source=transpose(x))
if (any( ubound(y) /= [6,2])) call abort()
if (any(reshape(y(:,:)%i, [12]) /= [ 1,3,5,7,9,11, 2,4,6,8,10,12])) call abort()
deallocate (x,y)
end
gcc/testsuite/gfortran.dg/coarray_alloc_comp_2.f08 0 → 100644
! { dg-do run }
! { dg-options "-fcoarray=lib -lcaf_single" }
! Contributed by Damian Rouson
! Check the new _caf_send_by_ref()-routine.
program main
implicit none
type :: mytype
integer :: i
integer, allocatable :: indices(:)
real, dimension(2,5,3) :: volume
integer, allocatable :: scalar
integer :: j
integer, allocatable :: matrix(:,:)
real, allocatable :: dynvol(:,:,:)
end type
type arrtype
type(mytype), allocatable :: vec(:)
type(mytype), allocatable :: mat(:,:)
end type arrtype
type(mytype), save :: object[*]
type(arrtype), save :: bar[*]
integer :: i,j,me,neighbor
integer :: idx(5)
real, allocatable :: volume(:,:,:), vol2(:,:,:)
real :: vol_static(2,5,3)
idx = (/ 1,2,1,7,5 /)
me=this_image()
neighbor = merge(1,me+1,me==num_images())
object[neighbor]%indices=[(i,i=1,5)]
object[neighbor]%i = 37
object[neighbor]%scalar = 42
vol_static = reshape([(i, i=1, 2*5*3)], [2, 5, 3])
object[neighbor]%volume = vol_static
object[neighbor]%matrix = reshape([(i, i=1, 70)], [10, 7])
object[neighbor]%dynvol = vol_static
sync all
if (object%scalar /= 42) call abort()
if (any( object%indices /= [1,2,3,4,5] )) call abort()
if (any( object%matrix /= reshape([(i, i=1, 70)], [10, 7]))) call abort()
if (any( object%volume /= vol_static)) call abort()
if (any( object%dynvol /= vol_static)) call abort()
vol2 = vol_static
vol2(:, ::2, :) = 42
object[neighbor]%volume(:, ::2, :) = 42
object[neighbor]%dynvol(:, ::2, :) = 42
if (any( object%volume /= vol2)) call abort()
if (any( object%dynvol /= vol2)) call abort()
allocate(bar%vec(-2:2))
bar[neighbor]%vec(1)%volume = vol_static
if (any(bar%vec(1)%volume /= vol_static)) call abort()
i = 15
bar[neighbor]%vec(1)%scalar = i
if (.not. allocated(bar%vec(1)%scalar)) call abort()
if (bar%vec(1)%scalar /= 15) call abort()
bar[neighbor]%vec(0)%scalar = 27
if (.not. allocated(bar%vec(0)%scalar)) call abort()
if (bar%vec(0)%scalar /= 27) call abort()
bar[neighbor]%vec(1)%indices = [ 3, 4, 15 ]
allocate(bar%vec(2)%indices(5))
bar[neighbor]%vec(2)%indices = 89
if (.not. allocated(bar%vec(1)%indices)) call abort()
if (allocated(bar%vec(-2)%indices)) call abort()
if (allocated(bar%vec(-1)%indices)) call abort()
if (allocated(bar%vec( 0)%indices)) call abort()
if (.not. allocated(bar%vec( 2)%indices)) call abort()
if (any(bar%vec(2)%indices /= 89)) call abort()
if (any (bar%vec(1)%indices /= [ 3,4,15])) call abort()
end program
gcc/testsuite/gfortran.dg/realloc_on_assign_27.f08 0 → 100644
! { dg-do run }
type :: t
integer :: i
end type
type, extends(t) :: r
real :: r
end type
class(t), allocatable :: x
type(r) :: y = r (3, 42)
x = y
if (x%i /= 3) call abort()
select type(x)
class is (r)
if (x%r /= 42.0) call abort()
class default
call abort()
end select
end
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment