mirror of git://gcc.gnu.org/git/gcc.git
re PR fortran/24558 (ENTRY doesn't work in module procedures)
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-10 Paul Thomas <pault@gcc.gnu.org> PR fortran/24558 * gfortran.dg/entry_6.f90: New test. PR fortran/20877 PR fortran/25047 * gfortran.dg/entry_7.f90: New test. From-SVN: r114526
This commit is contained in:
Paul Thomas
parent
d0d1b24d89
commit
1a492601a1
|
|
@ -1,3 +1,22 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -596,13 +596,20 @@ end:
|
|||
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);
|
||||
|
|
@ -628,7 +635,8 @@ get_proc_name (const char *name, gfc_symbol ** 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);
|
||||
|
|
@ -637,18 +645,23 @@ get_proc_name (const char *name, gfc_symbol ** result)
|
|||
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;
|
||||
|
|
@ -2564,7 +2577,7 @@ gfc_match_function_decl (void)
|
|||
return MATCH_NO;
|
||||
}
|
||||
|
||||
if (get_proc_name (name, &sym))
|
||||
if (get_proc_name (name, &sym, false))
|
||||
return MATCH_ERROR;
|
||||
gfc_new_block = sym;
|
||||
|
||||
|
|
@ -2667,6 +2680,7 @@ gfc_match_entry (void)
|
|||
match m;
|
||||
gfc_entry_list *el;
|
||||
locus old_loc;
|
||||
bool module_procedure;
|
||||
|
||||
m = gfc_match_name (name);
|
||||
if (m != MATCH_YES)
|
||||
|
|
@ -2727,16 +2741,26 @@ gfc_match_entry (void)
|
|||
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 ();
|
||||
|
|
@ -2865,7 +2889,7 @@ gfc_match_subroutine (void)
|
|||
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;
|
||||
|
||||
|
|
|
|||
|
|
@ -385,6 +385,16 @@ resolve_entries (gfc_namespace * ns)
|
|||
ns->entries = el;
|
||||
ns->proc_name->attr.entry = 1;
|
||||
|
||||
/* If it is a module function, it needs to be in the right namespace
|
||||
so that gfc_get_fake_result_decl can gather up the results. The
|
||||
need for this arose in get_proc_name, where these beasts were
|
||||
left in their own namespace, to keep prior references linked to
|
||||
the entry declaration.*/
|
||||
if (ns->proc_name->attr.function
|
||||
&& ns->parent
|
||||
&& ns->parent->proc_name->attr.flavor == FL_MODULE)
|
||||
el->sym->ns = ns;
|
||||
|
||||
/* Add an entry statement for it. */
|
||||
c = gfc_get_code ();
|
||||
c->op = EXEC_ENTRY;
|
||||
|
|
|
|||
|
|
@ -2653,6 +2653,11 @@ gfc_create_module_variable (gfc_symbol * sym)
|
|||
{
|
||||
tree decl;
|
||||
|
||||
/* Module functions with alternate entries are dealt with later and
|
||||
would get caught by the next condition. */
|
||||
if (sym->attr.entry)
|
||||
return;
|
||||
|
||||
/* Only output symbols from this module. */
|
||||
if (sym->ns != module_namespace)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -361,6 +361,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
|
|||
|
||||
if ((se->expr == parent_decl && return_value)
|
||||
|| (sym->ns && sym->ns->proc_name
|
||||
&& parent_decl
|
||||
&& sym->ns->proc_name->backend_decl == parent_decl
|
||||
&& (alternate_entry || entry_master)))
|
||||
parent_flag = 1;
|
||||
|
|
|
|||
|
|
@ -1,3 +1,12 @@
|
|||
2006-06-10 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/24558
|
||||
* gfortran.dg/entry_6.f90: New test.
|
||||
|
||||
PR fortran/20877
|
||||
PR fortran/25047
|
||||
* gfortran.dg/entry_7.f90: New test.
|
||||
|
||||
2006-06-09 Jakub Jelinek <jakub@redhat.com>
|
||||
|
||||
PR c/27747
|
||||
|
|
|
|||
|
|
@ -0,0 +1,56 @@
|
|||
! { 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" } }
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
! { dg-do compile }
|
||||
! Check that PR20877 and PR25047 are fixed by the patch for
|
||||
! PR24558. Both modules would emit the error:
|
||||
! insert_bbt(): Duplicate key found!
|
||||
! because of the prior references to a module function entry.
|
||||
!
|
||||
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
|
||||
!
|
||||
MODULE TT
|
||||
CONTAINS
|
||||
FUNCTION K(I) RESULT(J)
|
||||
ENTRY J() ! { dg-error "conflicts with PROCEDURE attribute" }
|
||||
END FUNCTION K
|
||||
|
||||
integer function foo ()
|
||||
character*4 bar ! { dg-error "type CHARACTER" }
|
||||
foo = 21
|
||||
return
|
||||
entry bar ()
|
||||
bar = "abcd"
|
||||
end function
|
||||
END MODULE TT
|
||||
|
||||
|
||||
! { dg-final { cleanup-modules "TT" } }
|
||||
Loading…
Reference in New Issue