+2013-01-29 Janus Weil <janus@gcc.gnu.org>
+ Mikael Morin <mikael@gcc.gnu.org>
+
+ PR fortran/54107
+ * gfortran.h (gfc_component): Delete members 'formal' and 'formal_ns'.
+ (gfc_copy_formal_args,gfc_copy_formal_args_ppc,gfc_expr_replace_symbols,
+ gfc_expr_replace_comp): Delete.
+ (gfc_sym_get_dummy_args): New prototype.
+ * dependency.c (gfc_check_fncall_dependency): Use
+ 'gfc_sym_get_dummy_args'.
+ * expr.c (gfc_is_constant_expr): Ditto.
+ (replace_symbol,gfc_expr_replace_symbols,replace_comp,
+ gfc_expr_replace_comp): Deleted.
+ * frontend-passes.c (doloop_code,do_function): Use
+ 'gfc_sym_get_dummy_args'.
+ * interface.c (gfc_check_operator_interface,gfc_compare_interfaces,
+ gfc_procedure_use,gfc_ppc_use,gfc_arglist_matches_symbol,
+ gfc_check_typebound_override): Ditto.
+ * module.c (MOD_VERSION): Bump module version.
+ (mio_component): Do not read/write 'formal' and 'formal_ns'.
+ * resolve.c (resolve_procedure_interface,resolve_fl_derived0): Do not
+ copy formal args, but just keep a pointer to the interface.
+ (resolve_function,resolve_call,resolve_typebound_generic_call,
+ resolve_ppc_call,resolve_expr_ppc,generate_component_assignments,
+ resolve_fl_procedure,gfc_resolve_finalizers,check_generic_tbp_ambiguity,
+ resolve_typebound_procedure,check_uop_procedure): Use
+ 'gfc_sym_get_dummy_args'.
+ * symbol.c (free_components): Do not free 'formal' and 'formal_ns'.
+ (gfc_copy_formal_args,gfc_copy_formal_args_ppc): Deleted.
+ (gfc_sym_get_dummy_args): New function.
+ * trans-array.c (get_array_charlen,gfc_walk_elemental_function_args):
+ Use 'gfc_sym_get_dummy_args'.
+ * trans-decl.c (build_function_decl,create_function_arglist,
+ build_entry_thunks,init_intent_out_dt,gfc_trans_deferred_vars,
+ add_argument_checking): Ditto.
+ * trans-expr.c (gfc_map_fcn_formal_to_actual,gfc_conv_procedure_call,
+ gfc_conv_statement_function): Ditto.
+ * trans-stmt.c (gfc_conv_elemental_dependencies): Ditto.
+ * trans-types.c (create_fn_spec,gfc_get_function_type): Ditto.
+
2013-01-28 Tobias Burnus <burnus@net-b.de>
Mikael Morin <mikael@gcc.gnu.org>
gfc_formal_arglist *formal;
gfc_expr *expr;
- formal = fnsym ? fnsym->formal : NULL;
+ formal = fnsym ? gfc_sym_get_dummy_args (fnsym) : NULL;
for (; actual; actual = actual->next, formal = formal ? formal->next : NULL)
{
expr = actual->expr;
&& sym->attr.proc != PROC_INTERNAL
&& sym->attr.proc != PROC_ST_FUNCTION
&& sym->attr.proc != PROC_UNKNOWN
- && sym->formal == NULL)
+ && gfc_sym_get_dummy_args (sym) == NULL)
return 1;
if (e->value.function.isym
}
-/* Walk an expression tree and replace all dummy symbols by the corresponding
- symbol in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
- statements. The boolean return value is required by gfc_traverse_expr. */
-
-static bool
-replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
-{
- if ((expr->expr_type == EXPR_VARIABLE
- || (expr->expr_type == EXPR_FUNCTION
- && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
- && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns
- && expr->symtree->n.sym->attr.dummy)
- {
- gfc_symtree *root = sym->formal_ns ? sym->formal_ns->sym_root
- : gfc_current_ns->sym_root;
- gfc_symtree *stree = gfc_find_symtree (root, expr->symtree->n.sym->name);
- gcc_assert (stree);
- stree->n.sym->attr = expr->symtree->n.sym->attr;
- expr->symtree = stree;
- }
- return false;
-}
-
-void
-gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
-{
- gfc_traverse_expr (expr, dest, &replace_symbol, 0);
-}
-
-
-/* The following is analogous to 'replace_symbol', and needed for copying
- interfaces for procedure pointer components. The argument 'sym' must formally
- be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
- However, it gets actually passed a gfc_component (i.e. the procedure pointer
- component in whose formal_ns the arguments have to be). */
-
-static bool
-replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
-{
- gfc_component *comp;
- comp = (gfc_component *)sym;
- if ((expr->expr_type == EXPR_VARIABLE
- || (expr->expr_type == EXPR_FUNCTION
- && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
- && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
- {
- gfc_symtree *stree;
- gfc_namespace *ns = comp->formal_ns;
- /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
- the symtree rather than create a new one (and probably fail later). */
- stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
- expr->symtree->n.sym->name);
- gcc_assert (stree);
- stree->n.sym->attr = expr->symtree->n.sym->attr;
- expr->symtree = stree;
- }
- return false;
-}
-
-void
-gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
-{
- gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);
-}
-
-
bool
gfc_ref_this_image (gfc_ref *ref)
{
if (co->resolved_sym == NULL)
break;
- f = co->resolved_sym->formal;
+ f = gfc_sym_get_dummy_args (co->resolved_sym);
/* Withot a formal arglist, there is only unknown INTENT,
which we don't check for. */
if (expr->value.function.isym)
return 0;
- f = expr->symtree->n.sym->formal;
+ f = gfc_sym_get_dummy_args (expr->symtree->n.sym);
/* Without a formal arglist, there is only unknown INTENT,
which we don't check for. */
struct gfc_component *next;
/* Needed for procedure pointer components. */
- struct gfc_formal_arglist *formal;
- struct gfc_namespace *formal_ns;
struct gfc_typebound_proc *tb;
}
gfc_component;
bool gfc_type_is_extension_of (gfc_symbol *, gfc_symbol *);
bool gfc_type_compatible (gfc_typespec *, gfc_typespec *);
-void gfc_copy_formal_args (gfc_symbol *, gfc_symbol *, ifsrc);
void gfc_copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *);
-void gfc_copy_formal_args_ppc (gfc_component *, gfc_symbol *, ifsrc);
void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too */
bool gfc_is_associate_pointer (gfc_symbol*);
gfc_symbol * gfc_find_dt_in_generic (gfc_symbol *);
+gfc_formal_arglist *gfc_sym_get_dummy_args (gfc_symbol *);
/* intrinsic.c -- true if working in an init-expr, false otherwise. */
extern bool gfc_init_expr_flag;
int);
void gfc_expr_set_symbols_referenced (gfc_expr *);
gfc_try gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
-void gfc_expr_replace_symbols (gfc_expr *, gfc_symbol *);
-void gfc_expr_replace_comp (gfc_expr *, gfc_component *);
gfc_component * gfc_get_proc_ptr_comp (gfc_expr *);
bool gfc_is_proc_ptr_comp (gfc_expr *);
r1 = r2 = -1;
k1 = k2 = -1;
- for (formal = sym->formal; formal; formal = formal->next)
+ for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next)
{
gfc_symbol *fsym = formal->sym;
if (fsym == NULL)
INTRINSIC_ASSIGN which should map to a subroutine. */
if (op == INTRINSIC_ASSIGN)
{
+ gfc_formal_arglist *dummy_args;
+
if (!sym->attr.subroutine)
{
gfc_error ("Assignment operator interface at %L must be "
- First argument is a scalar and second an array,
- Types and kinds do not conform, or
- First argument is of derived type. */
- if (sym->formal->sym->ts.type != BT_DERIVED
- && sym->formal->sym->ts.type != BT_CLASS
+ dummy_args = gfc_sym_get_dummy_args (sym);
+ if (dummy_args->sym->ts.type != BT_DERIVED
+ && dummy_args->sym->ts.type != BT_CLASS
&& (r2 == 0 || r1 == r2)
- && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
- || (gfc_numeric_ts (&sym->formal->sym->ts)
- && gfc_numeric_ts (&sym->formal->next->sym->ts))))
+ && (dummy_args->sym->ts.type == dummy_args->next->sym->ts.type
+ || (gfc_numeric_ts (&dummy_args->sym->ts)
+ && gfc_numeric_ts (&dummy_args->next->sym->ts))))
{
gfc_error ("Assignment operator interface at %L must not redefine "
"an INTRINSIC type assignment", &sym->declared_at);
|| s2->attr.if_source == IFSRC_UNKNOWN)
return 1;
- f1 = s1->formal;
- f2 = s2->formal;
+ f1 = gfc_sym_get_dummy_args (s1);
+ f2 = gfc_sym_get_dummy_args (s2);
if (f1 == NULL && f2 == NULL)
return 1; /* Special case: No arguments. */
gfc_try
gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
{
+ gfc_formal_arglist *dummy_args;
+
/* Warn about calls with an implicit interface. Special case
for calling a ISO_C_BINDING becase c_loc and c_funloc
are pseudo-unknown. Additionally, warn about procedures not
return SUCCESS;
}
- if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where))
+ dummy_args = gfc_sym_get_dummy_args (sym);
+
+ if (!compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental, where))
return FAILURE;
- if (check_intents (sym->formal, *ap) == FAILURE)
+ if (check_intents (dummy_args, *ap) == FAILURE)
return FAILURE;
if (gfc_option.warn_aliasing)
- check_some_aliasing (sym->formal, *ap);
+ check_some_aliasing (dummy_args, *ap);
return SUCCESS;
}
void
gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
{
-
/* Warn about calls with an implicit interface. Special case
for calling a ISO_C_BINDING becase c_loc and c_funloc
are pseudo-unknown. */
return;
}
- if (!compare_actual_formal (ap, comp->formal, 0, comp->attr.elemental, where))
+ if (!compare_actual_formal (ap, comp->ts.interface->formal, 0,
+ comp->attr.elemental, where))
return;
- check_intents (comp->formal, *ap);
+ check_intents (comp->ts.interface->formal, *ap);
if (gfc_option.warn_aliasing)
- check_some_aliasing (comp->formal, *ap);
+ check_some_aliasing (comp->ts.interface->formal, *ap);
}
bool
gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
{
+ gfc_formal_arglist *dummy_args;
bool r;
gcc_assert (sym->attr.flavor == FL_PROCEDURE);
+ dummy_args = gfc_sym_get_dummy_args (sym);
+
r = !sym->attr.elemental;
- if (compare_actual_formal (args, sym->formal, r, !r, NULL))
+ if (compare_actual_formal (args, dummy_args, r, !r, NULL))
{
- check_intents (sym->formal, *args);
+ check_intents (dummy_args, *args);
if (gfc_option.warn_aliasing)
- check_some_aliasing (sym->formal, *args);
+ check_some_aliasing (dummy_args, *args);
return true;
}
if (!old->n.tb->nopass && !old->n.tb->pass_arg)
old_pass_arg = 1;
argpos = 1;
- for (proc_formal = proc_target->formal, old_formal = old_target->formal;
- proc_formal && old_formal;
+ proc_formal = gfc_sym_get_dummy_args (proc_target);
+ old_formal = gfc_sym_get_dummy_args (old_target);
+ for ( ; proc_formal && old_formal;
proc_formal = proc_formal->next, old_formal = old_formal->next)
{
if (proc->n.tb->pass_arg
/* Don't put any single quote (') in MOD_VERSION,
if yout want it to be recognized. */
-#define MOD_VERSION "9"
+#define MOD_VERSION "10"
/* Structure that describes a position within a module file. */
{
pointer_info *p;
int n;
- gfc_formal_arglist *formal;
mio_lparen ();
mio_expr (&c->initializer);
if (c->attr.proc_pointer)
- {
- if (iomode == IO_OUTPUT)
- {
- formal = c->formal;
- while (formal && !formal->sym)
- formal = formal->next;
-
- if (formal)
- mio_namespace_ref (&formal->sym->ns);
- else
- mio_namespace_ref (&c->formal_ns);
- }
- else
- {
- mio_namespace_ref (&c->formal_ns);
- /* TODO: if (c->formal_ns)
- {
- c->formal_ns->proc_name = c;
- c->refs++;
- }*/
- }
-
- mio_formal_arglist (&c->formal);
-
- mio_typebound_proc (&c->tb);
- }
+ mio_typebound_proc (&c->tb);
mio_rparen ();
}
sym->ts.interface = ifc;
sym->attr.function = ifc->attr.function;
sym->attr.subroutine = ifc->attr.subroutine;
- gfc_copy_formal_args (sym, ifc, IFSRC_DECL);
sym->attr.allocatable = ifc->attr.allocatable;
sym->attr.pointer = ifc->attr.pointer;
sym->attr.class_ok = ifc->attr.class_ok;
/* Copy array spec. */
sym->as = gfc_copy_array_spec (ifc->as);
- if (sym->as)
- {
- int i;
- for (i = 0; i < sym->as->rank; i++)
- {
- gfc_expr_replace_symbols (sym->as->lower[i], sym);
- gfc_expr_replace_symbols (sym->as->upper[i], sym);
- }
- }
/* Copy char length. */
if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
{
sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
- gfc_expr_replace_symbols (sym->ts.u.cl->length, sym);
if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved
&& gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
return FAILURE;
if (expr->value.function.isym && expr->value.function.isym->inquiry)
inquiry_argument = true;
- no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
+ no_formal_args = sym && is_external_proc (sym)
+ && gfc_sym_get_dummy_args (sym) == NULL;
if (resolve_actual_arglist (expr->value.function.actual,
p, no_formal_args) == FAILURE)
if (csym)
ptype = csym->attr.proc;
- no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
+ no_formal_args = csym && is_external_proc (csym)
+ && gfc_sym_get_dummy_args (csym) == NULL;
if (resolve_actual_arglist (c->ext.actual, ptype,
no_formal_args) == FAILURE)
return FAILURE;
g->specific->pass_arg);
}
resolve_actual_arglist (args, target->attr.proc,
- is_external_proc (target) && !target->formal);
+ is_external_proc (target)
+ && gfc_sym_get_dummy_args (target) == NULL);
/* Check if this arglist matches the formal. */
matches = gfc_arglist_matches_symbol (&args, target);
c->ext.actual = c->expr1->value.compcall.actual;
if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
- comp->formal == NULL) == FAILURE)
+ !(comp->ts.interface && comp->ts.interface->formal)) == FAILURE)
return FAILURE;
gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
return FAILURE;
if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
- comp->formal == NULL) == FAILURE)
+ !(comp->ts.interface && comp->ts.interface->formal)) == FAILURE)
return FAILURE;
if (update_ppc_arglist (e) == FAILURE)
if (this_code->op == EXEC_ASSIGN_CALL)
{
+ gfc_formal_arglist *dummy_args;
gfc_symbol *rsym;
/* Check that there is a typebound defined assignment. If not,
then this must be a module defined assignment. We cannot
/* If the first argument of the subroutine has intent INOUT
a temporary must be generated and used instead. */
rsym = this_code->resolved_sym;
- if (rsym->formal
- && rsym->formal->sym->attr.intent == INTENT_INOUT)
+ dummy_args = gfc_sym_get_dummy_args (rsym);
+ if (dummy_args
+ && dummy_args->sym->attr.intent == INTENT_INOUT)
{
gfc_code *temp_code;
inout = true;
{
gfc_interface *iface;
- for (arg = sym->formal; arg; arg = arg->next)
+ for (arg = gfc_sym_get_dummy_args (sym); arg; arg = arg->next)
{
if (arg->sym
&& arg->sym->ts.type == BT_DERIVED
PRIVATE to the containing module. */
for (iface = sym->generic; iface; iface = iface->next)
{
- for (arg = iface->sym->formal; arg; arg = arg->next)
+ for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next)
{
if (arg->sym
&& arg->sym->ts.type == BT_DERIVED
PRIVATE to the containing module. */
for (iface = sym->generic; iface; iface = iface->next)
{
- for (arg = iface->sym->formal; arg; arg = arg->next)
+ for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next)
{
if (arg->sym
&& arg->sym->ts.type == BT_DERIVED
sym->ts.is_c_interop = 1;
}
- curr_arg = sym->formal;
+ curr_arg = gfc_sym_get_dummy_args (sym);
while (curr_arg != NULL)
{
/* Skip implicitly typed dummy args here. */
prev_link = &derived->f2k_derived->finalizers;
for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
{
+ gfc_formal_arglist *dummy_args;
gfc_symbol* arg;
gfc_finalizer* i;
int my_rank;
}
/* We should have exactly one argument. */
- if (!list->proc_sym->formal || list->proc_sym->formal->next)
+ dummy_args = gfc_sym_get_dummy_args (list->proc_sym);
+ if (!dummy_args || dummy_args->next)
{
gfc_error ("FINAL procedure at %L must have exactly one argument",
&list->where);
goto error;
}
- arg = list->proc_sym->formal->sym;
+ arg = dummy_args->sym;
/* This argument must be of our type. */
if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)
my_rank = (arg->as ? arg->as->rank : 0);
for (i = list->next; i; i = i->next)
{
+ gfc_formal_arglist *dummy_args;
+
/* Argument list might be empty; that is an error signalled earlier,
but we nevertheless continued resolving. */
- if (i->proc_sym->formal)
+ dummy_args = gfc_sym_get_dummy_args (i->proc_sym);
+ if (dummy_args)
{
- gfc_symbol* i_arg = i->proc_sym->formal->sym;
+ gfc_symbol* i_arg = dummy_args->sym;
const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
if (i_rank == my_rank)
{
else if (t1->specific->pass_arg)
pass1 = t1->specific->pass_arg;
else
- pass1 = t1->specific->u.specific->n.sym->formal->sym->name;
+ pass1 = gfc_sym_get_dummy_args (t1->specific->u.specific->n.sym)->sym->name;
if (t2->specific->nopass)
pass2 = NULL;
else if (t2->specific->pass_arg)
pass2 = t2->specific->pass_arg;
else
- pass2 = t2->specific->u.specific->n.sym->formal->sym->name;
+ pass2 = gfc_sym_get_dummy_args (t2->specific->u.specific->n.sym)->sym->name;
if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0,
NULL, 0, pass1, pass2))
{
from a .mod file. */
if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
{
+ gfc_formal_arglist *dummy_args;
+
+ dummy_args = gfc_sym_get_dummy_args (proc);
if (stree->n.tb->pass_arg)
{
- gfc_formal_arglist* i;
+ gfc_formal_arglist *i;
/* If an explicit passing argument name is given, walk the arg-list
and look for it. */
me_arg = NULL;
stree->n.tb->pass_arg_num = 1;
- for (i = proc->formal; i; i = i->next)
+ for (i = dummy_args; i; i = i->next)
{
if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
{
/* Otherwise, take the first one; there should in fact be at least
one. */
stree->n.tb->pass_arg_num = 1;
- if (!proc->formal)
+ if (!dummy_args)
{
gfc_error ("Procedure '%s' with PASS at %L must have at"
" least one argument", proc->name, &where);
goto error;
}
- me_arg = proc->formal->sym;
+ me_arg = dummy_args->sym;
}
/* Now check that the argument-type matches and the passed-object
c->ts.interface = ifc;
c->attr.function = ifc->attr.function;
c->attr.subroutine = ifc->attr.subroutine;
- gfc_copy_formal_args_ppc (c, ifc, IFSRC_DECL);
c->attr.pure = ifc->attr.pure;
c->attr.elemental = ifc->attr.elemental;
c->attr.recursive = ifc->attr.recursive;
c->attr.always_explicit = ifc->attr.always_explicit;
c->attr.ext_attr |= ifc->attr.ext_attr;
- /* Replace symbols in array spec. */
- if (c->as)
- {
- int i;
- for (i = 0; i < c->as->rank; i++)
- {
- gfc_expr_replace_comp (c->as->lower[i], c);
- gfc_expr_replace_comp (c->as->upper[i], c);
- }
- }
/* Copy char length. */
if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
{
gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
- gfc_expr_replace_comp (cl->length, c);
if (cl->length && !cl->resolved
- && gfc_resolve_expr (cl->length) == FAILURE)
+ && gfc_resolve_expr (cl->length) == FAILURE)
return FAILURE;
c->ts.u.cl = cl;
}
me_arg = NULL;
c->tb->pass_arg_num = 1;
- for (i = c->formal; i; i = i->next)
+ for (i = c->ts.interface->formal; i; i = i->next)
{
if (!strcmp (i->sym->name, c->tb->pass_arg))
{
/* Otherwise, take the first one; there should in fact be at least
one. */
c->tb->pass_arg_num = 1;
- if (!c->formal)
+ if (!c->ts.interface->formal)
{
gfc_error ("Procedure pointer component '%s' with PASS at %L "
"must have at least one argument",
c->tb->error = 1;
return FAILURE;
}
- me_arg = c->formal->sym;
+ me_arg = c->ts.interface->formal->sym;
}
/* Now check that the argument-type matches. */
return FAILURE;
}
- formal = sym->formal;
+ formal = gfc_sym_get_dummy_args (sym);
if (!formal || !formal->sym)
{
gfc_error ("User operator procedure '%s' at %L must have at least "
gfc_free_array_spec (p->as);
gfc_free_expr (p->initializer);
- gfc_free_formal_arglist (p->formal);
- gfc_free_namespace (p->formal_ns);
-
free (p);
}
}
declaration statement (see match_proc_decl()) to create the formal
args based on the args of a given named interface. */
-void
-gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src, ifsrc if_src)
-{
- gfc_formal_arglist *head = NULL;
- gfc_formal_arglist *tail = NULL;
- gfc_formal_arglist *formal_arg = NULL;
- gfc_formal_arglist *curr_arg = NULL;
- gfc_formal_arglist *formal_prev = NULL;
- /* Save current namespace so we can change it for formal args. */
- gfc_namespace *parent_ns = gfc_current_ns;
-
- /* Create a new namespace, which will be the formal ns (namespace
- of the formal args). */
- gfc_current_ns = gfc_get_namespace (parent_ns, 0);
- gfc_current_ns->proc_name = dest;
- dest->formal_ns = gfc_current_ns;
-
- for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
- {
- formal_arg = gfc_get_formal_arglist ();
- gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
-
- /* May need to copy more info for the symbol. */
- formal_arg->sym->attr = curr_arg->sym->attr;
- formal_arg->sym->ts = curr_arg->sym->ts;
- formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
- gfc_copy_formal_args (formal_arg->sym, curr_arg->sym,
- curr_arg->sym->attr.if_source);
-
- /* If this isn't the first arg, set up the next ptr. For the
- last arg built, the formal_arg->next will never get set to
- anything other than NULL. */
- if (formal_prev != NULL)
- formal_prev->next = formal_arg;
- else
- formal_arg->next = NULL;
-
- formal_prev = formal_arg;
-
- /* Add arg to list of formal args. */
- add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
-
- /* Validate changes. */
- gfc_commit_symbol (formal_arg->sym);
- }
-
- /* Add the interface to the symbol. */
- add_proc_interface (dest, if_src, head);
-
- /* Store the formal namespace information. */
- if (dest->formal != NULL)
- /* The current ns should be that for the dest proc. */
- dest->formal_ns = gfc_current_ns;
- /* Restore the current namespace to what it was on entry. */
- gfc_current_ns = parent_ns;
-}
-
-
void
gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
{
}
-void
-gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src, ifsrc if_src)
-{
- gfc_formal_arglist *head = NULL;
- gfc_formal_arglist *tail = NULL;
- gfc_formal_arglist *formal_arg = NULL;
- gfc_formal_arglist *curr_arg = NULL;
- gfc_formal_arglist *formal_prev = NULL;
- /* Save current namespace so we can change it for formal args. */
- gfc_namespace *parent_ns = gfc_current_ns;
-
- /* Create a new namespace, which will be the formal ns (namespace
- of the formal args). */
- gfc_current_ns = gfc_get_namespace (parent_ns, 0);
- /* TODO: gfc_current_ns->proc_name = dest;*/
-
- for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
- {
- formal_arg = gfc_get_formal_arglist ();
- gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
-
- /* May need to copy more info for the symbol. */
- formal_arg->sym->attr = curr_arg->sym->attr;
- formal_arg->sym->ts = curr_arg->sym->ts;
- formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
- gfc_copy_formal_args (formal_arg->sym, curr_arg->sym,
- curr_arg->sym->attr.if_source);
-
- /* If this isn't the first arg, set up the next ptr. For the
- last arg built, the formal_arg->next will never get set to
- anything other than NULL. */
- if (formal_prev != NULL)
- formal_prev->next = formal_arg;
- else
- formal_arg->next = NULL;
-
- formal_prev = formal_arg;
-
- /* Add arg to list of formal args. */
- add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
-
- /* Validate changes. */
- gfc_commit_symbol (formal_arg->sym);
- }
-
- /* Add the interface to the symbol. */
- gfc_free_formal_arglist (dest->formal);
- dest->formal = head;
- dest->attr.if_source = if_src;
-
- /* Store the formal namespace information. */
- if (dest->formal != NULL)
- /* The current ns should be that for the dest proc. */
- dest->formal_ns = gfc_current_ns;
- /* Restore the current namespace to what it was on entry. */
- gfc_current_ns = parent_ns;
-}
-
-
/* Builds the parameter list for the iso_c_binding procedure
c_f_pointer or c_f_procpointer. The old_sym typically refers to a
generic version of either the c_f_pointer or c_f_procpointer
break;
return intr ? intr->sym : NULL;
}
+
+
+/* Get the dummy arguments from a procedure symbol. If it has been declared
+ via a PROCEDURE statement with a named interface, ts.interface will be set
+ and the arguments need to be taken from there. */
+
+gfc_formal_arglist *
+gfc_sym_get_dummy_args (gfc_symbol *sym)
+{
+ gfc_formal_arglist *dummies;
+
+ dummies = sym->formal;
+ if (dummies == NULL && sym->ts.interface != NULL)
+ dummies = sym->ts.interface->formal;
+
+ return dummies;
+}
/* Map expressions involving the dummy arguments onto the actual
argument expressions. */
gfc_init_interface_mapping (&mapping);
- formal = expr->symtree->n.sym->formal;
+ formal = gfc_sym_get_dummy_args (expr->symtree->n.sym);
arg = expr->value.function.actual;
/* Set se = NULL in the calls to the interface mapping, to suppress any
tail = NULL;
if (proc_ifc)
- dummy_arg = proc_ifc->formal;
+ dummy_arg = gfc_sym_get_dummy_args (proc_ifc);
else
dummy_arg = NULL;
{
/* Look for alternate return placeholders. */
int has_alternate_returns = 0;
- for (f = sym->formal; f; f = f->next)
+ for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
{
if (f->sym == NULL)
{
}
hidden_typelist = typelist;
- for (f = sym->formal; f; f = f->next)
+ for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
if (f->sym != NULL) /* Ignore alternate returns. */
hidden_typelist = TREE_CHAIN (hidden_typelist);
- for (f = sym->formal; f; f = f->next)
+ for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
{
char name[GFC_MAX_SYMBOL_LEN + 2];
}
}
- for (formal = ns->proc_name->formal; formal; formal = formal->next)
+ for (formal = gfc_sym_get_dummy_args (ns->proc_name); formal;
+ formal = formal->next)
{
/* Ignore alternate returns. */
if (formal->sym == NULL)
/* We don't have a clever way of identifying arguments, so resort to
a brute-force search. */
- for (thunk_formal = thunk_sym->formal;
+ for (thunk_formal = gfc_sym_get_dummy_args (thunk_sym);
thunk_formal;
thunk_formal = thunk_formal->next)
{
/* We share the symbols in the formal argument list with other entry
points and the master function. Clear them so that they are
recreated for each function. */
- for (formal = thunk_sym->formal; formal; formal = formal->next)
+ for (formal = gfc_sym_get_dummy_args (thunk_sym); formal;
+ formal = formal->next)
if (formal->sym != NULL) /* Ignore alternate returns. */
{
formal->sym->backend_decl = NULL_TREE;
tree present;
gfc_init_block (&init);
- for (f = proc_sym->formal; f; f = f->next)
+ for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
if (f->sym && f->sym->attr.intent == INTENT_OUT
&& !f->sym->attr.pointer
&& f->sym->ts.type == BT_DERIVED)
gfc_init_block (&tmpblock);
- for (f = proc_sym->formal; f; f = f->next)
+ for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
{
if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
{
{
gfc_formal_arglist *formal;
- for (formal = sym->formal; formal; formal = formal->next)
+ for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next)
if (formal->sym && formal->sym->ts.type == BT_CHARACTER
&& !formal->sym->ts.deferred)
{
gfc_actual_arglist *actual;
actual = expr->value.function.actual;
- f = map_expr->symtree->n.sym->formal;
+ f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
for (; f && actual; f = f->next, actual = actual->next)
{
gfc_init_interface_mapping (&mapping);
if (!comp)
{
- formal = sym->formal;
+ formal = gfc_sym_get_dummy_args (sym);
need_interface_mapping = sym->attr.dimension ||
(sym->ts.type == BT_CHARACTER
&& sym->ts.u.cl->length
}
else
{
- formal = comp->formal;
+ formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
need_interface_mapping = comp->attr.dimension ||
(comp->ts.type == BT_CHARACTER
&& comp->ts.u.cl->length
cl.backend_decl = (*stringargs)[0];
else
{
- formal = sym->ns->proc_name->formal;
+ formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
for (; formal; formal = formal->next)
if (strcmp (formal->sym->name, sym->name) == 0)
cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
gfc_init_se (&rse, NULL);
n = 0;
- for (fargs = sym->formal; fargs; fargs = fargs->next)
+ for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
n++;
saved_vars = XCNEWVEC (gfc_saved_var, n);
temp_vars = XCNEWVEC (tree, n);
- for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
+ for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
+ fargs = fargs->next, n++)
{
/* Each dummy shall be specified, explicitly or implicitly, to be
scalar. */
}
/* Use the temporary variables in place of the real ones. */
- for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
+ for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
+ fargs = fargs->next, n++)
gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
gfc_conv_expr (se, sym->value);
}
/* Restore the original variables. */
- for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
+ for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
+ fargs = fargs->next, n++)
gfc_restore_sym (fargs->sym, &saved_vars[n]);
free (temp_vars);
free (saved_vars);
ss = loopse->ss;
arg0 = arg;
- formal = sym->formal;
+ formal = gfc_sym_get_dummy_args (sym);
/* Loop over all the arguments testing for dependencies. */
for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
spec[spec_len++] = 'R';
}
- for (f = sym->formal; f; f = f->next)
+ for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
if (spec_len < sizeof (spec))
{
if (!f->sym || f->sym->attr.pointer || f->sym->attr.target
}
/* Build the argument types for the function. */
- for (f = sym->formal; f; f = f->next)
+ for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
{
arg = f->sym;
if (arg)
}
/* Add hidden string length parameters. */
- for (f = sym->formal; f; f = f->next)
+ for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
{
arg = f->sym;
if (arg && arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
+2013-01-29 Janus Weil <janus@gcc.gnu.org>
+ Mikael Morin <mikael@gcc.gnu.org>
+
+ PR fortran/54107
+ * gfortran.dg/proc_ptr_comp_36.f90: New.
+
2013-01-29 Richard Biener <rguenther@suse.de>
PR tree-optimization/55270
--- /dev/null
+! { dg-do compile }
+!
+! PR 54107: [4.8 Regression] Memory hog with abstract interface
+!
+! Contributed by Arjen Markus <arjen.markus895@gmail.com>
+
+ implicit none
+ type computation_method
+ character(len=40) :: name
+ procedure(compute_routine), pointer, nopass :: compute
+ end type
+ abstract interface
+ subroutine compute_routine( param_value, zfunc, probability )
+ real, dimension(:), intent(in) :: param_value
+ procedure(compute_routine) :: zfunc
+ real, intent(in) :: probability
+ end subroutine
+ end interface
+end
projects / gcc.git / commitdiff