Patchwork [Fortran] First ASSOCIATE patch and some questions / RFCs

login
register
mail settings
Submitter Daniel Kraft
Date June 8, 2010, 2:38 p.m.
Message ID <4C0E55F8.80103@domob.eu>
Download mbox | patch
Permalink /patch/54995/
State New
Headers show

Comments

Daniel Kraft - June 8, 2010, 2:38 p.m.
Hi,

here's an updated version of my patch addressing Tobias' comments. 
Namely, I changed the co-indexed check to an error message, added the 
CRITICAL back in the comment where it disappeared, removed ST_CRITICAL 
in addition to ST_BLOCK (see Tobias' last message; but I can also let 
this change out entirely if you want) and added a test for the 
"unexpected data declaration statement" in associate_3.f03.

I plan to re-regtest and commit tomorrow or Thursday, after the merge is 
settled for some time.  What's about the "variable definition context" 
thing?  I think it should be ok to just remove the XXX comment.  I can 
also change it to a FIXME / TODO, though, if we want to investigate this 
further.

Yours,
Daniel

Daniel Kraft wrote:
> Hi all,
> 
> attached is my first patch on the way of implementing the ASSOCIATE 
> construct.  See the test-cases for what it is supposed to do.  Not yet 
> working are basically two things:
> 
> 
> * Association of names to variables (currently only expressions).  I 
> think that my original idea of replacing each occurrence directly in the 
> parser with the corresponding gfc_expr does not work, because it will do 
> the wrong thing if the selector expression changes, as in these two cases:
> 
> INTEGER, POINTER :: ptr
> ptr => something
> ASSOCIATE (x => ptr)
>   ptr => something else
>   ! x should still refer to something
> END ASSOCIATE
> 
> INTEGER :: n
> REAL :: array(10)
> n = 2
> ASSOCIATE (arr => array(n : n+2)
>   n = 5
>   ! arr is still array(2 : 4)
> END ASSOCIATE
> 
> (At least if I read the standard correctly.)  So instead we need another 
> strategy; possibly using a BLOCK local pointer that it pointed to the 
> selector.
> 
> Does this provoke problems, when the selector is not TARGET or the like? 
>  But I think we're already doing something like that for SELECT TYPE at 
> the moment -- Janus, can the current implementation be used for the 
> general ASSOCIATE case, too?  Or does it only work for polymorphism?
> 
> 
> * Association to array expressions.  The problem here is that for 
> something like:
> 
> INTEGER :: array(10)
> ASSOCIATE (doubled => 2 * array)
>   PRINT *, doubled(2)
> END ASSOCIATE
> 
> During parsing, the expression "2 * array" seems not to have its rank 
> defined yet; this is only done at resolution stage.  However, when 
> parsing doubled(2), the compiler already needs to know that doubled is 
> an array!  Any ideas what we could do here?
> 
> Otherwise, I think that with the ability of BLOCK to declare 
> "dynamically sized" arrays (like VLA's in C) we can easily generate a 
> correctly shaped local variable to hold the results whenever necessary.
> 
> 
> On the other side, basic association to scalar expressions seems already 
> to work quite well.  I've still two positions marked "XXX" in the patch 
> I'd also like to get another opinion on:
> 
> First, when calling gfc_get_sym_tree to insert a symbol into the current 
> namespace, in theory this function may return a failure code.  However, 
> I'm not sure what to do in this case; especially, a grep of the source 
> shows that it is already used without checking for the return value at 
> all in different places.  So:  When may it precisely fail and what's the 
> guideline to follow here?  Is it ok to call it without check, is the 
> gcc_unreachable() check as in my patch ok, or do we have to deal and 
> correctly handle a failure?  If so, should the other places also be 
> updated to do so?
> 
> Second, is primary.c:match_variable the place that handles what the 
> standard calls a "variable definition context"?  It seems to be so, at 
> least for the basic handling.  Or is there already some other routine to 
> check that?  Do I have to implement my own to be fully correct?
> 
> 
> The patch was regression-tested on GNU/Linux-x86-32. 
> array_constructor_11.f90 failed with -O3 -g, but I don't see how this 
> could be related to my patch...  Does anyone else see this?  If so, ok 
> for trunk?
> 
> Thanks,
> Daniel
>
Tobias Burnus - June 8, 2010, 2:48 p.m.
On 06/08/2010 04:38 PM, Daniel Kraft wrote:
> here's an updated version of my patch addressing Tobias' comments.
> Namely, I changed the co-indexed check to an error message

s/co-indexed/coindexed/
to be consistent with the Fortran standard. (At some point during the
standardization, co-arrays and the other co-* terms lost their hyphen.)

> I plan to re-regtest and commit tomorrow or Thursday, after the merge
> is settled for some time. What's about the "variable definition
> context" thing?  I think it should be ok to just remove the XXX
> comment.  I can also change it to a FIXME / TODO, though, if we want
> to investigate this further.

I think it is sufficient to just remove the XXX. Thanks for the patch!

After committal, can you also update
http://gcc.gnu.org/wiki/GFortran#news and 
http://gcc.gnu.org/wiki/Fortran2003Status (No->Partial)?

Tobias
Daniel Kraft - June 10, 2010, 2:53 p.m.
Tobias Burnus wrote:
> On 06/08/2010 04:38 PM, Daniel Kraft wrote:
>> here's an updated version of my patch addressing Tobias' comments.
>> Namely, I changed the co-indexed check to an error message
> 
> s/co-indexed/coindexed/
> to be consistent with the Fortran standard. (At some point during the
> standardization, co-arrays and the other co-* terms lost their hyphen.)
 >
>> I plan to re-regtest and commit tomorrow or Thursday, after the merge
>> is settled for some time. What's about the "variable definition
>> context" thing?  I think it should be ok to just remove the XXX
>> comment.  I can also change it to a FIXME / TODO, though, if we want
>> to investigate this further.
> 
> I think it is sufficient to just remove the XXX. Thanks for the patch!

Committed with these changes and an added test-case for the coindexed 
error as rev. 160550.

> After committal, can you also update
> http://gcc.gnu.org/wiki/GFortran#news and 
> http://gcc.gnu.org/wiki/Fortran2003Status (No->Partial)?

Yes, I'll do that now.  And then work on the documentation and 
dump-parse-tree patch ;)

Yours,
Daniel

Patch

Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(revision 160337)
+++ gcc/fortran/interface.c	(working copy)
@@ -1821,8 +1821,8 @@  get_expr_storage_size (gfc_expr *e)
    which has a vector subscript. If it has, one is returned,
    otherwise zero.  */
 
-static int
-has_vector_subscript (gfc_expr *e)
+int
+gfc_has_vector_subscript (gfc_expr *e)
 {
   int i;
   gfc_ref *ref;
@@ -2134,7 +2134,7 @@  compare_actual_formal (gfc_actual_arglis
       if ((f->sym->attr.intent == INTENT_OUT
 	   || f->sym->attr.intent == INTENT_INOUT
 	   || f->sym->attr.volatile_)
-          && has_vector_subscript (a->expr))
+	  && gfc_has_vector_subscript (a->expr))
 	{
 	  if (where)
 	    gfc_error ("Array-section actual argument with vector subscripts "
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 160337)
+++ gcc/fortran/symbol.c	(working copy)
@@ -2515,6 +2515,7 @@  gfc_new_symbol (const char *name, gfc_na
   /* Clear the ptrs we may need.  */
   p->common_block = NULL;
   p->f2k_derived = NULL;
+  p->assoc = NULL;
   
   return p;
 }
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 160337)
+++ gcc/fortran/decl.c	(working copy)
@@ -5483,14 +5483,23 @@  gfc_match_end (gfc_statement *st)
   block_name = gfc_current_block () == NULL
 	     ? NULL : gfc_current_block ()->name;
 
-  if (state == COMP_BLOCK && !strcmp (block_name, "block@"))
-    block_name = NULL;
-
-  if (state == COMP_CONTAINS || state == COMP_DERIVED_CONTAINS)
+  switch (state)
     {
+    case COMP_ASSOCIATE:
+    case COMP_BLOCK:
+      if (!strcmp (block_name, "block@"))
+	block_name = NULL;
+      break;
+
+    case COMP_CONTAINS:
+    case COMP_DERIVED_CONTAINS:
       state = gfc_state_stack->previous->state;
       block_name = gfc_state_stack->previous->sym == NULL
 		 ? NULL : gfc_state_stack->previous->sym->name;
+      break;
+
+    default:
+      break;
     }
 
   switch (state)
@@ -5539,6 +5548,12 @@  gfc_match_end (gfc_statement *st)
       eos_ok = 0;
       break;
 
+    case COMP_ASSOCIATE:
+      *st = ST_END_ASSOCIATE;
+      target = " associate";
+      eos_ok = 0;
+      break;
+
     case COMP_BLOCK:
       *st = ST_END_BLOCK;
       target = " block";
@@ -5622,7 +5637,7 @@  gfc_match_end (gfc_statement *st)
 
       if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
 	  && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
-	  && *st != ST_END_CRITICAL)
+	  && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL)
 	return MATCH_YES;
 
       if (!block_name)
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 160337)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -205,11 +205,12 @@  arith;
 /* Statements.  */
 typedef enum
 {
-  ST_ARITHMETIC_IF, ST_ALLOCATE, ST_ATTR_DECL, ST_BACKSPACE,
-  ST_BLOCK, ST_BLOCK_DATA,
+  ST_ARITHMETIC_IF, ST_ALLOCATE, ST_ATTR_DECL, ST_ASSOCIATE,
+  ST_BACKSPACE, ST_BLOCK, ST_BLOCK_DATA,
   ST_CALL, ST_CASE, ST_CLOSE, ST_COMMON, ST_CONTINUE, ST_CONTAINS, ST_CYCLE,
   ST_DATA, ST_DATA_DECL, ST_DEALLOCATE, ST_DO, ST_ELSE, ST_ELSEIF,
-  ST_ELSEWHERE, ST_END_BLOCK, ST_END_BLOCK_DATA, ST_ENDDO, ST_IMPLIED_ENDDO,
+  ST_ELSEWHERE, ST_END_ASSOCIATE, ST_END_BLOCK, ST_END_BLOCK_DATA,
+  ST_ENDDO, ST_IMPLIED_ENDDO,
   ST_END_FILE, ST_FINAL, ST_FLUSH, ST_END_FORALL, ST_END_FUNCTION, ST_ENDIF,
   ST_END_INTERFACE, ST_END_MODULE, ST_END_PROGRAM, ST_END_SELECT,
   ST_END_SUBROUTINE, ST_END_WHERE, ST_END_TYPE, ST_ENTRY, ST_EQUIVALENCE,
@@ -1201,6 +1202,9 @@  typedef struct gfc_symbol
   char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
   /* Store a reference to the common_block, if this symbol is in one.  */
   struct gfc_common_head *common_block;
+
+  /* Link to corresponding association-list if this is an associate name.  */
+  struct gfc_association_list *assoc;
 }
 gfc_symbol;
 
