2010-06-10 Daniel Kraft <d@domob.eu>

	PR fortran/38936
	* gfortran.h (enum gfc_statement): Add ST_ASSOCIATE, ST_END_ASSOCIATE.
	(struct gfc_symbol): New field `assoc'.
	(struct gfc_association_list): New struct.
	(struct gfc_code): New struct `block' in union, move `ns' there
	and add association list.
	(gfc_free_association_list): New method.
	(gfc_has_vector_subscript): Made public;
	* match.h (gfc_match_associate): New method.
	* parse.h (enum gfc_compile_state): Add COMP_ASSOCIATE.
	* decl.c (gfc_match_end): Handle ST_END_ASSOCIATE.
	* interface.c (gfc_has_vector_subscript): Made public.
	(compare_actual_formal): Rename `has_vector_subscript' accordingly.
	* match.c (gfc_match_associate): New method.
	(gfc_match_select_type): Change reference to gfc_code's `ns' field.
	* primary.c (match_variable): Don't allow names associated to expr here.
	* parse.c (decode_statement): Try matching ASSOCIATE statement.
	(case_exec_markers, case_end): Add ASSOCIATE statement.
	(gfc_ascii_statement): Hande ST_ASSOCIATE and ST_END_ASSOCIATE.
	(parse_associate): New method.
	(parse_executable): Handle ST_ASSOCIATE.
	(parse_block_construct): Change reference to gfc_code's `ns' field.
	* resolve.c (resolve_select_type): Ditto.
	(resolve_code): Ditto.
	(resolve_block_construct): Ditto and add comment.
	(resolve_select_type): Set association list in generated BLOCK to NULL.
	(resolve_symbol): Resolve associate names.
	* st.c (gfc_free_statement): Change reference to gfc_code's `ns' field
	and free association list.
	(gfc_free_association_list): New method.
	* symbol.c (gfc_new_symbol): NULL new field `assoc'.
	* trans-stmt.c (gfc_trans_block_construct): Change reference to
	gfc_code's `ns' field.

2010-06-10  Daniel Kraft  <d@domob.eu>

	PR fortran/38936
	* gfortran.dg/associate_1.f03: New test.
	* gfortran.dg/associate_2.f95: New test.
	* gfortran.dg/associate_3.f03: New test.
	* gfortran.dg/associate_4.f08: New test.


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

1 files changed, 102 insertions, 6 deletions

diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 7fc35418bec..7b887bc1e39 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -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;