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

re PR fortran/31214 (User-defined operator using entry leads to ICE) 

2007-08-04  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/31214
	* symbol.c (get_unique_symtree): Moved from module.c.
	* module.c (get_unique_symtree): Moved to symbol.c.
	* decl.c (get_proc_name): Transfer the typespec from the local
	symbol to the module symbol, in the case that an entry is also
	a module procedure.  Ensure the local symbol is cleaned up by
	pointing to it with a unique symtree.

	* dump_parse_tree (gfc_show_code_node): Add EXEC_ASSIGN_CALL.

2007-08-04  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/31214
	* gfortran.dg/entry_13.f90: New test.

	* gfortran.dg/entry_12.f90: Clean up .mod file.

From-SVN: r127213
This commit is contained in:
Paul Thomas 2007-08-04 20:46:11 +00:00
parent 6b44ad312f
commit aa84a9a5e4
9 changed files with 161 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
gcc/fortran/ChangeLog
View File

@ -1,3 +1,10 @@
2007-08-04 Paul Thomas <pault@gcc.gnu.org>
PR fortran/31214
* gfortran.dg/entry_13.f90: New test.
* gfortran.dg/entry_12.f90: Clean up .mod file.
2008-08-04 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/32969

19
gcc/fortran/decl.c
View File

@ -681,8 +681,27 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
{
/* Present if entry is declared to be a module procedure. */
rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
if (*result == NULL)
rc = gfc_get_symbol (name, NULL, result);
else if (gfc_get_symbol (name, NULL, &sym) == 0
&& sym
&& sym->ts.type != BT_UNKNOWN
&& (*result)->ts.type == BT_UNKNOWN
&& sym->attr.flavor == FL_UNKNOWN)
/* Pick up the typespec for the entry, if declared in the function
body. Note that this symbol is FL_UNKNOWN because it will
only have appeared in a type declaration. The local symtree
is set to point to the module symbol and a unique symtree
to the local version. This latter ensures a correct clearing
of the symbols. */
{
(*result)->ts = sym->ts;
gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
st->n.sym = *result;
st = gfc_get_unique_symtree (gfc_current_ns);
st->n.sym = sym;
}
}
else
rc = gfc_get_symbol (name, gfc_current_ns->parent, result);

1
gcc/fortran/dump-parse-tree.c
View File

@ -1084,6 +1084,7 @@ gfc_show_code_node (int level, gfc_code *c)
break;
case EXEC_CALL:
case EXEC_ASSIGN_CALL:
if (c->resolved_sym)
gfc_status ("CALL %s ", c->resolved_sym->name);
else if (c->symtree)

1
gcc/fortran/gfortran.h
View File

@ -2124,6 +2124,7 @@ gfc_expr * gfc_lval_expr_from_sym (gfc_symbol *);
gfc_namespace *gfc_get_namespace (gfc_namespace *, int);
gfc_symtree *gfc_new_symtree (gfc_symtree **, const char *);
gfc_symtree *gfc_find_symtree (gfc_symtree *, const char *);
gfc_symtree *gfc_get_unique_symtree (gfc_namespace *);
gfc_user_op *gfc_get_uop (const char *);
gfc_user_op *gfc_find_uop (const char *, gfc_namespace *);
void gfc_free_symbol (gfc_symbol *);

20
gcc/fortran/module.c
View File

@ -1822,20 +1822,6 @@ mio_charlen (gfc_charlen **clp)
}
/* Return a symtree node with a name that is guaranteed to be unique
within the namespace and corresponds to an illegal fortran name. */
static gfc_symtree *
get_unique_symtree (gfc_namespace *ns)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
static int serial = 0;
sprintf (name, "@%d", serial++);
return gfc_new_symtree (&ns->sym_root, name);
}
/* See if a name is a generated name. */
static int
@ -2287,7 +2273,7 @@ mio_symtree_ref (gfc_symtree **stp)
if (in_load_equiv && p->u.rsym.symtree == NULL)
{
/* Since this is not used, it must have a unique name. */
p->u.rsym.symtree = get_unique_symtree (gfc_current_ns);
p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns);
/* Make the symbol. */
if (p->u.rsym.sym == NULL)
@ -3418,7 +3404,7 @@ read_cleanup (pointer_info *p)
{
/* Add hidden symbols to the symtree. */
q = get_integer (p->u.rsym.ns);
st = get_unique_symtree ((gfc_namespace *) q->u.pointer);
st = gfc_get_unique_symtree ((gfc_namespace *) q->u.pointer);
st->n.sym = p->u.rsym.sym;
st->n.sym->refs++;
@ -3598,7 +3584,7 @@ read_module (void)
/* Create a symtree node in the current namespace for this
symbol. */
st = check_unique_name (p)
? get_unique_symtree (gfc_current_ns)
? gfc_get_unique_symtree (gfc_current_ns)
: gfc_new_symtree (&gfc_current_ns->sym_root, p);
st->ambiguous = ambiguous;

14
gcc/fortran/symbol.c
View File

@ -2129,6 +2129,20 @@ gfc_find_symtree (gfc_symtree *st, const char *name)
}
/* Return a symtree node with a name that is guaranteed to be unique
within the namespace and corresponds to an illegal fortran name. */
gfc_symtree *
gfc_get_unique_symtree (gfc_namespace *ns)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
static int serial = 0;
sprintf (name, "@%d", serial++);
return gfc_new_symtree (&ns->sym_root, name);
}
/* Given a name find a user operator node, creating it if it doesn't
exist. These are much simpler than symbols because they can't be
ambiguous with one another. */

