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.


git-svn-id: https://gcc.gnu.org/svn/gcc/trunk@116369 138bc75d-0d04-0410-961f-82ee72b054a4

9 files changed, 184 insertions, 39 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 655c01481fd..dd3ae5fc95e 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,16 @@
+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
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 79310e9dfbe..19bf1b0ee76 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -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)
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 801e85acec0..c36c4567a86 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -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)
 	{
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 3dfdc235bcb..51f2d928b0d 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,16 @@
+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
diff --git a/gcc/testsuite/gfortran.dg/assumed_charlen_in_main.f90 b/gcc/testsuite/gfortran.dg/assumed_charlen_in_main.f90
index a29bdb9d5d0..f4bb701548d 100644
--- a/gcc/testsuite/gfortran.dg/assumed_charlen_in_main.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_charlen_in_main.f90
@@ -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
 
diff --git a/gcc/testsuite/gfortran.dg/derived_init_2.f90 b/gcc/testsuite/gfortran.dg/derived_init_2.f90
index 381f13afbbc..99951c32a52 100644
--- a/gcc/testsuite/gfortran.dg/derived_init_2.f90
+++ b/gcc/testsuite/gfortran.dg/derived_init_2.f90
@@ -1,38 +1,48 @@
-! { 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
diff --git a/gcc/testsuite/gfortran.dg/used_types_2.f90 b/gcc/testsuite/gfortran.dg/used_types_2.f90
index 167323c0cb1..b1870d12b5a 100644
--- a/gcc/testsuite/gfortran.dg/used_types_2.f90
+++ b/gcc/testsuite/gfortran.dg/used_types_2.f90
@@ -30,4 +30,5 @@ LOGICAL FUNCTION foobar (x)
    foobar = .FALSE.
    c = bar (x)
 END FUNCTION foobar
+! { dg-final { cleanup-modules "types foo" } }
 
diff --git a/gcc/testsuite/gfortran.dg/used_types_3.f90 b/gcc/testsuite/gfortran.dg/used_types_3.f90
index 8273ee420ea..68d112bd281 100644
--- a/gcc/testsuite/gfortran.dg/used_types_3.f90
+++ b/gcc/testsuite/gfortran.dg/used_types_3.f90
@@ -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" } }
diff --git a/gcc/testsuite/gfortran.dg/used_types_4.f90 b/gcc/testsuite/gfortran.dg/used_types_4.f90
new file mode 100644
index 00000000000..a08fd0f73d3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/used_types_4.f90
@@ -0,0 +1,40 @@
+! { 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" } }