diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index ae54bc552d836b8a53d50172cbed632f88421fc9..d463f15139192b570dc01236de01de58cd4e1dad 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,39 @@
+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.
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 9786a860baec50749df94af9c2d9f8114b1a96e9..e2de24f3f137aebc037028e2b400bf349527bafc 100644
--- a/gcc/fortran/decl.c
+++ b/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@"))
- 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)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 9762cddfaa888aa593b576bc2dc8e908c79cdfab..2a553d198fa743ac8bdb061aacc6ff65af105432 100644
--- a/gcc/fortran/gfortran.h
+++ b/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;
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 99ade9d273d5f7075c4879437bcf1487ac0575f1..379c636d695958fd0930fb7c2147b5efd79ff065 100644
--- a/gcc/fortran/interface.c
+++ b/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 "
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 2cbac0200fdf235eb6e5c45cbe8f2ca91d44c8f0..8c43531d8752af72298ab7f1ec283d67324efc7f 100644
--- a/gcc/fortran/match.c
+++ b/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);
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 049f3d3285c6cde0d71a73067ec0ddd54d4d65ee..09740fb248569fd19fda8a2b65053d1062f480b9 100644
--- a/gcc/fortran/match.h
+++ b/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);
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 7fc35418bec41345a9516b949548f1b790b8c833..7b887bc1e39adc126036c925a61332977b189840 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;
diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h
index faa813d88d09bf9c17835620289817c76991708e..65d1a7e604a8f80e1c2323d6aa289f992d79b02d 100644
--- a/gcc/fortran/parse.h
+++ b/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
}
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 68b6a437360cbea4a153063b9ff8f23cdb37e002..b6c08a9c406f79a168d32179c926384997cbdda7 100644
--- a/gcc/fortran/primary.c
+++ b/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:
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 8fabf4e69b743566794b78abc1b36d3b50bb118f..5f920c9e3d3c94e8cc16a073f1d8e34e9f29c049 100644
--- a/gcc/fortran/resolve.c
+++ b/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)
{
diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c
index ffef22d11409ef2519d96b9fa430ba148e7def3b..f9ad5d82793e8233b0026588dbdec3bf7fb578d2 100644
--- a/gcc/fortran/st.c
+++ b/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);
+}
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 07802e8349a70e2a2cde3064ddaca0352b28406f..049e4a735285bc7b6d079c0f6e8559270a92b8f4 100644
--- a/gcc/fortran/symbol.c
+++ b/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;
}
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 37b577f2cc4472c77dc955bc52437609c366cb3d..e5636bfed53945a375c1a3fe0770f8a9fbabe20a 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/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);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 7f4c7f3818d950fa639f221ac7eed5c229aa12e4..e72a684dba7482ee9e4bc647feb0300daeed5927 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+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.
diff --git a/gcc/testsuite/gfortran.dg/associate_1.f03 b/gcc/testsuite/gfortran.dg/associate_1.f03
new file mode 100644
index 0000000000000000000000000000000000000000..90579c99ce3c5e469a70743f58dd7272fe5b2296
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_1.f03
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/associate_2.f95 b/gcc/testsuite/gfortran.dg/associate_2.f95
new file mode 100644
index 0000000000000000000000000000000000000000..a41398d7850c82ba9b926fe1272629a714060d85
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_2.f95
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/associate_3.f03 b/gcc/testsuite/gfortran.dg/associate_3.f03
new file mode 100644
index 0000000000000000000000000000000000000000..c53bd559fb8ef46deb1f2ff725d2fd04faf1caa5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_3.f03
@@ -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" }
diff --git a/gcc/testsuite/gfortran.dg/associate_4.f08 b/gcc/testsuite/gfortran.dg/associate_4.f08
new file mode 100644
index 0000000000000000000000000000000000000000..c336af2ab13c0b1941f0ec0a78e73ef170698a27
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_4.f08
@@ -0,0 +1,12 @@
+! { 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