re PR fortran/46581 ([OOP] segfault in SELECT TYPE with associate-name)

2010-11-25  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/46581
	* trans.h (gfc_process_block_locals): Removed second argument.
	* trans-decl.c (trans_associate_var): Moved to trans-stmt.c.
	(gfc_trans_deferred_vars): Skip ASSOCIATE variables.
	(gfc_process_block_locals): Don't mark associate names to be
	initialized.
	* trans-stmt.c (trans_associate_var): Moved here from trans-decl.c.
	(gfc_trans_block_construct): Call 'trans_associate_var' from here
	to make sure SELECT TYPE with associate-name is treated correctly.

2010-11-25  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/46581
	* gfortran.dg/select_type_19.f03: New.

From-SVN: r167154

6 files changed, 135 insertions, 100 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index adf75f8..fa1dc77 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,15 @@
+2010-11-25  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46581
+	* trans.h (gfc_process_block_locals): Removed second argument.
+	* trans-decl.c (trans_associate_var): Moved to trans-stmt.c.
+	(gfc_trans_deferred_vars): Skip ASSOCIATE variables.
+	(gfc_process_block_locals): Don't mark associate names to be
+	initialized.
+	* trans-stmt.c (trans_associate_var): Moved here from trans-decl.c.
+	(gfc_trans_block_construct): Call 'trans_associate_var' from here
+	to make sure SELECT TYPE with associate-name is treated correctly.
+
 2010-11-24  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/46638
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 0441db7..3eb70f8 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -3165,91 +3165,6 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 }
 
 
-/* Do proper initialization for ASSOCIATE names.  */
-
-static void
-trans_associate_var (gfc_symbol* sym, gfc_wrapped_block* block)
-{
-  gfc_expr* e;
-  tree tmp;
-
-  gcc_assert (sym->assoc);
-  e = sym->assoc->target;
-
-  /* Do a `pointer assignment' with updated descriptor (or assign descriptor
-     to array temporary) for arrays with either unknown shape or if associating
-     to a variable.  */
-  if (sym->attr.dimension
-      && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
-    {
-      gfc_se se;
-      gfc_ss* ss;
-      tree desc;
-
-      desc = sym->backend_decl;
-
-      /* If association is to an expression, evaluate it and create temporary.
-	 Otherwise, get descriptor of target for pointer assignment.  */
-      gfc_init_se (&se, NULL);
-      ss = gfc_walk_expr (e);
-      if (sym->assoc->variable)
-	{
-	  se.direct_byref = 1;
-	  se.expr = desc;
-	}
-      gfc_conv_expr_descriptor (&se, e, ss);
-
-      /* If we didn't already do the pointer assignment, set associate-name
-	 descriptor to the one generated for the temporary.  */
-      if (!sym->assoc->variable)
-	{
-	  int dim;
-
-	  gfc_add_modify (&se.pre, desc, se.expr);
-
-	  /* The generated descriptor has lower bound zero (as array
-	     temporary), shift bounds so we get lower bounds of 1.  */
-	  for (dim = 0; dim < e->rank; ++dim)
-	    gfc_conv_shift_descriptor_lbound (&se.pre, desc,
-					      dim, gfc_index_one_node);
-	}
-
-      /* Done, register stuff as init / cleanup code.  */
-      gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
-			    gfc_finish_block (&se.post));
-    }
-
-  /* Do a scalar pointer assignment; this is for scalar variable targets.  */
-  else if (gfc_is_associate_pointer (sym))
-    {
-      gfc_se se;
-
-      gcc_assert (!sym->attr.dimension);
-
-      gfc_init_se (&se, NULL);
-      gfc_conv_expr (&se, e);
-
-      tmp = TREE_TYPE (sym->backend_decl);
-      tmp = gfc_build_addr_expr (tmp, se.expr);
-      gfc_add_modify (&se.pre, sym->backend_decl, tmp);
-      
-      gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
-			    gfc_finish_block (&se.post));
-    }
-
-  /* Do a simple assignment.  This is for scalar expressions, where we
-     can simply use expression assignment.  */
-  else
-    {
-      gfc_expr* lhs;
-
-      lhs = gfc_lval_expr_from_sym (sym);
-      tmp = gfc_trans_assignment (lhs, e, false, true);
-      gfc_add_init_cleanup (block, tmp, NULL_TREE);
-    }
-}
-
-
 /* Generate function entry and exit code, and add it to the function body.
    This includes:
     Allocation and initialization of array variables.
@@ -3316,8 +3231,9 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
       bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
 				   && sym->ts.u.derived->attr.alloc_comp;
       if (sym->assoc)
-	trans_associate_var (sym, block);
-      else if (sym->attr.dimension)
+	continue;
+
+      if (sym->attr.dimension)
 	{
 	  switch (sym->as->type)
 	    {
@@ -4890,22 +4806,13 @@ gfc_generate_block_data (gfc_namespace * ns)
 /* Process the local variables of a BLOCK construct.  */
 
 void
