OSDN Git Service

2006-05-29 Jerry DeLisle <jvdelisle@gcc.gnu.org>
[pf3gnuchains/gcc-fork.git] / gcc / fortran / io.c
index 8230fa9..aab5d39 100644 (file)
@@ -1,6 +1,6 @@
 /* Deal with I/O statements & related stuff.
-   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
-   Inc.
+   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
+   Foundation, Inc.
    Contributed by Andy Vaught
 
 This file is part of GCC.
@@ -17,8 +17,8 @@ for more details.
 
 You should have received a copy of the GNU General Public License
 along with GCC; see the file COPYING.  If not, write to the Free
-Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.  */
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.  */
 
 #include "config.h"
 #include "system.h"
@@ -28,8 +28,8 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
 #include "parse.h"
 
 gfc_st_label format_asterisk =
-  { -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL, 0,
-    {NULL, NULL}, NULL, NULL};
+  {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL,
+   0, {NULL, NULL}};
 
 typedef struct
 {
@@ -53,6 +53,7 @@ static const io_tag
        tag_advance     = {"ADVANCE", " advance = %e", BT_CHARACTER},
        tag_rec         = {"REC", " rec = %e", BT_INTEGER},
        tag_format      = {"FORMAT", NULL, BT_CHARACTER},
+       tag_iomsg       = {"IOMSG", " iomsg = %e", BT_CHARACTER},
        tag_iostat      = {"IOSTAT", " iostat = %v", BT_INTEGER},
        tag_size        = {"SIZE", " size = %v", BT_INTEGER},
        tag_exist       = {"EXIST", " exist = %v", BT_LOGICAL},
@@ -77,6 +78,7 @@ static const io_tag
        tag_s_delim     = {"DELIM", " delim = %v", BT_CHARACTER},
        tag_s_pad       = {"PAD", " pad = %v", BT_CHARACTER},
        tag_iolength    = {"IOLENGTH", " iolength = %v", BT_INTEGER},
+       tag_convert     = {"CONVERT", " convert = %e", BT_CHARACTER},
        tag_err         = {"ERR", " err = %l", BT_UNKNOWN},
        tag_end         = {"END", " end = %l", BT_UNKNOWN},
        tag_eor         = {"EOR", " eor = %l", BT_UNKNOWN};
@@ -152,6 +154,20 @@ unget_char (void)
   use_last_char = 1;
 }
 
+/* Eat up the spaces and return a character. */
+
+static char
+next_char_not_space(void)
+{
+  char c;
+  do
+    {
+      c = next_char (0);
+    }
+  while (gfc_is_whitespace (c));
+  return c;
+}
+
 static int value = 0;
 
 /* Simple lexical analyzer for getting the next token in a FORMAT
@@ -172,19 +188,15 @@ format_lex (void)
       return token;
     }
 
-  do
-    {
-      c = next_char (0);
-    }
-  while (gfc_is_whitespace (c));
-
+  c = next_char_not_space ();
+  
   negative_flag = 0;
   switch (c)
     {
     case '-':
       negative_flag = 1;
     case '+':
-      c = next_char (0);
+      c = next_char_not_space ();
       if (!ISDIGIT (c))
        {
          token = FMT_UNKNOWN;
@@ -195,7 +207,7 @@ format_lex (void)
 
       do
        {
-         c = next_char (0);
+         c = next_char_not_space ();
           if(ISDIGIT (c))
             value = 10 * value + c - '0';
        }
@@ -225,7 +237,7 @@ format_lex (void)
 
       do
        {
-         c = next_char (0);
+         c = next_char_not_space ();
          if (c != '0')
            zflag = 0;
           if (ISDIGIT (c))
@@ -258,7 +270,7 @@ format_lex (void)
       break;
 
     case 'T':
-      c = next_char (0);
+      c = next_char_not_space ();
       if (c != 'L' && c != 'R')
        unget_char ();
 
@@ -278,7 +290,7 @@ format_lex (void)
       break;
 
     case 'S':
-      c = next_char (0);
+      c = next_char_not_space ();
       if (c != 'P' && c != 'S')
        unget_char ();
 
@@ -286,7 +298,7 @@ format_lex (void)
       break;
 
     case 'B':
-      c = next_char (0);
+      c = next_char_not_space ();
       if (c == 'N' || c == 'Z')
        token = FMT_BLANK;
       else
@@ -348,7 +360,7 @@ format_lex (void)
       break;
 
     case 'E':
-      c = next_char (0);
+      c = next_char_not_space ();
       if (c == 'N' || c == 'S')
        token = FMT_EXT;
       else
@@ -400,11 +412,10 @@ format_lex (void)
 static try
 check_format (void)
 {
-  const char *posint_required    = "Positive width required";
-  const char *period_required    = "Period required";
-  const char *nonneg_required    = "Nonnegative width required";
-  const char *unexpected_element  = "Unexpected element";
-  const char *unexpected_end     = "Unexpected end of format string";
+  const char *posint_required    = _("Positive width required");
+  const char *nonneg_required    = _("Nonnegative width required");
+  const char *unexpected_element  = _("Unexpected element");
+  const char *unexpected_end     = _("Unexpected end of format string");
 
   const char *error;
   format_token t, u;
@@ -421,7 +432,7 @@ check_format (void)
   t = format_lex ();
   if (t != FMT_LPAREN)
     {
-      error = "Missing leading left parenthesis";
+      error = _("Missing leading left parenthesis");
       goto syntax;
     }
 
@@ -433,6 +444,7 @@ check_format (void)
 format_item:
   /* In this state, the next thing has to be a format item.  */
   t = format_lex ();
