io.c (resolve_tag_format): New function using code split out and simplified from ...

fortran/
* io.c (resolve_tag_format): New function using code split out
and simplified from ...
(resolve_tag): ... this function.  Simplify logic.  Unify
IOSTAT, IOLENGTH and SIZE handling.
testsuite/
* gfortran.dg/g77/19981216-0.f: Remove dg-warning annotation.
* gfortran.dg/io_constraints_1.f90: Make a -std=f95 test.  Add
warning annotation.
* gfortran.dg/iostat_3.f90: Make a -std=f95 test.

From-SVN: r128623

2 files changed, 99 insertions, 108 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 29d8dd2d..9e7ca3a 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2007-09-20  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	* io.c (resolve_tag_format): New function using code split out
+	and simplified from ...
+	(resolve_tag): ... this function.  Simplify logic.  Unify
+	IOSTAT, IOLENGTH and SIZE handling.
+
 2007-09-20  Christopher D. Rickett  <crickett@lanl.gov>
 
 	PR fortran/33497
diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index 1ecea88..901af92 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -1091,141 +1091,125 @@ match_ltag (const io_tag *tag, gfc_st_label ** label)
 }
 
 
-/* Do expression resolution and type-checking on an expression tag.  */
+/* Resolution of the FORMAT tag, to be called from resolve_tag.  */
 
 static try
-resolve_tag (const io_tag *tag, gfc_expr *e)
+resolve_tag_format (const gfc_expr *e)
 {
-  if (e == NULL)
-    return SUCCESS;
-
-  if (gfc_resolve_expr (e) == FAILURE)
-    return FAILURE;
-
-  if (e->ts.type != tag->type && tag != &tag_format)
+  if (e->expr_type == EXPR_CONSTANT
+      && (e->ts.type != BT_CHARACTER
+	  || e->ts.kind != gfc_default_character_kind))
     {
-      gfc_error ("%s tag at %L must be of type %s", tag->name,
-		 &e->where, gfc_basic_typename (tag->type));
+      gfc_error ("Constant expression in FORMAT tag at %L must be "
+		 "of type default CHARACTER", &e->where);
       return FAILURE;
     }
 
-  if (tag == &tag_format)
+  /* If e's rank is zero and e is not an element of an array, it should be
+     of integer or character type.  The integer variable should be
+     ASSIGNED.  */
+  if (e->symtree == NULL || e->symtree->n.sym->as == NULL
+      || e->symtree->n.sym->as->rank == 0)
     {
-      if (e->expr_type == EXPR_CONSTANT
-	  && (e->ts.type != BT_CHARACTER
-	      || e->ts.kind != gfc_default_character_kind))
+      if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER)
 	{
-	  gfc_error ("Constant expression in FORMAT tag at %L must be "
-		     "of type default CHARACTER", &e->where);
+	  gfc_error ("FORMAT tag at %L must be of type CHARACTER or INTEGER",
+		     &e->where);
 	  return FAILURE;
 	}
-
-      /* If e's rank is zero and e is not an element of an array, it should be
-	 of integer or character type.  The integer variable should be
-	 ASSIGNED.  */
-      if (e->symtree == NULL || e->symtree->n.sym->as == NULL
-	  || e->symtree->n.sym->as->rank == 0)
+      else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
 	{
-	  if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER)
-	    {
-	      gfc_error ("%s tag at %L must be of type %s or %s", tag->name,
-			 &e->where, gfc_basic_typename (BT_CHARACTER),
-			 gfc_basic_typename (BT_INTEGER));
-	      return FAILURE;
-	    }
-	  else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
-	    {
-	      if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGNED "
-				  "variable in FORMAT tag at %L", &e->where)
-		  == FAILURE)
-		return FAILURE;
-	      if (e->symtree->n.sym->attr.assign != 1)
-		{
-		  gfc_error ("Variable '%s' at %L has not been assigned a "
-			     "format label", e->symtree->n.sym->name,
-			     &e->where);
-		  return FAILURE;
-		}
-	    }
-	  else if (e->ts.type == BT_INTEGER)
+	  if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGNED "
+			      "variable in FORMAT tag at %L", &e->where)
+	      == FAILURE)
+	    return FAILURE;
+	  if (e->symtree->n.sym->attr.assign != 1)
 	    {
-	      gfc_error ("scalar '%s' FORMAT tag at %L is not an ASSIGNED "
-			 "variable", gfc_basic_typename (e->ts.type),
-			 &e->where);
+	      gfc_error ("Variable '%s' at %L has not been assigned a "
+			 "format label", e->symtree->n.sym->name, &e->where);
 	      return FAILURE;
 	    }
