re PR fortran/34438 (gfortran not compliant w.r.t default initialization of…

re PR fortran/34438 (gfortran not compliant w.r.t default initialization of derived type component and implicit SAVE attribute)

2007-12-21  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/34438
	* trans-decl.c (gfc_finish_var_decl): Do not mark derived types
	with default initializers as TREE_STATIC unless they are in the
	main program scope.
	(gfc_get_symbol_decl): Pass derived types with a default
	initializer to gfc_defer_symbol_init.
	(init_default_dt): Apply default initializer to a derived type.
	(init_intent_out_dt): Call init_default_dt.
	(gfc_trans_deferred_vars): Ditto.

	* module.c (read_module): Check sym->module is there before
	using it in a string comparison.

2007-12-21  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/34438
	* gfortran.dg/default_initialization_3.f90: New test.

From-SVN: r131124

gcc/fortran/ChangeLog

+2007-12-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34438
+	* trans-decl.c (gfc_finish_var_decl): Do not mark derived types
+	with default initializers as TREE_STATIC unless they are in the
+	main program scope.
+	(gfc_get_symbol_decl): Pass derived types with a default
+	initializer to gfc_defer_symbol_init.
+	(init_default_dt): Apply default initializer to a derived type.
+	(init_intent_out_dt): Call init_default_dt.
+	(gfc_trans_deferred_vars): Ditto.
+
+	* module.c (read_module): Check sym->module is there before
+	using it in a string comparison.
+
 2007-12-20  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/34482

gcc/fortran/module.c

@@ -3732,6 +3732,7 @@ read_module (void)
 	      if (st && only_flag
 		     && !st->n.sym->attr.use_only
 		     && !st->n.sym->attr.use_rename
+		     && st->n.sym->module
 		     && strcmp (st->n.sym->module, module_name) == 0)
 		st->name = gfc_get_string ("hidden.%s", name);
 

gcc/fortran/trans-decl.c

@@ -517,8 +517,15 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
       TREE_STATIC (decl) = 1;
     }
 
-  if ((sym->attr.save || sym->attr.data || sym->value)
-      && !sym->attr.use_assoc)
+  /* Derived types are a bit peculiar because of the possibility of
+     a default initializer; this must be applied each time the variable
+     comes into scope it therefore need not be static.  These variables
+     are SAVE_NONE but have an initializer.  Otherwise explicitly
+     intitialized variables are SAVE_IMPLICIT and explicitly saved are
+     SAVE_EXPLICIT.  */
+  if (!sym->attr.use_assoc
+	&& (sym->attr.save != SAVE_NONE || sym->attr.data
+	      || (sym->value && sym->ns->proc_name->attr.is_main_program)))
     TREE_STATIC (decl) = 1;
 
   if (sym->attr.volatile_)
@@ -995,6 +1002,14 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 
   if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
     gfc_defer_symbol_init (sym);
+  /* This applies a derived type default initializer.  */
+  else if (sym->ts.type == BT_DERIVED
+	     && sym->attr.save == SAVE_NONE
+	     && !sym->attr.data
+	     && !sym->attr.allocatable
+	     && (sym->value && !sym->ns->proc_name->attr.is_main_program)
+	     && !sym->attr.use_assoc)
+    gfc_defer_symbol_init (sym);
 
   gfc_finish_var_decl (decl, sym);
 
@@ -2572,43 +2587,53 @@ gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
 }
 
 
-/* Initialize INTENT(OUT) derived type dummies.  */
+/* Initialize a derived type by building an lvalue from the symbol
+   and using trans_assignment to do the work.  */
 static tree
-init_intent_out_dt (gfc_symbol * proc_sym, tree body)
+init_default_dt (gfc_symbol * sym, tree body)
 {
   stmtblock_t fnblock;
-  gfc_formal_arglist *f;
-  gfc_expr *tmpe;
+  gfc_expr *e;
   tree tmp;
   tree present;
 
   gfc_init_block (&fnblock);
-
-  for (f = proc_sym->formal; f; f = f->next)
+  gcc_assert (!sym->attr.allocatable);
+  gfc_set_sym_referenced (sym);
+  e = gfc_lval_expr_from_sym (sym);
+  tmp = gfc_trans_assignment (e, sym->value, false);
+  if (sym->attr.dummy)
     {
-      if (f->sym && f->sym->attr.intent == INTENT_OUT
-	    && f->sym->ts.type == BT_DERIVED
-	    && !f->sym->ts.derived->attr.alloc_comp
-	    && f->sym->value)
-	{
-	  gcc_assert (!f->sym->attr.allocatable);
-	  gfc_set_sym_referenced (f->sym);
-	  tmpe = gfc_lval_expr_from_sym (f->sym);
-	  tmp = gfc_trans_assignment (tmpe, f->sym->value, false);
-
-	  present = gfc_conv_expr_present (f->sym);
-	  tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
-			tmp, build_empty_stmt ());
-	  gfc_add_expr_to_block (&fnblock, tmp);
-	  gfc_free_expr (tmpe);
-	}
+      present = gfc_conv_expr_present (sym);
+      tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
+		    tmp, build_empty_stmt ());
     }
-
+  gfc_add_expr_to_block (&fnblock, tmp);
+  gfc_free_expr (e);
   gfc_add_expr_to_block (&fnblock, body);
   return gfc_finish_block (&fnblock);
 }
 
 
