#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "tree-gimple.h"
#include "ggc.h"
#include "toplev.h"
#include "real.h"
#include "gfortran.h"
#include "flags.h"
#include "trans.h"
#include "trans-stmt.h"
#include "trans-types.h"
#include "trans-array.h"
#include "trans-const.h"
#include "arith.h"
#include "dependency.h"
typedef struct iter_info
{
tree var;
tree start;
tree end;
tree step;
struct iter_info *next;
}
iter_info;
typedef struct forall_info
{
iter_info *this_loop;
tree mask;
tree maskindex;
int nvar;
tree size;
struct forall_info *prev_nest;
}
forall_info;
static void gfc_trans_where_2 (gfc_code *, tree, bool,
forall_info *, stmtblock_t *);
tree
gfc_trans_label_here (gfc_code * code)
{
return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
}
void
gfc_conv_label_variable (gfc_se * se, gfc_expr * expr)
{
gcc_assert (expr->symtree->n.sym->attr.assign == 1);
gfc_conv_expr (se, expr);
if (TREE_CODE (se->expr) == COMPONENT_REF)
se->expr = TREE_OPERAND (se->expr, 1);
else if (TREE_CODE (se->expr) == INDIRECT_REF)
se->expr = TREE_OPERAND (se->expr, 0);
}
tree
gfc_trans_label_assign (gfc_code * code)
{
tree label_tree;
gfc_se se;
tree len;
tree addr;
tree len_tree;
char *label_str;
int label_len;
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
gfc_conv_label_variable (&se, code->expr);
len = GFC_DECL_STRING_LEN (se.expr);
addr = GFC_DECL_ASSIGN_ADDR (se.expr);
label_tree = gfc_get_label_decl (code->label);
if (code->label->defined == ST_LABEL_TARGET)
{
label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
len_tree = integer_minus_one_node;
}
else
{
label_str = code->label->format->value.character.string;
label_len = code->label->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_addr_expr (pvoid_type_node, label_tree);
}
gfc_add_modify_expr (&se.pre, len, len_tree);
gfc_add_modify_expr (&se.pre, addr, label_tree);
return gfc_finish_block (&se.pre);
}
tree
gfc_trans_goto (gfc_code * code)
{
locus loc = code->loc;
tree assigned_goto;
tree target;
tree tmp;
gfc_se se;
if (code->label != NULL)
return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
gfc_conv_label_variable (&se, code->expr);
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, "Assigned label is not a target label",
&se.pre, &loc);
assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
code = code->block;
if (code == NULL)
{
target = build1 (GOTO_EXPR, void_type_node, assigned_goto);
gfc_add_expr_to_block (&se.pre, target);
return gfc_finish_block (&se.pre);
}
do
{
target = gfc_get_label_decl (code->label);
tmp = gfc_build_addr_expr (pvoid_type_node, target);
tmp = build2 (EQ_EXPR, boolean_type_node, tmp, assigned_goto);
tmp = build3_v (COND_EXPR, tmp,
build1 (GOTO_EXPR, void_type_node, target),
build_empty_stmt ());
gfc_add_expr_to_block (&se.pre, tmp);
code = code->block;
}
while (code != NULL);
gfc_trans_runtime_check (boolean_true_node,
"Assigned label is not in the list", &se.pre, &loc);
return gfc_finish_block (&se.pre);
}
tree
gfc_trans_entry (gfc_code * code)
{
return build1_v (LABEL_EXPR, code->ext.entry->label);
}
static void
gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
gfc_symbol * sym, gfc_actual_arglist * arg)
{
gfc_actual_arglist *arg0;
gfc_expr *e;
gfc_formal_arglist *formal;
gfc_loopinfo tmp_loop;
gfc_se parmse;
gfc_ss *ss;
gfc_ss_info *info;
gfc_symbol *fsym;
int n;
stmtblock_t block;
tree data;
tree offset;
tree size;
tree tmp;
if (loopse->ss == NULL)
return;
ss = loopse->ss;
arg0 = arg;
formal = sym->formal;
for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
{
e = arg->expr;
if (e == NULL)
continue;
info = NULL;
for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next)
{
if (ss->expr != e)
continue;
info = &ss->data.info;
break;
}
fsym = formal ? formal->sym : NULL;
if (e->expr_type == EXPR_VARIABLE
&& e->rank && fsym
&& fsym->attr.intent == INTENT_OUT
&& gfc_check_fncall_dependency (e, INTENT_OUT, sym, arg0))
{
gfc_init_loopinfo (&tmp_loop);
for (n = 0; n < info->dimen; n++)
{
tmp_loop.to[n] = loopse->loop->to[n];
tmp_loop.from[n] = loopse->loop->from[n];
tmp_loop.order[n] = loopse->loop->order[n];
}
size = gfc_create_var (gfc_array_index_type, NULL);
data = gfc_create_var (pvoid_type_node, NULL);
gfc_start_block (&block);
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 = fold_convert (pvoid_type_node, info->data);
gfc_add_modify_expr (&se->pre, data, tmp);
gfc_merge_block_scope (&block);
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);
offset = gfc_index_zero_node;
for (n = 0; n < info->dimen; n++)
{
tmp = gfc_conv_descriptor_stride (info->descriptor,
gfc_rank_cst[n]);
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
loopse->loop->from[n], tmp);
offset = fold_build2 (MINUS_EXPR, gfc_array_index_type,
offset, tmp);
}
info->offset = gfc_create_var (gfc_array_index_type, NULL);
gfc_add_modify_expr (&se->pre, info->offset, offset);
tmp = gfc_chainon_list (NULL_TREE, parmse.expr);
tmp = gfc_chainon_list (tmp, data);
tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
gfc_add_expr_to_block (&se->post, tmp);
gfc_add_block_to_block (&se->post, &parmse.post);
}
}
}
tree
gfc_trans_call (gfc_code * code, bool dependency_check)
{
gfc_se se;
gfc_ss * ss;
int has_alternate_specifier;
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
gcc_assert (code->resolved_sym);
ss = gfc_ss_terminator;
if (code->resolved_sym->attr.elemental)
ss = gfc_walk_elemental_function_args (ss, code->ext.actual, GFC_SS_REFERENCE);
if (ss == gfc_ss_terminator)
{
has_alternate_specifier
= gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual);
TREE_SIDE_EFFECTS (se.expr) = 1;
if (has_alternate_specifier)
{
gfc_code *select_code;
gfc_symbol *sym;
select_code = code->next;
gcc_assert(select_code->op == EXEC_SELECT);
sym = select_code->expr->symtree->n.sym;
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);
}
else
gfc_add_expr_to_block (&se.pre, se.expr);
gfc_add_block_to_block (&se.pre, &se.post);
}
else
{
gfc_loopinfo loop;
stmtblock_t body;
stmtblock_t block;
gfc_se loopse;
ss = gfc_reverse_ss (ss);
gfc_init_se (&loopse, NULL);
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, ss);
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop);
gfc_mark_ss_chain_used (ss, 1);
gfc_copy_loopinfo_to_se (&loopse, &loop);
loopse.ss = ss;
if (dependency_check)
{
gfc_symbol *sym;
sym = code->resolved_sym;
gcc_assert (sym->formal->sym->attr.intent = INTENT_OUT);
gcc_assert (sym->formal->next->sym->attr.intent = INTENT_IN);
gfc_conv_elemental_dependencies (&se, &loopse, sym,
code->ext.actual);
}
gfc_start_scalarized_body (&loop, &body);
gfc_init_block (&block);
gfc_conv_function_call (&loopse, code->resolved_sym, code->ext.actual);
gfc_add_expr_to_block (&loopse.pre, loopse.expr);
gfc_add_block_to_block (&block, &loopse.pre);
gfc_add_block_to_block (&block, &loopse.post);
gfc_add_expr_to_block (&body, gfc_finish_block (&block));
gfc_trans_scalarizing_loops (&loop, &body);
gfc_add_block_to_block (&se.pre, &loop.pre);
gfc_add_block_to_block (&se.pre, &loop.post);
gfc_add_block_to_block (&se.pre, &se.post);
gfc_cleanup_loop (&loop);
}
return gfc_finish_block (&se.pre);
}
tree
gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED)
{
if (code->expr)
{
gfc_se se;
tree tmp;
tree result;
result = gfc_get_fake_result_decl (NULL, 0);
if (!result)
{
gfc_warning ("An alternate return at %L without a * dummy argument",
&code->expr->where);
return build1_v (GOTO_EXPR, gfc_get_return_label ());
}
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
gfc_conv_expr (&se, code->expr);
tmp = build2 (MODIFY_EXPR, TREE_TYPE (result), result, se.expr);
gfc_add_expr_to_block (&se.pre, tmp);
tmp = build1_v (GOTO_EXPR, gfc_get_return_label ());
gfc_add_expr_to_block (&se.pre, tmp);
gfc_add_block_to_block (&se.pre, &se.post);
return gfc_finish_block (&se.pre);
}
else
return build1_v (GOTO_EXPR, gfc_get_return_label ());
}
tree
gfc_trans_pause (gfc_code * code)
{
tree gfc_int4_type_node = gfc_get_int_type (4);
gfc_se se;
tree args;
tree tmp;
tree fndecl;
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
if (code->expr == NULL)
{
tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
args = gfc_chainon_list (NULL_TREE, tmp);
fndecl = gfor_fndecl_pause_numeric;
}
else
{
gfc_conv_expr_reference (&se, code->expr);
args = gfc_chainon_list (NULL_TREE, se.expr);
args = gfc_chainon_list (args, se.string_length);
fndecl = gfor_fndecl_pause_string;
}
tmp = build_function_call_expr (fndecl, args);
gfc_add_expr_to_block (&se.pre, tmp);
gfc_add_block_to_block (&se.pre, &se.post);
return gfc_finish_block (&se.pre);
}
tree
gfc_trans_stop (gfc_code * code)
{
tree gfc_int4_type_node = gfc_get_int_type (4);
gfc_se se;
tree args;
tree tmp;
tree fndecl;
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
if (code->expr == NULL)
{
tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
args = gfc_chainon_list (NULL_TREE, tmp);
fndecl = gfor_fndecl_stop_numeric;
}
else
{
gfc_conv_expr_reference (&se, code->expr);
args = gfc_chainon_list (NULL_TREE, se.expr);
args = gfc_chainon_list (args, se.string_length);
fndecl = gfor_fndecl_stop_string;
}
tmp = build_function_call_expr (fndecl, args);
gfc_add_expr_to_block (&se.pre, tmp);
gfc_add_block_to_block (&se.pre, &se.post);
return gfc_finish_block (&se.pre);
}
static tree
gfc_trans_if_1 (gfc_code * code)
{
gfc_se if_se;
tree stmt, elsestmt;
if (!code->expr)
return gfc_trans_code (code->next);
gfc_init_se (&if_se, NULL);
gfc_start_block (&if_se.pre);
gfc_conv_expr_val (&if_se, code->expr);
stmt = gfc_trans_code (code->next);
if (code->block)
elsestmt = gfc_trans_if_1 (code->block);
else
elsestmt = build_empty_stmt ();
stmt = fold_build3 (COND_EXPR, void_type_node, if_se.expr, stmt, elsestmt);
gfc_add_expr_to_block (&if_se.pre, stmt);
return gfc_finish_block (&if_se.pre);
}
tree
gfc_trans_if (gfc_code * code)
{
return gfc_trans_if_1 (code->block);
}
tree
gfc_trans_arithmetic_if (gfc_code * code)
{
gfc_se se;
tree tmp;
tree branch1;
tree branch2;
tree zero;
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
gfc_conv_expr_val (&se, code->expr);
se.expr = gfc_evaluate_now (se.expr, &se.pre);
zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);
if (code->label->value != code->label2->value)
{
branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));
if (code->label->value != code->label3->value)
tmp = fold_build2 (LT_EXPR, boolean_type_node, se.expr, zero);
else
tmp = fold_build2 (NE_EXPR, boolean_type_node, se.expr, zero);
branch1 = fold_build3 (COND_EXPR, void_type_node, tmp, branch1, branch2);
}
else
branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
if (code->label->value != code->label3->value
&& code->label2->value != code->label3->value)
{
branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
tmp = fold_build2 (LE_EXPR, boolean_type_node, se.expr, zero);
branch1 = fold_build3 (COND_EXPR, void_type_node, tmp, branch1, branch2);
}
gfc_add_expr_to_block (&se.pre, branch1);
return gfc_finish_block (&se.pre);
}
static tree
gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
tree from, tree to, tree step)
{
stmtblock_t body;
tree type;
tree cond;
tree tmp;
tree cycle_label;
tree exit_label;
type = TREE_TYPE (dovar);
gfc_add_modify_expr (pblock, dovar, from);
cycle_label = gfc_build_label_decl (NULL_TREE);
exit_label = gfc_build_label_decl (NULL_TREE);
code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
gfc_start_block (&body);
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);
}
cond = fold_build2 (EQ_EXPR, boolean_type_node, dovar, to);
cond = gfc_evaluate_now (cond, &body);
tmp = fold_build2 (PLUS_EXPR, type, dovar, step);
gfc_add_modify_expr (&body, dovar, tmp);
tmp = build1_v (GOTO_EXPR, exit_label);
TREE_USED (exit_label) = 1;
tmp = fold_build3 (COND_EXPR, void_type_node,
cond, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&body, tmp);
tmp = gfc_finish_block (&body);
tmp = build1_v (LOOP_EXPR, tmp);
if (tree_int_cst_sgn (step) > 0)
cond = fold_build2 (LE_EXPR, boolean_type_node, dovar, to);
else
cond = fold_build2 (GE_EXPR, boolean_type_node, dovar, to);
tmp = fold_build3 (COND_EXPR, void_type_node,
cond, tmp, build_empty_stmt ());
gfc_add_expr_to_block (pblock, tmp);
tmp = build1_v (LABEL_EXPR, exit_label);
gfc_add_expr_to_block (pblock, tmp);
return gfc_finish_block (pblock);
}
tree
gfc_trans_do (gfc_code * code)
{
gfc_se se;
tree dovar;
tree from;
tree to;
tree step;
tree count;
tree count_one;
tree type;
tree cond;
tree cycle_label;
tree exit_label;
tree tmp;
stmtblock_t block;
stmtblock_t body;
gfc_start_block (&block);
gfc_init_se (&se, NULL);
gfc_conv_expr_lhs (&se, code->ext.iterator->var);
gfc_add_block_to_block (&block, &se.pre);
dovar = se.expr;
type = TREE_TYPE (dovar);
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, code->ext.iterator->start);
gfc_add_block_to_block (&block, &se.pre);
from = gfc_evaluate_now (se.expr, &block);
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, code->ext.iterator->end);
gfc_add_block_to_block (&block, &se.pre);
to = gfc_evaluate_now (se.expr, &block);
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, code->ext.iterator->step);
gfc_add_block_to_block (&block, &se.pre);
step = gfc_evaluate_now (se.expr, &block);
if (TREE_CODE (type) == INTEGER_TYPE
&& (integer_onep (step)
|| tree_int_cst_equal (step, integer_minus_one_node)))
return gfc_trans_simple_do (code, &block, dovar, from, to, step);
tmp = fold_build2 (MINUS_EXPR, type, step, from);
tmp = fold_build2 (PLUS_EXPR, type, to, tmp);
if (TREE_CODE (type) == INTEGER_TYPE)
{
tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step);
count = gfc_create_var (type, "count");
}
else
{
tmp = fold_build2 (RDIV_EXPR, type, tmp, step);
tmp = fold_build1 (FIX_TRUNC_EXPR, gfc_array_index_type, tmp);
count = gfc_create_var (gfc_array_index_type, "count");
}
gfc_add_modify_expr (&block, count, tmp);
count_one = build_int_cst (TREE_TYPE (count), 1);
gfc_add_modify_expr (&block, dovar, from);
gfc_start_block (&body);
cycle_label = gfc_build_label_decl (NULL_TREE);
exit_label = gfc_build_label_decl (NULL_TREE);
cond = fold_build2 (LE_EXPR, boolean_type_node, count,
build_int_cst (TREE_TYPE (count), 0));
tmp = build1_v (GOTO_EXPR, exit_label);
TREE_USED (exit_label) = 1;
tmp = fold_build3 (COND_EXPR, void_type_node,
cond, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&body, tmp);
code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
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 = build2 (PLUS_EXPR, type, dovar, step);
gfc_add_modify_expr (&body, dovar, tmp);
tmp = build2 (MINUS_EXPR, TREE_TYPE (count), count, count_one);
gfc_add_modify_expr (&body, count, tmp);
tmp = gfc_finish_block (&body);
tmp = build1_v (LOOP_EXPR, tmp);
gfc_add_expr_to_block (&block, tmp);
tmp = build1_v (LABEL_EXPR, exit_label);
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}
tree
gfc_trans_do_while (gfc_code * code)
{
gfc_se cond;
tree tmp;
tree cycle_label;
tree exit_label;
stmtblock_t block;
gfc_start_block (&block);
cycle_label = gfc_build_label_decl (NULL_TREE);
exit_label = gfc_build_label_decl (NULL_TREE);
code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
gfc_init_se (&cond, NULL);
gfc_conv_expr_val (&cond, code->expr);
gfc_add_block_to_block (&block, &cond.pre);
cond.expr = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, cond.expr);
tmp = build1_v (GOTO_EXPR, exit_label);
TREE_USED (exit_label) = 1;
tmp = fold_build3 (COND_EXPR, void_type_node,
cond.expr, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&block, tmp);
tmp = gfc_trans_code (code->block->next);
gfc_add_expr_to_block (&block, tmp);
if (TREE_USED (cycle_label))
{
tmp = build1_v (LABEL_EXPR, cycle_label);
gfc_add_expr_to_block (&block, tmp);
}
tmp = gfc_finish_block (&block);
gfc_init_block (&block);
tmp = build1_v (LOOP_EXPR, tmp);
gfc_add_expr_to_block (&block, tmp);
tmp = build1_v (LABEL_EXPR, exit_label);
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}
static tree
gfc_trans_integer_select (gfc_code * code)
{
gfc_code *c;
gfc_case *cp;
tree end_label;
tree tmp;
gfc_se se;
stmtblock_t block;
stmtblock_t body;
gfc_start_block (&block);
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, code->expr);
gfc_add_block_to_block (&block, &se.pre);
end_label = gfc_build_label_decl (NULL_TREE);
gfc_init_block (&body);
for (c = code->block; c; c = c->block)
{
for (cp = c->ext.case_list; cp; cp = cp->next)
{
tree low, high;
tree label;
low = high = NULL_TREE;
if (cp->low)
{
low = gfc_conv_constant_to_tree (cp->low);
if (!cp->high)
high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
}
if (cp->high)
{
if (!cp->low
|| (cp->low
&& mpz_cmp (cp->low->value.integer,
cp->high->value.integer) != 0))
high = gfc_conv_constant_to_tree (cp->high);
if (!cp->low)
low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
}
label = gfc_build_label_decl (NULL_TREE);
tmp = build3 (CASE_LABEL_EXPR, void_type_node, low, high, label);
gfc_add_expr_to_block (&body, tmp);
}
tmp = gfc_trans_code (c->next);
gfc_add_expr_to_block (&body, tmp);
tmp = build1_v (GOTO_EXPR, end_label);
gfc_add_expr_to_block (&body, tmp);
}
tmp = gfc_finish_block (&body);
tmp = build3_v (SWITCH_EXPR, se.expr, tmp, NULL_TREE);
gfc_add_expr_to_block (&block, tmp);
tmp = build1_v (LABEL_EXPR, end_label);
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}
static tree
gfc_trans_logical_select (gfc_code * code)
{
gfc_code *c;
gfc_code *t, *f, *d;
gfc_case *cp;
gfc_se se;
stmtblock_t block;
t = f = d = NULL;
for (c = code->block; c; c = c->block)
{
for (cp = c->ext.case_list; cp; cp = cp->next)
{
if (cp->low)
{
if (cp->low->value.logical == 0)
f = c;
else
t = c;
}
else
d = c;
}
}
gfc_start_block (&block);
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, code->expr);
gfc_add_block_to_block (&block, &se.pre);
if (t == f && t != NULL)
{
gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
}
else
{
tree true_tree, false_tree, stmt;
true_tree = build_empty_stmt ();
false_tree = build_empty_stmt ();
if (t != NULL && f != NULL)
d = NULL;
else if (d != NULL)
{
if (t == NULL)
t = d;
else
f = d;
}
if (t != NULL)
true_tree = gfc_trans_code (t->next);
if (f != NULL)
false_tree = gfc_trans_code (f->next);
stmt = fold_build3 (COND_EXPR, void_type_node, se.expr,
true_tree, false_tree);
gfc_add_expr_to_block (&block, stmt);
}
return gfc_finish_block (&block);
}
static tree
gfc_trans_character_select (gfc_code *code)
{
tree init, node, end_label, tmp, type, args, *labels;
tree case_label;
stmtblock_t block, body;
gfc_case *cp, *d;
gfc_code *c;
gfc_se se;
int i, n;
static tree select_struct;
static tree ss_string1, ss_string1_len;
static tree ss_string2, ss_string2_len;
static tree ss_target;
if (select_struct == NULL)
{
tree gfc_int4_type_node = gfc_get_int_type (4);
select_struct = make_node (RECORD_TYPE);
TYPE_NAME (select_struct) = get_identifier ("_jump_struct");
#undef ADD_FIELD
#define ADD_FIELD(NAME, TYPE) \
ss_##NAME = gfc_add_field_to_struct \
(&(TYPE_FIELDS (select_struct)), select_struct, \
get_identifier (stringize(NAME)), TYPE)
ADD_FIELD (string1, pchar_type_node);
ADD_FIELD (string1_len, gfc_int4_type_node);
ADD_FIELD (string2, pchar_type_node);
ADD_FIELD (string2_len, gfc_int4_type_node);
ADD_FIELD (target, pvoid_type_node);
#undef ADD_FIELD
gfc_finish_type (select_struct);
}
cp = code->block->ext.case_list;
while (cp->left != NULL)
cp = cp->left;
n = 0;
for (d = cp; d; d = d->right)
d->n = n++;
if (n != 0)
labels = gfc_getmem (n * sizeof (tree));
else
labels = NULL;
for(i = 0; i < n; i++)
{
labels[i] = gfc_build_label_decl (NULL_TREE);
TREE_USED (labels[i]) = 1;
FORCED_LABEL (labels[i]) = 1;
}
end_label = gfc_build_label_decl (NULL_TREE);
gfc_start_block (&block);
gfc_init_block (&body);
for (c = code->block; c; c = c->block)
{
for (d = c->ext.case_list; d; d = d->next)
{
tmp = build1_v (LABEL_EXPR, labels[d->n]);
gfc_add_expr_to_block (&body, tmp);
}
tmp = gfc_trans_code (c->next);
gfc_add_expr_to_block (&body, tmp);
tmp = build1_v (GOTO_EXPR, end_label);
gfc_add_expr_to_block (&body, tmp);
}
init = NULL_TREE;
i = 0;
for(d = cp; d; d = d->right, i++)
{
node = NULL_TREE;
gfc_init_se (&se, NULL);
if (d->low == NULL)
{
node = tree_cons (ss_string1, null_pointer_node, node);
node = tree_cons (ss_string1_len, 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);
}
if (d->high == NULL)
{
node = tree_cons (ss_string2, null_pointer_node, node);
node = tree_cons (ss_string2_len, 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);
}
tmp = gfc_build_addr_expr (pvoid_type_node, labels[i]);
node = tree_cons (ss_target, tmp, node);
tmp = build_constructor_from_list (select_struct, 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)));
init = build_constructor_from_list (type, nreverse(init));
TREE_CONSTANT (init) = 1;
TREE_INVARIANT (init) = 1;
TREE_STATIC (init) = 1;
tmp = gfc_create_var (type, "jumptable");
TREE_CONSTANT (tmp) = 1;
TREE_INVARIANT (tmp) = 1;
TREE_STATIC (tmp) = 1;
DECL_INITIAL (tmp) = init;
init = tmp;
init = gfc_build_addr_expr (pvoid_type_node, init);
args = gfc_chainon_list (NULL_TREE, init);
tmp = build_int_cst (NULL_TREE, n);
args = gfc_chainon_list (args, tmp);
tmp = gfc_build_addr_expr (pvoid_type_node, end_label);
args = gfc_chainon_list (args, tmp);
gfc_init_se (&se, NULL);
gfc_conv_expr_reference (&se, code->expr);
args = gfc_chainon_list (args, se.expr);
args = gfc_chainon_list (args, se.string_length);
gfc_add_block_to_block (&block, &se.pre);
tmp = build_function_call_expr (gfor_fndecl_select_string, args);
case_label = gfc_create_var (TREE_TYPE (tmp), "case_label");
gfc_add_modify_expr (&block, case_label, tmp);
gfc_add_block_to_block (&block, &se.post);
tmp = build1 (GOTO_EXPR, void_type_node, case_label);
gfc_add_expr_to_block (&block, tmp);
tmp = gfc_finish_block (&body);
gfc_add_expr_to_block (&block, tmp);
tmp = build1_v (LABEL_EXPR, end_label);
gfc_add_expr_to_block (&block, tmp);
if (n != 0)
gfc_free (labels);
return gfc_finish_block (&block);
}
tree
gfc_trans_select (gfc_code * code)
{
gcc_assert (code && code->expr);
if (code->block == NULL)
return build_empty_stmt ();
switch (code->expr->ts.type)
{
case BT_LOGICAL: return gfc_trans_logical_select (code);
case BT_INTEGER: return gfc_trans_integer_select (code);
case BT_CHARACTER: return gfc_trans_character_select (code);
default:
gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
}
}
static tree
gfc_trans_forall_loop (forall_info *forall_tmp, tree body,
int mask_flag, stmtblock_t *outer)
{
int n, nvar;
tree tmp;
tree cond;
stmtblock_t block;
tree exit_label;
tree count;
tree var, start, end, step;
iter_info *iter;
if (mask_flag && forall_tmp->mask)
gfc_add_modify_expr (outer, forall_tmp->maskindex, gfc_index_zero_node);
iter = forall_tmp->this_loop;
nvar = forall_tmp->nvar;
for (n = 0; n < nvar; n++)
{
var = iter->var;
start = iter->start;
end = iter->end;
step = iter->step;
exit_label = gfc_build_label_decl (NULL_TREE);
TREE_USED (exit_label) = 1;
count = gfc_create_var (TREE_TYPE (var), "count");
gfc_init_block (&block);
cond = fold_build2 (LE_EXPR, boolean_type_node,
count, build_int_cst (TREE_TYPE (count), 0));
tmp = build1_v (GOTO_EXPR, exit_label);
tmp = fold_build3 (COND_EXPR, void_type_node,
cond, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&block, tmp);
gfc_add_expr_to_block (&block, body);
tmp = build2 (PLUS_EXPR, TREE_TYPE (var), var, step);
gfc_add_modify_expr (&block, var, tmp);
if (n == 0 && mask_flag && forall_tmp->mask)
{
tree maskindex = forall_tmp->maskindex;
tmp = build2 (PLUS_EXPR, gfc_array_index_type,
maskindex, gfc_index_one_node);
gfc_add_modify_expr (&block, maskindex, tmp);
}
tmp = build2 (MINUS_EXPR, TREE_TYPE (var), count, gfc_index_one_node);
gfc_add_modify_expr (&block, count, tmp);
body = gfc_finish_block (&block);
gfc_init_block (&block);
gfc_add_modify_expr (&block, var, start);
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);
tmp = build1_v (LOOP_EXPR, body);
gfc_add_expr_to_block (&block, tmp);
tmp = build1_v (LABEL_EXPR, exit_label);
gfc_add_expr_to_block (&block, tmp);
body = gfc_finish_block (&block);
iter = iter->next;
}
return body;
}
static tree
gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
int mask_flag)
{
tree tmp;
stmtblock_t header;
forall_info *forall_tmp;
tree mask, maskindex;
gfc_start_block (&header);
forall_tmp = nested_forall_info;
while (forall_tmp != NULL)
{
if (mask_flag)
{
mask = forall_tmp->mask;
maskindex = forall_tmp->maskindex;
if (mask)
{
tmp = gfc_build_array_ref (mask, maskindex);
body = build3_v (COND_EXPR, tmp, body, build_empty_stmt ());
}
}
body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header);
forall_tmp = forall_tmp->prev_nest;
mask_flag = 1;
}
gfc_add_expr_to_block (&header, body);
return gfc_finish_block (&header);
}
static tree
gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
tree elem_type)
{
tree tmpvar;
tree type;
tree tmp;
tree args;
if (INTEGER_CST_P (size))
{
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
gfc_index_one_node);
}
else
tmp = NULL_TREE;
type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
type = build_array_type (elem_type, type);
if (gfc_can_put_var_on_stack (bytesize))
{
gcc_assert (INTEGER_CST_P (size));
tmpvar = gfc_create_var (type, "temp");
*pdata = NULL_TREE;
}
else
{
tmpvar = gfc_create_var (build_pointer_type (type), "temp");
*pdata = convert (pvoid_type_node, tmpvar);
args = gfc_chainon_list (NULL_TREE, bytesize);
if (gfc_index_integer_kind == 4)
tmp = gfor_fndecl_internal_malloc;
else if (gfc_index_integer_kind == 8)
tmp = gfor_fndecl_internal_malloc64;
else
gcc_unreachable ();
tmp = build_function_call_expr (tmp, args);
tmp = convert (TREE_TYPE (tmpvar), tmp);
gfc_add_modify_expr (pblock, tmpvar, tmp);
}
return tmpvar;
}
static tree
generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
tree count1, tree wheremask, bool invert)
{
gfc_ss *lss;
gfc_se lse, rse;
stmtblock_t block, body;
gfc_loopinfo loop1;
tree tmp;
tree wheremaskexpr;
lss = gfc_walk_expr (expr);
if (lss == gfc_ss_terminator)
{
gfc_start_block (&block);
gfc_init_se (&lse, NULL);
gfc_conv_expr (&lse, expr);
tmp = gfc_build_array_ref (tmp1, count1);
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_modify_expr (&block, lse.expr, tmp);
gfc_add_block_to_block (&block, &lse.post);
tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1,
gfc_index_one_node);
gfc_add_modify_expr (&block, count1, tmp);
tmp = gfc_finish_block (&block);
}
else
{
gfc_start_block (&block);
gfc_init_loopinfo (&loop1);
gfc_init_se (&rse, NULL);
gfc_init_se (&lse, NULL);
gfc_add_ss_to_loop (&loop1, lss);
gfc_conv_ss_startstride (&loop1);
gfc_conv_loop_setup (&loop1);
gfc_mark_ss_chain_used (lss, 1);
gfc_start_scalarized_body (&loop1, &body);
gfc_copy_loopinfo_to_se (&lse, &loop1);
lse.ss = lss;
if (lss != gfc_ss_terminator)
rse.expr = gfc_build_array_ref (tmp1, count1);
gfc_conv_expr (&lse, expr);
rse.string_length = lse.string_length;
tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
if (wheremask)
{
wheremaskexpr = gfc_build_array_ref (wheremask, count3);
if (invert)
wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
TREE_TYPE (wheremaskexpr),
wheremaskexpr);
tmp = fold_build3 (COND_EXPR, void_type_node,
wheremaskexpr, tmp, build_empty_stmt ());
}
gfc_add_expr_to_block (&body, tmp);
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count1, gfc_index_one_node);
gfc_add_modify_expr (&body, count1, tmp);
if (count3)
{
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count3, gfc_index_one_node);
gfc_add_modify_expr (&body, count3, tmp);
}
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);
tmp = gfc_finish_block (&block);
}
return tmp;
}
static tree
generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
tree count1, gfc_ss *lss, gfc_ss *rss,
tree wheremask, bool invert)
{
stmtblock_t block, body1;
gfc_loopinfo loop;
gfc_se lse;
gfc_se rse;
tree tmp;
tree wheremaskexpr;
gfc_start_block (&block);
gfc_init_se (&rse, NULL);
gfc_init_se (&lse, NULL);
if (lss == gfc_ss_terminator)
{
gfc_init_block (&body1);
gfc_conv_expr (&rse, expr2);
lse.expr = gfc_build_array_ref (tmp1, count1);
}
else
{
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, lss);
gfc_add_ss_to_loop (&loop, rss);
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop);
gfc_mark_ss_chain_used (rss, 1);
gfc_start_scalarized_body (&loop, &body1);
gfc_copy_loopinfo_to_se (&rse, &loop);
rse.ss = rss;
gfc_conv_expr (&rse, expr2);
lse.expr = gfc_build_array_ref (tmp1, count1);
}
lse.string_length = rse.string_length;
tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, true,
expr2->expr_type == EXPR_VARIABLE);
if (wheremask)
{
wheremaskexpr = gfc_build_array_ref (wheremask, count3);
if (invert)
wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
TREE_TYPE (wheremaskexpr),
wheremaskexpr);
tmp = fold_build3 (COND_EXPR, void_type_node,
wheremaskexpr, tmp, build_empty_stmt ());
}
gfc_add_expr_to_block (&body1, tmp);
if (lss == gfc_ss_terminator)
{
gfc_add_block_to_block (&block, &body1);
tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1,
gfc_index_one_node);
gfc_add_modify_expr (&block, count1, tmp);
}
else
{
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count1, gfc_index_one_node);
gfc_add_modify_expr (&body1, count1, tmp);
if (count3)
{
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count3, gfc_index_one_node);
gfc_add_modify_expr (&body1, count3, tmp);
}
gfc_trans_scalarizing_loops (&loop, &body1);
gfc_add_block_to_block (&block, &loop.pre);
gfc_add_block_to_block (&block, &loop.post);
gfc_cleanup_loop (&loop);
}
tmp = gfc_finish_block (&block);
return tmp;
}
static tree
compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
stmtblock_t * pblock,
gfc_ss **lss, gfc_ss **rss)
{
gfc_loopinfo loop;
tree size;
int i;
int save_flag;
tree tmp;
*lss = gfc_walk_expr (expr1);
*rss = NULL;
size = gfc_index_one_node;
if (*lss != gfc_ss_terminator)
{
gfc_init_loopinfo (&loop);
*rss = gfc_walk_expr (expr2);
if (*rss == gfc_ss_terminator)
{
*rss = gfc_get_ss ();
(*rss)->next = gfc_ss_terminator;
(*rss)->type = GFC_SS_SCALAR;
(*rss)->expr = expr2;
}
gfc_add_ss_to_loop (&loop, *lss);
gfc_add_ss_to_loop (&loop, *rss);
loop.array_parameter = 1;
save_flag = flag_bounds_check;
flag_bounds_check = 0;
gfc_conv_ss_startstride (&loop);
flag_bounds_check = save_flag;
gfc_conv_loop_setup (&loop);
for (i = 0; i < loop.dimen; i++)
{
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
gfc_index_one_node, loop.from[i]);
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
tmp, loop.to[i]);
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
}
gfc_add_block_to_block (pblock, &loop.pre);
size = gfc_evaluate_now (size, pblock);
gfc_add_block_to_block (pblock, &loop.post);
}
return size;
}
static tree
compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
stmtblock_t *inner_size_body, stmtblock_t *block)
{
tree tmp, number;
stmtblock_t body;
if (INTEGER_CST_P (inner_size) && !nested_forall_info)
return inner_size;
number = gfc_create_var (gfc_array_index_type, "num");
gfc_add_modify_expr (block, number, gfc_index_zero_node);
gfc_start_block (&body);
if (inner_size_body)
gfc_add_block_to_block (&body, inner_size_body);
if (nested_forall_info)
tmp = build2 (PLUS_EXPR, gfc_array_index_type, number,
inner_size);
else
tmp = inner_size;
gfc_add_modify_expr (&body, number, tmp);
tmp = gfc_finish_block (&body);
if (nested_forall_info != NULL)
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
gfc_add_expr_to_block (block, tmp);
return number;
}
static tree
allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block,
tree * ptemp1)
{
tree bytesize;
tree unit;
tree tmp;
unit = TYPE_SIZE_UNIT (type);
if (!integer_onep (unit))
bytesize = fold_build2 (MULT_EXPR, gfc_array_index_type, size, unit);
else
bytesize = size;
*ptemp1 = NULL;
tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type);
if (*ptemp1)
tmp = build_fold_indirect_ref (tmp);
return tmp;
}
static tree
allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
tree inner_size, stmtblock_t * inner_size_body,
stmtblock_t * block, tree * ptemp1)
{
tree size;
size = compute_overall_iter_number (nested_forall_info, inner_size,
inner_size_body, block);
return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1);
}
static void
gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
tree wheremask, bool invert,
forall_info * nested_forall_info,
stmtblock_t * block)
{
tree type;
tree inner_size;
gfc_ss *lss, *rss;
tree count, count1;
tree tmp, tmp1;
tree ptemp1;
stmtblock_t inner_size_body;
count1 = gfc_create_var (gfc_array_index_type, "count1");
if (wheremask)
{
count = gfc_create_var (gfc_array_index_type, "count");
gfc_add_modify_expr (block, count, gfc_index_zero_node);
}
else
count = NULL;
gfc_add_modify_expr (block, count1, gfc_index_zero_node);
gfc_init_block (&inner_size_body);
inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
&lss, &rss);
type = gfc_typenode_for_spec (&expr1->ts);
tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
&inner_size_body, block, &ptemp1);
tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss,
wheremask, invert);
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
gfc_add_expr_to_block (block, tmp);
gfc_add_modify_expr (block, count1, gfc_index_zero_node);
if (wheremask)
gfc_add_modify_expr (block, count, gfc_index_zero_node);
tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
wheremask, invert);
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
gfc_add_expr_to_block (block, tmp);
if (ptemp1)
{
tmp = gfc_chainon_list (NULL_TREE, ptemp1);
tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
gfc_add_expr_to_block (block, tmp);
}
}
static void
gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
forall_info * nested_forall_info,
stmtblock_t * block)
{
tree type;
tree inner_size;
gfc_ss *lss, *rss;
gfc_se lse;
gfc_se rse;
gfc_ss_info *info;
gfc_loopinfo loop;
tree desc;
tree parm;
tree parmtype;
stmtblock_t body;
tree count;
tree tmp, tmp1, ptemp1;
count = gfc_create_var (gfc_array_index_type, "count");
gfc_add_modify_expr (block, count, gfc_index_zero_node);
inner_size = integer_one_node;
lss = gfc_walk_expr (expr1);
rss = gfc_walk_expr (expr2);
if (lss == gfc_ss_terminator)
{
type = gfc_typenode_for_spec (&expr1->ts);
type = build_pointer_type (type);
tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
inner_size, NULL, block, &ptemp1);
gfc_start_block (&body);
gfc_init_se (&lse, NULL);
lse.expr = gfc_build_array_ref (tmp1, count);
gfc_init_se (&rse, NULL);
rse.want_pointer = 1;
gfc_conv_expr (&rse, expr2);
gfc_add_block_to_block (&body, &rse.pre);
gfc_add_modify_expr (&body, lse.expr,
fold_convert (TREE_TYPE (lse.expr), rse.expr));
gfc_add_block_to_block (&body, &rse.post);
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count, gfc_index_one_node);
gfc_add_modify_expr (&body, count, tmp);
tmp = gfc_finish_block (&body);
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
gfc_add_expr_to_block (block, tmp);
gfc_add_modify_expr (block, count, gfc_index_zero_node);
gfc_start_block (&body);
gfc_init_se (&lse, NULL);
gfc_init_se (&rse, NULL);
rse.expr = gfc_build_array_ref (tmp1, count);
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_block_to_block (&body, &lse.post);
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count, gfc_index_one_node);
gfc_add_modify_expr (&body, count, tmp);
tmp = gfc_finish_block (&body);
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
gfc_add_expr_to_block (block, tmp);
}
else
{
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, rss);
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop);
info = &rss->data.info;
desc = info->descriptor;
parmtype = gfc_get_element_type (TREE_TYPE (desc));
parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
loop.from, loop.to, 1);
tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
inner_size, NULL, block, &ptemp1);
gfc_start_block (&body);
gfc_init_se (&lse, NULL);
lse.expr = gfc_build_array_ref (tmp1, count);
lse.direct_byref = 1;
rss = gfc_walk_expr (expr2);
gfc_conv_expr_descriptor (&lse, expr2, rss);
gfc_add_block_to_block (&body, &lse.pre);
gfc_add_block_to_block (&body, &lse.post);
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count, gfc_index_one_node);
gfc_add_modify_expr (&body, count, tmp);
tmp = gfc_finish_block (&body);
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
gfc_add_expr_to_block (block, tmp);
gfc_add_modify_expr (block, count, gfc_index_zero_node);
parm = gfc_build_array_ref (tmp1, count);
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_start_block (&body);
gfc_add_block_to_block (&body, &lse.pre);
gfc_add_block_to_block (&body, &lse.post);
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count, gfc_index_one_node);
gfc_add_modify_expr (&body, count, tmp);
tmp = gfc_finish_block (&body);
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
gfc_add_expr_to_block (block, tmp);
}
if (ptemp1)
{
tmp = gfc_chainon_list (NULL_TREE, ptemp1);
tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
gfc_add_expr_to_block (block, tmp);
}
}
static tree
gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
{
stmtblock_t block;
stmtblock_t body;
tree *var;
tree *start;
tree *end;
tree *step;
gfc_expr **varexpr;
tree tmp;
tree assign;
tree size;
tree maskindex;
tree mask;
tree pmask;
int n;
int nvar;
int need_temp;
gfc_forall_iterator *fa;
gfc_se se;
gfc_code *c;
gfc_saved_var *saved_vars;
iter_info *this_forall;
forall_info *info;
n = 0;
for (fa = code->ext.forall_iterator; fa; fa = fa->next)
n++;
nvar = n;
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));
info = (forall_info *) gfc_getmem (sizeof (forall_info));
gfc_start_block (&block);
n = 0;
for (fa = code->ext.forall_iterator; fa; fa = fa->next)
{
gfc_symbol *sym = fa->var->symtree->n.sym;
this_forall = (iter_info *) gfc_getmem (sizeof (iter_info));
tmp = gfc_typenode_for_spec (&sym->ts);
var[n] = gfc_create_var (tmp, sym->name);
gfc_shadow_sym (sym, var[n], &saved_vars[n]);
this_forall->var = var[n];
sym->backend_decl = var[n];
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, fa->start);
this_forall->start = se.expr;
gfc_add_block_to_block (&block, &se.pre);
start[n] = se.expr;
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, fa->end);
this_forall->end = se.expr;
gfc_make_safe_expr (&se);
gfc_add_block_to_block (&block, &se.pre);
end[n] = se.expr;
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, fa->stride);
this_forall->step = se.expr;
gfc_make_safe_expr (&se);
gfc_add_block_to_block (&block, &se.pre);
step[n] = se.expr;
this_forall->next = NULL;
if (info->this_loop)
{
iter_info *iter_tmp = info->this_loop;
while (iter_tmp->next != NULL)
iter_tmp = iter_tmp->next;
iter_tmp->next = this_forall;
}
else
info->this_loop = this_forall;
n++;
}
nvar = n;
size = gfc_index_one_node;
for (n = 0; n < nvar; n++)
{
tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (start[n]),
step[n], start[n]);
tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (end[n]), end[n], tmp);
tmp = fold_build2 (FLOOR_DIV_EXPR, TREE_TYPE (tmp), tmp, step[n]);
tmp = convert (gfc_array_index_type, tmp);
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
}
info->nvar = nvar;
info->size = size;
if (code->expr)
{
tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
mask = allocate_temp_for_forall_nest (nested_forall_info, mask_type,
size, NULL, &block, &pmask);
maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
info->maskindex = maskindex;
info->mask = mask;
}
else
{
maskindex = NULL_TREE;
mask = pmask = NULL_TREE;
}
info->prev_nest = nested_forall_info;
nested_forall_info = info;
if (code->expr)
{
tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
gfc_start_block (&body);
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, code->expr);
gfc_add_block_to_block (&body, &se.pre);
se.expr = convert (mask_type, se.expr);
tmp = gfc_build_array_ref (mask, maskindex);
gfc_add_modify_expr (&body, tmp, se.expr);
tmp = build2 (PLUS_EXPR, gfc_array_index_type,
maskindex, gfc_index_one_node);
gfc_add_modify_expr (&body, maskindex, tmp);
tmp = gfc_finish_block (&body);
tmp = gfc_trans_nested_forall_loop (info, tmp, 0);
gfc_add_expr_to_block (&block, tmp);
}
c = code->block->next;
while (c)
{
switch (c->op)
{
case EXEC_ASSIGN:
need_temp = gfc_check_dependency (c->expr, c->expr2, 0);
if (need_temp)
gfc_trans_assign_need_temp (c->expr, c->expr2, NULL, false,
nested_forall_info, &block);
else
{
assign = gfc_trans_assignment (c->expr, c->expr2, false);
tmp = gfc_trans_nested_forall_loop (nested_forall_info,
assign, 1);
gfc_add_expr_to_block (&block, tmp);
}
break;
case EXEC_WHERE:
gfc_trans_where_2 (c, NULL, false, nested_forall_info, &block);
break;
case EXEC_POINTER_ASSIGN:
need_temp = gfc_check_dependency (c->expr, c->expr2, 0);
if (need_temp)
gfc_trans_pointer_assign_need_temp (c->expr, c->expr2,
nested_forall_info, &block);
else
{
assign = gfc_trans_pointer_assignment (c->expr, c->expr2);
tmp = gfc_trans_nested_forall_loop (nested_forall_info,
assign, 1);
gfc_add_expr_to_block (&block, tmp);
}
break;
case EXEC_FORALL:
tmp = gfc_trans_forall_1 (c, nested_forall_info);
gfc_add_expr_to_block (&block, tmp);
break;
case EXEC_ASSIGN_CALL:
assign = gfc_trans_call (c, true);
tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1);
gfc_add_expr_to_block (&block, tmp);
break;
default:
gcc_unreachable ();
}
c = c->next;
}
for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
gfc_free (var);
gfc_free (start);
gfc_free (end);
gfc_free (step);
gfc_free (varexpr);
gfc_free (saved_vars);
gfc_free (info);
if (pmask)
{
tmp = gfc_chainon_list (NULL_TREE, pmask);
tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
gfc_add_expr_to_block (&block, tmp);
}
if (maskindex)
pushdecl (maskindex);
return gfc_finish_block (&block);
}
tree gfc_trans_forall (gfc_code * code)
{
return gfc_trans_forall_1 (code, NULL);
}
static void
gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
tree mask, bool invert, tree cmask, tree pmask,
tree mask_type, stmtblock_t * block)
{
tree tmp, tmp1;
gfc_ss *lss, *rss;
gfc_loopinfo loop;
stmtblock_t body, body1;
tree count, cond, mtmp;
gfc_se lse, rse;
gfc_init_loopinfo (&loop);
lss = gfc_walk_expr (me);
rss = gfc_walk_expr (me);
count = gfc_create_var (gfc_array_index_type, "count");
gfc_add_modify_expr (block, count, gfc_index_zero_node);
gfc_start_block (&body);
gfc_init_se (&rse, NULL);
gfc_init_se (&lse, NULL);
if (lss == gfc_ss_terminator)
{
gfc_init_block (&body1);
}
else
{
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, lss);
gfc_add_ss_to_loop (&loop, rss);
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop);
gfc_mark_ss_chain_used (rss, 1);
gfc_start_scalarized_body (&loop, &body1);
gfc_copy_loopinfo_to_se (&rse, &loop);
rse.ss = rss;
gfc_conv_expr (&rse, me);
}
cond = gfc_create_var (mask_type, "cond");
if (mask && (cmask || pmask))
mtmp = gfc_create_var (mask_type, "mask");
else mtmp = NULL_TREE;
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));
if (mask && (cmask || pmask))
{
tmp = gfc_build_array_ref (mask, count);
if (invert)
tmp = fold_build1 (TRUTH_NOT_EXPR, mask_type, tmp);
gfc_add_modify_expr (&body1, mtmp, tmp);
}
if (cmask)
{
tmp1 = gfc_build_array_ref (cmask, count);
tmp = cond;
if (mask)
tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
gfc_add_modify_expr (&body1, tmp1, tmp);
}
if (pmask)
{
tmp1 = gfc_build_array_ref (pmask, count);
tmp = build1 (TRUTH_NOT_EXPR, mask_type, cond);
if (mask)
tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
gfc_add_modify_expr (&body1, tmp1, tmp);
}
gfc_add_block_to_block (&body1, &lse.post);
gfc_add_block_to_block (&body1, &rse.post);
if (lss == gfc_ss_terminator)
{
gfc_add_block_to_block (&body, &body1);
}
else
{
tmp1 = fold_build2 (PLUS_EXPR, gfc_array_index_type, count,
gfc_index_one_node);
gfc_add_modify_expr (&body1, count, tmp1);
gfc_trans_scalarizing_loops (&loop, &body1);
gfc_add_block_to_block (&body, &loop.pre);
gfc_add_block_to_block (&body, &loop.post);
gfc_cleanup_loop (&loop);
}
tmp1 = gfc_finish_block (&body);
if (nested_forall_info != NULL)
tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1);
gfc_add_expr_to_block (block, tmp1);
}
static tree
gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
tree mask, bool invert,
tree count1, tree count2,
gfc_symbol *sym)
{
gfc_se lse;
gfc_se rse;
gfc_ss *lss;
gfc_ss *lss_section;
gfc_ss *rss;
gfc_loopinfo loop;
tree tmp;
stmtblock_t block;
stmtblock_t body;
tree index, maskexpr;
#if 0
if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
{
tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
if (tmp)
return tmp;
}
#endif
gfc_start_block (&block);
gfc_init_se (&lse, NULL);
gfc_init_se (&rse, NULL);
lss = gfc_walk_expr (expr1);
rss = NULL;
gcc_assert (lss != gfc_ss_terminator);
lss_section = lss;
while (lss_section != gfc_ss_terminator
&& lss_section->type != GFC_SS_SECTION)
lss_section = lss_section->next;
gcc_assert (lss_section != gfc_ss_terminator);
gfc_init_loopinfo (&loop);
rss = gfc_walk_expr (expr2);
if (rss == gfc_ss_terminator)
{
rss = gfc_get_ss ();
rss->next = gfc_ss_terminator;
rss->type = GFC_SS_SCALAR;
rss->expr = expr2;
}
gfc_add_ss_to_loop (&loop, lss);
gfc_add_ss_to_loop (&loop, rss);
gfc_conv_ss_startstride (&loop);
gfc_conv_resolve_dependencies (&loop, lss_section, rss);
gfc_conv_loop_setup (&loop);
gfc_copy_loopinfo_to_se (&lse, &loop);
gfc_copy_loopinfo_to_se (&rse, &loop);
rse.ss = rss;
gfc_mark_ss_chain_used (rss, 1);
if (loop.temp_ss == NULL)
{
lse.ss = lss;
gfc_mark_ss_chain_used (lss, 1);
}
else
{
lse.ss = loop.temp_ss;
gfc_mark_ss_chain_used (lss, 3);
gfc_mark_ss_chain_used (loop.temp_ss, 3);
}
gfc_start_scalarized_body (&loop, &body);
gfc_conv_expr (&rse, expr2);
if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
{
gfc_conv_tmp_array_ref (&lse);
gfc_advance_se_ss_chain (&lse);
}
else
gfc_conv_expr (&lse, expr1);
index = count1;
maskexpr = gfc_build_array_ref (mask, index);
if (invert)
maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
if (sym == NULL)
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
loop.temp_ss != NULL, false);
else
tmp = gfc_conv_operator_assign (&lse, &rse, sym);
tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&body, tmp);
if (lss == gfc_ss_terminator)
{
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count1, gfc_index_one_node);
gfc_add_modify_expr (&body, count1, tmp);
gfc_add_block_to_block (&block, &body);
}
else
{
gcc_assert (lse.ss == gfc_ss_terminator
&& rse.ss == gfc_ss_terminator);
if (loop.temp_ss != NULL)
{
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count1, gfc_index_one_node);
gfc_add_modify_expr (&body, count1, tmp);
gfc_trans_scalarized_loop_boundary (&loop, &body);
gfc_init_se (&lse, NULL);
gfc_init_se (&rse, NULL);
gfc_copy_loopinfo_to_se (&lse, &loop);
gfc_copy_loopinfo_to_se (&rse, &loop);
rse.ss = loop.temp_ss;
lse.ss = lss;
gfc_conv_tmp_array_ref (&rse);
gfc_advance_se_ss_chain (&rse);
gfc_conv_expr (&lse, expr1);
gcc_assert (lse.ss == gfc_ss_terminator
&& rse.ss == gfc_ss_terminator);
index = count2;
maskexpr = gfc_build_array_ref (mask, index);
if (invert)
maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr),
maskexpr);
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&body, tmp);
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count2, gfc_index_one_node);
gfc_add_modify_expr (&body, count2, tmp);
}
else
{
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
count1, gfc_index_one_node);
gfc_add_modify_expr (&body, count1, tmp);
}
gfc_trans_scalarizing_loops (&loop, &body);
gfc_add_block_to_block (&block, &loop.pre);
gfc_add_block_to_block (&block, &loop.post);
gfc_cleanup_loop (&loop);
}
return gfc_finish_block (&block);
}
static void
gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
forall_info * nested_forall_info, stmtblock_t * block)
{
stmtblock_t inner_size_body;
tree inner_size, size;
gfc_ss *lss, *rss;
tree mask_type;
gfc_expr *expr1;
gfc_expr *expr2;
gfc_code *cblock;
gfc_code *cnext;
tree tmp;
tree count1, count2;
bool need_cmask;
bool need_pmask;
int need_temp;
tree pcmask = NULL_TREE;
tree ppmask = NULL_TREE;
tree cmask = NULL_TREE;
tree pmask = NULL_TREE;
gfc_actual_arglist *arg;
cblock = code->block;
mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
if (!cblock->block)
{
need_cmask = (cblock->next != 0);
need_pmask = false;
}
else if (cblock->block->block)
{
need_cmask = true;
need_pmask = true;
}
else if (cblock->next)
{
need_cmask = true;
need_pmask = (mask != NULL_TREE
&& cblock->block->next != 0);
}
else if (!cblock->block->next)
{
need_cmask = false;
need_pmask = false;
}
else if (mask)
{
need_cmask = (cblock->block->expr != 0);
need_pmask = true;
}
else
{
need_cmask = true;
need_pmask = false;
}
if (need_cmask || need_pmask)
{
gfc_init_block (&inner_size_body);
inner_size = compute_inner_temp_size (cblock->expr, cblock->expr,
&inner_size_body, &lss, &rss);
size = compute_overall_iter_number (nested_forall_info, inner_size,
&inner_size_body, block);
if (need_cmask)
cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
&pcmask);
if (need_pmask)
pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
&ppmask);
}
while (cblock)
{
if (cblock->expr)
{
if (mask)
gfc_evaluate_where_mask (cblock->expr, nested_forall_info,
mask, invert,
cblock->next ? cmask : NULL_TREE,
cblock->block ? pmask : NULL_TREE,
mask_type, block);
else
gfc_evaluate_where_mask (cblock->expr, nested_forall_info,
NULL_TREE, false,
(cblock->next || cblock->block)
? cmask : NULL_TREE,
NULL_TREE, mask_type, block);
invert = false;
}
else
cmask = mask;
cnext = cblock->next;
while (cnext)
{
switch (cnext->op)
{
case EXEC_ASSIGN_CALL:
arg = cnext->ext.actual;
expr1 = expr2 = NULL;
for (; arg; arg = arg->next)
{
if (!arg->expr)
continue;
if (expr1 == NULL)
expr1 = arg->expr;
else
expr2 = arg->expr;
}
goto evaluate;
case EXEC_ASSIGN:
expr1 = cnext->expr;
expr2 = cnext->expr2;
evaluate:
if (nested_forall_info != NULL)
{
need_temp = gfc_check_dependency (expr1, expr2, 0);
if (need_temp && cnext->op != EXEC_ASSIGN_CALL)
gfc_trans_assign_need_temp (expr1, expr2,
cmask, invert,
nested_forall_info, block);
else
{
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);
tmp = gfc_trans_where_assign (expr1, expr2,
cmask, invert,
count1, count2,
cnext->resolved_sym);
tmp = gfc_trans_nested_forall_loop (nested_forall_info,
tmp, 1);
gfc_add_expr_to_block (block, tmp);
}
}
else
{
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);
tmp = gfc_trans_where_assign (expr1, expr2,
cmask, invert,
count1, count2,
cnext->resolved_sym);
gfc_add_expr_to_block (block, tmp);
}
break;
case EXEC_WHERE:
gfc_trans_where_2 (cnext, cmask, invert,
nested_forall_info, block);
break;
default:
gcc_unreachable ();
}
cnext = cnext->next;
}
cblock = cblock->block;
if (mask == NULL_TREE)
{
invert = true;
mask = cmask;
}
else
{
invert = false;
mask = pmask;
}
}
if (ppmask)
{
tree args = gfc_chainon_list (NULL_TREE, ppmask);
tmp = build_function_call_expr (gfor_fndecl_internal_free, args);
gfc_add_expr_to_block (block, tmp);
}
if (pcmask)
{
tree args = gfc_chainon_list (NULL_TREE, pcmask);
tmp = build_function_call_expr (gfor_fndecl_internal_free, args);
gfc_add_expr_to_block (block, tmp);
}
}
static tree
gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
{
stmtblock_t block, body;
gfc_expr *cond, *tdst, *tsrc, *edst, *esrc;
tree tmp, cexpr, tstmt, estmt;
gfc_ss *css, *tdss, *tsss;
gfc_se cse, tdse, tsse, edse, esse;
gfc_loopinfo loop;
gfc_ss *edss = 0;
gfc_ss *esss = 0;
cond = cblock->expr;
tdst = cblock->next->expr;
tsrc = cblock->next->expr2;
edst = eblock ? eblock->next->expr : NULL;
esrc = eblock ? eblock->next->expr2 : NULL;
gfc_start_block (&block);
gfc_init_loopinfo (&loop);
gfc_init_se (&cse, NULL);
css = gfc_walk_expr (cond);
gfc_add_ss_to_loop (&loop, css);
gfc_init_se (&tdse, NULL);
gfc_init_se (&tsse, NULL);
tdss = gfc_walk_expr (tdst);
tsss = gfc_walk_expr (tsrc);
if (tsss == gfc_ss_terminator)
{
tsss = gfc_get_ss ();
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);
if (eblock)
{
gfc_init_se (&edse, NULL);
gfc_init_se (&esse, NULL);
edss = gfc_walk_expr (edst);
esss = gfc_walk_expr (esrc);
if (esss == gfc_ss_terminator)
{
esss = gfc_get_ss ();
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);
}
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop);
gfc_mark_ss_chain_used (css, 1);
gfc_mark_ss_chain_used (tdss, 1);
gfc_mark_ss_chain_used (tsss, 1);
if (eblock)
{
gfc_mark_ss_chain_used (edss, 1);
gfc_mark_ss_chain_used (esss, 1);
}
gfc_start_scalarized_body (&loop, &body);
gfc_copy_loopinfo_to_se (&cse, &loop);
gfc_copy_loopinfo_to_se (&tdse, &loop);
gfc_copy_loopinfo_to_se (&tsse, &loop);
cse.ss = css;
tdse.ss = tdss;
tsse.ss = tsss;
if (eblock)
{
gfc_copy_loopinfo_to_se (&edse, &loop);
gfc_copy_loopinfo_to_se (&esse, &loop);
edse.ss = edss;
esse.ss = esss;
}
gfc_conv_expr (&cse, cond);
gfc_add_block_to_block (&body, &cse.pre);
cexpr = cse.expr;
gfc_conv_expr (&tsse, tsrc);
if (tdss != gfc_ss_terminator && loop.temp_ss != NULL)
{
gfc_conv_tmp_array_ref (&tdse);
gfc_advance_se_ss_chain (&tdse);
}
else
gfc_conv_expr (&tdse, tdst);
if (eblock)
{
gfc_conv_expr (&esse, esrc);
if (edss != gfc_ss_terminator && loop.temp_ss != NULL)
{
gfc_conv_tmp_array_ref (&edse);
gfc_advance_se_ss_chain (&edse);
}
else
gfc_conv_expr (&edse, edst);
}
tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false);
estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, false)
: build_empty_stmt ();
tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
gfc_add_expr_to_block (&body, tmp);
gfc_add_block_to_block (&body, &cse.post);
gfc_trans_scalarizing_loops (&loop, &body);
gfc_add_block_to_block (&block, &loop.pre);
gfc_add_block_to_block (&block, &loop.post);
gfc_cleanup_loop (&loop);
return gfc_finish_block (&block);
}
tree
gfc_trans_where (gfc_code * code)
{
stmtblock_t block;
gfc_code *cblock;
gfc_code *eblock;
cblock = code->block;
if (cblock->next
&& cblock->next->op == EXEC_ASSIGN
&& !cblock->next->next)
{
eblock = cblock->block;
if (!eblock)
{
if (!gfc_check_dependency (cblock->next->expr,
cblock->expr, 0)
&& !gfc_check_dependency (cblock->next->expr,
cblock->next->expr2, 0))
return gfc_trans_where_3 (cblock, NULL);
}
else if (!eblock->expr
&& !eblock->block
&& eblock->next
&& eblock->next->op == EXEC_ASSIGN
&& !eblock->next->next)
{
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)
&& !gfc_check_dependency(eblock->next->expr,
cblock->next->expr2, 0)
&& !gfc_check_dependency(cblock->next->expr,
cblock->next->expr2, 0)
&& !gfc_check_dependency(eblock->next->expr,
eblock->next->expr2, 0))
return gfc_trans_where_3 (cblock, eblock);
}
}
gfc_start_block (&block);
gfc_trans_where_2 (code, NULL, false, NULL, &block);
return gfc_finish_block (&block);
}
tree
gfc_trans_cycle (gfc_code * code)
{
tree cycle_label;
cycle_label = TREE_PURPOSE (code->ext.whichloop->backend_decl);
TREE_USED (cycle_label) = 1;
return build1_v (GOTO_EXPR, cycle_label);
}
tree
gfc_trans_exit (gfc_code * code)
{
tree exit_label;
exit_label = TREE_VALUE (code->ext.whichloop->backend_decl);
TREE_USED (exit_label) = 1;
return build1_v (GOTO_EXPR, exit_label);
}
tree
gfc_trans_allocate (gfc_code * code)
{
gfc_alloc *al;
gfc_expr *expr;
gfc_se se;
tree tmp;
tree parm;
tree stat;
tree pstat;
tree error_label;
stmtblock_t block;
if (!code->ext.alloc_list)
return NULL_TREE;
gfc_start_block (&block);
if (code->expr)
{
tree gfc_int4_type_node = gfc_get_int_type (4);
stat = gfc_create_var (gfc_int4_type_node, "stat");
pstat = build_fold_addr_expr (stat);
error_label = gfc_build_label_decl (NULL_TREE);
TREE_USED (error_label) = 1;
}
else
{
pstat = integer_zero_node;
stat = error_label = NULL_TREE;
}
for (al = code->ext.alloc_list; al != NULL; al = al->next)
{
expr = al->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))
{
tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE)
tmp = se.string_length;
parm = gfc_chainon_list (NULL_TREE, tmp);
parm = gfc_chainon_list (parm, pstat);
tmp = build_function_call_expr (gfor_fndecl_allocate, parm);
tmp = build2 (MODIFY_EXPR, void_type_node, se.expr, tmp);
gfc_add_expr_to_block (&se.pre, tmp);
if (code->expr)
{
tmp = build1_v (GOTO_EXPR, error_label);
parm = fold_build2 (NE_EXPR, boolean_type_node,
stat, build_int_cst (TREE_TYPE (stat), 0));
tmp = fold_build3 (COND_EXPR, void_type_node,
parm, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&se.pre, tmp);
}
if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
{
tmp = build_fold_indirect_ref (se.expr);
tmp = gfc_nullify_alloc_comp (expr->ts.derived, tmp, 0);
gfc_add_expr_to_block (&se.pre, tmp);
}
}
tmp = gfc_finish_block (&se.pre);
gfc_add_expr_to_block (&block, tmp);
}
if (code->expr)
{
tmp = build1_v (LABEL_EXPR, error_label);
gfc_add_expr_to_block (&block, tmp);
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);
}
return gfc_finish_block (&block);
}
tree
gfc_trans_deallocate (gfc_code * code)
{
gfc_se se;
gfc_alloc *al;
gfc_expr *expr;
tree apstat, astat, parm, pstat, stat, tmp;
stmtblock_t block;
gfc_start_block (&block);
if (code->expr)
{
tree gfc_int4_type_node = gfc_get_int_type (4);
stat = gfc_create_var (gfc_int4_type_node, "stat");
pstat = build_fold_addr_expr (stat);
astat = gfc_create_var (gfc_int4_type_node, "astat");
apstat = build_fold_addr_expr (astat);
gfc_add_modify_expr (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
}
else
{
pstat = apstat = null_pointer_node;
stat = astat = NULL_TREE;
}
for (al = code->ext.alloc_list; al != NULL; al = al->next)
{
expr = al->expr;
gcc_assert (expr->expr_type == EXPR_VARIABLE);
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
se.want_pointer = 1;
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
if (expr->ts.type == BT_DERIVED
&& expr->ts.derived->attr.alloc_comp)
{
gfc_ref *ref;
gfc_ref *last = NULL;
for (ref = expr->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT)
last = ref;
if (!(last && last->u.c.component->pointer)
&& !(!last && expr->symtree->n.sym->attr.pointer))
{
tmp = gfc_deallocate_alloc_comp (expr->ts.derived, se.expr,
expr->rank);
gfc_add_expr_to_block (&se.pre, tmp);
}
}
if (expr->rank)
tmp = gfc_array_deallocate (se.expr, pstat);
else
{
parm = gfc_chainon_list (NULL_TREE, se.expr);
parm = gfc_chainon_list (parm, pstat);
tmp = build_function_call_expr (gfor_fndecl_deallocate, parm);
gfc_add_expr_to_block (&se.pre, tmp);
tmp = build2 (MODIFY_EXPR, void_type_node,
se.expr, build_int_cst (TREE_TYPE (se.expr), 0));
}
gfc_add_expr_to_block (&se.pre, tmp);
if (code->expr)
{
apstat = build2 (PLUS_EXPR, TREE_TYPE (stat), astat, stat);
gfc_add_modify_expr (&se.pre, astat, apstat);
}
tmp = gfc_finish_block (&se.pre);
gfc_add_expr_to_block (&block, tmp);
}
if (code->expr)
{
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);
}
return gfc_finish_block (&block);
}