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

	PR fortran/38936
	* gfortran.h (struct gfc_association_list): New member `where'.
	(gfc_is_associate_pointer) New method.
	* match.c (gfc_match_associate): Remember locus for each associate
	name matched and do not try to set variable flag.
	* parse.c (parse_associate): Use remembered locus for symbols.
	* primary.c (match_variable): Instead of variable-flag check for
	associate names set it for all such names used.
	* symbol.c (gfc_is_associate_pointer): New method.
	* resolve.c (resolve_block_construct): Don't generate assignments
	to give associate-names their values.
	(resolve_fl_var_and_proc): Allow associate-names to be deferred-shape.
	(resolve_symbol): Set some more attributes for associate variables,
	set variable flag here and check it and don't try to build an
	explicitely shaped array-spec for array associate variables.
	* trans-expr.c (gfc_conv_variable): Dereference in case of association
	to scalar variable.
	* trans-types.c (gfc_is_nodesc_array): Handle array association symbols.
	(gfc_sym_type): Return pointer type for association to scalar vars.
	* trans-decl.c (gfc_get_symbol_decl): Defer association symbols.
	(trans_associate_var): New method.
	(gfc_trans_deferred_vars): Handle association symbols.

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

	PR fortran/38936
	* gfortran.dg/associate_1.f03: Extended to test newly supported
	features like association to variables.
	* gfortran.dg/associate_3.f03: Removed check for illegal change
	of associate-name here...
	* gfortran.dg/associate_5.f03: ...and added it here.
	* gfortran.dg/associate_6.f03: No longer XFAIL'ed.
	* gfortran.dg/associate_7.f03: New test.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@163295 138bc75d-0d04-0410-961f-82ee72b054a4

16 files changed, 346 insertions, 110 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a0b5c2421b9..77560d10ae4 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,28 @@
+2010-08-17  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/38936
+	* gfortran.h (struct gfc_association_list): New member `where'.
+	(gfc_is_associate_pointer) New method.
+	* match.c (gfc_match_associate): Remember locus for each associate
+	name matched and do not try to set variable flag.
+	* parse.c (parse_associate): Use remembered locus for symbols.
+	* primary.c (match_variable): Instead of variable-flag check for
+	associate names set it for all such names used.
+	* symbol.c (gfc_is_associate_pointer): New method.
+	* resolve.c (resolve_block_construct): Don't generate assignments
+	to give associate-names their values.
+	(resolve_fl_var_and_proc): Allow associate-names to be deferred-shape.
+	(resolve_symbol): Set some more attributes for associate variables,
+	set variable flag here and check it and don't try to build an
+	explicitely shaped array-spec for array associate variables.
+	* trans-expr.c (gfc_conv_variable): Dereference in case of association
+	to scalar variable.
+	* trans-types.c (gfc_is_nodesc_array): Handle array association symbols.
+	(gfc_sym_type): Return pointer type for association to scalar vars.
+	* trans-decl.c (gfc_get_symbol_decl): Defer association symbols.
+	(trans_associate_var): New method.
+	(gfc_trans_deferred_vars): Handle association symbols.
+
 2010-08-16  Joseph Myers  <joseph@codesourcery.com>
 
 	* lang.opt (MDX): Change back to MD.  Mark NoDriverArg instead of
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index dbaf9c3a8c8..c9634d3ee91 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2007,6 +2007,8 @@ typedef struct gfc_association_list
 
   char name[GFC_MAX_SYMBOL_LEN + 1];
   gfc_symtree *st; /* Symtree corresponding to name.  */
+  locus where;
+
   gfc_expr *target;
 }
 gfc_association_list;
@@ -2579,6 +2581,8 @@ void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too  */
 gfc_try gfc_check_symbol_typed (gfc_symbol*, gfc_namespace*, bool, locus);
 gfc_namespace* gfc_find_proc_namespace (gfc_namespace*);
 
