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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 29d8dd2debc5709f71db96605d5baa72e7e6544e..9e7ca3a389ef3ff76de9709c81dd6b9cbd60b8e9 100644 (file)
--- 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 1ecea88eb18143ce50baf4876a27c60c478cd2e7..901af922b953dcdb9e99450bc031a5189445a16c 100644 (file)
--- 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 52e2cdf778a6268f6aa739181230312ef044e5be..4521fe5adaad8764e8eb5c4f2c2ea97c6d2a6d34 100644 (file)
--- 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 5920ddf64347973511a550974c6ecb3bab752e94..1e5db3c3b5c6172913fffa6b44ce929ad90c9ff7 100644 (file)
--- 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 00306a0a7b403353935f87f79a85384001156350..05f52faae7651cf70d3cdf170565e6d7561b3aa8 100644 (file)
--- 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 1dc72d149c4fb35ffe8848a4fa0afde3df34b908..0f6aacaf004864296ef59c44f78d1dc84fc9ed54 100644 (file)
--- 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