/* 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_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. */
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 ((*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)
{
- /* FIXME - there is a bug in the insertion code for DO loops. Bail
- out here. */
+ if ((*e)->expr_type != EXPR_FUNCTION)
+ return 0;
- if ((*current_code)->op == EXEC_DO)
+ /* 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;
- if ((*e)->expr_type != EXPR_FUNCTION)
+ /* We don't do function elimination within FORALL statements, it can
+ lead to wrong-code in certain circumstances. */
+
+ if (forall_level > 0)
return 0;
- /* We don't do character functions (yet). */
- if ((*e)->ts.type == BT_CHARACTER)
+ /* Function elimination inside an iterator could lead to functions
+ which depend on iterator variables being moved outside. */
+
+ if (iterator_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. */
+ /* 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)
+ 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;
}
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);
if (gfc_option.warn_function_elimination)
warn_function_elimination (*(expr_array[j]));
- gfc_free (*(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);
}
/* Strip off unneeded TRIM calls from string comparisons. */
- change = false;
+ change = remove_trim (op1);
- if (op1->expr_type == EXPR_FUNCTION
- && op1->value.function.isym
- && op1->value.function.isym->id == GFC_ISYM_TRIM)
- {
- strip_function_call (op1);
- change = true;
- }
-
- if (op2->expr_type == EXPR_FUNCTION
- && op2->value.function.isym
- && op2->value.function.isym->id == GFC_ISYM_TRIM)
- {
- strip_function_call (op2);
- change = true;
- }
-
- if (change)
- {
- optimize_comparison (e, op);
- return true;
- }
+ 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 false;
+ return change;
else
{
- gfc_free (op1_left);
- gfc_free (op2_left);
+ free (op1_left);
+ free (op2_left);
if (firstarg)
{
firstarg->expr = op1_right;
}
if (gfc_dep_compare_expr (op1_right, op2_right) == 0)
{
- gfc_free (op1_right);
- gfc_free (op2_right);
+ free (op1_right);
+ free (op2_right);
if (firstarg)
{
firstarg->expr = op1_left;
/* 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);
{
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. */
- switch ((*c)->op)
+ co = *c;
+ saved_in_omp_workshare = in_omp_workshare;
+
+ 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;