+format_item_1:
   switch (t)
     {
     case FMT_POSINT:
@@ -458,7 +470,7 @@ format_item:
       t = format_lex ();
       if (t != FMT_P)
        {
-         error = "Expected P edit descriptor";
+         error = _("Expected P edit descriptor");
          goto syntax;
        }
 
@@ -466,7 +478,7 @@ format_item:
 
     case FMT_P:
       /* P requires a prior number.  */
-      error = "P descriptor requires leading scale factor";
+      error = _("P descriptor requires leading scale factor");
       goto syntax;
 
     case FMT_X:
@@ -490,9 +502,13 @@ format_item:
 
     case FMT_DOLLAR:
       t = format_lex ();
+
+      if (gfc_notify_std (GFC_STD_GNU, "Extension: $ descriptor at %C")
+          == FAILURE)
+        return FAILURE;
       if (t != FMT_RPAREN || level > 0)
        {
-         error = "$ must the last specifier";
+         error = _("$ must be the last specifier");
          goto syntax;
        }
 
@@ -537,7 +553,7 @@ data_desc:
          t = format_lex ();
          if (t == FMT_POSINT)
            {
-             error = "Repeat count cannot follow P descriptor";
+             error = _("Repeat count cannot follow P descriptor");
              goto syntax;
            }
 
@@ -552,8 +568,26 @@ data_desc:
       if (t == FMT_POSINT)
        break;
 
-      error = posint_required;
-      goto syntax;
+      switch (gfc_notification_std (GFC_STD_GNU))
+       {
+         case WARNING:
+           gfc_warning
+             ("Extension: Missing positive width after L descriptor at %C");
+           saved_token = t;
+           break;
+
+         case ERROR:
+           error = posint_required;
+           goto syntax;
+
+         case SILENT:
+           saved_token = t;
+           break;
+
+         default:
+           gcc_unreachable ();
+       }
+      break;
 
     case FMT_A:
       t = format_lex ();
@@ -575,8 +609,13 @@ data_desc:
       u = format_lex ();
       if (u != FMT_PERIOD)
        {
-         error = period_required;
-         goto syntax;
+         /* Warn if -std=legacy, otherwise error.  */
+         if (gfc_option.warn_std != 0)
+           gfc_error_now ("Period required in format specifier at %C");
+         else
+           gfc_warning ("Period required in format specifier at %C");
+         saved_token = u;
+         break;
        }
 
       u = format_lex ();
@@ -600,7 +639,7 @@ data_desc:
          u = format_lex ();
          if (u != FMT_POSINT)
            {
-             error = "Positive exponent width required";
+             error = _("Positive exponent width required");
              goto syntax;
            }
        }
@@ -618,8 +657,13 @@ data_desc:
       t = format_lex ();
       if (t != FMT_PERIOD)
        {
-         error = period_required;
-         goto syntax;
+         /* Warn if -std=legacy, otherwise error.  */
+          if (gfc_option.warn_std != 0)
+           gfc_error_now ("Period required in format specifier at %C");
+         else
+           gfc_warning ("Period required in format specifier at %C");
+         saved_token = t;
+         break;
        }
 
       t = format_lex ();
@@ -641,7 +685,7 @@ data_desc:
       {
         while(repeat >0)
          {
-          next_char(0);
+          next_char(1);
           repeat -- ;
          }
       }
@@ -701,8 +745,10 @@ between_desc:
       goto syntax;
 
     default:
-      error = "Missing comma";
-      goto syntax;
+      if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %C")
+         == FAILURE)
+       return FAILURE;
+      goto format_item_1;
     }
 
 optional_comma:
@@ -807,6 +853,13 @@ gfc_match_format (void)
   gfc_expr *e;
   locus start;
 
