|| code->label1->defined == ST_LABEL_DO_TARGET)
{
label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
- len_tree = integer_minus_one_node;
+ len_tree = build_int_cst (gfc_charlen_type_node, -1);
}
else
{
label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
}
- gfc_add_modify (&se.pre, len, len_tree);
+ gfc_add_modify (&se.pre, len, fold_convert (TREE_TYPE (len), len_tree));
gfc_add_modify (&se.pre, addr, label_tree);
return gfc_finish_block (&se.pre);
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);
}
}
+/* 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.
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. */
&& se.string_length != sym->ts.u.cl->backend_decl)
{
gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl,
- fold_convert (gfc_charlen_type_node,
+ fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
se.string_length));
}
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));
+ 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. */
gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
gfc_finish_block (&se.post));
&& se.string_length != sym->ts.u.cl->backend_decl)
{
gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl,
- fold_convert (gfc_charlen_type_node,
+ fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
se.string_length));
if (e->expr_type == EXPR_FUNCTION)
{
attr = gfc_expr_attr (e);
if (sym->ts.type == BT_CHARACTER && e->ts.type == BT_CHARACTER
- && (attr.allocatable || attr.pointer || attr.dummy))
+ && (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
{
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. */
{
for (d = cp; d; d = d->right)
{
- int i;
+ gfc_charlen_t i;
if (d->low)
{
gcc_assert (d->low->expr_type == EXPR_CONSTANT
if (d->low == NULL)
{
CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node);
- CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], integer_zero_node);
+ CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], build_zero_cst (gfc_charlen_type_node));
}
else
{
if (d->high == NULL)
{
CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node);
- CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], integer_zero_node);
+ CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], build_zero_cst (gfc_charlen_type_node));
}
else
{
/* The exit condition. */
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 = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
build_int_cst (integer_type_node,
- annot_expr_parallel_kind),
+ annot_expr_ivdep_kind),
integer_zero_node);
tmp = build1_v (GOTO_EXPR, exit_label);
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 needs_caf_sync, caf_refs_comp;
gfc_init_block (&block);
gfc_init_block (&post);
+ gfc_init_block (&final_block);
/* STAT= (and maybe ERRMSG=) is present. */
if (code->expr1)
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)
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
{
gfc_init_se (&se, NULL);
temp_var_needed = false;
- expr3_len = integer_zero_node;
+ expr3_len = build_zero_cst (gfc_charlen_type_node);
e3_is = E3_MOLD;
}
/* Prevent aliasing, i.e., se.expr may be already a
e.g., a string. */
memsz = fold_build2_loc (input_location, GT_EXPR,
logical_type_node, expr3_len,
- integer_zero_node);
+ build_zero_cst
+ (TREE_TYPE (expr3_len)));
memsz = fold_build3_loc (input_location, COND_EXPR,
TREE_TYPE (expr3_esize),
memsz, tmp, expr3_esize);
gfc_build_addr_expr (pchar_type_node,
gfc_build_localized_cstring_const (msg)));
- slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
+ slen = build_int_cst (gfc_charlen_type_node, strlen (msg));
dlen = gfc_get_expr_charlen (code->expr2);
slen = fold_build2_loc (input_location, MIN_EXPR,
TREE_TYPE (slen), dlen, slen);
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);
}
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)));
+ slen = build_int_cst (gfc_charlen_type_node, strlen (msg));
dlen = gfc_get_expr_charlen (code->expr2);
gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
projects / gcc.git / blobdiff