[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

15 files changed, 200 insertions, 12 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a6ff8db..e2c2bcf 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,30 @@
+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-16  Tobias Burnus  <burnus@net-b.de>
 
 	* primary.c: Revert 'significand'-to-'significant' comment change.
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 66a173c..8a7eab5 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -1021,6 +1021,7 @@ gfc_show_code_node (int level, gfc_code * c)
       gfc_status ("ENTRY %s", c->ext.entry->sym->name);
       break;
 
+    case EXEC_INIT_ASSIGN:
     case EXEC_ASSIGN:
       gfc_status ("ASSIGN ");
       gfc_show_expr (c->expr);
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index f07c2a6..c89c136 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1507,7 +1507,7 @@ typedef enum
 {
   EXEC_NOP = 1, EXEC_ASSIGN, EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN,
   EXEC_GOTO, EXEC_CALL, EXEC_ASSIGN_CALL, EXEC_RETURN, EXEC_ENTRY,
-  EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE,
+  EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN,
   EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT,
   EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT,
   EXEC_ALLOCATE, EXEC_DEALLOCATE,
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);
+    }
 }
 
 
diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c
index cc86687..24c69da 100644
--- a/gcc/fortran/st.c
+++ b/gcc/fortran/st.c
@@ -93,6 +93,7 @@ gfc_free_statement (gfc_code * p)
     {
     case EXEC_NOP:
     case EXEC_ASSIGN:
+    case EXEC_INIT_ASSIGN:
     case EXEC_GOTO:
     case EXEC_CYCLE:
     case EXEC_RETURN:
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 190a115..3e7844e 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2031,7 +2031,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 		    && fsym->value)
 		{
 		  gcc_assert (!fsym->attr.allocatable);
-		  tmp = gfc_trans_assignment (e, fsym->value);
+		  tmp = gfc_trans_assignment (e, fsym->value, false);
 		  gfc_add_expr_to_block (&se->pre, tmp);
 		}
 
@@ -3363,7 +3363,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
    setting up the scalarizer.  */
 
 tree
-gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
+gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
 {
   gfc_se lse;
   gfc_se rse;
@@ -3466,7 +3466,8 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
   else
     gfc_conv_expr (&lse, expr1);
 
-  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, l_is_temp,
+  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
+				 l_is_temp || init_flag,
 				 expr2->expr_type == EXPR_VARIABLE);
   gfc_add_expr_to_block (&body, tmp);
 
@@ -3500,7 +3501,8 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	  gcc_assert (lse.ss == gfc_ss_terminator
 		      && rse.ss == gfc_ss_terminator);
 
-	  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
+	  tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
+					 false, false);
 	  gfc_add_expr_to_block (&body, tmp);
 	}
 
@@ -3518,7 +3520,13 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
 }
 
 tree
+gfc_trans_init_assign (gfc_code * code)
+{
+  return gfc_trans_assignment (code->expr, code->expr2, true);
+}
+
+tree
 gfc_trans_assign (gfc_code * code)
 {
-  return gfc_trans_assignment (code->expr, code->expr2);
+  return gfc_trans_assignment (code->expr, code->expr2, false);
 }
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index e817196..32020cc 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -424,7 +424,7 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
 
   /* Create the init statement list.  */
   pushlevel (0);
-  stmt = gfc_trans_assignment (e1, e2);
+  stmt = gfc_trans_assignment (e1, e2, false);
   if (TREE_CODE (stmt) != BIND_EXPR)
     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
   else
@@ -433,7 +433,7 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
 
   /* Create the merge statement list.  */
   pushlevel (0);
-  stmt = gfc_trans_assignment (e3, e4);
+  stmt = gfc_trans_assignment (e3, e4, false);
   if (TREE_CODE (stmt) != BIND_EXPR)
     stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
   else
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 1c49e7b..08ba113 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -2638,7 +2638,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
           else
             {
               /* Use the normal assignment copying routines.  */
-              assign = gfc_trans_assignment (c->expr, c->expr2);
+              assign = gfc_trans_assignment (c->expr, c->expr2, false);
 
               /* Generate body and loops.  */
               tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1);
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index e30cb23..2a8cf3c 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -28,6 +28,7 @@ tree gfc_trans_code (gfc_code *);
 /* trans-expr.c */
 tree gfc_trans_assign (gfc_code *);
 tree gfc_trans_pointer_assign (gfc_code *);