+  if (gfc_current_ns->proc_name
+       && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+    {
+      gfc_error ("Format statement in module main block at %C.");
+      return MATCH_ERROR;
+    }
+
   if (gfc_statement_label == NULL)
     {
       gfc_error ("Missing format label at %C");
@@ -946,6 +999,10 @@ match_ltag (const io_tag * tag, gfc_st_label ** label)
       return MATCH_ERROR;
     }
 
+  if (m == MATCH_YES 
+      && gfc_reference_st_label (*label, ST_LABEL_TARGET) == FAILURE)
+    return MATCH_ERROR;
+
   return m;
 }
 
@@ -962,25 +1019,73 @@ resolve_tag (const io_tag * tag, gfc_expr * e)
   if (gfc_resolve_expr (e) == FAILURE)
     return FAILURE;
 
-  if (e->ts.type != tag->type)
+  if (e->ts.type != tag->type && tag != &tag_format)
     {
-      /* Format label can be integer varibale.  */
-      if (tag != &tag_format || e->ts.type != BT_INTEGER)
-        {
-          gfc_error ("%s tag at %L must be of type %s", tag->name, &e->where,
-                    gfc_basic_typename (tag->type));
-          return FAILURE;
-        }
+      gfc_error ("%s tag at %L must be of type %s", tag->name,
+               &e->where, gfc_basic_typename (tag->type));
+      return FAILURE;
     }
 
   if (tag == &tag_format)
     {
-      if (e->rank != 1 && e->rank != 0)
+      if (e->expr_type == EXPR_CONSTANT
+         && (e->ts.type != BT_CHARACTER
+             || e->ts.kind != gfc_default_character_kind))
        {
-         gfc_error ("FORMAT tag at %L cannot be array of strings",
-                    &e->where);
+         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.  */
+      if (e->symtree == NULL || e->symtree->n.sym->as == NULL
+               || e->symtree->n.sym->as->rank == 0)
+       {
+         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,
+                       "Obsolete: 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;
+               }
+           }
+         return SUCCESS;
+       }
+      else
+       {
+         /* 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;
+       }
     }
   else
     {
@@ -989,6 +1094,36 @@ resolve_tag (const io_tag * tag, gfc_expr * e)
          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 && 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_GNU, "Fortran 95 requires default "
+                             "INTEGER in SIZE tag at %L",
+                             &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;
@@ -1005,6 +1140,9 @@ match_open_element (gfc_open * open)
   m = match_etag (&tag_unit, &open->unit);
   if (m != MATCH_NO)
     return m;
+  m = match_out_tag (&tag_iomsg, &open->iomsg);
+  if (m != MATCH_NO)
+    return m;
   m = match_out_tag (&tag_iostat, &open->iostat);
   if (m != MATCH_NO)
     return m;
@@ -1041,6 +1179,9 @@ match_open_element (gfc_open * open)
   m = match_ltag (&tag_err, &open->err);
   if (m != MATCH_NO)
     return m;
+  m = match_etag (&tag_convert, &open->convert);
+  if (m != MATCH_NO)
+    return m;
 
   return MATCH_NO;
 }
@@ -1056,6 +1197,7 @@ gfc_free_open (gfc_open * open)
     return;
 
   gfc_free_expr (open->unit);
+  gfc_free_expr (open->iomsg);
   gfc_free_expr (open->iostat);
   gfc_free_expr (open->file);
   gfc_free_expr (open->status);
@@ -1067,6 +1209,7 @@ gfc_free_open (gfc_open * open)
   gfc_free_expr (open->action);
   gfc_free_expr (open->delim);
   gfc_free_expr (open->pad);
+  gfc_free_expr (open->convert);
 
   gfc_free (open);
 }
@@ -1079,9 +1222,11 @@ gfc_resolve_open (gfc_open * open)
 {
 
   RESOLVE_TAG (&tag_unit, open->unit);
+  RESOLVE_TAG (&tag_iomsg, open->iomsg);
   RESOLVE_TAG (&tag_iostat, open->iostat);
   RESOLVE_TAG (&tag_file, open->file);
   RESOLVE_TAG (&tag_status, open->status);
+  RESOLVE_TAG (&tag_e_access, open->access);
   RESOLVE_TAG (&tag_e_form, open->form);
   RESOLVE_TAG (&tag_e_recl, open->recl);
 
@@ -1090,6 +1235,7 @@ gfc_resolve_open (gfc_open * open)
   RESOLVE_TAG (&tag_e_action, open->action);
   RESOLVE_TAG (&tag_e_delim, open->delim);
   RESOLVE_TAG (&tag_e_pad, open->pad);
+  RESOLVE_TAG (&tag_convert, open->convert);
 
   if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE)
     return FAILURE;
@@ -1171,6 +1317,7 @@ gfc_free_close (gfc_close * close)
     return;
 
   gfc_free_expr (close->unit);
+  gfc_free_expr (close->iomsg);
   gfc_free_expr (close->iostat);
   gfc_free_expr (close->status);
 
@@ -1191,6 +1338,9 @@ match_close_element (gfc_close * close)
   m = match_etag (&tag_status, &close->status);
   if (m != MATCH_NO)
     return m;
+  m = match_out_tag (&tag_iomsg, &close->iomsg);
+  if (m != MATCH_NO)
+    return m;
   m = match_out_tag (&tag_iostat, &close->iostat);
   if (m != MATCH_NO)
     return m;
@@ -1272,6 +1422,7 @@ gfc_resolve_close (gfc_close * close)
 {
 
   RESOLVE_TAG (&tag_unit, close->unit);
+  RESOLVE_TAG (&tag_iomsg, close->iomsg);
   RESOLVE_TAG (&tag_iostat, close->iostat);
   RESOLVE_TAG (&tag_status, close->status);
 
@@ -1289,12 +1440,13 @@ gfc_free_filepos (gfc_filepos * fp)
 {
 
   gfc_free_expr (fp->unit);
+  gfc_free_expr (fp->iomsg);
   gfc_free_expr (fp->iostat);
   gfc_free (fp);
 }
 
 
-/* Match elements of a REWIND, BACKSPACE or ENDFILE statement.  */
+/* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement.  */
 
 static match
 match_file_element (gfc_filepos * fp)
@@ -1304,6 +1456,9 @@ match_file_element (gfc_filepos * fp)
   m = match_etag (&tag_unit, &fp->unit);
   if (m != MATCH_NO)
     return m;
+  m = match_out_tag (&tag_iomsg, &fp->iomsg);
+  if (m != MATCH_NO)
+    return m;
   m = match_out_tag (&tag_iostat, &fp->iostat);
   if (m != MATCH_NO)
     return m;
@@ -1316,7 +1471,7 @@ match_file_element (gfc_filepos * fp)
 
 
 /* Match the second half of the file-positioning statements, REWIND,
-   BACKSPACE or ENDFILE.  */
+   BACKSPACE, ENDFILE, or the FLUSH statement.  */
 
 static match
 match_filepos (gfc_statement st, gfc_exec_op op)
@@ -1393,6 +1548,8 @@ gfc_resolve_filepos (gfc_filepos * fp)
 {
 
   RESOLVE_TAG (&tag_unit, fp->unit);
+  RESOLVE_TAG (&tag_iostat, fp->iostat);
+  RESOLVE_TAG (&tag_iomsg, fp->iomsg);
   if (gfc_reference_st_label (fp->err, ST_LABEL_TARGET) == FAILURE)
     return FAILURE;
 
@@ -1400,8 +1557,8 @@ gfc_resolve_filepos (gfc_filepos * fp)
 }
 
 
-/* Match the file positioning statements: ENDFILE, BACKSPACE or
-   REWIND.  */
+/* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
+   and the FLUSH statement.  */
 
 match
 gfc_match_endfile (void)
@@ -1424,6 +1581,14 @@ gfc_match_rewind (void)
   return match_filepos (ST_REWIND, EXEC_REWIND);
 }
 
