This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Patch, Fortran] First ASSOCIATE patch and some questions / RFCs
- From: Daniel Kraft <d at domob dot eu>
- To: Tobias Burnus <burnus at net-b dot de>, Fortran List <fortran at gcc dot gnu dot org>
- Cc: gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Tue, 08 Jun 2010 16:38:48 +0200
- Subject: Re: [Patch, Fortran] First ASSOCIATE patch and some questions / RFCs
- References: <4C0BDF48.2050403@domob.eu>
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
--
http://www.pro-vegan.info/
--
Done: Arc-Bar-Cav-Ran-Rog-Sam-Tou-Val-Wiz
To go: Hea-Kni-Mon-Pri
2010-06-06 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-06 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.
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