Patchwork [Fortran] SELECT TYPE via ASSOCIATE

login
register
mail settings
Submitter Daniel Kraft
Date Aug. 26, 2010, 9:12 a.m.
Message ID <4C762FED.7020609@domob.eu>
Download mbox | patch
Permalink /patch/62762/
State New
Headers show

Comments

Daniel Kraft - Aug. 26, 2010, 9:12 a.m.
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?

Yours,
Daniel
Janus Weil - Aug. 26, 2010, 2:46 p.m.
Hi Daniel,

> the attached patch fixes ASSOCIATE for polymorphic values and switches the
> current implementation of SELECT TYPE to using ASSOCIATE internally.

thanks for working on this. I only had a glance at your patch, but
what I've seen looks good so far. Just some comments ...


> As a side-effect, this fixes the "double-free" PRs 44047 and 45384.

Ok. You told me before that you don't do anything special to prevent
these double free issues with ASSOCIATE. Can you explain to me how
your patch actually fixes these? I'd just like to understand it.


One difference I observed in the dump of PR 45384 (comment #3) is that
the old version had:

        struct class$d_base_sparse_mat_a aa;

while with your patch one gets:

        struct class$d_base_sparse_mat_a * aa;

I.e. one now has a pointer to a class container. This is a thing we
usually don't have in the OOP implementation, not even for

class(...), pointer :: x

since the pointer attribute is propagated to the $data component of
the class container, and the container itself always appears as
non-pointer. Therefore I think it might be better to stick with the
old non-pointer declaration. However, the pointer might just be the
reason that auto-deallocation does not happen. Right?


> 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).

Yes, can be done later.


> 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?

Pretty much ok from my side, except for the points mentioned above.

Btw, for select_type_13.f03 you might wanna give credit to Salvatore
instead of me, since it's basically his test case (and he puts a lot
of effort into testing gfortran, so he very much deserved to be
mentioned).

Cheers,
Janus



> 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.
>        * symbol.c (gfc_free_symbol): Free a dangling association-list.
>        * 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.
Daniel Kraft - Aug. 26, 2010, 3:10 p.m.
Hi Janus,

thanks for your review / comments!

Janus Weil wrote:
> Hi Daniel,
> 
>> the attached patch fixes ASSOCIATE for polymorphic values and switches the
>> current implementation of SELECT TYPE to using ASSOCIATE internally.
> 
> thanks for working on this. I only had a glance at your patch, but
> what I've seen looks good so far. Just some comments ...
> 
> 
>> As a side-effect, this fixes the "double-free" PRs 44047 and 45384.
> 
> Ok. You told me before that you don't do anything special to prevent
> these double free issues with ASSOCIATE. Can you explain to me how
> your patch actually fixes these? I'd just like to understand it.

Honestly, I don't have a really good explanation -- for one, I do not 
even understand why there were two free's in your old case.  As I saw 
it, what you did was basically to build a POINTER variable and point it 
to the result in the front-end.  Why was it auto-deallocated (being a 
POINTER!)?

But I think the main difference now is that ASSOCIATE is handled in the 
trans-* phase.  Thus I have complete control over the initialization and 
clean-up code (see trans_assoc_var or what it is called in trans-decl.c) 
instead of building something up in the front-end and "hoping" that 
trans-* does what I we want it to do.

> One difference I observed in the dump of PR 45384 (comment #3) is that
> the old version had:
> 
>         struct class$d_base_sparse_mat_a aa;
> 
> while with your patch one gets:
> 
>         struct class$d_base_sparse_mat_a * aa;
> 
> I.e. one now has a pointer to a class container. This is a thing we
> usually don't have in the OOP implementation, not even for
> 
> class(...), pointer :: x
> 
> since the pointer attribute is propagated to the $data component of
> the class container, and the container itself always appears as
> non-pointer. Therefore I think it might be better to stick with the
> old non-pointer declaration. However, the pointer might just be the
> reason that auto-deallocation does not happen. Right?

This is also a consequence of my ASSOCIATE implementation in the 
backend.  I.e., associate-names are not POINTERs assigned to the target, 
but instead they are smoething "special" and trans-* takes care of them 
-- building a real pointer to whatever the object in question is (for 
scalar quantities; for arrays, a new descriptor is built and assigned to).

You surely know gfortran's OOP much better than I do, so I leave it to 
you to decide whether this is ok or not (it did not fail for any of my 
tests so far).  If the latter, we should probably implement something 
similar to arrays and create a new class-container in the backend linked 
to the target (or something like that).

As I wrote above, the big difference is that ASSOCIATE is done directly 
in trans (because I think it could not be done reliably for stuff like 
arrays in the front-end); this somehow fixes the double-free problem. 
I'd like to stick with the current implementation (real pointer to 
class-container rather than the _p struct) if this is possible without 
really breaking anything (because this is the "natural" implementation 
that works without further special cases), but if you have a good reason 
why this is not correct for CLASS, I'll add special handling to the 
ASSOCIATE code.

>> 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?
> 
> Pretty much ok from my side, except for the points mentioned above.