+match
+gfc_match_flush (void)
+{
+  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: FLUSH statement at %C") == FAILURE)
+    return MATCH_ERROR;
+
+  return match_filepos (ST_FLUSH, EXEC_FLUSH);
+}
 
 /******************** Data Transfer Statements *********************/
 
@@ -1504,7 +1669,7 @@ match_dt_format (gfc_dt * dt)
       return MATCH_YES;
     }
 
-  if (gfc_match_st_label (&label, 0) == MATCH_YES)
+  if (gfc_match_st_label (&label) == MATCH_YES)
     {
       if (dt->format_expr != NULL || dt->format_label != NULL)
        {
@@ -1526,9 +1691,6 @@ match_dt_format (gfc_dt * dt)
          gfc_free_expr (e);
          goto conflict;
        }
-      if (e->ts.type == BT_INTEGER && e->rank == 0)
-        e->symtree->n.sym->attr.assign = 1;
-
       dt->format_expr = e;
       return MATCH_YES;
     }
@@ -1615,10 +1777,15 @@ match_dt_element (io_kind k, gfc_dt * dt)
   m = match_etag (&tag_rec, &dt->rec);
   if (m != MATCH_NO)
     return m;
+  m = match_out_tag (&tag_iomsg, &dt->iomsg);
+  if (m != MATCH_NO)
+    return m;
   m = match_out_tag (&tag_iostat, &dt->iostat);
   if (m != MATCH_NO)
     return m;
   m = match_ltag (&tag_err, &dt->err);
