gfc_expr *format = code->label1->format;
label_len = format->value.character.length;
- len_tree = build_int_cst (NULL_TREE, label_len);
+ len_tree = build_int_cst (gfc_charlen_type_node, label_len);
label_tree = gfc_build_wide_string_const (format->ts.kind, label_len + 1,
format->value.character.string);
label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
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,
+ &tmp_loop, ss, temptype,
initial,
false, true, false,
&arg->expr->where);
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
+ if (gfc_option.coarray == GFC_FCOARRAY_LIB && !error_stop)
+ {
+ /* Per F2008, 8.5.1 STOP implies a SYNC MEMORY. */
+ 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);
+
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
+ gfc_add_expr_to_block (&se.pre, tmp);
+ }
+
if (code->expr1 == NULL)
{
tmp = build_int_cst (gfc_int4_type_node, 0);
tmp = build_call_expr_loc (input_location,
- error_stop ? gfor_fndecl_error_stop_string
+ error_stop
+ ? (gfc_option.coarray == GFC_FCOARRAY_LIB
+ ? gfor_fndecl_caf_error_stop_str
+ : gfor_fndecl_error_stop_string)
: gfor_fndecl_stop_string,
2, build_int_cst (pchar_type_node, 0), tmp);
}
{
gfc_conv_expr (&se, code->expr1);
tmp = build_call_expr_loc (input_location,
- error_stop ? gfor_fndecl_error_stop_numeric
+ error_stop
+ ? (gfc_option.coarray == GFC_FCOARRAY_LIB
+ ? gfor_fndecl_caf_error_stop
+ : gfor_fndecl_error_stop_numeric)
: gfor_fndecl_stop_numeric_f08, 1,
fold_convert (gfc_int4_type_node, se.expr));
}
{
gfc_conv_expr_reference (&se, code->expr1);
tmp = build_call_expr_loc (input_location,
- error_stop ? gfor_fndecl_error_stop_string
+ error_stop
+ ? (gfc_option.coarray == GFC_FCOARRAY_LIB
+ ? gfor_fndecl_caf_error_stop_str
+ : gfor_fndecl_error_stop_string)
: gfor_fndecl_stop_string,
2, se.expr, se.string_length);
}
tree
-gfc_trans_sync (gfc_code *code, gfc_exec_op type __attribute__ ((unused)))
+gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op type ATTRIBUTE_UNUSED)
{
- gfc_se se;
+ gfc_se se, argse;
+ tree stat = NULL_TREE, lock_acquired = NULL_TREE;
- if ((code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) || code->expr2)
+ /* Short cut: For single images without STAT= or LOCK_ACQUIRED
+ return early. (ERRMSG= is always untouched for -fcoarray=single.) */
+ if (!code->expr2 && !code->expr4 && gfc_option.coarray != GFC_FCOARRAY_LIB)
+ return NULL_TREE;
+
+ gfc_init_se (&se, NULL);
+ gfc_start_block (&se.pre);
+
+ if (code->expr2)
{
- gfc_init_se (&se, NULL);
- gfc_start_block (&se.pre);
+ gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr2);
+ stat = argse.expr;
+ }
+
+ if (code->expr4)
+ {
+ gcc_assert (code->expr4->expr_type == EXPR_VARIABLE);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr4);
+ lock_acquired = argse.expr;
+ }
+
+ if (stat != NULL_TREE)
+ gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
+
+ if (lock_acquired != NULL_TREE)
+ gfc_add_modify (&se.pre, lock_acquired,
+ fold_convert (TREE_TYPE (lock_acquired),
+ boolean_true_node));
+
+ return gfc_finish_block (&se.pre);
+}
+
+
+tree
+gfc_trans_sync (gfc_code *code, gfc_exec_op type)
+{
+ gfc_se se, argse;
+ tree tmp;
+ tree images = NULL_TREE, stat = NULL_TREE,
+ errmsg = NULL_TREE, errmsglen = NULL_TREE;
+
+ /* Short cut: For single images without bound checking or without STAT=,
+ return early. (ERRMSG= is always untouched for -fcoarray=single.) */
+ if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+ && gfc_option.coarray != GFC_FCOARRAY_LIB)
+ return NULL_TREE;
+
+ gfc_init_se (&se, NULL);
+ gfc_start_block (&se.pre);
+
+ if (code->expr1 && code->expr1->rank == 0)
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr1);
+ images = argse.expr;
+ }
+
+ if (code->expr2)
+ {
+ gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_val (&argse, code->expr2);
+ stat = argse.expr;
+ }
+ else
+ stat = null_pointer_node;
+
+ if (code->expr3 && gfc_option.coarray == GFC_FCOARRAY_LIB
+ && type != EXEC_SYNC_MEMORY)
+ {
+ gcc_assert (code->expr3->expr_type == EXPR_VARIABLE);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr (&argse, code->expr3);
+ gfc_conv_string_parameter (&argse);
+ errmsg = gfc_build_addr_expr (NULL, argse.expr);
+ errmsglen = argse.string_length;
+ }
+ else if (gfc_option.coarray == GFC_FCOARRAY_LIB && type != EXEC_SYNC_MEMORY)
+ {
+ errmsg = null_pointer_node;
+ errmsglen = build_int_cst (integer_type_node, 0);
}
/* Check SYNC IMAGES(imageset) for valid image index.
&& code->expr1->rank == 0)
{
tree cond;
- gfc_conv_expr (&se, code->expr1);
- cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
- se.expr, build_int_cst (TREE_TYPE (se.expr), 1));
+ if (gfc_option.coarray != GFC_FCOARRAY_LIB)
+ cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ images, build_int_cst (TREE_TYPE (images), 1));
+ else
+ {
+ tree cond2;
+ cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+ images, gfort_gvar_caf_num_images);
+ cond2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ images,
+ build_int_cst (TREE_TYPE (images), 1));
+ cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+ boolean_type_node, cond, cond2);
+ }
gfc_trans_runtime_check (true, false, cond, &se.pre,
&code->expr1->where, "Invalid image number "
"%d in SYNC IMAGES",
fold_convert (integer_type_node, se.expr));
}
- /* If STAT is present, set it to zero. */
- if (code->expr2)
+ /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
+ image control statements SYNC IMAGES and SYNC ALL. */
+ if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+ {
+ 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)
{
- gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
- gfc_conv_expr (&se, code->expr2);
- gfc_add_modify (&se.pre, se.expr, build_int_cst (TREE_TYPE (se.expr), 0));
+ /* Set STAT to zero. */
+ if (code->expr2)
+ gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
}
+ else if (type == EXEC_SYNC_ALL)
+ {
+ /* SYNC ALL => stat == null_pointer_node
+ SYNC ALL(stat=s) => stat has an integer type
- if ((code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) || code->expr2)
- return gfc_finish_block (&se.pre);
-
- return NULL_TREE;
+ If "stat" has the wrong integer type, use a temp variable of
+ the right type and later cast the result back into "stat". */
+ if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
+ {
+ if (TREE_TYPE (stat) == integer_type_node)
+ stat = gfc_build_addr_expr (NULL, stat);
+
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
+ 3, stat, errmsg, errmsglen);
+ gfc_add_expr_to_block (&se.pre, tmp);
+ }
+ else
+ {
+ tree tmp_stat = gfc_create_var (integer_type_node, "stat");
+
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
+ 3, gfc_build_addr_expr (NULL, tmp_stat),
+ errmsg, errmsglen);
+ gfc_add_expr_to_block (&se.pre, tmp);
+
+ gfc_add_modify (&se.pre, stat,
+ fold_convert (TREE_TYPE (stat), tmp_stat));
+ }
+ }
+ else
+ {
+ tree len;
+
+ gcc_assert (type == EXEC_SYNC_IMAGES);
+
+ if (!code->expr1)
+ {
+ len = build_int_cst (integer_type_node, -1);
+ images = null_pointer_node;
+ }
+ else if (code->expr1->rank == 0)
+ {
+ len = build_int_cst (integer_type_node, 1);
+ images = gfc_build_addr_expr (NULL_TREE, images);
+ }
+ else
+ {
+ /* FIXME. */
+ if (code->expr1->ts.kind != gfc_c_int_kind)
+ gfc_fatal_error ("Sorry, only support for integer kind %d "
+ "implemented for image-set at %L",
+ gfc_c_int_kind, &code->expr1->where);
+
+ gfc_conv_array_parameter (&se, code->expr1,
+ gfc_walk_expr (code->expr1), true, NULL,
+ NULL, &len);
+ images = se.expr;
+
+ tmp = gfc_typenode_for_spec (&code->expr1->ts);
+ if (GFC_ARRAY_TYPE_P (tmp) || GFC_DESCRIPTOR_TYPE_P (tmp))
+ tmp = gfc_get_element_type (tmp);
+
+ len = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+ TREE_TYPE (len), len,
+ fold_convert (TREE_TYPE (len),
+ TYPE_SIZE_UNIT (tmp)));
+ len = fold_convert (integer_type_node, len);
+ }
+
+ /* SYNC IMAGES(imgs) => stat == null_pointer_node
+ SYNC IMAGES(imgs,stat=s) => stat has an integer type
+
+ If "stat" has the wrong integer type, use a temp variable of
+ the right type and later cast the result back into "stat". */
+ if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
+ {
+ if (TREE_TYPE (stat) == integer_type_node)
+ stat = gfc_build_addr_expr (NULL, stat);
+
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
+ 5, fold_convert (integer_type_node, len),
+ images, stat, errmsg, errmsglen);
+ gfc_add_expr_to_block (&se.pre, tmp);
+ }
+ else
+ {
+ tree tmp_stat = gfc_create_var (integer_type_node, "stat");
+
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
+ 5, fold_convert (integer_type_node, len),
+ images, gfc_build_addr_expr (NULL, tmp_stat),
+ errmsg, errmsglen);
+ gfc_add_expr_to_block (&se.pre, tmp);
+
+ gfc_add_modify (&se.pre, stat,
+ fold_convert (TREE_TYPE (stat), tmp_stat));
+ }
+ }
+
+ return gfc_finish_block (&se.pre);
}
{
gfc_se if_se;
tree stmt, elsestmt;
+ locus saved_loc;
location_t loc;
/* Check for an unconditional ELSE clause. */
gfc_start_block (&if_se.pre);
/* Calculate the IF condition expression. */
+ if (code->expr1->where.lb)
+ {
+ gfc_save_backend_locus (&saved_loc);
+ gfc_set_backend_locus (&code->expr1->where);
+ }
+
gfc_conv_expr_val (&if_se, code->expr1);
+ if (code->expr1->where.lb)
+ gfc_restore_backend_locus (&saved_loc);
+
/* Translate the THEN clause. */
stmt = gfc_trans_code (code->next);
tree tmp;
gfc_start_block (&block);
+
+ if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+ {
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_critical, 0);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
tmp = gfc_trans_code (code->block->next);
gfc_add_expr_to_block (&block, tmp);
+ if (gfc_option.coarray == GFC_FCOARRAY_LIB)
+ {
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_end_critical,
+ 0);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
+
return gfc_finish_block (&block);
}
/* Add this case label.
Add parameter 'label', make it match GCC backend. */
- tmp = fold_build3_loc (input_location, CASE_LABEL_EXPR,
- void_type_node, low, high, label);
+ tmp = build_case_label (low, high, label);
gfc_add_expr_to_block (&body, tmp);
}
/* Add this case label.
Add parameter 'label', make it match GCC backend. */
- tmp = fold_build3_loc (input_location, CASE_LABEL_EXPR,
- void_type_node, low, high, label);
+ tmp = build_case_label (low, high, label);
gfc_add_expr_to_block (&body, tmp);
}
for (d = c->ext.block.case_list; d; d = d->next)
{
label = gfc_build_label_decl (NULL_TREE);
- tmp = fold_build3_loc (input_location, CASE_LABEL_EXPR,
- void_type_node,
- (d->low == NULL && d->high == NULL)
- ? NULL : build_int_cst (NULL_TREE, d->n),
- NULL, label);
+ tmp = build_case_label ((d->low == NULL && d->high == NULL)
+ ? NULL
+ : build_int_cst (integer_type_node, d->n),
+ NULL, label);
gfc_add_expr_to_block (&body, tmp);
}
}
type = build_array_type (select_struct[k],
- build_index_type (build_int_cst (NULL_TREE, n-1)));
+ build_index_type (size_int (n-1)));
init = build_constructor (type, inits);
TREE_CONSTANT (init) = 1;
gcc_unreachable ();
tmp = build_call_expr_loc (input_location,
- fndecl, 4, init, build_int_cst (NULL_TREE, n),
+ fndecl, 4, init,
+ build_int_cst (gfc_charlen_type_node, n),
expr1se.expr, expr1se.string_length);
case_num = gfc_create_var (integer_type_node, "case_num");
gfc_add_modify (&block, case_num, tmp);
{
forall_restore_symtree (c->expr1);
forall_restore_symtree (c->expr2);
- gfc_free (new_symtree->n.sym);
- gfc_free (new_symtree);
+ free (new_symtree->n.sym);
+ free (new_symtree);
}
/* 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);
count = gfc_create_var (gfc_array_index_type, "count");
gfc_add_modify (block, count, gfc_index_zero_node);
- inner_size = integer_one_node;
+ inner_size = gfc_index_one_node;
lss = gfc_walk_expr (expr1);
rss = gfc_walk_expr (expr2);
if (lss == gfc_ss_terminator)
tree maskindex;
tree mask;
tree pmask;
+ tree cycle_label = NULL_TREE;
int n;
int nvar;
int need_temp;
nvar = n;
/* Allocate the space for var, start, end, step, varexpr. */
- var = (tree *) gfc_getmem (nvar * sizeof (tree));
- start = (tree *) gfc_getmem (nvar * sizeof (tree));
- end = (tree *) gfc_getmem (nvar * sizeof (tree));
- step = (tree *) gfc_getmem (nvar * sizeof (tree));
- varexpr = (gfc_expr **) gfc_getmem (nvar * sizeof (gfc_expr *));
- saved_vars = (gfc_saved_var *) gfc_getmem (nvar * sizeof (gfc_saved_var));
+ var = XCNEWVEC (tree, nvar);
+ start = XCNEWVEC (tree, nvar);
+ end = XCNEWVEC (tree, nvar);
+ step = XCNEWVEC (tree, nvar);
+ varexpr = XCNEWVEC (gfc_expr *, nvar);
+ saved_vars = XCNEWVEC (gfc_saved_var, nvar);
/* Allocate the space for info. */
- info = (forall_info *) gfc_getmem (sizeof (forall_info));
+ info = XCNEW (forall_info);
gfc_start_block (&pre);
gfc_init_block (&post);
gfc_symbol *sym = fa->var->symtree->n.sym;
/* Allocate space for this_forall. */
- this_forall = (iter_info *) gfc_getmem (sizeof (iter_info));
+ this_forall = XCNEW (iter_info);
/* Create a temporary variable for the FORALL index. */
tmp = gfc_typenode_for_spec (&sym->ts);
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]);
/* Free the space for var, start, end, step, varexpr. */
- gfc_free (var);
- gfc_free (start);
- gfc_free (end);
- gfc_free (step);
- gfc_free (varexpr);
- gfc_free (saved_vars);
+ free (var);
+ free (start);
+ free (end);
+ free (step);
+ free (varexpr);
+ free (saved_vars);
for (this_forall = info->this_loop; this_forall;)
{
iter_info *next = this_forall->next;
- gfc_free (this_forall);
+ free (this_forall);
this_forall = next;
}
/* Free the space for this forall_info. */
- gfc_free (info);
+ free (info);
if (pmask)
{
}
+/* 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
/* 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->where = 1;
}
/* Associate the SS with the loop. */
tsss = gfc_walk_expr (tsrc);
if (tsss == gfc_ss_terminator)
{
- tsss = gfc_get_ss ();
+ tsss = gfc_get_scalar_ss (gfc_ss_terminator, tsrc);
tsss->where = 1;
- tsss->next = gfc_ss_terminator;
- tsss->type = GFC_SS_SCALAR;
- tsss->expr = tsrc;
}
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 = gfc_get_scalar_ss (gfc_ss_terminator, esrc);
esss->where = 1;
- esss->next = gfc_ss_terminator;
- esss->type = GFC_SS_SCALAR;
- esss->expr = esrc;
}
gfc_add_ss_to_loop (&loop, edss);
gfc_add_ss_to_loop (&loop, esss);
tree tmp;
tree parm;
tree stat;
- tree pstat;
- tree error_label;
+ tree errmsg;
+ tree errlen;
+ tree label_errmsg;
+ tree label_finish;
tree memsz;
+ tree expr3;
+ tree slen3;
stmtblock_t block;
+ stmtblock_t post;
+ gfc_expr *sz;
+ gfc_se se_sz;
if (!code->ext.alloc.list)
return NULL_TREE;
- pstat = stat = error_label = tmp = memsz = NULL_TREE;
+ stat = tmp = memsz = NULL_TREE;
+ label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
- gfc_start_block (&block);
+ gfc_init_block (&block);
+ gfc_init_block (&post);
- /* Either STAT= and/or ERRMSG is present. */
- if (code->expr1 || code->expr2)
+ /* STAT= (and maybe ERRMSG=) is present. */
+ if (code->expr1)
{
+ /* STAT=. */
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);
- error_label = gfc_build_label_decl (NULL_TREE);
- TREE_USED (error_label) = 1;
+ /* ERRMSG= only makes sense with STAT=. */
+ if (code->expr2)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_lhs (&se, code->expr2);
+
+ errlen = gfc_get_expr_charlen (code->expr2);
+ errmsg = gfc_build_addr_expr (pchar_type_node, se.expr);
+ }
+ else
+ {
+ errmsg = null_pointer_node;
+ errlen = build_int_cst (gfc_charlen_type_node, 0);
+ }
+
+ /* 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;
}
+ expr3 = NULL_TREE;
+ slen3 = NULL_TREE;
+
for (al = code->ext.alloc.list; al != NULL; al = al->next)
{
expr = gfc_copy_expr (al->expr);
gfc_add_data_component (expr);
gfc_init_se (&se, NULL);
- gfc_start_block (&se.pre);
se.want_pointer = 1;
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
- if (!gfc_array_allocate (&se, expr, pstat))
+ if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
{
/* A scalar or derived type. */
{
if (code->expr3->ts.type == BT_CLASS)
{
- gfc_expr *sz;
- gfc_se se_sz;
sz = gfc_copy_expr (code->expr3);
gfc_add_vptr_component (sz);
gfc_add_size_component (sz);
if (!code->expr3->ts.u.cl->backend_decl)
{
/* Convert and use the length expression. */
- gfc_se se_sz;
gfc_init_se (&se_sz, NULL);
if (code->expr3->expr_type == EXPR_VARIABLE
|| code->expr3->expr_type == EXPR_CONSTANT)
{
gfc_conv_expr (&se_sz, code->expr3);
+ gfc_add_block_to_block (&se.pre, &se_sz.pre);
+ se_sz.string_length
+ = gfc_evaluate_now (se_sz.string_length, &se.pre);
+ gfc_add_block_to_block (&se.pre, &se_sz.post);
memsz = se_sz.string_length;
}
- else
+ else if (code->expr3->mold
+ && code->expr3->ts.u.cl
+ && code->expr3->ts.u.cl->length)
{
- gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
+ gfc_conv_expr (&se_sz, code->expr3->ts.u.cl->length);
+ gfc_add_block_to_block (&se.pre, &se_sz.pre);
+ se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
+ gfc_add_block_to_block (&se.pre, &se_sz.post);
memsz = se_sz.expr;
}
- if (TREE_CODE (se.string_length) == VAR_DECL)
- gfc_add_modify (&block, se.string_length,
- fold_convert (TREE_TYPE (se.string_length),
- memsz));
+ else
+ {
+ /* This is would be inefficient and possibly could
+ generate wrong code if the result were not stored
+ in expr3/slen3. */
+ if (slen3 == NULL_TREE)
+ {
+ gfc_conv_expr (&se_sz, code->expr3);
+ gfc_add_block_to_block (&se.pre, &se_sz.pre);
+ expr3 = gfc_evaluate_now (se_sz.expr, &se.pre);
+ gfc_add_block_to_block (&post, &se_sz.post);
+ slen3 = gfc_evaluate_now (se_sz.string_length,
+ &se.pre);
+ }
+ memsz = slen3;
+ }
}
else
/* Otherwise use the stored string length. */
/* Store the string length. */
if (tmp && TREE_CODE (tmp) == VAR_DECL)
- gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp),
+ gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
memsz));
/* Convert to size in bytes, using the character KIND. */
TREE_TYPE (tmp), tmp,
fold_convert (TREE_TYPE (tmp), memsz));
}
+ else if (al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred)
+ {
+ gcc_assert (code->ext.alloc.ts.u.cl && code->ext.alloc.ts.u.cl->length);
+ gfc_init_se (&se_sz, NULL);
+ gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
+ gfc_add_block_to_block (&se.pre, &se_sz.pre);
+ se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
+ gfc_add_block_to_block (&se.pre, &se_sz.post);
+ /* Store the string length. */
+ tmp = al->expr->ts.u.cl->backend_decl;
+ gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
+ se_sz.expr));
+ tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
+ tmp = TYPE_SIZE_UNIT (tmp);
+ memsz = fold_build2_loc (input_location, MULT_EXPR,
+ TREE_TYPE (tmp), tmp,
+ fold_convert (TREE_TYPE (se_sz.expr),
+ se_sz.expr));
+ }
else if (code->ext.alloc.ts.type != BT_UNKNOWN)
memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
else
if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE)
{
- if (expr->ts.deferred)
- {
- gfc_se se_sz;
- gfc_init_se (&se_sz, NULL);
- gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
- memsz = se_sz.expr;
- gfc_add_modify (&block, se.string_length,
- fold_convert (TREE_TYPE (se.string_length),
- memsz));
- }
- else
- memsz = se.string_length;
+ memsz = se.string_length;
+
/* Convert to size in bytes, using the character KIND. */
tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
tmp = TYPE_SIZE_UNIT (tmp);
TREE_TYPE (tmp), tmp,
fold_convert (TREE_TYPE (tmp), memsz));
}
- /* Allocate - for non-pointers with re-alloc checking. */
- {
- gfc_ref *ref;
- bool allocatable;
-
- ref = expr->ref;
-
- /* Find the last reference in the chain. */
- while (ref && ref->next != NULL)
- {
- gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
- ref = ref->next;
- }
-
- if (!ref)
- allocatable = expr->symtree->n.sym->attr.allocatable;
- else
- allocatable = ref->u.c.component->attr.allocatable;
-
- if (allocatable)
- tmp = gfc_allocate_array_with_status (&se.pre, se.expr, memsz,
- pstat, expr);
- else
- tmp = gfc_allocate_with_status (&se.pre, memsz, pstat);
- }
-
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
- se.expr,
- fold_convert (TREE_TYPE (se.expr), tmp));
- gfc_add_expr_to_block (&se.pre, tmp);
- if (code->expr1 || code->expr2)
- {
- tmp = build1_v (GOTO_EXPR, error_label);
- 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,
- parm, tmp,
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&se.pre, tmp);
- }
+ /* 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);
+ else
+ gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
{
tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
gfc_add_expr_to_block (&se.pre, tmp);
}
-
}
- tmp = gfc_finish_block (&se.pre);
- gfc_add_expr_to_block (&block, 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);
+ 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,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
if (code->expr3 && !code->expr3->mold)
{
/* Initialization via SOURCE block
gfc_add_block_to_block (&call.pre, &call.post);
tmp = gfc_finish_block (&call.pre);
}
+ else if (expr3 != NULL_TREE)
+ {
+ tmp = build_fold_indirect_ref_loc (input_location, se.expr);
+ gfc_trans_string_copy (&block, slen3, tmp, code->expr3->ts.kind,
+ slen3, expr3, code->expr3->ts.kind);
+ tmp = NULL_TREE;
+ }
else
- tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
- rhs, false, false);
+ {
+ /* Switch off automatic reallocation since we have just done
+ the ALLOCATE. */
+ int realloc_lhs = gfc_option.flag_realloc_lhs;
+ gfc_option.flag_realloc_lhs = 0;
+ tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
+ rhs, false, false);
+ gfc_option.flag_realloc_lhs = realloc_lhs;
+ }
gfc_free_expr (rhs);
gfc_add_expr_to_block (&block, tmp);
}
}
- /* STAT block. */
+ /* STAT (ERRMSG only makes sense with STAT). */
if (code->expr1)
{
- tmp = build1_v (LABEL_EXPR, error_label);
+ tmp = build1_v (LABEL_EXPR, label_errmsg);
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_add_modify (&block, se.expr, tmp);
}
/* ERRMSG block. */
{
/* A better error message may be possible, but not required. */
const char *msg = "Attempt to allocate an allocated object";
- tree errmsg, slen, dlen;
+ tree slen, dlen;
gfc_init_se (&se, NULL);
gfc_conv_expr_lhs (&se, code->expr2);
slen);
dlen = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMCPY], 3,
+ builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen);
tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
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)
+ {
+ 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);
+ }
+
+ gfc_add_block_to_block (&block, &se.post);
+ gfc_add_block_to_block (&block, &post);
+
return gfc_finish_block (&block);
}
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
- if (expr->rank)
+ if (expr->rank || gfc_expr_attr (expr).codimension)
{
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
{
slen);
dlen = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMCPY], 3,
+ builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen);
tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, astat,
OSDN Git Service
