re PR fortran/38936 ([F03] ASSOCIATE construct / improved SELECT TYPE (a=>expr))

2010-08-26  Daniel Kraft  <d@domob.eu>

	PR fortran/38936
	PR fortran/44047
	PR fortran/45384
	* gfortran.h (struct gfc_association_list): New flag `dangling'.
	(gfc_build_block_ns): Declared here...
	* parse.h (gfc_build_block_ns): ...instead of here.
	* trans.h (gfc_process_block_locals): Expect additionally the
	gfc_association_list of BLOCK (if present).
	* match.c (select_type_set_tmp): Create sym->assoc for temporary.
	* resolve.c (resolve_variable): Only check for invalid *array*
	references on associate-names.
	(resolve_assoc_var): New method with code previously in resolve_symbol.
	(resolve_select_type): Use association to give the selector and
	temporaries their values instead of ordinary assignment.
	(resolve_fl_var_and_proc): Allow CLASS associate-names.
	(resolve_symbol): Use new `resolve_assoc_var' instead of inlining here.
	* trans-stmt.c (gfc_trans_block_construct): Pass association-list
	to `gfc_process_block_locals' to match new interface.
	* trans-decl.c (gfc_get_symbol_decl): Don't defer associate-names
	here automatically.
	(gfc_process_block_locals): Defer them rather here when linked to
	from the BLOCK's association list.

2010-08-26  Daniel Kraft  <d@domob.eu>

	PR fortran/38936
	PR fortran/44047
	PR fortran/45384
	* gfortran.dg/associate_8.f03: New test.
	* gfortran.dg/select_type_13.f03: New test.
	* gfortran.dg/select_type_14.f03: New test.

From-SVN: r163572

gcc/fortran/ChangeLog

+2010-08-26  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/38936
+	PR fortran/44047
+	PR fortran/45384
+	* gfortran.h (struct gfc_association_list): New flag `dangling'.
+	(gfc_build_block_ns): Declared here...
+	* parse.h (gfc_build_block_ns): ...instead of here.
+	* trans.h (gfc_process_block_locals): Expect additionally the
+	gfc_association_list of BLOCK (if present).
+	* match.c (select_type_set_tmp): Create sym->assoc for temporary.
+	* resolve.c (resolve_variable): Only check for invalid *array*
+	references on associate-names.
+	(resolve_assoc_var): New method with code previously in resolve_symbol.
+	(resolve_select_type): Use association to give the selector and
+	temporaries their values instead of ordinary assignment.
+	(resolve_fl_var_and_proc): Allow CLASS associate-names.
+	(resolve_symbol): Use new `resolve_assoc_var' instead of inlining here.
+	* trans-stmt.c (gfc_trans_block_construct): Pass association-list
+	to `gfc_process_block_locals' to match new interface.
+	* trans-decl.c (gfc_get_symbol_decl): Don't defer associate-names
+	here automatically.
+	(gfc_process_block_locals): Defer them rather here when linked to
+	from the BLOCK's association list.
+
 2010-08-25  Jakub Jelinek  <jakub@redhat.com>
 
 	* trans-decl.c (gfc_build_intrinsic_function_decls): Set

gcc/fortran/gfortran.h

@@ -2007,6 +2007,12 @@ typedef struct gfc_association_list
      lvalue.  */
   unsigned variable:1;
 
+  /* True if this struct is currently only linked to from a gfc_symbol rather
+     than as part of a real list in gfc_code->ext.block.assoc.  This may
+     happen for SELECT TYPE temporaries and must be considered
+     for memory handling.  */
+  unsigned dangling:1;
+
   char name[GFC_MAX_SYMBOL_LEN + 1];
   gfc_symtree *st; /* Symtree corresponding to name.  */
   locus where;
@@ -2831,6 +2837,7 @@ void gfc_dump_parse_tree (gfc_namespace *, FILE *);
 /* parse.c */
 gfc_try gfc_parse_file (void);
 void gfc_global_used (gfc_gsymbol *, locus *);
+gfc_namespace* gfc_build_block_ns (gfc_namespace *);
 
 /* dependency.c */
 int gfc_dep_compare_expr (gfc_expr *, gfc_expr *);