+bool gfc_is_associate_pointer (gfc_symbol*);
+
 /* intrinsic.c -- true if working in an init-expr, false otherwise.  */
 extern bool gfc_init_expr_flag;
 
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index a37a6798a84..c1cef962248 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1827,6 +1827,7 @@ gfc_match_associate (void)
 	  gfc_error ("Expected association at %C");
 	  goto assocListError;
 	}
+      newAssoc->where = gfc_current_locus;
 
       /* Check that the current name is not yet in the list.  */
       for (a = new_st.ext.block.assoc; a; a = a->next)
@@ -1844,10 +1845,11 @@ gfc_match_associate (void)
 	  goto assocListError;
 	}
 
-      /* The target is a variable (and may be used as lvalue) if it's an
-	 EXPR_VARIABLE and does not have vector-subscripts.  */
-      newAssoc->variable = (newAssoc->target->expr_type == EXPR_VARIABLE
-			    && !gfc_has_vector_subscript (newAssoc->target));
+      /* The `variable' field is left blank for now; because the target is not
+	 yet resolved, we can't use gfc_has_vector_subscript to determine it
+	 for now.  Instead, if the symbol is matched as variable, this field
+	 is set -- and during resolution we check that.  */
+      newAssoc->variable = 0;
 
       /* Put it into the list.  */
       newAssoc->next = new_st.ext.block.assoc;
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 72a82c7649d..cbb945aa9a5 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -3215,23 +3215,21 @@ parse_associate (void)
   new_st.ext.block.ns = my_ns;
   gcc_assert (new_st.ext.block.assoc);
 
-  /* Add all associate-names as BLOCK variables.  There values will be assigned
-     to them during resolution of the ASSOCIATE construct.  */
+  /* Add all associate-names as BLOCK variables.  Creating them is enough
+     for now, they'll get their values during trans-* phase.  */
   gfc_current_ns = my_ns;
   for (a = new_st.ext.block.assoc; a; a = a->next)
     {
-      if (a->variable)
-	{
-	  gfc_error ("Association to variables is not yet supported at %C");
-	  return;
-	}
+      gfc_symbol* sym;
 
       if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
 	gcc_unreachable ();
 
-      a->st->n.sym->attr.flavor = FL_VARIABLE;
-      a->st->n.sym->assoc = a;
-      gfc_set_sym_referenced (a->st->n.sym);
+      sym = a->st->n.sym;
+      sym->attr.flavor = FL_VARIABLE;
+      sym->assoc = a;
+      sym->declared_at = a->where;
+      gfc_set_sym_referenced (sym);
     }
 
   accept_statement (ST_ASSOCIATE);
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 077704650b5..8b5bc148c2a 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2982,12 +2982,8 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
 	  gfc_error ("Assigning to PROTECTED variable at %C");
 	  return MATCH_ERROR;
 	}
-      if (sym->assoc && !sym->assoc->variable)
-	{
-	  gfc_error ("'%s' associated to expression can't appear in a variable"
-		     " definition context at %C", sym->name);
-	  return MATCH_ERROR;
-	}
+      if (sym->assoc)
+	sym->assoc->variable = 1;
       break;
 
     case FL_UNKNOWN:
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index dc9ce514118..d6da043dcfb 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8295,39 +8295,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.  Here, we have to add code
-     to assign expression values to the variables associated to expressions.  */
-  if (code->ext.block.assoc)
-    {
-      gfc_association_list* a;     
-      gfc_code* assignTail;
-      gfc_code* assignHead;
-
-      assignHead = assignTail = NULL;
-      for (a = code->ext.block.assoc; a; a = a->next)
-	if (!a->variable)
-	  {
-	    gfc_code* newAssign;
-
-	    newAssign = gfc_get_code ();
-	    newAssign->op = EXEC_ASSIGN;
-	    newAssign->loc = gfc_current_locus;
-	    newAssign->expr1 = gfc_lval_expr_from_sym (a->st->n.sym);
-	    newAssign->expr2 = a->target;
-
-	    if (!assignHead)
-	      assignHead = newAssign;
-	    else
-	      {
-		gcc_assert (assignTail);
-		assignTail->next = newAssign;
-	      }
-	    assignTail = newAssign;
-	  }
-
-      assignTail->next = code->ext.block.ns->code;
-      code->ext.block.ns->code = assignHead;
-    }
+     resolved during gfc_resolve_symbol.  */
 }
 
 
