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 fd67582631b6f36189117d153135ba3f66960c5a..d3f24d068b039ca4dae49ff940000da2651e9ebb 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,25 @@
+2004-07-16  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+       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  <tobias.schlueter@physik.uni-muenchen.de>
 
        PR fortran/15129

diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index 5db519a02f84bbc62dba6ddb6cd1a6152c319575..05c4571302ee526c87c8e6cd71d09ca4b39e771a 100644 (file)
--- 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 0b9dc7307d5e8146e13b197b6ccf47aa20caf5dc..55e135b9ea213ad7bd0c3a3bf03bdfe5a7529223 100644 (file)
--- 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 32f5185b2d6d9816d9680579e8049fdb62132c1f..68f1ddd673db0ee368c34c98ae90082cd80b18e1 100644 (file)
--- 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 a6bf12a1392ae93da847e843fd12e7f9303caee4..c0c096547514a2c53a3a4d511d2a0c93aa0fe6dd 100644 (file)
--- 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);