+tree gfc_trans_init_assign (gfc_code *);
 
 /* trans-stmt.c */
 tree gfc_trans_cycle (gfc_code *);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index d4856fd..69a702e 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -477,6 +477,10 @@ gfc_trans_code (gfc_code * code)
 	  res = gfc_trans_pointer_assign (code);
 	  break;
 
+	case EXEC_INIT_ASSIGN:
+	  res = gfc_trans_init_assign (code);
+	  break;
+
 	case EXEC_CONTINUE:
 	  res = NULL_TREE;
 	  break;
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index bdee578..13c21aa 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -426,7 +426,7 @@ bool get_array_ctor_strlen (gfc_constructor *, tree *);
 void gfc_trans_runtime_check (tree, const char *, stmtblock_t *, locus *);
 
 /* Generate code for an assignment, includes scalarization.  */
-tree gfc_trans_assignment (gfc_expr *, gfc_expr *);
+tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool);
 
 /* Generate code for a pointer assignment.  */
 tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 40e89cc..45304d8 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,14 @@
+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.
+
 2006-10-18  Geoffrey Keating  <geoffk@apple.com>
 
 	* g++.old-deja/g++.robertl/eb133b.C: Add XFAILed error for
diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
index 06989d3..649c4a7 100644
--- a/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
+++ b/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
@@ -139,5 +139,5 @@ contains
     end subroutine check_alloc2
 
 end program alloc
-! { dg-final { scan-tree-dump-times "deallocate" 38 "original" } }
+! { dg-final { scan-tree-dump-times "deallocate" 33 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/automatic_default_init_1.f90 b/gcc/testsuite/gfortran.dg/automatic_default_init_1.f90
new file mode 100644
index 0000000..525632b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/automatic_default_init_1.f90
@@ -0,0 +1,21 @@
+! { dg-do run }
+! { dg-options "-O" }
+! Test the fix for PR29394 in which automatic arrays did not
+! get default initialization.
+! Contributed by Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org> 
+!
+MODULE M1
+  TYPE T1 
+    INTEGER :: I=7 
+  END TYPE T1 
+CONTAINS 
+  SUBROUTINE S1(I) 
+    INTEGER, INTENT(IN) :: I 
+    TYPE(T1) :: D(1:I)
+    IF (any (D(:)%I.NE.7)) CALL ABORT() 
+  END SUBROUTINE S1 
+END MODULE M1
+  USE M1 
+  CALL S1(2) 
+END 
+! { dg-final { cleanup-modules "m1" } }
diff --git a/gcc/testsuite/gfortran.dg/result_default_init_1.f90 b/gcc/testsuite/gfortran.dg/result_default_init_1.f90
new file mode 100644
index 0000000..58872df
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/result_default_init_1.f90
@@ -0,0 +1,26 @@
+! { dg-do run }
+! { dg-options "-O" }
+! Test the fix for PR29216 in which function results did not
+! get default initialization.
+! Contributed by Stephan Kramer  <stephan.kramer@imperial.ac.uk>  
+!
+  type A
+    integer, pointer:: p => null ()
+    integer:: i=3
+  end type A
+  type(A):: x,y
+  if (associated(x%p) .or. x%i /= 3) call abort ()
+  x=f()
+  if (associated(x%p) .or. x%i /= 3) call abort ()
+  x=g()
+  if (associated(x%p) .or. x%i /= 3) call abort ()
+contains
+  function f() result (fr)
+    type(A):: fr
+    if (associated(fr%p) .or. fr%i /= 3) call abort ()
+  end function f
+  function g()
+    type(A):: g
+    if (associated(g%p) .or. g%i /= 3) call abort ()
+  end function g
+end