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

gcc/fortran/ChangeLog

+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

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)

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)
 	{

gcc/testsuite/ChangeLog

+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

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
 

gcc/testsuite/gfortran.dg/derived_init_2.f90

-! { 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

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" } }
 

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" } }

gcc/testsuite/gfortran.dg/used_types_4.f90

+! { 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" } }