@@ -9523,12 +9491,11 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
 		     sym->name, &sym->declared_at);
 	  return FAILURE;
 	}
-
     }
   else
     {
       if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
-	  && !sym->attr.dummy && sym->ts.type != BT_CLASS)
+	  && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc)
 	{
 	  gfc_error ("Array '%s' at %L cannot have a deferred shape",
 		     sym->name, &sym->declared_at);
@@ -11692,59 +11659,70 @@ resolve_symbol (gfc_symbol *sym)
      they get their type-spec set this way.  */
   if (sym->assoc)
     {
+      gfc_expr* target;
+      bool to_var;
+
       gcc_assert (sym->attr.flavor == FL_VARIABLE);
-      if (gfc_resolve_expr (sym->assoc->target) != SUCCESS)
+
+      target = sym->assoc->target;
+      if (gfc_resolve_expr (target) != SUCCESS)
 	return;
 
-      sym->ts = sym->assoc->target->ts;
+      /* 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);
 
-      if (sym->attr.dimension && sym->assoc->target->rank == 0)
+      /* 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 (sym->assoc->target->rank > 0)
+      if (target->rank > 0)
 	sym->attr.dimension = 1;
 
       if (sym->attr.dimension)
 	{
-	  int dim;
-
 	  sym->as = gfc_get_array_spec ();
-	  sym->as->rank = sym->assoc->target->rank;
-	  sym->as->type = AS_EXPLICIT;
+	  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;
-
-	  for (dim = 0; dim < sym->assoc->target->rank; ++dim)
-	    {
-	      gfc_expr* dim_expr;
-	      gfc_expr* e;
-
-	      dim_expr = gfc_get_constant_expr (BT_INTEGER,
-						gfc_default_integer_kind,
-						&sym->declared_at);
-	      mpz_set_si (dim_expr->value.integer, dim + 1);
-
-	      e = gfc_build_intrinsic_call ("lbound", sym->declared_at, 3,
-					    gfc_copy_expr (sym->assoc->target),
-					    gfc_copy_expr (dim_expr), NULL);
-	      gfc_resolve_expr (e);
-	      sym->as->lower[dim] = e;
-
-	      e = gfc_build_intrinsic_call ("ubound", sym->declared_at, 3,
-					    gfc_copy_expr (sym->assoc->target),
-					    gfc_copy_expr (dim_expr), NULL);
-	      gfc_resolve_expr (e);
-	      sym->as->upper[dim] = e;
-
-	      gfc_free_expr (dim_expr);
-	    }
 	}
     }
 
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 009f1b6a2c9..0199ac42144 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -4758,3 +4758,23 @@ gfc_find_proc_namespace (gfc_namespace* ns)
 
   return ns;
 }
+
+
+/* Check if an associate-variable should be translated as an `implicit' pointer
+   internally (if it is associated to a variable and not an array with
+   descriptor).  */
+
+bool
+gfc_is_associate_pointer (gfc_symbol* sym)
+{
+  if (!sym->assoc)
+    return false;
+
+  if (!sym->assoc->variable)
+    return false;
+
+  if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)
+    return false;
+
+  return true;
+}
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index a44b4a19407..4fb0251054d 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1206,7 +1206,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
     }
 
   /* Remember this variable for allocation/cleanup.  */
