/* Statement translation -- generate GCC trees from gfc_code.
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
- 2011
+ 2011, 2012
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
}
+/* Replace a gfc_ss structure by another both in the gfc_se struct
+ and the gfc_loopinfo struct. This is used in gfc_conv_elemental_dependencies
+ to replace a variable ss by the corresponding temporary. */
+
+static void
+replace_ss (gfc_se *se, gfc_ss *old_ss, gfc_ss *new_ss)
+{
+ gfc_ss **sess, **loopss;
+
+ /* The old_ss is a ss for a single variable. */
+ gcc_assert (old_ss->info->type == GFC_SS_SECTION);
+
+ for (sess = &(se->ss); *sess != gfc_ss_terminator; sess = &((*sess)->next))
+ if (*sess == old_ss)
+ break;
+ gcc_assert (*sess != gfc_ss_terminator);
+
+ *sess = new_ss;
+ new_ss->next = old_ss->next;
+
+
+ for (loopss = &(se->loop->ss); *loopss != gfc_ss_terminator;
+ loopss = &((*loopss)->loop_chain))
+ if (*loopss == old_ss)
+ break;
+ gcc_assert (*loopss != gfc_ss_terminator);
+
+ *loopss = new_ss;
+ new_ss->loop_chain = old_ss->loop_chain;
+ new_ss->loop = old_ss->loop;
+
+ gfc_free_ss (old_ss);
+}
+
+
/* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
elemental subroutines. Make temporaries for output arguments if any such
dependencies are found. Output arguments are chosen because internal_unpack
gfc_actual_arglist *arg0;
gfc_expr *e;
gfc_formal_arglist *formal;
- gfc_loopinfo tmp_loop;
gfc_se parmse;
gfc_ss *ss;
- gfc_ss_info *info;
gfc_symbol *fsym;
- gfc_ref *ref;
- int n;
tree data;
- tree offset;
tree size;
tree tmp;
continue;
/* Obtain the info structure for the current argument. */
- info = NULL;
for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next)
- {
- if (ss->expr != e)
- continue;
- info = &ss->data.info;
+ if (ss->info->expr == e)
break;
- }
/* If there is a dependency, create a temporary and use it
instead of the variable. */
{
tree initial, temptype;
stmtblock_t temp_post;
+ gfc_ss *tmp_ss;
- /* Make a local loopinfo for the temporary creation, so that
- none of the other ss->info's have to be renormalized. */
- gfc_init_loopinfo (&tmp_loop);
- tmp_loop.dimen = info->dimen;
- for (n = 0; n < info->dimen; n++)
- {
- tmp_loop.to[n] = loopse->loop->to[n];
- tmp_loop.from[n] = loopse->loop->from[n];
- tmp_loop.order[n] = loopse->loop->order[n];
- }
+ tmp_ss = gfc_get_array_ss (gfc_ss_terminator, NULL, ss->dimen,
+ GFC_SS_SECTION);
+ gfc_mark_ss_chain_used (tmp_ss, 1);
+ tmp_ss->info->expr = ss->info->expr;
+ replace_ss (loopse, ss, tmp_ss);
/* Obtain the argument descriptor for unpacking. */
gfc_init_se (&parmse, NULL);
parmse.want_pointer = 1;
-
- /* The scalarizer introduces some specific peculiarities when
- handling elemental subroutines; the stride can be needed up to
- the dim_array - 1, rather than dim_loop - 1 to calculate
- offsets outside the loop. For this reason, we make sure that
- the descriptor has the dimensionality of the array by converting
- trailing elements into ranges with end = start. */
- for (ref = e->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
- break;
-
- if (ref)
- {
- bool seen_range = false;
- for (n = 0; n < ref->u.ar.dimen; n++)
- {
- if (ref->u.ar.dimen_type[n] == DIMEN_RANGE)
- seen_range = true;
-
- if (!seen_range
- || ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
- continue;
-
- ref->u.ar.end[n] = gfc_copy_expr (ref->u.ar.start[n]);
- ref->u.ar.dimen_type[n] = DIMEN_RANGE;
- }
- }
-
gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e));
gfc_add_block_to_block (&se->pre, &parmse.pre);
|| (fsym->ts.type ==BT_DERIVED
&& fsym->attr.intent == INTENT_OUT))
initial = parmse.expr;
+ /* For class expressions, we always initialize with the copy of
+ the values. */
+ else if (e->ts.type == BT_CLASS)
+ initial = parmse.expr;
else
initial = NULL_TREE;
- /* Find the type of the temporary to create; we don't use the type
- of e itself as this breaks for subcomponent-references in e (where
- the type of e is that of the final reference, but parmse.expr's
- type corresponds to the full derived-type). */
- /* TODO: Fix this somehow so we don't need a temporary of the whole
- array but instead only the components referenced. */
- temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor. */
- gcc_assert (TREE_CODE (temptype) == POINTER_TYPE);
- temptype = TREE_TYPE (temptype);
- temptype = gfc_get_element_type (temptype);
+ if (e->ts.type != BT_CLASS)
+ {
+ /* Find the type of the temporary to create; we don't use the type
+ of e itself as this breaks for subcomponent-references in e
+ (where the type of e is that of the final reference, but
+ parmse.expr's type corresponds to the full derived-type). */
+ /* TODO: Fix this somehow so we don't need a temporary of the whole
+ array but instead only the components referenced. */
+ temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor. */
+ gcc_assert (TREE_CODE (temptype) == POINTER_TYPE);
+ temptype = TREE_TYPE (temptype);
+ temptype = gfc_get_element_type (temptype);
+ }
+
+ else
+ /* For class arrays signal that the size of the dynamic type has to
+ be obtained from the vtable, using the 'initial' expression. */
+ temptype = NULL_TREE;
/* Generate the temporary. Cleaning up the temporary should be the
very last thing done, so we add the code to a new block and add it
size = gfc_create_var (gfc_array_index_type, NULL);
data = gfc_create_var (pvoid_type_node, NULL);
gfc_init_block (&temp_post);
- tmp = gfc_trans_create_temp_array (&se->pre, &temp_post,
- &tmp_loop, info, temptype,
- initial,
- false, true, false,
- &arg->expr->where);
+ tmp = gfc_trans_create_temp_array (&se->pre, &temp_post, tmp_ss,
+ temptype, initial, false, true,
+ false, &arg->expr->where);
gfc_add_modify (&se->pre, size, tmp);
- tmp = fold_convert (pvoid_type_node, info->data);
+ tmp = fold_convert (pvoid_type_node, tmp_ss->info->data.array.data);
gfc_add_modify (&se->pre, data, tmp);
- /* Calculate the offset for the temporary. */
- offset = gfc_index_zero_node;
- for (n = 0; n < info->dimen; n++)
+ /* Update other ss' delta. */
+ gfc_set_delta (loopse->loop);
+
+ /* Copy the result back using unpack..... */
+ if (e->ts.type != BT_CLASS)
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_in_unpack, 2, parmse.expr, data);
+ else
{
- tmp = gfc_conv_descriptor_stride_get (info->descriptor,
- gfc_rank_cst[n]);
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type,
- loopse->loop->from[n], tmp);
- offset = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, offset, tmp);
+ /* ... except for class results where the copy is
+ unconditional. */
+ tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
+ tmp = gfc_conv_descriptor_data_get (tmp);
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_MEMCPY),
+ 3, tmp, data, size);
}
- info->offset = gfc_create_var (gfc_array_index_type, NULL);
- gfc_add_modify (&se->pre, info->offset, offset);
-
- /* Copy the result back using unpack. */
- tmp = build_call_expr_loc (input_location,
- gfor_fndecl_in_unpack, 2, parmse.expr, data);
gfc_add_expr_to_block (&se->post, tmp);
/* parmse.pre is already added above. */
}
+/* Get the interface symbol for the procedure corresponding to the given call.
+ We can't get the procedure symbol directly as we have to handle the case
+ of (deferred) type-bound procedures. */
+
+static gfc_symbol *
+get_proc_ifc_for_call (gfc_code *c)
+{
+ gfc_symbol *sym;
+
+ gcc_assert (c->op == EXEC_ASSIGN_CALL || c->op == EXEC_CALL);
+
+ sym = gfc_get_proc_ifc_for_expr (c->expr1);
+
+ /* Fall back/last resort try. */
+ if (sym == NULL)
+ sym = c->resolved_sym;
+
+ return sym;
+}
+
+
/* Translate the CALL statement. Builds a call to an F95 subroutine. */
tree
ss = gfc_ss_terminator;
if (code->resolved_sym->attr.elemental)
- ss = gfc_walk_elemental_function_args (ss, code->ext.actual, GFC_SS_REFERENCE);
+ ss = gfc_walk_elemental_function_args (ss, code->ext.actual,
+ get_proc_ifc_for_call (code),
+ GFC_SS_REFERENCE);
/* Is not an elemental subroutine call with array valued arguments. */
if (ss == gfc_ss_terminator)
if (gfc_option.coarray == GFC_FCOARRAY_LIB && !error_stop)
{
/* Per F2008, 8.5.1 STOP implies a SYNC MEMORY. */
- tmp = built_in_decls [BUILT_IN_SYNC_SYNCHRONIZE];
+ tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
tmp = build_call_expr_loc (input_location, tmp, 0);
gfc_add_expr_to_block (&se.pre, tmp);
image control statements SYNC IMAGES and SYNC ALL. */
if (gfc_option.coarray == GFC_FCOARRAY_LIB)
{
- tmp = built_in_decls [BUILT_IN_SYNC_SYNCHRONIZE];
- tmp = build_call_expr_loc (input_location, tmp, 0);
- gfc_add_expr_to_block (&se.pre, tmp);
+ tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
+ tmp = build_call_expr_loc (input_location, tmp, 0);
+ gfc_add_expr_to_block (&se.pre, tmp);
}
if (gfc_option.coarray != GFC_FCOARRAY_LIB || type == EXEC_SYNC_MEMORY)
{
gfc_expr *e;
tree tmp;
+ bool class_target;
gcc_assert (sym->assoc);
e = sym->assoc->target;
+ class_target = (e->expr_type == EXPR_VARIABLE)
+ && (gfc_is_class_scalar_expr (e)
+ || gfc_is_class_array_ref (e, NULL));
+
/* Do a `pointer assignment' with updated descriptor (or assign descriptor
to array temporary) for arrays with either unknown shape or if associating
to a variable. */
- if (sym->attr.dimension
+ if (sym->attr.dimension && !class_target
&& (sym->as->type == AS_DEFERRED || sym->assoc->variable))
{
gfc_se se;
gfc_finish_block (&se.post));
}
+ /* CLASS arrays just need the descriptor to be directly assigned. */
+ else if (class_target && sym->attr.dimension)
+ {
+ gfc_se se;
+
+ gfc_init_se (&se, NULL);
+ se.descriptor_only = 1;
+ gfc_conv_expr (&se, e);
+
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)));
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)));
+
+ gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
+
+ gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
+ gfc_finish_block (&se.post));
+ }
+
/* Do a scalar pointer assignment; this is for scalar variable targets. */
else if (gfc_is_associate_pointer (sym))
{
loc = code->ext.iterator->start->where.lb->location;
/* Initialize the DO variable: dovar = from. */
- gfc_add_modify_loc (loc, pblock, dovar, from);
+ gfc_add_modify_loc (loc, pblock, dovar,
+ fold_convert (TREE_TYPE(dovar), from));
/* Save value for do-tinkering checking. */
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
/* Walk the RHS of the expression. */
*rss = gfc_walk_expr (expr2);
if (*rss == gfc_ss_terminator)
- {
- /* The rhs is scalar. Add a ss for the expression. */
- *rss = gfc_get_ss ();
- (*rss)->next = gfc_ss_terminator;
- (*rss)->type = GFC_SS_SCALAR;
- (*rss)->expr = expr2;
- }
+ /* The rhs is scalar. Add a ss for the expression. */
+ *rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
/* Associate the SS with the loop. */
gfc_add_ss_to_loop (&loop, *lss);
gfc_ss *lss, *rss;
gfc_se lse;
gfc_se rse;
- gfc_ss_info *info;
+ gfc_array_info *info;
gfc_loopinfo loop;
tree desc;
tree parm;
gfc_conv_loop_setup (&loop, &expr2->where);
- info = &rss->data.info;
+ info = &rss->info->data.array;
desc = info->descriptor;
/* Make a new descriptor. */
tree maskindex;
tree mask;
tree pmask;
+ tree cycle_label = NULL_TREE;
int n;
int nvar;
int need_temp;
gfc_add_expr_to_block (&block, tmp);
}
+ if (code->op == EXEC_DO_CONCURRENT)
+ {
+ gfc_init_block (&body);
+ cycle_label = gfc_build_label_decl (NULL_TREE);
+ code->cycle_label = cycle_label;
+ tmp = gfc_trans_code (code->block->next);
+ gfc_add_expr_to_block (&body, tmp);
+
+ if (TREE_USED (cycle_label))
+ {
+ tmp = build1_v (LABEL_EXPR, cycle_label);
+ gfc_add_expr_to_block (&body, tmp);
+ }
+
+ tmp = gfc_finish_block (&body);
+ tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
+ gfc_add_expr_to_block (&block, tmp);
+ goto done;
+ }
+
c = code->block->next;
/* TODO: loop merging in FORALL statements. */
c = c->next;
}
+done:
/* Restore the original index variables. */
for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
}
+/* Translate the DO CONCURRENT construct. */
+
+tree gfc_trans_do_concurrent (gfc_code * code)
+{
+ return gfc_trans_forall_1 (code, NULL);
+}
+
+
/* Evaluate the WHERE mask expression, copy its value to a temporary.
If the WHERE construct is nested in FORALL, compute the overall temporary
needed by the WHERE mask expression multiplied by the iterator number of
/* Find a non-scalar SS from the lhs. */
while (lss_section != gfc_ss_terminator
- && lss_section->type != GFC_SS_SECTION)
+ && lss_section->info->type != GFC_SS_SECTION)
lss_section = lss_section->next;
gcc_assert (lss_section != gfc_ss_terminator);
/* Walk the rhs. */
rss = gfc_walk_expr (expr2);
if (rss == gfc_ss_terminator)
- {
- /* The rhs is scalar. Add a ss for the expression. */
- rss = gfc_get_ss ();
- rss->where = 1;
- rss->next = gfc_ss_terminator;
- rss->type = GFC_SS_SCALAR;
- rss->expr = expr2;
+ {
+ /* The rhs is scalar. Add a ss for the expression. */
+ rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
+ rss->info->where = 1;
}
/* Associate the SS with the loop. */
tsss = gfc_walk_expr (tsrc);
if (tsss == gfc_ss_terminator)
{
- tsss = gfc_get_ss ();
- tsss->where = 1;
- tsss->next = gfc_ss_terminator;
- tsss->type = GFC_SS_SCALAR;
- tsss->expr = tsrc;
+ tsss = gfc_get_scalar_ss (gfc_ss_terminator, tsrc);
+ tsss->info->where = 1;
}
gfc_add_ss_to_loop (&loop, tdss);
gfc_add_ss_to_loop (&loop, tsss);
esss = gfc_walk_expr (esrc);
if (esss == gfc_ss_terminator)
{
- esss = gfc_get_ss ();
- esss->where = 1;
- esss->next = gfc_ss_terminator;
- esss->type = GFC_SS_SCALAR;
- esss->expr = esrc;
+ esss = gfc_get_scalar_ss (gfc_ss_terminator, esrc);
+ esss->info->where = 1;
}
gfc_add_ss_to_loop (&loop, edss);
gfc_add_ss_to_loop (&loop, esss);
gfc_trans_allocate (gfc_code * code)
{
gfc_alloc *al;
+ gfc_expr *e;
gfc_expr *expr;
gfc_se se;
tree tmp;
stmtblock_t post;
gfc_expr *sz;
gfc_se se_sz;
+ tree class_expr;
+ tree nelems;
+ tree memsize = NULL_TREE;
+ tree classexpr = NULL_TREE;
if (!code->ext.alloc.list)
return NULL_TREE;
if (code->expr2)
{
gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
gfc_conv_expr_lhs (&se, code->expr2);
-
- errlen = gfc_get_expr_charlen (code->expr2);
- errmsg = gfc_build_addr_expr (pchar_type_node, se.expr);
+ errmsg = se.expr;
+ errlen = se.string_length;
}
else
{
/* GOTO destinations. */
label_errmsg = gfc_build_label_decl (NULL_TREE);
label_finish = gfc_build_label_decl (NULL_TREE);
- TREE_USED (label_errmsg) = 1;
- TREE_USED (label_finish) = 1;
+ TREE_USED (label_finish) = 0;
}
expr3 = NULL_TREE;
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
- if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
+ /* Evaluate expr3 just once if not a variable. */
+ if (al == code->ext.alloc.list
+ && al->expr->ts.type == BT_CLASS
+ && code->expr3
+ && code->expr3->ts.type == BT_CLASS
+ && code->expr3->expr_type != EXPR_VARIABLE)
+ {
+ gfc_init_se (&se_sz, NULL);
+ gfc_conv_expr_reference (&se_sz, code->expr3);
+ gfc_conv_class_to_class (&se_sz, code->expr3,
+ code->expr3->ts, false);
+ gfc_add_block_to_block (&se.pre, &se_sz.pre);
+ gfc_add_block_to_block (&se.post, &se_sz.post);
+ classexpr = build_fold_indirect_ref_loc (input_location,
+ se_sz.expr);
+ classexpr = gfc_evaluate_now (classexpr, &se.pre);
+ memsize = gfc_vtable_size_get (classexpr);
+ memsize = fold_convert (sizetype, memsize);
+ }
+
+ memsz = memsize;
+ class_expr = classexpr;
+
+ nelems = NULL_TREE;
+ if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
+ memsz, &nelems, code->expr3))
{
/* A scalar or derived type. */
/* Determine allocate size. */
- if (al->expr->ts.type == BT_CLASS && code->expr3)
+ if (al->expr->ts.type == BT_CLASS
+ && code->expr3
+ && memsz == NULL_TREE)
{
if (code->expr3->ts.type == BT_CLASS)
{
}
else if (code->ext.alloc.ts.type != BT_UNKNOWN)
memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
- else
+ else if (memsz == NULL_TREE)
memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE)
/* Allocate - for non-pointers with re-alloc checking. */
if (gfc_expr_attr (expr).allocatable)
gfc_allocate_allocatable (&se.pre, se.expr, memsz, NULL_TREE,
- stat, errmsg, errlen, expr);
+ stat, errmsg, errlen, label_finish, expr);
else
gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
- if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
+ if (al->expr->ts.type == BT_DERIVED
+ && expr->ts.u.derived->attr.alloc_comp)
{
tmp = build_fold_indirect_ref_loc (input_location, se.expr);
tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
gfc_add_expr_to_block (&se.pre, tmp);
}
+ else if (al->expr->ts.type == BT_CLASS)
+ {
+ /* With class objects, it is best to play safe and null the
+ memory because we cannot know if dynamic types have allocatable
+ components or not. */
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_MEMSET),
+ 3, se.expr, integer_zero_node, memsz);
+ gfc_add_expr_to_block (&se.pre, tmp);
+ }
}
gfc_add_block_to_block (&block, &se.pre);
/* Error checking -- Note: ERRMSG only makes sense with STAT. */
if (code->expr1)
{
- /* The coarray library already sets the errmsg. */
- if (gfc_option.coarray == GFC_FCOARRAY_LIB
- && gfc_expr_attr (expr).codimension)
- tmp = build1_v (GOTO_EXPR, label_finish);
- else
- tmp = build1_v (GOTO_EXPR, label_errmsg);
-
+ tmp = build1_v (GOTO_EXPR, label_errmsg);
parm = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, stat,
build_int_cst (TREE_TYPE (stat), 0));
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
- gfc_unlikely(parm), tmp,
+ gfc_unlikely (parm), tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&block, tmp);
}
+ /* We need the vptr of CLASS objects to be initialized. */
+ e = gfc_copy_expr (al->expr);
+ if (e->ts.type == BT_CLASS)
+ {
+ gfc_expr *lhs, *rhs;
+ gfc_se lse;
+
+ lhs = gfc_expr_to_initialize (e);
+ gfc_add_vptr_component (lhs);
+
+ if (class_expr != NULL_TREE)
+ {
+ /* Polymorphic SOURCE: VPTR must be determined at run time. */
+ gfc_init_se (&lse, NULL);
+ lse.want_pointer = 1;
+ gfc_conv_expr (&lse, lhs);
+ tmp = gfc_class_vptr_get (class_expr);
+ gfc_add_modify (&block, lse.expr,
+ fold_convert (TREE_TYPE (lse.expr), tmp));
+ }
+ else if (code->expr3 && code->expr3->ts.type == BT_CLASS)
+ {
+ /* Polymorphic SOURCE: VPTR must be determined at run time. */
+ rhs = gfc_copy_expr (code->expr3);
+ gfc_add_vptr_component (rhs);
+ tmp = gfc_trans_pointer_assignment (lhs, rhs);
+ gfc_add_expr_to_block (&block, tmp);
+ gfc_free_expr (rhs);
+ rhs = gfc_expr_to_initialize (e);
+ }
+ else
+ {
+ /* VPTR is fixed at compile time. */
+ gfc_symbol *vtab;
+ gfc_typespec *ts;
+ if (code->expr3)
+ ts = &code->expr3->ts;
+ else if (e->ts.type == BT_DERIVED)
+ ts = &e->ts;
+ else if (code->ext.alloc.ts.type == BT_DERIVED)
+ ts = &code->ext.alloc.ts;
+ else if (e->ts.type == BT_CLASS)
+ ts = &CLASS_DATA (e)->ts;
+ else
+ ts = &e->ts;
+
+ if (ts->type == BT_DERIVED)
+ {
+ vtab = gfc_find_derived_vtab (ts->u.derived);
+ gcc_assert (vtab);
+ gfc_init_se (&lse, NULL);
+ lse.want_pointer = 1;
+ gfc_conv_expr (&lse, lhs);
+ tmp = gfc_build_addr_expr (NULL_TREE,
+ gfc_get_symbol_decl (vtab));
+ gfc_add_modify (&block, lse.expr,
+ fold_convert (TREE_TYPE (lse.expr), tmp));
+ }
+ }
+ gfc_free_expr (lhs);
+ }
+
+ gfc_free_expr (e);
+
if (code->expr3 && !code->expr3->mold)
{
/* Initialization via SOURCE block
(or static default initializer). */
gfc_expr *rhs = gfc_copy_expr (code->expr3);
- if (al->expr->ts.type == BT_CLASS)
+ if (class_expr != NULL_TREE)
+ {
+ tree to;
+ to = TREE_OPERAND (se.expr, 0);
+
+ tmp = gfc_copy_class_to_class (class_expr, to, nelems);
+ }
+ else if (al->expr->ts.type == BT_CLASS)
{
- gfc_se call;
gfc_actual_arglist *actual;
gfc_expr *ppc;
- gfc_init_se (&call, NULL);
+ gfc_code *ppc_code;
+ gfc_ref *dataref;
+
/* Do a polymorphic deep copy. */
actual = gfc_get_actual_arglist ();
actual->expr = gfc_copy_expr (rhs);
gfc_add_data_component (actual->expr);
actual->next = gfc_get_actual_arglist ();
actual->next->expr = gfc_copy_expr (al->expr);
+ actual->next->expr->ts.type = BT_CLASS;
gfc_add_data_component (actual->next->expr);
+
+ dataref = actual->next->expr->ref;
+ /* Make sure we go up through the reference chain to
+ the _data reference, where the arrayspec is found. */
+ while (dataref->next && dataref->next->type != REF_ARRAY)
+ dataref = dataref->next;
+
+ if (dataref->u.c.component->as)
+ {
+ int dim;
+ gfc_expr *temp;
+ gfc_ref *ref = dataref->next;
+ ref->u.ar.type = AR_SECTION;
+ /* We have to set up the array reference to give ranges
+ in all dimensions and ensure that the end and stride
+ are set so that the copy can be scalarized. */
+ dim = 0;
+ for (; dim < dataref->u.c.component->as->rank; dim++)
+ {
+ ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
+ if (ref->u.ar.end[dim] == NULL)
+ {
+ ref->u.ar.end[dim] = ref->u.ar.start[dim];
+ temp = gfc_get_int_expr (gfc_default_integer_kind,
+ &al->expr->where, 1);
+ ref->u.ar.start[dim] = temp;
+ }
+ temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]),
+ gfc_copy_expr (ref->u.ar.start[dim]));
+ temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind,
+ &al->expr->where, 1),
+ temp);
+ }
+ }
if (rhs->ts.type == BT_CLASS)
{
ppc = gfc_copy_expr (rhs);
gfc_add_vptr_component (ppc);
}
else
- ppc = gfc_lval_expr_from_sym (gfc_find_derived_vtab (rhs->ts.u.derived));
+ ppc = gfc_lval_expr_from_sym
+ (gfc_find_derived_vtab (rhs->ts.u.derived));
gfc_add_component_ref (ppc, "_copy");
- gfc_conv_procedure_call (&call, ppc->symtree->n.sym, actual,
- ppc, NULL);
- gfc_add_expr_to_block (&call.pre, call.expr);
- gfc_add_block_to_block (&call.pre, &call.post);
- tmp = gfc_finish_block (&call.pre);
+
+ ppc_code = gfc_get_code ();
+ ppc_code->resolved_sym = ppc->symtree->n.sym;
+ /* 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;
+ ppc_code->op = EXEC_CALL;
+ /* 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);
+ gfc_free_statements (ppc_code);
}
else if (expr3 != NULL_TREE)
{
gfc_free_expr (rhs);
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)
{
- /* Default-initialization via MOLD (polymorphic). */
- gfc_expr *rhs = gfc_copy_expr (code->expr3);
- gfc_se dst,src;
- gfc_add_vptr_component (rhs);
- gfc_add_def_init_component (rhs);
- gfc_init_se (&dst, NULL);
- gfc_init_se (&src, NULL);
- gfc_conv_expr (&dst, expr);
- gfc_conv_expr (&src, rhs);
- gfc_add_block_to_block (&block, &src.pre);
- tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
+ /* 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);
gfc_add_expr_to_block (&block, tmp);
- gfc_free_expr (rhs);
- }
-
- /* Allocation of CLASS entities. */
- gfc_free_expr (expr);
- expr = al->expr;
- if (expr->ts.type == BT_CLASS)
- {
- gfc_expr *lhs,*rhs;
- gfc_se lse;
-
- /* Initialize VPTR for CLASS objects. */
- lhs = gfc_expr_to_initialize (expr);
- gfc_add_vptr_component (lhs);
- rhs = NULL;
- if (code->expr3 && code->expr3->ts.type == BT_CLASS)
- {
- /* Polymorphic SOURCE: VPTR must be determined at run time. */
- rhs = gfc_copy_expr (code->expr3);
- gfc_add_vptr_component (rhs);
- tmp = gfc_trans_pointer_assignment (lhs, rhs);
- gfc_add_expr_to_block (&block, tmp);
- gfc_free_expr (rhs);
- }
- else
- {
- /* VPTR is fixed at compile time. */
- gfc_symbol *vtab;
- gfc_typespec *ts;
- if (code->expr3)
- ts = &code->expr3->ts;
- else if (expr->ts.type == BT_DERIVED)
- ts = &expr->ts;
- else if (code->ext.alloc.ts.type == BT_DERIVED)
- ts = &code->ext.alloc.ts;
- else if (expr->ts.type == BT_CLASS)
- ts = &CLASS_DATA (expr)->ts;
- else
- ts = &expr->ts;
-
- if (ts->type == BT_DERIVED)
- {
- vtab = gfc_find_derived_vtab (ts->u.derived);
- gcc_assert (vtab);
- gfc_init_se (&lse, NULL);
- lse.want_pointer = 1;
- gfc_conv_expr (&lse, lhs);
- tmp = gfc_build_addr_expr (NULL_TREE,
- gfc_get_symbol_decl (vtab));
- gfc_add_modify (&block, lse.expr,
- fold_convert (TREE_TYPE (lse.expr), tmp));
- }
- }
- gfc_free_expr (lhs);
}
+ gfc_free_expr (expr);
}
- /* STAT (ERRMSG only makes sense with STAT). */
+ /* STAT. */
if (code->expr1)
{
tmp = build1_v (LABEL_EXPR, label_errmsg);
gfc_add_expr_to_block (&block, tmp);
}
- /* ERRMSG block. */
- if (code->expr2)
+ /* ERRMSG - only useful if STAT is present. */
+ if (code->expr1 && code->expr2)
{
- /* A better error message may be possible, but not required. */
const char *msg = "Attempt to allocate an allocated object";
- tree slen, dlen;
-
- gfc_init_se (&se, NULL);
- gfc_conv_expr_lhs (&se, code->expr2);
+ tree slen, dlen, errmsg_str;
+ stmtblock_t errmsg_block;
- errmsg = gfc_create_var (pchar_type_node, "ERRMSG");
+ gfc_init_block (&errmsg_block);
- gfc_add_modify (&block, errmsg,
+ errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
+ gfc_add_modify (&errmsg_block, errmsg_str,
gfc_build_addr_expr (pchar_type_node,
gfc_build_localized_cstring_const (msg)));
slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen,
slen);
- dlen = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMCPY], 3,
- gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen);
+ gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
+ slen, errmsg_str, gfc_default_character_kind);
+ dlen = gfc_finish_block (&errmsg_block);
tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
build_int_cst (TREE_TYPE (stat), 0));
gfc_add_expr_to_block (&block, tmp);
}
- /* STAT (ERRMSG only makes sense with STAT). */
- if (code->expr1)
- {
- tmp = build1_v (LABEL_EXPR, label_finish);
- gfc_add_expr_to_block (&block, tmp);
- }
-
/* STAT block. */
if (code->expr1)
{
+ if (TREE_USED (label_finish))
+ {
+ tmp = build1_v (LABEL_EXPR, label_finish);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
gfc_init_se (&se, NULL);
gfc_conv_expr_lhs (&se, code->expr1);
tmp = convert (TREE_TYPE (se.expr), stat);
{
gfc_se se;
gfc_alloc *al;
- tree apstat, astat, pstat, stat, tmp;
+ tree apstat, pstat, stat, errmsg, errlen, tmp;
+ tree label_finish, label_errmsg;
stmtblock_t block;
- pstat = apstat = stat = astat = tmp = NULL_TREE;
+ pstat = apstat = stat = errmsg = errlen = tmp = NULL_TREE;
+ label_finish = label_errmsg = NULL_TREE;
gfc_start_block (&block);
/* Count the number of failed deallocations. If deallocate() was
called with STAT= , then set STAT to the count. If deallocate
was called with ERRMSG, then set ERRMG to a string. */
- if (code->expr1 || code->expr2)
+ if (code->expr1)
{
tree gfc_int4_type_node = gfc_get_int_type (4);
stat = gfc_create_var (gfc_int4_type_node, "stat");
pstat = gfc_build_addr_expr (NULL_TREE, stat);
- /* Running total of possible deallocation failures. */
- astat = gfc_create_var (gfc_int4_type_node, "astat");
- apstat = gfc_build_addr_expr (NULL_TREE, astat);
+ /* GOTO destinations. */
+ label_errmsg = gfc_build_label_decl (NULL_TREE);
+ label_finish = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (label_finish) = 0;
+ }
- /* Initialize astat to 0. */
- gfc_add_modify (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
+ /* Set ERRMSG - only needed if STAT is available. */
+ if (code->expr1 && code->expr2)
+ {
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ gfc_conv_expr_lhs (&se, code->expr2);
+ errmsg = se.expr;
+ errlen = se.string_length;
}
for (al = code->ext.alloc.list; al != NULL; al = al->next)
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
- if (expr->rank || gfc_expr_attr (expr).codimension)
+ if (expr->rank || gfc_is_coarray (expr))
{
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
{
gfc_add_expr_to_block (&se.pre, tmp);
}
}
- tmp = gfc_array_deallocate (se.expr, pstat, expr);
+ tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen,
+ label_finish, expr);
gfc_add_expr_to_block (&se.pre, tmp);
}
else
}
}
- /* Keep track of the number of failed deallocations by adding stat
- of the last deallocation to the running total. */
- if (code->expr1 || code->expr2)
+ if (code->expr1)
{
- apstat = fold_build2_loc (input_location, PLUS_EXPR,
- TREE_TYPE (stat), astat, stat);
- gfc_add_modify (&se.pre, astat, apstat);
+ tree cond;
+
+ cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
+ build_int_cst (TREE_TYPE (stat), 0));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ gfc_unlikely (cond),
+ build1_v (GOTO_EXPR, label_errmsg),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&se.pre, tmp);
}
tmp = gfc_finish_block (&se.pre);
gfc_free_expr (expr);
}
- /* Set STAT. */
if (code->expr1)
{
- gfc_init_se (&se, NULL);
- gfc_conv_expr_lhs (&se, code->expr1);
- tmp = convert (TREE_TYPE (se.expr), astat);
- gfc_add_modify (&block, se.expr, tmp);
+ tmp = build1_v (LABEL_EXPR, label_errmsg);
+ gfc_add_expr_to_block (&block, tmp);
}
- /* Set ERRMSG. */
- if (code->expr2)
+ /* Set ERRMSG - only needed if STAT is available. */
+ if (code->expr1 && code->expr2)
{
- /* A better error message may be possible, but not required. */
const char *msg = "Attempt to deallocate an unallocated object";
- tree errmsg, slen, dlen;
+ stmtblock_t errmsg_block;
+ tree errmsg_str, slen, dlen, cond;
- gfc_init_se (&se, NULL);
- gfc_conv_expr_lhs (&se, code->expr2);
+ gfc_init_block (&errmsg_block);
- errmsg = gfc_create_var (pchar_type_node, "ERRMSG");
-
- gfc_add_modify (&block, errmsg,
+ errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
+ gfc_add_modify (&errmsg_block, errmsg_str,
gfc_build_addr_expr (pchar_type_node,
gfc_build_localized_cstring_const (msg)));
-
slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
dlen = gfc_get_expr_charlen (code->expr2);
- slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen,
- slen);
- dlen = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMCPY], 3,
- gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen);
+ gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
+ slen, errmsg_str, gfc_default_character_kind);
+ tmp = gfc_finish_block (&errmsg_block);
- tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, astat,
- build_int_cst (TREE_TYPE (astat), 0));
+ cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
+ build_int_cst (TREE_TYPE (stat), 0));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ gfc_unlikely (cond), tmp,
+ build_empty_stmt (input_location));
- tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ if (code->expr1 && TREE_USED (label_finish))
+ {
+ tmp = build1_v (LABEL_EXPR, label_finish);
gfc_add_expr_to_block (&block, tmp);
}
+ /* Set STAT. */
+ if (code->expr1)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_lhs (&se, code->expr1);
+ tmp = convert (TREE_TYPE (se.expr), stat);
+ gfc_add_modify (&block, se.expr, tmp);
+ }
+
return gfc_finish_block (&block);
}
OSDN Git Service