gcc/fortran/match.c

@@ -4479,6 +4479,12 @@ select_type_set_tmp (gfc_typespec *ts)
       tmp->n.sym->attr.class_ok = 1;
     }
 
+  /* Add an association for it, so the rest of the parser knows it is
+     an associate-name.  The target will be set during resolution.  */
+  tmp->n.sym->assoc = gfc_get_association_list ();
+  tmp->n.sym->assoc->dangling = 1;
+  tmp->n.sym->assoc->st = tmp;
+
   select_type_stack->tmp = tmp;
 }
 

gcc/fortran/parse.h

@@ -68,5 +68,4 @@ match gfc_match_enumerator_def (void);
 void gfc_free_enum_history (void);
 extern bool gfc_matching_function;
 match gfc_match_prefix (gfc_typespec *);
-gfc_namespace* gfc_build_block_ns (gfc_namespace *);
 #endif  /* GFC_PARSE_H  */

gcc/fortran/resolve.c

@@ -4921,9 +4921,9 @@ resolve_variable (gfc_expr *e)
     return FAILURE;
   sym = e->symtree->n.sym;
 
-  /* If this is an associate-name, it may be parsed with references in error
-     even though the target is scalar.  Fail directly in this case.  */
-  if (sym->assoc && !sym->attr.dimension && e->ref)
+  /* If this is an associate-name, it may be parsed with an array reference
+     in error even though the target is scalar.  Fail directly in this case.  */
+  if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
     return FAILURE;
 
   /* On the other hand, the parser may not have known this is an array;
@@ -7551,6 +7551,88 @@ gfc_type_is_extensible (gfc_symbol *sym)
 }
 
 
+/* Resolve an associate name:  Resolve target and ensure the type-spec is
+   correct as well as possibly the array-spec.  */
+
+static void
+resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
+{
+  gfc_expr* target;
+  bool to_var;
+
+  gcc_assert (sym->assoc);
+  gcc_assert (sym->attr.flavor == FL_VARIABLE);
+
+  /* If this is for SELECT TYPE, the target may not yet be set.  In that
+     case, return.  Resolution will be called later manually again when
+     this is done.  */
+  target = sym->assoc->target;
+  if (!target)
+    return;
+  gcc_assert (!sym->assoc->dangling);
+
+  if (resolve_target && gfc_resolve_expr (target) != SUCCESS)
+    return;
+
+  /* For variable targets, we get some attributes from the target.  */
+  if (target->expr_type == EXPR_VARIABLE)
+    {
+      gfc_symbol* tsym;
+
+      gcc_assert (target->symtree);
+      tsym = target->symtree->n.sym;
+
+      sym->attr.asynchronous = tsym->attr.asynchronous;
+      sym->attr.volatile_ = tsym->attr.volatile_;
+
+      sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
+    }
+
+  sym->ts = target->ts;
+  gcc_assert (sym->ts.type != BT_UNKNOWN);
+
+  /* See if this is a valid association-to-variable.  */
+  to_var = (target->expr_type == EXPR_VARIABLE
+	    && !gfc_has_vector_subscript (target));
+  if (sym->assoc->variable && !to_var)
+    {
+      if (target->expr_type == EXPR_VARIABLE)
+	gfc_error ("'%s' at %L associated to vector-indexed target can not"
+		   " be used in a variable definition context",
+		   sym->name, &sym->declared_at);
+      else
+	gfc_error ("'%s' at %L associated to expression can not"
+		   " be used in a variable definition context",
+		   sym->name, &sym->declared_at);
+
+      return;
+    }
+  sym->assoc->variable = to_var;
+
+  /* Finally resolve if this is an array or not.  */
+  if (sym->attr.dimension && target->rank == 0)
+    {
+      gfc_error ("Associate-name '%s' at %L is used as array",
+		 sym->name, &sym->declared_at);
+      sym->attr.dimension = 0;
+      return;
+    }
+  if (target->rank > 0)
+    sym->attr.dimension = 1;
+
+  if (sym->attr.dimension)
+    {
+      sym->as = gfc_get_array_spec ();
+      sym->as->rank = target->rank;
+      sym->as->type = AS_DEFERRED;
+
+      /* Target must not be coindexed, thus the associate-variable
+	 has no corank.  */
+      sym->as->corank = 0;
+    }
+}
+
+
 /* Resolve a SELECT TYPE statement.  */
 
 static void
