OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/54107 ([F03] Memory hog with abstract interface)

Browse Source 
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-29  Janus Weil  <janus@gcc.gnu.org>
	    Mikael Morin <mikael@gcc.gnu.org>

	PR fortran/54107
	* gfortran.dg/proc_ptr_comp_36.f90: New.

Co-Authored-By: Mikael Morin <mikael@gcc.gnu.org>

From-SVN: r195562
This commit is contained in:
Janus Weil 2013-01-29 22:40:51 +01:00
parent d6f2922e91
commit 4cbc903996
16 changed files with 187 additions and 316 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
gcc/fortran/ChangeLog
View File

@ -1,3 +1,43 @@
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>

2
gcc/fortran/dependency.c
View File

@ -822,7 +822,7 @@ gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent,
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;

68
gcc/fortran/expr.c
View File

@ -934,7 +934,7 @@ gfc_is_constant_expr (gfc_expr *e)
&& 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
@ -4301,72 +4301,6 @@ gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
}
/* 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)
{

4
gcc/fortran/frontend-passes.c
View File

@ -1447,7 +1447,7 @@ doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
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. */
@ -1516,7 +1516,7 @@ do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
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. */

7
gcc/fortran/gfortran.h
View File

@ -974,8 +974,6 @@ typedef struct gfc_component
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;
@ -2659,9 +2657,7 @@ gfc_symbol* gfc_get_ultimate_derived_super_type (gfc_symbol*);
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 */
@ -2670,6 +2666,7 @@ gfc_namespace* gfc_find_proc_namespace (gfc_namespace*);
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;
@ -2784,8 +2781,6 @@ bool gfc_traverse_expr (gfc_expr *, gfc_symbol *,
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 *);

51
gcc/fortran/interface.c
View File

@ -616,7 +616,7 @@ gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
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)
@ -662,6 +662,8 @@ gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
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 "
@ -674,12 +676,13 @@ gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
- 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);
@ -1377,8 +1380,8 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
|| 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. */
@ -3107,6 +3110,8 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
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
@ -3202,14 +3207,16 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
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;
}
@ -3222,7 +3229,6 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
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. */
@ -3250,12 +3256,13 @@ gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
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);
}
@ -3266,16 +3273,19 @@ gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
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;
}
@ -4080,8 +4090,9 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
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

30
gcc/fortran/module.c
View File

@ -80,7 +80,7 @@ along with GCC; see the file COPYING3. If not see
/* 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. */
@ -2573,7 +2573,6 @@ mio_component (gfc_component *c, int vtype)
{
pointer_info *p;
int n;
gfc_formal_arglist *formal;
mio_lparen ();
@ -2606,32 +2605,7 @@ mio_component (gfc_component *c, int vtype)
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 ();
}

88
gcc/fortran/resolve.c
View File

@ -223,7 +223,6 @@ resolve_procedure_interface (gfc_symbol *sym)
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;
@ -238,20 +237,10 @@ resolve_procedure_interface (gfc_symbol *sym)
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;
@ -3141,7 +3130,8 @@ resolve_function (gfc_expr *expr)
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)
@ -3826,7 +3816,8 @@ resolve_call (gfc_code *c)
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;
@ -6018,7 +6009,8 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name)
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);
@ -6438,7 +6430,7 @@ resolve_ppc_call (gfc_code* c)
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);
@ -6472,7 +6464,7 @@ resolve_expr_ppc (gfc_expr* e)
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)
@ -9963,6 +9955,7 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
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
@ -9981,8 +9974,9 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
/* 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;
@ -11414,7 +11408,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
{
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
@ -11436,7 +11430,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
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
@ -11460,7 +11454,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
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
@ -11580,7 +11574,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
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. */
@ -11667,6 +11661,7 @@ gfc_resolve_finalizers (gfc_symbol* derived)
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;
@ -11687,13 +11682,14 @@ gfc_resolve_finalizers (gfc_symbol* derived)
}
/* 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)
@ -11745,11 +11741,14 @@ gfc_resolve_finalizers (gfc_symbol* 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)
{
@ -11835,13 +11834,13 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
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))
{
@ -12205,16 +12204,19 @@ resolve_typebound_procedure (gfc_symtree* stree)
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))
{
@ -12238,13 +12240,13 @@ resolve_typebound_procedure (gfc_symtree* stree)
/* 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
@ -12623,30 +12625,18 @@ resolve_fl_derived0 (gfc_symbol *sym)
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;
}
@ -12674,7 +12664,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
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))
{
@ -12698,7 +12688,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
/* 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",
@ -12706,7 +12696,7 @@ resolve_fl_derived0 (gfc_symbol *sym)
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. */
@ -14793,7 +14783,7 @@ check_uop_procedure (gfc_symbol *sym, locus where)
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 "

137
gcc/fortran/symbol.c
View File

@ -2077,9 +2077,6 @@ free_components (gfc_component *p)
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);
}
}
@ -4128,64 +4125,6 @@ add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal)
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)
{
@ -4247,65 +4186,6 @@ 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
@ -4983,3 +4863,20 @@ gfc_find_dt_in_generic (gfc_symbol *sym)
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;
}

4
gcc/fortran/trans-array.c
View File

@ -6282,7 +6282,7 @@ get_array_charlen (gfc_expr *expr, gfc_se *se)
/* 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
@ -8626,7 +8626,7 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
tail = NULL;
if (proc_ifc)
dummy_arg = proc_ifc->formal;
dummy_arg = gfc_sym_get_dummy_args (proc_ifc);
else
dummy_arg = NULL;

20
gcc/fortran/trans-decl.c
View File

@ -1906,7 +1906,7 @@ build_function_decl (gfc_symbol * sym, bool global)
{
/* 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)
{
@ -2074,11 +2074,11 @@ create_function_arglist (gfc_symbol * sym)
}
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];
@ -2344,7 +2344,8 @@ build_entry_thunks (gfc_namespace * ns, bool global)
}
}
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)
@ -2352,7 +2353,7 @@ build_entry_thunks (gfc_namespace * ns, bool global)
/* 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)
{
@ -2459,7 +2460,8 @@ build_entry_thunks (gfc_namespace * ns, bool global)
/* 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;
@ -3458,7 +3460,7 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
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)
@ -3911,7 +3913,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
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)
{
@ -4804,7 +4806,7 @@ add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
{
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)
{

19
gcc/fortran/trans-expr.c
View File

@ -3266,7 +3266,7 @@ gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
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)
{
@ -3996,7 +3996,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
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
@ -4005,7 +4005,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
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
@ -4858,7 +4858,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
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;
@ -5440,12 +5440,13 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
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. */
@ -5499,7 +5500,8 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
}
/* 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);
@ -5525,7 +5527,8 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
}
/* 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);

2
gcc/fortran/trans-stmt.c
View File

@ -236,7 +236,7 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
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)

6
gcc/fortran/trans-types.c
View File

@ -2679,7 +2679,7 @@ create_fn_spec (gfc_symbol *sym, tree fntype)
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
@ -2763,7 +2763,7 @@ gfc_get_function_type (gfc_symbol * sym)
}
/* 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)
@ -2806,7 +2806,7 @@ gfc_get_function_type (gfc_symbol * sym)
}
/* 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)

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
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

19
gcc/testsuite/gfortran.dg/proc_ptr_comp_36.f90 Normal file
View File

@ -0,0 +1,19 @@
! { 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