@@ -1974,6 +1978,25 @@  typedef struct gfc_forall_iterator
 gfc_forall_iterator;
 
 
+/* Linked list to store associations in an ASSOCIATE statement.  */
+
+typedef struct gfc_association_list
+{
+  struct gfc_association_list *next; 
+
+  /* Whether this is association to a variable that can be changed; otherwise,
+     it's association to an expression and the name may not be used as
+     lvalue.  */
+  unsigned variable:1;
+
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symtree *st; /* Symtree corresponding to name.  */
+  gfc_expr *target;
+}
+gfc_association_list;
+#define gfc_get_association_list() XCNEW (gfc_association_list)
+
+
 /* Executable statements that fill gfc_code structures.  */
 typedef enum
 {
@@ -2026,6 +2049,13 @@  typedef struct gfc_code
     }
     alloc;
 
+    struct
+    {
+      gfc_namespace *ns;
+      gfc_association_list *assoc;
+    }
+    block;
+
     gfc_open *open;
     gfc_close *close;
     gfc_filepos *filepos;
@@ -2040,7 +2070,6 @@  typedef struct gfc_code
     const char *omp_name;
     gfc_namelist *omp_namelist;
     bool omp_bool;
-    gfc_namespace *ns;
   }
   ext;		/* Points to additional structures required by statement */
 
