re PR fortran/38936 ([F03] ASSOCIATE construct / improved SELECT TYPE (a=>expr))

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.

From-SVN: r160550

gcc/fortran/ChangeLog

+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  Kai Tietz  <kai.tietz@onevision.com>
 
 	* error.c (error_print): Pre-initialize loc by NULL.

gcc/fortran/decl.c

@@ -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@"))
+  switch (state)
+    {
+    case COMP_ASSOCIATE:
+    case COMP_BLOCK:
+      if (!strcmp (block_name, "block@"))
 	block_name = NULL;
+      break;
 
-  if (state == COMP_CONTAINS || state == COMP_DERIVED_CONTAINS)
-    {
+    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)

gcc/fortran/gfortran.h

@@ -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_interface *);
 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;

gcc/fortran/interface.c

@@ -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_arglist **ap, gfc_formal_arglist *formal,
       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 "

gcc/fortran/match.c

@@ -1797,6 +1797,98 @@ 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 coindexed.  */
+      if (gfc_is_coindexed (newAssoc->target))
+	{
+	  gfc_error ("Association target at %C must not be coindexed");
+	  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));
+
+      /* 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 +4453,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);
 

gcc/fortran/match.h

@@ -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);

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;

gcc/fortran/parse.h

@@ -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
 }

gcc/fortran/primary.c

@@ -2975,6 +2975,12 @@ 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;
+	}
       break;
 
     case FL_UNKNOWN:

gcc/fortran/resolve.c

@@ -7158,7 +7158,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.  */
@@ -7245,6 +7245,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;
 
@@ -7988,10 +7989,11 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
 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);
 }
 
 
@@ -8312,7 +8314,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	      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;
@@ -8476,7 +8478,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	  break;
 
 	case EXEC_BLOCK:
-	  gfc_resolve (code->ext.ns);
+	  gfc_resolve (code->ext.block.ns);
 	  break;
 
 	case EXEC_DO:
@@ -11341,7 +11343,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.  */
@@ -11349,6 +11350,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)
     {

gcc/fortran/st.c

@@ -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);
+}

gcc/fortran/symbol.c

@@ -2512,6 +2512,7 @@ gfc_new_symbol (const char *name, gfc_namespace *ns)
   /* Clear the ptrs we may need.  */
   p->common_block = NULL;
   p->f2k_derived = NULL;
+  p->assoc = NULL;
   
   return p;
 }

gcc/fortran/trans-stmt.c

@@ -850,7 +850,7 @@ gfc_trans_block_construct (gfc_code* code)
   stmtblock_t body;
   tree tmp;
 
-  ns = code->ext.ns;
+  ns = code->ext.block.ns;
   gcc_assert (ns);
   sym = ns->proc_name;
   gcc_assert (sym);

gcc/testsuite/ChangeLog

+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.
+
 2010-06-10  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
 	* gfortran.dg/selected_char_kind_4.f90: New test.

gcc/testsuite/gfortran.dg/associate_1.f03

+! { 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

gcc/testsuite/gfortran.dg/associate_2.f95

+! { 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

gcc/testsuite/gfortran.dg/associate_3.f03

+! { 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" }

gcc/testsuite/gfortran.dg/associate_4.f08

+! { dg-do compile }
+! { dg-options "-std=f2008 -fcoarray=single" }
+
+! PR fortran/38936
+! Check for error with coindexed target.
+
+PROGRAM main
+  IMPLICIT NONE
+  INTEGER :: a[*]
+
+  ASSOCIATE (x => a[1]) ! { dg-error "must not be coindexed" }
+END PROGRAM main