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

gcc/fortran/ChangeLog

+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

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);

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;

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 = ⊤
 

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);