@@ -2647,6 +2676,7 @@  gfc_code *gfc_get_code (void);
 gfc_code *gfc_append_code (gfc_code *, gfc_code *);
 void gfc_free_statement (gfc_code *);
 void gfc_free_statements (gfc_code *);
+void gfc_free_association_list (gfc_association_list *);
 
 /* resolve.c */
 gfc_try gfc_resolve_expr (gfc_expr *);
@@ -2719,6 +2749,7 @@  void gfc_set_current_interface_head (gfc
 gfc_symtree* gfc_find_sym_in_symtree (gfc_symbol*);
 bool gfc_arglist_matches_symbol (gfc_actual_arglist**, gfc_symbol*);
 bool gfc_check_operator_interface (gfc_symbol*, gfc_intrinsic_op, locus);
+int gfc_has_vector_subscript (gfc_expr*);
 
 /* io.c */
 extern gfc_st_label format_asterisk;
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c	(revision 160337)
+++ gcc/fortran/trans-stmt.c	(working copy)
@@ -850,7 +850,7 @@  gfc_trans_block_construct (gfc_code* cod
   stmtblock_t body;
   tree tmp;
 
-  ns = code->ext.ns;
+  ns = code->ext.block.ns;
   gcc_assert (ns);
   sym = ns->proc_name;
   gcc_assert (sym);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 160337)
+++ gcc/fortran/resolve.c	(working copy)
@@ -7151,7 +7151,7 @@  resolve_select_type (gfc_code *code)
   gfc_namespace *ns;
   int error = 0;
 
-  ns = code->ext.ns;
+  ns = code->ext.block.ns;
   gfc_resolve (ns);
 
   /* Check for F03:C813.  */
@@ -7238,6 +7238,7 @@  resolve_select_type (gfc_code *code)
   else
     ns->code->next = new_st;
   code->op = EXEC_BLOCK;
+  code->ext.block.assoc = NULL;
   code->expr1 = code->expr2 =  NULL;
   code->block = NULL;
 
@@ -7981,10 +7982,11 @@  gfc_resolve_forall (gfc_code *code, gfc_
 static void
 resolve_block_construct (gfc_code* code)
 {
-  /* Eventually, we may want to do some checks here or handle special stuff.
-     But so far the only thing we can do is resolving the local namespace.  */
+  /* For an ASSOCIATE block, the associations (and their targets) are already
+     resolved during gfc_resolve_symbol.  */
 
-  gfc_resolve (code->ext.ns);
+  /* Resolve the BLOCK's namespace.  */
+  gfc_resolve (code->ext.block.ns);
 }
 
 
@@ -8305,7 +8307,7 @@  resolve_code (gfc_code *code, gfc_namesp
 	      gfc_resolve_omp_do_blocks (code, ns);
 	      break;
 	    case EXEC_SELECT_TYPE:
-	      gfc_current_ns = code->ext.ns;
+	      gfc_current_ns = code->ext.block.ns;
 	      gfc_resolve_blocks (code->block, gfc_current_ns);
 	      gfc_current_ns = ns;
 	      break;
@@ -8469,7 +8471,7 @@  resolve_code (gfc_code *code, gfc_namesp
 	  break;
 
 	case EXEC_BLOCK:
-	  gfc_resolve (code->ext.ns);
+	  gfc_resolve (code->ext.block.ns);
 	  break;
 
 	case EXEC_DO:
@@ -11321,7 +11323,6 @@  resolve_symbol (gfc_symbol *sym)
      can.  */
   mp_flag = (sym->result != NULL && sym->result != sym);
 
-
   /* Make sure that the intrinsic is consistent with its internal 
      representation. This needs to be done before assigning a default 
      type to avoid spurious warnings.  */
@@ -11329,6 +11330,18 @@  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.  */
+  if (sym->assoc)
+    {
+      gcc_assert (sym->attr.flavor == FL_VARIABLE);
+      if (gfc_resolve_expr (sym->assoc->target) != SUCCESS)
+	return;
+
+      sym->ts = sym->assoc->target->ts;
+      gcc_assert (sym->ts.type != BT_UNKNOWN);
+    }
+
   /* Assign default type to symbols that need one and don't have one.  */
   if (sym->ts.type == BT_UNKNOWN)
     {
Index: gcc/fortran/st.c
===================================================================
--- gcc/fortran/st.c	(revision 160337)
+++ gcc/fortran/st.c	(working copy)
@@ -116,7 +116,8 @@  gfc_free_statement (gfc_code *p)
       break;
 
     case EXEC_BLOCK:
-      gfc_free_namespace (p->ext.ns);
+      gfc_free_namespace (p->ext.block.ns);
+      gfc_free_association_list (p->ext.block.assoc);
       break;
 
     case EXEC_COMPCALL:
@@ -231,3 +232,15 @@  gfc_free_statements (gfc_code *p)
     }
 }
 
+
+/* Free an association list (of an ASSOCIATE statement).  */
+
+void
+gfc_free_association_list (gfc_association_list* assoc)
+{
+  if (!assoc)
+    return;
+
+  gfc_free_association_list (assoc->next);
+  gfc_free (assoc);
+}
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(revision 160337)
+++ gcc/fortran/match.c	(working copy)
@@ -1797,6 +1797,99 @@  gfc_match_block (void)
 }
 
 
+/* Match an ASSOCIATE statement.  */
+
+match
+gfc_match_associate (void)
+{
+  if (gfc_match_label () == MATCH_ERROR)
+    return MATCH_ERROR;
+
+  if (gfc_match (" associate") != MATCH_YES)
+    return MATCH_NO;
+
+  /* Match the association list.  */
+  if (gfc_match_char ('(') != MATCH_YES)
+    {
+      gfc_error ("Expected association list at %C");
+      return MATCH_ERROR;
+    }
+  new_st.ext.block.assoc = NULL;
+  while (true)
+    {
+      gfc_association_list* newAssoc = gfc_get_association_list ();
+      gfc_association_list* a;
+
+      /* Match the next association.  */
+      if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target)
+	    != MATCH_YES)
+	{
+	  gfc_error ("Expected association at %C");
+	  goto assocListError;
+	}
+
+      /* Check that the current name is not yet in the list.  */
+      for (a = new_st.ext.block.assoc; a; a = a->next)
+	if (!strcmp (a->name, newAssoc->name))
+	  {
+	    gfc_error ("Duplicate name '%s' in association at %C",
+		       newAssoc->name);
+	    goto assocListError;
+	  }
+
+      /* The target expression must not be co-indexed.  */
+      if (gfc_is_coindexed (newAssoc->target))
+	{
+	  gfc_error ("Association target at %C must not be co-indexed");
+	  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.  In addition,
+	 it must not be coindexed.  */
+      newAssoc->variable = (newAssoc->target->expr_type == EXPR_VARIABLE
+			    && !gfc_has_vector_subscript (newAssoc->target));
+
+      /* Put it into the list.  */
+      newAssoc->next = new_st.ext.block.assoc;
+      new_st.ext.block.assoc = newAssoc;
+
+      /* Try next one or end if closing parenthesis is found.  */
+      gfc_gobble_whitespace ();
+      if (gfc_peek_char () == ')')
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	{
+	  gfc_error ("Expected ')' or ',' at %C");
+	  return MATCH_ERROR;
+	}
+
+      continue;
+
+assocListError:
+      gfc_free (newAssoc);
+      goto error;
+    }
+  if (gfc_match_char (')') != MATCH_YES)
+    {
+      /* This should never happen as we peek above.  */
+      gcc_unreachable ();
+    }
+
+  if (gfc_match_eos () != MATCH_YES)
+    {
+      gfc_error ("Junk after ASSOCIATE statement at %C");
+      goto error;
+    }
+
+  return MATCH_YES;
+
+error:
+  gfc_free_association_list (new_st.ext.block.assoc);
+  return MATCH_ERROR;
+}
+
+
 /* Match a DO statement.  */
 
 match
@@ -4361,7 +4454,7 @@  gfc_match_select_type (void)
   new_st.op = EXEC_SELECT_TYPE;
   new_st.expr1 = expr1;
   new_st.expr2 = expr2;
-  new_st.ext.ns = gfc_current_ns;
+  new_st.ext.block.ns = gfc_current_ns;
 
   select_type_push (expr1->symtree->n.sym);
 
Index: gcc/fortran/match.h
===================================================================
--- gcc/fortran/match.h	(revision 160337)
+++ gcc/fortran/match.h	(working copy)
@@ -69,6 +69,7 @@  match gfc_match_else (void);
 match gfc_match_elseif (void);
 match gfc_match_critical (void);
 match gfc_match_block (void);
+match gfc_match_associate (void);
 match gfc_match_do (void);
 match gfc_match_cycle (void);
 match gfc_match_exit (void);
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c	(revision 160337)
+++ gcc/fortran/parse.c	(working copy)
@@ -292,7 +292,7 @@  decode_statement (void)
   gfc_undo_symbols ();
   gfc_current_locus = old_locus;
 
-  /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, and BLOCK
+  /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
      statements, which might begin with a block label.  The match functions for
      these statements are unusual in that their keyword is not seen before
      the matcher is called.  */
@@ -314,6 +314,7 @@  decode_statement (void)
 
   match (NULL, gfc_match_do, ST_DO);
   match (NULL, gfc_match_block, ST_BLOCK);
+  match (NULL, gfc_match_associate, ST_ASSOCIATE);
   match (NULL, gfc_match_critical, ST_CRITICAL);
   match (NULL, gfc_match_select, ST_SELECT_CASE);
   match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
@@ -949,7 +950,7 @@  next_statement (void)
 /* Statements that mark other executable statements.  */
 
 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
-  case ST_IF_BLOCK: case ST_BLOCK: \
+  case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
   case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
   case ST_OMP_PARALLEL: \
   case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
@@ -970,7 +971,7 @@  next_statement (void)
 
 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
 		 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
-		 case ST_END_BLOCK
+		 case ST_END_BLOCK: case ST_END_ASSOCIATE
 
 
 /* Push a new state onto the stack.  */
@@ -1155,6 +1156,9 @@  gfc_ascii_statement (gfc_statement st)
     case ST_ALLOCATE:
       p = "ALLOCATE";
       break;
+    case ST_ASSOCIATE:
+      p = "ASSOCIATE";
+      break;
     case ST_ATTR_DECL:
       p = _("attribute declaration");
       break;
@@ -1215,6 +1219,9 @@  gfc_ascii_statement (gfc_statement st)
     case ST_ELSEWHERE:
       p = "ELSEWHERE";
       break;
+    case ST_END_ASSOCIATE:
+      p = "END ASSOCIATE";
+      break;
     case ST_END_BLOCK:
       p = "END BLOCK";
       break;
@@ -3160,7 +3167,8 @@  parse_block_construct (void)
   my_ns = gfc_build_block_ns (gfc_current_ns);
 
   new_st.op = EXEC_BLOCK;
-  new_st.ext.ns = my_ns;
+  new_st.ext.block.ns = my_ns;
+  new_st.ext.block.assoc = NULL;
   accept_statement (ST_BLOCK);
 
   push_state (&s, COMP_BLOCK, my_ns->proc_name);
@@ -3173,6 +3181,92 @@  parse_block_construct (void)
 }
 
 