-  if (sym->attr.dimension || sym->attr.allocatable
+  if (sym->attr.dimension || sym->attr.allocatable || sym->assoc
       || (sym->ts.type == BT_CLASS &&
 	  (CLASS_DATA (sym)->attr.dimension
 	   || CLASS_DATA (sym)->attr.allocatable))
@@ -3095,12 +3095,125 @@ 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)
+	{
+	  tree offs;
+	  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 all the time.
+	     The offset has to be corrected as well.
+	     Because the ubound shift and offset depends on the lower bounds, we
+	     first calculate those and set the lbound to one last.  */
+
+	  offs = gfc_conv_descriptor_offset_get (desc);
+	  for (dim = 0; dim < e->rank; ++dim)
+	    {
+	      tree from, to;
+	      tree stride;
+
+	      from = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
+	      to = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
+	      stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
+
+	      tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+				 gfc_index_one_node, from);
+	      to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
+
+	      tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, stride);
+	      offs = fold_build2 (MINUS_EXPR, gfc_array_index_type, offs, tmp);
+
+	      gfc_conv_descriptor_ubound_set (&se.pre, desc,
+					      gfc_rank_cst[dim], to);
+	    }
+	  gfc_conv_descriptor_offset_set (&se.pre, desc, offs);
+
+	  for (dim = 0; dim < e->rank; ++dim)
+	    gfc_conv_descriptor_lbound_set (&se.pre, desc, gfc_rank_cst[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.
     Allocation of character string variables.
     Initialization and possibly repacking of dummy arrays.
     Initialization of ASSIGN statement auxiliary variable.
+    Initialization of ASSOCIATE names.
     Automatic deallocation.  */
 
 void
@@ -3159,7 +3272,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->attr.dimension)
+      if (sym->assoc)
+	trans_associate_var (sym, block);
+      else if (sym->attr.dimension)
 	{
 	  switch (sym->as->type)
 	    {
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 98000a1cfbb..4465832d847 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -672,9 +672,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 	    se->expr = build_fold_indirect_ref_loc (input_location,
 						se->expr);
 
-          /* Dereference non-character pointer variables. 
+	  /* Dereference non-character pointer variables. 
 	     These must be dummies, results, or scalars.  */
-	  if ((sym->attr.pointer || sym->attr.allocatable)
+	  if ((sym->attr.pointer || sym->attr.allocatable
+	       || gfc_is_associate_pointer (sym))
 	      && (sym->attr.dummy
 		  || sym->attr.function
 		  || sym->attr.result
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index b532788365a..892a73ebd80 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1183,13 +1183,13 @@ gfc_is_nodesc_array (gfc_symbol * sym)
   if (sym->attr.pointer || sym->attr.allocatable)
     return 0;
 
+  /* We want a descriptor for associate-name arrays that do not have an
+     explicitely known shape already.  */
+  if (sym->assoc && sym->as->type != AS_EXPLICIT)
+    return 0;
+
   if (sym->attr.dummy)
-    {
-      if (sym->as->type != AS_ASSUMED_SHAPE)
-        return 1;
-      else
-        return 0;
-    }
+    return sym->as->type != AS_ASSUMED_SHAPE;
 
   if (sym->attr.result || sym->attr.function)
     return 0;
@@ -1798,7 +1798,8 @@ gfc_sym_type (gfc_symbol * sym)
     }
   else
     {
-      if (sym->attr.allocatable || sym->attr.pointer)
+      if (sym->attr.allocatable || sym->attr.pointer
+	  || gfc_is_associate_pointer (sym))
 	type = gfc_build_pointer_type (sym, type);
       if (sym->attr.pointer || sym->attr.cray_pointee)
 	GFC_POINTER_TYPE_P (type) = 1;
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c42c1b2d5b7..760b5f1259f 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,14 @@
+2010-08-17  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/38936
+	* gfortran.dg/associate_1.f03: Extended to test newly supported
+	features like association to variables.
+	* gfortran.dg/associate_3.f03: Removed check for illegal change
+	of associate-name here...
+	* gfortran.dg/associate_5.f03: ...and added it here.
+	* gfortran.dg/associate_6.f03: No longer XFAIL'ed.
+	* gfortran.dg/associate_7.f03: New test.
+
 2010-08-15  Kaz Kojima  <kkojima@gcc.gnu.org>
 
 	* gcc.dg/tree-ssa/pr42585.c: Skip dump scan on sh.
diff --git a/gcc/testsuite/gfortran.dg/associate_1.f03 b/gcc/testsuite/gfortran.dg/associate_1.f03
index 0b3081b241b..4cb727f0b5a 100644
--- a/gcc/testsuite/gfortran.dg/associate_1.f03
+++ b/gcc/testsuite/gfortran.dg/associate_1.f03
@@ -1,5 +1,5 @@
 ! { dg-do run }
-! { dg-options "-std=f2003 -fall-intrinsics" }
+! { dg-options "-std=f2003 -fall-intrinsics -cpp" }
 
 ! PR fortran/38936
 ! Check the basic semantics of the ASSOCIATE construct.
@@ -8,6 +8,13 @@ PROGRAM main
   IMPLICIT NONE
   REAL :: a, b, c
   INTEGER, ALLOCATABLE :: arr(:)
+  INTEGER :: mat(3, 3)
+
+  TYPE :: myt
+    INTEGER :: comp
+  END TYPE myt
+
+  TYPE(myt) :: tp
 
   a = -2.0
   b = 3.0
@@ -20,9 +27,6 @@ PROGRAM main
     IF (ABS (t - a - b) > 1.0e-3) CALL abort ()
   END ASSOCIATE
 
-  ! TODO: Test association to variables when that is supported.
-  ! TODO: Test association to derived types.
-
   ! Test association to arrays.
   ALLOCATE (arr(3))
   arr = (/ 1, 2, 3 /)
@@ -34,6 +38,12 @@ PROGRAM main
     IF (ANY (xyz /= (/ 1, 3, 5 /))) CALL abort ()
   END ASSOCIATE
 
+  ! Target is vector-indexed.
+  ASSOCIATE (foo => arr((/ 3, 1 /)))
+    IF (LBOUND (foo, 1) /= 1 .OR. UBOUND (foo, 1) /= 2) CALL abort ()
+    IF (foo(1) /= 3 .OR. foo(2) /= 1) CALL abort ()
+  END ASSOCIATE
+
   ! Named and nested associate.
   myname: ASSOCIATE (x => a - b * c)
     ASSOCIATE (y => 2.0 * x)
@@ -49,6 +59,33 @@ PROGRAM main
     END ASSOCIATE
   END ASSOCIATE
 
+  ! Association to variables.
+  mat = 0
+  mat(2, 2) = 5;
+  ASSOCIATE (x => arr(2), y => mat(2:3, 1:2))
+    IF (x /= 2) CALL abort ()
+    IF (ANY (LBOUND (y) /= (/ 1, 1 /) .OR. UBOUND (y) /= (/ 2, 2 /))) &
+      CALL abort ()
+    IF (y(1, 2) /= 5) CALL abort ()
+
+    x = 7
+    y = 8
+  END ASSOCIATE
+  IF (arr(2) /= 7 .OR. ANY (mat(2:3, 1:2) /= 8)) CALL abort ()
+
+  ! Association to derived type and component.
+  tp = myt (1)
+  ASSOCIATE (x => tp, y => tp%comp)
+    ! FIXME: Parsing of derived-type associate names, tests with x.
+    IF (y /= 1) CALL abort ()
+    y = 5
+  END ASSOCIATE
+  IF (tp%comp /= 5) CALL abort ()
+
+  ! Association to character variables.
+  ! FIXME: Enable character test, once this works.
+  !CALL test_char (5)
+
 CONTAINS
 
   FUNCTION func ()
@@ -56,4 +93,21 @@ CONTAINS
     func = (/ 1, 3, 5 /)
   END FUNCTION func
 
+#if 0
+  ! Test association to character variable with automatic length.
+  SUBROUTINE test_char (n)
+    INTEGER, INTENT(IN) :: n
+
+    CHARACTER(LEN=n) :: str
+
+    str = "foobar"
+    ASSOCIATE (my => str)
+      IF (LEN (my) /= n) CALL abort ()
+      IF (my /= "fooba") CALL abort ()
+      my = "abcdef"
+    END ASSOCIATE
+    IF (str /= "abcde") CALL abort ()
+  END SUBROUTINE test_char
+#endif
+
 END PROGRAM main
diff --git a/gcc/testsuite/gfortran.dg/associate_3.f03 b/gcc/testsuite/gfortran.dg/associate_3.f03
index f8a49052a1a..20a375dcfd1 100644
--- a/gcc/testsuite/gfortran.dg/associate_3.f03
+++ b/gcc/testsuite/gfortran.dg/associate_3.f03
@@ -31,10 +31,6 @@ PROGRAM main
   ASSOCIATE (a => 1, b => 2, a => 3) ! { dg-error "Duplicate name 'a'" }
 
   ASSOCIATE (a => 5)
-    a = 4 ! { dg-error "variable definition context" }
-  ENd ASSOCIATE
-
-  ASSOCIATE (a => 5)
     INTEGER :: b ! { dg-error "Unexpected data declaration statement" }
   END ASSOCIATE
 END PROGRAM main ! { dg-error "Expecting END ASSOCIATE" }
diff --git a/gcc/testsuite/gfortran.dg/associate_5.f03 b/gcc/testsuite/gfortran.dg/associate_5.f03
index ca62f944545..31cc144d5a9 100644
--- a/gcc/testsuite/gfortran.dg/associate_5.f03
+++ b/gcc/testsuite/gfortran.dg/associate_5.f03
@@ -6,8 +6,21 @@
 
 PROGRAM main
   IMPLICIT NONE
+  INTEGER :: nontarget
+  INTEGER :: arr(3)
+  INTEGER, POINTER :: ptr
 
   ASSOCIATE (a => 5) ! { dg-error "is used as array" }
     PRINT *, a(3)
   END ASSOCIATE
+
+  ASSOCIATE (a => nontarget)
+    ptr => a ! { dg-error "neither TARGET nor POINTER" }
+  END ASSOCIATE
+
+  ASSOCIATE (a => 5, & ! { dg-error "variable definition context" }
+             b => arr((/ 1, 3 /))) ! { dg-error "variable definition context" }
+    a = 4
+    b = 7
+  END ASSOCIATE
 END PROGRAM main
diff --git a/gcc/testsuite/gfortran.dg/associate_6.f03 b/gcc/testsuite/gfortran.dg/associate_6.f03
index bf30fa3f7cb..ba0e5c09809 100644
--- a/gcc/testsuite/gfortran.dg/associate_6.f03
+++ b/gcc/testsuite/gfortran.dg/associate_6.f03
@@ -7,8 +7,6 @@
 
 ! Contributed by Daniel Kraft, d@domob.eu.
 
-! FIXME: XFAIL'ed because this is not yet implemented 'correctly'.
-
 MODULE m
   IMPLICIT NONE
 
@@ -31,8 +29,11 @@ PROGRAM main
 
   ASSOCIATE (arr => func (4))
     ! func should only be called once here, not again for the bounds!
+
+    IF (LBOUND (arr, 1) /= 1 .OR. UBOUND (arr, 1) /= 4) CALL abort ()
+    IF (arr(1) /= 1 .OR. arr(4) /= 4) CALL abort ()
   END ASSOCIATE
 END PROGRAM main
 ! { dg-final { cleanup-modules "m" } }
-! { dg-final { scan-tree-dump-times "func" 2 "original" { xfail *-*-* } } }
+! { dg-final { scan-tree-dump-times "func" 2 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/associate_7.f03 b/gcc/testsuite/gfortran.dg/associate_7.f03
new file mode 100644
index 00000000000..6fd3f343d00
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_7.f03
@@ -0,0 +1,21 @@
+! { dg-do run }
+! { dg-options "-std=f2003 -fall-intrinsics" }
+
+! PR fortran/38936
+! Check association and pointers.
+
+! Contributed by Daniel Kraft, d@domob.eu.
+
+PROGRAM main
+  IMPLICIT NONE
+  INTEGER, TARGET :: tgt
+  INTEGER, POINTER :: ptr
+
+  tgt = 1
+  ASSOCIATE (x => tgt)
+    ptr => x
+    IF (ptr /= 1) CALL abort ()
+    ptr = 2
+  END ASSOCIATE
+  IF (tgt /= 2) CALL abort ()
+END PROGRAM main