From: Tobias Schlüter Date: Fri, 16 Jul 2004 00:39:40 +0000 (+0200) Subject: re PR fortran/16404 (should reject invalid code with -pedantic -std=f95 ? (x8)) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=c9583ed23d6fc2706bfaf403c4c3ba41f92b9b50;p=gcc.git re PR fortran/16404 (should reject invalid code with -pedantic -std=f95 ? (x8)) PR fortran/16404 (parts ported from g95) * parse.h (gfc_state_data): New field do_variable. (gfc_check_do_variable): Add prototype. * parse.c (push_state): Initialize field 'do_variable'. (gfc_check_do_variable): New function. (parse_do_block): Remember do iterator variable. (parse_file): Initialize field 'do_variable'. * match.c (gfc_match_assignment, gfc_match_do, gfc_match_allocate, gfc_match_nullify, gfc_match_deallocate): Add previously missing checks. (gfc_match_return): Reformat error message. * io.c (match_out_tag): New function. (match_open_element, match_close_element, match_file_element, match_dt_element): Call match_out_tag instead of match_vtag where appropriate. (match_io_iterator, match_io_element): Add missing check. (match_io): Reformat error message. (match_inquire_element): Call match_out_tag where appropriate. From-SVN: r84793 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index fd67582631b..d3f24d068b0 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,25 @@ +2004-07-16 Tobias Schlueter + + PR fortran/16404 + (parts ported from g95) + * parse.h (gfc_state_data): New field do_variable. + (gfc_check_do_variable): Add prototype. + * parse.c (push_state): Initialize field 'do_variable'. + (gfc_check_do_variable): New function. + (parse_do_block): Remember do iterator variable. + (parse_file): Initialize field 'do_variable'. + * match.c (gfc_match_assignment, gfc_match_do, + gfc_match_allocate, gfc_match_nullify, gfc_match_deallocate): + Add previously missing checks. + (gfc_match_return): Reformat error message. + * io.c (match_out_tag): New function. + (match_open_element, match_close_element, + match_file_element, match_dt_element): Call match_out_tag + instead of match_vtag where appropriate. + (match_io_iterator, match_io_element): Add missing check. + (match_io): Reformat error message. + (match_inquire_element): Call match_out_tag where appropriate. + 2004-07-15 Tobias Schlueter PR fortran/15129 diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 5db519a02f8..05c4571302e 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -918,6 +918,21 @@ match_vtag (const io_tag * tag, gfc_expr ** v) } +/* Match I/O tags that cause variables to become redefined. */ + +static match +match_out_tag(const io_tag *tag, gfc_expr **result) +{ + match m; + + m = match_vtag(tag, result); + if (m == MATCH_YES) + gfc_check_do_variable((*result)->symtree); + + return m; +} + + /* Match a label I/O tag. */ static match @@ -993,7 +1008,7 @@ match_open_element (gfc_open * open) m = match_etag (&tag_unit, &open->unit); if (m != MATCH_NO) return m; - m = match_vtag (&tag_iostat, &open->iostat); + m = match_out_tag (&tag_iostat, &open->iostat); if (m != MATCH_NO) return m; m = match_etag (&tag_file, &open->file); @@ -1179,7 +1194,7 @@ match_close_element (gfc_close * close) m = match_etag (&tag_status, &close->status); if (m != MATCH_NO) return m; - m = match_vtag (&tag_iostat, &close->iostat); + m = match_out_tag (&tag_iostat, &close->iostat); if (m != MATCH_NO) return m; m = match_ltag (&tag_err, &close->err); @@ -1292,7 +1307,7 @@ match_file_element (gfc_filepos * fp) m = match_etag (&tag_unit, &fp->unit); if (m != MATCH_NO) return m; - m = match_vtag (&tag_iostat, &fp->iostat); + m = match_out_tag (&tag_iostat, &fp->iostat); if (m != MATCH_NO) return m; m = match_ltag (&tag_err, &fp->err); @@ -1603,7 +1618,7 @@ match_dt_element (io_kind k, gfc_dt * dt) m = match_etag (&tag_rec, &dt->rec); if (m != MATCH_NO) return m; - m = match_vtag (&tag_iostat, &dt->iostat); + m = match_out_tag (&tag_iostat, &dt->iostat); if (m != MATCH_NO) return m; m = match_ltag (&tag_err, &dt->err); @@ -1612,7 +1627,7 @@ match_dt_element (io_kind k, gfc_dt * dt) m = match_etag (&tag_advance, &dt->advance); if (m != MATCH_NO) return m; - m = match_vtag (&tag_size, &dt->size); + m = match_out_tag (&tag_size, &dt->size); if (m != MATCH_NO) return m; @@ -1842,7 +1857,10 @@ match_io_iterator (io_kind k, gfc_code ** result) if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_YES) - break; + { + gfc_check_do_variable (iter->var->symtree); + break; + } m = match_io_element (k, &new); if (m == MATCH_ERROR) @@ -1942,6 +1960,9 @@ match_io_element (io_kind k, gfc_code ** cpp) m = MATCH_ERROR; } + if (gfc_check_do_variable (expr->symtree)) + m = MATCH_ERROR; + break; case M_WRITE: @@ -2149,8 +2170,8 @@ get_io_list: if (!comma_flag && gfc_match_char (',') == MATCH_YES && k == M_WRITE - && gfc_notify_std (GFC_STD_GNU, "Comma before output item list " - "at %C is an extension") == FAILURE) + && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before output " + "item list at %C is an extension") == FAILURE) return MATCH_ERROR; io_code = NULL; @@ -2298,20 +2319,20 @@ match_inquire_element (gfc_inquire * inquire) m = match_etag (&tag_unit, &inquire->unit); RETM m = match_etag (&tag_file, &inquire->file); RETM m = match_ltag (&tag_err, &inquire->err); - RETM m = match_vtag (&tag_iostat, &inquire->iostat); + RETM m = match_out_tag (&tag_iostat, &inquire->iostat); RETM m = match_vtag (&tag_exist, &inquire->exist); RETM m = match_vtag (&tag_opened, &inquire->opened); RETM m = match_vtag (&tag_named, &inquire->named); RETM m = match_vtag (&tag_name, &inquire->name); - RETM m = match_vtag (&tag_number, &inquire->number); + RETM m = match_out_tag (&tag_number, &inquire->number); RETM m = match_vtag (&tag_s_access, &inquire->access); RETM m = match_vtag (&tag_sequential, &inquire->sequential); RETM m = match_vtag (&tag_direct, &inquire->direct); RETM m = match_vtag (&tag_s_form, &inquire->form); RETM m = match_vtag (&tag_formatted, &inquire->formatted); RETM m = match_vtag (&tag_unformatted, &inquire->unformatted); - RETM m = match_vtag (&tag_s_recl, &inquire->recl); - RETM m = match_vtag (&tag_nextrec, &inquire->nextrec); + RETM m = match_out_tag (&tag_s_recl, &inquire->recl); + RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec); RETM m = match_vtag (&tag_s_blank, &inquire->blank); RETM m = match_vtag (&tag_s_position, &inquire->position); RETM m = match_vtag (&tag_s_action, &inquire->action); diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 0b9dc7307d5..55e135b9ea2 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -835,6 +835,13 @@ gfc_match_assignment (void) if (m != MATCH_YES) goto cleanup; + if (lvalue->symtree->n.sym->attr.flavor == FL_PARAMETER) + { + gfc_error ("Cannot assign to a PARAMETER variable at %C"); + m = MATCH_ERROR; + goto cleanup; + } + m = gfc_match (" %e%t", &rvalue); if (m != MATCH_YES) goto cleanup; @@ -845,6 +852,8 @@ gfc_match_assignment (void) new_st.expr = lvalue; new_st.expr2 = rvalue; + gfc_check_do_variable (lvalue->symtree); + return MATCH_YES; cleanup: @@ -1232,6 +1241,8 @@ gfc_match_do (void) if (m == MATCH_ERROR) goto cleanup; + gfc_check_do_variable (iter.var->symtree); + if (gfc_match_eos () != MATCH_YES) { gfc_syntax_error (ST_DO); @@ -1688,6 +1699,9 @@ gfc_match_allocate (void) if (m == MATCH_ERROR) goto cleanup; + if (gfc_check_do_variable (tail->expr->symtree)) + goto cleanup; + if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym)) { @@ -1723,6 +1737,14 @@ gfc_match_allocate (void) "procedure"); goto cleanup; } + + if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE) + { + gfc_error("STAT expression at %C must be a variable"); + goto cleanup; + } + + gfc_check_do_variable(stat->symtree); } if (gfc_match (" )%t") != MATCH_YES) @@ -1767,6 +1789,9 @@ gfc_match_nullify (void) if (m == MATCH_NO) goto syntax; + if (gfc_check_do_variable(p->symtree)) + goto cleanup; + if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym)) { gfc_error @@ -1841,6 +1866,9 @@ gfc_match_deallocate (void) if (m == MATCH_NO) goto syntax; + if (gfc_check_do_variable (tail->expr->symtree)) + goto cleanup; + if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym)) { @@ -1860,11 +1888,29 @@ gfc_match_deallocate (void) break; } - if (stat != NULL && stat->symtree->n.sym->attr.intent == INTENT_IN) + if (stat != NULL) { - gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C cannot be " - "INTENT(IN)", stat->symtree->n.sym->name); - goto cleanup; + if (stat->symtree->n.sym->attr.intent == INTENT_IN) + { + gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C " + "cannot be INTENT(IN)", stat->symtree->n.sym->name); + goto cleanup; + } + + if (gfc_pure(NULL) && gfc_impure_variable (stat->symtree->n.sym)) + { + gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C " + "for a PURE procedure"); + goto cleanup; + } + + if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE) + { + gfc_error("STAT expression at %C must be a variable"); + goto cleanup; + } + + gfc_check_do_variable(stat->symtree); } if (gfc_match (" )%t") != MATCH_YES) @@ -1897,8 +1943,8 @@ gfc_match_return (void) gfc_enclosing_unit (&s); if (s == COMP_PROGRAM - && gfc_notify_std (GFC_STD_GNU, "RETURN statement in a main " - "program at %C is an extension.") == FAILURE) + && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in " + "main program at %C") == FAILURE) return MATCH_ERROR; e = NULL; diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 32f5185b2d6..68f1ddd673d 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -551,6 +551,7 @@ push_state (gfc_state_data * p, gfc_compile_state new_state, gfc_symbol * sym) p->previous = gfc_state_stack; p->sym = sym; p->head = p->tail = NULL; + p->do_variable = NULL; gfc_state_stack = p; } @@ -1911,6 +1912,28 @@ parse_select_block (void) } +/* Given a symbol, make sure it is not an iteration variable for a DO + statement. This subroutine is called when the symbol is seen in a + context that causes it to become redefined. If the symbol is an + iterator, we generate an error message and return nonzero. */ + +int +gfc_check_do_variable (gfc_symtree *st) +{ + gfc_state_data *s; + + for (s=gfc_state_stack; s; s = s->previous) + if (s->do_variable == st) + { + gfc_error_now("Variable '%s' at %C cannot be redefined inside " + "loop beginning at %L", st->name, &s->tail->loc); + return 1; + } + + return 0; +} + + /* Checks to see if the current statement label closes an enddo. Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues an error) if it incorrectly closes an ENDDO. */ @@ -1965,14 +1988,22 @@ parse_do_block (void) gfc_statement st; gfc_code *top; gfc_state_data s; + gfc_symtree *stree; s.ext.end_do_label = new_st.label; + if (new_st.ext.iterator != NULL) + stree = new_st.ext.iterator->var->symtree; + else + stree = NULL; + accept_statement (ST_DO); top = gfc_state_stack->tail; push_state (&s, COMP_DO, gfc_new_block); + s.do_variable = stree; + top->block = new_level (top); top->block->op = EXEC_DO; @@ -2506,6 +2537,7 @@ gfc_parse_file (void) top.sym = NULL; top.previous = NULL; top.head = top.tail = NULL; + top.do_variable = NULL; gfc_state_stack = ⊤ diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index a6bf12a1392..c0c09654751 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -40,6 +40,8 @@ typedef struct gfc_state_data { gfc_compile_state state; gfc_symbol *sym; /* Block name associated with this level */ + gfc_symtree *do_variable; /* For DO blocks the iterator variable. */ + struct gfc_code *head, *tail; struct gfc_state_data *previous; @@ -57,6 +59,7 @@ extern gfc_state_data *gfc_state_stack; #define gfc_current_block() (gfc_state_stack->sym) #define gfc_current_state() (gfc_state_stack->state) +int gfc_check_do_variable (gfc_symtree *); try gfc_find_state (gfc_compile_state); gfc_state_data *gfc_enclosing_unit (gfc_compile_state *); const char *gfc_ascii_statement (gfc_statement);