-
-	  return SUCCESS;
 	}
-      else
+      else if (e->ts.type == BT_INTEGER)
 	{
-	  /* if rank is nonzero, we allow the type to be character under
-	     GFC_STD_GNU and other type under GFC_STD_LEGACY. It may be
-	     assigned an Hollerith constant.  */
-	  if (e->ts.type == BT_CHARACTER)
-	    {
-	      if (gfc_notify_std (GFC_STD_GNU, "Extension: Character array "
-				  "in FORMAT tag at %L", &e->where)
-		  == FAILURE)
-		return FAILURE;
-	    }
-	  else
-	    {
-	      if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character "
-				  "in FORMAT tag at %L", &e->where)
-		  == FAILURE)
-		return FAILURE;
-	    }
-	  return SUCCESS;
+	  gfc_error ("Scalar '%s' in FORMAT tag at %L is not an ASSIGNED "
+		     "variable", gfc_basic_typename (e->ts.type), &e->where);
+	  return FAILURE;
 	}
+
+      return SUCCESS;
+    }
+
+  /* If rank is nonzero, we allow the type to be character under GFC_STD_GNU
+     and other type under GFC_STD_LEGACY. It may be assigned an Hollerith
+     constant.  */
+  if (e->ts.type == BT_CHARACTER)
+    {
+      if (gfc_notify_std (GFC_STD_GNU, "Extension: Character array "
+			  "in FORMAT tag at %L", &e->where) == FAILURE)
+	return FAILURE;
     }
   else
     {
-      if (e->rank != 0)
-	{
-	  gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
-	  return FAILURE;
-	}
+      if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character "
+			  "in FORMAT tag at %L", &e->where) == FAILURE)
+	return FAILURE;
+    }
 
-      if (tag == &tag_iomsg)
-	{
-	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IOMSG tag at %L",
-			      &e->where) == FAILURE)
-	    return FAILURE;
-	}
+  return SUCCESS;
+}
 
-      if (tag == &tag_iostat && e->ts.kind != gfc_default_integer_kind)
-	{
-	  if (gfc_notify_std (GFC_STD_GNU, "Fortran 95 requires default "
-			      "INTEGER in IOSTAT tag at %L", &e->where)
-	      == FAILURE)
-	    return FAILURE;
-	}
 
-      if (tag == &tag_size && e->ts.kind != gfc_default_integer_kind)
-	{
-	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
-			      "INTEGER in SIZE tag at %L", &e->where)
-	      == FAILURE)
-	    return FAILURE;
-	}
+/* Do expression resolution and type-checking on an expression tag.  */
 
-      if (tag == &tag_convert)
-	{
-	  if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L",
-			      &e->where) == FAILURE)
-	    return FAILURE;
-	}
-    
-      if (tag == &tag_iolength && e->ts.kind != gfc_default_integer_kind)
-	{
-	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
-			      "INTEGER in IOLENGTH tag at %L", &e->where)
-	      == FAILURE)
-	    return FAILURE;
-	}
+static try
+resolve_tag (const io_tag *tag, gfc_expr *e)
+{
+  if (e == NULL)
+    return SUCCESS;
+
+  if (gfc_resolve_expr (e) == FAILURE)
+    return FAILURE;
+
+  if (tag == &tag_format)
+    return resolve_tag_format (e);
+
+  if (e->ts.type != tag->type)
+    {
+      gfc_error ("%s tag at %L must be of type %s", tag->name,
+		 &e->where, gfc_basic_typename (tag->type));
+      return FAILURE;
     }
 
+  if (e->rank != 0)
+    {
+      gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
+      return FAILURE;
+    }
+
+  if (tag == &tag_iomsg)
+    {
+      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IOMSG tag at %L",
+			  &e->where) == FAILURE)
+	return FAILURE;
+    }
+
+  if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength)
+      && e->ts.kind != gfc_default_integer_kind)
+    {
+      if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
+			  "INTEGER in %s tag at %L", tag->name, &e->where)
+	  == FAILURE)
+	return FAILURE;
+    }
+
+  if (tag == &tag_convert)
+    {
+      if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L",
+			  &e->where) == FAILURE)
+	return FAILURE;
+    }
+  
   return SUCCESS;
 }