11
gcc/testsuite/ChangeLog
View File

@ -1,10 +1,9 @@
2007-08-04 Thomas Koenig <tkoenig@gcc.gnu.org>
2007-08-04 Paul Thomas <pault@gcc.gnu.org>
PR fortran/32770
* gfortran.dg/streamio_8.f90: Adjust so test case passes
for -fdefault-integer-8 and -fdefault-real-8.
* gfortran.dg/streamio_10.f90: Likewise.
* gfortran.dg/sizeof.f90: Likewise.
PR fortran/31214
* gfortran.dg/entry_13.f90: New test.
* gfortran.dg/entry_12.f90: Clean up .mod file.
2007-08-04 Thomas Koenig <tkoenig@gcc.gnu.org>

61
gcc/testsuite/gfortran.dg/entry_12.f90
View File

@ -1,30 +1,31 @@
! { dg-do run }
! Tests the fix for pr31609, where module procedure entries found
! themselves in the wrong namespace. This test checks that all
! combinations of generic and specific calls work correctly.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org> as comment #8 to the pr.
!
MODULE ksbin1_aux_mod
interface foo
module procedure j
end interface
interface bar
module procedure k
end interface
interface foobar
module procedure j, k
end interface
CONTAINS
FUNCTION j ()
j = 1
return
ENTRY k (i)
k = 2
END FUNCTION j
END MODULE ksbin1_aux_mod
use ksbin1_aux_mod
if (any ((/foo (), bar (99), foobar (), foobar (99), j (), k (99)/) .ne. &
(/1, 2, 1, 2, 1, 2/))) Call abort ()
end
! { dg-do run }
! Tests the fix for pr31609, where module procedure entries found
! themselves in the wrong namespace. This test checks that all
! combinations of generic and specific calls work correctly.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org> as comment #8 to the pr.
!
MODULE ksbin1_aux_mod
interface foo
module procedure j
end interface
interface bar
module procedure k
end interface
interface foobar
module procedure j, k
end interface
CONTAINS
FUNCTION j ()
j = 1
return
ENTRY k (i)
k = 2
END FUNCTION j
END MODULE ksbin1_aux_mod
use ksbin1_aux_mod
if (any ((/foo (), bar (99), foobar (), foobar (99), j (), k (99)/) .ne. &
(/1, 2, 1, 2, 1, 2/))) Call abort ()
end
! { dg-final { cleanup-modules "ksbin1_aux_mod" } }

80
gcc/testsuite/gfortran.dg/entry_13.f90 Normal file
View File

@ -0,0 +1,80 @@
! { dg-do run }
! Tests the fix for pr31214, in which the typespec for the entry would be lost,
! thereby causing the function to be disallowed, since the function and entry
! types did not match.
!
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
!
module type_mod
implicit none
type x
real x
end type x
type y
real x
end type y
type z
real x
end type z
interface assignment(=)
module procedure equals
end interface assignment(=)
interface operator(//)
module procedure a_op_b, b_op_a
end interface operator(//)
interface operator(==)
module procedure a_po_b, b_po_a
end interface operator(==)
contains
subroutine equals(x,y)
type(z), intent(in) :: y
type(z), intent(out) :: x
x%x = y%x
end subroutine equals
function a_op_b(a,b)
type(x), intent(in) :: a
type(y), intent(in) :: b
type(z) a_op_b
type(z) b_op_a
a_op_b%x = a%x + b%x
return
entry b_op_a(b,a)
b_op_a%x = a%x - b%x
end function a_op_b
function a_po_b(a,b)
type(x), intent(in) :: a
type(y), intent(in) :: b
type(z) a_po_b
type(z) b_po_a
entry b_po_a(b,a)
a_po_b%x = a%x/b%x
end function a_po_b
end module type_mod
program test
use type_mod
implicit none
type(x) :: x1 = x(19.0_4)
type(y) :: y1 = y(7.0_4)
type(z) z1
z1 = x1//y1
if (z1%x .ne. 19.0_4 + 7.0_4) call abort ()
z1 = y1//x1
if (z1%x .ne. 19.0_4 - 7.0_4) call abort ()
z1 = x1==y1
if (z1%x .ne. 19.0_4/7.0_4) call abort ()
z1 = y1==x1
if (z1%x .ne. 19.0_4/7.0_4) call abort ()
end program test
! { dg-final { cleanup-modules "type_mod" } }