+/* Parse an ASSOCIATE construct.  This is essentially a BLOCK construct
+   behind the scenes with compiler-generated variables.  */
+
+static void
+parse_associate (void)
+{
+  gfc_namespace* my_ns;
+  gfc_state_data s;
+  gfc_statement st;
+  gfc_association_list* a;
+  gfc_code* assignTail;
+
+  gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASSOCIATE construct at %C");
+
+  my_ns = gfc_build_block_ns (gfc_current_ns);
+
+  new_st.op = EXEC_BLOCK;
+  new_st.ext.block.ns = my_ns;
+  gcc_assert (new_st.ext.block.assoc);
+
+  /* Add all associations to expressions as BLOCK variables, and create
+     assignments to them giving their values.  */
+  gfc_current_ns = my_ns;
+  assignTail = NULL;
+  for (a = new_st.ext.block.assoc; a; a = a->next)
+    if (!a->variable)
+      {
+	gfc_code* newAssign;
+
+	if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
+	  gcc_unreachable ();
+
+	/* Note that in certain cases, the target-expression's type is not yet
+	   known and so we have to adapt the symbol's ts also during resolution
+	   for these cases.  */
+	a->st->n.sym->ts = a->target->ts;
+	a->st->n.sym->attr.flavor = FL_VARIABLE;
+	a->st->n.sym->assoc = a;
+	gfc_set_sym_referenced (a->st->n.sym);
+
+	/* Create the assignment to calculate the expression and set it.  */
+	newAssign = gfc_get_code ();
+	newAssign->op = EXEC_ASSIGN;
+	newAssign->loc = gfc_current_locus;
+	newAssign->expr1 = gfc_get_variable_expr (a->st);
+	newAssign->expr2 = a->target;
+
+	/* Hang it in.  */
+	if (assignTail)
+	  assignTail->next = newAssign;
+	else
+	  gfc_current_ns->code = newAssign;
+	assignTail = newAssign;
+      }
+    else
+      {
+	gfc_error ("Association to variables is not yet supported at %C");
+	return;
+      }
+  gcc_assert (assignTail);
+
+  accept_statement (ST_ASSOCIATE);
+  push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
+
+loop:
+  st = parse_executable (ST_NONE);
+  switch (st)
+    {
+    case ST_NONE:
+      unexpected_eof ();
+
+    case_end:
+      accept_statement (st);
+      assignTail->next = gfc_state_stack->head;
+      break;
+
+    default:
+      unexpected_statement (st);
+      goto loop;
+    }
+
+  gfc_current_ns = gfc_current_ns->parent;
+  pop_state ();
+}
+
+
 /* Parse a DO loop.  Note that the ST_CYCLE and ST_EXIT statements are
    handled inside of parse_executable(), because they aren't really
    loop statements.  */
