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 904 additions and 435 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> 2016-10-21 Paul Thomas <pault@gcc.gnu.org>
PR fortran/69566 PR fortran/69566
......
gcc/fortran/primary.c
...@@ -2359,6 +2359,10 @@ gfc_expr_attr (gfc_expr *e) ...@@ -2359,6 +2359,10 @@ gfc_expr_attr (gfc_expr *e)
attr.allocatable = CLASS_DATA (sym)->attr.allocatable; 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 else
attr = gfc_variable_attr (e, NULL); attr = gfc_variable_attr (e, NULL);
......
gcc/fortran/resolve.c
...@@ -9911,10 +9911,6 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) ...@@ -9911,10 +9911,6 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
"requires %<-frealloc-lhs%>", &lhs->where); "requires %<-frealloc-lhs%>", &lhs->where);
return false; 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) else if (lhs->ts.type == BT_CLASS)
{ {
...@@ -10817,6 +10813,19 @@ start: ...@@ -10817,6 +10813,19 @@ start:
break; break;
gfc_check_pointer_assign (code->expr1, code->expr2); 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; break;
} }
......
gcc/fortran/trans-array.c
...@@ -2292,7 +2292,8 @@ trans_array_constructor (gfc_ss * ss, locus * where) ...@@ -2292,7 +2292,8 @@ trans_array_constructor (gfc_ss * ss, locus * where)
type = build_pointer_type (type); type = build_pointer_type (type);
} }
else 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. */ /* See if the constructor determines the loop bounds. */
dynamic = false; dynamic = false;
...@@ -3036,50 +3037,57 @@ build_class_array_ref (gfc_se *se, tree base, tree index) ...@@ -3036,50 +3037,57 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
tree type; tree type;
tree size; tree size;
tree offset; tree offset;
tree decl; tree decl = NULL_TREE;
tree tmp; tree tmp;
gfc_expr *expr = se->ss->info->expr; gfc_expr *expr = se->ss->info->expr;
gfc_ref *ref; gfc_ref *ref;
gfc_ref *class_ref; gfc_ref *class_ref = NULL;
gfc_typespec *ts; gfc_typespec *ts;
if (expr == NULL if (se->expr && DECL_P (se->expr) && DECL_LANG_SPECIFIC (se->expr)
|| (expr->ts.type != BT_CLASS && GFC_DECL_SAVED_DESCRIPTOR (se->expr)
&& !gfc_is_alloc_class_array_function (expr))) && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se->expr))))
return false; decl = se->expr;
if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
ts = &expr->symtree->n.sym->ts;
else else
ts = NULL;
class_ref = NULL;
for (ref = expr->ref; ref; ref = ref->next)
{ {
if (ref->type == REF_COMPONENT if (expr == NULL
&& ref->u.c.component->ts.type == BT_CLASS || (expr->ts.type != BT_CLASS
&& ref->next && ref->next->type == REF_COMPONENT && !gfc_is_alloc_class_array_function (expr)
&& strcmp (ref->next->u.c.component->name, "_data") == 0 && !gfc_is_class_array_ref (expr, NULL)))
&& ref->next->next return false;
&& ref->next->next->type == REF_ARRAY
&& ref->next->next->u.ar.type != AR_ELEMENT) if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
ts = &expr->symtree->n.sym->ts;
else
ts = NULL;
for (ref = expr->ref; ref; ref = ref->next)
{ {
ts = &ref->u.c.component->ts; if (ref->type == REF_COMPONENT
class_ref = ref; && ref->u.c.component->ts.type == BT_CLASS
break; && ref->next && ref->next->type == REF_COMPONENT
&& strcmp (ref->next->u.c.component->name, "_data") == 0
&& ref->next->next
&& ref->next->next->type == REF_ARRAY
&& ref->next->next->u.ar.type != AR_ELEMENT)
{
ts = &ref->u.c.component->ts;
class_ref = ref;
break;
}
} }
}
if (ts == NULL) if (ts == NULL)
return false; 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) && expr->symtree->n.sym == expr->symtree->n.sym->result)
{ {
gcc_assert (expr->symtree->n.sym->backend_decl == current_function_decl); gcc_assert (expr->symtree->n.sym->backend_decl == current_function_decl);
decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0); 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; size = NULL_TREE;
decl = NULL_TREE; decl = NULL_TREE;
...@@ -3105,7 +3113,8 @@ build_class_array_ref (gfc_se *se, tree base, tree index) ...@@ -3105,7 +3113,8 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
} }
else if (class_ref == NULL) else if (class_ref == NULL)
{ {
decl = expr->symtree->n.sym->backend_decl; if (decl == NULL_TREE)
decl = expr->symtree->n.sym->backend_decl;
/* For class arrays the tree containing the class is stored in /* For class arrays the tree containing the class is stored in
GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl. GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
For all others it's sym's backend_decl directly. */ For all others it's sym's backend_decl directly. */
...@@ -3121,6 +3130,7 @@ build_class_array_ref (gfc_se *se, tree base, tree index) ...@@ -3121,6 +3130,7 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
class_ref->next = NULL; class_ref->next = NULL;
gfc_init_se (&tmpse, NULL); gfc_init_se (&tmpse, NULL);
gfc_conv_expr (&tmpse, expr); gfc_conv_expr (&tmpse, expr);
gfc_add_block_to_block (&se->pre, &tmpse.pre);
decl = tmpse.expr; decl = tmpse.expr;
class_ref->next = ref; class_ref->next = ref;
} }
...@@ -7094,6 +7104,28 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) ...@@ -7094,6 +7104,28 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
loop.from, loop.to, 0, loop.from, loop.to, 0,
GFC_ARRAY_UNKNOWN, false); GFC_ARRAY_UNKNOWN, false);
parm = gfc_create_var (parmtype, "parm"); 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; offset = gfc_index_zero_node;
...@@ -7255,6 +7287,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) ...@@ -7255,6 +7287,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
: base; : base;
gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp); 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) else if (onebased && (!rank_remap || se->use_offset)
&& expr->symtree && expr->symtree
&& !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS && !(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) ...@@ -7290,6 +7329,18 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl) GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
: 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) if (!se->direct_byref || se->byref_noassign)
{ {
/* Get a pointer to the new descriptor. */ /* Get a pointer to the new descriptor. */
...@@ -8200,10 +8251,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, ...@@ -8200,10 +8251,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
/* Allocatable CLASS components. */ /* Allocatable CLASS components. */
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE); decl, cdecl, NULL_TREE);
/* Add reference to '_data' component. */
tmp = CLASS_DATA (c)->backend_decl; comp = gfc_class_data_get (comp);
comp = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (tmp), comp, tmp, NULL_TREE);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))) if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node); gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
else else
...@@ -8541,6 +8590,14 @@ gfc_is_reallocatable_lhs (gfc_expr *expr) ...@@ -8541,6 +8590,14 @@ gfc_is_reallocatable_lhs (gfc_expr *expr)
if (!expr->ref) if (!expr->ref)
return false; 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. */ /* An allocatable variable. */
if (expr->symtree->n.sym->attr.allocatable if (expr->symtree->n.sym->attr.allocatable
&& expr->ref && expr->ref
......
gcc/fortran/trans-expr.c
...@@ -350,7 +350,7 @@ gfc_expr * ...@@ -350,7 +350,7 @@ gfc_expr *
gfc_find_and_cut_at_last_class_ref (gfc_expr *e) gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
{ {
gfc_expr *base_expr; 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. */ /* Find the last class reference. */
class_ref = NULL; class_ref = NULL;
...@@ -383,7 +383,7 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e) ...@@ -383,7 +383,7 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
tail = class_ref->next; tail = class_ref->next;
class_ref->next = NULL; class_ref->next = NULL;
} }
else else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
{ {
tail = e->ref; tail = e->ref;
e->ref = NULL; e->ref = NULL;
...@@ -397,7 +397,7 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e) ...@@ -397,7 +397,7 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
gfc_free_ref_list (class_ref->next); gfc_free_ref_list (class_ref->next);
class_ref->next = tail; class_ref->next = tail;
} }
else else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
{ {
gfc_free_ref_list (e->ref); gfc_free_ref_list (e->ref);
e->ref = tail; e->ref = tail;
...@@ -1458,7 +1458,12 @@ gfc_trans_class_init_assign (gfc_code *code) ...@@ -1458,7 +1458,12 @@ gfc_trans_class_init_assign (gfc_code *code)
if (code->expr1->ts.type == BT_CLASS if (code->expr1->ts.type == BT_CLASS
&& CLASS_DATA (code->expr1)->attr.dimension) && CLASS_DATA (code->expr1)->attr.dimension)
tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1); {
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 else
{ {
sz = gfc_copy_expr (code->expr1); sz = gfc_copy_expr (code->expr1);
...@@ -1503,114 +1508,6 @@ gfc_trans_class_init_assign (gfc_code *code) ...@@ -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 */ /* End of prototype trans-class.c */
...@@ -5908,6 +5805,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ...@@ -5908,6 +5805,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (comp) if (comp)
ts = comp->ts; ts = comp->ts;
else if (sym->ts.type == BT_CLASS)
ts = CLASS_DATA (sym)->ts;
else else
ts = sym->ts; ts = sym->ts;
...@@ -5978,7 +5877,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ...@@ -5978,7 +5877,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& GFC_DESCRIPTOR_TYPE_P && GFC_DESCRIPTOR_TYPE_P
(TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))))) (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
se->expr = build_fold_indirect_ref_loc (input_location, se->expr = build_fold_indirect_ref_loc (input_location,
se->expr); se->expr);
/* If the lhs of an assignment x = f(..) is allocatable and /* If the lhs of an assignment x = f(..) is allocatable and
f2003 is allowed, we must do the automatic reallocation. f2003 is allowed, we must do the automatic reallocation.
...@@ -6264,6 +6163,26 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ...@@ -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. */ /* Follow the function call with the argument post block. */
if (byref) if (byref)
{ {
...@@ -7886,6 +7805,201 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) ...@@ -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 tree
gfc_trans_pointer_assign (gfc_code * code) gfc_trans_pointer_assign (gfc_code * code)
{ {
...@@ -7898,20 +8012,22 @@ gfc_trans_pointer_assign (gfc_code * code) ...@@ -7898,20 +8012,22 @@ gfc_trans_pointer_assign (gfc_code * code)
tree tree
gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
{ {
gfc_expr *expr1_vptr = NULL;
gfc_se lse; gfc_se lse;
gfc_se rse; gfc_se rse;
stmtblock_t block; stmtblock_t block;
tree desc; tree desc;
tree tmp; tree tmp;
tree decl; tree decl;
bool scalar; bool scalar, non_proc_pointer_assign;
gfc_ss *ss; gfc_ss *ss;
gfc_start_block (&block); gfc_start_block (&block);
gfc_init_se (&lse, NULL); 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 /* Check whether the expression is a scalar or not; we cannot use
expr1->rank as it can be nonzero for proc pointers. */ expr1->rank as it can be nonzero for proc pointers. */
ss = gfc_walk_expr (expr1); ss = gfc_walk_expr (expr1);
...@@ -7920,7 +8036,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) ...@@ -7920,7 +8036,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_free_ss_chain (ss); gfc_free_ss_chain (ss);
if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS 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); gfc_add_data_component (expr2);
/* The following is required as gfc_add_data_component doesn't /* 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) ...@@ -7937,6 +8053,13 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
rse.want_pointer = 1; rse.want_pointer = 1;
gfc_conv_expr (&rse, expr2); 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 if (expr1->symtree->n.sym->attr.proc_pointer
&& expr1->symtree->n.sym->attr.dummy) && expr1->symtree->n.sym->attr.dummy)
lse.expr = build_fold_indirect_ref_loc (input_location, lse.expr = build_fold_indirect_ref_loc (input_location,
...@@ -7950,27 +8073,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) ...@@ -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, &lse.pre);
gfc_add_block_to_block (&block, &rse.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 /* Check character lengths if character expression. The test is only
really added if -fbounds-check is enabled. Exclude deferred really added if -fbounds-check is enabled. Exclude deferred
character length lefthand sides. */ character length lefthand sides. */
...@@ -7997,9 +8099,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) ...@@ -7997,9 +8099,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
build_int_cst (gfc_charlen_type_node, 0)); 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, gfc_add_modify (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), rse.expr)); fold_convert (TREE_TYPE (lse.expr), rse.expr));
...@@ -8010,6 +8109,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) ...@@ -8010,6 +8109,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
{ {
gfc_ref* remap; gfc_ref* remap;
bool rank_remap; bool rank_remap;
tree expr1_vptr = NULL_TREE;
tree strlen_lhs; tree strlen_lhs;
tree strlen_rhs = NULL_TREE; tree strlen_rhs = NULL_TREE;
...@@ -8026,9 +8126,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) ...@@ -8026,9 +8126,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_init_se (&lse, NULL); gfc_init_se (&lse, NULL);
if (remap) if (remap)
lse.descriptor_only = 1; 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); gfc_conv_expr_descriptor (&lse, expr1);
strlen_lhs = lse.string_length; strlen_lhs = lse.string_length;
desc = lse.expr; desc = lse.expr;
...@@ -8054,16 +8151,15 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) ...@@ -8054,16 +8151,15 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
rse.expr = gfc_class_data_get (rse.expr); rse.expr = gfc_class_data_get (rse.expr);
else else
{ {
expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
expr2, &rse,
NULL, NULL);
gfc_add_block_to_block (&block, &rse.pre); gfc_add_block_to_block (&block, &rse.pre);
tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp"); tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
gfc_add_modify (&lse.pre, tmp, rse.expr); gfc_add_modify (&lse.pre, tmp, rse.expr);
gfc_add_vptr_component (expr1_vptr); gfc_add_modify (&lse.pre, expr1_vptr,
gfc_init_se (&rse, NULL); fold_convert (TREE_TYPE (expr1_vptr),
rse.want_pointer = 1;
gfc_conv_expr (&rse, expr1_vptr);
gfc_add_modify (&lse.pre, rse.expr,
fold_convert (TREE_TYPE (rse.expr),
gfc_class_vptr_get (tmp))); gfc_class_vptr_get (tmp)));
rse.expr = gfc_class_data_get (tmp); rse.expr = gfc_class_data_get (tmp);
} }
...@@ -8091,6 +8187,10 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) ...@@ -8091,6 +8187,10 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
{ {
gfc_conv_expr_descriptor (&rse, expr2); gfc_conv_expr_descriptor (&rse, expr2);
strlen_rhs = rse.string_length; 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) else if (expr2->expr_type == EXPR_VARIABLE)
...@@ -8109,12 +8209,22 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) ...@@ -8109,12 +8209,22 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_init_se (&rse, NULL); gfc_init_se (&rse, NULL);
rse.descriptor_only = 1; rse.descriptor_only = 1;
gfc_conv_expr (&rse, expr2); 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 = gfc_get_element_type (TREE_TYPE (rse.expr));
tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp)); tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
if (!INTEGER_CST_P (tmp)) if (!INTEGER_CST_P (tmp))
gfc_add_block_to_block (&lse.post, &rse.pre); gfc_add_block_to_block (&lse.post, &rse.pre);
gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp); 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) 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) ...@@ -8128,16 +8238,15 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
} }
else else
{ {
expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
expr2, &rse, NULL,
NULL);
gfc_add_block_to_block (&block, &rse.pre); gfc_add_block_to_block (&block, &rse.pre);
tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp"); tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
gfc_add_modify (&lse.pre, tmp, rse.expr); gfc_add_modify (&lse.pre, tmp, rse.expr);
gfc_add_vptr_component (expr1_vptr); gfc_add_modify (&lse.pre, expr1_vptr,
gfc_init_se (&rse, NULL); fold_convert (TREE_TYPE (expr1_vptr),
rse.want_pointer = 1;
gfc_conv_expr (&rse, expr1_vptr);
gfc_add_modify (&lse.pre, rse.expr,
fold_convert (TREE_TYPE (rse.expr),
gfc_class_vptr_get (tmp))); gfc_class_vptr_get (tmp)));
rse.expr = gfc_class_data_get (tmp); rse.expr = gfc_class_data_get (tmp);
gfc_add_modify (&lse.pre, desc, rse.expr); gfc_add_modify (&lse.pre, desc, rse.expr);
...@@ -8156,9 +8265,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) ...@@ -8156,9 +8265,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_add_modify (&lse.pre, desc, tmp); gfc_add_modify (&lse.pre, desc, tmp);
} }
if (expr1_vptr)
gfc_free_expr (expr1_vptr);
gfc_add_block_to_block (&block, &lse.pre); gfc_add_block_to_block (&block, &lse.pre);
if (rank_remap) if (rank_remap)
gfc_add_block_to_block (&block, &rse.pre); 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, ...@@ -8408,7 +8514,6 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
if (rse->string_length != NULL_TREE) if (rse->string_length != NULL_TREE)
{ {
gcc_assert (rse->string_length != NULL_TREE);
gfc_conv_string_parameter (rse); gfc_conv_string_parameter (rse);
gfc_add_block_to_block (&block, &rse->pre); gfc_add_block_to_block (&block, &rse->pre);
rlen = rse->string_length; rlen = rse->string_length;
...@@ -9364,14 +9469,101 @@ is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2) ...@@ -9364,14 +9469,101 @@ is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
return false; 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 /* Subroutine of gfc_trans_assignment that actually scalarizes the
assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
init_flag indicates initialization expressions and dealloc that no 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 static tree
gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, 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 lse;
gfc_se rse; gfc_se rse;
...@@ -9387,7 +9579,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, ...@@ -9387,7 +9579,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
tree string_length; tree string_length;
int n; int n;
bool maybe_workshare = false; 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. */ /* Assignment of the form lhs = rhs. */
gfc_start_block (&block); gfc_start_block (&block);
...@@ -9408,8 +9600,13 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, ...@@ -9408,8 +9600,13 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
|| gfc_is_alloc_class_scalar_function (expr2))) || gfc_is_alloc_class_scalar_function (expr2)))
expr2->must_finalize = 1; expr2->must_finalize = 1;
lhs_caf_attr = gfc_caf_attr (expr1); /* Only analyze the expressions for coarray properties, when in coarray-lib
rhs_caf_attr = gfc_caf_attr (expr2); 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) if (lss != gfc_ss_terminator)
{ {
...@@ -9442,7 +9639,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, ...@@ -9442,7 +9639,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
for (n = 0; n < GFC_MAX_DIMENSIONS; n++) for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
loop.reverse[n] = GFC_ENABLE_REVERSE; loop.reverse[n] = GFC_ENABLE_REVERSE;
/* Resolve any data dependencies in the statement. */ /* Resolve any data dependencies in the statement. */
gfc_conv_resolve_dependencies (&loop, lss, rss); if (may_alias)
gfc_conv_resolve_dependencies (&loop, lss, rss);
/* Setup the scalarizing loops. */ /* Setup the scalarizing loops. */
gfc_conv_loop_setup (&loop, &expr2->where); gfc_conv_loop_setup (&loop, &expr2->where);
...@@ -9589,9 +9787,26 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, ...@@ -9589,9 +9787,26 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
gfc_add_block_to_block (&loop.post, &rse.post); gfc_add_block_to_block (&loop.post, &rse.post);
} }
if (flag_coarray == GFC_FCOARRAY_LIB lhs_attr = gfc_expr_attr (expr1);
&& lhs_caf_attr.codimension && rhs_caf_attr.codimension if ((use_vptr_copy || lhs_attr.pointer
&& lhs_caf_attr.alloc_comp && rhs_caf_attr.alloc_comp) || (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)
{ {
gfc_code code; gfc_code code;
gfc_actual_arglist a1, a2; gfc_actual_arglist a1, a2;
...@@ -9609,7 +9824,13 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, ...@@ -9609,7 +9824,13 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
|| scalar_to_array || scalar_to_array
|| expr2->expr_type == EXPR_ARRAY, || expr2->expr_type == EXPR_ARRAY,
!(l_is_temp || init_flag) && dealloc); !(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); 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) if (lss == gfc_ss_terminator)
{ {
...@@ -9724,7 +9945,7 @@ copyable_array_p (gfc_expr * expr) ...@@ -9724,7 +9945,7 @@ copyable_array_p (gfc_expr * expr)
tree tree
gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, 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; tree tmp;
...@@ -9767,7 +9988,8 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, ...@@ -9767,7 +9988,8 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
} }
/* Fallback to the scalarizer to generate explicit loops. */ /* 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 tree
......
gcc/fortran/trans-stmt.c
...@@ -5439,7 +5439,10 @@ gfc_trans_allocate (gfc_code * code) ...@@ -5439,7 +5439,10 @@ gfc_trans_allocate (gfc_code * code)
if (code->expr3->rank != 0 if (code->expr3->rank != 0
&& ((!attr.allocatable && !attr.pointer) && ((!attr.allocatable && !attr.pointer)
|| (code->expr3->expr_type == EXPR_FUNCTION || (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); gfc_conv_expr_descriptor (&se, code->expr3);
else else
gfc_conv_expr_reference (&se, code->expr3); gfc_conv_expr_reference (&se, code->expr3);
...@@ -5623,73 +5626,6 @@ gfc_trans_allocate (gfc_code * code) ...@@ -5623,73 +5626,6 @@ gfc_trans_allocate (gfc_code * code)
else else
expr3_esize = TYPE_SIZE_UNIT ( expr3_esize = TYPE_SIZE_UNIT (
gfc_typenode_for_spec (&code->expr3->ts)); gfc_typenode_for_spec (&code->expr3->ts));
/* The routine gfc_trans_assignment () already implements all
techniques needed. Unfortunately we may have a temporary
variable for the source= expression here. When that is the
case convert this variable into a temporary gfc_expr of type
EXPR_VARIABLE and used it as rhs for the assignment. The
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.
No need to check whether e3_is is E3_UNSET, because that is
done by expr3 != NULL_TREE.
Exclude variables since the following block does not handle
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->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. */
newsym = XCNEW (gfc_symtree);
/* 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);
/* The backend_decl is known. It is expr3, which is inserted
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. */
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. */
newsym->n.sym->ts = e3rhs->ts;
/* Check whether the expr3 is array valued. */
if (e3rhs->rank)
{
gfc_array_spec *arr;
arr = gfc_get_array_spec ();
arr->rank = e3rhs->rank;
arr->type = AS_DEFERRED;
/* Set the dimension and pointer attribute for arrays
to be on the safe side. */
newsym->n.sym->attr.dimension = 1;
newsym->n.sym->attr.pointer = 1;
newsym->n.sym->as = arr;
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. */
if (e3rhs->ts.type == BT_CHARACTER)
newsym->n.sym->ts.u.cl->backend_decl = expr3_len;
gfc_commit_symbol (newsym->n.sym);
}
else
e3rhs = gfc_copy_expr (code->expr3);
} }
gcc_assert (expr3_esize); gcc_assert (expr3_esize);
expr3_esize = fold_convert (sizetype, expr3_esize); expr3_esize = fold_convert (sizetype, expr3_esize);
...@@ -5723,6 +5659,95 @@ gfc_trans_allocate (gfc_code * code) ...@@ -5723,6 +5659,95 @@ gfc_trans_allocate (gfc_code * code)
} }
} }
/* The routine gfc_trans_assignment () already implements all
techniques needed. Unfortunately we may have a temporary
variable for the source= expression here. When that is the
case convert this variable into a temporary gfc_expr of type
EXPR_VARIABLE and used it as rhs for the assignment. The
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.
No need to check whether e3_is is E3_UNSET, because that is
done by expr3 != NULL_TREE.
Exclude variables since the following block does not handle
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. */
newsym = XCNEW (gfc_symtree);
/* 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);
/* The backend_decl is known. It is expr3, which is inserted
here. */
newsym->n.sym->backend_decl = expr3;
e3rhs = gfc_get_expr ();
e3rhs->rank = code->expr3->rank;
e3rhs->symtree = newsym;
/* 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)
{
gfc_array_spec *arr;
arr = gfc_get_array_spec ();
arr->rank = e3rhs->rank;
arr->type = AS_DEFERRED;
/* Set the dimension and pointer attribute for arrays
to be on the safe side. */
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, 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);
}
else
e3rhs = gfc_copy_expr (code->expr3);
}
/* Loop over all objects to allocate. */ /* Loop over all objects to allocate. */
for (al = code->ext.alloc.list; al != NULL; al = al->next) for (al = code->ext.alloc.list; al != NULL; al = al->next)
{ {
...@@ -5960,8 +5985,9 @@ gfc_trans_allocate (gfc_code * code) ...@@ -5960,8 +5985,9 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_expr_to_block (&block, tmp); gfc_add_expr_to_block (&block, tmp);
} }
/* Set the vptr. */ /* Set the vptr only when no source= is set. When source= is set, then
if (al_vptr != NULL_TREE) the trans_assignment below will set the vptr. */
if (al_vptr != NULL_TREE && (!code->expr3 || code->expr3->mold))
{ {
if (expr3_vptr != NULL_TREE) if (expr3_vptr != NULL_TREE)
/* The vtab is already known, so just assign it. */ /* The vtab is already known, so just assign it. */
...@@ -6046,153 +6072,34 @@ gfc_trans_allocate (gfc_code * code) ...@@ -6046,153 +6072,34 @@ gfc_trans_allocate (gfc_code * code)
if (code->expr3 && !code->expr3->mold && e3_is != E3_MOLD) if (code->expr3 && !code->expr3->mold && e3_is != E3_MOLD)
{ {
/* Initialization via SOURCE block (or static default initializer). /* Initialization via SOURCE block (or static default initializer).
Classes need some special handling, so catch them first. */ Switch off automatic reallocation since we have just done the
if (expr3 != NULL_TREE ALLOCATE. */
&& TREE_CODE (expr3) != POINTER_PLUS_EXPR int realloc_lhs = flag_realloc_lhs;
&& code->expr3->ts.type == BT_CLASS gfc_expr *init_expr = gfc_expr_to_initialize (expr);
&& (expr->ts.type == BT_CLASS gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
|| expr->ts.type == BT_DERIVED)) flag_realloc_lhs = 0;
{ tmp = gfc_trans_assignment (init_expr, rhs, false, false, true,
/* copy_class_to_class can be used for class arrays, too. false);
It just needs to be ensured, that the decl_saved_descriptor flag_realloc_lhs = realloc_lhs;
has a way to get to the vptr. */ /* Free the expression allocated for init_expr. */
tree to; gfc_free_expr (init_expr);
to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0); if (rhs != e3rhs)
tmp = gfc_copy_class_to_class (expr3, to, gfc_free_expr (rhs);
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. */
int realloc_lhs = flag_realloc_lhs;
gfc_expr *init_expr = gfc_expr_to_initialize (expr);
flag_realloc_lhs = 0;
tmp = gfc_trans_assignment (init_expr, e3rhs, false, false);
flag_realloc_lhs = realloc_lhs;
/* Free the expression allocated for init_expr. */
gfc_free_expr (init_expr);
}
gfc_add_expr_to_block (&block, tmp); gfc_add_expr_to_block (&block, tmp);
} }
else if (code->expr3 && code->expr3->mold 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 /* Use class_init_assign to initialize expr. */
object, we can use gfc_copy_class_to_class in its gfc_code *ini;
initialization mode. */ ini = gfc_get_code (EXEC_INIT_ASSIGN);
tmp = TREE_OPERAND (se.expr, 0); ini->expr1 = gfc_find_and_cut_at_last_class_ref (expr);
tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems, tmp = gfc_trans_class_init_assign (ini);
upoly_expr); gfc_free_statements (ini);
gfc_add_expr_to_block (&block, tmp); gfc_add_expr_to_block (&block, tmp);
} }
gfc_free_expr (expr); gfc_free_expr (expr);
} // for-loop } // for-loop
if (e3rhs) if (e3rhs)
......
gcc/fortran/trans-stmt.h
...@@ -32,7 +32,6 @@ tree gfc_trans_assign (gfc_code *); ...@@ -32,7 +32,6 @@ tree gfc_trans_assign (gfc_code *);
tree gfc_trans_pointer_assign (gfc_code *); tree gfc_trans_pointer_assign (gfc_code *);
tree gfc_trans_init_assign (gfc_code *); tree gfc_trans_init_assign (gfc_code *);
tree gfc_trans_class_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 */ /* trans-stmt.c */
tree gfc_trans_cycle (gfc_code *); tree gfc_trans_cycle (gfc_code *);
......
gcc/fortran/trans.c
...@@ -1704,10 +1704,7 @@ trans_code (gfc_code * code, tree cond) ...@@ -1704,10 +1704,7 @@ trans_code (gfc_code * code, tree cond)
break; break;
case EXEC_ASSIGN: case EXEC_ASSIGN:
if (code->expr1->ts.type == BT_CLASS) res = gfc_trans_assign (code);
res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
else
res = gfc_trans_assign (code);
break; break;
case EXEC_LABEL_ASSIGN: case EXEC_LABEL_ASSIGN:
...@@ -1715,16 +1712,7 @@ trans_code (gfc_code * code, tree cond) ...@@ -1715,16 +1712,7 @@ trans_code (gfc_code * code, tree cond)
break; break;
case EXEC_POINTER_ASSIGN: case EXEC_POINTER_ASSIGN:
if (code->expr1->ts.type == BT_CLASS) res = gfc_trans_pointer_assign (code);
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; break;
case EXEC_INIT_ASSIGN: case EXEC_INIT_ASSIGN:
......
gcc/fortran/trans.h
...@@ -699,7 +699,8 @@ tree gfc_call_realloc (stmtblock_t *, tree, tree); ...@@ -699,7 +699,8 @@ tree gfc_call_realloc (stmtblock_t *, tree, tree);
tree gfc_trans_structure_assign (tree, gfc_expr *, bool); tree gfc_trans_structure_assign (tree, gfc_expr *, bool);
/* Generate code for an assignment, includes scalarization. */ /* 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. */ /* Generate code for a pointer assignment. */
tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *); 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> 2016-10-21 Jeff Law <law@redhat.com>
* PR tree-optimization/71947 * 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