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

6 files changed, 110 insertions, 110 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;
 }
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 52e2cdf..4521fe5 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2007-09-20  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+	* 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.
+
 2007-09-20  Christopher D. Rickett  <crickett@lanl.gov>
 
 	PR fortran/33497
diff --git a/gcc/testsuite/gfortran.dg/g77/19981216-0.f b/gcc/testsuite/gfortran.dg/g77/19981216-0.f
index 5920ddf..1e5db3c 100644
--- a/gcc/testsuite/gfortran.dg/g77/19981216-0.f
+++ b/gcc/testsuite/gfortran.dg/g77/19981216-0.f
@@ -29,7 +29,7 @@ c { dg-do compile }
 
         name = 'blah'
         open(unit=8,status='unknown',file=name,form='formatted',
-     F       iostat=ios) ! { dg-warning "INTEGER in IOSTAT" }
+     F       iostat=ios)
 
       END
 * -------------------------------------------
diff --git a/gcc/testsuite/gfortran.dg/io_constraints_1.f90 b/gcc/testsuite/gfortran.dg/io_constraints_1.f90
index 00306a0..05f52fa 100644
--- a/gcc/testsuite/gfortran.dg/io_constraints_1.f90
+++ b/gcc/testsuite/gfortran.dg/io_constraints_1.f90
@@ -1,4 +1,5 @@
 ! { dg-do compile }
+! { dg-options "-std=f95" }
 ! Part I of the test  of the IO constraints patch, which fixes PRs:
 ! PRs 25053, 25063, 25064, 25066, 25067, 25068, 25069, 25307 and 20862.
 !
@@ -20,7 +21,7 @@ contains
   subroutine foo (i)
     integer :: i
     write (*, 100) i
- 100 format (1h , "i=", i6)                     ! This is OK.
+ 100 format (1h , "i=", i6)                     ! { dg-warning "The H format specifier at ... is a Fortran 95 deleted feature" }
   end subroutine foo
 
 end module global
diff --git a/gcc/testsuite/gfortran.dg/iostat_3.f90 b/gcc/testsuite/gfortran.dg/iostat_3.f90
index 1dc72d1..0f6aaca 100644
--- a/gcc/testsuite/gfortran.dg/iostat_3.f90
+++ b/gcc/testsuite/gfortran.dg/iostat_3.f90
@@ -1,4 +1,5 @@
 ! { dg-do compile }
+! { dg-options "-std=f95" }
 ! Testcase for PR libfortran/25068
   real :: u
   integer(kind=8) :: i