@@ -3542,8 +3636,6 @@  parse_executable (gfc_statement st)
 	  case ST_END_SUBROUTINE:
 
 	  case ST_DO:
-	  case ST_CRITICAL:
-	  case ST_BLOCK:
 	  case ST_FORALL:
 	  case ST_WHERE:
 	  case ST_SELECT_CASE:
@@ -3573,6 +3665,10 @@  parse_executable (gfc_statement st)
 	  parse_block_construct ();
 	  break;
 
+	case ST_ASSOCIATE:
+	  parse_associate ();
+	  break;
+
 	case ST_IF_BLOCK:
 	  parse_if_block ();
 	  break;
Index: gcc/fortran/parse.h
===================================================================
--- gcc/fortran/parse.h	(revision 160337)
+++ gcc/fortran/parse.h	(working copy)
@@ -28,7 +28,7 @@  typedef enum
 {
   COMP_NONE, COMP_PROGRAM, COMP_MODULE, COMP_SUBROUTINE, COMP_FUNCTION,
   COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS,
-  COMP_BLOCK, COMP_IF,
+  COMP_BLOCK, COMP_ASSOCIATE, COMP_IF,
   COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
   COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL
 }
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 160337)
+++ gcc/fortran/primary.c	(working copy)
@@ -2975,6 +2975,14 @@  match_variable (gfc_expr **result, int e
 	  gfc_error ("Assigning to PROTECTED variable at %C");
 	  return MATCH_ERROR;
 	}