So I'm waiting on your impression of my answers above ;)

> Btw, for select_type_13.f03 you might wanna give credit to Salvatore
> instead of me, since it's basically his test case (and he puts a lot
> of effort into testing gfortran, so he very much deserved to be
> mentioned).

Ok, I'll switch this ;)  We could of course also use his original 
test-case from the PR, but I think the reduced one is better suited for 
the test-suite.

Yours,
Daniel
Janus Weil - Aug. 26, 2010, 7:36 p.m.
>>> As a side-effect, this fixes the "double-free" PRs 44047 and 45384.
>>
>> Ok. You told me before that you don't do anything special to prevent
>> these double free issues with ASSOCIATE. Can you explain to me how
>> your patch actually fixes these? I'd just like to understand it.
>
> Honestly, I don't have a really good explanation -- for one, I do not even
> understand why there were two free's in your old case.  As I saw it, what
> you did was basically to build a POINTER variable and point it to the result
> in the front-end.  Why was it auto-deallocated (being a POINTER!)?

The double-free issue that Salvatore observed (i.e. PR 45384) involves
allocatable components - those were auto-deallocated although they
shouldn't. In the other case (PR 44047) the selector itself was
allocatable - and also the temporary we used for the associate-name.


>> One difference I observed in the dump of PR 45384 (comment #3) is that
>> the old version had:
>>
>>        struct class$d_base_sparse_mat_a aa;
>>
>> while with your patch one gets:
>>
>>        struct class$d_base_sparse_mat_a * aa;
>>
>> I.e. one now has a pointer to a class container. This is a thing we
>> usually don't have in the OOP implementation, not even for
>>
>> class(...), pointer :: x
>>
>> since the pointer attribute is propagated to the $data component of
>> the class container, and the container itself always appears as
>> non-pointer. Therefore I think it might be better to stick with the
>> old non-pointer declaration. However, the pointer might just be the
>> reason that auto-deallocation does not happen. Right?
>
> This is also a consequence of my ASSOCIATE implementation in the backend.
>  I.e., associate-names are not POINTERs assigned to the target, but instead
> they are smoething "special" and trans-* takes care of them -- building a
> real pointer to whatever the object in question is (for scalar quantities;
> for arrays, a new descriptor is built and assigned to).
>
> You surely know gfortran's OOP much better than I do, so I leave it to you
> to decide whether this is ok or not (it did not fail for any of my tests so
> far).  If the latter, we should probably implement something similar to
> arrays and create a new class-container in the backend linked to the target
> (or something like that).
>
> As I wrote above, the big difference is that ASSOCIATE is done directly in
> trans (because I think it could not be done reliably for stuff like arrays
> in the front-end); this somehow fixes the double-free problem. I'd like to
> stick with the current implementation (real pointer to class-container
> rather than the _p struct) if this is possible without really breaking
> anything (because this is the "natural" implementation that works without
> further special cases), but if you have a good reason why this is not
> correct for CLASS, I'll add special handling to the ASSOCIATE code.

No, I guess it's fine. I just hope it will not introduce any unforeseen trouble.


>>> 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?
>>
>> Pretty much ok from my side, except for the points mentioned above.
>
> So I'm waiting on your impression of my answers above ;)
>
>> Btw, for select_type_13.f03 you might wanna give credit to Salvatore
>> instead of me, since it's basically his test case (and he puts a lot
>> of effort into testing gfortran, so he very much deserved to be
>> mentioned).
>
> Ok, I'll switch this ;)  We could of course also use his original test-case
> from the PR, but I think the reduced one is better suited for the
> test-suite.

Yes, using the reduced version is preferable.

The patch is ok to commit from my side.

Cheers,
Janus
Daniel Kraft - Aug. 26, 2010, 7:56 p.m.
Janus Weil wrote:
>>>> 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?
>>> Pretty much ok from my side, except for the points mentioned above.
>> So I'm waiting on your impression of my answers above ;)
>>
>>> Btw, for select_type_13.f03 you might wanna give credit to Salvatore
>>> instead of me, since it's basically his test case (and he puts a lot
>>> of effort into testing gfortran, so he very much deserved to be
>>> mentioned).
>> Ok, I'll switch this ;)  We could of course also use his original test-case
>> from the PR, but I think the reduced one is better suited for the
>> test-suite.
> 
> Yes, using the reduced version is preferable.
> 
> The patch is ok to commit from my side.

Thanks, committed as rev. 163572.

As I understand it, you will look into the new issue from Salvatore? 
Then I'll continue with ASSOCIATE, maybe the variable definition context 
thing so also fixing PR 44044.

Daniel

Patch

Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 163540)
+++ gcc/fortran/symbol.c	(working copy)
@@ -2499,6 +2499,9 @@  gfc_free_symbol (gfc_symbol *sym)
 
   gfc_free_namespace (sym->f2k_derived);
 
+  if (sym->assoc && sym->assoc->dangling)
+    gfc_free_association_list (sym->assoc);
+
   gfc_free (sym);
 }
 
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/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/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/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