/* Statement translation -- generate GCC trees from gfc_code.
- Copyright (C) 2002-2017 Free Software Foundation, Inc.
+ Copyright (C) 2002-2018 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
gfc_start_block (&se.pre);
gfc_conv_label_variable (&se, code->expr1);
tmp = GFC_DECL_STRING_LEN (se.expr);
- tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
+ tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
build_int_cst (TREE_TYPE (tmp), -1));
gfc_trans_runtime_check (true, false, tmp, &se.pre, &loc,
"Assigned label is not a target label");
subscripts. This could be prevented in the elemental case
as temporaries are handled separatedly
(below in gfc_conv_elemental_dependencies). */
- gfc_conv_loop_setup (&loop, &code->expr1->where);
+ if (code->expr1)
+ gfc_conv_loop_setup (&loop, &code->expr1->where);
+ else
+ gfc_conv_loop_setup (&loop, &code->loc);
+
gfc_mark_ss_chain_used (ss, 1);
/* Convert the arguments, checking for dependencies. */
tree
gfc_trans_pause (gfc_code * code)
{
- tree gfc_int4_type_node = gfc_get_int_type (4);
+ tree gfc_int8_type_node = gfc_get_int_type (8);
gfc_se se;
tree tmp;
if (code->expr1 == NULL)
{
- tmp = build_int_cst (gfc_int4_type_node, 0);
+ tmp = build_int_cst (size_type_node, 0);
tmp = build_call_expr_loc (input_location,
gfor_fndecl_pause_string, 2,
build_int_cst (pchar_type_node, 0), tmp);
gfc_conv_expr (&se, code->expr1);
tmp = build_call_expr_loc (input_location,
gfor_fndecl_pause_numeric, 1,
- fold_convert (gfc_int4_type_node, se.expr));
+ fold_convert (gfc_int8_type_node, se.expr));
}
else
{
gfc_conv_expr_reference (&se, code->expr1);
tmp = build_call_expr_loc (input_location,
gfor_fndecl_pause_string, 2,
- se.expr, se.string_length);
+ se.expr, fold_convert (size_type_node,
+ se.string_length));
}
gfc_add_expr_to_block (&se.pre, tmp);
tree
gfc_trans_stop (gfc_code *code, bool error_stop)
{
- tree gfc_int4_type_node = gfc_get_int_type (4);
gfc_se se;
tree tmp;
if (code->expr1 == NULL)
{
- tmp = build_int_cst (gfc_int4_type_node, 0);
+ tmp = build_int_cst (size_type_node, 0);
tmp = build_call_expr_loc (input_location,
error_stop
? (flag_coarray == GFC_FCOARRAY_LIB
: (flag_coarray == GFC_FCOARRAY_LIB
? gfor_fndecl_caf_stop_str
: gfor_fndecl_stop_string),
- 2, build_int_cst (pchar_type_node, 0), tmp);
+ 3, build_int_cst (pchar_type_node, 0), tmp,
+ boolean_false_node);
}
else if (code->expr1->ts.type == BT_INTEGER)
{
: gfor_fndecl_error_stop_numeric)
: (flag_coarray == GFC_FCOARRAY_LIB
? gfor_fndecl_caf_stop_numeric
- : gfor_fndecl_stop_numeric), 1,
- fold_convert (gfc_int4_type_node, se.expr));
+ : gfor_fndecl_stop_numeric), 2,
+ fold_convert (integer_type_node, se.expr),
+ boolean_false_node);
}
else
{
: (flag_coarray == GFC_FCOARRAY_LIB
? gfor_fndecl_caf_stop_str
: gfor_fndecl_stop_string),
- 2, se.expr, se.string_length);
+ 3, se.expr, fold_convert (size_type_node,
+ se.string_length),
+ boolean_false_node);
}
gfc_add_expr_to_block (&se.pre, tmp);
return gfc_finish_block (&se.pre);
}
+/* Translate the FAIL IMAGE statement. */
+
+tree
+gfc_trans_fail_image (gfc_code *code ATTRIBUTE_UNUSED)
+{
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ return build_call_expr_loc (input_location,
+ gfor_fndecl_caf_fail_image, 1,
+ build_int_cst (pchar_type_node, 0));
+ else
+ {
+ const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
+ gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
+ tree tmp = gfc_get_symbol_decl (exsym);
+ return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
+ }
+}
+
+/* Translate the FORM TEAM statement. */
+
+tree
+gfc_trans_form_team (gfc_code *code)
+{
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ {
+ gfc_se argse;
+ tree team_id,team_type;
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr1);
+ team_id = fold_convert (integer_type_node, argse.expr);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr2);
+ team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr);
+
+ return build_call_expr_loc (input_location,
+ gfor_fndecl_caf_form_team, 3,
+ team_id, team_type,
+ build_int_cst (integer_type_node, 0));
+ }
+ else
+ {
+ const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
+ gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
+ tree tmp = gfc_get_symbol_decl (exsym);
+ return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
+ }
+}
+
+/* Translate the CHANGE TEAM statement. */
+
+tree
+gfc_trans_change_team (gfc_code *code)
+{
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ {
+ gfc_se argse;
+ tree team_type;
+
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr1);
+ team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr);
+
+ return build_call_expr_loc (input_location,
+ gfor_fndecl_caf_change_team, 2, team_type,
+ build_int_cst (integer_type_node, 0));
+ }
+ else
+ {
+ const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
+ gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
+ tree tmp = gfc_get_symbol_decl (exsym);
+ return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
+ }
+}
+
+/* Translate the END TEAM statement. */
+
+tree
+gfc_trans_end_team (gfc_code *code ATTRIBUTE_UNUSED)
+{
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ {
+ return build_call_expr_loc (input_location,
+ gfor_fndecl_caf_end_team, 1,
+ build_int_cst (pchar_type_node, 0));
+ }
+ else
+ {
+ const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
+ gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
+ tree tmp = gfc_get_symbol_decl (exsym);
+ return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
+ }
+}
+
+/* Translate the SYNC TEAM statement. */
+
+tree
+gfc_trans_sync_team (gfc_code *code)
+{
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ {
+ gfc_se argse;
+ tree team_type;
+
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr1);
+ team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr);
+
+ return build_call_expr_loc (input_location,
+ gfor_fndecl_caf_sync_team, 2,
+ team_type,
+ build_int_cst (integer_type_node, 0));
+ }
+ else
+ {
+ const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
+ gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
+ tree tmp = gfc_get_symbol_decl (exsym);
+ return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
+ }
+}
tree
gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
gfc_conv_expr (&argse, code->expr3);
gfc_add_block_to_block (&se.pre, &argse.pre);
errmsg = argse.expr;
- errmsg_len = fold_convert (integer_type_node, argse.string_length);
+ errmsg_len = fold_convert (size_type_node, argse.string_length);
}
else
{
errmsg = null_pointer_node;
- errmsg_len = integer_zero_node;
+ errmsg_len = build_zero_cst (size_type_node);
}
if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
gfc_conv_expr (&argse, code->expr3);
gfc_add_block_to_block (&se.pre, &argse.pre);
errmsg = argse.expr;
- errmsg_len = fold_convert (integer_type_node, argse.string_length);
+ errmsg_len = fold_convert (size_type_node, argse.string_length);
}
else
{
errmsg = null_pointer_node;
- errmsg_len = integer_zero_node;
+ errmsg_len = build_zero_cst (size_type_node);
}
if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
gfc_conv_expr (&argse, code->expr3);
gfc_conv_string_parameter (&argse);
errmsg = gfc_build_addr_expr (NULL, argse.expr);
- errmsglen = argse.string_length;
+ errmsglen = fold_convert (size_type_node, argse.string_length);
}
else if (flag_coarray == GFC_FCOARRAY_LIB)
{
errmsg = null_pointer_node;
- errmsglen = build_int_cst (integer_type_node, 0);
+ errmsglen = build_int_cst (size_type_node, 0);
}
/* Check SYNC IMAGES(imageset) for valid image index.
{
tree cond;
if (flag_coarray != GFC_FCOARRAY_LIB)
- cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
images, build_int_cst (TREE_TYPE (images), 1));
else
{
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2, integer_zero_node,
build_int_cst (integer_type_node, -1));
- cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
images, tmp);
- cond2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
images,
build_int_cst (TREE_TYPE (images), 1));
cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- boolean_type_node, cond, cond2);
+ logical_type_node, cond, cond2);
}
gfc_trans_runtime_check (true, false, cond, &se.pre,
&code->expr1->where, "Invalid image number "
branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));
if (code->label1->value != code->label3->value)
- tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
se.expr, zero);
else
- tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
se.expr, zero);
branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
{
/* if (cond <= 0) take branch1 else take branch2. */
branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
- tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
+ tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
se.expr, zero);
branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
tmp, branch1, branch2);
int n;
tree charlen;
bool need_len_assign;
+ bool whole_array = true;
+ gfc_ref *ref;
+ symbol_attribute attr;
gcc_assert (sym->assoc);
e = sym->assoc->target;
unlimited = UNLIMITED_POLY (e);
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY
+ && ref->u.ar.type == AR_FULL
+ && ref->next)
+ {
+ whole_array = false;
+ break;
+ }
+
/* Assignments to the string length need to be generated, when
( sym is a char array or
sym has a _len component)
desc = sym->backend_decl;
cst_array_ctor = e->expr_type == EXPR_ARRAY
- && gfc_constant_array_constructor_p (e->value.constructor);
+ && gfc_constant_array_constructor_p (e->value.constructor)
+ && e->ts.type != BT_CHARACTER;
/* If association is to an expression, evaluate it and create temporary.
Otherwise, get descriptor of target for pointer assignment. */
gfc_conv_expr_descriptor (&se, e);
+ if (sym->ts.type == BT_CHARACTER
+ && sym->ts.deferred
+ && !sym->attr.select_type_temporary
+ && VAR_P (sym->ts.u.cl->backend_decl)
+ && se.string_length != sym->ts.u.cl->backend_decl)
+ {
+ gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl,
+ fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
+ se.string_length));
+ }
+
/* If we didn't already do the pointer assignment, set associate-name
descriptor to the one generated for the temporary. */
- if (!sym->assoc->variable && !cst_array_ctor)
+ if ((!sym->assoc->variable && !cst_array_ctor)
+ || !whole_array)
{
int dim;
- gfc_add_modify (&se.pre, desc, se.expr);
+ if (whole_array)
+ gfc_add_modify (&se.pre, desc, se.expr);
/* The generated descriptor has lower bound zero (as array
temporary), shift bounds so we get lower bounds of 1. */
if (sym->attr.subref_array_pointer)
{
gcc_assert (e->expr_type == EXPR_VARIABLE);
- tmp = e->symtree->n.sym->ts.type == BT_CLASS
- ? gfc_class_data_get (e->symtree->n.sym->backend_decl)
- : e->symtree->n.sym->backend_decl;
- tmp = gfc_get_element_type (TREE_TYPE (tmp));
- tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
- gfc_add_modify (&se.pre, GFC_DECL_SPAN(desc), tmp);
+ tmp = gfc_get_array_span (se.expr, e);
+
+ gfc_conv_descriptor_span_set (&se.pre, desc, tmp);
+ }
+
+ if (e->expr_type == EXPR_FUNCTION
+ && sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived
+ && sym->ts.u.derived->attr.pdt_type)
+ {
+ tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, se.expr,
+ sym->as->rank);
+ gfc_add_expr_to_block (&se.post, tmp);
}
/* Done, register stuff as init / cleanup code. */
need_len_assign = need_len_assign && sym->ts.type == BT_CHARACTER;
}
- tmp = TREE_TYPE (sym->backend_decl);
- tmp = gfc_build_addr_expr (tmp, se.expr);
+ if (sym->ts.type == BT_CHARACTER
+ && sym->ts.deferred
+ && !sym->attr.select_type_temporary
+ && VAR_P (sym->ts.u.cl->backend_decl)
+ && se.string_length != sym->ts.u.cl->backend_decl)
+ {
+ gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl,
+ fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
+ se.string_length));
+ if (e->expr_type == EXPR_FUNCTION)
+ {
+ tmp = gfc_call_free (sym->backend_decl);
+ gfc_add_expr_to_block (&se.post, tmp);
+ }
+ }
+
+ attr = gfc_expr_attr (e);
+ if (sym->ts.type == BT_CHARACTER && e->ts.type == BT_CHARACTER
+ && (attr.allocatable || attr.pointer || attr.dummy)
+ && POINTER_TYPE_P (TREE_TYPE (se.expr)))
+ {
+ /* These are pointer types already. */
+ tmp = fold_convert (TREE_TYPE (sym->backend_decl), se.expr);
+ }
+ else
+ {
+ tmp = TREE_TYPE (sym->backend_decl);
+ tmp = gfc_build_addr_expr (tmp, se.expr);
+ }
+
gfc_add_modify (&se.pre, sym->backend_decl, tmp);
gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
else
{
gfc_expr *lhs;
+ tree res;
+ gfc_se se;
+
+ gfc_init_se (&se, NULL);
+
+ /* resolve.c converts some associate names to allocatable so that
+ allocation can take place automatically in gfc_trans_assignment.
+ The frontend prevents them from being either allocated,
+ deallocated or reallocated. */
+ if (sym->attr.allocatable)
+ {
+ tmp = sym->backend_decl;
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_conv_descriptor_data_get (tmp);
+ gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
+ null_pointer_node));
+ }
lhs = gfc_lval_expr_from_sym (sym);
- tmp = gfc_trans_assignment (lhs, e, false, true);
- gfc_add_init_cleanup (block, tmp, NULL_TREE);
+ res = gfc_trans_assignment (lhs, e, false, true);
+ gfc_add_expr_to_block (&se.pre, res);
+
+ tmp = sym->backend_decl;
+ if (e->expr_type == EXPR_FUNCTION
+ && sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived
+ && sym->ts.u.derived->attr.pdt_type)
+ {
+ tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, tmp,
+ 0);
+ }
+ else if (e->expr_type == EXPR_FUNCTION
+ && sym->ts.type == BT_CLASS
+ && CLASS_DATA (sym)->ts.u.derived
+ && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type)
+ {
+ tmp = gfc_class_data_get (tmp);
+ tmp = gfc_deallocate_pdt_comp (CLASS_DATA (sym)->ts.u.derived,
+ tmp, 0);
+ }
+ else if (sym->attr.allocatable)
+ {
+ tmp = sym->backend_decl;
+
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_conv_descriptor_data_get (tmp);
+
+ /* A simple call to free suffices here. */
+ tmp = gfc_call_free (tmp);
+
+ /* Make sure that reallocation on assignment cannot occur. */
+ sym->attr.allocatable = 0;
+ }
+ else
+ tmp = NULL_TREE;
+
+ res = gfc_finish_block (&se.pre);
+ gfc_add_init_cleanup (block, res, tmp);
+ gfc_free_expr (lhs);
}
/* Set the stringlength, when needed. */
gfc_init_se (&se, NULL);
if (e->symtree->n.sym->ts.type == BT_CHARACTER)
{
- /* What about deferred strings? */
+ /* Deferred strings are dealt with in the preceeding. */
gcc_assert (!e->symtree->n.sym->ts.deferred);
tmp = e->symtree->n.sym->ts.u.cl->backend_decl;
}
+ else if (e->symtree->n.sym->attr.function
+ && e->symtree->n.sym == e->symtree->n.sym->result)
+ {
+ tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
+ tmp = gfc_class_len_get (tmp);
+ }
else
tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym));
gfc_get_symbol_decl (sym);
/* Evaluate the loop condition. */
if (is_step_positive)
- cond = fold_build2_loc (loc, GT_EXPR, boolean_type_node, dovar,
+ cond = fold_build2_loc (loc, GT_EXPR, logical_type_node, dovar,
fold_convert (type, to));
else
- cond = fold_build2_loc (loc, LT_EXPR, boolean_type_node, dovar,
+ cond = fold_build2_loc (loc, LT_EXPR, logical_type_node, dovar,
fold_convert (type, to));
cond = gfc_evaluate_now_loc (loc, cond, &body);
+ if (code->ext.iterator->unroll && cond != error_mark_node)
+ cond
+ = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
+ build_int_cst (integer_type_node, annot_expr_unroll_kind),
+ build_int_cst (integer_type_node, code->ext.iterator->unroll));
/* The loop exit. */
tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
tree boundary = is_step_positive ? TYPE_MAX_VALUE (type)
: TYPE_MIN_VALUE (type);
- tmp = fold_build2_loc (loc, EQ_EXPR, boolean_type_node,
+ tmp = fold_build2_loc (loc, EQ_EXPR, logical_type_node,
dovar, boundary);
gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
"Loop iterates infinitely");
/* Check whether someone has modified the loop variable. */
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
{
- tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node,
+ tmp = fold_build2_loc (loc, NE_EXPR, logical_type_node,
dovar, saved_dovar);
gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
"Loop variable has been modified");
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
{
- tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, step,
+ tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, step,
build_zero_cst (type));
gfc_trans_runtime_check (true, false, tmp, &block, &code->loc,
"DO step value is zero");
/* For a positive step, when to < from, exit, otherwise compute
countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */
- tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, to, from);
+ tmp = fold_build2_loc (loc, LT_EXPR, logical_type_node, to, from);
tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype,
fold_build2_loc (loc, MINUS_EXPR, utype,
tou, fromu),
/* For a negative step, when to > from, exit, otherwise compute
countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */
- tmp = fold_build2_loc (loc, GT_EXPR, boolean_type_node, to, from);
+ tmp = fold_build2_loc (loc, GT_EXPR, logical_type_node, to, from);
tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype,
fold_build2_loc (loc, MINUS_EXPR, utype,
fromu, tou),
build1_loc (loc, GOTO_EXPR, void_type_node,
exit_label), NULL_TREE));
- tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, step,
+ tmp = fold_build2_loc (loc, LT_EXPR, logical_type_node, step,
build_int_cst (TREE_TYPE (step), 0));
tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, neg, pos);
/* We need a special check for empty loops:
empty = (step > 0 ? to < from : to > from); */
- pos_step = fold_build2_loc (loc, GT_EXPR, boolean_type_node, step,
+ pos_step = fold_build2_loc (loc, GT_EXPR, logical_type_node, step,
build_zero_cst (type));
- tmp = fold_build3_loc (loc, COND_EXPR, boolean_type_node, pos_step,
+ tmp = fold_build3_loc (loc, COND_EXPR, logical_type_node, pos_step,
fold_build2_loc (loc, LT_EXPR,
- boolean_type_node, to, from),
+ logical_type_node, to, from),
fold_build2_loc (loc, GT_EXPR,
- boolean_type_node, to, from));
+ logical_type_node, to, from));
/* If the loop is empty, go directly to the exit label. */
tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
build1_v (GOTO_EXPR, exit_label),
/* Check whether someone has modified the loop variable. */
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
{
- tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node, dovar,
+ tmp = fold_build2_loc (loc, NE_EXPR, logical_type_node, dovar,
saved_dovar);
gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
"Loop variable has been modified");
gfc_add_modify_loc (loc, &body, countm1, tmp);
/* End with the loop condition. Loop until countm1t == 0. */
- cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, countm1t,
+ cond = fold_build2_loc (loc, EQ_EXPR, logical_type_node, countm1t,
build_int_cst (utype, 0));
+ if (code->ext.iterator->unroll && cond != error_mark_node)
+ cond
+ = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
+ build_int_cst (integer_type_node, annot_expr_unroll_kind),
+ build_int_cst (integer_type_node, code->ext.iterator->unroll));
tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
cond, tmp, build_empty_stmt (loc));
to represent unbounded cases. */
if (!cp->low
- || (cp->low
- && mpz_cmp (cp->low->value.integer,
- cp->high->value.integer) != 0))
+ || (mpz_cmp (cp->low->value.integer,
+ cp->high->value.integer) != 0))
high = gfc_conv_mpz_to_tree (cp->high->value.integer,
cp->high->ts.kind);
}
tmp = gfc_finish_block (&body);
- tmp = fold_build3_loc (input_location, SWITCH_EXPR, NULL_TREE,
- se.expr, tmp, NULL_TREE);
+ tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, se.expr, tmp);
gfc_add_expr_to_block (&block, tmp);
tmp = build1_v (LABEL_EXPR, end_label);
gfc_add_block_to_block (&block, &expr1se.post);
tmp = gfc_finish_block (&body);
- tmp = fold_build3_loc (input_location, SWITCH_EXPR, NULL_TREE,
- case_num, tmp, NULL_TREE);
+ tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE,
+ case_num, tmp);
gfc_add_expr_to_block (&block, tmp);
tmp = build1_v (LABEL_EXPR, end_label);
gfc_add_block_to_block (&block, &expr1se.post);
tmp = gfc_finish_block (&body);
- tmp = fold_build3_loc (input_location, SWITCH_EXPR, NULL_TREE,
- case_num, tmp, NULL_TREE);
+ tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE,
+ case_num, tmp);
gfc_add_expr_to_block (&block, tmp);
tmp = build1_v (LABEL_EXPR, end_label);
gfc_add_block_to_block (post, &tse.post);
tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);
- if (e->ts.type != BT_CHARACTER)
+ if (c->expr1->ref->u.ar.type != AR_SECTION)
{
/* Use the variable offset for the temporary. */
tmp = gfc_conv_array_offset (old_sym->backend_decl);
gfc_init_block (&block);
/* The exit condition. */
- cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
+ cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
count, build_int_cst (TREE_TYPE (count), 0));
+
+ /* PR 83064 means that we cannot use annot_expr_parallel_kind until
+ the autoparallelizer can hande this. */
if (forall_tmp->do_concurrent)
- cond = build2 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
+ cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
build_int_cst (integer_type_node,
- annot_expr_ivdep_kind));
+ annot_expr_ivdep_kind),
+ integer_zero_node);
tmp = build1_v (GOTO_EXPR, exit_label);
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
static tree
generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
- tree count1, tree wheremask, bool invert)
+ tree count1,
+ gfc_ss *lss, gfc_ss *rss,
+ tree wheremask, bool invert)
{
- gfc_ss *lss;
- gfc_se lse, rse;
- stmtblock_t block, body;
- gfc_loopinfo loop1;
+ stmtblock_t block, body1;
+ gfc_loopinfo loop;
+ gfc_se lse;
+ gfc_se rse;
tree tmp;
tree wheremaskexpr;
- /* Walk the lhs. */
- lss = gfc_walk_expr (expr);
+ (void) rss; /* TODO: unused. */
- if (lss == gfc_ss_terminator)
- {
- gfc_start_block (&block);
+ gfc_start_block (&block);
- gfc_init_se (&lse, NULL);
+ gfc_init_se (&rse, NULL);
+ gfc_init_se (&lse, NULL);
- /* Translate the expression. */
+ if (lss == gfc_ss_terminator)
+ {
+ gfc_init_block (&body1);
gfc_conv_expr (&lse, expr);
-
- /* Form the expression for the temporary. */
- tmp = gfc_build_array_ref (tmp1, count1, NULL);
-
- /* Use the scalar assignment as is. */
- gfc_add_block_to_block (&block, &lse.pre);
- gfc_add_modify (&block, lse.expr, tmp);
- gfc_add_block_to_block (&block, &lse.post);
-
- /* Increment the count1. */
- tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
- count1, gfc_index_one_node);
- gfc_add_modify (&block, count1, tmp);
-
- tmp = gfc_finish_block (&block);
+ rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
}
else
{
- gfc_start_block (&block);
-
- gfc_init_loopinfo (&loop1);
- gfc_init_se (&rse, NULL);
- gfc_init_se (&lse, NULL);
+ /* Initialize the loop. */
+ gfc_init_loopinfo (&loop);
- /* Associate the lss with the loop. */
- gfc_add_ss_to_loop (&loop1, lss);
+ /* We may need LSS to determine the shape of the expression. */
+ gfc_add_ss_to_loop (&loop, lss);
- /* Calculate the bounds of the scalarization. */
- gfc_conv_ss_startstride (&loop1);
- /* Setup the scalarizing loops. */
- gfc_conv_loop_setup (&loop1, &expr->where);
+ gfc_conv_ss_startstride (&loop);
+ gfc_conv_loop_setup (&loop, &expr->where);
gfc_mark_ss_chain_used (lss, 1);
+ /* Start the loop body. */
+ gfc_start_scalarized_body (&loop, &body1);
- /* Start the scalarized loop body. */
- gfc_start_scalarized_body (&loop1, &body);
-
- /* Setup the gfc_se structures. */
- gfc_copy_loopinfo_to_se (&lse, &loop1);
+ /* Translate the expression. */
+ gfc_copy_loopinfo_to_se (&lse, &loop);
lse.ss = lss;
+ gfc_conv_expr (&lse, expr);
/* Form the expression of the temporary. */
- if (lss != gfc_ss_terminator)
- rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
- /* Translate expr. */
- gfc_conv_expr (&lse, expr);
+ rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
+ }
- /* Use the scalar assignment. */
- rse.string_length = lse.string_length;
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, true);
+ /* Use the scalar assignment. */
+ rse.string_length = lse.string_length;
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
+ expr->expr_type == EXPR_VARIABLE, false);
- /* Form the mask expression according to the mask tree list. */
- if (wheremask)
- {
- wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
- if (invert)
- wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
- TREE_TYPE (wheremaskexpr),
- wheremaskexpr);
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
- wheremaskexpr, tmp,
- build_empty_stmt (input_location));
- }
+ /* Form the mask expression according to the mask tree list. */
+ if (wheremask)
+ {
+ wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
+ if (invert)
+ wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
+ TREE_TYPE (wheremaskexpr),
+ wheremaskexpr);
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ wheremaskexpr, tmp,
+ build_empty_stmt (input_location));
+ }
- gfc_add_expr_to_block (&body, tmp);
+ gfc_add_expr_to_block (&body1, tmp);
- /* Increment count1. */
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- count1, gfc_index_one_node);
- gfc_add_modify (&body, count1, tmp);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
+ count1, gfc_index_one_node);
+ gfc_add_modify (&body1, count1, tmp);
+ if (lss == gfc_ss_terminator)
+ gfc_add_block_to_block (&block, &body1);
+ else
+ {
/* Increment count3. */
if (count3)
{
tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, count3,
- gfc_index_one_node);
- gfc_add_modify (&body, count3, tmp);
+ gfc_array_index_type,
+ count3, gfc_index_one_node);
+ gfc_add_modify (&body1, count3, tmp);
}
/* Generate the copying loops. */
- gfc_trans_scalarizing_loops (&loop1, &body);
- gfc_add_block_to_block (&block, &loop1.pre);
- gfc_add_block_to_block (&block, &loop1.post);
- gfc_cleanup_loop (&loop1);
+ gfc_trans_scalarizing_loops (&loop, &body1);
- tmp = gfc_finish_block (&block);
+ gfc_add_block_to_block (&block, &loop.pre);
+ gfc_add_block_to_block (&block, &loop.post);
+
+ gfc_cleanup_loop (&loop);
+ /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
+ as tree nodes in SS may not be valid in different scope. */
}
+
+ tmp = gfc_finish_block (&block);
return tmp;
}
/* Calculate the size of temporary needed in the assignment. Return loop, lss
and rss which are used in function generate_loop_for_rhs_to_temp(). */
- gfc_init_block (&inner_size_body);
- inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
- &lss, &rss);
-
/* The type of LHS. Used in function allocate_temp_for_forall_nest */
- if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->length)
+ if (expr1->ts.type == BT_CHARACTER)
{
- if (!expr1->ts.u.cl->backend_decl)
+ type = NULL;
+ if (expr1->ref && expr1->ref->type == REF_SUBSTRING)
{
- gfc_se tse;
- gfc_init_se (&tse, NULL);
- gfc_conv_expr (&tse, expr1->ts.u.cl->length);
- expr1->ts.u.cl->backend_decl = tse.expr;
+ gfc_se ssse;
+ gfc_init_se (&ssse, NULL);
+ gfc_conv_expr (&ssse, expr1);
+ type = gfc_get_character_type_len (gfc_default_character_kind,
+ ssse.string_length);
+ }
+ else
+ {
+ if (!expr1->ts.u.cl->backend_decl)
+ {
+ gfc_se tse;
+ gcc_assert (expr1->ts.u.cl->length);
+ gfc_init_se (&tse, NULL);
+ gfc_conv_expr (&tse, expr1->ts.u.cl->length);
+ expr1->ts.u.cl->backend_decl = tse.expr;
+ }
+ type = gfc_get_character_type_len (gfc_default_character_kind,
+ expr1->ts.u.cl->backend_decl);
}
- type = gfc_get_character_type_len (gfc_default_character_kind,
- expr1->ts.u.cl->backend_decl);
}
else
type = gfc_typenode_for_spec (&expr1->ts);
+ gfc_init_block (&inner_size_body);
+ inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
+ &lss, &rss);
+
/* Allocate temporary for nested forall construct according to the
information in nested_forall_info and inner_size. */
tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
if (wheremask)
gfc_add_modify (block, count, gfc_index_zero_node);
+ /* TODO: Second call to compute_inner_temp_size to initialize lss and
+ rss; there must be a better way. */
+ inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
+ &lss, &rss);
+
/* Generate codes to copy the temporary to lhs. */
tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
+ lss, rss,
wheremask, invert);
/* Generate body and loops according to the information in
/* Temporaries due to array assignment data dependencies introduce
no end of problems. */
- if (need_temp)
- gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false,
+ if (need_temp || flag_test_forall_temp)
+ gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false,
nested_forall_info, &block);
else
{
/* Pointer assignment inside FORALL. */
case EXEC_POINTER_ASSIGN:
need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
- if (need_temp)
+ /* Avoid cases where a temporary would never be needed and where
+ the temp code is guaranteed to fail. */
+ if (need_temp
+ || (flag_test_forall_temp
+ && c->expr2->expr_type != EXPR_CONSTANT
+ && c->expr2->expr_type != EXPR_NULL))
gfc_trans_pointer_assign_need_temp (c->expr1, c->expr2,
nested_forall_info, &block);
else
&inner_size_body, block);
/* Check whether the size is negative. */
- cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, size,
+ cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, size,
gfc_index_zero_node);
size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
cond, gfc_index_zero_node, size);
if (nested_forall_info != NULL)
{
need_temp = gfc_check_dependency (expr1, expr2, 0);
- if (need_temp && cnext->op != EXEC_ASSIGN_CALL)
+ if ((need_temp || flag_test_forall_temp)
+ && cnext->op != EXEC_ASSIGN_CALL)
gfc_trans_assign_need_temp (expr1, expr2,
cmask, invert,
nested_forall_info, block);
enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is;
stmtblock_t block;
stmtblock_t post;
+ stmtblock_t final_block;
tree nelems;
- bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set, is_coarray ;
+ bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set, is_coarray;
+ bool needs_caf_sync, caf_refs_comp;
gfc_symtree *newsym = NULL;
+ symbol_attribute caf_attr;
+ gfc_actual_arglist *param_list;
if (!code->ext.alloc.list)
return NULL_TREE;
expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE;
label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
e3_is = E3_UNSET;
- is_coarray = false;
+ is_coarray = needs_caf_sync = false;
gfc_init_block (&block);
gfc_init_block (&post);
+ gfc_init_block (&final_block);
/* STAT= (and maybe ERRMSG=) is present. */
if (code->expr1)
expression. */
if (code->expr3)
{
- bool vtab_needed = false, temp_var_needed = false;
+ bool vtab_needed = false, temp_var_needed = false,
+ temp_obj_created = false;
is_coarray = gfc_is_coarray (code->expr3);
+ if (code->expr3->expr_type == EXPR_FUNCTION && !code->expr3->mold
+ && (gfc_is_class_array_function (code->expr3)
+ || gfc_is_alloc_class_scalar_function (code->expr3)))
+ code->expr3->must_finalize = 1;
+
/* Figure whether we need the vtab from expr3. */
for (al = code->ext.alloc.list; !vtab_needed && al != NULL;
al = al->next)
code->expr3->ts,
false, true,
false, false);
- temp_var_needed = !VAR_P (se.expr);
+ temp_obj_created = temp_var_needed = !VAR_P (se.expr);
}
gfc_add_block_to_block (&block, &se.pre);
- gfc_add_block_to_block (&post, &se.post);
+ if (code->expr3->must_finalize)
+ gfc_add_block_to_block (&final_block, &se.post);
+ else
+ gfc_add_block_to_block (&post, &se.post);
/* Special case when string in expr3 is zero. */
if (code->expr3->ts.type == BT_CHARACTER
}
/* Deallocate any allocatable components in expressions that use a
- temporary, i.e. are not of expr-type EXPR_VARIABLE or force the
- use of a temporary, after the assignment of expr3 is completed. */
+ temporary object, i.e. are not a simple alias of to an EXPR_VARIABLE.
+ E.g. temporaries of a function call need freeing of their components
+ here. */
if ((code->expr3->ts.type == BT_DERIVED
|| code->expr3->ts.type == BT_CLASS)
- && (code->expr3->expr_type != EXPR_VARIABLE || temp_var_needed)
+ && (code->expr3->expr_type != EXPR_VARIABLE || temp_obj_created)
&& code->expr3->ts.u.derived->attr.alloc_comp)
{
tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived,
if (code->ext.alloc.ts.type != BT_CHARACTER)
expr3_esize = TYPE_SIZE_UNIT (
gfc_typenode_for_spec (&code->ext.alloc.ts));
- else
+ else if (code->ext.alloc.ts.u.cl->length != NULL)
{
gfc_expr *sz;
- gcc_assert (code->ext.alloc.ts.u.cl->length != NULL);
sz = gfc_copy_expr (code->ext.alloc.ts.u.cl->length);
gfc_init_se (&se_sz, NULL);
gfc_conv_expr (&se_sz, sz);
tmp, se_sz.expr);
expr3_esize = gfc_evaluate_now (expr3_esize, &block);
}
+ else
+ expr3_esize = NULL_TREE;
}
/* The routine gfc_trans_assignment () already implements all
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->name
+ = gfc_get_string ("%s", 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. */
needs to be provided, which is done most of the time by the
pre-evaluation step. */
nelems = NULL_TREE;
- if (expr3_len && code->expr3->ts.type == BT_CHARACTER)
- /* When al is an array, then the element size for each element
- in the array is needed, which is the product of the len and
- esize for char arrays. */
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- TREE_TYPE (expr3_esize), expr3_esize,
- fold_convert (TREE_TYPE (expr3_esize),
- expr3_len));
+ if (expr3_len && (code->expr3->ts.type == BT_CHARACTER
+ || code->expr3->ts.type == BT_CLASS))
+ {
+ /* When al is an array, then the element size for each element
+ in the array is needed, which is the product of the len and
+ esize for char arrays. For unlimited polymorphics len can be
+ zero, therefore take the maximum of len and one. */
+ tmp = fold_build2_loc (input_location, MAX_EXPR,
+ TREE_TYPE (expr3_len),
+ expr3_len, fold_convert (TREE_TYPE (expr3_len),
+ integer_one_node));
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ TREE_TYPE (expr3_esize), expr3_esize,
+ fold_convert (TREE_TYPE (expr3_esize), tmp));
+ }
else
tmp = expr3_esize;
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
polymorphic and stores a _len dependent object,
e.g., a string. */
memsz = fold_build2_loc (input_location, GT_EXPR,
- boolean_type_node, expr3_len,
+ logical_type_node, expr3_len,
build_zero_cst
(TREE_TYPE (expr3_len)));
memsz = fold_build3_loc (input_location, COND_EXPR,
/* Handle size computation of the type declared to alloc. */
memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
- if (gfc_caf_attr (expr).codimension
- && flag_coarray == GFC_FCOARRAY_LIB)
+ /* Store the caf-attributes for latter use. */
+ if (flag_coarray == GFC_FCOARRAY_LIB
+ && (caf_attr = gfc_caf_attr (expr, true, &caf_refs_comp))
+ .codimension)
{
/* Scalar allocatable components in coarray'ed derived types make
it here and are treated now. */
tree caf_decl, token;
gfc_se caf_se;
- /* Set flag, to add synchronize after the allocate. */
is_coarray = true;
+ /* Set flag, to add synchronize after the allocate. */
+ needs_caf_sync = needs_caf_sync
+ || caf_attr.coarray_comp || !caf_refs_comp;
gfc_init_se (&caf_se, NULL);
{
/* Allocating coarrays needs a sync after the allocate executed.
Set the flag to add the sync after all objects are allocated. */
- is_coarray = is_coarray || (gfc_caf_attr (expr).codimension
- && flag_coarray == GFC_FCOARRAY_LIB);
+ if (flag_coarray == GFC_FCOARRAY_LIB
+ && (caf_attr = gfc_caf_attr (expr, true, &caf_refs_comp))
+ .codimension)
+ {
+ is_coarray = true;
+ needs_caf_sync = needs_caf_sync
+ || caf_attr.coarray_comp || !caf_refs_comp;
+ }
if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE
&& expr3_len != NULL_TREE)
{
tmp = build1_v (GOTO_EXPR, label_errmsg);
parm = fold_build2_loc (input_location, NE_EXPR,
- boolean_type_node, stat,
+ logical_type_node, stat,
build_int_cst (TREE_TYPE (stat), 0));
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
gfc_unlikely (parm, PRED_FORTRAN_FAIL_ALLOC),
gfc_free_expr (rhs);
gfc_add_expr_to_block (&block, tmp);
}
+ /* Set KIND and LEN PDT components and allocate those that are
+ parameterized. */
+ else if (expr->ts.type == BT_DERIVED
+ && expr->ts.u.derived->attr.pdt_type)
+ {
+ if (code->expr3 && code->expr3->param_list)
+ param_list = code->expr3->param_list;
+ else if (expr->param_list)
+ param_list = expr->param_list;
+ else
+ param_list = expr->symtree->n.sym->param_list;
+ tmp = gfc_allocate_pdt_comp (expr->ts.u.derived, se.expr,
+ expr->rank, param_list);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ /* Ditto for CLASS expressions. */
+ else if (expr->ts.type == BT_CLASS
+ && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type)
+ {
+ if (code->expr3 && code->expr3->param_list)
+ param_list = code->expr3->param_list;
+ else if (expr->param_list)
+ param_list = expr->param_list;
+ else
+ param_list = expr->symtree->n.sym->param_list;
+ tmp = gfc_allocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived,
+ se.expr, expr->rank, param_list);
+ gfc_add_expr_to_block (&block, tmp);
+ }
else if (code->expr3 && code->expr3->mold
&& code->expr3->ts.type == BT_CLASS)
{
gfc_default_character_kind);
dlen = gfc_finish_block (&errmsg_block);
- tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
stat, build_int_cst (TREE_TYPE (stat), 0));
tmp = build3_v (COND_EXPR, tmp,
gfc_add_modify (&block, se.expr, tmp);
}
- if (is_coarray && flag_coarray == GFC_FCOARRAY_LIB)
+ if (needs_caf_sync)
{
/* Add a sync all after the allocation has been executed. */
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
gfc_add_block_to_block (&block, &se.post);
gfc_add_block_to_block (&block, &post);
+ if (code->expr3 && code->expr3->must_finalize)
+ gfc_add_block_to_block (&block, &final_block);
return gfc_finish_block (&block);
}
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
+ /* Deallocate PDT components that are parameterized. */
+ tmp = NULL;
+ if (expr->ts.type == BT_DERIVED
+ && expr->ts.u.derived->attr.pdt_type
+ && expr->symtree->n.sym->param_list)
+ tmp = gfc_deallocate_pdt_comp (expr->ts.u.derived, se.expr, expr->rank);
+ else if (expr->ts.type == BT_CLASS
+ && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type
+ && expr->symtree->n.sym->param_list)
+ tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived,
+ se.expr, expr->rank);
+
+ if (tmp)
+ gfc_add_expr_to_block (&block, tmp);
+
if (flag_coarray == GFC_FCOARRAY_LIB
|| flag_coarray == GFC_FCOARRAY_SINGLE)
{
{
tree cond;
- cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
+ cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat,
build_int_cst (TREE_TYPE (stat), 0));
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC),
slen, errmsg_str, gfc_default_character_kind);
tmp = gfc_finish_block (&errmsg_block);
- cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
+ cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat,
build_int_cst (TREE_TYPE (stat), 0));
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), tmp,
projects / gcc.git / blobdiff