+  if (m == MATCH_YES)
+    dt->err_where = gfc_current_locus;
   if (m != MATCH_NO)
     return m;
   m = match_etag (&tag_advance, &dt->advance);
@@ -1630,7 +1797,14 @@ match_dt_element (io_kind k, gfc_dt * dt)
 
   m = match_ltag (&tag_end, &dt->end);
   if (m == MATCH_YES)
-    dt->end_where = gfc_current_locus;
+    {
+      if (k == M_WRITE)
+       {
+         gfc_error ("END tag at %C not allowed in output statement");
+         return MATCH_ERROR;
+       }
+      dt->end_where = gfc_current_locus;
+    }
   if (m != MATCH_NO)
     return m;
 
@@ -1657,6 +1831,7 @@ gfc_free_dt (gfc_dt * dt)
   gfc_free_expr (dt->format_expr);
   gfc_free_expr (dt->rec);
   gfc_free_expr (dt->advance);
+  gfc_free_expr (dt->iomsg);
   gfc_free_expr (dt->iostat);
   gfc_free_expr (dt->size);
 
@@ -1674,6 +1849,7 @@ gfc_resolve_dt (gfc_dt * dt)
   RESOLVE_TAG (&tag_format, dt->format_expr);
   RESOLVE_TAG (&tag_rec, dt->rec);
   RESOLVE_TAG (&tag_advance, dt->advance);
+  RESOLVE_TAG (&tag_iomsg, dt->iomsg);
   RESOLVE_TAG (&tag_iostat, dt->iostat);
   RESOLVE_TAG (&tag_size, dt->size);
 
@@ -1689,87 +1865,58 @@ gfc_resolve_dt (gfc_dt * dt)
       return FAILURE;
     }
 
-  /* Sanity checks on data transfer statements.  */
   if (e->ts.type == BT_CHARACTER)
     {
-      if (dt->rec != NULL)
+      if (gfc_has_vector_index (e))
        {
-         gfc_error ("REC tag at %L is incompatible with internal file",
-                    &dt->rec->where);
-         return FAILURE;
-       }
-
-      if (dt->namelist != NULL)
-       {
-         gfc_error ("Internal file at %L is incompatible with namelist",
-                    &dt->io_unit->where);
+         gfc_error ("Internal unit with vector subscript at %L",
+                    &e->where);
          return FAILURE;
        }
+    }
 
-      if (dt->advance != NULL)
-       {
-         gfc_error ("ADVANCE tag at %L is incompatible with internal file",
-                    &dt->advance->where);
-         return FAILURE;
-       }
+  if (e->rank && e->ts.type != BT_CHARACTER)
+    {
+      gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
+      return FAILURE;
     }
 
-  if (dt->rec != NULL)
+  if (dt->err)
     {
-      if (dt->end != NULL)
+      if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
+       return FAILURE;
+      if (dt->err->defined == ST_LABEL_UNKNOWN)
        {
-         gfc_error ("REC tag at %L is incompatible with END tag",
-                    &dt->rec->where);
+         gfc_error ("ERR tag label %d at %L not defined",
+                     dt->err->value, &dt->err_where);
          return FAILURE;
        }
+    }
 
-      if (dt->format_label == &format_asterisk)
+  if (dt->end)
+    {
+      if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE)
+       return FAILURE;
+      if (dt->end->defined == ST_LABEL_UNKNOWN)
        {
-         gfc_error
-           ("END tag at %L is incompatible with list directed format (*)",
-            &dt->end_where);
+         gfc_error ("END tag label %d at %L not defined",
+                     dt->end->value, &dt->end_where);
          return FAILURE;
        }
+    }
 
-      if (dt->namelist != NULL)
+  if (dt->eor)
+    {
+      if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE)
+       return FAILURE;
+      if (dt->eor->defined == ST_LABEL_UNKNOWN)
        {
-         gfc_error ("REC tag at %L is incompatible with namelist",
-                    &dt->rec->where);
+         gfc_error ("EOR tag label %d at %L not defined",
+                     dt->eor->value, &dt->eor_where);
          return FAILURE;
        }
     }
 
