fortran/

	PR fortran/23420
	* io.c (resolve_tag): Don't allow non-CHARACTER constants as formats.
	(match_io): Fix usage of gfc_find_symbol.
testsuite/
	PR fortran/23420
	* gfortran.dg/print_fmt_4.f: New.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@104454 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 4b8183cdab928f33c9ff1420aa3c5c40be6bc805..13af14bca7439f18c7705d7ed573f57b9e5103fa 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2005-09-20  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+       PR fortran/23420
+       * io.c (resolve_tag): Don't allow non-CHARACTER constants as formats.
+       (match_io): Fix usage of gfc_find_symbol.
+
 2005-09-20  Jakub Jelinek  <jakub@redhat.com>
 
        PR fortran/23663

diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index 95abbc5ff52be0652bb4111b0393ebbf0333ccb8..9f459c683631b017a37d94c7cbb24b4da548e81a 100644 (file)
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -979,6 +979,15 @@ resolve_tag (const io_tag * tag, gfc_expr * e)
 
   if (tag == &tag_format)
     {
+      if (e->expr_type == EXPR_CONSTANT
+         && (e->ts.type != BT_CHARACTER
+             || e->ts.kind != gfc_default_character_kind))
+       {
+         gfc_error ("Constant expression in FORMAT tag at %L must be "
+                    "of type default CHARACTER", &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.  */
@@ -2158,51 +2167,51 @@ match_io (io_kind k)
 
   comma_flag = 0;
   current_dt = dt = gfc_getmem (sizeof (gfc_dt));
-
   if (gfc_match_char ('(') == MATCH_NO)
     {
+      where = gfc_current_locus;
       if (k == M_WRITE)
        goto syntax;
-      else if (k == M_PRINT 
-              && (gfc_current_form == FORM_FIXED
-                  || gfc_peek_char () == ' '))
+      else if (k == M_PRINT)
        {
          /* Treat the non-standard case of PRINT namelist.  */
-         where = gfc_current_locus;
-         if ((gfc_match_name (name) == MATCH_YES)
-             && !gfc_find_symbol (name, NULL, 1, &sym)
-             && sym->attr.flavor == FL_NAMELIST)
+         if ((gfc_current_form == FORM_FIXED || gfc_peek_char () == ' ')
+             && gfc_match_name (name) == MATCH_YES)
            {
-             if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
-                                 "%C is an extension") == FAILURE)
+             gfc_find_symbol (name, NULL, 1, &sym);
+             if (sym && sym->attr.flavor == FL_NAMELIST)
                {
-                 m = MATCH_ERROR;
-                 goto cleanup;
+                 if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
+                                     "%C is an extension") == FAILURE)
+                   {
+                     m = MATCH_ERROR;
+                     goto cleanup;
+                   }
+                 if (gfc_match_eos () == MATCH_NO)
+                   {
+                     gfc_error ("Namelist followed by I/O list at %C");
+                     m = MATCH_ERROR;
+                     goto cleanup;
+                   }
+
+                 dt->io_unit = default_unit (k);
+                 dt->namelist = sym;
+                 goto get_io_list;
                }
-             if (gfc_match_eos () == MATCH_NO)
-               {
-                 gfc_error ("Namelist followed by I/O list at %C");
-                 m = MATCH_ERROR;
-                 goto cleanup;
-               }
-
-             dt->io_unit = default_unit (k);
-             dt->namelist = sym;
-             goto get_io_list;
+             else
+               gfc_current_locus = where;
            }
-         else
-           gfc_current_locus = where;
        }
 
       if (gfc_current_form == FORM_FREE)
-       {
-         c = gfc_peek_char();
-         if (c != ' ' && c != '*' && c != '\'' && c != '"')
-           {
-             m = MATCH_NO;
-             goto cleanup;
-           }
-       }
+       {
+         c = gfc_peek_char();
+         if (c != ' ' && c != '*' && c != '\'' && c != '"')
+           {
+             m = MATCH_NO;
+             goto cleanup;
+           }
+       }
 
       m = match_dt_format (dt);
       if (m == MATCH_ERROR)
@@ -2240,17 +2249,20 @@ match_io (io_kind k)
 
   where = gfc_current_locus;
 
-  if (gfc_match_name (name) == MATCH_YES
-      && !gfc_find_symbol (name, NULL, 1, &sym)
-      && sym->attr.flavor == FL_NAMELIST)
+  m = gfc_match_name (name);
+  if (m == MATCH_YES)
     {
-      dt->namelist = sym;
-      if (k == M_READ && check_namelist (sym))
+      gfc_find_symbol (name, NULL, 1, &sym);
+      if (sym && sym->attr.flavor == FL_NAMELIST)
        {
-         m = MATCH_ERROR;
-         goto cleanup;
+         dt->namelist = sym;
+         if (k == M_READ && check_namelist (sym))
+           {
+             m = MATCH_ERROR;
+             goto cleanup;
+           }
+         goto next;
        }
-      goto next;
     }
 
   gfc_current_locus = where;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index eddca508c69aeeca100cc92466bf625676b53843..f91da85168639c1edb3c73e36c34f25a96173f19 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2005-09-20  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
+
+       PR fortran/23420
+       * gfortran.dg/print_fmt_4.f: New.
+
 2005-09-20  Jakub Jelinek  <jakub@redhat.com>
 
        PR fortran/23663

diff --git a/gcc/testsuite/gfortran.dg/print_fmt_4.f b/gcc/testsuite/gfortran.dg/print_fmt_4.f
new file mode 100644 (file)
index 0000000..f8978eb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/print_fmt_4.f
@@ -0,0 +1,3 @@
+! { dg-do compile }
+      print precision(1.) ! { dg-error "must be of type default CHARACTER" }
+      end