------- Comment #5 from pault at gcc dot gnu dot org 2010-02-08 18:19 -------
Please excuse the lack of a diff - I was using a snap shot to work on this PR.
This fixes the problem but I do not know if it regtests; however, I believe it
to be good. If somebody wants to take it to completion, please be my guest.
Otherwise, I'll do the job at the weekend.
Paul
static void
fix_mio_expr (gfc_expr *e)
{
gfc_symtree *ns_st = NULL;
gfc_symbol *sym;
const char *fname;
if (iomode != IO_OUTPUT)
return;
if (e->symtree)
{
/* If this is a symtree for a symbol that came from a contained module
namespace, it has a unique name and we should look in the current
namespace to see if the required, non-contained symbol is available
yet. If so, the latter should be written. */
if (e->symtree->n.sym && check_unique_name (e->symtree->name))
ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
e->symtree->n.sym->name);
/* On the other hand, if the existing symbol is the module name or the
new symbol is a dummy argument, do not do the promotion. */
if (ns_st && ns_st->n.sym
&& ns_st->n.sym->attr.flavor != FL_MODULE
&& !e->symtree->n.sym->attr.dummy)
e->symtree = ns_st;
}
else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
{
/* In some circumstances, a function used in an initialization
expression, in one use associated module, can fail to be
coupled to its symtree when used in a specification
expression in another module. */
fname = e->value.function.esym ? e->value.function.esym->name
: e->value.function.isym->name;
e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
if (e->symtree)
return;
/* This is probably a reference to a private procedure from another
module. To prevent a segfault, make a generic with no specific
instances. If this module is used, without the required
specific coming from somewhere, the appropriate error message
is issued. */
gfc_get_symbol (fname, gfc_current_ns, &sym);
sym->attr.flavor = FL_PROCEDURE;
sym->attr.generic = 1;
e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
}
}
--
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=41869