-  if (dt->advance != NULL && dt->format_label == &format_asterisk)
-    {
-      gfc_error ("ADVANCE tag at %L is incompatible with list directed "
-                "format (*)", &dt->advance->where);
-      return FAILURE;
-    }
-
-  if (dt->eor != 0 && dt->advance == NULL)
-    {
-      gfc_error ("EOR tag at %L requires an ADVANCE tag", &dt->eor_where);
-      return FAILURE;
-    }
-
-  if (dt->size != NULL && dt->advance == NULL)
-    {
-      gfc_error ("SIZE tag at %L requires an ADVANCE tag", &dt->size->where);
-      return FAILURE;
-    }
-
-  /* TODO: Make sure the ADVANCE tag is 'yes' or 'no' if it is a string
-     constant.  */
-
-  if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
-    return FAILURE;
-
-  if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE)
-    return FAILURE;
-
-  if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE)
-    return FAILURE;
-
   /* Check the format label actually exists.  */
   if (dt->format_label && dt->format_label != &format_asterisk
       && dt->format_label->defined == ST_LABEL_UNKNOWN)
@@ -2045,7 +2192,7 @@ terminate_io (gfc_code * io_code)
   gfc_code *c;
 
   if (io_code == NULL)
-    io_code = &new_st;
+    io_code = new_st.block;
 
   c = gfc_get_code ();
   c->op = EXEC_DT_END;
@@ -2056,6 +2203,169 @@ terminate_io (gfc_code * io_code)
 }
 
 
+/* Check the constraints for a data transfer statement.  The majority of the
+   constraints appearing in 9.4 of the standard appear here.  Some are handled
+   in resolve_tag and others in gfc_resolve_dt.  */
+
+static match
+check_io_constraints (io_kind k, gfc_dt *dt, gfc_code * io_code, locus * spec_end)
+{
+#define io_constraint(condition,msg,arg)\
+if (condition) \
+  {\
+    gfc_error(msg,arg);\
+    m = MATCH_ERROR;\
+  }
+
+  match m;
+  gfc_expr * expr;
+  gfc_symbol * sym = NULL;
+
+  m = MATCH_YES;
+
+  expr = dt->io_unit;
+  if (expr && expr->expr_type == EXPR_VARIABLE
+       && expr->ts.type == BT_CHARACTER)
+    {
+      sym = expr->symtree->n.sym;
+
+      io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
+                    "Internal file at %L must not be INTENT(IN)",
+                    &expr->where);
+
+      io_constraint (gfc_has_vector_index (dt->io_unit),
+                    "Internal file incompatible with vector subscript at %L",
+                    &expr->where);
+
+      io_constraint (dt->rec != NULL,
+                    "REC tag at %L is incompatible with internal file",
+                    &dt->rec->where);
+
+      io_constraint (dt->namelist != NULL,
+                    "Internal file at %L is incompatible with namelist",
+                    &expr->where);
+
+      io_constraint (dt->advance != NULL,
+                    "ADVANCE tag at %L is incompatible with internal file",
+                    &dt->advance->where);
+    }
+
+  if (expr && expr->ts.type != BT_CHARACTER)
+    {
+
+      io_constraint (gfc_pure (NULL)
+                      && (k == M_READ || k == M_WRITE),
+                    "IO UNIT in %s statement at %C must be "
+                    "an internal file in a PURE procedure",
+                    io_kind_name (k));
+    }
+
+
+  if (k != M_READ)
+    {
+      io_constraint (dt->end,
+                    "END tag not allowed with output at %L",
+                    &dt->end_where);
+
+      io_constraint (dt->eor,
+                    "EOR tag not allowed with output at %L",
+                    &dt->eor_where);
+
+      io_constraint (k != M_READ && dt->size,
+                    "SIZE=specifier not allowed with output at %L",
+                    &dt->size->where);
+    }
+  else
+    {
+      io_constraint (dt->size && dt->advance == NULL,
+                    "SIZE tag at %L requires an ADVANCE tag",
+                    &dt->size->where);
+
+      io_constraint (dt->eor && dt->advance == NULL,
+                    "EOR tag at %L requires an ADVANCE tag",
+                    &dt->eor_where);
+    }
+
+
+
+  if (dt->namelist)
+    {
+      io_constraint (io_code && dt->namelist,
+                    "NAMELIST cannot be followed by IO-list at %L",
+                    &io_code->loc);
+
+      io_constraint (dt->format_expr,
+                    "IO spec-list cannot contain both NAMELIST group name "
+                    "and format specification at %L.",
+                    &dt->format_expr->where);
+
+      io_constraint (dt->format_label,
+                    "IO spec-list cannot contain both NAMELIST group name "
+                    "and format label at %L", spec_end);
+
+      io_constraint (dt->rec,
+                    "NAMELIST IO is not allowed with a REC=specifier "
+                    "at %L.", &dt->rec->where);
+
+      io_constraint (dt->advance,
+                    "NAMELIST IO is not allowed with a ADVANCE=specifier "
+                    "at %L.", &dt->advance->where);
+    }
+
+  if (dt->rec)
+    {
+      io_constraint (dt->end,
+                    "An END tag is not allowed with a "
+                    "REC=specifier at %L.", &dt->end_where);
+
+
+      io_constraint (dt->format_label == &format_asterisk,
+                    "FMT=* is not allowed with a REC=specifier "
+                    "at %L.", spec_end);
+    }
+
+  if (dt->advance)
+    {
+      int not_yes, not_no;
+      expr = dt->advance;
+
+      io_constraint (dt->format_label == &format_asterisk,
+                    "List directed format(*) is not allowed with a "
+                    "ADVANCE=specifier at %L.", &expr->where);
+
+      if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
+       {
+         const char * advance = expr->value.character.string;
+         not_no = strncasecmp (advance, "no", 2) != 0;
+         not_yes = strncasecmp (advance, "yes", 2) != 0;
+       }
+      else
+       {
+         not_no = 0;
+         not_yes = 0;
+       }
+
+      io_constraint (not_no && not_yes,
+                    "ADVANCE=specifier at %L must have value = "
+                    "YES or NO.", &expr->where);
+
+      io_constraint (dt->size && not_no && k == M_READ,
+                    "SIZE tag at %L requires an ADVANCE = 'NO'",
+                    &dt->size->where);
+
+      io_constraint (dt->eor && not_no && k == M_READ,
+                    "EOR tag at %L requires an ADVANCE = 'NO'",
+                    &dt->eor_where);      
+    }
+
+  expr = dt->format_expr;
+  if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
+    check_format_string (expr);
+
+  return m;
+}
+#undef io_constraint
+
 /* Match a READ, WRITE or PRINT statement.  */
 
 static match
