/* Statement translation -- generate GCC trees from gfc_code.
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
#include "system.h"
#include "coretypes.h"
#include "tree.h"
-#include "tree-gimple.h"
+#include "gimple.h"
#include "ggc.h"
#include "toplev.h"
#include "real.h"
tree len;
tree addr;
tree len_tree;
- char *label_str;
int label_len;
/* Start a new block. */
}
else
{
- label_len = code->label->format->value.character.length;
- label_str
- = gfc_widechar_to_char (code->label->format->value.character.string,
- label_len);
+ gfc_expr *format = code->label->format;
+
+ label_len = format->value.character.length;
len_tree = build_int_cst (NULL_TREE, label_len);
- label_tree = gfc_build_string_const (label_len + 1, label_str);
+ 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);
- gfc_free (label_str);
}
- gfc_add_modify_expr (&se.pre, len, len_tree);
- gfc_add_modify_expr (&se.pre, addr, label_tree);
+ gfc_add_modify (&se.pre, len, len_tree);
+ gfc_add_modify (&se.pre, addr, label_tree);
return gfc_finish_block (&se.pre);
}
tmp = GFC_DECL_STRING_LEN (se.expr);
tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
build_int_cst (TREE_TYPE (tmp), -1));
- gfc_trans_runtime_check (tmp, &se.pre, &loc,
+ gfc_trans_runtime_check (true, false, tmp, &se.pre, &loc,
"Assigned label is not a target label");
assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
code = code->block;
}
while (code != NULL);
- gfc_trans_runtime_check (boolean_true_node, &se.pre, &loc,
+ gfc_trans_runtime_check (true, false, boolean_true_node, &se.pre, &loc,
"Assigned label is not in the list");
return gfc_finish_block (&se.pre);
can be used, as is, to copy the result back to the variable. */
static void
gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
- gfc_symbol * sym, gfc_actual_arglist * arg)
+ gfc_symbol * sym, gfc_actual_arglist * arg,
+ gfc_dep_check check_variable)
{
gfc_actual_arglist *arg0;
gfc_expr *e;
&& e->rank && fsym
&& fsym->attr.intent != INTENT_IN
&& gfc_check_fncall_dependency (e, fsym->attr.intent,
- sym, arg0))
+ sym, arg0, check_variable))
{
+ tree initial;
+ stmtblock_t temp_post;
+
/* 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.order[n] = loopse->loop->order[n];
}
+ /* Obtain the argument descriptor for unpacking. */
+ gfc_init_se (&parmse, NULL);
+ parmse.want_pointer = 1;
+ gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e));
+ gfc_add_block_to_block (&se->pre, &parmse.pre);
+
+ /* If we've got INTENT(INOUT), initialize the array temporary with
+ a copy of the values. */
+ if (fsym->attr.intent == INTENT_INOUT)
+ initial = parmse.expr;
+ else
+ initial = NULL_TREE;
+
/* Generate the temporary. Merge the block so that the
- declarations are put at the right binding level. */
+ declarations are put at the right binding level. Cleaning up the
+ temporary should be the very last thing done, so we add the code to
+ a new block and add it to se->post as last instructions. */
size = gfc_create_var (gfc_array_index_type, NULL);
data = gfc_create_var (pvoid_type_node, NULL);
gfc_start_block (&block);
+ gfc_init_block (&temp_post);
tmp = gfc_typenode_for_spec (&e->ts);
- tmp = gfc_trans_create_temp_array (&se->pre, &se->post,
- &tmp_loop, info, tmp,
- false, true, false);
- gfc_add_modify_expr (&se->pre, size, tmp);
+ tmp = gfc_trans_create_temp_array (&se->pre, &temp_post,
+ &tmp_loop, info, tmp,
+ initial,
+ false, true, false,
+ &arg->expr->where);
+ gfc_add_modify (&se->pre, size, tmp);
tmp = fold_convert (pvoid_type_node, info->data);
- gfc_add_modify_expr (&se->pre, data, tmp);
+ gfc_add_modify (&se->pre, data, tmp);
gfc_merge_block_scope (&block);
- /* Obtain the argument descriptor for unpacking. */
- gfc_init_se (&parmse, NULL);
- parmse.want_pointer = 1;
- gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e));
- gfc_add_block_to_block (&se->pre, &parmse.pre);
-
/* Calculate the offset for the temporary. */
offset = gfc_index_zero_node;
for (n = 0; n < info->dimen; n++)
offset, tmp);
}
info->offset = gfc_create_var (gfc_array_index_type, NULL);
- gfc_add_modify_expr (&se->pre, info->offset, offset);
+ gfc_add_modify (&se->pre, info->offset, offset);
/* Copy the result back using unpack. */
tmp = build_call_expr (gfor_fndecl_in_unpack, 2, parmse.expr, data);
gfc_add_expr_to_block (&se->post, tmp);
+ gfc_add_block_to_block (&se->pre, &parmse.pre);
gfc_add_block_to_block (&se->post, &parmse.post);
+ gfc_add_block_to_block (&se->post, &temp_post);
}
}
}
gfc_se se;
gfc_ss * ss;
int has_alternate_specifier;
+ gfc_dep_check check_variable;
/* A CALL starts a new block because the actual arguments may have to
be evaluated first. */
se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
if (sym->backend_decl == NULL)
sym->backend_decl = gfc_get_symbol_decl (sym);
- gfc_add_modify_expr (&se.pre, sym->backend_decl, se.expr);
+ gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
}
else
gfc_add_expr_to_block (&se.pre, se.expr);
stmtblock_t body;
stmtblock_t block;
gfc_se loopse;
+ gfc_se depse;
/* gfc_walk_elemental_function_args renders the ss chain in the
- reverse order to the actual argument order. */
+ reverse order to the actual argument order. */
ss = gfc_reverse_ss (ss);
/* Initialize the loop. */
gfc_add_ss_to_loop (&loop, ss);
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop);
+ /* TODO: gfc_conv_loop_setup generates a temporary for vector
+ 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->expr->where);
gfc_mark_ss_chain_used (ss, 1);
/* Convert the arguments, checking for dependencies. */
/* For operator assignment, do dependency checking. */
if (dependency_check)
- {
- gfc_symbol *sym;
- sym = code->resolved_sym;
- gfc_conv_elemental_dependencies (&se, &loopse, sym,
- code->ext.actual);
- }
+ check_variable = ELEM_CHECK_VARIABLE;
+ else
+ check_variable = ELEM_DONT_CHECK_VARIABLE;
+
+ gfc_init_se (&depse, NULL);
+ gfc_conv_elemental_dependencies (&depse, &loopse, code->resolved_sym,
+ code->ext.actual, check_variable);
+
+ gfc_add_block_to_block (&loop.pre, &depse.pre);
+ gfc_add_block_to_block (&loop.post, &depse.post);
/* Generate the loop body. */
gfc_start_scalarized_body (&loop, &body);
type = TREE_TYPE (dovar);
/* Initialize the DO variable: dovar = from. */
- gfc_add_modify_expr (pblock, dovar, from);
+ gfc_add_modify (pblock, dovar, from);
/* Cycle and exit statements are implemented with gotos. */
cycle_label = gfc_build_label_decl (NULL_TREE);
/* Increment the loop variable. */
tmp = fold_build2 (PLUS_EXPR, type, dovar, step);
- gfc_add_modify_expr (&body, dovar, tmp);
+ gfc_add_modify (&body, dovar, tmp);
/* The loop exit. */
tmp = build1_v (GOTO_EXPR, exit_label);
tree from;
tree to;
tree step;
- tree empty;
tree countm1;
tree type;
tree utype;
&& (integer_onep (step)
|| tree_int_cst_equal (step, integer_minus_one_node)))
return gfc_trans_simple_do (code, &block, dovar, from, to, step);
-
- /* We need a special check for empty loops:
- empty = (step > 0 ? to < from : to > from); */
+
pos_step = fold_build2 (GT_EXPR, boolean_type_node, step,
fold_convert (type, integer_zero_node));
- empty = fold_build3 (COND_EXPR, boolean_type_node, pos_step,
- fold_build2 (LT_EXPR, boolean_type_node, to, from),
- fold_build2 (GT_EXPR, boolean_type_node, to, from));
- /* Initialize loop count. This code is executed before we enter the
- loop body. We generate: countm1 = abs(to - from) / abs(step). */
if (TREE_CODE (type) == INTEGER_TYPE)
- {
- tree ustep;
+ utype = unsigned_type_for (type);
+ else
+ utype = unsigned_type_for (gfc_array_index_type);
+ countm1 = gfc_create_var (utype, "countm1");
+
+ /* Cycle and exit statements are implemented with gotos. */
+ cycle_label = gfc_build_label_decl (NULL_TREE);
+ exit_label = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (exit_label) = 1;
- utype = unsigned_type_for (type);
+ /* Initialize the DO variable: dovar = from. */
+ gfc_add_modify (&block, dovar, from);
- /* tmp = abs(to - from) / abs(step) */
- ustep = fold_convert (utype, fold_build1 (ABS_EXPR, type, step));
- tmp = fold_build3 (COND_EXPR, type, pos_step,
- fold_build2 (MINUS_EXPR, type, to, from),
- fold_build2 (MINUS_EXPR, type, from, to));
- tmp = fold_build2 (TRUNC_DIV_EXPR, utype, fold_convert (utype, tmp),
- ustep);
+ /* Initialize loop count and jump to exit label if the loop is empty.
+ This code is executed before we enter the loop body. We generate:
+ if (step > 0)
+ {
+ if (to < from) goto exit_label;
+ countm1 = (to - from) / step;
+ }
+ else
+ {
+ if (to > from) goto exit_label;
+ countm1 = (from - to) / -step;
+ } */
+ if (TREE_CODE (type) == INTEGER_TYPE)
+ {
+ tree pos, neg;
+
+ tmp = fold_build2 (LT_EXPR, boolean_type_node, to, from);
+ pos = fold_build3 (COND_EXPR, void_type_node, tmp,
+ build1_v (GOTO_EXPR, exit_label),
+ build_empty_stmt ());
+ tmp = fold_build2 (MINUS_EXPR, type, to, from);
+ tmp = fold_convert (utype, tmp);
+ tmp = fold_build2 (TRUNC_DIV_EXPR, utype, tmp,
+ fold_convert (utype, step));
+ tmp = build2 (MODIFY_EXPR, void_type_node, countm1, tmp);
+ pos = build2 (COMPOUND_EXPR, void_type_node, pos, tmp);
+
+ tmp = fold_build2 (GT_EXPR, boolean_type_node, to, from);
+ neg = fold_build3 (COND_EXPR, void_type_node, tmp,
+ build1_v (GOTO_EXPR, exit_label),
+ build_empty_stmt ());
+ tmp = fold_build2 (MINUS_EXPR, type, from, to);
+ tmp = fold_convert (utype, tmp);
+ tmp = fold_build2 (TRUNC_DIV_EXPR, utype, tmp,
+ fold_convert (utype, fold_build1 (NEGATE_EXPR,
+ type, step)));
+ tmp = build2 (MODIFY_EXPR, void_type_node, countm1, tmp);
+ neg = build2 (COMPOUND_EXPR, void_type_node, neg, tmp);
+
+ tmp = fold_build3 (COND_EXPR, void_type_node, pos_step, pos, neg);
+ gfc_add_expr_to_block (&block, tmp);
}
else
{
/* TODO: We could use the same width as the real type.
This would probably cause more problems that it solves
when we implement "long double" types. */
- utype = unsigned_type_for (gfc_array_index_type);
+
tmp = fold_build2 (MINUS_EXPR, type, to, from);
tmp = fold_build2 (RDIV_EXPR, type, tmp, step);
tmp = fold_build1 (FIX_TRUNC_EXPR, utype, tmp);
+ gfc_add_modify (&block, countm1, tmp);
+
+ /* We need a special check for empty loops:
+ empty = (step > 0 ? to < from : to > from); */
+ tmp = fold_build3 (COND_EXPR, boolean_type_node, pos_step,
+ fold_build2 (LT_EXPR, boolean_type_node, to, from),
+ fold_build2 (GT_EXPR, boolean_type_node, to, from));
+ /* If the loop is empty, go directly to the exit label. */
+ tmp = fold_build3 (COND_EXPR, void_type_node, tmp,
+ build1_v (GOTO_EXPR, exit_label),
+ build_empty_stmt ());
+ gfc_add_expr_to_block (&block, tmp);
}
- countm1 = gfc_create_var (utype, "countm1");
- gfc_add_modify_expr (&block, countm1, tmp);
-
- /* Cycle and exit statements are implemented with gotos. */
- cycle_label = gfc_build_label_decl (NULL_TREE);
- exit_label = gfc_build_label_decl (NULL_TREE);
- TREE_USED (exit_label) = 1;
-
- /* Initialize the DO variable: dovar = from. */
- gfc_add_modify_expr (&block, dovar, from);
-
- /* If the loop is empty, go directly to the exit label. */
- tmp = fold_build3 (COND_EXPR, void_type_node, empty,
- build1_v (GOTO_EXPR, exit_label), build_empty_stmt ());
- gfc_add_expr_to_block (&block, tmp);
/* Loop body. */
gfc_start_block (&body);
/* Increment the loop variable. */
tmp = fold_build2 (PLUS_EXPR, type, dovar, step);
- gfc_add_modify_expr (&body, dovar, tmp);
+ gfc_add_modify (&body, dovar, tmp);
/* End with the loop condition. Loop until countm1 == 0. */
cond = fold_build2 (EQ_EXPR, boolean_type_node, countm1,
/* Decrement the loop count. */
tmp = fold_build2 (MINUS_EXPR, utype, countm1, build_int_cst (utype, 1));
- gfc_add_modify_expr (&body, countm1, tmp);
+ gfc_add_modify (&body, countm1, tmp);
/* End of loop body. */
tmp = gfc_finish_block (&body);
static tree
gfc_trans_character_select (gfc_code *code)
{
- tree init, node, end_label, tmp, type, case_num, label;
+ tree init, node, end_label, tmp, type, case_num, label, fndecl;
stmtblock_t block, body;
gfc_case *cp, *d;
gfc_code *c;
gfc_se se;
- int n;
+ int n, k;
+
+ /* The jump table types are stored in static variables to avoid
+ constructing them from scratch every single time. */
+ static tree select_struct[2];
+ static tree ss_string1[2], ss_string1_len[2];
+ static tree ss_string2[2], ss_string2_len[2];
+ static tree ss_target[2];
- static tree select_struct;
- static tree ss_string1, ss_string1_len;
- static tree ss_string2, ss_string2_len;
- static tree ss_target;
+ tree pchartype = gfc_get_pchar_type (code->expr->ts.kind);
+
+ if (code->expr->ts.kind == 1)
+ k = 0;
+ else if (code->expr->ts.kind == 4)
+ k = 1;
+ else
+ gcc_unreachable ();
- if (select_struct == NULL)
+ if (select_struct[k] == NULL)
{
- tree gfc_int4_type_node = gfc_get_int_type (4);
+ select_struct[k] = make_node (RECORD_TYPE);
- select_struct = make_node (RECORD_TYPE);
- TYPE_NAME (select_struct) = get_identifier ("_jump_struct");
+ if (code->expr->ts.kind == 1)
+ TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1");
+ else if (code->expr->ts.kind == 4)
+ TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4");
+ else
+ gcc_unreachable ();
#undef ADD_FIELD
-#define ADD_FIELD(NAME, TYPE) \
- ss_##NAME = gfc_add_field_to_struct \
- (&(TYPE_FIELDS (select_struct)), select_struct, \
+#define ADD_FIELD(NAME, TYPE) \
+ ss_##NAME[k] = gfc_add_field_to_struct \
+ (&(TYPE_FIELDS (select_struct[k])), select_struct[k], \
get_identifier (stringize(NAME)), TYPE)
- ADD_FIELD (string1, pchar_type_node);
- ADD_FIELD (string1_len, gfc_int4_type_node);
+ ADD_FIELD (string1, pchartype);
+ ADD_FIELD (string1_len, gfc_charlen_type_node);
- ADD_FIELD (string2, pchar_type_node);
- ADD_FIELD (string2_len, gfc_int4_type_node);
+ ADD_FIELD (string2, pchartype);
+ ADD_FIELD (string2_len, gfc_charlen_type_node);
ADD_FIELD (target, integer_type_node);
#undef ADD_FIELD
- gfc_finish_type (select_struct);
+ gfc_finish_type (select_struct[k]);
}
cp = code->block->ext.case_list;
if (d->low == NULL)
{
- node = tree_cons (ss_string1, null_pointer_node, node);
- node = tree_cons (ss_string1_len, integer_zero_node, node);
+ node = tree_cons (ss_string1[k], null_pointer_node, node);
+ node = tree_cons (ss_string1_len[k], integer_zero_node, node);
}
else
{
gfc_conv_expr_reference (&se, d->low);
- node = tree_cons (ss_string1, se.expr, node);
- node = tree_cons (ss_string1_len, se.string_length, node);
+ node = tree_cons (ss_string1[k], se.expr, node);
+ node = tree_cons (ss_string1_len[k], se.string_length, node);
}
if (d->high == NULL)
{
- node = tree_cons (ss_string2, null_pointer_node, node);
- node = tree_cons (ss_string2_len, integer_zero_node, node);
+ node = tree_cons (ss_string2[k], null_pointer_node, node);
+ node = tree_cons (ss_string2_len[k], integer_zero_node, node);
}
else
{
gfc_init_se (&se, NULL);
gfc_conv_expr_reference (&se, d->high);
- node = tree_cons (ss_string2, se.expr, node);
- node = tree_cons (ss_string2_len, se.string_length, node);
+ node = tree_cons (ss_string2[k], se.expr, node);
+ node = tree_cons (ss_string2_len[k], se.string_length, node);
}
- node = tree_cons (ss_target, build_int_cst (integer_type_node, d->n),
+ node = tree_cons (ss_target[k], build_int_cst (integer_type_node, d->n),
node);
- tmp = build_constructor_from_list (select_struct, nreverse (node));
+ tmp = build_constructor_from_list (select_struct[k], nreverse (node));
init = tree_cons (NULL_TREE, tmp, init);
}
- type = build_array_type (select_struct, build_index_type
- (build_int_cst (NULL_TREE, n - 1)));
+ type = build_array_type (select_struct[k],
+ build_index_type (build_int_cst (NULL_TREE, n-1)));
init = build_constructor_from_list (type, nreverse(init));
TREE_CONSTANT (init) = 1;
gfc_add_block_to_block (&block, &se.pre);
- tmp = build_call_expr (gfor_fndecl_select_string, 4, init,
- build_int_cst (NULL_TREE, n), se.expr,
- se.string_length);
+ if (code->expr->ts.kind == 1)
+ fndecl = gfor_fndecl_select_string;
+ else if (code->expr->ts.kind == 4)
+ fndecl = gfor_fndecl_select_string_char4;
+ else
+ gcc_unreachable ();
+
+ tmp = build_call_expr (fndecl, 4, init, build_int_cst (NULL_TREE, n),
+ se.expr, se.string_length);
case_num = gfc_create_var (integer_type_node, "case_num");
- gfc_add_modify_expr (&block, case_num, tmp);
+ gfc_add_modify (&block, case_num, tmp);
gfc_add_block_to_block (&block, &se.post);
{
/* Use the variable offset for the temporary. */
tmp = gfc_conv_descriptor_offset (tse.expr);
- gfc_add_modify_expr (pre, tmp,
+ gfc_add_modify (pre, tmp,
gfc_conv_array_offset (old_sym->backend_decl));
}
}
/* Initialize the mask index outside the FORALL nest. */
if (mask_flag && forall_tmp->mask)
- gfc_add_modify_expr (outer, forall_tmp->maskindex, gfc_index_zero_node);
+ gfc_add_modify (outer, forall_tmp->maskindex, gfc_index_zero_node);
iter = forall_tmp->this_loop;
nvar = forall_tmp->nvar;
/* Increment the loop variable. */
tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (var), var, step);
- gfc_add_modify_expr (&block, var, tmp);
+ gfc_add_modify (&block, var, tmp);
/* Advance to the next mask element. Only do this for the
innermost loop. */
tree maskindex = forall_tmp->maskindex;
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
maskindex, gfc_index_one_node);
- gfc_add_modify_expr (&block, maskindex, tmp);
+ gfc_add_modify (&block, maskindex, tmp);
}
/* Decrement the loop counter. */
tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (var), count,
build_int_cst (TREE_TYPE (var), 1));
- gfc_add_modify_expr (&block, count, tmp);
+ gfc_add_modify (&block, count, tmp);
body = gfc_finish_block (&block);
/* Loop var initialization. */
gfc_init_block (&block);
- gfc_add_modify_expr (&block, var, start);
+ gfc_add_modify (&block, var, start);
/* Initialize the loop counter. */
tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (var), step, start);
tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (var), end, tmp);
tmp = fold_build2 (TRUNC_DIV_EXPR, TREE_TYPE (var), tmp, step);
- gfc_add_modify_expr (&block, count, tmp);
+ gfc_add_modify (&block, count, tmp);
/* The loop expression. */
tmp = build1_v (LOOP_EXPR, body);
*pdata = convert (pvoid_type_node, tmpvar);
tmp = gfc_call_malloc (pblock, TREE_TYPE (tmpvar), bytesize);
- gfc_add_modify_expr (pblock, tmpvar, tmp);
+ gfc_add_modify (pblock, tmpvar, tmp);
}
return tmpvar;
}
/* Use the scalar assignment as is. */
gfc_add_block_to_block (&block, &lse.pre);
- gfc_add_modify_expr (&block, lse.expr, tmp);
+ gfc_add_modify (&block, lse.expr, tmp);
gfc_add_block_to_block (&block, &lse.post);
/* Increment the count1. */
tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1,
gfc_index_one_node);
- gfc_add_modify_expr (&block, count1, tmp);
+ gfc_add_modify (&block, count1, tmp);
tmp = gfc_finish_block (&block);
}
/* Calculate the bounds of the scalarization. */
gfc_conv_ss_startstride (&loop1);
/* Setup the scalarizing loops. */
- gfc_conv_loop_setup (&loop1);
+ gfc_conv_loop_setup (&loop1, &expr->where);
gfc_mark_ss_chain_used (lss, 1);
/* Increment count1. */
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count1, gfc_index_one_node);
- gfc_add_modify_expr (&body, count1, tmp);
+ gfc_add_modify (&body, count1, tmp);
/* Increment count3. */
if (count3)
{
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count3, gfc_index_one_node);
- gfc_add_modify_expr (&body, count3, tmp);
+ gfc_add_modify (&body, count3, tmp);
}
/* Generate the copying loops. */
gfc_add_ss_to_loop (&loop, rss);
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, &expr2->where);
gfc_mark_ss_chain_used (rss, 1);
/* Start the loop body. */
/* Increment count1. */
tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1,
gfc_index_one_node);
- gfc_add_modify_expr (&block, count1, tmp);
+ gfc_add_modify (&block, count1, tmp);
}
else
{
/* Increment count1. */
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count1, gfc_index_one_node);
- gfc_add_modify_expr (&body1, count1, tmp);
+ gfc_add_modify (&body1, count1, tmp);
/* Increment count3. */
if (count3)
{
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count3, gfc_index_one_node);
- gfc_add_modify_expr (&body1, count3, tmp);
+ gfc_add_modify (&body1, count3, tmp);
}
/* Generate the copying loops. */
flag_bounds_check = 0;
gfc_conv_ss_startstride (&loop);
flag_bounds_check = save_flag;
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, &expr2->where);
/* Figure out how many elements we need. */
for (i = 0; i < loop.dimen; i++)
/* Otherwise, create a temporary variable to compute the result. */
number = gfc_create_var (gfc_array_index_type, "num");
- gfc_add_modify_expr (block, number, gfc_index_zero_node);
+ gfc_add_modify (block, number, gfc_index_zero_node);
gfc_start_block (&body);
if (inner_size_body)
number, inner_size);
else
tmp = inner_size;
- gfc_add_modify_expr (&body, number, tmp);
+ gfc_add_modify (&body, number, tmp);
tmp = gfc_finish_block (&body);
/* Generate loops. */
if (wheremask)
{
count = gfc_create_var (gfc_array_index_type, "count");
- gfc_add_modify_expr (block, count, gfc_index_zero_node);
+ gfc_add_modify (block, count, gfc_index_zero_node);
}
else
count = NULL;
/* Initialize count1. */
- gfc_add_modify_expr (block, count1, gfc_index_zero_node);
+ gfc_add_modify (block, count1, gfc_index_zero_node);
/* 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_add_expr_to_block (block, tmp);
/* Reset count1. */
- gfc_add_modify_expr (block, count1, gfc_index_zero_node);
+ gfc_add_modify (block, count1, gfc_index_zero_node);
/* Reset count. */
if (wheremask)
- gfc_add_modify_expr (block, count, gfc_index_zero_node);
+ gfc_add_modify (block, count, gfc_index_zero_node);
/* Generate codes to copy the temporary to lhs. */
tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
tree tmp, tmp1, ptemp1;
count = gfc_create_var (gfc_array_index_type, "count");
- gfc_add_modify_expr (block, count, gfc_index_zero_node);
+ gfc_add_modify (block, count, gfc_index_zero_node);
inner_size = integer_one_node;
lss = gfc_walk_expr (expr1);
rse.want_pointer = 1;
gfc_conv_expr (&rse, expr2);
gfc_add_block_to_block (&body, &rse.pre);
- gfc_add_modify_expr (&body, lse.expr,
+ gfc_add_modify (&body, lse.expr,
fold_convert (TREE_TYPE (lse.expr), rse.expr));
gfc_add_block_to_block (&body, &rse.post);
/* Increment count. */
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count, gfc_index_one_node);
- gfc_add_modify_expr (&body, count, tmp);
+ gfc_add_modify (&body, count, tmp);
tmp = gfc_finish_block (&body);
gfc_add_expr_to_block (block, tmp);
/* Reset count. */
- gfc_add_modify_expr (block, count, gfc_index_zero_node);
+ gfc_add_modify (block, count, gfc_index_zero_node);
gfc_start_block (&body);
gfc_init_se (&lse, NULL);
lse.want_pointer = 1;
gfc_conv_expr (&lse, expr1);
gfc_add_block_to_block (&body, &lse.pre);
- gfc_add_modify_expr (&body, lse.expr, rse.expr);
+ gfc_add_modify (&body, lse.expr, rse.expr);
gfc_add_block_to_block (&body, &lse.post);
/* Increment count. */
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count, gfc_index_one_node);
- gfc_add_modify_expr (&body, count, tmp);
+ gfc_add_modify (&body, count, tmp);
tmp = gfc_finish_block (&body);
/* Generate body and loops according to the information in
/* Setup the scalarizing loops and bounds. */
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, &expr2->where);
info = &rss->data.info;
desc = info->descriptor;
/* Increment count. */
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count, gfc_index_one_node);
- gfc_add_modify_expr (&body, count, tmp);
+ gfc_add_modify (&body, count, tmp);
tmp = gfc_finish_block (&body);
gfc_add_expr_to_block (block, tmp);
/* Reset count. */
- gfc_add_modify_expr (block, count, gfc_index_zero_node);
+ gfc_add_modify (block, count, gfc_index_zero_node);
parm = gfc_build_array_ref (tmp1, count, NULL);
lss = gfc_walk_expr (expr1);
gfc_init_se (&lse, NULL);
gfc_conv_expr_descriptor (&lse, expr1, lss);
- gfc_add_modify_expr (&lse.pre, lse.expr, parm);
+ gfc_add_modify (&lse.pre, lse.expr, parm);
gfc_start_block (&body);
gfc_add_block_to_block (&body, &lse.pre);
gfc_add_block_to_block (&body, &lse.post);
/* Increment count. */
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count, gfc_index_one_node);
- gfc_add_modify_expr (&body, count, tmp);
+ gfc_add_modify (&body, count, tmp);
tmp = gfc_finish_block (&body);
/* As the mask array can be very big, prefer compact boolean types. */
tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
- gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
+ gfc_add_modify (&block, maskindex, gfc_index_zero_node);
/* Start of mask assignment loop body. */
gfc_start_block (&body);
se.expr = convert (mask_type, se.expr);
tmp = gfc_build_array_ref (mask, maskindex, NULL);
- gfc_add_modify_expr (&body, tmp, se.expr);
+ gfc_add_modify (&body, tmp, se.expr);
/* Advance to the next mask element. */
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
maskindex, gfc_index_one_node);
- gfc_add_modify_expr (&body, maskindex, tmp);
+ gfc_add_modify (&body, maskindex, tmp);
/* Generate the loops. */
tmp = gfc_finish_block (&body);
/* Variable to index the temporary. */
count = gfc_create_var (gfc_array_index_type, "count");
/* Initialize count. */
- gfc_add_modify_expr (block, count, gfc_index_zero_node);
+ gfc_add_modify (block, count, gfc_index_zero_node);
gfc_start_block (&body);
gfc_add_ss_to_loop (&loop, rss);
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, &me->where);
gfc_mark_ss_chain_used (rss, 1);
/* Start the loop body. */
gfc_add_block_to_block (&body1, &lse.pre);
gfc_add_block_to_block (&body1, &rse.pre);
- gfc_add_modify_expr (&body1, cond, fold_convert (mask_type, rse.expr));
+ gfc_add_modify (&body1, cond, fold_convert (mask_type, rse.expr));
if (mask && (cmask || pmask))
{
tmp = gfc_build_array_ref (mask, count, NULL);
if (invert)
tmp = fold_build1 (TRUTH_NOT_EXPR, mask_type, tmp);
- gfc_add_modify_expr (&body1, mtmp, tmp);
+ gfc_add_modify (&body1, mtmp, tmp);
}
if (cmask)
tmp = cond;
if (mask)
tmp = fold_build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
- gfc_add_modify_expr (&body1, tmp1, tmp);
+ gfc_add_modify (&body1, tmp1, tmp);
}
if (pmask)
tmp = fold_build1 (TRUTH_NOT_EXPR, mask_type, cond);
if (mask)
tmp = fold_build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
- gfc_add_modify_expr (&body1, tmp1, tmp);
+ gfc_add_modify (&body1, tmp1, tmp);
}
gfc_add_block_to_block (&body1, &lse.post);
/* Increment count. */
tmp1 = fold_build2 (PLUS_EXPR, gfc_array_index_type, count,
gfc_index_one_node);
- gfc_add_modify_expr (&body1, count, tmp1);
+ gfc_add_modify (&body1, count, tmp1);
/* Generate the copying loops. */
gfc_trans_scalarizing_loops (&loop, &body1);
{
/* 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;
gfc_conv_resolve_dependencies (&loop, lss_section, rss);
/* Setup the scalarizing loops. */
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, &expr2->where);
/* Setup the gfc_se structures. */
gfc_copy_loopinfo_to_se (&lse, &loop);
/* Increment count1. */
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count1, gfc_index_one_node);
- gfc_add_modify_expr (&body, count1, tmp);
+ gfc_add_modify (&body, count1, tmp);
/* Use the scalar assignment as is. */
gfc_add_block_to_block (&block, &body);
expression. */
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count1, gfc_index_one_node);
- gfc_add_modify_expr (&body, count1, tmp);
+ gfc_add_modify (&body, count1, tmp);
gfc_trans_scalarized_loop_boundary (&loop, &body);
/* We need to copy the temporary to the actual lhs. */
/* Increment count2. */
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count2, gfc_index_one_node);
- gfc_add_modify_expr (&body, count2, tmp);
+ gfc_add_modify (&body, count2, tmp);
}
else
{
/* Increment count1. */
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count1, gfc_index_one_node);
- gfc_add_modify_expr (&body, count1, tmp);
+ gfc_add_modify (&body, count1, tmp);
}
/* Generate the copying loops. */
gfc_code *cblock;
gfc_code *cnext;
tree tmp;
+ tree cond;
tree count1, count2;
bool need_cmask;
bool need_pmask;
size = compute_overall_iter_number (nested_forall_info, inner_size,
&inner_size_body, block);
+ /* Check whether the size is negative. */
+ cond = fold_build2 (LE_EXPR, boolean_type_node, size,
+ gfc_index_zero_node);
+ size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
+ gfc_index_zero_node, size);
+ size = gfc_evaluate_now (size, block);
+
/* Allocate temporary for WHERE mask if needed. */
if (need_cmask)
cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
/* Variables to control maskexpr. */
count1 = gfc_create_var (gfc_array_index_type, "count1");
count2 = gfc_create_var (gfc_array_index_type, "count2");
- gfc_add_modify_expr (block, count1, gfc_index_zero_node);
- gfc_add_modify_expr (block, count2, gfc_index_zero_node);
+ gfc_add_modify (block, count1, gfc_index_zero_node);
+ gfc_add_modify (block, count2, gfc_index_zero_node);
tmp = gfc_trans_where_assign (expr1, expr2,
cmask, invert,
/* Variables to control maskexpr. */
count1 = gfc_create_var (gfc_array_index_type, "count1");
count2 = gfc_create_var (gfc_array_index_type, "count2");
- gfc_add_modify_expr (block, count1, gfc_index_zero_node);
- gfc_add_modify_expr (block, count2, gfc_index_zero_node);
+ gfc_add_modify (block, count1, gfc_index_zero_node);
+ gfc_add_modify (block, count2, gfc_index_zero_node);
tmp = gfc_trans_where_assign (expr1, expr2,
cmask, invert,
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;
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;
}
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, &tdst->where);
gfc_mark_ss_chain_used (css, 1);
gfc_mark_ss_chain_used (tdss, 1);
block is dependence free if cond is not dependent on writes
to x1 and x2, y1 is not dependent on writes to x2, and y2
is not dependent on writes to x1, and both y's are not
- dependent upon their own x's. */
+ dependent upon their own x's. In addition to this, the
+ final two dependency checks below exclude all but the same
+ array reference if the where and elswhere destinations
+ are the same. In short, this is VERY conservative and this
+ is needed because the two loops, required by the standard
+ are coalesced in gfc_trans_where_3. */
if (!gfc_check_dependency(cblock->next->expr,
cblock->expr, 0)
&& !gfc_check_dependency(eblock->next->expr,
cblock->expr, 0)
&& !gfc_check_dependency(cblock->next->expr,
- eblock->next->expr2, 0)
+ eblock->next->expr2, 1)
+ && !gfc_check_dependency(eblock->next->expr,
+ cblock->next->expr2, 1)
+ && !gfc_check_dependency(cblock->next->expr,
+ cblock->next->expr2, 1)
&& !gfc_check_dependency(eblock->next->expr,
- cblock->next->expr2, 0)
+ eblock->next->expr2, 1)
&& !gfc_check_dependency(cblock->next->expr,
- cblock->next->expr2, 0)
+ eblock->next->expr, 0)
&& !gfc_check_dependency(eblock->next->expr,
- eblock->next->expr2, 0))
+ cblock->next->expr, 0))
return gfc_trans_where_3 (cblock, eblock);
}
}
gfc_init_se (&se, NULL);
gfc_conv_expr_lhs (&se, code->expr);
tmp = convert (TREE_TYPE (se.expr), stat);
- gfc_add_modify_expr (&block, se.expr, tmp);
+ gfc_add_modify (&block, se.expr, tmp);
}
return gfc_finish_block (&block);
apstat = build_fold_addr_expr (astat);
/* Initialize astat to 0. */
- gfc_add_modify_expr (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
+ gfc_add_modify (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
}
else
pstat = apstat = stat = astat = NULL_TREE;
/* Do not deallocate the components of a derived type
ultimate pointer component. */
- if (!(last && last->u.c.component->pointer)
+ if (!(last && last->u.c.component->attr.pointer)
&& !(!last && expr->symtree->n.sym->attr.pointer))
{
tmp = gfc_deallocate_alloc_comp (expr->ts.derived, se.expr,
- expr->rank);
+ expr->rank);
gfc_add_expr_to_block (&se.pre, tmp);
}
}
if (expr->rank)
- tmp = gfc_array_deallocate (se.expr, pstat);
+ tmp = gfc_array_deallocate (se.expr, pstat, expr);
else
{
- tmp = gfc_deallocate_with_status (se.expr, pstat, false);
+ tmp = gfc_deallocate_with_status (se.expr, pstat, false, expr);
gfc_add_expr_to_block (&se.pre, tmp);
tmp = fold_build2 (MODIFY_EXPR, void_type_node,
if (code->expr)
{
apstat = fold_build2 (PLUS_EXPR, TREE_TYPE (stat), astat, stat);
- gfc_add_modify_expr (&se.pre, astat, apstat);
+ gfc_add_modify (&se.pre, astat, apstat);
}
tmp = gfc_finish_block (&se.pre);
gfc_init_se (&se, NULL);
gfc_conv_expr_lhs (&se, code->expr);
tmp = convert (TREE_TYPE (se.expr), astat);
- gfc_add_modify_expr (&block, se.expr, tmp);
+ gfc_add_modify (&block, se.expr, tmp);
}
return gfc_finish_block (&block);
OSDN Git Service
