Re: [Patch, Fortran] SELECT TYPE via ASSOCIATE

[Daniel Kraft <d at domob dot eu>]

Daniel Kraft wrote:
> Hi,
>
> the attached patch fixes ASSOCIATE for polymorphic values and switches 
> the current implementation of SELECT TYPE to using ASSOCIATE internally. 
>  As a side-effect, this fixes the "double-free" PRs 44047 and 45384.  I 
> also think that the still missing piece (comment #3) of PR 44044 will be 
> fixed when the testing for variable definition contexts in ASSOCIATE is 
> extended (but so far the problem is still not detected).
>
> Regtested on GNU/Linux-x86-32.  The only failure was bessel_7.f90, which 
> goes away when I increase the tolerance according to
> http://gcc.gnu.org/ml/fortran/2010-08/msg00308.html.  Ok for trunk?

...and another update which seems to fix the problems finally.  This 
removes the symbol.c change, as the free can seemingly not be done 
safely.  It would only have been useful for invalid code and in special 
cases anyway, as association entries should usually not be "dangling".

Daniel

--
http://www.pro-vegan.info/
--
Done:  Arc-Bar-Cav-Kni-Ran-Rog-Sam-Tou-Val-Wiz
To go: Hea-Mon-Pri

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.

Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 163540)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -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 
 /* 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 *);
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c	(revision 163540)
+++ gcc/fortran/trans-stmt.c	(working copy)
@@ -860,7 +860,7 @@ gfc_trans_block_construct (gfc_code* cod
   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);
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h	(revision 163540)
+++ gcc/fortran/trans.h	(working copy)
@@ -538,7 +538,7 @@ tree gfc_build_library_function_decl_wit
 						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 *);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 163540)
+++ gcc/fortran/resolve.c	(working copy)
@@ -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
 	}
 
       /* 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)
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(revision 163540)
+++ gcc/fortran/match.c	(working copy)
@@ -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;
 }
 
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 163540)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -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))
@@ -4831,13 +4831,22 @@ gfc_generate_block_data (gfc_namespace *
 /* 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)
     {
Index: gcc/fortran/parse.h
===================================================================
--- gcc/fortran/parse.h	(revision 163540)
+++ gcc/fortran/parse.h	(working copy)
@@ -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  */
Index: gcc/testsuite/gfortran.dg/select_type_13.f03
===================================================================
--- gcc/testsuite/gfortran.dg/select_type_13.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/select_type_13.f03	(revision 0)
@@ -0,0 +1,26 @@
+! { dg-do run }
+
+! PR fortran/45384
+! Double free happened, check that it works now.
+
+! Contributed by Janus Weil, janus@gcc.gnu.org.
+
+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
Index: gcc/testsuite/gfortran.dg/associate_8.f03
===================================================================
--- gcc/testsuite/gfortran.dg/associate_8.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/associate_8.f03	(revision 0)
@@ -0,0 +1,37 @@
+! { 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
Index: gcc/testsuite/gfortran.dg/select_type_14.f03
===================================================================
--- gcc/testsuite/gfortran.dg/select_type_14.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/select_type_14.f03	(revision 0)
@@ -0,0 +1,24 @@
+! { 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