@@ -2064,29 +2374,54 @@ match_io (io_kind k)
   char name[GFC_MAX_SYMBOL_LEN + 1];
   gfc_code *io_code;
   gfc_symbol *sym;
-  gfc_expr *expr;
   int comma_flag, c;
   locus where;
+  locus spec_end;
   gfc_dt *dt;
   match m;
 
+  where = gfc_current_locus;
   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)
+       {
+         /* Treat the non-standard case of PRINT namelist.  */
+         if ((gfc_current_form == FORM_FIXED || gfc_peek_char () == ' ')
+             && gfc_match_name (name) == MATCH_YES)
+           {
+             gfc_find_symbol (name, NULL, 1, &sym);
+             if (sym && sym->attr.flavor == FL_NAMELIST)
+               {
+                 if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
+                                     "%C is an extension") == FAILURE)
+                   {
+                     m = MATCH_ERROR;
+                     goto cleanup;
+                   }
+
+                 dt->io_unit = default_unit (k);
+                 dt->namelist = sym;
+                 goto get_io_list;
+               }
+             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)
@@ -2098,6 +2433,12 @@ match_io (io_kind k)
       dt->io_unit = default_unit (k);
       goto get_io_list;
     }
+  else
+    {
+      /* Error for constructs like print (1,*).   */
+      if (k == M_PRINT)
+       goto  syntax;
+    }
 
   /* Match a control list */
   if (match_dt_element (k, dt) == MATCH_YES)
@@ -2124,17 +2465,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;
@@ -2163,6 +2507,10 @@ loop:
     }
 
 get_io_list:
+
+  /* Used in check_io_constraints, where no locus is available.  */
+  spec_end = gfc_current_locus;
+
   /* Optional leading comma (non-standard).  */
   if (!comma_flag
       && gfc_match_char (',') == MATCH_YES
@@ -2188,37 +2536,18 @@ get_io_list:
        goto syntax;
     }
 
-  /* A full IO statement has been matched.  */
-  if (dt->io_unit->expr_type == EXPR_VARIABLE
-      && k == M_WRITE
-      && dt->io_unit->ts.type == BT_CHARACTER
-      && dt->io_unit->symtree->n.sym->attr.intent == INTENT_IN)
-    {
-      gfc_error ("Internal file '%s' at %L is INTENT(IN)",
-                dt->io_unit->symtree->n.sym->name, &dt->io_unit->where);
-      m = MATCH_ERROR;
-      goto cleanup;
-    }
-
-  expr = dt->format_expr;
-
-  if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
-    check_format_string (expr);
+  /* A full IO statement has been matched.  Check the constraints.  spec_end is
+     supplied for cases where no locus is supplied.  */
+  m = check_io_constraints (k, dt, io_code, &spec_end);
 
-  if (gfc_pure (NULL)
-      && (k == M_READ || k == M_WRITE)
-      && dt->io_unit->ts.type != BT_CHARACTER)
-    {
-      gfc_error
-       ("io-unit in %s statement at %C must be an internal file in a "
-        "PURE procedure", io_kind_name (k));
-      m = MATCH_ERROR;
-      goto cleanup;
-    }
+  if (m == MATCH_ERROR)
+    goto cleanup;
 
   new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
   new_st.ext.dt = dt;
