diff options
Diffstat (limited to 'gcc/fortran/iresolve.cc')
| -rw-r--r-- | gcc/fortran/iresolve.cc | 214 |
1 files changed, 214 insertions, 0 deletions
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc index 55f7e19..8189d7a 100644 --- a/gcc/fortran/iresolve.cc +++ b/gcc/fortran/iresolve.cc @@ -2408,6 +2408,220 @@ gfc_resolve_realpart (gfc_expr *f, gfc_expr *a) } +/* Generate a wrapper subroutine for the operation so that the library REDUCE + function can use pointer arithmetic for OPERATION and not be dependent on + knowledge of its type. */ +static gfc_symtree * +generate_reduce_op_wrapper (gfc_expr *op) +{ + gfc_symbol *operation = op->symtree->n.sym; + gfc_symbol *wrapper, *a, *b, *c; + gfc_symtree *st; + char tname[GFC_MAX_SYMBOL_LEN+1]; + char *name; + gfc_namespace *ns; + gfc_expr *e; + + /* Find the top-level namespace. */ + for (ns = gfc_current_ns; ns; ns = ns->parent) + if (!ns->parent) + break; + + sprintf (tname, "%s_%s", operation->name, + ns->proc_name ? ns->proc_name->name : "noname"); + name = xasprintf ("__reduce_wrapper_%s", tname); + + gfc_find_sym_tree (name, ns, 0, &st); + + if (st && !strcmp (name, st->name)) + { + free (name); + return st; + } + + /* Create the wrapper namespace and contain it in 'ns'. */ + 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_get_symbol (name, ns, &wrapper); + sub_ns->proc_name = wrapper; + wrapper->attr.flavor = FL_PROCEDURE; + wrapper->attr.subroutine = 1; + wrapper->attr.artificial = 1; + wrapper->attr.if_source = IFSRC_DECL; + if (ns->proc_name->attr.flavor == FL_MODULE) + wrapper->module = ns->proc_name->name; + gfc_set_sym_referenced (wrapper); + + /* Set up formal argument for the argument 'a'. */ + gfc_get_symbol ("a", sub_ns, &a); + a->ts = operation->ts; + a->attr.flavor = FL_VARIABLE; + a->attr.dummy = 1; + a->attr.artificial = 1; + a->attr.intent = INTENT_INOUT; + wrapper->formal = gfc_get_formal_arglist (); + wrapper->formal->sym = a; + gfc_set_sym_referenced (a); + + /* Set up formal argument for the argument 'b'. This is optional. When + present, the wrapped function is called, otherwise 'a' is assigned + to 'c'. This way, deep copies are effected in the library. */ + gfc_get_symbol ("b", sub_ns, &b); + b->ts = operation->ts; + b->attr.flavor = FL_VARIABLE; + b->attr.dummy = 1; + b->attr.optional= 1; + b->attr.artificial = 1; + b->attr.intent = INTENT_INOUT; + wrapper->formal->next = gfc_get_formal_arglist (); + wrapper->formal->next->sym = b; + gfc_set_sym_referenced (b); + + /* Set up formal argument for the argument 'c'. */ + gfc_get_symbol ("c", sub_ns, &c); + c->ts = operation->ts; + c->attr.flavor = FL_VARIABLE; + c->attr.dummy = 1; + c->attr.artificial = 1; + c->attr.intent = INTENT_INOUT; + wrapper->formal->next->next = gfc_get_formal_arglist (); + wrapper->formal->next->next->sym = c; + gfc_set_sym_referenced (c); + +/* The only code is: + if (present (b)) + c = operation (a, b) + else + c = a + endif + A call with 'b' missing provides a convenient way for the library to do + an intrinsic assignment instead of a call to memcpy and, where allocatable + components are present, a deep copy. + + Code for if (present (b)) */ + sub_ns->code = gfc_get_code (EXEC_IF); + gfc_code *if_block = sub_ns->code; + if_block->block = gfc_get_code (EXEC_IF); + if_block->block->expr1 = gfc_get_expr (); + e = if_block->block->expr1; + e->expr_type = EXPR_FUNCTION; + e->where = gfc_current_locus; + gfc_get_sym_tree ("present", sub_ns, &e->symtree, false); + e->symtree->n.sym->attr.flavor = FL_PROCEDURE; + e->symtree->n.sym->attr.intrinsic = 1; + e->ts.type = BT_LOGICAL; + e->ts.kind = gfc_default_logical_kind; + e->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_PRESENT); + e->value.function.actual = gfc_get_actual_arglist (); + e->value.function.actual->expr = gfc_lval_expr_from_sym (b); + +/* Code for c = operation (a, b) */ + if_block->block->next = gfc_get_code (EXEC_ASSIGN); + if_block->block->next->expr1 = gfc_lval_expr_from_sym (c); + if_block->block->next->expr2 = gfc_get_expr (); + e = if_block->block->next->expr2; + e->expr_type = EXPR_FUNCTION; + e->where = gfc_current_locus; + if_block->block->next->expr2->ts = operation->ts; + gfc_get_sym_tree (operation->name, ns, &e->symtree, false); + e->value.function.esym = if_block->block->next->expr2->symtree->n.sym; + e->value.function.actual = gfc_get_actual_arglist (); + e->value.function.actual->expr = gfc_lval_expr_from_sym (a); + e->value.function.actual->next = gfc_get_actual_arglist (); + e->value.function.actual->next->expr = gfc_lval_expr_from_sym (b); + + if_block->block->block = gfc_get_code (EXEC_IF); + if_block->block->block->next = gfc_get_code (EXEC_ASSIGN); + if_block->block->block->next->expr1 = gfc_lval_expr_from_sym (c); + if_block->block->block->next->expr2 = gfc_lval_expr_from_sym (a); + + /* It is unexpected to have some symbols added at resolution. Commit the + changes in order to keep a clean state. */ + gfc_commit_symbol (if_block->block->expr1->symtree->n.sym); + gfc_commit_symbol (wrapper); + gfc_commit_symbol (a); + gfc_commit_symbol (b); + gfc_commit_symbol (c); + + gfc_find_sym_tree (name, ns, 0, &st); + free (name); + + return st; +} + +void +gfc_resolve_reduce (gfc_expr *f, gfc_expr *array, + gfc_expr *operation, + gfc_expr *dim, + gfc_expr *mask, + gfc_expr *identity ATTRIBUTE_UNUSED, + gfc_expr *ordered ATTRIBUTE_UNUSED) +{ + gfc_symtree *wrapper_symtree; + gfc_typespec ts; + + gfc_resolve_expr (array); + if (array->ts.type == BT_CHARACTER && array->ref) + gfc_resolve_substring_charlen (array); + + f->ts = array->ts; + + /* Replace 'operation' with its subroutine wrapper so that pointers may be + used throughout the library function. */ + wrapper_symtree = generate_reduce_op_wrapper (operation); + gcc_assert (wrapper_symtree && wrapper_symtree->n.sym); + operation->symtree = wrapper_symtree; + operation->ts = operation->symtree->n.sym->ts; + + /* The scalar library function converts the scalar result to a dimension + zero descriptor and then returns the data after the call. */ + if (f->ts.type == BT_CHARACTER) + { + if (dim && array->rank > 1) + { + f->value.function.name = gfc_get_string (PREFIX ("reduce_c")); + f->rank = array->rank - 1; + } + else + { + f->value.function.name = gfc_get_string (PREFIX ("reduce_scalar_c")); + f->rank = 0; + } + } + else + { + if (dim && array->rank > 1) + { + f->value.function.name = gfc_get_string (PREFIX ("reduce")); + f->rank = array->rank - 1; + } + else + { + f->value.function.name = gfc_get_string (PREFIX ("reduce_scalar")); + f->rank = 0; + } + } + + if (dim) + { + ts = dim->ts; + ts.kind = 4; + gfc_convert_type_warn (dim, &ts, 1, 0); + } + + if (mask) + { + ts = mask->ts; + ts.kind = 4; + gfc_convert_type_warn (mask, &ts, 1, 0); + } +} + + void gfc_resolve_rename (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED, gfc_expr *p2 ATTRIBUTE_UNUSED) |