From patchwork Tue Jun 8 14:38:48 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Daniel Kraft X-Patchwork-Id: 54995 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id CECBBB7D59 for ; Wed, 9 Jun 2010 00:34:37 +1000 (EST) Received: (qmail 28396 invoked by alias); 8 Jun 2010 14:34:33 -0000 Received: (qmail 28191 invoked by uid 22791); 8 Jun 2010 14:34:29 -0000 X-SWARE-Spam-Status: No, hits=-2.7 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_LOW, SPF_HELO_PASS, TW_TM X-Spam-Check-By: sourceware.org Received: from tatiana.utanet.at (HELO tatiana.utanet.at) (213.90.36.46) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 08 Jun 2010 14:34:21 +0000 Received: from pam.xoc.tele2net.at ([213.90.36.6]) by tatiana.utanet.at with esmtp (Exim 4.71) (envelope-from ) id 1OLzsg-0000kP-FT; Tue, 08 Jun 2010 16:34:18 +0200 Received: from d91-128-23-114.cust.tele2.at ([91.128.23.114] helo=[192.168.1.18]) by pam.xoc.tele2net.at with esmtpa (Exim 4.71) (envelope-from ) id 1OLzsf-0002En-HU; Tue, 08 Jun 2010 16:34:18 +0200 Message-ID: <4C0E55F8.80103@domob.eu> Date: Tue, 08 Jun 2010 16:38:48 +0200 From: Daniel Kraft User-Agent: Thunderbird 2.0.0.0 (X11/20070425) MIME-Version: 1.0 To: Tobias Burnus , Fortran List CC: gcc-patches Subject: Re: [Patch, Fortran] First ASSOCIATE patch and some questions / RFCs References: <4C0BDF48.2050403@domob.eu> In-Reply-To: <4C0BDF48.2050403@domob.eu> Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org 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 > 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