-  new_st.next = io_code;
+  new_st.block = gfc_get_code ();
+  new_st.block->op = new_st.op;
+  new_st.block->next = io_code;
 
   terminate_io (io_code);
 
@@ -2276,6 +2605,7 @@ gfc_free_inquire (gfc_inquire * inquire)
 
   gfc_free_expr (inquire->unit);
   gfc_free_expr (inquire->file);
+  gfc_free_expr (inquire->iomsg);
   gfc_free_expr (inquire->iostat);
   gfc_free_expr (inquire->exist);
   gfc_free_expr (inquire->opened);
@@ -2299,6 +2629,7 @@ gfc_free_inquire (gfc_inquire * inquire)
   gfc_free_expr (inquire->delim);
   gfc_free_expr (inquire->pad);
   gfc_free_expr (inquire->iolength);
+  gfc_free_expr (inquire->convert);
 
   gfc_free (inquire);
 }
@@ -2316,6 +2647,7 @@ match_inquire_element (gfc_inquire * inquire)
   m = match_etag (&tag_unit, &inquire->unit);
   RETM m = match_etag (&tag_file, &inquire->file);
   RETM m = match_ltag (&tag_err, &inquire->err);
+  RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg);
   RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
   RETM m = match_vtag (&tag_exist, &inquire->exist);
   RETM m = match_vtag (&tag_opened, &inquire->opened);
@@ -2339,6 +2671,7 @@ match_inquire_element (gfc_inquire * inquire)
   RETM m = match_vtag (&tag_s_delim, &inquire->delim);
   RETM m = match_vtag (&tag_s_pad, &inquire->pad);
   RETM m = match_vtag (&tag_iolength, &inquire->iolength);
+  RETM m = match_vtag (&tag_convert, &inquire->convert);
   RETM return MATCH_NO;
 }
 
@@ -2351,6 +2684,7 @@ gfc_match_inquire (void)
   gfc_inquire *inquire;
   gfc_code *code;
   match m;
+  locus loc;
 
   m = gfc_match_char ('(');
   if (m == MATCH_NO)
@@ -2358,6 +2692,8 @@ gfc_match_inquire (void)
 
   inquire = gfc_getmem (sizeof (gfc_inquire));
 
+  loc = gfc_current_locus;
+
   m = match_inquire_element (inquire);
   if (m == MATCH_ERROR)
     goto cleanup;
@@ -2382,8 +2718,6 @@ gfc_match_inquire (void)
       if (m == MATCH_NO)
        goto syntax;
 
-      terminate_io (code);
-
       new_st.op = EXEC_IOLENGTH;
       new_st.expr = inquire->iolength;
       new_st.ext.inquire = inquire;
@@ -2395,7 +2729,10 @@ gfc_match_inquire (void)
          return MATCH_ERROR;
        }
 
-      new_st.next = code;
+      new_st.block = gfc_get_code ();
+      new_st.block->op = EXEC_IOLENGTH;
+      terminate_io (code);
+      new_st.block->next = code;
       return MATCH_YES;
     }
 
@@ -2423,6 +2760,20 @@ gfc_match_inquire (void)
   if (gfc_match_eos () != MATCH_YES)
     goto syntax;
 
+  if (inquire->unit != NULL && inquire->file != NULL)
+    {
+      gfc_error ("INQUIRE statement at %L cannot contain both FILE and"
+                " UNIT specifiers", &loc);
+      goto cleanup;
+    }
+
+  if (inquire->unit == NULL && inquire->file == NULL)
+    {
+      gfc_error ("INQUIRE statement at %L requires either FILE or"
+                    " UNIT specifier", &loc);
+      goto cleanup;
+    }
+
   if (gfc_pure (NULL))
     {
       gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
@@ -2450,6 +2801,7 @@ gfc_resolve_inquire (gfc_inquire * inquire)
 
   RESOLVE_TAG (&tag_unit, inquire->unit);
   RESOLVE_TAG (&tag_file, inquire->file);
+  RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
   RESOLVE_TAG (&tag_iostat, inquire->iostat);
   RESOLVE_TAG (&tag_exist, inquire->exist);
   RESOLVE_TAG (&tag_opened, inquire->opened);
@@ -2473,6 +2825,7 @@ gfc_resolve_inquire (gfc_inquire * inquire)
   RESOLVE_TAG (&tag_s_delim, inquire->delim);
   RESOLVE_TAG (&tag_s_pad, inquire->pad);
   RESOLVE_TAG (&tag_iolength, inquire->iolength);
+  RESOLVE_TAG (&tag_convert, inquire->convert);
 
   if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
     return FAILURE;