#include "arith.h"
#include "flags.h"
#include "dependency.h"
+#include "constructor.h"
+#include "opts.h"
/* Forward declarations. */
static void strip_function_call (gfc_expr *);
+static void optimize_namespace (gfc_namespace *);
static void optimize_assignment (gfc_code *);
-static void optimize_expr_0 (gfc_expr *);
-static bool optimize_expr (gfc_expr *);
static bool optimize_op (gfc_expr *);
-static bool optimize_equality (gfc_expr *, bool);
-static void optimize_code (gfc_code *);
-static void optimize_code_node (gfc_code *);
-static void optimize_actual_arglist (gfc_actual_arglist *);
+static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op);
+static bool optimize_trim (gfc_expr *);
+
+/* How deep we are inside an argument list. */
+
+static int count_arglist;
/* Entry point - run all passes for a namespace. So far, only an
optimization pass is run. */
void
-gfc_run_passes (gfc_namespace * ns)
+gfc_run_passes (gfc_namespace *ns)
{
if (optimize)
- optimize_code (ns->code);
-}
-
-static void
-optimize_code (gfc_code *c)
-{
- for (; c; c = c->next)
- optimize_code_node (c);
+ {
+ optimize_namespace (ns);
+ if (gfc_option.dump_fortran_optimized)
+ gfc_dump_parse_tree (ns, stdout);
+ }
}
+/* Callback for each gfc_code node invoked through gfc_code_walker
+ from optimize_namespace. */
-/* Do the optimizations for a code node. */
-
-static void
-optimize_code_node (gfc_code *c)
+static int
+optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
{
- gfc_forall_iterator *fa;
- gfc_code *d;
- gfc_alloc *a;
-
- switch (c->op)
- {
- case EXEC_ASSIGN:
- optimize_assignment (c);
- break;
-
- case EXEC_CALL:
- case EXEC_ASSIGN_CALL:
- case EXEC_CALL_PPC:
- optimize_actual_arglist (c->ext.actual);
- break;
+ gfc_exec_op op;
- case EXEC_ARITHMETIC_IF:
- optimize_expr_0 (c->expr1);
- break;
+ op = (*c)->op;
- case EXEC_PAUSE:
- case EXEC_RETURN:
- case EXEC_ERROR_STOP:
- case EXEC_STOP:
- case EXEC_COMPCALL:
- optimize_expr_0 (c->expr1);
- break;
+ if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL
+ || op == EXEC_CALL_PPC)
+ count_arglist = 1;
+ else
+ count_arglist = 0;
- case EXEC_SYNC_ALL:
- case EXEC_SYNC_MEMORY:
- case EXEC_SYNC_IMAGES:
- optimize_expr_0 (c->expr2);
- break;
+ if (op == EXEC_ASSIGN)
+ optimize_assignment (*c);
+ return 0;
+}
- case EXEC_IF:
- d = c->block;
- optimize_expr_0 (d->expr1);
- optimize_code (d->next);
+/* Callback for each gfc_expr node invoked through gfc_code_walker
+ from optimize_namespace. */
- for (d = d->block; d; d = d->block)
- {
- optimize_expr_0 (d->expr1);
+static int
+optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ bool function_expr;
- optimize_code (d->next);
- }
+ if ((*e)->expr_type == EXPR_FUNCTION)
+ {
+ count_arglist ++;
+ function_expr = true;
+ }
+ else
+ function_expr = false;
+ if (optimize_trim (*e))
+ gfc_simplify_expr (*e, 0);
- break;
+ if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
+ gfc_simplify_expr (*e, 0);
- case EXEC_SELECT:
- case EXEC_SELECT_TYPE:
- d = c->block;
+ if (function_expr)
+ count_arglist --;
- optimize_expr_0 (c->expr1);
+ return 0;
+}
- for (; d; d = d->block)
- optimize_code (d->next);
+/* Optimize a namespace, including all contained namespaces. */
- break;
+static void
+optimize_namespace (gfc_namespace *ns)
+{
+ gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
- case EXEC_WHERE:
- d = c->block;
- optimize_expr_0 (d->expr1);
- optimize_code (d->next);
+ for (ns = ns->contained; ns; ns = ns->sibling)
+ optimize_namespace (ns);
+}
- for (d = d->block; d; d = d->block)
- {
- optimize_expr_0 (d->expr1);
- optimize_code (d->next);
- }
- break;
+/* Replace code like
+ a = matmul(b,c) + d
+ with
+ a = matmul(b,c) ; a = a + d
+ where the array function is not elemental and not allocatable
+ and does not depend on the left-hand side.
+*/
- case EXEC_FORALL:
+static bool
+optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
+{
+ gfc_expr *e;
- for (fa = c->ext.forall_iterator; fa; fa = fa->next)
+ e = *rhs;
+ if (e->expr_type == EXPR_OP)
+ {
+ switch (e->value.op.op)
{
- optimize_expr_0 (fa->start);
- optimize_expr_0 (fa->end);
- optimize_expr_0 (fa->stride);
+ /* Unary operators and exponentiation: Only look at a single
+ operand. */
+ case INTRINSIC_NOT:
+ case INTRINSIC_UPLUS:
+ case INTRINSIC_UMINUS:
+ case INTRINSIC_PARENTHESES:
+ case INTRINSIC_POWER:
+ if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op))
+ return true;
+ break;
+
+ default:
+ /* Binary operators. */
+ if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
+ return true;
+
+ if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
+ return true;
+
+ break;
}
+ }
+ else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0
+ && ! (e->value.function.esym
+ && (e->value.function.esym->attr.elemental
+ || e->value.function.esym->attr.allocatable
+ || e->value.function.esym->ts.type != c->expr1->ts.type
+ || e->value.function.esym->ts.kind != c->expr1->ts.kind))
+ && ! (e->value.function.isym
+ && (e->value.function.isym->elemental
+ || e->ts.type != c->expr1->ts.type
+ || e->ts.kind != c->expr1->ts.kind)))
+ {
- if (c->expr1 != NULL)
- optimize_expr_0 (c->expr1);
-
- optimize_code (c->block->next);
-
- break;
-
- case EXEC_CRITICAL:
- optimize_code (c->block->next);
- break;
-
- case EXEC_DO:
- optimize_expr_0 (c->ext.iterator->start);
- optimize_expr_0 (c->ext.iterator->end);
- optimize_expr_0 (c->ext.iterator->step);
- optimize_code (c->block->next);
-
- break;
-
- case EXEC_DO_WHILE:
- optimize_expr_0 (c->expr1);
- optimize_code (c->block->next);
- break;
-
-
- case EXEC_ALLOCATE:
- for (a = c->ext.alloc.list; a; a = a->next)
- optimize_expr_0 (a->expr);
- break;
-
- /* Todo: Some of these may need to be optimized, as well. */
- case EXEC_WRITE:
- case EXEC_READ:
- case EXEC_OPEN:
- case EXEC_INQUIRE:
- case EXEC_REWIND:
- case EXEC_ENDFILE:
- case EXEC_BACKSPACE:
- case EXEC_CLOSE:
- case EXEC_WAIT:
- case EXEC_TRANSFER:
- case EXEC_FLUSH:
- case EXEC_IOLENGTH:
- case EXEC_END_PROCEDURE:
- case EXEC_NOP:
- case EXEC_CONTINUE:
- case EXEC_ENTRY:
- case EXEC_INIT_ASSIGN:
- case EXEC_LABEL_ASSIGN:
- case EXEC_POINTER_ASSIGN:
- case EXEC_GOTO:
- case EXEC_CYCLE:
- case EXEC_EXIT:
- case EXEC_BLOCK:
- case EXEC_END_BLOCK:
- case EXEC_OMP_ATOMIC:
- case EXEC_OMP_BARRIER:
- case EXEC_OMP_CRITICAL:
- case EXEC_OMP_FLUSH:
- case EXEC_OMP_DO:
- case EXEC_OMP_MASTER:
- case EXEC_OMP_ORDERED:
- case EXEC_OMP_PARALLEL:
- case EXEC_OMP_PARALLEL_DO:
- case EXEC_OMP_PARALLEL_SECTIONS:
- case EXEC_OMP_PARALLEL_WORKSHARE:
- case EXEC_OMP_SECTIONS:
- case EXEC_OMP_SINGLE:
- case EXEC_OMP_TASK:
- case EXEC_OMP_TASKWAIT:
- case EXEC_OMP_WORKSHARE:
- case EXEC_DEALLOCATE:
+ gfc_code *n;
+ gfc_expr *new_expr;
+
+ /* Insert a new assignment statement after the current one. */
+ n = XCNEW (gfc_code);
+ n->op = EXEC_ASSIGN;
+ n->loc = c->loc;
+ n->next = c->next;
+ c->next = n;
+
+ n->expr1 = gfc_copy_expr (c->expr1);
+ n->expr2 = c->expr2;
+ new_expr = gfc_copy_expr (c->expr1);
+ c->expr2 = e;
+ *rhs = new_expr;
- break;
-
- default:
- gcc_unreachable ();
+ return true;
}
+
+ /* Nothing to optimize. */
+ return false;
}
/* Optimizations for an assignment. */
}
}
- /* All direct optimizations have been done. Now it's time
- to optimize the rhs. */
-
- optimize_expr_0 (rhs);
+ if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
+ optimize_binop_array_assignment (c, &rhs, false);
}
}
-/* Top-level optimization of expressions. Calls gfc_simplify_expr if
- optimize_expr succeeds in doing something.
- TODO: Optimization of multiple function occurrence to come here. */
-
-static void
-optimize_expr_0 (gfc_expr * e)
-{
- if (optimize_expr (e))
- gfc_simplify_expr (e, 0);
-
- return;
-}
-
-/* Recursive optimization of expressions.
- TODO: Make this handle many more things. */
-
-static bool
-optimize_expr (gfc_expr *e)
-{
- bool ret;
-
- if (e == NULL)
- return false;
-
- ret = false;
-
- switch (e->expr_type)
- {
- case EXPR_OP:
- return optimize_op (e);
- break;
-
- case EXPR_FUNCTION:
- optimize_actual_arglist (e->value.function.actual);
- break;
-
- default:
- break;
- }
-
- return ret;
-}
-
/* Recursive optimization of operators. */
static bool
optimize_op (gfc_expr *e)
{
-
- gfc_intrinsic_op op;
-
- op = e->value.op.op;
+ gfc_intrinsic_op op = e->value.op.op;
switch (op)
{
case INTRINSIC_GE_OS:
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
- return optimize_equality (e, true);
- break;
-
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
- return optimize_equality (e, false);
- break;
+ return optimize_comparison (e, op);
default:
break;
/* Optimize expressions for equality. */
static bool
-optimize_equality (gfc_expr *e, bool equal)
+optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
{
-
gfc_expr *op1, *op2;
bool change;
+ int eq;
+ bool result;
op1 = e->value.op.op1;
op2 = e->value.op.op2;
if (change)
{
- optimize_equality (e, equal);
+ optimize_comparison (e, op);
return true;
}
- /* Check for direct comparison between identical variables. Don't compare
- REAL or COMPLEX because of NaN checks. */
- if (op1->expr_type == EXPR_VARIABLE
- && op2->expr_type == EXPR_VARIABLE
- && op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
- && op1->ts.type != BT_COMPLEX && op2->ts.type !=BT_COMPLEX
- && gfc_are_identical_variables (op1, op2))
+ /* 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;
+
+ /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
+
+ if (flag_finite_math_only
+ || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
+ && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
{
- /* Replace the expression by a constant expression. The typespec
- and where remains the way it is. */
- gfc_free (op1);
- gfc_free (op2);
- e->expr_type = EXPR_CONSTANT;
- e->value.logical = equal;
- return true;
+ eq = gfc_dep_compare_expr (op1, op2);
+ 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->value.op.op == INTRINSIC_CONCAT
+ && op2->value.op.op == INTRINSIC_CONCAT)
+ {
+ gfc_expr *op1_left = op1->value.op.op1;
+ gfc_expr *op2_left = op2->value.op.op1;
+ gfc_expr *op1_right = op1->value.op.op2;
+ gfc_expr *op2_right = op2->value.op.op2;
+
+ if (gfc_dep_compare_expr (op1_left, op2_left) == 0)
+ {
+ /* Watch out for 'A ' // x vs. 'A' // x. */
+
+ if (op1_left->expr_type == EXPR_CONSTANT
+ && op2_left->expr_type == EXPR_CONSTANT
+ && op1_left->value.character.length
+ != op2_left->value.character.length)
+ return -2;
+ else
+ {
+ gfc_free (op1_left);
+ gfc_free (op2_left);
+ 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;
+ optimize_comparison (e, op);
+ return true;
+ }
+ }
+ }
+ else
+ {
+ /* eq can only be -1, 0 or 1 at this point. */
+ switch (op)
+ {
+ case INTRINSIC_EQ:
+ case INTRINSIC_EQ_OS:
+ result = eq == 0;
+ break;
+
+ case INTRINSIC_GE:
+ case INTRINSIC_GE_OS:
+ result = eq >= 0;
+ break;
+
+ case INTRINSIC_LE:
+ case INTRINSIC_LE_OS:
+ result = eq <= 0;
+ break;
+
+ case INTRINSIC_NE:
+ case INTRINSIC_NE_OS:
+ result = eq != 0;
+ break;
+
+ case INTRINSIC_GT:
+ case INTRINSIC_GT_OS:
+ result = eq > 0;
+ break;
+
+ case INTRINSIC_LT:
+ case INTRINSIC_LT_OS:
+ result = eq < 0;
+ break;
+
+ default:
+ gfc_internal_error ("illegal OP in optimize_comparison");
+ break;
+ }
+
+ /* Replace the expression by a constant expression. The typespec
+ and where remains the way it is. */
+ gfc_free (op1);
+ gfc_free (op2);
+ e->expr_type = EXPR_CONSTANT;
+ e->value.logical = result;
+ return true;
+ }
}
+
return false;
}
-/* Optimize a call list. Right now, this just goes through the actual
- arg list and optimizes each expression in turn. */
+/* Optimize a trim function by replacing it with an equivalent substring
+ involving a call to len_trim. This only works for expressions where
+ variables are trimmed. Return true if anything was modified. */
-static void
-optimize_actual_arglist (gfc_actual_arglist *a)
+static bool
+optimize_trim (gfc_expr *e)
{
+ gfc_expr *a;
+ gfc_ref *ref;
+ gfc_expr *fcn;
+ gfc_actual_arglist *actual_arglist, *next;
+
+ /* Don't do this optimization within an argument list, because
+ otherwise aliasing issues may occur. */
- for (; a; a = a->next)
+ if (count_arglist != 1)
+ return false;
+
+ if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
+ || e->value.function.isym == NULL
+ || e->value.function.isym->id != GFC_ISYM_TRIM)
+ return false;
+
+ a = e->value.function.actual->expr;
+
+ if (a->expr_type != EXPR_VARIABLE)
+ return false;
+
+ if (a->ref)
+ {
+ /* FIXME - also handle substring references, by modifying the
+ reference itself. Make sure not to evaluate functions in
+ the references twice. */
+ return false;
+ }
+ else
{
- if (a->expr != NULL)
- optimize_expr_0 (a->expr);
+ strip_function_call (e);
+
+ /* Create the reference. */
+
+ ref = gfc_get_ref ();
+ ref->type = REF_SUBSTRING;
+
+ /* Set the start of the reference. */
+
+ ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+
+ /* Build the function call to len_trim(x, gfc_defaul_integer_kind). */
+
+ fcn = gfc_get_expr ();
+ fcn->expr_type = EXPR_FUNCTION;
+ fcn->value.function.isym =
+ gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
+ actual_arglist = gfc_get_actual_arglist ();
+ actual_arglist->expr = gfc_copy_expr (e);
+ next = gfc_get_actual_arglist ();
+ next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ gfc_default_integer_kind);
+ actual_arglist->next = next;
+ fcn->value.function.actual = actual_arglist;
+
+ /* Set the end of the reference to the call to len_trim. */
+
+ ref->u.ss.end = fcn;
+ e->ref = ref;
+ return true;
+ }
+}
+
+#define WALK_SUBEXPR(NODE) \
+ do \
+ { \
+ result = gfc_expr_walker (&(NODE), exprfn, data); \
+ if (result) \
+ return result; \
+ } \
+ while (0)
+#define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
+
+/* Walk expression *E, calling EXPRFN on each expression in it. */
+
+int
+gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
+{
+ while (*e)
+ {
+ int walk_subtrees = 1;
+ gfc_actual_arglist *a;
+ gfc_ref *r;
+ gfc_constructor *c;
+
+ int result = exprfn (e, &walk_subtrees, data);
+ if (result)
+ return result;
+ if (walk_subtrees)
+ switch ((*e)->expr_type)
+ {
+ case EXPR_OP:
+ WALK_SUBEXPR ((*e)->value.op.op1);
+ WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
+ break;
+ case EXPR_FUNCTION:
+ for (a = (*e)->value.function.actual; a; a = a->next)
+ WALK_SUBEXPR (a->expr);
+ break;
+ case EXPR_COMPCALL:
+ case EXPR_PPC:
+ WALK_SUBEXPR ((*e)->value.compcall.base_object);
+ for (a = (*e)->value.compcall.actual; a; a = a->next)
+ WALK_SUBEXPR (a->expr);
+ break;
+
+ case EXPR_STRUCTURE:
+ case EXPR_ARRAY:
+ for (c = gfc_constructor_first ((*e)->value.constructor); c;
+ c = gfc_constructor_next (c))
+ {
+ WALK_SUBEXPR (c->expr);
+ if (c->iterator != NULL)
+ {
+ WALK_SUBEXPR (c->iterator->var);
+ WALK_SUBEXPR (c->iterator->start);
+ WALK_SUBEXPR (c->iterator->end);
+ WALK_SUBEXPR (c->iterator->step);
+ }
+ }
+
+ if ((*e)->expr_type != EXPR_ARRAY)
+ break;
+
+ /* Fall through to the variable case in order to walk the
+ the reference. */
+
+ case EXPR_SUBSTRING:
+ case EXPR_VARIABLE:
+ for (r = (*e)->ref; r; r = r->next)
+ {
+ gfc_array_ref *ar;
+ int i;
+
+ switch (r->type)
+ {
+ case REF_ARRAY:
+ ar = &r->u.ar;
+ if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
+ {
+ for (i=0; i< ar->dimen; i++)
+ {
+ WALK_SUBEXPR (ar->start[i]);
+ WALK_SUBEXPR (ar->end[i]);
+ WALK_SUBEXPR (ar->stride[i]);
+ }
+ }
+
+ break;
+
+ case REF_SUBSTRING:
+ WALK_SUBEXPR (r->u.ss.start);
+ WALK_SUBEXPR (r->u.ss.end);
+ break;
+
+ case REF_COMPONENT:
+ break;
+ }
+ }
+
+ default:
+ break;
+ }
+ return 0;
+ }
+ return 0;
+}
+
+#define WALK_SUBCODE(NODE) \
+ do \
+ { \
+ result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
+ if (result) \
+ return result; \
+ } \
+ while (0)
+
+/* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
+ on each expression in it. If any of the hooks returns non-zero, that
+ value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
+ no subcodes or subexpressions are traversed. */
+
+int
+gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
+ void *data)
+{
+ for (; *c; c = &(*c)->next)
+ {
+ int walk_subtrees = 1;
+ int result = codefn (c, &walk_subtrees, data);
+ if (result)
+ return result;
+
+ if (walk_subtrees)
+ {
+ gfc_code *b;
+ gfc_actual_arglist *a;
+
+ switch ((*c)->op)
+ {
+ 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);
+ break;
+
+ case EXEC_CALL:
+ case EXEC_ASSIGN_CALL:
+ for (a = (*c)->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 (a->expr);
+ break;
+
+ case EXEC_SELECT:
+ WALK_SUBEXPR ((*c)->expr1);
+ for (b = (*c)->block; b; b = b->block)
+ {
+ gfc_case *cp;
+ for (cp = b->ext.block.case_list; cp; cp = cp->next)
+ {
+ WALK_SUBEXPR (cp->low);
+ WALK_SUBEXPR (cp->high);
+ }
+ WALK_SUBCODE (b->next);
+ }
+ continue;
+
+ case EXEC_ALLOCATE:
+ case EXEC_DEALLOCATE:
+ {
+ gfc_alloc *a;
+ for (a = (*c)->ext.alloc.list; a; a = a->next)
+ WALK_SUBEXPR (a->expr);
+ break;
+ }
+
+ case EXEC_FORALL:
+ {
+ gfc_forall_iterator *fa;
+ for (fa = (*c)->ext.forall_iterator; fa; fa = fa->next)
+ {
+ WALK_SUBEXPR (fa->var);
+ WALK_SUBEXPR (fa->start);
+ WALK_SUBEXPR (fa->end);
+ WALK_SUBEXPR (fa->stride);
+ }
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ 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);
+ break;
+
+ case EXEC_OMP_DO:
+ case EXEC_OMP_PARALLEL:
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ 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)
+ {
+ WALK_SUBEXPR ((*c)->ext.omp_clauses->if_expr);
+ WALK_SUBEXPR ((*c)->ext.omp_clauses->num_threads);
+ WALK_SUBEXPR ((*c)->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 (b->expr1);
+ WALK_SUBEXPR (b->expr2);
+ WALK_SUBCODE (b->next);
+ }
+ }
}
-
- return;
+ return 0;
}
OSDN Git Service