-gfc_process_block_locals (gfc_namespace* ns, gfc_association_list* assoc)
+gfc_process_block_locals (gfc_namespace* ns)
 {
   tree decl;
 
   gcc_assert (saved_local_decls == NULL_TREE);
   generate_local_vars (ns);
 
-  /* Mark associate names to be initialized.  The symbol's namespace may not
-     be the BLOCK's, we have to force this so that the deferring
-     works as expected.  */
-  for (; assoc; assoc = assoc->next)
-    {
-      assoc->st->n.sym->ns = ns;
-      gfc_defer_symbol_init (assoc->st->n.sym);
-    }
-
   decl = saved_local_decls;
   while (decl)
     {
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 1fd4254..c64b5f2 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -866,6 +866,91 @@ gfc_trans_critical (gfc_code *code)
 }
 
 
+/* Do proper initialization for ASSOCIATE names.  */
+
+static void
+trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
+{
+  gfc_expr *e;
+  tree tmp;
+
+  gcc_assert (sym->assoc);
+  e = sym->assoc->target;
+
+  /* Do a `pointer assignment' with updated descriptor (or assign descriptor
+     to array temporary) for arrays with either unknown shape or if associating
+     to a variable.  */
+  if (sym->attr.dimension
+      && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
+    {
+      gfc_se se;
+      gfc_ss *ss;
+      tree desc;
+
+      desc = sym->backend_decl;
+
+      /* If association is to an expression, evaluate it and create temporary.
+	 Otherwise, get descriptor of target for pointer assignment.  */
+      gfc_init_se (&se, NULL);
+      ss = gfc_walk_expr (e);
+      if (sym->assoc->variable)
+	{
+	  se.direct_byref = 1;
+	  se.expr = desc;
+	}
+      gfc_conv_expr_descriptor (&se, e, ss);
+
+      /* If we didn't already do the pointer assignment, set associate-name
+	 descriptor to the one generated for the temporary.  */
+      if (!sym->assoc->variable)
+	{
+	  int dim;
+
+	  gfc_add_modify (&se.pre, desc, se.expr);
+
+	  /* The generated descriptor has lower bound zero (as array
+	     temporary), shift bounds so we get lower bounds of 1.  */
+	  for (dim = 0; dim < e->rank; ++dim)
+	    gfc_conv_shift_descriptor_lbound (&se.pre, desc,
+					      dim, gfc_index_one_node);
+	}
+
+      /* Done, register stuff as init / cleanup code.  */
+      gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
+			    gfc_finish_block (&se.post));
+    }
+
+  /* Do a scalar pointer assignment; this is for scalar variable targets.  */
+  else if (gfc_is_associate_pointer (sym))
+    {
+      gfc_se se;
+
+      gcc_assert (!sym->attr.dimension);
+
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr (&se, e);
+
+      tmp = TREE_TYPE (sym->backend_decl);
+      tmp = gfc_build_addr_expr (tmp, se.expr);
+      gfc_add_modify (&se.pre, sym->backend_decl, tmp);
+      
+      gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
+			    gfc_finish_block (&se.post));
+    }
+
+  /* Do a simple assignment.  This is for scalar expressions, where we
+     can simply use expression assignment.  */
+  else
+    {
+      gfc_expr *lhs;
+
+      lhs = gfc_lval_expr_from_sym (sym);
+      tmp = gfc_trans_assignment (lhs, e, false, true);
+      gfc_add_init_cleanup (block, tmp, NULL_TREE);
+    }
+}
+
+
 /* Translate a BLOCK construct.  This is basically what we would do for a
    procedure body.  */
 
@@ -877,6 +962,7 @@ gfc_trans_block_construct (gfc_code* code)
   gfc_wrapped_block block;
   tree exit_label;
   stmtblock_t body;
+  gfc_association_list *ass;
 
   ns = code->ext.block.ns;
   gcc_assert (ns);
@@ -886,7 +972,7 @@ gfc_trans_block_construct (gfc_code* code)
   /* Process local variables.  */
   gcc_assert (!sym->tlink);
   sym->tlink = sym;
-  gfc_process_block_locals (ns, code->ext.block.assoc);
+  gfc_process_block_locals (ns);
 
   /* Generate code including exit-label.  */
   gfc_init_block (&body);
@@ -898,7 +984,9 @@ gfc_trans_block_construct (gfc_code* code)
   /* Finish everything.  */
   gfc_start_wrapped_block (&block, gfc_finish_block (&body));
   gfc_trans_deferred_vars (sym, &block);
-
+  for (ass = code->ext.block.assoc; ass; ass = ass->next)
+    trans_associate_var (ass->st->n.sym, &block);
+    
   return gfc_finish_wrapped_block (&block);
 }
 
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 6c944df..b5e30ff 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -554,7 +554,7 @@ tree gfc_build_library_function_decl_with_spec (tree name, const char *spec,
 						tree rettype, int nargs, ...);
 
 /* Process the local variable decls of a block construct.  */
-void gfc_process_block_locals (gfc_namespace*, gfc_association_list*);
+void gfc_process_block_locals (gfc_namespace*);
 
 /* Output initialization/clean-up code that was deferred.  */
 void gfc_trans_deferred_vars (gfc_symbol*, gfc_wrapped_block *);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 9af459f..e8e3341 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2010-11-25  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/46581
+	* gfortran.dg/select_type_19.f03: New.
+
 2010-11-25  Nicola Pero  <nicola.pero@meta-innovation.com>
 
 	* objc.dg/ivar-problem-1.m: New.
diff --git a/gcc/testsuite/gfortran.dg/select_type_19.f03 b/gcc/testsuite/gfortran.dg/select_type_19.f03
new file mode 100644
index 0000000..0ae2e1c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_type_19.f03
@@ -0,0 +1,23 @@
+! { dg-do run }
+!
+! PR 46581: [4.6 Regression] [OOP] segfault in SELECT TYPE with associate-name
+!
+! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
+
+
+  implicit none
+
+  type :: t1
+    integer, allocatable :: ja(:)
+  end type
+
+  class(t1), allocatable  :: a 
+
+  allocate(a)
+
+  select type (aa=>a)
+  type is (t1)
+    if (allocated(aa%ja)) call abort()
+  end select
+
+end