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

3 files changed, 76 insertions, 25 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 4701a2f..f90a077 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+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
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 9cb082a..f3c54b7 100644
--- a/gcc/fortran/module.c
+++ b/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);
 
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 876219f..f97870c 100644
--- a/gcc/fortran/trans-decl.c
+++ b/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 ();
     }