Commit 96f4873b by Paul Thomas

re PR fortran/28788 (ICE on valid code)

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

	PR fortran/28788
	* gfortran.dg/used_types_4.f90: New test.
	* gfortran.dg/derived_init_2.f90: Modify to check sibling
	association of derived types.
	* gfortran.dg/used_types_2.f90: Add module cleanup.
	* gfortran.dg/used_types_3.f90: The same.

	PR fortran/28771
	* gfortran.dg/assumed_charlen_in_main.f90: Modify to check
	fix of regression.

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

	PR fortran/28788
	* gfortran.dg/used_types_4.f90: New test.
	* gfortran.dg/derived_init_2.f90: Modify to check sibling
	association of derived types.
	* gfortran.dg/used_types_2.f90: Add module cleanup.
	* gfortran.dg/used_types_3.f90: The same.

	PR fortran/28771
	* gfortran.dg/assumed_charlen_in_main.f90: Modify to check
	fix of regression.

From-SVN: r116369
parent 664ee581
2006-08-24 Paul Thomas <pault@gcc.gnu.org>
PR fortran/28788
* symbol.c (shift_types): Shift the derived type references in
formal namespaces.
(gfc_use_derived): Return if the derived type symbol is already
in another namspace. Add searches for the derived type in
sibling namespaces.
PR fortran/28771
* decl.c (add_init_expr_to_sym): Restore the original but
restricted to parameter arrays to fix a regression.
2006-08-23 Steven G. Kargl <kargls@comcast.net>
* gfortran.texi: Fix last commit where a "no" was deleted and
......
......@@ -875,6 +875,10 @@ add_init_expr_to_sym (const char *name, gfc_expr ** initp,
sym->ts.cl = gfc_get_charlen ();
sym->ts.cl->next = gfc_current_ns->cl_list;
gfc_current_ns->cl_list = sym->ts.cl;
if (sym->attr.flavor == FL_PARAMETER
&& init->expr_type == EXPR_ARRAY)
sym->ts.cl->length = gfc_copy_expr (init->ts.cl->length);
}
/* Update initializer character length according symbol. */
else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
......
......@@ -1391,8 +1391,10 @@ find_renamed_type (gfc_symbol * der, gfc_symtree * st)
return sym;
}
/* Recursive function to switch derived types of all symbol in a
namespace. */
/* Recursive function to switch derived types of all symbols in a
namespace. The formal namespaces contain references to derived
types that can be left hanging by gfc_use_derived, so these must
be switched too. */
static void
switch_types (gfc_symtree * st, gfc_symbol * from, gfc_symbol * to)
......@@ -1405,6 +1407,9 @@ switch_types (gfc_symtree * st, gfc_symbol * from, gfc_symbol * to)
sym = st->n.sym;
if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
sym->ts.derived = to;
if (sym->formal_ns && sym->formal_ns->sym_root)
switch_types (sym->formal_ns->sym_root, from, to);
switch_types (st->left, from, to);
switch_types (st->right, from, to);
......@@ -1436,11 +1441,12 @@ gfc_use_derived (gfc_symbol * sym)
gfc_typespec *t;
gfc_symtree *st;
gfc_component *c;
gfc_namespace *ns;
int i;
if (sym->ns->parent == NULL)
if (sym->ns->parent == NULL || sym->ns != gfc_current_ns)
{
/* Already defined in highest possible namespace. */
/* Already defined in highest possible or sibling namespace. */
if (sym->components != NULL)
return sym;
......@@ -1466,6 +1472,27 @@ gfc_use_derived (gfc_symbol * sym)
return NULL;
}
/* Look in sibling namespaces for a derived type of the same name. */
if (s == NULL && sym->attr.use_assoc && sym->ns->sibling)
{
ns = sym->ns->sibling;
for (; ns; ns = ns->sibling)
{
s = NULL;
if (sym->ns == ns)
break;
if (gfc_find_symbol (sym->name, ns, 1, &s))
{
gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
return NULL;
}
if (s != NULL && s->attr.flavor == FL_DERIVED)
break;
}
}
if (s == NULL || s->attr.flavor != FL_DERIVED)
{
/* Check to see if type has been renamed in parent namespace.
......@@ -1479,6 +1506,28 @@ gfc_use_derived (gfc_symbol * sym)
return s;
}
/* See if sym is identical to renamed, use-associated derived
types in sibling namespaces. */
if (sym->attr.use_assoc
&& sym->ns->parent
&& sym->ns->parent->contained)
{
ns = sym->ns->parent->contained;
for (; ns; ns = ns->sibling)
{
if (sym->ns == ns)
break;
s = find_renamed_type (sym, ns->sym_root);
if (s != NULL)
{
switch_types (sym->ns->sym_root, sym, s);
return s;
}
}
}
/* The local definition is all that there is. */
if (sym->components != NULL)
{
......
2006-08-23 Paul Thomas <pault@gcc.gnu.org>
PR fortran/28788
* gfortran.dg/used_types_4.f90: New test.
* gfortran.dg/derived_init_2.f90: Modify to check sibling
association of derived types.
* gfortran.dg/used_types_2.f90: Add module cleanup.
* gfortran.dg/used_types_3.f90: The same.
PR fortran/28771
* gfortran.dg/assumed_charlen_in_main.f90: Modify to check
fix of regression.
2006-08-23 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR 28813
......@@ -3,11 +3,25 @@
! survive in the main program without causing an error.
!
! Contributed by Martin Reinecke <martin@mpa-garching.mpg.de>
!
! Modified to test fix of regression reported by P.Schaffnit@access.rwth-aachen.de
subroutine poobar ()
! The regression caused an ICE here
CHARACTER ( LEN = * ), PARAMETER :: Markers(5) = (/ "Error ", &
& "Fehler", &
& "Erreur", &
& "Stop ", &
& "Arret " /)
character(6) :: recepteur (5)
recepteur = Markers
end subroutine poobar
! If the regression persisted, the compilation would stop before getting here
program test
character(len=*), parameter :: foo = 'test' ! Parameters must work.
character(len=4) :: bar = foo
character(len=*) :: foobar = 'This should fail' ! { dg-error "must be a dummy" }
print *, bar
call poobar ()
end
! { dg-do run }
! PR 25217: INTENT(OUT) dummies of derived type with default initializers shall
! { dg-do run }
! PR 25217: INTENT(OUT) dummies of derived type with default initializers shall
! be (re)initialized upon procedure entry, unless they are ALLOCATABLE.
program main
implicit none
type :: drv
integer :: a(3) = [ 1, 2, 3 ]
character(3) :: s = "abc"
real, pointer :: p => null()
end type drv
type(drv) :: aa
type(drv), allocatable :: ab(:)
real, target :: x
aa%a = [ 4, 5, 6]
aa%s = "def"
aa%p => x
call sub(aa)
call sub2(ab)
! Modified to take account of the regression, identified by Martin Tees
! http://gcc.gnu.org/ml/fortran/2006-08/msg00276.html and fixed with
! PR 28788.
module dt
type :: drv
integer :: a(3) = [ 1, 2, 3 ]
character(3) :: s = "abc"
real, pointer :: p => null()
end type drv
end module dt
module subs
contains
subroutine foo(fb)
use dt
type(drv), intent(out) :: fb
call sub (fb)
end subroutine foo
subroutine sub(fa)
type(drv), intent(out) :: fa
if (any(fa%a /= [ 1, 2, 3 ])) call abort()
if (fa%s /= "abc") call abort()
if (associated(fa%p)) call abort()
use dt
type(drv), intent(out) :: fa
if (any(fa%a /= [ 1, 2, 3 ])) call abort()
if (fa%s /= "abc") call abort()
if (associated(fa%p)) call abort()
end subroutine sub
subroutine sub2(fa)
type(drv), allocatable, intent(out) :: fa(:)
end subroutine sub2
end program main
end module subs
program main
use dt
use subs
implicit none
type(drv) :: aa
type(drv), allocatable :: ab(:)
real, target :: x = 99, y = 999
aa = drv ([ 4, 5, 6], "def", x)
call sub(aa)
aa = drv ([ 7, 8, 9], "ghi", y)
call foo(aa)
end program main
! { dg-final { cleanup-modules "dt subs" } }
\ No newline at end of file
......@@ -30,4 +30,5 @@ LOGICAL FUNCTION foobar (x)
foobar = .FALSE.
c = bar (x)
END FUNCTION foobar
! { dg-final { cleanup-modules "types foo" } }
......@@ -55,3 +55,4 @@ ofTypB => a%ofTypA
a%ofTypA(i,j) = ofTypB(k,j)
end subroutine buggy
end module modC
! { dg-final { cleanup-modules "modA modB modC" } }
! { dg-do compile }
! Tests the fix for PR28788, a regression in which an ICE was caused
! by the failure of derived type association for the arguments of
! InitRECFAST because the formal namespace derived types references
! were not being reassociated to the module.
!
! Contributed by Martin Reinecke <martin@mpa-garching.mpg.de>
!
module Precision
integer, parameter :: dl = KIND(1.d0)
end module Precision
module ModelParams
use precision
type CAMBparams
real(dl)::omegab,h0,tcmb,yhe
end type
type (CAMBparams) :: CP
contains
subroutine CAMBParams_Set(P)
type(CAMBparams), intent(in) :: P
end subroutine CAMBParams_Set
end module ModelParams
module TimeSteps
use precision
use ModelParams
end module TimeSteps
module ThermoData
use TimeSteps
contains
subroutine inithermo(taumin,taumax)
use precision
use ModelParams ! Would ICE here
real(dl) taumin,taumax
call InitRECFAST(CP%omegab,CP%h0,CP%tcmb,CP%yhe)
end subroutine inithermo
end module ThermoData
! { dg-final { cleanup-modules "PRECISION ModelParams TimeSteps ThermoData" } }
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