@@ -7628,37 +7710,42 @@ resolve_select_type (gfc_code *code)
 	}
     }
     
-  if (error>0)
+  if (error > 0)
     return;
 
+  /* Transform SELECT TYPE statement to BLOCK and associate selector to
+     target if present.  */
+  code->op = EXEC_BLOCK;
   if (code->expr2)
     {
-      /* Insert assignment for selector variable.  */
-      new_st = gfc_get_code ();
-      new_st->op = EXEC_ASSIGN;
-      new_st->expr1 = gfc_copy_expr (code->expr1);
-      new_st->expr2 = gfc_copy_expr (code->expr2);
-      ns->code = new_st;
+      gfc_association_list* assoc;
+
+      assoc = gfc_get_association_list ();
+      assoc->st = code->expr1->symtree;
+      assoc->target = gfc_copy_expr (code->expr2);
+      /* assoc->variable will be set by resolve_assoc_var.  */
+      
+      code->ext.block.assoc = assoc;
+      code->expr1->symtree->n.sym->assoc = assoc;
+
+      resolve_assoc_var (code->expr1->symtree->n.sym, false);
     }
+  else
+    code->ext.block.assoc = NULL;
 
-  /* Put SELECT TYPE statement inside a BLOCK.  */
+  /* Add EXEC_SELECT to switch on type.  */
   new_st = gfc_get_code ();
   new_st->op = code->op;
   new_st->expr1 = code->expr1;
   new_st->expr2 = code->expr2;
   new_st->block = code->block;
+  code->expr1 = code->expr2 =  NULL;
+  code->block = NULL;
   if (!ns->code)
     ns->code = new_st;
   else
     ns->code->next = new_st;
-  code->op = EXEC_BLOCK;
-  code->ext.block.assoc = NULL;
-  code->expr1 = code->expr2 =  NULL;
-  code->block = NULL;
-
   code = new_st;
-
-  /* Transform to EXEC_SELECT.  */
   code->op = EXEC_SELECT;
   gfc_add_component_ref (code->expr1, "$vptr");
   gfc_add_component_ref (code->expr1, "$hash");
@@ -7675,24 +7762,37 @@ resolve_select_type (gfc_code *code)
       else if (c->ts.type == BT_UNKNOWN)
 	continue;
 
-      /* Assign temporary to selector.  */
+      /* Associate temporary to selector.  This should only be done
+	 when this case is actually true, so build a new ASSOCIATE
+	 that does precisely this here (instead of using the
+	 'global' one).  */
+
       if (c->ts.type == BT_CLASS)
 	sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
       else
 	sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
       st = gfc_find_symtree (ns->sym_root, name);
-      new_st = gfc_get_code ();
-      new_st->expr1 = gfc_get_variable_expr (st);
-      new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree);
+      gcc_assert (st->n.sym->assoc);
+      st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
       if (c->ts.type == BT_DERIVED)
+	gfc_add_component_ref (st->n.sym->assoc->target, "$data");
+
+      new_st = gfc_get_code ();
+      new_st->op = EXEC_BLOCK;
+      new_st->ext.block.ns = gfc_build_block_ns (ns);
+      new_st->ext.block.ns->code = body->next;
+      body->next = new_st;
+
+      /* Chain in the new list only if it is marked as dangling.  Otherwise
+	 there is a CASE label overlap and this is already used.  Just ignore,
+	 the error is diagonsed elsewhere.  */
+      if (st->n.sym->assoc->dangling)
 	{
-	  new_st->op = EXEC_POINTER_ASSIGN;
-	  gfc_add_component_ref (new_st->expr2, "$data");
+	  new_st->ext.block.assoc = st->n.sym->assoc;
+	  st->n.sym->assoc->dangling = 0;
 	}
