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

1 files changed, 52 insertions, 6 deletions

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 0b9dc73..55e135b 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;