+2006-06-10 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/24558
+ PR fortran/20877
+ PR fortran/25047
+ * decl.c (get_proc_name): Add new argument to flag that a
+ module function entry is being treated. If true, correct
+ error condition, add symtree to module namespace and add
+ a module procedure.
+ (gfc_match_function_decl, gfc_match_entry,
+ gfc_match_subroutine): Use the new argument in calls to
+ get_proc_name.
+ * resolve.c (resolve_entries): ENTRY symbol reference to
+ to master entry namespace if a module function.
+ * trans-decl.c (gfc_create_module_variable): Return if
+ the symbol is an entry.
+ * trans-exp.c (gfc_conv_variable): Check that parent_decl
+ is not NULL.
+
2006-06-09 Jakub Jelinek <jakub@redhat.com>
PR fortran/27916
parent, then the symbol is just created in the current unit. */
static int
-get_proc_name (const char *name, gfc_symbol ** result)
+get_proc_name (const char *name, gfc_symbol ** result,
+ bool module_fcn_entry)
{
gfc_symtree *st;
gfc_symbol *sym;
int rc;
- if (gfc_current_ns->parent == NULL)
+ /* Module functions have to be left in their own namespace because
+ they have potentially (almost certainly!) already been referenced.
+ In this sense, they are rather like external functions. This is
+ fixed up in resolve.c(resolve_entries), where the symbol name-
+ space is set to point to the master function, so that the fake
+ result mechanism can work. */
+ if (module_fcn_entry)
rc = gfc_get_symbol (name, NULL, result);
else
rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
if (sym->ts.kind != 0
&& sym->attr.proc == 0
&& gfc_current_ns->parent != NULL
- && sym->attr.access == 0)
+ && sym->attr.access == 0
+ && !module_fcn_entry)
gfc_error_now ("Procedure '%s' at %C has an explicit interface"
" and must not have attributes declared at %L",
name, &sym->declared_at);
if (gfc_current_ns->parent == NULL || *result == NULL)
return rc;
- st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
+ /* Module function entries will already have a symtree in
+ the current namespace but will need one at module level. */
+ if (module_fcn_entry)
+ st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
+ else
+ st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
st->n.sym = sym;
sym->refs++;
/* See if the procedure should be a module procedure */
- if (sym->ns->proc_name != NULL
- && sym->ns->proc_name->attr.flavor == FL_MODULE
- && sym->attr.proc != PROC_MODULE
- && gfc_add_procedure (&sym->attr, PROC_MODULE,
- sym->name, NULL) == FAILURE)
+ if (((sym->ns->proc_name != NULL
+ && sym->ns->proc_name->attr.flavor == FL_MODULE
+ && sym->attr.proc != PROC_MODULE) || module_fcn_entry)
+ && gfc_add_procedure (&sym->attr, PROC_MODULE,
+ sym->name, NULL) == FAILURE)
rc = 2;
return rc;
return MATCH_NO;
}
- if (get_proc_name (name, &sym))
+ if (get_proc_name (name, &sym, false))
return MATCH_ERROR;
gfc_new_block = sym;
match m;
gfc_entry_list *el;
locus old_loc;
+ bool module_procedure;
m = gfc_match_name (name);
if (m != MATCH_YES)
return MATCH_ERROR;
}
+ module_procedure = gfc_current_ns->parent != NULL
+ && gfc_current_ns->parent->proc_name
+ && gfc_current_ns->parent->proc_name->attr.flavor == FL_MODULE;
+
if (gfc_current_ns->parent != NULL
&& gfc_current_ns->parent->proc_name
- && gfc_current_ns->parent->proc_name->attr.flavor != FL_MODULE)
+ && !module_procedure)
{
gfc_error("ENTRY statement at %C cannot appear in a "
"contained procedure");
return MATCH_ERROR;
}
- if (get_proc_name (name, &entry))
+ /* Module function entries need special care in get_proc_name
+ because previous references within the function will have
+ created symbols attached to the current namespace. */
+ if (get_proc_name (name, &entry,
+ gfc_current_ns->parent != NULL
+ && module_procedure
+ && gfc_current_ns->proc_name->attr.function))
return MATCH_ERROR;
proc = gfc_current_block ();
if (m != MATCH_YES)
return m;
- if (get_proc_name (name, &sym))
+ if (get_proc_name (name, &sym, false))
return MATCH_ERROR;
gfc_new_block = sym;
--- /dev/null
+! { dg-do run }
+! Tests the fix for PR24558, which reported that module
+! alternate function entries did not work.
+!
+! Contributed by Erik Edelmann <eedelman@gcc.gnu.org>
+!
+module foo
+contains
+ function n1 (a)
+ integer :: n1, n2, a, b
+ integer, save :: c
+ c = a
+ n1 = c**3
+ return
+ entry n2 (b)
+ n2 = c * b
+ n2 = n2**2
+ return
+ end function n1
+ function z1 (u)
+ complex :: z1, z2, u, v
+ z1 = (1.0, 2.0) * u
+ return
+ entry z2 (v)
+ z2 = (3, 4) * v
+ return
+ end function z1
+ function n3 (d)
+ integer :: n3, d
+ n3 = n2(d) * n1(d) ! Check sibling references.
+ return
+ end function n3
+ function c1 (a)
+ character(4) :: c1, c2, a, b
+ c1 = a
+ if (a .eq. "abcd") c1 = "ABCD"
+ return
+ entry c2 (b)
+ c2 = b
+ if (b .eq. "wxyz") c2 = "WXYZ"
+ return
+ end function c1
+end module foo
+ use foo
+ if (n1(9) .ne. 729) call abort ()
+ if (n2(2) .ne. 324) call abort ()
+ if (n3(19) .ne. 200564019) call abort ()
+ if (c1("lmno") .ne. "lmno") call abort ()
+ if (c1("abcd") .ne. "ABCD") call abort ()
+ if (c2("lmno") .ne. "lmno") call abort ()
+ if (c2("wxyz") .ne. "WXYZ") call abort ()
+ if (z1((3,4)) .ne. (-5, 10)) call abort ()
+ if (z2((5,6)) .ne. (-9, 38)) call abort ()
+ end
+
+! { dg-final { cleanup-modules "foo" } }