-      else
-	new_st->op = EXEC_POINTER_ASSIGN;
-      new_st->next = body->next;
-      body->next = new_st;
+
+      resolve_assoc_var (st->n.sym, false);
     }
     
   /* Take out CLASS IS cases for separate treatment.  */
@@ -8405,7 +8505,7 @@ resolve_block_construct (gfc_code* code)
   gfc_resolve (code->ext.block.ns);
 
   /* For an ASSOCIATE block, the associations (and their targets) are already
-     resolved during gfc_resolve_symbol.  */
+     resolved during resolve_symbol.  */
 }
 
 
@@ -9634,8 +9734,10 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
 	}
 
       /* F03:C509.  */
-      /* Assume that use associated symbols were checked in the module ns.  */ 
-      if (!sym->attr.class_ok && !sym->attr.use_assoc)
+      /* Assume that use associated symbols were checked in the module ns.
+	 Class-variables that are associate-names are also something special
+	 and excepted from the test.  */
+      if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc)
 	{
 	  gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
 		     "or pointer", sym->name, &sym->declared_at);
@@ -11701,76 +11803,9 @@ resolve_symbol (gfc_symbol *sym)
       && resolve_intrinsic (sym, &sym->declared_at) == FAILURE)
     return;
 
-  /* For associate names, resolve corresponding expression and make sure
-     they get their type-spec set this way.  */
+  /* Resolve associate names.  */
   if (sym->assoc)
-    {
-      gfc_expr* target;
-      bool to_var;
-
-      gcc_assert (sym->attr.flavor == FL_VARIABLE);
-
-      target = sym->assoc->target;
-      if (gfc_resolve_expr (target) != SUCCESS)
-	return;
-
-      /* For variable targets, we get some attributes from the target.  */
-      if (target->expr_type == EXPR_VARIABLE)
-	{
-	  gfc_symbol* tsym;
-
-	  gcc_assert (target->symtree);
-	  tsym = target->symtree->n.sym;
-
-	  sym->attr.asynchronous = tsym->attr.asynchronous;
-	  sym->attr.volatile_ = tsym->attr.volatile_;
-
-	  sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
-	}
-
-      sym->ts = target->ts;
-      gcc_assert (sym->ts.type != BT_UNKNOWN);
-
-      /* See if this is a valid association-to-variable.  */
-      to_var = (target->expr_type == EXPR_VARIABLE
-		&& !gfc_has_vector_subscript (target));
-      if (sym->assoc->variable && !to_var)
-	{
-	  if (target->expr_type == EXPR_VARIABLE)
-	    gfc_error ("'%s' at %L associated to vector-indexed target can not"
-		       " be used in a variable definition context",
-		       sym->name, &sym->declared_at);
-	  else
-	    gfc_error ("'%s' at %L associated to expression can not"
-		       " be used in a variable definition context",
-		       sym->name, &sym->declared_at);
-
-	  return;
-	}
-      sym->assoc->variable = to_var;
-
-      /* Finally resolve if this is an array or not.  */
-      if (sym->attr.dimension && target->rank == 0)
-	{
-	  gfc_error ("Associate-name '%s' at %L is used as array",
-		     sym->name, &sym->declared_at);
-	  sym->attr.dimension = 0;
-	  return;
-	}
-      if (target->rank > 0)
-	sym->attr.dimension = 1;
-
-      if (sym->attr.dimension)
-	{
-	  sym->as = gfc_get_array_spec ();
-	  sym->as->rank = target->rank;
-	  sym->as->type = AS_DEFERRED;
-
-	  /* Target must not be coindexed, thus the associate-variable
-	     has no corank.  */
-	  sym->as->corank = 0;
-	}
-    }
+    resolve_assoc_var (sym, true);
 
   /* Assign default type to symbols that need one and don't have one.  */
   if (sym->ts.type == BT_UNKNOWN)

gcc/fortran/trans-decl.c

@@ -1218,7 +1218,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
     }
 
   /* Remember this variable for allocation/cleanup.  */