+/* Initialize INTENT(OUT) derived type dummies.  */
+static tree
+init_intent_out_dt (gfc_symbol * proc_sym, tree body)
+{
+  stmtblock_t fnblock;
+  gfc_formal_arglist *f;
+
+  gfc_init_block (&fnblock);
+  for (f = proc_sym->formal; f; f = f->next)
+    if (f->sym && f->sym->attr.intent == INTENT_OUT
+	  && f->sym->ts.type == BT_DERIVED
+	  && !f->sym->ts.derived->attr.alloc_comp
+	  && f->sym->value)
+      body = init_default_dt (f->sym, body);
+
+  gfc_add_expr_to_block (&fnblock, body);
+  return gfc_finish_block (&fnblock);
+}
+
 
 /* Generate function entry and exit code, and add it to the function body.
    This includes:
@@ -2698,6 +2723,11 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 		      seen_trans_deferred_array = true;
 		      fnbody = gfc_trans_deferred_array (sym, fnbody);
 		    }
+		  else if (sym->ts.type == BT_DERIVED
+			     && sym->value
+			     && !sym->attr.data
+			     && sym->attr.save == SAVE_NONE)
+		    fnbody = init_default_dt (sym, fnbody);
 
 		  gfc_get_backend_locus (&loc);
 		  gfc_set_backend_locus (&sym->declared_at);
@@ -2753,6 +2783,11 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 	  fnbody = gfc_trans_assign_aux_var (sym, fnbody);
 	  gfc_set_backend_locus (&loc);
 	}
+      else if (sym->ts.type == BT_DERIVED
+		 && sym->value
+		 && !sym->attr.data
+		 && sym->attr.save == SAVE_NONE)
+	fnbody = init_default_dt (sym, fnbody);
       else
 	gcc_unreachable ();
     }

gcc/testsuite/ChangeLog

+2007-12-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/34438
+	* gfortran.dg/default_initialization_3.f90: New test.
+
 2007-12-21  Richard Sandiford  <rsandifo@nildram.co.uk>
 
 	* gcc.target/mips/mips.exp (setup_mips_tests): Fix _MIPS_SIM

gcc/testsuite/gfortran.dg/default_initialization_3.f90

+! { dg-do run }
+! Test the fix for PR34438, in which default initializers
+! forced the derived type to be static; ie. initialized once
+! during the lifetime of the programme.  Instead, they should
+! be initialized each time they come into scope.
+!
+! Contributed by Sven Buijssen <sven.buijssen@math.uni-dortmund.de>
+! Third test is from  Dominique Dhumieres <dominiq@lps.ens.fr>
+!
+module demo
+   type myint
+     integer :: bar = 42
+   end type myint
+end module demo
+
+! As the name implies, this was the original testcase
+! provided by the contributor....
+subroutine original
+  use demo
+  integer val1 (6)
+  integer val2 (6)
+  call recfunc (1)
+  if (any (val1 .ne. (/1, 2, 3, 1, 2, 3/))) call abort ()
+  if (any (val2 .ne. (/1, 2, 3, 4, 4, 4/))) call abort ()
+contains
+
+  recursive subroutine recfunc (ivalue)
+    integer, intent(in) :: ivalue
+    type(myint) :: foo1
+    type(myint) :: foo2 = myint (99)
+    foo1%bar = ivalue
+    foo2%bar = ivalue
+    if (ivalue .le. 3) then
+      val1(ivalue) = foo1%bar
+      val2(ivalue) = foo2%bar
+      call recfunc (ivalue + 1)
+      val1(ivalue + 3) = foo1%bar
+      val2(ivalue + 3) = foo2%bar
+    endif
+  end subroutine recfunc
+end subroutine original
+
+! ...who came up with this one too.
+subroutine func (ivalue, retval1, retval2)
+  use demo
+  integer, intent(in) :: ivalue
+  type(myint) :: foo1
+  type(myint) :: foo2 = myint (77)
+  type(myint) :: retval1
+  type(myint) :: retval2
+  retval1 = foo1
+  retval2 = foo2
+  foo1%bar = 999
+  foo2%bar = 999
+end subroutine func
+
+subroutine other
+  use demo
+  interface
+    subroutine func(ivalue, rv1, rv2)
+      use demo
+      integer, intent(in) :: ivalue
+      type(myint) :: foo, rv1, rv2
+   end subroutine func
+  end interface
+  type(myint) :: val1, val2
+  call func (1, val1, val2)
+  if ((val1%bar .ne. 42) .or. (val2%bar .ne. 77)) call abort ()
+  call func (2, val1, val2)
+  if ((val1%bar .ne. 42) .or. (val2%bar .ne. 999)) call abort ()
+
+end subroutine other
+
+MODULE M1
+  TYPE T1
+    INTEGER :: i=7
+  END TYPE T1
+CONTAINS
+  FUNCTION F1(d1) RESULT(res)
+    INTEGER :: res
+    TYPE(T1), INTENT(OUT) :: d1
+    TYPE(T1), INTENT(INOUT) :: d2
+    res=d1%i
+    d1%i=0
+    RETURN
+  ENTRY   E1(d2) RESULT(res)
+    res=d2%i
+    d2%i=0
+  END FUNCTION F1
+END MODULE M1
+
+! This tests the fix of a regression caused by the first version
+! of the patch.
+subroutine dominique ()
+  USE M1
+  TYPE(T1) :: D1
+  D1=T1(3)
+  if (F1(D1) .ne. 7) call abort ()
+  D1=T1(3)
+  if (E1(D1) .ne. 3) call abort ()
+END
+
+! Run both tests.
+  call original
+  call other
+  call dominique
+end
+! { dg-final { cleanup-modules "demo M1" } }