Commit d218d0e6 by Paul Thomas

re PR fortran/28788 (ICE on valid code)

2006-08-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/28788
	REGRESSION FIX
	* symbol.c (gfc_use_derived): Never eliminate the symbol,
	following reassociation of use associated derived types.

2006-08-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/28788
	* gfortran.dg/used_types_5.f90: New test.
	* gfortran.dg/used_types_6.f90: New test.

From-SVN: r116552
parent bb6e5621
2006-08-29 Paul Thomas <pault@gcc.gnu.org>
PR fortran/28788
REGRESSION FIX
* symbol.c (gfc_use_derived): Never eliminate the symbol,
following reassociation of use associated derived types.
2006-08-26 Steven G. Kargl <kargls@comcast.net>
* arith.h: Update Copyright dates. Fix whitespace.
......
......@@ -1495,16 +1495,10 @@ gfc_use_derived (gfc_symbol * sym)
if (s == NULL || s->attr.flavor != FL_DERIVED)
{
/* Check to see if type has been renamed in parent namespace.
Leave cleanup of local symbols until the end of the
compilation because doing it here is complicated by
multiple association with the same type. */
/* Check to see if type has been renamed in parent namespace. */
s = find_renamed_type (sym, sym->ns->parent->sym_root);
if (s != NULL)
{
switch_types (sym->ns->sym_root, sym, s);
return s;
}
goto return_use_assoc;
/* See if sym is identical to renamed, use-associated derived
types in sibling namespaces. */
......@@ -1521,10 +1515,7 @@ gfc_use_derived (gfc_symbol * sym)
s = find_renamed_type (sym, ns->sym_root);
if (s != NULL)
{
switch_types (sym->ns->sym_root, sym, s);
return s;
}
goto return_use_assoc;
}
}
......@@ -1557,6 +1548,9 @@ gfc_use_derived (gfc_symbol * sym)
t->derived = s;
}
if (sym->attr.use_assoc)
goto return_use_assoc;
st = gfc_find_symtree (sym->ns->sym_root, sym->name);
st->n.sym = s;
......@@ -1573,6 +1567,14 @@ gfc_use_derived (gfc_symbol * sym)
return s;
return_use_assoc:
/* Use associated types are not freed at this stage because some
references remain to 'sym'. We retain the symbol and leave it
to be cleaned up by gfc_free_namespace, at the end of the
compilation. */
switch_types (sym->ns->sym_root, sym, s);
return s;
bad:
gfc_error ("Derived type '%s' at %C is being used before it is defined",
sym->name);
......
! { dg-do compile }
! Tests the fix for a further regression caused by the
! fix for PR28788, as noted in reply #9 in the Bugzilla
! entry by Martin Reinecke <martin@mpa-garching.mpg.de>.
! The problem was caused by certain types of references
! that point to a deleted derived type symbol, after the
! type has been associated to another namespace. An
! example of this is the specification expression for x
! in subroutine foo below. At the same time, this tests
! the correct association of typeaa between a module
! procedure and a new definition of the type in MAIN.
!
module types
type :: typea
sequence
integer :: i
end type typea
type :: typeaa
sequence
integer :: i
end type typeaa
type(typea) :: it = typea(2)
end module types
!------------------------------
module global
use types, only: typea, it
contains
subroutine foo (x)
use types
type(typeaa) :: ca
real :: x(it%i)
common /c/ ca
x = 42.0
ca%i = 99
end subroutine foo
end module global
!------------------------------
use global, only: typea, foo
type :: typeaa
sequence
integer :: i
end type typeaa
type(typeaa) :: cam
real :: x(4)
common /c/ cam
x = -42.0
call foo(x)
if (any (x .ne. (/42.0, 42.0, -42.0, -42.0/))) call abort ()
if (cam%i .ne. 99) call abort ()
end
! { dg-final { cleanup-modules "types global" } }
! { dg-do compile }
! Tests the fix for a further regression caused by the
! fix for PR28788, as noted in reply #13 in the Bugzilla
! entry by Martin Tee <aovb94@dsl.pipex.com>.
! The problem was caused by contained, use associated
! derived types with pointer components of a derived type
! use associated in a sibling procedure, where both are
! associated by an ONLY clause. This is the reporter's
! test case.
!
MODULE type_mod
TYPE a
INTEGER :: n(10)
END TYPE a
TYPE b
TYPE (a), POINTER :: m(:) => NULL ()
END TYPE b
END MODULE type_mod
MODULE seg_mod
CONTAINS
SUBROUTINE foo (x)
USE type_mod, ONLY : a ! failed
IMPLICIT NONE
TYPE (a) :: x
RETURN
END SUBROUTINE foo
SUBROUTINE bar (x)
USE type_mod, ONLY : b ! failed
IMPLICIT NONE
TYPE (b) :: x
RETURN
END SUBROUTINE bar
END MODULE seg_mod
! { dg-final { cleanup-modules "type_mod seg_mod" } }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment