diff options
Diffstat (limited to 'gcc/fortran/coarray.cc')
| -rw-r--r-- | gcc/fortran/coarray.cc | 761 |
1 files changed, 761 insertions, 0 deletions
diff --git a/gcc/fortran/coarray.cc b/gcc/fortran/coarray.cc new file mode 100644 index 0000000..1094a3a --- /dev/null +++ b/gcc/fortran/coarray.cc @@ -0,0 +1,761 @@ +/* Rewrite the expression tree for coarrays. + Copyright (C) 2010-2025 Free Software Foundation, Inc. + Contributed by Andre Vehreschild. + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +<http://www.gnu.org/licenses/>. */ + +/* Rewrite the expression for coarrays where needed: + - coarray indexing operations need the indexing expression put into a + routine callable on the remote image + + This rewriter is meant to used for non-optimisational expression tree + rewrites. When implementing early optimisation it is recommended to + do this in frontend-passes.cc. +*/ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "bitmap.h" +#include "gfortran.h" + +static gfc_code **current_code; + +static bool caf_on_lhs = false; + +static gfc_array_spec * +get_arrayspec_from_expr (gfc_expr *expr) +{ + gfc_array_spec *src_as, *dst_as = NULL; + gfc_ref *ref; + gfc_array_ref mod_src_ar; + int dst_rank = 0; + + if (expr->rank == 0) + return NULL; + + /* Follow any component references. */ + if (expr->expr_type == EXPR_VARIABLE || expr->expr_type == EXPR_CONSTANT) + { + if (expr->symtree) + src_as = expr->symtree->n.sym->as; + else + src_as = NULL; + + for (ref = expr->ref; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_COMPONENT: + src_as = ref->u.c.component->as; + continue; + + case REF_SUBSTRING: + case REF_INQUIRY: + continue; + + case REF_ARRAY: + switch (ref->u.ar.type) + { + case AR_ELEMENT: + src_as = NULL; + break; + case AR_SECTION: + { + if (!dst_as) + dst_as = gfc_get_array_spec (); + memset (&mod_src_ar, 0, sizeof (gfc_array_ref)); + mod_src_ar = ref->u.ar; + for (int dim = 0; dim < src_as->rank; ++dim) + { + switch (ref->u.ar.dimen_type[dim]) + { + case DIMEN_ELEMENT: + gfc_free_expr (mod_src_ar.start[dim]); + mod_src_ar.start[dim] = NULL; + break; + case DIMEN_RANGE: + dst_as->lower[dst_rank] + = gfc_copy_expr (ref->u.ar.start[dim]); + mod_src_ar.start[dst_rank] + = gfc_copy_expr (ref->u.ar.start[dim]); + if (ref->u.ar.end[dim]) + { + dst_as->upper[dst_rank] + = gfc_copy_expr (ref->u.ar.end[dim]); + mod_src_ar.end[dst_rank] = ref->u.ar.end[dim]; + mod_src_ar.stride[dst_rank] + = ref->u.ar.stride[dim]; + } + else + dst_as->upper[dst_rank] + = gfc_copy_expr (ref->u.ar.as->upper[dim]); + ++dst_rank; + break; + case DIMEN_STAR: + dst_as->lower[dst_rank] + = gfc_copy_expr (ref->u.ar.as->lower[dim]); + mod_src_ar.start[dst_rank] + = gfc_copy_expr (ref->u.ar.start[dim]); + if (ref->u.ar.as->upper[dim]) + { + dst_as->upper[dst_rank] + = gfc_copy_expr (ref->u.ar.as->upper[dim]); + mod_src_ar.end[dst_rank] = ref->u.ar.end[dim]; + mod_src_ar.stride[dst_rank] + = ref->u.ar.stride[dim]; + } + ++dst_rank; + break; + case DIMEN_VECTOR: + dst_as->lower[dst_rank] + = gfc_get_constant_expr (BT_INTEGER, + gfc_index_integer_kind, + &expr->where); + mpz_set_ui (dst_as->lower[dst_rank]->value.integer, + 1); + mod_src_ar.start[dst_rank] + = gfc_copy_expr (ref->u.ar.start[dim]); + dst_as->upper[dst_rank] + = gfc_get_constant_expr (BT_INTEGER, + gfc_index_integer_kind, + &expr->where); + mpz_set (dst_as->upper[dst_rank]->value.integer, + ref->u.ar.start[dim]->shape[0]); + ++dst_rank; + break; + case DIMEN_THIS_IMAGE: + case DIMEN_UNKNOWN: + gcc_unreachable (); + } + if (ref->u.ar.dimen_type[dim] != DIMEN_ELEMENT) + mod_src_ar.dimen_type[dst_rank] + = ref->u.ar.dimen_type[dim]; + } + dst_as->rank = dst_rank; + dst_as->type = AS_EXPLICIT; + ref->u.ar = mod_src_ar; + ref->u.ar.dimen = dst_rank; + break; + + case AR_UNKNOWN: + src_as = NULL; + break; + + case AR_FULL: + dst_as = gfc_copy_array_spec (src_as); + break; + } + break; + } + } + } + } + else + src_as = NULL; + + return dst_as; +} + +static void +remove_coarray_from_derived_type (gfc_symbol *base, gfc_namespace *ns, + gfc_array_spec *src_as = NULL) +{ + gfc_symbol *derived; + gfc_symbol *src_derived = base->ts.u.derived; + + if (!src_as) + src_as = src_derived->as; + gfc_get_symbol (src_derived->name, ns, &derived); + derived->attr.flavor = FL_DERIVED; + derived->attr.alloc_comp = src_derived->attr.alloc_comp; + if (src_as && src_as->rank != 0) + { + base->attr.dimension = 1; + base->as = gfc_copy_array_spec (src_as); + base->as->corank = 0; + } + for (gfc_component *p = NULL, *c = src_derived->components; c; c = c->next) + { + gfc_component *n = gfc_get_component (); + *n = *c; + if (n->as) + n->as = gfc_copy_array_spec (c->as); + n->backend_decl = NULL; + n->initializer = NULL; + n->param_list = NULL; + if (p) + p->next = n; + else + derived->components = n; + + p = n; + } + gfc_set_sym_referenced (derived); + gfc_commit_symbol (derived); + base->ts.u.derived = derived; + gfc_commit_symbol (base); +} + +static void +convert_coarray_class_to_derived_type (gfc_symbol *base, gfc_namespace *ns) +{ + gfc_symbol *src_derived = CLASS_DATA (base)->ts.u.derived; + gfc_array_spec *src_as = CLASS_DATA (base)->as; + const bool attr_allocatable + = src_as && src_as->rank && src_as->type == AS_DEFERRED; + + base->ts.type = BT_DERIVED; + base->ts.u.derived = src_derived; + + remove_coarray_from_derived_type (base, ns, src_as); + + base->attr.allocatable = attr_allocatable; + base->attr.pointer = 0; // Ensure, that it is no pointer. +} + +static void +split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns, + gfc_expr **post_caf_ref_expr) +{ + gfc_ref *caf_ref = NULL; + gfc_symtree *st; + gfc_symbol *base; + + gcc_assert (expr->expr_type == EXPR_VARIABLE); + if (!expr->symtree->n.sym->attr.codimension) + { + /* The coarray is in some component. Find it. */ + caf_ref = expr->ref; + while (caf_ref) + { + if (caf_ref->type == REF_COMPONENT + && caf_ref->u.c.component->attr.codimension) + break; + caf_ref = caf_ref->next; + } + } + + gcc_assert (!gfc_get_sym_tree (!caf_ref ? expr->symtree->name : "base", ns, + &st, false)); + st->n.sym->attr.flavor = FL_PARAMETER; + st->n.sym->attr.dummy = 1; + st->n.sym->attr.intent = INTENT_IN; + st->n.sym->ts = caf_ref ? caf_ref->u.c.sym->ts : expr->symtree->n.sym->ts; + + *post_caf_ref_expr = gfc_get_variable_expr (st); + (*post_caf_ref_expr)->where = expr->where; + base = (*post_caf_ref_expr)->symtree->n.sym; + + if (!caf_ref) + { + (*post_caf_ref_expr)->ref = gfc_copy_ref (expr->ref); + if (expr->symtree->n.sym->attr.dimension) + { + base->as = gfc_copy_array_spec (expr->symtree->n.sym->as); + base->as->corank = 0; + base->attr.dimension = 1; + base->attr.allocatable = expr->symtree->n.sym->attr.allocatable; + base->attr.pointer = expr->symtree->n.sym->attr.pointer + || expr->symtree->n.sym->attr.associate_var; + } + } + else + { + (*post_caf_ref_expr)->ref = gfc_copy_ref (caf_ref->next); + if (caf_ref->u.c.component->attr.dimension) + { + base->as = gfc_copy_array_spec (caf_ref->u.c.component->as); + base->as->corank = 0; + base->attr.dimension = 1; + base->attr.allocatable = caf_ref->u.c.component->attr.allocatable; + base->attr.pointer = caf_ref->u.c.component->attr.pointer; + } + base->ts = caf_ref->u.c.component->ts; + } + (*post_caf_ref_expr)->ts = expr->ts; + if (base->ts.type == BT_CHARACTER) + { + base->ts.u.cl = gfc_get_charlen (); + *base->ts.u.cl = *(caf_ref ? caf_ref->u.c.component->ts.u.cl + : expr->symtree->n.sym->ts.u.cl); + base->ts.deferred = 1; + base->ts.u.cl->length = nullptr; + } + + if (base->ts.type == BT_DERIVED) + remove_coarray_from_derived_type (base, ns); + else if (base->ts.type == BT_CLASS) + convert_coarray_class_to_derived_type (base, ns); + + gfc_expression_rank (expr); + gfc_expression_rank (*post_caf_ref_expr); +} + +static void +check_add_new_component (gfc_symbol *type, gfc_expr *e, gfc_symbol *get_data) +{ + if (e) + { + switch (e->expr_type) + { + case EXPR_CONSTANT: + case EXPR_NULL: + break; + case EXPR_OP: + check_add_new_component (type, e->value.op.op1, get_data); + if (e->value.op.op2) + check_add_new_component (type, e->value.op.op2, get_data); + break; + case EXPR_COMPCALL: + for (gfc_actual_arglist *actual = e->value.compcall.actual; actual; + actual = actual->next) + check_add_new_component (type, actual->expr, get_data); + break; + case EXPR_FUNCTION: + if (!e->symtree->n.sym->attr.pure + && !e->symtree->n.sym->attr.elemental) + { + // Treat non-pure functions. + gfc_error ("Sorry, not yet able to call a non-pure/non-elemental" + " function %s in a coarray reference; use a temporary" + " for the function's result instead", + e->symtree->n.sym->name); + } + for (gfc_actual_arglist *actual = e->value.function.actual; actual; + actual = actual->next) + check_add_new_component (type, actual->expr, get_data); + break; + case EXPR_VARIABLE: + { + gfc_component *comp; + gfc_ref *ref; + int old_rank = e->rank; + + /* Can't use gfc_find_component here, because type is not yet + complete. */ + comp = type->components; + while (comp) + { + if (strcmp (comp->name, e->symtree->name) == 0) + break; + comp = comp->next; + } + if (!comp) + { + gcc_assert (gfc_add_component (type, e->symtree->name, &comp)); + /* Take a copy of e, before modifying it. */ + gfc_expr *init = gfc_copy_expr (e); + if (e->ref) + { + switch (e->ref->type) + { + case REF_ARRAY: + comp->as = get_arrayspec_from_expr (e); + comp->attr.dimension = e->ref->u.ar.dimen != 0; + comp->ts = e->ts; + break; + case REF_COMPONENT: + comp->ts = e->ref->u.c.sym->ts; + break; + default: + gcc_unreachable (); + break; + } + } + else + comp->ts = e->ts; + comp->attr.access = ACCESS_PRIVATE; + comp->initializer = init; + } + else + gcc_assert (comp->ts.type == e->ts.type + && comp->ts.u.derived == e->ts.u.derived); + + ref = e->ref; + e->ref = NULL; + gcc_assert (gfc_find_component (get_data->ts.u.derived, + e->symtree->name, false, true, + &e->ref)); + e->symtree + = gfc_find_symtree (get_data->ns->sym_root, get_data->name); + e->ref->next = ref; + gfc_free_shape (&e->shape, old_rank); + gfc_expression_rank (e); + break; + } + case EXPR_ARRAY: + case EXPR_PPC: + case EXPR_STRUCTURE: + case EXPR_SUBSTRING: + gcc_unreachable (); + default:; + } + } +} + +static gfc_symbol * +create_get_parameter_type (gfc_expr *expr, gfc_namespace *ns, + gfc_symbol *get_data) +{ + static int type_cnt = 0; + char tname[GFC_MAX_SYMBOL_LEN + 1]; + char *name; + gfc_symbol *type; + + gcc_assert (expr->expr_type == EXPR_VARIABLE); + + strcpy (tname, expr->symtree->name); + name = xasprintf ("@_rget_data_t_%s_%d", tname, ++type_cnt); + gfc_get_symbol (name, ns, &type); + + type->attr.flavor = FL_DERIVED; + get_data->ts.u.derived = type; + + for (gfc_ref *ref = expr->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY) + { + gfc_array_ref *ar = &ref->u.ar; + for (int i = 0; i < ar->dimen; ++i) + { + check_add_new_component (type, ar->start[i], get_data); + check_add_new_component (type, ar->end[i], get_data); + check_add_new_component (type, ar->stride[i], get_data); + } + } + } + + gfc_set_sym_referenced (type); + gfc_commit_symbol (type); + return type; +} + +static gfc_expr * +create_get_callback (gfc_expr *expr) +{ + static int cnt = 0; + gfc_namespace *ns; + gfc_symbol *extproc, *proc, *buffer, *free_buffer, *base, *get_data, + *old_buffer_data; + char tname[GFC_MAX_SYMBOL_LEN + 1]; + char *name; + const char *mname; + gfc_expr *cb, *post_caf_ref_expr; + gfc_code *code; + int expr_rank = expr->rank; + + /* Find the top-level namespace. */ + for (ns = gfc_current_ns; ns->parent; ns = ns->parent) + ; + + if (expr->expr_type == EXPR_VARIABLE) + strcpy (tname, expr->symtree->name); + else + strcpy (tname, "dummy"); + if (expr->symtree->n.sym->module) + mname = expr->symtree->n.sym->module; + else + mname = "main"; + name = xasprintf ("_caf_rget_%s_%s_%d", mname, tname, ++cnt); + gfc_get_symbol (name, ns, &extproc); + gfc_set_sym_referenced (extproc); + ++extproc->refs; + gfc_commit_symbol (extproc); + + /* Set up namespace. */ + gfc_namespace *sub_ns = gfc_get_namespace (ns, 0); + sub_ns->sibling = ns->contained; + ns->contained = sub_ns; + sub_ns->resolved = 1; + /* Set up procedure symbol. */ + gfc_find_symbol (name, sub_ns, 1, &proc); + sub_ns->proc_name = proc; + proc->attr.if_source = IFSRC_DECL; + proc->attr.access = ACCESS_PUBLIC; + gfc_add_subroutine (&proc->attr, name, NULL); + proc->attr.host_assoc = 1; + proc->attr.always_explicit = 1; + ++proc->refs; + gfc_commit_symbol (proc); + free (name); + + split_expr_at_caf_ref (expr, sub_ns, &post_caf_ref_expr); + + if (ns->proc_name->attr.flavor == FL_MODULE) + proc->module = ns->proc_name->name; + gfc_set_sym_referenced (proc); + /* Set up formal arguments. */ + gfc_formal_arglist **argptr = &proc->formal; +#define ADD_ARG(name, nsym, stype, sintent) \ + gfc_get_symbol (name, sub_ns, &nsym); \ + nsym->ts.type = stype; \ + nsym->attr.flavor = FL_PARAMETER; \ + nsym->attr.dummy = 1; \ + nsym->attr.intent = sintent; \ + gfc_set_sym_referenced (nsym); \ + *argptr = gfc_get_formal_arglist (); \ + (*argptr)->sym = nsym; \ + argptr = &(*argptr)->next + + ADD_ARG ("buffer", buffer, expr->ts.type, INTENT_INOUT); + buffer->ts = expr->ts; + if (expr_rank) + { + buffer->as = gfc_get_array_spec (); + buffer->as->rank = expr_rank; + if (expr->shape) + { + buffer->as->type = AS_EXPLICIT; + for (int d = 0; d < expr_rank; ++d) + { + buffer->as->lower[d] + = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, + &gfc_current_locus); + gfc_mpz_set_hwi (buffer->as->lower[d]->value.integer, 1); + buffer->as->upper[d] + = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, + &gfc_current_locus); + gfc_mpz_set_hwi (buffer->as->upper[d]->value.integer, + gfc_mpz_get_hwi (expr->shape[d])); + } + buffer->attr.allocatable = 1; + } + else + { + buffer->as->type = AS_DEFERRED; + buffer->attr.allocatable = 1; + } + buffer->attr.dimension = 1; + } + else + buffer->attr.pointer = 1; + if (buffer->ts.type == BT_CHARACTER) + { + buffer->ts.u.cl = gfc_get_charlen (); + *buffer->ts.u.cl = *expr->ts.u.cl; + buffer->ts.deferred = 1; + buffer->ts.u.cl->length = nullptr; + } + gfc_commit_symbol (buffer); + ADD_ARG ("free_buffer", free_buffer, BT_LOGICAL, INTENT_OUT); + free_buffer->ts.kind = gfc_default_logical_kind; + gfc_commit_symbol (free_buffer); + + // ADD_ARG (expr->symtree->name, base, BT_VOID, INTENT_IN); + base = post_caf_ref_expr->symtree->n.sym; + gfc_set_sym_referenced (base); + gfc_commit_symbol (base); + *argptr = gfc_get_formal_arglist (); + (*argptr)->sym = base; + argptr = &(*argptr)->next; + + gfc_commit_symbol (base); + ADD_ARG ("get_data", get_data, BT_DERIVED, INTENT_IN); + gfc_commit_symbol (get_data); +#undef ADD_ARG + + /* Set up code. */ + if (expr->rank != 0) + { + /* Code: old_buffer_ptr = C_LOC (buffer); */ + code = sub_ns->code = gfc_get_code (EXEC_ASSIGN); + gfc_get_symbol ("old_buffer_data", sub_ns, &old_buffer_data); + old_buffer_data->ts.type = BT_VOID; + old_buffer_data->attr.flavor = FL_VARIABLE; + gfc_set_sym_referenced (old_buffer_data); + gfc_commit_symbol (old_buffer_data); + code->expr1 = gfc_lval_expr_from_sym (old_buffer_data); + code->expr2 = gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC", + gfc_current_locus, 1, + gfc_lval_expr_from_sym (buffer)); + code->next = gfc_get_code (EXEC_ASSIGN); + code = code->next; + } + else + code = sub_ns->code = gfc_get_code (EXEC_POINTER_ASSIGN); + + /* Code: buffer = expr; */ + code->expr1 = gfc_lval_expr_from_sym (buffer); + code->expr2 = post_caf_ref_expr; + gfc_ref *ref = code->expr2->ref, **pref = &code->expr2->ref; + if (ref && ref->type == REF_ARRAY && ref->u.ar.codimen != 0) + { + if (ref->u.ar.dimen != 0) + { + ref->u.ar.codimen = 0; + pref = &ref->next; + ref = ref->next; + } + else + { + code->expr2->ref = ref->next; + ref->next = NULL; + gfc_free_ref_list (ref); + ref = code->expr2->ref; + pref = &code->expr2->ref; + } + } + if (ref && ref->type == REF_COMPONENT) + { + gfc_find_component (code->expr2->symtree->n.sym->ts.u.derived, + ref->u.c.component->name, false, false, pref); + if (*pref != ref) + { + (*pref)->next = ref->next; + ref->next = NULL; + gfc_free_ref_list (ref); + } + } + get_data->ts.u.derived + = create_get_parameter_type (code->expr2, ns, get_data); + if (code->expr2->rank == 0) + code->expr2 = gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC", + gfc_current_locus, 1, code->expr2); + + /* Code: *free_buffer = old_buffer_ptr /= C_LOC (buffer); for rank != 0 or + * *free_buffer = 0; for rank == 0. */ + code->next = gfc_get_code (EXEC_ASSIGN); + code = code->next; + code->expr1 = gfc_lval_expr_from_sym (free_buffer); + if (expr->rank != 0) + { + code->expr2 = gfc_get_operator_expr ( + &gfc_current_locus, INTRINSIC_NE_OS, + gfc_lval_expr_from_sym (old_buffer_data), + gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC", + gfc_current_locus, 1, + gfc_lval_expr_from_sym (buffer))); + code->expr2->ts.type = BT_LOGICAL; + code->expr2->ts.kind = gfc_default_logical_kind; + } + else + { + code->expr2 = gfc_get_logical_expr (gfc_default_logical_kind, + &gfc_current_locus, false); + } + + cb = gfc_lval_expr_from_sym (extproc); + cb->ts.interface = extproc; + + return cb; +} + +static void +add_caf_get_intrinsic (gfc_expr *e) +{ + gfc_expr *wrapper, *tmp_expr, *rget_expr, *rget_hash_expr; + gfc_ref *ref; + int n; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + break; + if (ref == NULL) + return; + + for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++) + if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT) + return; + + tmp_expr = XCNEW (gfc_expr); + *tmp_expr = *e; + rget_expr = create_get_callback (tmp_expr); + rget_hash_expr = gfc_get_expr (); + rget_hash_expr->expr_type = EXPR_CONSTANT; + rget_hash_expr->ts.type = BT_INTEGER; + rget_hash_expr->ts.kind = gfc_default_integer_kind; + rget_hash_expr->where = tmp_expr->where; + mpz_init_set_ui (rget_hash_expr->value.integer, + gfc_hash_value (rget_expr->symtree->n.sym)); + wrapper = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_CAF_GET, + "caf_get", tmp_expr->where, 3, tmp_expr, + rget_hash_expr, rget_expr); + gfc_add_caf_accessor (rget_hash_expr, rget_expr); + wrapper->ts = e->ts; + wrapper->rank = e->rank; + wrapper->corank = e->corank; + if (e->rank) + wrapper->shape = gfc_copy_shape (e->shape, e->rank); + *e = *wrapper; + free (wrapper); +} + +static int +coindexed_expr_callback (gfc_expr **e, int *walk_subtrees, + void *data ATTRIBUTE_UNUSED) +{ + if ((*e)->expr_type == EXPR_VARIABLE) + { + if (!caf_on_lhs && gfc_is_coindexed (*e)) + { + add_caf_get_intrinsic (*e); + *walk_subtrees = 0; + return 0; + } + /* Clear the flag to rewrite caf_gets in sub expressions of the lhs. */ + caf_on_lhs = false; + } + + *walk_subtrees = 1; + return 0; +} + +static int +coindexed_code_callback (gfc_code **c, int *walk_subtrees, + void *data ATTRIBUTE_UNUSED) +{ + int ws = 1; + current_code = c; + + switch ((*c)->op) + { + case EXEC_ASSIGN: + case EXEC_POINTER_ASSIGN: + caf_on_lhs = true; + coindexed_expr_callback (&((*c)->expr1), &ws, NULL); + caf_on_lhs = false; + ws = 1; + coindexed_expr_callback (&((*c)->expr2), &ws, NULL); + *walk_subtrees = ws; + break; + case EXEC_LOCK: + case EXEC_UNLOCK: + case EXEC_EVENT_POST: + case EXEC_EVENT_WAIT: + *walk_subtrees = 0; + break; + default: + *walk_subtrees = 1; + break; + } + return 0; +} + +void +gfc_coarray_rewrite (gfc_namespace *ns) +{ + gfc_namespace *saved_ns = gfc_current_ns; + gfc_current_ns = ns; + + if (flag_coarray == GFC_FCOARRAY_LIB) + gfc_code_walker (&ns->code, coindexed_code_callback, + coindexed_expr_callback, NULL); + + gfc_current_ns = saved_ns; +} |