-  if (sym->attr.dimension || sym->attr.allocatable || sym->assoc
+  if (sym->attr.dimension || sym->attr.allocatable
       || (sym->ts.type == BT_CLASS &&
 	  (CLASS_DATA (sym)->attr.dimension
 	   || CLASS_DATA (sym)->attr.allocatable))
@@ -4869,13 +4869,22 @@ gfc_generate_block_data (gfc_namespace * ns)
 /* Process the local variables of a BLOCK construct.  */
 
 void
-gfc_process_block_locals (gfc_namespace* ns)
+gfc_process_block_locals (gfc_namespace* ns, gfc_association_list* assoc)
 {
   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)
     {

gcc/fortran/trans-stmt.c

@@ -860,7 +860,7 @@ gfc_trans_block_construct (gfc_code* code)
   gcc_assert (!sym->tlink);
   sym->tlink = sym;
 
-  gfc_process_block_locals (ns);
+  gfc_process_block_locals (ns, code->ext.block.assoc);
 
   gfc_start_wrapped_block (&body, gfc_trans_code (ns->code));
   gfc_trans_deferred_vars (sym, &body);

gcc/fortran/trans.h

@@ -538,7 +538,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*);
+void gfc_process_block_locals (gfc_namespace*, gfc_association_list*);
 
 /* Output initialization/clean-up code that was deferred.  */
 void gfc_trans_deferred_vars (gfc_symbol*, gfc_wrapped_block *);

gcc/testsuite/ChangeLog

+2010-08-26  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/38936
+	PR fortran/44047
+	PR fortran/45384
+	* gfortran.dg/associate_8.f03: New test.
+	* gfortran.dg/select_type_13.f03: New test.
+	* gfortran.dg/select_type_14.f03: New test.
+
 2010-08-26  Jakub Jelinek  <jakub@redhat.com>
 
 	PR tree-optimization/44485

gcc/testsuite/gfortran.dg/associate_8.f03

+! { dg-do run}
+! { dg-options "-std=f2003 -fall-intrinsics" }
+
+! PR fortran/38936
+! Check associate to polymorphic entities.
+
+! Contributed by Tobias Burnus, burnus@gcc.gnu.org.
+
+type t
+end type t
+
+type, extends(t) :: t2
+end type t2
+
+class(t), allocatable :: a, b
+allocate( t :: a)
+allocate( t2 :: b)
+
+associate ( one => a, two => b)
+  select type(two)
+    type is (t)
+      call abort ()
+    type is (t2)
+      print *, 'OK', two
+    class default
+      call abort ()
+  end select
+  select type(one)
+    type is (t2)
+      call abort ()
+    type is (t)
+      print *, 'OK', one
+    class default
+      call abort ()
+  end select
+end associate
+end

gcc/testsuite/gfortran.dg/select_type_13.f03

+! { dg-do run }
+
+! PR fortran/45384
+! Double free happened, check that it works now.
+
+! Contributed by Salvatore Filippone  <salvatore.filippone@uniroma2.it>
+
+program bug20
+
+  type :: d_base_sparse_mat
+    integer :: v(10) = 0.
+  end type d_base_sparse_mat
+
+  class(d_base_sparse_mat),allocatable :: a
+
+  allocate (d_base_sparse_mat :: a)
+
+  select type(aa => a)
+  type is (d_base_sparse_mat)
+    write(0,*) 'NV = ',size(aa%v)
+    if (size(aa%v) /= 10) call abort ()
+  class default 
+    write(0,*) 'Not implemented yet '
+  end select
+
+end program bug20

gcc/testsuite/gfortran.dg/select_type_14.f03

+! { dg-do run }
+
+! PR fortran/44047
+! Double free happened, check that it works now.
+
+! Contributed by Janus Weil, janus@gcc.gnu.org.
+
+implicit none
+type t0
+ integer :: j = 42
+end type t0
+type t
+ integer :: i
+ class(t0), allocatable :: foo
+end type t
+type(t) :: m
+allocate(t0 :: m%foo)
+m%i = 5
+select type(bar => m%foo)
+type is(t0)
+ print *, bar
+ if (bar%j /= 42) call abort ()
+end select
+end