+      /* XXX: Is this match_variable really the same as variable definition
+	 context in the standard?  */
+      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;
+	}
       break;
 
     case FL_UNKNOWN:
Index: gcc/testsuite/gfortran.dg/associate_3.f03
===================================================================
--- gcc/testsuite/gfortran.dg/associate_3.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/associate_3.f03	(revision 0)
@@ -0,0 +1,41 @@ 
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+
+! PR fortran/38936
+! Check for errors with ASSOCIATE.
+
+PROGRAM main
+  IMPLICIT NONE
+
+  ASSOCIATE ! { dg-error "Expected association list" }
+
+  ASSOCIATE () ! { dg-error "Expected association" }
+
+  ASSOCIATE (a => 1) 5 ! { dg-error "Junk after ASSOCIATE" }
+
+  ASSOCIATE (x =>) ! { dg-error "Expected association" }
+
+  ASSOCIATE (=> 5) ! { dg-error "Expected association" }
+
+  ASSOCIATE (x => 5, ) ! { dg-error "Expected association" }
+
+  myname: ASSOCIATE (a => 1)
+  END ASSOCIATE ! { dg-error "Expected block name of 'myname'" }
+
+  ASSOCIATE (b => 2)
+  END ASSOCIATE myname ! { dg-error "Syntax error in END ASSOCIATE" }
+
+  myname2: ASSOCIATE (c => 3)
+  END ASSOCIATE myname3 ! { dg-error "Expected label 'myname2'" }
+
+  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" }
+! { dg-excess-errors "Unexpected end of file" }
Index: gcc/testsuite/gfortran.dg/associate_2.f95
===================================================================
--- gcc/testsuite/gfortran.dg/associate_2.f95	(revision 0)
+++ gcc/testsuite/gfortran.dg/associate_2.f95	(revision 0)
@@ -0,0 +1,12 @@ 
+! { dg-do compile }
+! { dg-options "-std=f95" }
+
+! PR fortran/38936
+! Test that F95 rejects ASSOCIATE.
+
+PROGRAM main
+  IMPLICIT NONE
+
+  ASSOCIATE (a => 5) ! { dg-error "Fortran 2003" }
+  END ASSOCIATE
+END PROGRAM main
Index: gcc/testsuite/gfortran.dg/associate_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/associate_1.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/associate_1.f03	(revision 0)
@@ -0,0 +1,49 @@ 
+! { dg-do run }
+! { dg-options "-std=f2003 -fall-intrinsics" }
+
+! PR fortran/38936
+! Check the basic semantics of the ASSOCIATE construct.
+
+PROGRAM main
+  IMPLICIT NONE
+  REAL :: a, b, c
+  INTEGER, ALLOCATABLE :: arr(:)
+
+  a = -2.0
+  b = 3.0
+  c = 4.0
+
+  ! Simple association to expressions.
+  ASSOCIATE (r => SQRT (a**2 + b**2 + c**2), t => a + b)
+    PRINT *, t, a, b
+    IF (ABS (r - SQRT (4.0 + 9.0 + 16.0)) > 1.0e-3) CALL abort ()
+    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.
+  ! TODO: Enable when working.
+  !ALLOCATE (arr(3))
+  !arr = (/ 1, 2, 3 /)
+  !ASSOCIATE (doubled => 2 * arr)
+  !  IF (doubled(1) /= 2 .OR. doubled(2) /= 4 .OR. doubled(3) /= 6) &
+  !    CALL abort ()
+  !END ASSOCIATE
+
+  ! Named and nested associate.
+  myname: ASSOCIATE (x => a - b * c)
+    ASSOCIATE (y => 2.0 * x)
+      IF (ABS (y - 2.0 * (a - b * c)) > 1.0e-3) CALL abort ()
+    END ASSOCIATE
+  END ASSOCIATE myname ! Matching end-label.
+
+  ! Correct behaviour when shadowing already existing names.
+  ASSOCIATE (a => 1 * b, b => 1 * a, x => 1, y => 2)
+    IF (ABS (a - 3.0) > 1.0e-3 .OR. ABS (b + 2.0) > 1.0e-3) CALL abort ()
+    ASSOCIATE (x => 1 * y, y => 1 * x)
+      IF (x /= 2 .OR. y /= 1) CALL abort ()
+    END ASSOCIATE
+  END ASSOCIATE
+END PROGRAM main