diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 36 | ||||
| -rw-r--r-- | gcc/fortran/decl.c | 25 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 39 | ||||
| -rw-r--r-- | gcc/fortran/interface.c | 6 | ||||
| -rw-r--r-- | gcc/fortran/match.c | 94 | ||||
| -rw-r--r-- | gcc/fortran/match.h | 1 | ||||
| -rw-r--r-- | gcc/fortran/parse.c | 108 | ||||
| -rw-r--r-- | gcc/fortran/parse.h | 2 | ||||
| -rw-r--r-- | gcc/fortran/primary.c | 6 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 27 | ||||
| -rw-r--r-- | gcc/fortran/st.c | 15 | ||||
| -rw-r--r-- | gcc/fortran/symbol.c | 1 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 2 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 8 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/associate_1.f03 | 49 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/associate_2.f95 | 12 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/associate_3.f03 | 41 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/associate_4.f08 | 12 |
18 files changed, 455 insertions, 29 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index ae54bc552d8..d463f151391 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 9786a860bae..e2de24f3f13 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 9762cddfaa8..2a553d198fa 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 99ade9d273d..379c636d695 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 2cbac0200fd..8c43531d875 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 049f3d3285c..09740fb2485 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 7fc35418bec..7b887bc1e39 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -292,7 +292,7 @@ decode_statement (void) gfc_undo_symbols (); gfc_current_locus = old_locus; - /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, and BLOCK + /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE statements, which might begin with a block label. The match functions for these statements are unusual in that their keyword is not seen before the matcher is called. */ @@ -314,6 +314,7 @@ decode_statement (void) match (NULL, gfc_match_do, ST_DO); match (NULL, gfc_match_block, ST_BLOCK); + match (NULL, gfc_match_associate, ST_ASSOCIATE); match (NULL, gfc_match_critical, ST_CRITICAL); match (NULL, gfc_match_select, ST_SELECT_CASE); match (NULL, gfc_match_select_type, ST_SELECT_TYPE); @@ -949,7 +950,7 @@ next_statement (void) /* Statements that mark other executable statements. */ #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \ - case ST_IF_BLOCK: case ST_BLOCK: \ + case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \ case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \ case ST_OMP_PARALLEL: \ case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \ @@ -970,7 +971,7 @@ next_statement (void) #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \ case ST_END_PROGRAM: case ST_END_SUBROUTINE: \ - case ST_END_BLOCK + case ST_END_BLOCK: case ST_END_ASSOCIATE /* Push a new state onto the stack. */ @@ -1155,6 +1156,9 @@ gfc_ascii_statement (gfc_statement st) case ST_ALLOCATE: p = "ALLOCATE"; break; + case ST_ASSOCIATE: + p = "ASSOCIATE"; + break; case ST_ATTR_DECL: p = _("attribute declaration"); break; @@ -1215,6 +1219,9 @@ gfc_ascii_statement (gfc_statement st) case ST_ELSEWHERE: p = "ELSEWHERE"; break; + case ST_END_ASSOCIATE: + p = "END ASSOCIATE"; + break; case ST_END_BLOCK: p = "END BLOCK"; break; @@ -3160,7 +3167,8 @@ parse_block_construct (void) my_ns = gfc_build_block_ns (gfc_current_ns); new_st.op = EXEC_BLOCK; - new_st.ext.ns = my_ns; + new_st.ext.block.ns = my_ns; + new_st.ext.block.assoc = NULL; accept_statement (ST_BLOCK); push_state (&s, COMP_BLOCK, my_ns->proc_name); @@ -3173,6 +3181,92 @@ parse_block_construct (void) } +/* Parse an ASSOCIATE construct. This is essentially a BLOCK construct + behind the scenes with compiler-generated variables. */ + +static void +parse_associate (void) +{ + gfc_namespace* my_ns; + gfc_state_data s; + gfc_statement st; + gfc_association_list* a; + gfc_code* assignTail; + + gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASSOCIATE construct at %C"); + + my_ns = gfc_build_block_ns (gfc_current_ns); + + new_st.op = EXEC_BLOCK; + new_st.ext.block.ns = my_ns; + gcc_assert (new_st.ext.block.assoc); + + /* Add all associations to expressions as BLOCK variables, and create + assignments to them giving their values. */ + gfc_current_ns = my_ns; + assignTail = NULL; + for (a = new_st.ext.block.assoc; a; a = a->next) + if (!a->variable) + { + gfc_code* newAssign; + + if (gfc_get_sym_tree (a->name, NULL, &a->st, false)) + gcc_unreachable (); + + /* Note that in certain cases, the target-expression's type is not yet + known and so we have to adapt the symbol's ts also during resolution + for these cases. */ + a->st->n.sym->ts = a->target->ts; + a->st->n.sym->attr.flavor = FL_VARIABLE; + a->st->n.sym->assoc = a; + gfc_set_sym_referenced (a->st->n.sym); + + /* Create the assignment to calculate the expression and set it. */ + newAssign = gfc_get_code (); + newAssign->op = EXEC_ASSIGN; + newAssign->loc = gfc_current_locus; + newAssign->expr1 = gfc_get_variable_expr (a->st); + newAssign->expr2 = a->target; + + /* Hang it in. */ + if (assignTail) + assignTail->next = newAssign; + else + gfc_current_ns->code = newAssign; + assignTail = newAssign; + } + else + { + gfc_error ("Association to variables is not yet supported at %C"); + return; + } + gcc_assert (assignTail); + + accept_statement (ST_ASSOCIATE); + push_state (&s, COMP_ASSOCIATE, my_ns->proc_name); + +loop: + st = parse_executable (ST_NONE); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case_end: + accept_statement (st); + assignTail->next = gfc_state_stack->head; + break; + + default: + unexpected_statement (st); + goto loop; + } + + gfc_current_ns = gfc_current_ns->parent; + pop_state (); +} + + /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are handled inside of parse_executable(), because they aren't really loop statements. */ @@ -3542,8 +3636,6 @@ parse_executable (gfc_statement st) case ST_END_SUBROUTINE: case ST_DO: - case ST_CRITICAL: - case ST_BLOCK: case ST_FORALL: case ST_WHERE: case ST_SELECT_CASE: @@ -3573,6 +3665,10 @@ parse_executable (gfc_statement st) parse_block_construct (); break; + case ST_ASSOCIATE: + parse_associate (); + break; + case ST_IF_BLOCK: parse_if_block (); break; diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index faa813d88d0..65d1a7e604a 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 68b6a437360..b6c08a9c406 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 8fabf4e69b7..5f920c9e3d3 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 ffef22d1140..f9ad5d82793 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 07802e8349a..049e4a73528 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 37b577f2cc4..e5636bfed53 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 7f4c7f3818d..e72a684dba7 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 00000000000..90579c99ce3 --- /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 00000000000..a41398d7850 --- /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 00000000000..c53bd559fb8 --- /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 00000000000..c336af2ab13 --- /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 |