/* Pass manager for Fortran front end.
- Copyright (C) 2010 Free Software Foundation, Inc.
+ Copyright (C) 2010, 2011 Free Software Foundation, Inc.
Contributed by Thomas König.
This file is part of GCC.
static bool optimize_op (gfc_expr *);
static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op);
static bool optimize_trim (gfc_expr *);
+static bool optimize_lexical_comparison (gfc_expr *);
+static void optimize_minmaxloc (gfc_expr **);
/* How deep we are inside an argument list. */
static int expr_size, expr_count;
/* Pointer to the gfc_code we currently work on - to be able to insert
- a statement before. */
+ a block before the statement. */
static gfc_code **current_code;
+/* Pointer to the block to be inserted, and the statement we are
+ changing within the block. */
+
+static gfc_code *inserted_block, **changed_statement;
+
/* The namespace we are currently dealing with. */
-gfc_namespace *current_ns;
+static gfc_namespace *current_ns;
+
+/* If we are within any forall loop. */
+
+static int forall_level;
+
+/* Keep track of whether we are within an OMP workshare. */
+
+static bool in_omp_workshare;
+
+/* Keep track of iterators for array constructors. */
+
+static int iterator_level;
/* Entry point - run all passes for a namespace. So far, only an
optimization pass is run. */
void
gfc_run_passes (gfc_namespace *ns)
{
- if (optimize)
+ if (gfc_option.flag_frontend_optimize)
{
expr_size = 20;
expr_array = XNEWVEC(gfc_expr **, expr_size);
if (gfc_option.dump_fortran_optimized)
gfc_dump_parse_tree (ns, stdout);
- /* FIXME: The following should be XDELETEVEC(expr_array);
- but we cannot do that because it depends on free. */
- gfc_free (expr_array);
+ XDELETEVEC (expr_array);
}
}
if (optimize_trim (*e))
gfc_simplify_expr (*e, 0);
+ if (optimize_lexical_comparison (*e))
+ gfc_simplify_expr (*e, 0);
+
if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
gfc_simplify_expr (*e, 0);
+ if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym)
+ switch ((*e)->value.function.isym->id)
+ {
+ case GFC_ISYM_MINLOC:
+ case GFC_ISYM_MAXLOC:
+ optimize_minmaxloc (e);
+ break;
+ default:
+ break;
+ }
+
if (function_expr)
count_arglist --;
/* Callback function for common function elimination, called from cfe_expr_0.
- Put all eligible function expressions into expr_array. We can't do
- allocatable functions. */
+ Put all eligible function expressions into expr_array. */
static int
cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
void *data ATTRIBUTE_UNUSED)
{
+
if ((*e)->expr_type != EXPR_FUNCTION)
return 0;
- /* We don't do character functions (yet). */
- if ((*e)->ts.type == BT_CHARACTER)
+ /* We don't do character functions with unknown charlens. */
+ if ((*e)->ts.type == BT_CHARACTER
+ && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL
+ || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT))
+ return 0;
+
+ /* We don't do function elimination within FORALL statements, it can
+ lead to wrong-code in certain circumstances. */
+
+ if (forall_level > 0)
return 0;
- /* If we don't know the shape at compile time, we do not create a temporary
- variable to hold the intermediate result. FIXME: Change this later when
- allocation on assignment works for intrinsics. */
+ /* Function elimination inside an iterator could lead to functions
+ which depend on iterator variables being moved outside. */
- if ((*e)->rank > 0 && (*e)->shape == NULL)
+ if (iterator_level > 0)
+ return 0;
+
+ /* If we don't know the shape at compile time, we create an allocatable
+ temporary variable to hold the intermediate result, but only if
+ allocation on assignment is active. */
+
+ if ((*e)->rank > 0 && (*e)->shape == NULL && !gfc_option.flag_realloc_lhs)
return 0;
/* Skip the test for pure functions if -faggressive-function-elimination
is specified. */
if ((*e)->value.function.esym)
{
- if ((*e)->value.function.esym->attr.allocatable)
- return 0;
-
/* Don't create an array temporary for elemental functions. */
if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0)
return 0;
if ((*e)->value.function.isym)
{
/* Conversions are handled on the fly by the middle end,
- transpose during trans-* stages. */
+ transpose during trans-* stages and TRANSFER by the middle end. */
if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION
- || (*e)->value.function.isym->id == GFC_ISYM_TRANSPOSE)
+ || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER
+ || gfc_inline_intrinsic_function_p (*e))
return 0;
/* Don't create an array temporary for elemental functions,
/* Returns a new expression (a variable) to be used in place of the old one,
with an an assignment statement before the current statement to set
- the value of the variable. */
+ the value of the variable. Creates a new BLOCK for the statement if
+ that hasn't already been done and puts the statement, plus the
+ newly created variables, in that block. */
static gfc_expr*
create_var (gfc_expr * e)
gfc_symbol *symbol;
gfc_expr *result;
gfc_code *n;
+ gfc_namespace *ns;
int i;
+ /* If the block hasn't already been created, do so. */
+ if (inserted_block == NULL)
+ {
+ inserted_block = XCNEW (gfc_code);
+ inserted_block->op = EXEC_BLOCK;
+ inserted_block->loc = (*current_code)->loc;
+ ns = gfc_build_block_ns (current_ns);
+ inserted_block->ext.block.ns = ns;
+ inserted_block->ext.block.assoc = NULL;
+
+ ns->code = *current_code;
+
+ /* If the statement has a label, make sure it is transferred to
+ the newly created block. */
+
+ if ((*current_code)->here)
+ {
+ inserted_block->here = (*current_code)->here;
+ (*current_code)->here = NULL;
+ }
+
+ inserted_block->next = (*current_code)->next;
+ changed_statement = &(inserted_block->ext.block.ns->code);
+ (*current_code)->next = NULL;
+ /* Insert the BLOCK at the right position. */
+ *current_code = inserted_block;
+ ns->parent = current_ns;
+ }
+ else
+ ns = inserted_block->ext.block.ns;
+
sprintf(name, "__var_%d",num++);
- if (gfc_get_sym_tree (name, current_ns, &symtree, false) != 0)
+ if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
gcc_unreachable ();
symbol = symtree->n.sym;
symbol->ts = e->ts;
- symbol->as = gfc_get_array_spec ();
- symbol->as->rank = e->rank;
- symbol->as->type = AS_EXPLICIT;
- for (i=0; i<e->rank; i++)
+
+ if (e->rank > 0)
{
- gfc_expr *p, *q;
+ symbol->as = gfc_get_array_spec ();
+ symbol->as->rank = e->rank;
+
+ if (e->shape == NULL)
+ {
+ /* We don't know the shape at compile time, so we use an
+ allocatable. */
+ symbol->as->type = AS_DEFERRED;
+ symbol->attr.allocatable = 1;
+ }
+ else
+ {
+ symbol->as->type = AS_EXPLICIT;
+ /* Copy the shape. */
+ for (i=0; i<e->rank; i++)
+ {
+ gfc_expr *p, *q;
- p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
- &(e->where));
- mpz_set_si (p->value.integer, 1);
- symbol->as->lower[i] = p;
-
- q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
- &(e->where));
- mpz_set (q->value.integer, e->shape[i]);
- symbol->as->upper[i] = q;
+ p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &(e->where));
+ mpz_set_si (p->value.integer, 1);
+ symbol->as->lower[i] = p;
+
+ q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
+ &(e->where));
+ mpz_set (q->value.integer, e->shape[i]);
+ symbol->as->upper[i] = q;
+ }
+ }
}
symbol->attr.flavor = FL_VARIABLE;
result->ref->type = REF_ARRAY;
result->ref->u.ar.type = AR_FULL;
result->ref->u.ar.where = e->where;
- result->ref->u.ar.as = symbol->as;
+ result->ref->u.ar.as = symbol->ts.type == BT_CLASS
+ ? CLASS_DATA (symbol)->as : symbol->as;
if (gfc_option.warn_array_temp)
gfc_warning ("Creating array temporary at %L", &(e->where));
}
n = XCNEW (gfc_code);
n->op = EXEC_ASSIGN;
n->loc = (*current_code)->loc;
- n->next = *current_code;
+ n->next = *changed_statement;
n->expr1 = gfc_copy_expr (result);
n->expr2 = e;
- *current_code = n;
+ *changed_statement = n;
return result;
}
+/* Warn about function elimination. */
+
+static void
+warn_function_elimination (gfc_expr *e)
+{
+ if (e->expr_type != EXPR_FUNCTION)
+ return;
+ if (e->value.function.esym)
+ gfc_warning ("Removing call to function '%s' at %L",
+ e->value.function.esym->name, &(e->where));
+ else if (e->value.function.isym)
+ gfc_warning ("Removing call to function '%s' at %L",
+ e->value.function.isym->name, &(e->where));
+}
/* Callback function for the code walker for doing common function
elimination. This builds up the list of functions in the expression
and goes through them to detect duplicates, which it then replaces
int i,j;
gfc_expr *newvar;
+ /* Don't do this optimization within OMP workshare. */
+
+ if (in_omp_workshare)
+ {
+ *walk_subtrees = 0;
+ return 0;
+ }
+
expr_count = 0;
gfc_expr_walker (e, cfe_register_funcs, NULL);
- /* Walk backwards through all the functions to make sure we
- catch the leaf functions first. */
- for (i=expr_count-1; i>=1; i--)
+ /* Walk through all the functions. */
+
+ for (i=1; i<expr_count; i++)
{
/* Skip if the function has been replaced by a variable already. */
if ((*(expr_array[i]))->expr_type == EXPR_VARIABLE)
continue;
newvar = NULL;
- for (j=i-1; j>=0; j--)
+ for (j=0; j<i; j++)
{
if (gfc_dep_compare_functions(*(expr_array[i]),
*(expr_array[j]), true) == 0)
{
if (newvar == NULL)
newvar = create_var (*(expr_array[i]));
- gfc_free (*(expr_array[j]));
+
+ if (gfc_option.warn_function_elimination)
+ warn_function_elimination (*(expr_array[j]));
+
+ free (*(expr_array[j]));
*(expr_array[j]) = gfc_copy_expr (newvar);
}
}
void *data ATTRIBUTE_UNUSED)
{
current_code = c;
+ inserted_block = NULL;
+ changed_statement = NULL;
+ return 0;
+}
+
+/* Dummy function for expression call back, for use when we
+ really don't want to do any walking. */
+
+static int
+dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees,
+ void *data ATTRIBUTE_UNUSED)
+{
+ *walk_subtrees = 0;
return 0;
}
+/* Code callback function for converting
+ do while(a)
+ end do
+ into the equivalent
+ do
+ if (.not. a) exit
+ end do
+ This is because common function elimination would otherwise place the
+ temporary variables outside the loop. */
+
+static int
+convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_code *co = *c;
+ gfc_code *c_if1, *c_if2, *c_exit;
+ gfc_code *loopblock;
+ gfc_expr *e_not, *e_cond;
+
+ if (co->op != EXEC_DO_WHILE)
+ return 0;
+
+ if (co->expr1 == NULL || co->expr1->expr_type == EXPR_CONSTANT)
+ return 0;
+
+ e_cond = co->expr1;
+
+ /* Generate the condition of the if statement, which is .not. the original
+ statement. */
+ e_not = gfc_get_expr ();
+ e_not->ts = e_cond->ts;
+ e_not->where = e_cond->where;
+ e_not->expr_type = EXPR_OP;
+ e_not->value.op.op = INTRINSIC_NOT;
+ e_not->value.op.op1 = e_cond;
+
+ /* Generate the EXIT statement. */
+ c_exit = XCNEW (gfc_code);
+ c_exit->op = EXEC_EXIT;
+ c_exit->ext.which_construct = co;
+ c_exit->loc = co->loc;
+
+ /* Generate the IF statement. */
+ c_if2 = XCNEW (gfc_code);
+ c_if2->op = EXEC_IF;
+ c_if2->expr1 = e_not;
+ c_if2->next = c_exit;
+ c_if2->loc = co->loc;
+
+ /* ... plus the one to chain it to. */
+ c_if1 = XCNEW (gfc_code);
+ c_if1->op = EXEC_IF;
+ c_if1->block = c_if2;
+ c_if1->loc = co->loc;
+
+ /* Make the DO WHILE loop into a DO block by replacing the condition
+ with a true constant. */
+ co->expr1 = gfc_get_logical_expr (gfc_default_integer_kind, &co->loc, true);
+
+ /* Hang the generated if statement into the loop body. */
+
+ loopblock = co->block->next;
+ co->block->next = c_if1;
+ c_if1->next = loopblock;
+
+ return 0;
+}
+
+/* Code callback function for converting
+ if (a) then
+ ...
+ else if (b) then
+ end if
+
+ into
+ if (a) then
+ else
+ if (b) then
+ end if
+ end if
+
+ because otherwise common function elimination would place the BLOCKs
+ into the wrong place. */
+
+static int
+convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_code *co = *c;
+ gfc_code *c_if1, *c_if2, *else_stmt;
+
+ if (co->op != EXEC_IF)
+ return 0;
+
+ /* This loop starts out with the first ELSE statement. */
+ else_stmt = co->block->block;
+
+ while (else_stmt != NULL)
+ {
+ gfc_code *next_else;
+
+ /* If there is no condition, we're done. */
+ if (else_stmt->expr1 == NULL)
+ break;
+
+ next_else = else_stmt->block;
+
+ /* Generate the new IF statement. */
+ c_if2 = XCNEW (gfc_code);
+ c_if2->op = EXEC_IF;
+ c_if2->expr1 = else_stmt->expr1;
+ c_if2->next = else_stmt->next;
+ c_if2->loc = else_stmt->loc;
+ c_if2->block = next_else;
+
+ /* ... plus the one to chain it to. */
+ c_if1 = XCNEW (gfc_code);
+ c_if1->op = EXEC_IF;
+ c_if1->block = c_if2;
+ c_if1->loc = else_stmt->loc;
+
+ /* Insert the new IF after the ELSE. */
+ else_stmt->expr1 = NULL;
+ else_stmt->next = c_if1;
+ else_stmt->block = NULL;
+
+ else_stmt = next_else;
+ }
+ /* Don't walk subtrees. */
+ return 0;
+}
/* Optimize a namespace, including all contained namespaces. */
static void
{
current_ns = ns;
+ forall_level = 0;
+ iterator_level = 0;
+ in_omp_workshare = false;
+ gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL);
+ gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL);
gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
+ /* BLOCKs are handled in the expression walker below. */
for (ns = ns->contained; ns; ns = ns->sibling)
- optimize_namespace (ns);
+ {
+ if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
+ optimize_namespace (ns);
+ }
}
/* Replace code like
&& ! (e->value.function.isym
&& (e->value.function.isym->elemental
|| e->ts.type != c->expr1->ts.type
- || e->ts.kind != c->expr1->ts.kind)))
+ || e->ts.kind != c->expr1->ts.kind))
+ && ! gfc_inline_intrinsic_function_p (e))
{
gfc_code *n;
return false;
}
+/* Remove unneeded TRIMs at the end of expressions. */
+
+static bool
+remove_trim (gfc_expr *rhs)
+{
+ bool ret;
+
+ ret = false;
+
+ /* Check for a // b // trim(c). Looping is probably not
+ necessary because the parser usually generates
+ (// (// a b ) trim(c) ) , but better safe than sorry. */
+
+ while (rhs->expr_type == EXPR_OP
+ && rhs->value.op.op == INTRINSIC_CONCAT)
+ rhs = rhs->value.op.op2;
+
+ while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym
+ && rhs->value.function.isym->id == GFC_ISYM_TRIM)
+ {
+ strip_function_call (rhs);
+ /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
+ remove_trim (rhs);
+ ret = true;
+ }
+
+ return ret;
+}
+
/* Optimizations for an assignment. */
static void
/* Optimize away a = trim(b), where a is a character variable. */
if (lhs->ts.type == BT_CHARACTER)
- {
- if (rhs->expr_type == EXPR_FUNCTION &&
- rhs->value.function.isym &&
- rhs->value.function.isym->id == GFC_ISYM_TRIM)
- {
- strip_function_call (rhs);
- optimize_assignment (c);
- return;
- }
- }
+ remove_trim (rhs);
if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
optimize_binop_array_assignment (c, &rhs, false);
/* Graft the argument expression onto the original function. */
*e = *e1;
- gfc_free (e1);
+ free (e1);
}
+/* Optimization of lexical comparison functions. */
+
+static bool
+optimize_lexical_comparison (gfc_expr *e)
+{
+ if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL)
+ return false;
+
+ switch (e->value.function.isym->id)
+ {
+ case GFC_ISYM_LLE:
+ return optimize_comparison (e, INTRINSIC_LE);
+
+ case GFC_ISYM_LGE:
+ return optimize_comparison (e, INTRINSIC_GE);
+
+ case GFC_ISYM_LGT:
+ return optimize_comparison (e, INTRINSIC_GT);
+
+ case GFC_ISYM_LLT:
+ return optimize_comparison (e, INTRINSIC_LT);
+
+ default:
+ break;
+ }
+ return false;
+}
+
/* Recursive optimization of operators. */
static bool
bool change;
int eq;
bool result;
+ gfc_actual_arglist *firstarg, *secondarg;
- op1 = e->value.op.op1;
- op2 = e->value.op.op2;
-
- /* Strip off unneeded TRIM calls from string comparisons. */
-
- change = false;
-
- if (op1->expr_type == EXPR_FUNCTION
- && op1->value.function.isym
- && op1->value.function.isym->id == GFC_ISYM_TRIM)
+ if (e->expr_type == EXPR_OP)
{
- strip_function_call (op1);
- change = true;
+ firstarg = NULL;
+ secondarg = NULL;
+ op1 = e->value.op.op1;
+ op2 = e->value.op.op2;
}
-
- if (op2->expr_type == EXPR_FUNCTION
- && op2->value.function.isym
- && op2->value.function.isym->id == GFC_ISYM_TRIM)
+ else if (e->expr_type == EXPR_FUNCTION)
{
- strip_function_call (op2);
- change = true;
+ /* One of the lexical comparision functions. */
+ firstarg = e->value.function.actual;
+ secondarg = firstarg->next;
+ op1 = firstarg->expr;
+ op2 = secondarg->expr;
}
+ else
+ gcc_unreachable ();
- if (change)
- {
- optimize_comparison (e, op);
- return true;
- }
+ /* Strip off unneeded TRIM calls from string comparisons. */
+
+ change = remove_trim (op1);
+
+ if (remove_trim (op2))
+ change = true;
/* An expression of type EXPR_CONSTANT is only valid for scalars. */
/* TODO: A scalar constant may be acceptable in some cases (the scalarizer
handles them well). However, there are also cases that need a non-scalar
argument. For example the any intrinsic. See PR 45380. */
if (e->rank > 0)
- return false;
+ return change;
/* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
&& op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
{
eq = gfc_dep_compare_expr (op1, op2);
- if (eq == -2)
+ if (eq <= -2)
{
/* Replace A // B < A // C with B < C, and A // B < C // B
with A < C. */
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
+ && op1->expr_type == EXPR_OP
&& op1->value.op.op == INTRINSIC_CONCAT
+ && op2->expr_type == EXPR_OP
&& op2->value.op.op == INTRINSIC_CONCAT)
{
gfc_expr *op1_left = op1->value.op.op1;
&& op2_left->expr_type == EXPR_CONSTANT
&& op1_left->value.character.length
!= op2_left->value.character.length)
- return -2;
+ return change;
else
{
- gfc_free (op1_left);
- gfc_free (op2_left);
- e->value.op.op1 = op1_right;
- e->value.op.op2 = op2_right;
+ free (op1_left);
+ free (op2_left);
+ if (firstarg)
+ {
+ firstarg->expr = op1_right;
+ secondarg->expr = op2_right;
+ }
+ else
+ {
+ e->value.op.op1 = op1_right;
+ e->value.op.op2 = op2_right;
+ }
optimize_comparison (e, op);
return true;
}
}
if (gfc_dep_compare_expr (op1_right, op2_right) == 0)
{
- gfc_free (op1_right);
- gfc_free (op2_right);
- e->value.op.op1 = op1_left;
- e->value.op.op2 = op2_left;
+ free (op1_right);
+ free (op2_right);
+ if (firstarg)
+ {
+ firstarg->expr = op1_left;
+ secondarg->expr = op2_left;
+ }
+ else
+ {
+ e->value.op.op1 = op1_left;
+ e->value.op.op2 = op2_left;
+ }
+
optimize_comparison (e, op);
return true;
}
/* Replace the expression by a constant expression. The typespec
and where remains the way it is. */
- gfc_free (op1);
- gfc_free (op2);
+ free (op1);
+ free (op2);
e->expr_type = EXPR_CONSTANT;
e->value.logical = result;
return true;
}
}
- return false;
+ return change;
}
/* Optimize a trim function by replacing it with an equivalent substring
return true;
}
+/* Optimize minloc(b), where b is rank 1 array, into
+ (/ minloc(b, dim=1) /), and similarly for maxloc,
+ as the latter forms are expanded inline. */
+
+static void
+optimize_minmaxloc (gfc_expr **e)
+{
+ gfc_expr *fn = *e;
+ gfc_actual_arglist *a;
+ char *name, *p;
+
+ if (fn->rank != 1
+ || fn->value.function.actual == NULL
+ || fn->value.function.actual->expr == NULL
+ || fn->value.function.actual->expr->rank != 1)
+ return;
+
+ *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where);
+ (*e)->shape = fn->shape;
+ fn->rank = 0;
+ fn->shape = NULL;
+ gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where);
+
+ name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1);
+ strcpy (name, fn->value.function.name);
+ p = strstr (name, "loc0");
+ p[3] = '1';
+ fn->value.function.name = gfc_get_string (name);
+ if (fn->value.function.actual->next)
+ {
+ a = fn->value.function.actual->next;
+ gcc_assert (a->expr == NULL);
+ }
+ else
+ {
+ a = gfc_get_actual_arglist ();
+ fn->value.function.actual->next = a;
+ }
+ a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &fn->where);
+ mpz_set_ui (a->expr->value.integer, 1);
+}
+
#define WALK_SUBEXPR(NODE) \
do \
{ \
for (c = gfc_constructor_first ((*e)->value.constructor); c;
c = gfc_constructor_next (c))
{
- WALK_SUBEXPR (c->expr);
- if (c->iterator != NULL)
+ if (c->iterator == NULL)
+ WALK_SUBEXPR (c->expr);
+ else
{
+ iterator_level ++;
+ WALK_SUBEXPR (c->expr);
+ iterator_level --;
WALK_SUBEXPR (c->iterator->var);
WALK_SUBEXPR (c->iterator->start);
WALK_SUBEXPR (c->iterator->end);
break;
/* Fall through to the variable case in order to walk the
- the reference. */
+ reference. */
case EXPR_SUBSTRING:
case EXPR_VARIABLE:
{
gfc_code *b;
gfc_actual_arglist *a;
+ gfc_code *co;
+ gfc_association_list *alist;
+ bool saved_in_omp_workshare;
+
+ /* There might be statement insertions before the current code,
+ which must not affect the expression walker. */
+
+ co = *c;
+ saved_in_omp_workshare = in_omp_workshare;
- switch ((*c)->op)
+ switch (co->op)
{
+
+ case EXEC_BLOCK:
+ WALK_SUBCODE (co->ext.block.ns->code);
+ for (alist = co->ext.block.assoc; alist; alist = alist->next)
+ WALK_SUBEXPR (alist->target);
+ break;
+
case EXEC_DO:
- WALK_SUBEXPR ((*c)->ext.iterator->var);
- WALK_SUBEXPR ((*c)->ext.iterator->start);
- WALK_SUBEXPR ((*c)->ext.iterator->end);
- WALK_SUBEXPR ((*c)->ext.iterator->step);
+ WALK_SUBEXPR (co->ext.iterator->var);
+ WALK_SUBEXPR (co->ext.iterator->start);
+ WALK_SUBEXPR (co->ext.iterator->end);
+ WALK_SUBEXPR (co->ext.iterator->step);
break;
case EXEC_CALL:
case EXEC_ASSIGN_CALL:
- for (a = (*c)->ext.actual; a; a = a->next)
+ for (a = co->ext.actual; a; a = a->next)
WALK_SUBEXPR (a->expr);
break;
case EXEC_CALL_PPC:
- WALK_SUBEXPR ((*c)->expr1);
- for (a = (*c)->ext.actual; a; a = a->next)
+ WALK_SUBEXPR (co->expr1);
+ for (a = co->ext.actual; a; a = a->next)
WALK_SUBEXPR (a->expr);
break;
case EXEC_SELECT:
- WALK_SUBEXPR ((*c)->expr1);
- for (b = (*c)->block; b; b = b->block)
+ WALK_SUBEXPR (co->expr1);
+ for (b = co->block; b; b = b->block)
{
gfc_case *cp;
for (cp = b->ext.block.case_list; cp; cp = cp->next)
case EXEC_DEALLOCATE:
{
gfc_alloc *a;
- for (a = (*c)->ext.alloc.list; a; a = a->next)
+ for (a = co->ext.alloc.list; a; a = a->next)
WALK_SUBEXPR (a->expr);
break;
}
case EXEC_FORALL:
+ case EXEC_DO_CONCURRENT:
{
gfc_forall_iterator *fa;
- for (fa = (*c)->ext.forall_iterator; fa; fa = fa->next)
+ for (fa = co->ext.forall_iterator; fa; fa = fa->next)
{
WALK_SUBEXPR (fa->var);
WALK_SUBEXPR (fa->start);
WALK_SUBEXPR (fa->end);
WALK_SUBEXPR (fa->stride);
}
+ if (co->op == EXEC_FORALL)
+ forall_level ++;
break;
}
case EXEC_OPEN:
- WALK_SUBEXPR ((*c)->ext.open->unit);
- WALK_SUBEXPR ((*c)->ext.open->file);
- WALK_SUBEXPR ((*c)->ext.open->status);
- WALK_SUBEXPR ((*c)->ext.open->access);
- WALK_SUBEXPR ((*c)->ext.open->form);
- WALK_SUBEXPR ((*c)->ext.open->recl);
- WALK_SUBEXPR ((*c)->ext.open->blank);
- WALK_SUBEXPR ((*c)->ext.open->position);
- WALK_SUBEXPR ((*c)->ext.open->action);
- WALK_SUBEXPR ((*c)->ext.open->delim);
- WALK_SUBEXPR ((*c)->ext.open->pad);
- WALK_SUBEXPR ((*c)->ext.open->iostat);
- WALK_SUBEXPR ((*c)->ext.open->iomsg);
- WALK_SUBEXPR ((*c)->ext.open->convert);
- WALK_SUBEXPR ((*c)->ext.open->decimal);
- WALK_SUBEXPR ((*c)->ext.open->encoding);
- WALK_SUBEXPR ((*c)->ext.open->round);
- WALK_SUBEXPR ((*c)->ext.open->sign);
- WALK_SUBEXPR ((*c)->ext.open->asynchronous);
- WALK_SUBEXPR ((*c)->ext.open->id);
- WALK_SUBEXPR ((*c)->ext.open->newunit);
+ WALK_SUBEXPR (co->ext.open->unit);
+ WALK_SUBEXPR (co->ext.open->file);
+ WALK_SUBEXPR (co->ext.open->status);
+ WALK_SUBEXPR (co->ext.open->access);
+ WALK_SUBEXPR (co->ext.open->form);
+ WALK_SUBEXPR (co->ext.open->recl);
+ WALK_SUBEXPR (co->ext.open->blank);
+ WALK_SUBEXPR (co->ext.open->position);
+ WALK_SUBEXPR (co->ext.open->action);
+ WALK_SUBEXPR (co->ext.open->delim);
+ WALK_SUBEXPR (co->ext.open->pad);
+ WALK_SUBEXPR (co->ext.open->iostat);
+ WALK_SUBEXPR (co->ext.open->iomsg);
+ WALK_SUBEXPR (co->ext.open->convert);
+ WALK_SUBEXPR (co->ext.open->decimal);
+ WALK_SUBEXPR (co->ext.open->encoding);
+ WALK_SUBEXPR (co->ext.open->round);
+ WALK_SUBEXPR (co->ext.open->sign);
+ WALK_SUBEXPR (co->ext.open->asynchronous);
+ WALK_SUBEXPR (co->ext.open->id);
+ WALK_SUBEXPR (co->ext.open->newunit);
break;
case EXEC_CLOSE:
- WALK_SUBEXPR ((*c)->ext.close->unit);
- WALK_SUBEXPR ((*c)->ext.close->status);
- WALK_SUBEXPR ((*c)->ext.close->iostat);
- WALK_SUBEXPR ((*c)->ext.close->iomsg);
+ WALK_SUBEXPR (co->ext.close->unit);
+ WALK_SUBEXPR (co->ext.close->status);
+ WALK_SUBEXPR (co->ext.close->iostat);
+ WALK_SUBEXPR (co->ext.close->iomsg);
break;
case EXEC_BACKSPACE:
case EXEC_ENDFILE:
case EXEC_REWIND:
case EXEC_FLUSH:
- WALK_SUBEXPR ((*c)->ext.filepos->unit);
- WALK_SUBEXPR ((*c)->ext.filepos->iostat);
- WALK_SUBEXPR ((*c)->ext.filepos->iomsg);
+ WALK_SUBEXPR (co->ext.filepos->unit);
+ WALK_SUBEXPR (co->ext.filepos->iostat);
+ WALK_SUBEXPR (co->ext.filepos->iomsg);
break;
case EXEC_INQUIRE:
- WALK_SUBEXPR ((*c)->ext.inquire->unit);
- WALK_SUBEXPR ((*c)->ext.inquire->file);
- WALK_SUBEXPR ((*c)->ext.inquire->iomsg);
- WALK_SUBEXPR ((*c)->ext.inquire->iostat);
- WALK_SUBEXPR ((*c)->ext.inquire->exist);
- WALK_SUBEXPR ((*c)->ext.inquire->opened);
- WALK_SUBEXPR ((*c)->ext.inquire->number);
- WALK_SUBEXPR ((*c)->ext.inquire->named);
- WALK_SUBEXPR ((*c)->ext.inquire->name);
- WALK_SUBEXPR ((*c)->ext.inquire->access);
- WALK_SUBEXPR ((*c)->ext.inquire->sequential);
- WALK_SUBEXPR ((*c)->ext.inquire->direct);
- WALK_SUBEXPR ((*c)->ext.inquire->form);
- WALK_SUBEXPR ((*c)->ext.inquire->formatted);
- WALK_SUBEXPR ((*c)->ext.inquire->unformatted);
- WALK_SUBEXPR ((*c)->ext.inquire->recl);
- WALK_SUBEXPR ((*c)->ext.inquire->nextrec);
- WALK_SUBEXPR ((*c)->ext.inquire->blank);
- WALK_SUBEXPR ((*c)->ext.inquire->position);
- WALK_SUBEXPR ((*c)->ext.inquire->action);
- WALK_SUBEXPR ((*c)->ext.inquire->read);
- WALK_SUBEXPR ((*c)->ext.inquire->write);
- WALK_SUBEXPR ((*c)->ext.inquire->readwrite);
- WALK_SUBEXPR ((*c)->ext.inquire->delim);
- WALK_SUBEXPR ((*c)->ext.inquire->encoding);
- WALK_SUBEXPR ((*c)->ext.inquire->pad);
- WALK_SUBEXPR ((*c)->ext.inquire->iolength);
- WALK_SUBEXPR ((*c)->ext.inquire->convert);
- WALK_SUBEXPR ((*c)->ext.inquire->strm_pos);
- WALK_SUBEXPR ((*c)->ext.inquire->asynchronous);
- WALK_SUBEXPR ((*c)->ext.inquire->decimal);
- WALK_SUBEXPR ((*c)->ext.inquire->pending);
- WALK_SUBEXPR ((*c)->ext.inquire->id);
- WALK_SUBEXPR ((*c)->ext.inquire->sign);
- WALK_SUBEXPR ((*c)->ext.inquire->size);
- WALK_SUBEXPR ((*c)->ext.inquire->round);
+ WALK_SUBEXPR (co->ext.inquire->unit);
+ WALK_SUBEXPR (co->ext.inquire->file);
+ WALK_SUBEXPR (co->ext.inquire->iomsg);
+ WALK_SUBEXPR (co->ext.inquire->iostat);
+ WALK_SUBEXPR (co->ext.inquire->exist);
+ WALK_SUBEXPR (co->ext.inquire->opened);
+ WALK_SUBEXPR (co->ext.inquire->number);
+ WALK_SUBEXPR (co->ext.inquire->named);
+ WALK_SUBEXPR (co->ext.inquire->name);
+ WALK_SUBEXPR (co->ext.inquire->access);
+ WALK_SUBEXPR (co->ext.inquire->sequential);
+ WALK_SUBEXPR (co->ext.inquire->direct);
+ WALK_SUBEXPR (co->ext.inquire->form);
+ WALK_SUBEXPR (co->ext.inquire->formatted);
+ WALK_SUBEXPR (co->ext.inquire->unformatted);
+ WALK_SUBEXPR (co->ext.inquire->recl);
+ WALK_SUBEXPR (co->ext.inquire->nextrec);
+ WALK_SUBEXPR (co->ext.inquire->blank);
+ WALK_SUBEXPR (co->ext.inquire->position);
+ WALK_SUBEXPR (co->ext.inquire->action);
+ WALK_SUBEXPR (co->ext.inquire->read);
+ WALK_SUBEXPR (co->ext.inquire->write);
+ WALK_SUBEXPR (co->ext.inquire->readwrite);
+ WALK_SUBEXPR (co->ext.inquire->delim);
+ WALK_SUBEXPR (co->ext.inquire->encoding);
+ WALK_SUBEXPR (co->ext.inquire->pad);
+ WALK_SUBEXPR (co->ext.inquire->iolength);
+ WALK_SUBEXPR (co->ext.inquire->convert);
+ WALK_SUBEXPR (co->ext.inquire->strm_pos);
+ WALK_SUBEXPR (co->ext.inquire->asynchronous);
+ WALK_SUBEXPR (co->ext.inquire->decimal);
+ WALK_SUBEXPR (co->ext.inquire->pending);
+ WALK_SUBEXPR (co->ext.inquire->id);
+ WALK_SUBEXPR (co->ext.inquire->sign);
+ WALK_SUBEXPR (co->ext.inquire->size);
+ WALK_SUBEXPR (co->ext.inquire->round);
break;
case EXEC_WAIT:
- WALK_SUBEXPR ((*c)->ext.wait->unit);
- WALK_SUBEXPR ((*c)->ext.wait->iostat);
- WALK_SUBEXPR ((*c)->ext.wait->iomsg);
- WALK_SUBEXPR ((*c)->ext.wait->id);
+ WALK_SUBEXPR (co->ext.wait->unit);
+ WALK_SUBEXPR (co->ext.wait->iostat);
+ WALK_SUBEXPR (co->ext.wait->iomsg);
+ WALK_SUBEXPR (co->ext.wait->id);
break;
case EXEC_READ:
case EXEC_WRITE:
- WALK_SUBEXPR ((*c)->ext.dt->io_unit);
- WALK_SUBEXPR ((*c)->ext.dt->format_expr);
- WALK_SUBEXPR ((*c)->ext.dt->rec);
- WALK_SUBEXPR ((*c)->ext.dt->advance);
- WALK_SUBEXPR ((*c)->ext.dt->iostat);
- WALK_SUBEXPR ((*c)->ext.dt->size);
- WALK_SUBEXPR ((*c)->ext.dt->iomsg);
- WALK_SUBEXPR ((*c)->ext.dt->id);
- WALK_SUBEXPR ((*c)->ext.dt->pos);
- WALK_SUBEXPR ((*c)->ext.dt->asynchronous);
- WALK_SUBEXPR ((*c)->ext.dt->blank);
- WALK_SUBEXPR ((*c)->ext.dt->decimal);
- WALK_SUBEXPR ((*c)->ext.dt->delim);
- WALK_SUBEXPR ((*c)->ext.dt->pad);
- WALK_SUBEXPR ((*c)->ext.dt->round);
- WALK_SUBEXPR ((*c)->ext.dt->sign);
- WALK_SUBEXPR ((*c)->ext.dt->extra_comma);
+ WALK_SUBEXPR (co->ext.dt->io_unit);
+ WALK_SUBEXPR (co->ext.dt->format_expr);
+ WALK_SUBEXPR (co->ext.dt->rec);
+ WALK_SUBEXPR (co->ext.dt->advance);
+ WALK_SUBEXPR (co->ext.dt->iostat);
+ WALK_SUBEXPR (co->ext.dt->size);
+ WALK_SUBEXPR (co->ext.dt->iomsg);
+ WALK_SUBEXPR (co->ext.dt->id);
+ WALK_SUBEXPR (co->ext.dt->pos);
+ WALK_SUBEXPR (co->ext.dt->asynchronous);
+ WALK_SUBEXPR (co->ext.dt->blank);
+ WALK_SUBEXPR (co->ext.dt->decimal);
+ WALK_SUBEXPR (co->ext.dt->delim);
+ WALK_SUBEXPR (co->ext.dt->pad);
+ WALK_SUBEXPR (co->ext.dt->round);
+ WALK_SUBEXPR (co->ext.dt->sign);
+ WALK_SUBEXPR (co->ext.dt->extra_comma);
break;
- case EXEC_OMP_DO:
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
case EXEC_OMP_PARALLEL_SECTIONS:
+
+ in_omp_workshare = false;
+
+ /* This goto serves as a shortcut to avoid code
+ duplication or a larger if or switch statement. */
+ goto check_omp_clauses;
+
+ case EXEC_OMP_WORKSHARE:
case EXEC_OMP_PARALLEL_WORKSHARE:
+
+ in_omp_workshare = true;
+
+ /* Fall through */
+
+ case EXEC_OMP_DO:
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
- case EXEC_OMP_WORKSHARE:
case EXEC_OMP_END_SINGLE:
case EXEC_OMP_TASK:
- if ((*c)->ext.omp_clauses)
+
+ /* Come to this label only from the
+ EXEC_OMP_PARALLEL_* cases above. */
+
+ check_omp_clauses:
+
+ if (co->ext.omp_clauses)
{
- WALK_SUBEXPR ((*c)->ext.omp_clauses->if_expr);
- WALK_SUBEXPR ((*c)->ext.omp_clauses->num_threads);
- WALK_SUBEXPR ((*c)->ext.omp_clauses->chunk_size);
+ WALK_SUBEXPR (co->ext.omp_clauses->if_expr);
+ WALK_SUBEXPR (co->ext.omp_clauses->final_expr);
+ WALK_SUBEXPR (co->ext.omp_clauses->num_threads);
+ WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
}
break;
default:
break;
}
- WALK_SUBEXPR ((*c)->expr1);
- WALK_SUBEXPR ((*c)->expr2);
- WALK_SUBEXPR ((*c)->expr3);
- for (b = (*c)->block; b; b = b->block)
+ WALK_SUBEXPR (co->expr1);
+ WALK_SUBEXPR (co->expr2);
+ WALK_SUBEXPR (co->expr3);
+ WALK_SUBEXPR (co->expr4);
+ for (b = co->block; b; b = b->block)
{
WALK_SUBEXPR (b->expr1);
WALK_SUBEXPR (b->expr2);
WALK_SUBCODE (b->next);
}
+
+ if (co->op == EXEC_FORALL)
+ forall_level --;
+
+ in_omp_workshare = saved_in_omp_workshare;
}
}
return 0;