[multiple changes]

2006-10-19  Paul Thomas <pault@gcc.gnu.org>

	PR fortran/29216
	PR fortran/29314
	* gfortran.h : Add EXEC_INIT_ASSIGN.
	* dump-parse-tree.c (gfc_show_code_node): The same.
	* trans-openmp.c (gfc_trans_omp_array_reduction): Set new
	argument for gfc_trans_assignment to false.
	* trans-stmt.c (gfc_trans_forall_1): The same.
	* trans-expr.c (gfc_conv_function_call, gfc_trans_assign,
	gfc_trans_arrayfunc_assign, gfc_trans_assignment): The
	same. In the latter function, use the new flag to stop
	the checking of the lhs for deallocation.
	(gfc_trans_init_assign): New function.
	* trans-stmt.h : Add prototype for gfc_trans_init_assign.
	* trans.c (gfc_trans_code): Implement EXEC_INIT_ASSIGN.
	* trans.h : Add new boolean argument to the prototype of
	gfc_trans_assignment.
	* resolve.c (resolve_allocate_exp): Replace EXEC_ASSIGN by
	EXEC_INIT_ASSIGN.
	(resolve_code): EXEC_INIT_ASSIGN does not need resolution.
	(apply_default_init): New function.
	(resolve_symbol): Call it for derived types that become
	defined but which do not already have an initialization
	expression..
	* st.c (gfc_free_statement): Include EXEC_INIT_ASSIGN.

2006-10-19  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/29216
	* gfortran.dg/result_default_init_1.f90: New test.

	PR fortran/29314
	* gfortran.dg/automatic_default_init_1.f90: New test.

	* gfortran.dg/alloc_comp_basics_1.f90: Reduce deallocate count
	from 38 to 33.

From-SVN: r117879

1 files changed, 89 insertions, 1 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 2639cab..d3722e6 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -3556,7 +3556,7 @@ resolve_allocate_expr (gfc_expr * e, gfc_code * code)
     {
         init_st = gfc_get_code ();
         init_st->loc = code->loc;
-        init_st->op = EXEC_ASSIGN;
+        init_st->op = EXEC_INIT_ASSIGN;
         init_st->expr = expr_to_initialize (e);
 	init_st->expr2 = init_e;
         init_st->next = code->next;
@@ -4907,6 +4907,9 @@ resolve_code (gfc_code * code, gfc_namespace * ns)
 		       "INTEGER return specifier", &code->expr->where);
 	  break;
 
+	case EXEC_INIT_ASSIGN:
+	  break;
+
 	case EXEC_ASSIGN:
 	  if (t == FAILURE)
 	    break;
@@ -5222,6 +5225,75 @@ is_non_constant_shape_array (gfc_symbol *sym)
   return not_constant;
 }
 
+
+/* Assign the default initializer to a derived type variable or result.  */
+
+static void
+apply_default_init (gfc_symbol *sym)
+{
+  gfc_expr *lval;
+  gfc_expr *init = NULL;
+  gfc_code *init_st;
+  gfc_namespace *ns = sym->ns;
+
+  if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
+    return;
+
+  if (sym->ts.type == BT_DERIVED && sym->ts.derived)
+    init = gfc_default_initializer (&sym->ts);
+
+  if (init == NULL)
+    return;
+
+  /* Search for the function namespace if this is a contained
+     function without an explicit result.  */
+  if (sym->attr.function && sym == sym->result
+	&& sym->name != sym->ns->proc_name->name)
+    {
+      ns = ns->contained;
+      for (;ns; ns = ns->sibling)
+	if (strcmp (ns->proc_name->name, sym->name) == 0)
+	  break;
+    }
+
+  if (ns == NULL)
+    {
+      gfc_free_expr (init);
+      return;
+    }
+
+  /* Build an l-value expression for the result.  */
+  lval = gfc_get_expr ();
+  lval->expr_type = EXPR_VARIABLE;
+  lval->where = sym->declared_at;
+  lval->ts = sym->ts;
+  lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
+
+  /* It will always be a full array.  */
+  lval->rank = sym->as ? sym->as->rank : 0;
+  if (lval->rank)
+    {
+      lval->ref = gfc_get_ref ();
+      lval->ref->type = REF_ARRAY;
+      lval->ref->u.ar.type = AR_FULL;
+      lval->ref->u.ar.dimen = lval->rank;
+      lval->ref->u.ar.where = sym->declared_at;
+      lval->ref->u.ar.as = sym->as;
+    }
+
+  /* Add the code at scope entry.  */
+  init_st = gfc_get_code ();
+  init_st->next = ns->code;
+  ns->code = init_st;
+
+  /* Assign the default initializer to the l-value.  */
+  init_st->loc = sym->declared_at;
+  init_st->op = EXEC_INIT_ASSIGN;
+  init_st->expr = lval;
+  init_st->expr2 = init;
+}
+
+
 /* Resolution of common features of flavors variable and procedure. */
 
 static try
@@ -5960,6 +6032,22 @@ resolve_symbol (gfc_symbol * sym)
           && (sym->ns->proc_name == NULL
               || sym->ns->proc_name->attr.flavor != FL_MODULE)))
     gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
+
+  /* If we have come this far we can apply default-initializers, as
+     described in 14.7.5, to those variables that have not already
+     been assigned one.  */
+  if (sym->ts.type == BT_DERIVED && sym->ns == gfc_current_ns && !sym->value
+	&& !sym->attr.allocatable && !sym->attr.alloc_comp)
+    {
+      symbol_attribute *a = &sym->attr;
+
+      if ((!a->save && !a->dummy && !a->pointer
+		&& !a->in_common && !a->use_assoc
+		&& !(a->function && sym != sym->result))
+	     ||
+	  (a->dummy && a->intent == INTENT_OUT))
+	apply_default_init (sym);
+    }
 }