OSDN Git Service

(root) / pf3gnuchains / gcc-fork.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
* ipa.c (cgraph_remove_unreachable_nodes): Revert accidental commit.
[pf3gnuchains/gcc-fork.git] / gcc / fortran / io.c
diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index adf274e..dc20bc2 100644 (file)
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -1,13 +1,14 @@
 /* Deal with I/O statements & related stuff.
 /* Deal with I/O statements & related stuff.
-   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
-   Foundation, Inc.
+   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+   2009, 2010
+   Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
 This file is part of GCC.
 
 GCC is free software; you can redistribute it and/or modify it under
 the terms of the GNU General Public License as published by the Free
    Contributed by Andy Vaught
 
 This file is part of GCC.
 
 GCC is free software; you can redistribute it and/or modify it under
 the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
 version.
 
 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
 version.
 
 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
@@ -16,9 +17,8 @@ FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
 for more details.
 
 You should have received a copy of the GNU General Public License
 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, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA.  */
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
 
 #include "config.h"
 #include "system.h"
 
 #include "config.h"
 #include "system.h"
@@ -27,63 +27,76 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
 #include "match.h"
 #include "parse.h"
 
 #include "match.h"
 #include "parse.h"
 
-gfc_st_label format_asterisk =
-  {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL,
-   0, {NULL, NULL}};
+gfc_st_label
+format_asterisk = {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL,
+                  0, {NULL, NULL}};
 
 typedef struct
 {
 
 typedef struct
 {
-  const char *name, *spec;
+  const char *name, *spec, *value;
   bt type;
 }
 io_tag;
 
 static const io_tag
   bt type;
 }
 io_tag;
 
 static const io_tag
-       tag_file        = { "FILE", " file = %e", BT_CHARACTER },
-       tag_status      = { "STATUS", " status = %e", BT_CHARACTER},
-       tag_e_access    = {"ACCESS", " access = %e", BT_CHARACTER},
-       tag_e_form      = {"FORM", " form = %e", BT_CHARACTER},
-       tag_e_recl      = {"RECL", " recl = %e", BT_INTEGER},
-       tag_e_blank     = {"BLANK", " blank = %e", BT_CHARACTER},
-       tag_e_position  = {"POSITION", " position = %e", BT_CHARACTER},
-       tag_e_action    = {"ACTION", " action = %e", BT_CHARACTER},
-       tag_e_delim     = {"DELIM", " delim = %e", BT_CHARACTER},
-       tag_e_pad       = {"PAD", " pad = %e", BT_CHARACTER},
-       tag_unit        = {"UNIT", " unit = %e", BT_INTEGER},
-       tag_advance     = {"ADVANCE", " advance = %e", BT_CHARACTER},
-       tag_rec         = {"REC", " rec = %e", BT_INTEGER},
-       tag_spos        = {"POSITION", " pos = %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},
-       tag_opened      = {"OPENED", " opened = %v", BT_LOGICAL},
-       tag_named       = {"NAMED", " named = %v", BT_LOGICAL},
-       tag_name        = {"NAME", " name = %v", BT_CHARACTER},
-       tag_number      = {"NUMBER", " number = %v", BT_INTEGER},
-       tag_s_access    = {"ACCESS", " access = %v", BT_CHARACTER},
-       tag_sequential  = {"SEQUENTIAL", " sequential = %v", BT_CHARACTER},
-       tag_direct      = {"DIRECT", " direct = %v", BT_CHARACTER},
-       tag_s_form      = {"FORM", " form = %v", BT_CHARACTER},
-       tag_formatted   = {"FORMATTED", " formatted = %v", BT_CHARACTER},
-       tag_unformatted = {"UNFORMATTED", " unformatted = %v", BT_CHARACTER},
-       tag_s_recl      = {"RECL", " recl = %v", BT_INTEGER},
-       tag_nextrec     = {"NEXTREC", " nextrec = %v", BT_INTEGER},
-       tag_s_blank     = {"BLANK", " blank = %v", BT_CHARACTER},
-       tag_s_position  = {"POSITION", " position = %v", BT_CHARACTER},
-       tag_s_action    = {"ACTION", " action = %v", BT_CHARACTER},
-       tag_read        = {"READ", " read = %v", BT_CHARACTER},
-       tag_write       = {"WRITE", " write = %v", BT_CHARACTER},
-       tag_readwrite   = {"READWRITE", " readwrite = %v", BT_CHARACTER},
-       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_strm_out    = {"POS", " pos = %v", BT_INTEGER},
-       tag_err         = {"ERR", " err = %l", BT_UNKNOWN},
-       tag_end         = {"END", " end = %l", BT_UNKNOWN},
-       tag_eor         = {"EOR", " eor = %l", BT_UNKNOWN};
+       tag_file        = {"FILE", " file =", " %e", BT_CHARACTER },
+       tag_status      = {"STATUS", " status =", " %e", BT_CHARACTER},
+       tag_e_access    = {"ACCESS", " access =", " %e", BT_CHARACTER},
+       tag_e_form      = {"FORM", " form =", " %e", BT_CHARACTER},
+       tag_e_recl      = {"RECL", " recl =", " %e", BT_INTEGER},
+       tag_e_blank     = {"BLANK", " blank =", " %e", BT_CHARACTER},
+       tag_e_position  = {"POSITION", " position =", " %e", BT_CHARACTER},
+       tag_e_action    = {"ACTION", " action =", " %e", BT_CHARACTER},
+       tag_e_delim     = {"DELIM", " delim =", " %e", BT_CHARACTER},
+       tag_e_pad       = {"PAD", " pad =", " %e", BT_CHARACTER},
+       tag_e_decimal   = {"DECIMAL", " decimal =", " %e", BT_CHARACTER},
+       tag_e_encoding  = {"ENCODING", " encoding =", " %e", BT_CHARACTER},
+       tag_e_async     = {"ASYNCHRONOUS", " asynchronous =", " %e", BT_CHARACTER},
+       tag_e_round     = {"ROUND", " round =", " %e", BT_CHARACTER},
+       tag_e_sign      = {"SIGN", " sign =", " %e", BT_CHARACTER},
+       tag_unit        = {"UNIT", " unit =", " %e", BT_INTEGER},
+       tag_advance     = {"ADVANCE", " advance =", " %e", BT_CHARACTER},
+       tag_rec         = {"REC", " rec =", " %e", BT_INTEGER},
+       tag_spos        = {"POSITION", " pos =", " %e", BT_INTEGER},
+       tag_format      = {"FORMAT", NULL, 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},
+       tag_opened      = {"OPENED", " opened =", " %v", BT_LOGICAL},
+       tag_named       = {"NAMED", " named =", " %v", BT_LOGICAL},
+       tag_name        = {"NAME", " name =", " %v", BT_CHARACTER},
+       tag_number      = {"NUMBER", " number =", " %v", BT_INTEGER},
+       tag_s_access    = {"ACCESS", " access =", " %v", BT_CHARACTER},
+       tag_sequential  = {"SEQUENTIAL", " sequential =", " %v", BT_CHARACTER},
+       tag_direct      = {"DIRECT", " direct =", " %v", BT_CHARACTER},
+       tag_s_form      = {"FORM", " form =", " %v", BT_CHARACTER},
+       tag_formatted   = {"FORMATTED", " formatted =", " %v", BT_CHARACTER},
+       tag_unformatted = {"UNFORMATTED", " unformatted =", " %v", BT_CHARACTER},
+       tag_s_recl      = {"RECL", " recl =", " %v", BT_INTEGER},
+       tag_nextrec     = {"NEXTREC", " nextrec =", " %v", BT_INTEGER},
+       tag_s_blank     = {"BLANK", " blank =", " %v", BT_CHARACTER},
+       tag_s_position  = {"POSITION", " position =", " %v", BT_CHARACTER},
+       tag_s_action    = {"ACTION", " action =", " %v", BT_CHARACTER},
+       tag_read        = {"READ", " read =", " %v", BT_CHARACTER},
+       tag_write       = {"WRITE", " write =", " %v", BT_CHARACTER},
+       tag_readwrite   = {"READWRITE", " readwrite =", " %v", BT_CHARACTER},
+       tag_s_delim     = {"DELIM", " delim =", " %v", BT_CHARACTER},
+       tag_s_pad       = {"PAD", " pad =", " %v", BT_CHARACTER},
+       tag_s_decimal   = {"DECIMAL", " decimal =", " %v", BT_CHARACTER},
+       tag_s_encoding  = {"ENCODING", " encoding =", " %v", BT_CHARACTER},
+       tag_s_async     = {"ASYNCHRONOUS", " asynchronous =", " %v", BT_CHARACTER},
+       tag_s_round     = {"ROUND", " round =", " %v", BT_CHARACTER},
+       tag_s_sign      = {"SIGN", " sign =", " %v", BT_CHARACTER},
+       tag_iolength    = {"IOLENGTH", " iolength =", " %v", BT_INTEGER},
+       tag_convert     = {"CONVERT", " convert =", " %e", BT_CHARACTER},
+       tag_strm_out    = {"POS", " pos =", " %v", BT_INTEGER},
+       tag_err         = {"ERR", " err =", " %l", BT_UNKNOWN},
+       tag_end         = {"END", " end =", " %l", BT_UNKNOWN},
+       tag_eor         = {"EOR", " eor =", " %l", BT_UNKNOWN},
+       tag_id          = {"ID", " id =", " %v", BT_INTEGER},
+       tag_pending     = {"PENDING", " pending =", " %v", BT_LOGICAL},
+       tag_newunit     = {"NEWUNIT", " newunit =", " %v", BT_INTEGER};
 
 static gfc_dt *current_dt;
 
 
 static gfc_dt *current_dt;
 
@@ -96,17 +109,22 @@ static gfc_dt *current_dt;
 typedef enum
 {
   FMT_NONE, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD,
 typedef enum
 {
   FMT_NONE, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD,
-  FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_POS, FMT_LPAREN,
+  FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_LPAREN,
   FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F,
   FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F,
-  FMT_E, FMT_EXT, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END
+  FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END,
+  FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC,
+  FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ
 }
 format_token;
 
 /* Local variables for checking format strings.  The saved_token is
    used to back up by a single format token during the parsing
    process.  */
 }
 format_token;
 
 /* Local variables for checking format strings.  The saved_token is
    used to back up by a single format token during the parsing
    process.  */
-static char *format_string;
+static gfc_char_t *format_string;
+static int format_string_pos;
 static int format_length, use_last_char;
 static int format_length, use_last_char;
+static char error_element;
+static locus format_locus;
 
 static format_token saved_token;
 
 
 static format_token saved_token;
 
@@ -120,7 +138,7 @@ mode;
 static char
 next_char (int in_string)
 {
 static char
 next_char (int in_string)
 {
-  static char c;
+  static gfc_char_t c;
 
   if (use_last_char)
     {
 
   if (use_last_char)
     {
@@ -137,12 +155,28 @@ next_char (int in_string)
       c = gfc_next_char_literal (in_string);
       if (c == '\n')
        c = '\0';
       c = gfc_next_char_literal (in_string);
       if (c == '\n')
        c = '\0';
+    }
+
+  if (gfc_option.flag_backslash && c == '\\')
+    {
+      locus old_locus = gfc_current_locus;
 
 
-      if (mode == MODE_COPY)
-       *format_string++ = c;
+      if (gfc_match_special_char (&c) == MATCH_NO)
+       gfc_current_locus = old_locus;
+
+      if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
+       gfc_warning ("Extension: backslash character at %C");
     }
 
     }
 
-  c = TOUPPER (c);
+  if (mode == MODE_COPY)
+    *format_string++ = c;
+
+  if (mode != MODE_STRING)
+    format_locus = gfc_current_locus;
+
+  format_string_pos++;
+
+  c = gfc_wide_toupper (c);
   return c;
 }
 
   return c;
 }
 
@@ -152,19 +186,29 @@ next_char (int in_string)
 static void
 unget_char (void)
 {
 static void
 unget_char (void)
 {
-
   use_last_char = 1;
 }
 
   use_last_char = 1;
 }
 
-/* Eat up the spaces and return a character. */
+/* Eat up the spaces and return a character.  */
 
 static char
 
 static char
-next_char_not_space(void)
+next_char_not_space (bool *error)
 {
   char c;
   do
     {
 {
   char c;
   do
     {
-      c = next_char (0);
+      error_element = c = next_char (0);
+      if (c == '\t')
+       {
+         if (gfc_option.allow_std & GFC_STD_GNU)
+           gfc_warning ("Extension: Tab character in format at %C");
+         else
+           {
+             gfc_error ("Extension: Tab character in format at %C");
+             *error = true;
+             return c;
+           }
+       }
     }
   while (gfc_is_whitespace (c));
   return c;
     }
   while (gfc_is_whitespace (c));
   return c;
@@ -182,6 +226,7 @@ format_lex (void)
   char c, delim;
   int zflag;
   int negative_flag;
   char c, delim;
   int zflag;
   int negative_flag;
+  bool error = false;
 
   if (saved_token != FMT_NONE)
     {
 
   if (saved_token != FMT_NONE)
     {
@@ -190,7 +235,7 @@ format_lex (void)
       return token;
     }
 
       return token;
     }
 
-  c = next_char_not_space ();
+  c = next_char_not_space (&error);
   
   negative_flag = 0;
   switch (c)
   
   negative_flag = 0;
   switch (c)
@@ -198,7 +243,7 @@ format_lex (void)
     case '-':
       negative_flag = 1;
     case '+':
     case '-':
       negative_flag = 1;
     case '+':
-      c = next_char_not_space ();
+      c = next_char_not_space (&error);
       if (!ISDIGIT (c))
        {
          token = FMT_UNKNOWN;
       if (!ISDIGIT (c))
        {
          token = FMT_UNKNOWN;
@@ -209,16 +254,16 @@ format_lex (void)
 
       do
        {
 
       do
        {
-         c = next_char_not_space ();
-          if(ISDIGIT (c))
-            value = 10 * value + c - '0';
+         c = next_char_not_space (&error);
+         if (ISDIGIT (c))
+           value = 10 * value + c - '0';
        }
       while (ISDIGIT (c));
 
       unget_char ();
 
       if (negative_flag)
        }
       while (ISDIGIT (c));
 
       unget_char ();
 
       if (negative_flag)
-        value = -value;
+       value = -value;
 
       token = FMT_SIGNED_INT;
       break;
 
       token = FMT_SIGNED_INT;
       break;
@@ -239,11 +284,13 @@ format_lex (void)
 
       do
        {
 
       do
        {
-         c = next_char_not_space ();
-         if (c != '0')
-           zflag = 0;
-          if (ISDIGIT (c))
-            value = 10 * value + c - '0';
+         c = next_char_not_space (&error);
+         if (ISDIGIT (c))
+           {
+             value = 10 * value + c - '0';
+             if (c != '0')
+               zflag = 0;
+           }
        }
       while (ISDIGIT (c));
 
        }
       while (ISDIGIT (c));
 
@@ -272,11 +319,19 @@ format_lex (void)
       break;
 
     case 'T':
       break;
 
     case 'T':
-      c = next_char_not_space ();
-      if (c != 'L' && c != 'R')
-       unget_char ();
-
-      token = FMT_POS;
+      c = next_char_not_space (&error);
+      switch (c)
+       {
+       case 'L':
+         token = FMT_TL;
+         break;
+       case 'R':
+         token = FMT_TR;
+         break;
+       default:
+         token = FMT_T;
+         unget_char ();
+       }
       break;
 
     case '(':
       break;
 
     case '(':
@@ -292,7 +347,7 @@ format_lex (void)
       break;
 
     case 'S':
       break;
 
     case 'S':
-      c = next_char_not_space ();
+      c = next_char_not_space (&error);
       if (c != 'P' && c != 'S')
        unget_char ();
 
       if (c != 'P' && c != 'S')
        unget_char ();
 
@@ -300,7 +355,7 @@ format_lex (void)
       break;
 
     case 'B':
       break;
 
     case 'B':
-      c = next_char_not_space ();
+      c = next_char_not_space (&error);
       if (c == 'N' || c == 'Z')
        token = FMT_BLANK;
       else
       if (c == 'N' || c == 'Z')
        token = FMT_BLANK;
       else
@@ -343,7 +398,7 @@ format_lex (void)
                  break;
                }
            }
                  break;
                }
            }
-          value++;
+         value++;
        }
       break;
 
        }
       break;
 
@@ -362,9 +417,11 @@ format_lex (void)
       break;
 
     case 'E':
       break;
 
     case 'E':
-      c = next_char_not_space ();
-      if (c == 'N' || c == 'S')
-       token = FMT_EXT;
+      c = next_char_not_space (&error);
+      if (c == 'N' )
+       token = FMT_EN;
+      else if (c == 'S')
+        token = FMT_ES;
       else
        {
          token = FMT_E;
       else
        {
          token = FMT_E;
@@ -390,48 +447,128 @@ format_lex (void)
       break;
 
     case 'D':
       break;
 
     case 'D':
-      token = FMT_D;
+      c = next_char_not_space (&error);
+      if (c == 'P')
+       {
+         if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DP format "
+             "specifier not allowed at %C") == FAILURE)
+           return FMT_ERROR;
+         token = FMT_DP;
+       }
+      else if (c == 'C')
+       {
+         if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DC format "
+             "specifier not allowed at %C") == FAILURE)
+           return FMT_ERROR;
+         token = FMT_DC;
+       }
+      else
+       {
+         token = FMT_D;
+         unget_char ();
+       }
+      break;
+
+    case 'R':
+      c = next_char_not_space (&error);
+      switch (c)
+       {
+       case 'C':
+         token = FMT_RC;
+         break;
+       case 'D':
+         token = FMT_RD;
+         break;
+       case 'N':
+         token = FMT_RN;
+         break;
+       case 'P':
+         token = FMT_RP;
+         break;
+       case 'U':
+         token = FMT_RU;
+         break;
+       case 'Z':
+         token = FMT_RZ;
+         break;
+       default:
+         token = FMT_UNKNOWN;
+         unget_char ();
+         break;
+       }
       break;
 
     case '\0':
       token = FMT_END;
       break;
 
       break;
 
     case '\0':
       token = FMT_END;
       break;
 
+    case '*':
+      token = FMT_STAR;
+      break;
+
     default:
       token = FMT_UNKNOWN;
       break;
     }
 
     default:
       token = FMT_UNKNOWN;
       break;
     }
 
+  if (error)
+    return FMT_ERROR;
+
   return token;
 }
 
 
   return token;
 }
 
 
+static const char *
+token_to_string (format_token t)
+{
+  switch (t)
+    {
+      case FMT_D:
+       return "D";
+      case FMT_G:
+       return "G";
+      case FMT_E:
+       return "E";
+      case FMT_EN:
+       return "EN";
+      case FMT_ES:
+       return "ES";
+      default:
+        return "";
+    }
+}
+
 /* Check a format statement.  The format string, either from a FORMAT
    statement or a constant in an I/O statement has already been parsed
    by itself, and we are checking it for validity.  The dual origin
    means that the warning message is a little less than great.  */
 
 /* Check a format statement.  The format string, either from a FORMAT
    statement or a constant in an I/O statement has already been parsed
    by itself, and we are checking it for validity.  The dual origin
    means that the warning message is a little less than great.  */
 
-static try
-check_format (void)
+static gfc_try
+check_format (bool is_input)
 {
   const char *posint_required    = _("Positive width required");
   const char *nonneg_required    = _("Nonnegative width required");
 {
   const char *posint_required    = _("Positive width required");
   const char *nonneg_required    = _("Nonnegative width required");
-  const char *unexpected_element  = _("Unexpected element");
+  const char *unexpected_element  = _("Unexpected element '%c' in format string"
+                                     " at %L");
   const char *unexpected_end     = _("Unexpected end of format string");
   const char *unexpected_end     = _("Unexpected end of format string");
+  const char *zero_width         = _("Zero width in format descriptor");
 
   const char *error;
   format_token t, u;
   int level;
   int repeat;
 
   const char *error;
   format_token t, u;
   int level;
   int repeat;
-  try rv;
+  gfc_try rv;
 
   use_last_char = 0;
   saved_token = FMT_NONE;
   level = 0;
   repeat = 0;
   rv = SUCCESS;
 
   use_last_char = 0;
   saved_token = FMT_NONE;
   level = 0;
   repeat = 0;
   rv = SUCCESS;
+  format_string_pos = 0;
 
   t = format_lex ();
 
   t = format_lex ();
+  if (t == FMT_ERROR)
+    goto fail;
   if (t != FMT_LPAREN)
     {
       error = _("Missing leading left parenthesis");
   if (t != FMT_LPAREN)
     {
       error = _("Missing leading left parenthesis");
@@ -439,6 +576,8 @@ check_format (void)
     }
 
   t = format_lex ();
     }
 
   t = format_lex ();
+  if (t == FMT_ERROR)
+    goto fail;
   if (t == FMT_RPAREN)
     goto finished;             /* Empty format is legal */
   saved_token = t;
   if (t == FMT_RPAREN)
     goto finished;             /* Empty format is legal */
   saved_token = t;
@@ -446,12 +585,29 @@ check_format (void)
 format_item:
   /* In this state, the next thing has to be a format item.  */
   t = format_lex ();
 format_item:
   /* In this state, the next thing has to be a format item.  */
   t = format_lex ();
+  if (t == FMT_ERROR)
+    goto fail;
 format_item_1:
   switch (t)
     {
 format_item_1:
   switch (t)
     {
+    case FMT_STAR:
+      repeat = -1;
+      t = format_lex ();
+      if (t == FMT_ERROR)
+       goto fail;
+      if (t == FMT_LPAREN)
+       {
+         level++;
+         goto format_item;
+       }
+      error = _("Left parenthesis required after '*'");
+      goto syntax;
+
     case FMT_POSINT:
       repeat = value;
       t = format_lex ();
     case FMT_POSINT:
       repeat = value;
       t = format_lex ();
+      if (t == FMT_ERROR)
+       goto fail;
       if (t == FMT_LPAREN)
        {
          level++;
       if (t == FMT_LPAREN)
        {
          level++;
@@ -468,8 +624,11 @@ format_item_1:
       goto format_item;
 
     case FMT_SIGNED_INT:
       goto format_item;
 
     case FMT_SIGNED_INT:
+    case FMT_ZERO:
       /* Signed integer can only precede a P format.  */
       t = format_lex ();
       /* Signed integer can only precede a P format.  */
       t = format_lex ();
+      if (t == FMT_ERROR)
+       goto fail;
       if (t != FMT_P)
        {
          error = _("Expected P edit descriptor");
       if (t != FMT_P)
        {
          error = _("Expected P edit descriptor");
@@ -485,14 +644,24 @@ format_item_1:
 
     case FMT_X:
       /* X requires a prior number if we're being pedantic.  */
 
     case FMT_X:
       /* X requires a prior number if we're being pedantic.  */
+      if (mode != MODE_FORMAT)
+       format_locus.nextc += format_string_pos;
       if (gfc_notify_std (GFC_STD_GNU, "Extension: X descriptor "
       if (gfc_notify_std (GFC_STD_GNU, "Extension: X descriptor "
-                         "requires leading space count at %C")
+                         "requires leading space count at %L", &format_locus)
          == FAILURE)
        return FAILURE;
       goto between_desc;
 
     case FMT_SIGN:
     case FMT_BLANK:
          == FAILURE)
        return FAILURE;
       goto between_desc;
 
     case FMT_SIGN:
     case FMT_BLANK:
+    case FMT_DP:
+    case FMT_DC:
+    case FMT_RC:
+    case FMT_RD:
+    case FMT_RN:
+    case FMT_RP:
+    case FMT_RU:
+    case FMT_RZ:
       goto between_desc;
 
     case FMT_CHAR:
       goto between_desc;
 
     case FMT_CHAR:
@@ -504,29 +673,33 @@ format_item_1:
 
     case FMT_DOLLAR:
       t = format_lex ();
 
     case FMT_DOLLAR:
       t = format_lex ();
+      if (t == FMT_ERROR)
+       goto fail;
 
 
-      if (gfc_notify_std (GFC_STD_GNU, "Extension: $ descriptor at %C")
-          == FAILURE)
-        return FAILURE;
+      if (gfc_notify_std (GFC_STD_GNU, "Extension: $ descriptor at %L",
+         &format_locus) == FAILURE)
+       return FAILURE;
       if (t != FMT_RPAREN || level > 0)
        {
       if (t != FMT_RPAREN || level > 0)
        {
-         gfc_warning ("$ should be the last specifier in format at %C");
+         gfc_warning ("$ should be the last specifier in format at %L",
+                      &format_locus);
          goto optional_comma_1;
        }
 
       goto finished;
 
          goto optional_comma_1;
        }
 
       goto finished;
 
-    case FMT_POS:
+    case FMT_T:
+    case FMT_TL:
+    case FMT_TR:
     case FMT_IBOZ:
     case FMT_F:
     case FMT_E:
     case FMT_IBOZ:
     case FMT_F:
     case FMT_E:
-    case FMT_EXT:
+    case FMT_EN:
+    case FMT_ES:
     case FMT_G:
     case FMT_L:
     case FMT_A:
     case FMT_D:
     case FMT_G:
     case FMT_L:
     case FMT_A:
     case FMT_D:
-      goto data_desc;
-
     case FMT_H:
       goto data_desc;
 
     case FMT_H:
       goto data_desc;
 
@@ -546,35 +719,68 @@ data_desc:
     {
     case FMT_SIGN:
     case FMT_BLANK:
     {
     case FMT_SIGN:
     case FMT_BLANK:
+    case FMT_DP:
+    case FMT_DC:
     case FMT_X:
       break;
 
     case FMT_P:
     case FMT_X:
       break;
 
     case FMT_P:
-      if (pedantic)
+      /* No comma after P allowed only for F, E, EN, ES, D, or G.
+        10.1.1 (1).  */
+      t = format_lex ();
+      if (t == FMT_ERROR)
+       goto fail;
+      if (gfc_option.allow_std < GFC_STD_F2003 && t != FMT_COMMA
+         && t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES
+         && t != FMT_D && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH)
+       {
+         error = _("Comma required after P descriptor");
+         goto syntax;
+       }
+      if (t != FMT_COMMA)
        {
        {
-         t = format_lex ();
          if (t == FMT_POSINT)
            {
          if (t == FMT_POSINT)
            {
-             error = _("Repeat count cannot follow P descriptor");
+             t = format_lex ();
+             if (t == FMT_ERROR)
+               goto fail;
+           }
+          if (t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES && t != FMT_D
+             && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH)
+           {
+             error = _("Comma required after P descriptor");
              goto syntax;
            }
              goto syntax;
            }
-
-         saved_token = t;
        }
 
        }
 
+      saved_token = t;
       goto optional_comma;
 
       goto optional_comma;
 
-    case FMT_POS:
+    case FMT_T:
+    case FMT_TL:
+    case FMT_TR:
+      t = format_lex ();
+      if (t != FMT_POSINT)
+       {
+         error = _("Positive width required with T descriptor");
+         goto syntax;
+       }
+      break;
+
     case FMT_L:
       t = format_lex ();
     case FMT_L:
       t = format_lex ();
+      if (t == FMT_ERROR)
+       goto fail;
       if (t == FMT_POSINT)
        break;
 
       switch (gfc_notification_std (GFC_STD_GNU))
        {
          case WARNING:
       if (t == FMT_POSINT)
        break;
 
       switch (gfc_notification_std (GFC_STD_GNU))
        {
          case WARNING:
-           gfc_warning
-             ("Extension: Missing positive width after L descriptor at %C");
+           if (mode != MODE_FORMAT)
+             format_locus.nextc += format_string_pos;
+           gfc_warning ("Extension: Missing positive width after L "
+                        "descriptor at %L", &format_locus);
            saved_token = t;
            break;
 
            saved_token = t;
            break;
 
@@ -593,6 +799,13 @@ data_desc:
 
     case FMT_A:
       t = format_lex ();
 
     case FMT_A:
       t = format_lex ();
+      if (t == FMT_ERROR)
+       goto fail;
+      if (t == FMT_ZERO)
+       {
+         error = zero_width;
+         goto syntax;
+       }
       if (t != FMT_POSINT)
        saved_token = t;
       break;
       if (t != FMT_POSINT)
        saved_token = t;
       break;
@@ -600,27 +813,80 @@ data_desc:
     case FMT_D:
     case FMT_E:
     case FMT_G:
     case FMT_D:
     case FMT_E:
     case FMT_G:
-    case FMT_EXT:
+    case FMT_EN:
+    case FMT_ES:
       u = format_lex ();
       u = format_lex ();
+      if (t == FMT_G && u == FMT_ZERO)
+       {
+         if (is_input)
+           {
+             error = zero_width;
+             goto syntax;
+           }
+         if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: 'G0' in "
+                             "format at %L", &format_locus) == FAILURE)
+           return FAILURE;
+         u = format_lex ();
+         if (u != FMT_PERIOD)
+           {
+             saved_token = u;
+             break;
+           }
+         u = format_lex ();
+         if (u != FMT_POSINT)
+           {
+             error = posint_required;
+             goto syntax;
+           }
+         u = format_lex ();
+         if (u == FMT_E)
+           {
+             error = _("E specifier not allowed with g0 descriptor");
+             goto syntax;
+           }
+         saved_token = u;
+         break;
+       }
+
       if (u != FMT_POSINT)
        {
       if (u != FMT_POSINT)
        {
-         error = posint_required;
-         goto syntax;
+         format_locus.nextc += format_string_pos;
+         gfc_error ("Positive width required in format "
+                        "specifier %s at %L", token_to_string (t),
+                        &format_locus);
+         saved_token = u;
+         goto fail;
        }
 
       u = format_lex ();
        }
 
       u = format_lex ();
+      if (u == FMT_ERROR)
+       goto fail;
       if (u != FMT_PERIOD)
        {
          /* Warn if -std=legacy, otherwise error.  */
       if (u != FMT_PERIOD)
        {
          /* Warn if -std=legacy, otherwise error.  */
+         format_locus.nextc += format_string_pos;
          if (gfc_option.warn_std != 0)
          if (gfc_option.warn_std != 0)
-           gfc_error_now ("Period required in format specifier at %C");
+           {
+             gfc_error ("Period required in format "
+                            "specifier %s at %L", token_to_string (t),
+                            &format_locus);
+             saved_token = u;
+              goto fail;
+           }
          else
          else
-           gfc_warning ("Period required in format specifier at %C");
+           gfc_warning ("Period required in format "
+                        "specifier %s at %L", token_to_string (t),
+                         &format_locus);
+         /* If we go to finished, we need to unwind this
+            before the next round.  */
+         format_locus.nextc -= format_string_pos;
          saved_token = u;
          break;
        }
 
       u = format_lex ();
          saved_token = u;
          break;
        }
 
       u = format_lex ();
+      if (u == FMT_ERROR)
+       goto fail;
       if (u != FMT_ZERO && u != FMT_POSINT)
        {
          error = nonneg_required;
       if (u != FMT_ZERO && u != FMT_POSINT)
        {
          error = nonneg_required;
@@ -632,6 +898,8 @@ data_desc:
 
       /* Look for optional exponent.  */
       u = format_lex ();
 
       /* Look for optional exponent.  */
       u = format_lex ();
+      if (u == FMT_ERROR)
+       goto fail;
       if (u != FMT_E)
        {
          saved_token = u;
       if (u != FMT_E)
        {
          saved_token = u;
@@ -639,6 +907,8 @@ data_desc:
       else
        {
          u = format_lex ();
       else
        {
          u = format_lex ();
+         if (u == FMT_ERROR)
+           goto fail;
          if (u != FMT_POSINT)
            {
              error = _("Positive exponent width required");
          if (u != FMT_POSINT)
            {
              error = _("Positive exponent width required");
@@ -650,25 +920,41 @@ data_desc:
 
     case FMT_F:
       t = format_lex ();
 
     case FMT_F:
       t = format_lex ();
+      if (t == FMT_ERROR)
+       goto fail;
       if (t != FMT_ZERO && t != FMT_POSINT)
        {
          error = nonneg_required;
          goto syntax;
        }
       if (t != FMT_ZERO && t != FMT_POSINT)
        {
          error = nonneg_required;
          goto syntax;
        }
+      else if (is_input && t == FMT_ZERO)
+       {
+         error = posint_required;
+         goto syntax;
+       }
 
       t = format_lex ();
 
       t = format_lex ();
+      if (t == FMT_ERROR)
+       goto fail;
       if (t != FMT_PERIOD)
        {
          /* Warn if -std=legacy, otherwise error.  */
       if (t != FMT_PERIOD)
        {
          /* 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");
+         if (gfc_option.warn_std != 0)
+           {
+             error = _("Period required in format specifier");
+             goto syntax;
+           }
+         if (mode != MODE_FORMAT)
+           format_locus.nextc += format_string_pos;
+         gfc_warning ("Period required in format specifier at %L",
+                      &format_locus);
          saved_token = t;
          break;
        }
 
       t = format_lex ();
          saved_token = t;
          break;
        }
 
       t = format_lex ();
+      if (t == FMT_ERROR)
+       goto fail;
       if (t != FMT_ZERO && t != FMT_POSINT)
        {
          error = nonneg_required;
       if (t != FMT_ZERO && t != FMT_POSINT)
        {
          error = nonneg_required;
@@ -678,30 +964,47 @@ data_desc:
       break;
 
     case FMT_H:
       break;
 
     case FMT_H:
-      if(mode == MODE_STRING)
-      {
-        format_string += value;
-        format_length -= value;
-      }
+      if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
+       {
+         if (mode != MODE_FORMAT)
+           format_locus.nextc += format_string_pos;
+         gfc_warning ("The H format specifier at %L is"
+                      " a Fortran 95 deleted feature", &format_locus);
+       }
+      if (mode == MODE_STRING)
+       {
+         format_string += value;
+         format_length -= value;
+          format_string_pos += repeat;
+       }
       else
       else
-      {
-        while(repeat >0)
-         {
-          next_char(1);
-          repeat -- ;
-         }
-      }
+       {
+         while (repeat >0)
+          {
+            next_char (1);
+            repeat -- ;
+          }
+       }
      break;
 
     case FMT_IBOZ:
       t = format_lex ();
      break;
 
     case FMT_IBOZ:
       t = format_lex ();
+      if (t == FMT_ERROR)
+       goto fail;
       if (t != FMT_ZERO && t != FMT_POSINT)
        {
          error = nonneg_required;
          goto syntax;
        }
       if (t != FMT_ZERO && t != FMT_POSINT)
        {
          error = nonneg_required;
          goto syntax;
        }
+      else if (is_input && t == FMT_ZERO)
+       {
+         error = posint_required;
+         goto syntax;
+       }
 
       t = format_lex ();
 
       t = format_lex ();
+      if (t == FMT_ERROR)
+       goto fail;
       if (t != FMT_PERIOD)
        {
          saved_token = t;
       if (t != FMT_PERIOD)
        {
          saved_token = t;
@@ -709,6 +1012,8 @@ data_desc:
       else
        {
          t = format_lex ();
       else
        {
          t = format_lex ();
+         if (t == FMT_ERROR)
+           goto fail;
          if (t != FMT_ZERO && t != FMT_POSINT)
            {
              error = nonneg_required;
          if (t != FMT_ZERO && t != FMT_POSINT)
            {
              error = nonneg_required;
@@ -726,6 +1031,8 @@ data_desc:
 between_desc:
   /* Between a descriptor and what comes next.  */
   t = format_lex ();
 between_desc:
   /* Between a descriptor and what comes next.  */
   t = format_lex ();
+  if (t == FMT_ERROR)
+    goto fail;
   switch (t)
     {
 
   switch (t)
     {
 
@@ -747,9 +1054,15 @@ between_desc:
       goto syntax;
 
     default:
       goto syntax;
 
     default:
-      if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %C")
-         == FAILURE)
+      if (mode != MODE_FORMAT)
+       format_locus.nextc += format_string_pos - 1;
+      if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %L",
+         &format_locus) == FAILURE)
        return FAILURE;
        return FAILURE;
+      /* If we do not actually return a failure, we need to unwind this
+         before the next round.  */
+      if (mode != MODE_FORMAT)
+       format_locus.nextc -= format_string_pos;
       goto format_item_1;
     }
 
       goto format_item_1;
     }
 
@@ -757,6 +1070,8 @@ optional_comma:
   /* Optional comma is a weird between state where we've just finished
      reading a colon, slash, dollar or P descriptor.  */
   t = format_lex ();
   /* Optional comma is a weird between state where we've just finished
      reading a colon, slash, dollar or P descriptor.  */
   t = format_lex ();
+  if (t == FMT_ERROR)
+    goto fail;
 optional_comma_1:
   switch (t)
     {
 optional_comma_1:
   switch (t)
     {
@@ -780,6 +1095,8 @@ optional_comma_1:
 extension_optional_comma:
   /* As a GNU extension, permit a missing comma after a string literal.  */
   t = format_lex ();
 extension_optional_comma:
   /* As a GNU extension, permit a missing comma after a string literal.  */
   t = format_lex ();
+  if (t == FMT_ERROR)
+    goto fail;
   switch (t)
     {
     case FMT_COMMA:
   switch (t)
     {
     case FMT_COMMA:
@@ -800,30 +1117,29 @@ extension_optional_comma:
       goto syntax;
 
     default:
       goto syntax;
 
     default:
-      if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %C")
-         == FAILURE)
+      if (mode != MODE_FORMAT)
+       format_locus.nextc += format_string_pos;
+      if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %L",
+         &format_locus) == FAILURE)
        return FAILURE;
        return FAILURE;
+      /* If we do not actually return a failure, we need to unwind this
+         before the next round.  */
+      if (mode != MODE_FORMAT)
+       format_locus.nextc -= format_string_pos;
       saved_token = t;
       break;
     }
 
   goto format_item;
       saved_token = t;
       break;
     }
 
   goto format_item;
-
+  
 syntax:
 syntax:
-  /* Something went wrong.  If the format we're checking is a string,
-     generate a warning, since the program is correct.  If the format
-     is in a FORMAT statement, this messes up parsing, which is an
-     error.  */
-  if (mode != MODE_STRING)
-    gfc_error ("%s in format string at %C", error);
+  if (mode != MODE_FORMAT)
+    format_locus.nextc += format_string_pos;
+  if (error == unexpected_element)
+    gfc_error (error, error_element, &format_locus);
   else
   else
-    {
-      gfc_warning ("%s in format string at %C", error);
-
-      /* TODO: More elaborate measures are needed to show where a problem
-         is within a format string that has been calculated.  */
-    }
-
+    gfc_error ("%s in format string at %L", error, &format_locus);
+fail:
   rv = FAILURE;
 
 finished:
   rv = FAILURE;
 
 finished:
@@ -834,13 +1150,35 @@ finished:
 /* Given an expression node that is a constant string, see if it looks
    like a format string.  */
 
 /* Given an expression node that is a constant string, see if it looks
    like a format string.  */
 
-static void
-check_format_string (gfc_expr * e)
+static gfc_try
+check_format_string (gfc_expr *e, bool is_input)
 {
 {
+  gfc_try rv;
+  int i;
+  if (!e || e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
+    return SUCCESS;
 
   mode = MODE_STRING;
   format_string = e->value.character.string;
 
   mode = MODE_STRING;
   format_string = e->value.character.string;
-  check_format ();
+
+  /* More elaborate measures are needed to show where a problem is within a
+     format string that has been calculated, but that's probably not worth the
+     effort.  */
+  format_locus = e->where;
+  rv = check_format (is_input);
+  /* check for extraneous characters at the end of an otherwise valid format
+     string, like '(A10,I3)F5'
+     start at the end and move back to the last character processed,
+     spaces are OK */
+  if (rv == SUCCESS && e->value.character.length > format_string_pos)
+    for (i=e->value.character.length-1;i>format_string_pos-1;i--)
+      if (e->value.character.string[i] != ' ')
+        {
+          format_locus.nextc += format_length + 1; 
+          gfc_warning ("Extraneous characters in format at %L", &format_locus); 
+          break;
+        }
+  return rv;
 }
 
 
 }
 
 
@@ -857,7 +1195,7 @@ gfc_match_format (void)
   locus start;
 
   if (gfc_current_ns->proc_name
   locus start;
 
   if (gfc_current_ns->proc_name
-       && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+      && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
     {
       gfc_error ("Format statement in module main block at %C");
       return MATCH_ERROR;
     {
       gfc_error ("Format statement in module main block at %C");
       return MATCH_ERROR;
@@ -875,7 +1213,7 @@ gfc_match_format (void)
 
   start = gfc_current_locus;
 
 
   start = gfc_current_locus;
 
-  if (check_format () == FAILURE)
+  if (check_format (false) == FAILURE)
     return MATCH_ERROR;
 
   if (gfc_match_eos () != MATCH_YES)
     return MATCH_ERROR;
 
   if (gfc_match_eos () != MATCH_YES)
@@ -892,17 +1230,13 @@ gfc_match_format (void)
   new_st.loc = start;
   new_st.op = EXEC_NOP;
 
   new_st.loc = start;
   new_st.op = EXEC_NOP;
 
-  e = gfc_get_expr();
-  e->expr_type = EXPR_CONSTANT;
-  e->ts.type = BT_CHARACTER;
-  e->ts.kind = gfc_default_character_kind;
-  e->where = start;
-  e->value.character.string = format_string = gfc_getmem(format_length+1);
-  e->value.character.length = format_length;
+  e = gfc_get_character_expr (gfc_default_character_kind, &start,
+                             NULL, format_length);
+  format_string = e->value.character.string;
   gfc_statement_label->format = e;
 
   mode = MODE_COPY;
   gfc_statement_label->format = e;
 
   mode = MODE_COPY;
-  check_format ();             /* Guaranteed to succeed */
+  check_format (false);                /* Guaranteed to succeed */
   gfc_match_eos ();            /* Guaranteed to succeed */
 
   return MATCH_YES;
   gfc_match_eos ();            /* Guaranteed to succeed */
 
   return MATCH_YES;
@@ -912,15 +1246,22 @@ gfc_match_format (void)
 /* Match an expression I/O tag of some sort.  */
 
 static match
 /* Match an expression I/O tag of some sort.  */
 
 static match
-match_etag (const io_tag * tag, gfc_expr ** v)
+match_etag (const io_tag *tag, gfc_expr **v)
 {
   gfc_expr *result;
   match m;
 
 {
   gfc_expr *result;
   match m;
 
-  m = gfc_match (tag->spec, &result);
+  m = gfc_match (tag->spec);
   if (m != MATCH_YES)
     return m;
 
   if (m != MATCH_YES)
     return m;
 
+  m = gfc_match (tag->value, &result);
+  if (m != MATCH_YES)
+    {
+      gfc_error ("Invalid value for %s specification at %C", tag->name);
+      return MATCH_ERROR;
+    }
+
   if (*v != NULL)
     {
       gfc_error ("Duplicate %s specification at %C", tag->name);
   if (*v != NULL)
     {
       gfc_error ("Duplicate %s specification at %C", tag->name);
@@ -936,15 +1277,22 @@ match_etag (const io_tag * tag, gfc_expr ** v)
 /* Match a variable I/O tag of some sort.  */
 
 static match
 /* Match a variable I/O tag of some sort.  */
 
 static match
-match_vtag (const io_tag * tag, gfc_expr ** v)
+match_vtag (const io_tag *tag, gfc_expr **v)
 {
   gfc_expr *result;
   match m;
 
 {
   gfc_expr *result;
   match m;
 
-  m = gfc_match (tag->spec, &result);
+  m = gfc_match (tag->spec);
   if (m != MATCH_YES)
     return m;
 
   if (m != MATCH_YES)
     return m;
 
+  m = gfc_match (tag->value, &result);
+  if (m != MATCH_YES)
+    {
+      gfc_error ("Invalid value for %s specification at %C", tag->name);
+      return MATCH_ERROR;
+    }
+
   if (*v != NULL)
     {
       gfc_error ("Duplicate %s specification at %C", tag->name);
   if (*v != NULL)
     {
       gfc_error ("Duplicate %s specification at %C", tag->name);
@@ -954,14 +1302,15 @@ match_vtag (const io_tag * tag, gfc_expr ** v)
 
   if (result->symtree->n.sym->attr.intent == INTENT_IN)
     {
 
   if (result->symtree->n.sym->attr.intent == INTENT_IN)
     {
-      gfc_error ("Variable tag cannot be INTENT(IN) at %C");
+      gfc_error ("Variable %s cannot be INTENT(IN) at %C", tag->name);
       gfc_free_expr (result);
       return MATCH_ERROR;
     }
 
   if (gfc_pure (NULL) && gfc_impure_variable (result->symtree->n.sym))
     {
       gfc_free_expr (result);
       return MATCH_ERROR;
     }
 
   if (gfc_pure (NULL) && gfc_impure_variable (result->symtree->n.sym))
     {
-      gfc_error ("Variable tag cannot be assigned in PURE procedure at %C");
+      gfc_error ("Variable %s cannot be assigned in PURE procedure at %C",
+                tag->name);
       gfc_free_expr (result);
       return MATCH_ERROR;
     }
       gfc_free_expr (result);
       return MATCH_ERROR;
     }
@@ -974,13 +1323,13 @@ match_vtag (const io_tag * tag, gfc_expr ** v)
 /* Match I/O tags that cause variables to become redefined.  */
 
 static match
 /* Match I/O tags that cause variables to become redefined.  */
 
 static match
-match_out_tag(const io_tag *tag, gfc_expr **result)
+match_out_tag (const io_tag *tag, gfc_expr **result)
 {
   match m;
 
 {
   match m;
 
-  m = match_vtag(tag, result);
+  m = match_vtag (tag, result);
   if (m == MATCH_YES)
   if (m == MATCH_YES)
-    gfc_check_do_variable((*result)->symtree);
+    gfc_check_do_variable ((*result)->symtree);
 
   return m;
 }
 
   return m;
 }
@@ -989,153 +1338,172 @@ match_out_tag(const io_tag *tag, gfc_expr **result)
 /* Match a label I/O tag.  */
 
 static match
 /* Match a label I/O tag.  */
 
 static match
-match_ltag (const io_tag * tag, gfc_st_label ** label)
+match_ltag (const io_tag *tag, gfc_st_label ** label)
 {
   match m;
   gfc_st_label *old;
 
   old = *label;
 {
   match m;
   gfc_st_label *old;
 
   old = *label;
-  m = gfc_match (tag->spec, label);
-  if (m == MATCH_YES && old != 0)
+  m = gfc_match (tag->spec);
+  if (m != MATCH_YES)
+    return m;
+
+  m = gfc_match (tag->value, label);
+  if (m != MATCH_YES)
+    {
+      gfc_error ("Invalid value for %s specification at %C", tag->name);
+      return MATCH_ERROR;
+    }
+
+  if (old)
     {
       gfc_error ("Duplicate %s label specification at %C", tag->name);
       return MATCH_ERROR;
     }
 
     {
       gfc_error ("Duplicate %s label specification at %C", tag->name);
       return MATCH_ERROR;
     }
 
-  if (m == MATCH_YES 
-      && gfc_reference_st_label (*label, ST_LABEL_TARGET) == FAILURE)
+  if (gfc_reference_st_label (*label, ST_LABEL_TARGET) == FAILURE)
     return MATCH_ERROR;
 
   return m;
 }
 
 
     return MATCH_ERROR;
 
   return m;
 }
 
 
-/* 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)
+static gfc_try
+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;
     }
 
       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->rank == 0
+      && (e->expr_type != EXPR_VARIABLE
+         || 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;
        }
          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,
-                       "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;
-               }
-           }
-         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 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;
     }
     }
-  else
+
+  /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
+     It may be assigned an Hollerith constant.  */
+  if (e->ts.type != BT_CHARACTER)
     {
     {
-      if (e->rank != 0)
+      if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character "
+                         "in FORMAT tag at %L", &e->where) == FAILURE)
+       return FAILURE;
+
+      if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)
        {
        {
-         gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
+         gfc_error ("Non-character assumed shape array element in FORMAT"
+                    " tag at %L", &e->where);
          return FAILURE;
        }
 
          return FAILURE;
        }
 
-      if (tag == &tag_iomsg)
+      if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
        {
        {
-         if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IOMSG tag at %L",
-                             &e->where) == FAILURE)
-           return FAILURE;
+         gfc_error ("Non-character assumed size array element in FORMAT"
+                    " tag at %L", &e->where);
+         return FAILURE;
        }
 
        }
 
-      if (tag == &tag_iostat && e->ts.kind != gfc_default_integer_kind)
+      if (e->rank == 0 && e->symtree->n.sym->attr.pointer)
        {
        {
-         if (gfc_notify_std (GFC_STD_GNU, "Fortran 95 requires default "
-                             "INTEGER in IOSTAT tag at %L",
-                             &e->where) == FAILURE)
-           return FAILURE;
+         gfc_error ("Non-character pointer array element in FORMAT tag at %L",
+                    &e->where);
+         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;
-       }
+  return SUCCESS;
+}
 
 
-      if (tag == &tag_convert)
-       {
-         if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L",
-                             &e->where) == FAILURE)
-           return FAILURE;
-       }
+
+/* Do expression resolution and type-checking on an expression tag.  */
+
+static gfc_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;
 }
 
   return SUCCESS;
 }
 
@@ -1143,10 +1511,13 @@ resolve_tag (const io_tag * tag, gfc_expr * e)
 /* Match a single tag of an OPEN statement.  */
 
 static match
 /* Match a single tag of an OPEN statement.  */
 
 static match
-match_open_element (gfc_open * open)
+match_open_element (gfc_open *open)
 {
   match m;
 
 {
   match m;
 
+  m = match_etag (&tag_e_async, &open->asynchronous);
+  if (m != MATCH_NO)
+    return m;
   m = match_etag (&tag_unit, &open->unit);
   if (m != MATCH_NO)
     return m;
   m = match_etag (&tag_unit, &open->unit);
   if (m != MATCH_NO)
     return m;
@@ -1186,12 +1557,27 @@ match_open_element (gfc_open * open)
   m = match_etag (&tag_e_pad, &open->pad);
   if (m != MATCH_NO)
     return m;
   m = match_etag (&tag_e_pad, &open->pad);
   if (m != MATCH_NO)
     return m;
+  m = match_etag (&tag_e_decimal, &open->decimal);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_encoding, &open->encoding);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_round, &open->round);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_sign, &open->sign);
+  if (m != MATCH_NO)
+    return m;
   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;
   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;
+  m = match_out_tag (&tag_newunit, &open->newunit);
+  if (m != MATCH_NO)
+    return m;
 
   return MATCH_NO;
 }
 
   return MATCH_NO;
 }
@@ -1200,9 +1586,8 @@ match_open_element (gfc_open * open)
 /* Free the gfc_open structure and all the expressions it contains.  */
 
 void
 /* Free the gfc_open structure and all the expressions it contains.  */
 
 void
-gfc_free_open (gfc_open * open)
+gfc_free_open (gfc_open *open)
 {
 {
-
   if (open == NULL)
     return;
 
   if (open == NULL)
     return;
 
@@ -1219,16 +1604,21 @@ 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->action);
   gfc_free_expr (open->delim);
   gfc_free_expr (open->pad);
+  gfc_free_expr (open->decimal);
+  gfc_free_expr (open->encoding);
+  gfc_free_expr (open->round);
+  gfc_free_expr (open->sign);
   gfc_free_expr (open->convert);
   gfc_free_expr (open->convert);
-
+  gfc_free_expr (open->asynchronous);
+  gfc_free_expr (open->newunit);
   gfc_free (open);
 }
 
 
 /* Resolve everything in a gfc_open structure.  */
 
   gfc_free (open);
 }
 
 
 /* Resolve everything in a gfc_open structure.  */
 
-try
-gfc_resolve_open (gfc_open * open)
+gfc_try
+gfc_resolve_open (gfc_open *open)
 {
 
   RESOLVE_TAG (&tag_unit, open->unit);
 {
 
   RESOLVE_TAG (&tag_unit, open->unit);
@@ -1239,13 +1629,18 @@ gfc_resolve_open (gfc_open * open)
   RESOLVE_TAG (&tag_e_access, open->access);
   RESOLVE_TAG (&tag_e_form, open->form);
   RESOLVE_TAG (&tag_e_recl, open->recl);
   RESOLVE_TAG (&tag_e_access, open->access);
   RESOLVE_TAG (&tag_e_form, open->form);
   RESOLVE_TAG (&tag_e_recl, open->recl);
-
   RESOLVE_TAG (&tag_e_blank, open->blank);
   RESOLVE_TAG (&tag_e_position, open->position);
   RESOLVE_TAG (&tag_e_action, open->action);
   RESOLVE_TAG (&tag_e_delim, open->delim);
   RESOLVE_TAG (&tag_e_pad, open->pad);
   RESOLVE_TAG (&tag_e_blank, open->blank);
   RESOLVE_TAG (&tag_e_position, open->position);
   RESOLVE_TAG (&tag_e_action, open->action);
   RESOLVE_TAG (&tag_e_delim, open->delim);
   RESOLVE_TAG (&tag_e_pad, open->pad);
+  RESOLVE_TAG (&tag_e_decimal, open->decimal);
+  RESOLVE_TAG (&tag_e_encoding, open->encoding);
+  RESOLVE_TAG (&tag_e_async, open->asynchronous);
+  RESOLVE_TAG (&tag_e_round, open->round);
+  RESOLVE_TAG (&tag_e_sign, open->sign);
   RESOLVE_TAG (&tag_convert, open->convert);
   RESOLVE_TAG (&tag_convert, open->convert);
+  RESOLVE_TAG (&tag_newunit, open->newunit);
 
   if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE)
     return FAILURE;
 
   if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE)
     return FAILURE;
@@ -1254,20 +1649,20 @@ gfc_resolve_open (gfc_open * open)
 }
 
 
 }
 
 
-
 /* Check if a given value for a SPECIFIER is either in the list of values
    allowed in F95 or F2003, issuing an error message and returning a zero
    value if it is not allowed.  */
 /* Check if a given value for a SPECIFIER is either in the list of values
    allowed in F95 or F2003, issuing an error message and returning a zero
    value if it is not allowed.  */
+
 static int
 static int
-compare_to_allowed_values (const char * specifier, const char * allowed[],
-                          const char * allowed_f2003[], 
-                          const char * allowed_gnu[], char * value,
-                          const char * statement, bool warn)
+compare_to_allowed_values (const char *specifier, const char *allowed[],
+                          const char *allowed_f2003[], 
+                          const char *allowed_gnu[], gfc_char_t *value,
+                          const char *statement, bool warn)
 {
   int i;
   unsigned int len;
 
 {
   int i;
   unsigned int len;
 
-  len = strlen(value);
+  len = gfc_wide_strlen (value);
   if (len > 0)
   {
     for (len--; len > 0; len--)
   if (len > 0)
   {
     for (len--; len > 0; len--)
@@ -1277,13 +1672,14 @@ compare_to_allowed_values (const char * specifier, const char * allowed[],
   }
 
   for (i = 0; allowed[i]; i++)
   }
 
   for (i = 0; allowed[i]; i++)
-    if (len == strlen(allowed[i])
-       && strncasecmp (value, allowed[i], strlen(allowed[i])) == 0)
+    if (len == strlen (allowed[i])
+       && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0)
       return 1;
 
   for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
       return 1;
 
   for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
-    if (len == strlen(allowed_f2003[i])
-       && strncasecmp (value, allowed_f2003[i], strlen(allowed_f2003[i])) == 0)
+    if (len == strlen (allowed_f2003[i])
+       && gfc_wide_strncasecmp (value, allowed_f2003[i],
+                                strlen (allowed_f2003[i])) == 0)
       {
        notification n = gfc_notification_std (GFC_STD_F2003);
 
       {
        notification n = gfc_notification_std (GFC_STD_F2003);
 
@@ -1308,8 +1704,9 @@ compare_to_allowed_values (const char * specifier, const char * allowed[],
       }
 
   for (i = 0; allowed_gnu && allowed_gnu[i]; i++)
       }
 
   for (i = 0; allowed_gnu && allowed_gnu[i]; i++)
-    if (len == strlen(allowed_gnu[i])
-       && strncasecmp (value, allowed_gnu[i], strlen(allowed_gnu[i])) == 0)
+    if (len == strlen (allowed_gnu[i])
+       && gfc_wide_strncasecmp (value, allowed_gnu[i],
+                                strlen (allowed_gnu[i])) == 0)
       {
        notification n = gfc_notification_std (GFC_STD_GNU);
 
       {
        notification n = gfc_notification_std (GFC_STD_GNU);
 
@@ -1335,18 +1732,23 @@ compare_to_allowed_values (const char * specifier, const char * allowed[],
 
   if (warn)
     {
 
   if (warn)
     {
+      char *s = gfc_widechar_to_char (value, -1);
       gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'",
       gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'",
-                  specifier, statement, value);
+                  specifier, statement, s);
+      gfc_free (s);
       return 1;
     }
   else
     {
       return 1;
     }
   else
     {
+      char *s = gfc_widechar_to_char (value, -1);
       gfc_error ("%s specifier in %s statement at %C has invalid value '%s'",
       gfc_error ("%s specifier in %s statement at %C has invalid value '%s'",
-                specifier, statement, value);
+                specifier, statement, s);
+      gfc_free (s);
       return 0;
     }
 }
 
       return 0;
     }
 }
 
+
 /* Match an OPEN statement.  */
 
 match
 /* Match an OPEN statement.  */
 
 match
@@ -1360,7 +1762,7 @@ gfc_match_open (void)
   if (m == MATCH_NO)
     return m;
 
   if (m == MATCH_NO)
     return m;
 
-  open = gfc_getmem (sizeof (gfc_open));
+  open = XCNEW (gfc_open);
 
   m = match_open_element (open);
 
 
   m = match_open_element (open);
 
@@ -1369,8 +1771,6 @@ gfc_match_open (void)
   if (m == MATCH_NO)
     {
       m = gfc_match_expr (&open->unit);
   if (m == MATCH_NO)
     {
       m = gfc_match_expr (&open->unit);
-      if (m == MATCH_NO)
-       goto syntax;
       if (m == MATCH_ERROR)
        goto cleanup;
     }
       if (m == MATCH_ERROR)
        goto cleanup;
     }
@@ -1399,12 +1799,37 @@ gfc_match_open (void)
     }
 
   warn = (open->err || open->iostat) ? true : false;
     }
 
   warn = (open->err || open->iostat) ? true : false;
+
+  /* Checks on NEWUNIT specifier.  */
+  if (open->newunit)
+    {
+      if (open->unit)
+       {
+         gfc_error ("UNIT specifier not allowed with NEWUNIT at %C");
+         goto cleanup;
+       }
+
+      if (!(open->file || (open->status
+          && gfc_wide_strncasecmp (open->status->value.character.string,
+                                  "scratch", 7) == 0)))
+       {
+         gfc_error ("NEWUNIT specifier must have FILE= "
+                    "or STATUS='scratch' at %C");
+         goto cleanup;
+       }
+    }
+  else if (!open->unit)
+    {
+      gfc_error ("OPEN statement at %C must have UNIT or NEWUNIT specified");
+      goto cleanup;
+    }
+
   /* Checks on the ACCESS specifier.  */
   if (open->access && open->access->expr_type == EXPR_CONSTANT)
     {
   /* Checks on the ACCESS specifier.  */
   if (open->access && open->access->expr_type == EXPR_CONSTANT)
     {
-      static const char * access_f95[] = { "SEQUENTIAL", "DIRECT", NULL };
-      static const char * access_f2003[] = { "STREAM", NULL };
-      static const char * access_gnu[] = { "APPEND", NULL };
+      static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL };
+      static const char *access_f2003[] = { "STREAM", NULL };
+      static const char *access_gnu[] = { "APPEND", NULL };
 
       if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003,
                                      access_gnu,
 
       if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003,
                                      access_gnu,
@@ -1416,7 +1841,7 @@ gfc_match_open (void)
   /* Checks on the ACTION specifier.  */
   if (open->action && open->action->expr_type == EXPR_CONSTANT)
     {
   /* Checks on the ACTION specifier.  */
   if (open->action && open->action->expr_type == EXPR_CONSTANT)
     {
-      static const char * action[] = { "READ", "WRITE", "READWRITE", NULL };
+      static const char *action[] = { "READ", "WRITE", "READWRITE", NULL };
 
       if (!compare_to_allowed_values ("ACTION", action, NULL, NULL,
                                      open->action->value.character.string,
 
       if (!compare_to_allowed_values ("ACTION", action, NULL, NULL,
                                      open->action->value.character.string,
@@ -1425,68 +1850,99 @@ gfc_match_open (void)
     }
 
   /* Checks on the ASYNCHRONOUS specifier.  */
     }
 
   /* Checks on the ASYNCHRONOUS specifier.  */
-  /* TODO: code is ready, just needs uncommenting when async I/O support
-     is added ;-)
-  if (open->asynchronous && open->asynchronous->expr_type == EXPR_CONSTANT)
+  if (open->asynchronous)
     {
     {
-      static const char * asynchronous[] = { "YES", "NO", NULL };
-
-      if (!compare_to_allowed_values
-               ("action", asynchronous, NULL, NULL,
-                open->asynchronous->value.character.string, "OPEN", warn))
+      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASYNCHRONOUS= at %C "
+         "not allowed in Fortran 95") == FAILURE)
        goto cleanup;
        goto cleanup;
-    }*/
-  
+
+      if (open->asynchronous->expr_type == EXPR_CONSTANT)
+       {
+         static const char * asynchronous[] = { "YES", "NO", NULL };
+
+         if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous,
+                       NULL, NULL, open->asynchronous->value.character.string,
+                       "OPEN", warn))
+           goto cleanup;
+       }
+    }
+
   /* Checks on the BLANK specifier.  */
   /* Checks on the BLANK specifier.  */
-  if (open->blank && open->blank->expr_type == EXPR_CONSTANT)
+  if (open->blank)
     {
     {
-      static const char * blank[] = { "ZERO", "NULL", NULL };
-
-      if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
-                                     open->blank->value.character.string,
-                                     "OPEN", warn))
+      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C "
+         "not allowed in Fortran 95") == FAILURE)
        goto cleanup;
        goto cleanup;
+
+      if (open->blank->expr_type == EXPR_CONSTANT)
+       {
+         static const char *blank[] = { "ZERO", "NULL", NULL };
+
+         if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
+                                         open->blank->value.character.string,
+                                         "OPEN", warn))
+           goto cleanup;
+       }
     }
 
   /* Checks on the DECIMAL specifier.  */
     }
 
   /* Checks on the DECIMAL specifier.  */
-  /* TODO: uncomment this code when DECIMAL support is added 
-  if (open->decimal && open->decimal->expr_type == EXPR_CONSTANT)
+  if (open->decimal)
     {
     {
-      static const char * decimal[] = { "COMMA", "POINT", NULL };
-
-      if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
-                                     open->decimal->value.character.string,
-                                     "OPEN", warn))
+      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C "
+         "not allowed in Fortran 95") == FAILURE)
        goto cleanup;
        goto cleanup;
-    } */
+
+      if (open->decimal->expr_type == EXPR_CONSTANT)
+       {
+         static const char * decimal[] = { "COMMA", "POINT", NULL };
+
+         if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
+                                         open->decimal->value.character.string,
+                                         "OPEN", warn))
+           goto cleanup;
+       }
+    }
 
   /* Checks on the DELIM specifier.  */
 
   /* Checks on the DELIM specifier.  */
-  if (open->delim && open->delim->expr_type == EXPR_CONSTANT)
+  if (open->delim)
     {
     {
-      static const char * delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
-
-      if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
-                                     open->delim->value.character.string,
-                                     "OPEN", warn))
+      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C "
+         "not allowed in Fortran 95") == FAILURE)
        goto cleanup;
        goto cleanup;
+
+      if (open->delim->expr_type == EXPR_CONSTANT)
+       {
+         static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
+
+         if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
+                                         open->delim->value.character.string,
+                                         "OPEN", warn))
+         goto cleanup;
+       }
     }
 
   /* Checks on the ENCODING specifier.  */
     }
 
   /* Checks on the ENCODING specifier.  */
-  /* TODO: uncomment this code when ENCODING support is added 
-  if (open->encoding && open->encoding->expr_type == EXPR_CONSTANT)
+  if (open->encoding)
     {
     {
-      static const char * encoding[] = { "UTF-8", "DEFAULT", NULL };
-
-      if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
-                                     open->encoding->value.character.string,
-                                     "OPEN", warn))
+      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENCODING= at %C "
+         "not allowed in Fortran 95") == FAILURE)
        goto cleanup;
        goto cleanup;
-    } */
+    
+      if (open->encoding->expr_type == EXPR_CONSTANT)
+       {
+         static const char * encoding[] = { "DEFAULT", "UTF-8", NULL };
+
+         if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
+                                         open->encoding->value.character.string,
+                                         "OPEN", warn))
+         goto cleanup;
+       }
+    }
 
   /* Checks on the FORM specifier.  */
   if (open->form && open->form->expr_type == EXPR_CONSTANT)
     {
 
   /* Checks on the FORM specifier.  */
   if (open->form && open->form->expr_type == EXPR_CONSTANT)
     {
-      static const char * form[] = { "FORMATTED", "UNFORMATTED", NULL };
+      static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL };
 
       if (!compare_to_allowed_values ("FORM", form, NULL, NULL,
                                      open->form->value.character.string,
 
       if (!compare_to_allowed_values ("FORM", form, NULL, NULL,
                                      open->form->value.character.string,
@@ -1497,7 +1953,7 @@ gfc_match_open (void)
   /* Checks on the PAD specifier.  */
   if (open->pad && open->pad->expr_type == EXPR_CONSTANT)
     {
   /* Checks on the PAD specifier.  */
   if (open->pad && open->pad->expr_type == EXPR_CONSTANT)
     {
-      static const char * pad[] = { "YES", "NO", NULL };
+      static const char *pad[] = { "YES", "NO", NULL };
 
       if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
                                      open->pad->value.character.string,
 
       if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
                                      open->pad->value.character.string,
@@ -1508,7 +1964,7 @@ gfc_match_open (void)
   /* Checks on the POSITION specifier.  */
   if (open->position && open->position->expr_type == EXPR_CONSTANT)
     {
   /* Checks on the POSITION specifier.  */
   if (open->position && open->position->expr_type == EXPR_CONSTANT)
     {
-      static const char * position[] = { "ASIS", "REWIND", "APPEND", NULL };
+      static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL };
 
       if (!compare_to_allowed_values ("POSITION", position, NULL, NULL,
                                      open->position->value.character.string,
 
       if (!compare_to_allowed_values ("POSITION", position, NULL, NULL,
                                      open->position->value.character.string,
@@ -1517,30 +1973,43 @@ gfc_match_open (void)
     }
 
   /* Checks on the ROUND specifier.  */
     }
 
   /* Checks on the ROUND specifier.  */
-  /* TODO: uncomment this code when ROUND support is added 
-  if (open->round && open->round->expr_type == EXPR_CONSTANT)
+  if (open->round)
     {
     {
-      static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
-                                     "COMPATIBLE", "PROCESSOR_DEFINED", NULL };
+      if (gfc_notify_std (GFC_STD_F2003, "Fortran F2003: ROUND= at %C "
+         "not allowed in Fortran 95") == FAILURE)
+      goto cleanup;
 
 
-      if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
-                                     open->round->value.character.string,
-                                     "OPEN", warn))
-       goto cleanup;
-    } */
+      if (open->round->expr_type == EXPR_CONSTANT)
+       {
+         static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
+                                         "COMPATIBLE", "PROCESSOR_DEFINED",
+                                          NULL };
+
+         if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
+                                         open->round->value.character.string,
+                                         "OPEN", warn))
+         goto cleanup;
+       }
+    }
 
   /* Checks on the SIGN specifier.  */
 
   /* Checks on the SIGN specifier.  */
-  /* TODO: uncomment this code when SIGN support is added 
-  if (open->sign && open->sign->expr_type == EXPR_CONSTANT)
+  if (open->sign) 
     {
     {
-      static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
-                                    NULL };
-
-      if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
-                                     open->sign->value.character.string,
-                                     "OPEN", warn))
+      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
+         "not allowed in Fortran 95") == FAILURE)
        goto cleanup;
        goto cleanup;
-    } */
+
+      if (open->sign->expr_type == EXPR_CONSTANT)
+       {
+         static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
+                                         NULL };
+
+         if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
+                                         open->sign->value.character.string,
+                                         "OPEN", warn))
+         goto cleanup;
+       }
+    }
 
 #define warn_or_error(...) \
 { \
 
 #define warn_or_error(...) \
 { \
@@ -1564,7 +2033,7 @@ gfc_match_open (void)
   /* Checks on the STATUS specifier.  */
   if (open->status && open->status->expr_type == EXPR_CONSTANT)
     {
   /* Checks on the STATUS specifier.  */
   if (open->status && open->status->expr_type == EXPR_CONSTANT)
     {
-      static const char * status[] = { "OLD", "NEW", "SCRATCH",
+      static const char *status[] = { "OLD", "NEW", "SCRATCH",
        "REPLACE", "UNKNOWN", NULL };
 
       if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
        "REPLACE", "UNKNOWN", NULL };
 
       if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
@@ -1573,58 +2042,62 @@ gfc_match_open (void)
        goto cleanup;
 
       /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
        goto cleanup;
 
       /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
-         the FILE= specifier shall appear.  */
-      if (open->file == NULL &&
-         (strncasecmp (open->status->value.character.string, "replace", 7) == 0
-         || strncasecmp (open->status->value.character.string, "new", 3) == 0))
+        the FILE= specifier shall appear.  */
+      if (open->file == NULL
+         && (gfc_wide_strncasecmp (open->status->value.character.string,
+                                   "replace", 7) == 0
+             || gfc_wide_strncasecmp (open->status->value.character.string,
+                                      "new", 3) == 0))
        {
        {
-         warn_or_error ("The STATUS specified in OPEN statement at %C is '%s' "
-                        "and no FILE specifier is present",
-                        open->status->value.character.string);
+         char *s = gfc_widechar_to_char (open->status->value.character.string,
+                                         -1);
+         warn_or_error ("The STATUS specified in OPEN statement at %C is "
+                        "'%s' and no FILE specifier is present", s);
+         gfc_free (s);
        }
 
       /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
         the FILE= specifier shall not appear.  */
        }
 
       /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
         the FILE= specifier shall not appear.  */
-      if (strncasecmp (open->status->value.character.string, "scratch", 7) == 0
-         && open->file)
+      if (gfc_wide_strncasecmp (open->status->value.character.string,
+                               "scratch", 7) == 0 && open->file)
        {
        {
-         warn_or_error ("The STATUS specified in OPEN statement at %C cannot "
-                        "have the value SCRATCH if a FILE specifier "
+         warn_or_error ("The STATUS specified in OPEN statement at %C "
+                        "cannot have the value SCRATCH if a FILE specifier "
                         "is present");
        }
     }
 
   /* Things that are not allowed for unformatted I/O.  */
   if (open->form && open->form->expr_type == EXPR_CONSTANT
                         "is present");
        }
     }
 
   /* Things that are not allowed for unformatted I/O.  */
   if (open->form && open->form->expr_type == EXPR_CONSTANT
-      && (open->delim
-         /* TODO uncomment this code when F2003 support is finished */
-         /* || open->decimal || open->encoding || open->round
-            || open->sign */
-         || open->pad || open->blank)
-      && strncasecmp (open->form->value.character.string,
-                     "unformatted", 11) == 0)
-    {
-      const char * spec = (open->delim ? "DELIM " : (open->pad ? "PAD " :
-           open->blank ? "BLANK " : ""));
-
-      warn_or_error ("%sspecifier at %C not allowed in OPEN statement for "
+      && (open->delim || open->decimal || open->encoding || open->round
+         || open->sign || open->pad || open->blank)
+      && gfc_wide_strncasecmp (open->form->value.character.string,
+                              "unformatted", 11) == 0)
+    {
+      const char *spec = (open->delim ? "DELIM "
+                                     : (open->pad ? "PAD " : open->blank
+                                                           ? "BLANK " : ""));
+
+      warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
                     "unformatted I/O", spec);
     }
 
   if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT
                     "unformatted I/O", spec);
     }
 
   if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT
-      && strncasecmp (open->access->value.character.string, "stream", 6) == 0)
+      && gfc_wide_strncasecmp (open->access->value.character.string,
+                              "stream", 6) == 0)
     {
       warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
                     "stream I/O");
     }
 
     {
       warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
                     "stream I/O");
     }
 
-  if (open->position && open->access && open->access->expr_type == EXPR_CONSTANT
-      && !(strncasecmp (open->access->value.character.string,
-                       "sequential", 10) == 0
-          || strncasecmp (open->access->value.character.string,
-                          "stream", 6) == 0
-          || strncasecmp (open->access->value.character.string,
-                          "append", 6) == 0))
+  if (open->position
+      && open->access && open->access->expr_type == EXPR_CONSTANT
+      && !(gfc_wide_strncasecmp (open->access->value.character.string,
+                                "sequential", 10) == 0
+          || gfc_wide_strncasecmp (open->access->value.character.string,
+                                   "stream", 6) == 0
+          || gfc_wide_strncasecmp (open->access->value.character.string,
+                                   "append", 6) == 0))
     {
       warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
                     "for stream or sequential ACCESS");
     {
       warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
                     "for stream or sequential ACCESS");
@@ -1648,9 +2121,8 @@ cleanup:
 /* Free a gfc_close structure an all its expressions.  */
 
 void
 /* Free a gfc_close structure an all its expressions.  */
 
 void
-gfc_free_close (gfc_close * close)
+gfc_free_close (gfc_close *close)
 {
 {
-
   if (close == NULL)
     return;
 
   if (close == NULL)
     return;
 
@@ -1658,7 +2130,6 @@ gfc_free_close (gfc_close * close)
   gfc_free_expr (close->iomsg);
   gfc_free_expr (close->iostat);
   gfc_free_expr (close->status);
   gfc_free_expr (close->iomsg);
   gfc_free_expr (close->iostat);
   gfc_free_expr (close->status);
-
   gfc_free (close);
 }
 
   gfc_free (close);
 }
 
@@ -1666,7 +2137,7 @@ gfc_free_close (gfc_close * close)
 /* Match elements of a CLOSE statement.  */
 
 static match
 /* Match elements of a CLOSE statement.  */
 
 static match
-match_close_element (gfc_close * close)
+match_close_element (gfc_close *close)
 {
   match m;
 
 {
   match m;
 
@@ -1703,7 +2174,7 @@ gfc_match_close (void)
   if (m == MATCH_NO)
     return m;
 
   if (m == MATCH_NO)
     return m;
 
-  close = gfc_getmem (sizeof (gfc_close));
+  close = XCNEW (gfc_close);
 
   m = match_close_element (close);
 
 
   m = match_close_element (close);
 
@@ -1746,7 +2217,7 @@ gfc_match_close (void)
   /* Checks on the STATUS specifier.  */
   if (close->status && close->status->expr_type == EXPR_CONSTANT)
     {
   /* Checks on the STATUS specifier.  */
   if (close->status && close->status->expr_type == EXPR_CONSTANT)
     {
-      static const char * status[] = { "KEEP", "DELETE", NULL };
+      static const char *status[] = { "KEEP", "DELETE", NULL };
 
       if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
                                      close->status->value.character.string,
 
       if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
                                      close->status->value.character.string,
@@ -1769,10 +2240,9 @@ cleanup:
 
 /* Resolve everything in a gfc_close structure.  */
 
 
 /* Resolve everything in a gfc_close structure.  */
 
-try
-gfc_resolve_close (gfc_close * close)
+gfc_try
+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_unit, close->unit);
   RESOLVE_TAG (&tag_iomsg, close->iomsg);
   RESOLVE_TAG (&tag_iostat, close->iostat);
@@ -1781,6 +2251,14 @@ gfc_resolve_close (gfc_close * close)
   if (gfc_reference_st_label (close->err, ST_LABEL_TARGET) == FAILURE)
     return FAILURE;
 
   if (gfc_reference_st_label (close->err, ST_LABEL_TARGET) == FAILURE)
     return FAILURE;
 
+  if (close->unit->expr_type == EXPR_CONSTANT
+      && close->unit->ts.type == BT_INTEGER
+      && mpz_sgn (close->unit->value.integer) < 0)
+    {
+      gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
+                &close->unit->where);
+    }
+
   return SUCCESS;
 }
 
   return SUCCESS;
 }
 
@@ -1788,9 +2266,8 @@ gfc_resolve_close (gfc_close * close)
 /* Free a gfc_filepos structure.  */
 
 void
 /* Free a gfc_filepos structure.  */
 
 void
-gfc_free_filepos (gfc_filepos * fp)
+gfc_free_filepos (gfc_filepos *fp)
 {
 {
-
   gfc_free_expr (fp->unit);
   gfc_free_expr (fp->iomsg);
   gfc_free_expr (fp->iostat);
   gfc_free_expr (fp->unit);
   gfc_free_expr (fp->iomsg);
   gfc_free_expr (fp->iostat);
@@ -1801,7 +2278,7 @@ gfc_free_filepos (gfc_filepos * fp)
 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement.  */
 
 static match
 /* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement.  */
 
 static match
-match_file_element (gfc_filepos * fp)
+match_file_element (gfc_filepos *fp)
 {
   match m;
 
 {
   match m;
 
@@ -1831,7 +2308,7 @@ match_filepos (gfc_statement st, gfc_exec_op op)
   gfc_filepos *fp;
   match m;
 
   gfc_filepos *fp;
   match m;
 
-  fp = gfc_getmem (sizeof (gfc_filepos));
+  fp = XCNEW (gfc_filepos);
 
   if (gfc_match_char ('(') == MATCH_NO)
     {
 
   if (gfc_match_char ('(') == MATCH_NO)
     {
@@ -1895,16 +2372,23 @@ cleanup:
 }
 
 
 }
 
 
-try
-gfc_resolve_filepos (gfc_filepos * fp)
+gfc_try
+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;
 
   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;
 
+  if (fp->unit->expr_type == EXPR_CONSTANT
+      && fp->unit->ts.type == BT_INTEGER
+      && mpz_sgn (fp->unit->value.integer) < 0)
+    {
+      gfc_error ("UNIT number in statement at %L must be non-negative",
+                &fp->unit->where);
+    }
+
   return SUCCESS;
 }
 
   return SUCCESS;
 }
 
@@ -1915,28 +2399,26 @@ gfc_resolve_filepos (gfc_filepos * fp)
 match
 gfc_match_endfile (void)
 {
 match
 gfc_match_endfile (void)
 {
-
   return match_filepos (ST_END_FILE, EXEC_ENDFILE);
 }
 
 match
 gfc_match_backspace (void)
 {
   return match_filepos (ST_END_FILE, EXEC_ENDFILE);
 }
 
 match
 gfc_match_backspace (void)
 {
-
   return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
 }
 
 match
 gfc_match_rewind (void)
 {
   return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
 }
 
 match
 gfc_match_rewind (void)
 {
-
   return match_filepos (ST_REWIND, EXEC_REWIND);
 }
 
 match
 gfc_match_flush (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)
+  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: FLUSH statement at %C")
+      == FAILURE)
     return MATCH_ERROR;
 
   return match_filepos (ST_FLUSH, EXEC_FLUSH);
     return MATCH_ERROR;
 
   return match_filepos (ST_FLUSH, EXEC_FLUSH);
@@ -1944,11 +2426,6 @@ gfc_match_flush (void)
 
 /******************** Data Transfer Statements *********************/
 
 
 /******************** Data Transfer Statements *********************/
 
-typedef enum
-{ M_READ, M_WRITE, M_PRINT, M_INQUIRE }
-io_kind;
-
-
 /* Return a default unit number.  */
 
 static gfc_expr *
 /* Return a default unit number.  */
 
 static gfc_expr *
@@ -1961,14 +2438,14 @@ default_unit (io_kind k)
   else
     unit = 6;
 
   else
     unit = 6;
 
-  return gfc_int_expr (unit);
+  return gfc_get_int_expr (gfc_default_integer_kind, NULL, unit);
 }
 
 
 /* Match a unit specification for a data transfer statement.  */
 
 static match
 }
 
 
 /* Match a unit specification for a data transfer statement.  */
 
 static match
-match_dt_unit (io_kind k, gfc_dt * dt)
+match_dt_unit (io_kind k, gfc_dt *dt)
 {
   gfc_expr *e;
 
 {
   gfc_expr *e;
 
@@ -2004,11 +2481,12 @@ conflict:
 /* Match a format specification.  */
 
 static match
 /* Match a format specification.  */
 
 static match
-match_dt_format (gfc_dt * dt)
+match_dt_format (gfc_dt *dt)
 {
   locus where;
   gfc_expr *e;
   gfc_st_label *label;
 {
   locus where;
   gfc_expr *e;
   gfc_st_label *label;
+  match m;
 
   where = gfc_current_locus;
 
 
   where = gfc_current_locus;
 
@@ -2021,7 +2499,7 @@ match_dt_format (gfc_dt * dt)
       return MATCH_YES;
     }
 
       return MATCH_YES;
     }
 
-  if (gfc_match_st_label (&label) == MATCH_YES)
+  if ((m = gfc_match_st_label (&label)) == MATCH_YES)
     {
       if (dt->format_expr != NULL || dt->format_label != NULL)
        {
     {
       if (dt->format_expr != NULL || dt->format_label != NULL)
        {
@@ -2035,6 +2513,9 @@ match_dt_format (gfc_dt * dt)
       dt->format_label = label;
       return MATCH_YES;
     }
       dt->format_label = label;
       return MATCH_YES;
     }
+  else if (m == MATCH_ERROR)
+    /* The label was zero or too large.  Emit the correct diagnosis.  */
+    return MATCH_ERROR;
 
   if (gfc_match_expr (&e) == MATCH_YES)
     {
 
   if (gfc_match_expr (&e) == MATCH_YES)
     {
@@ -2062,7 +2543,7 @@ conflict:
    nonzero if we find such a variable.  */
 
 static int
    nonzero if we find such a variable.  */
 
 static int
-check_namelist (gfc_symbol * sym)
+check_namelist (gfc_symbol *sym)
 {
   gfc_namelist *p;
 
 {
   gfc_namelist *p;
 
@@ -2081,7 +2562,7 @@ check_namelist (gfc_symbol * sym)
 /* Match a single data transfer element.  */
 
 static match
 /* Match a single data transfer element.  */
 
 static match
-match_dt_element (io_kind k, gfc_dt * dt)
+match_dt_element (io_kind k, gfc_dt *dt)
 {
   char name[GFC_MAX_SYMBOL_LEN + 1];
   gfc_symbol *sym;
 {
   char name[GFC_MAX_SYMBOL_LEN + 1];
   gfc_symbol *sym;
@@ -2126,10 +2607,34 @@ match_dt_element (io_kind k, gfc_dt * dt)
       return MATCH_YES;
     }
 
       return MATCH_YES;
     }
 
+  m = match_etag (&tag_e_async, &dt->asynchronous);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_blank, &dt->blank);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_delim, &dt->delim);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_pad, &dt->pad);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_sign, &dt->sign);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_round, &dt->round);
+  if (m != MATCH_NO)
+    return m;
+  m = match_out_tag (&tag_id, &dt->id);
+  if (m != MATCH_NO)
+    return m;
+  m = match_etag (&tag_e_decimal, &dt->decimal);
+  if (m != MATCH_NO)
+    return m;
   m = match_etag (&tag_rec, &dt->rec);
   if (m != MATCH_NO)
     return m;
   m = match_etag (&tag_rec, &dt->rec);
   if (m != MATCH_NO)
     return m;
-  m = match_etag (&tag_spos, &dt->rec);
+  m = match_etag (&tag_spos, &dt->pos);
   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_iomsg, &dt->iomsg);
@@ -2155,8 +2660,8 @@ match_dt_element (io_kind k, gfc_dt * dt)
     {
       if (k == M_WRITE)
        {
     {
       if (k == M_WRITE)
        {
-         gfc_error ("END tag at %C not allowed in output statement");
-         return MATCH_ERROR;
+        gfc_error ("END tag at %C not allowed in output statement");
+        return MATCH_ERROR;
        }
       dt->end_where = gfc_current_locus;
     }
        }
       dt->end_where = gfc_current_locus;
     }
@@ -2176,9 +2681,8 @@ match_dt_element (io_kind k, gfc_dt * dt)
 /* Free a data transfer structure and everything below it.  */
 
 void
 /* Free a data transfer structure and everything below it.  */
 
 void
-gfc_free_dt (gfc_dt * dt)
+gfc_free_dt (gfc_dt *dt)
 {
 {
-
   if (dt == NULL)
     return;
 
   if (dt == NULL)
     return;
 
@@ -2189,44 +2693,93 @@ gfc_free_dt (gfc_dt * dt)
   gfc_free_expr (dt->iomsg);
   gfc_free_expr (dt->iostat);
   gfc_free_expr (dt->size);
   gfc_free_expr (dt->iomsg);
   gfc_free_expr (dt->iostat);
   gfc_free_expr (dt->size);
-
+  gfc_free_expr (dt->pad);
+  gfc_free_expr (dt->delim);
+  gfc_free_expr (dt->sign);
+  gfc_free_expr (dt->round);
+  gfc_free_expr (dt->blank);
+  gfc_free_expr (dt->decimal);
+  gfc_free_expr (dt->extra_comma);
+  gfc_free_expr (dt->pos);
   gfc_free (dt);
 }
 
 
 /* Resolve everything in a gfc_dt structure.  */
 
   gfc_free (dt);
 }
 
 
 /* Resolve everything in a gfc_dt structure.  */
 
-try
-gfc_resolve_dt (gfc_dt * dt)
+gfc_try
+gfc_resolve_dt (gfc_dt *dt, locus *loc)
 {
   gfc_expr *e;
 
   RESOLVE_TAG (&tag_format, dt->format_expr);
   RESOLVE_TAG (&tag_rec, dt->rec);
 {
   gfc_expr *e;
 
   RESOLVE_TAG (&tag_format, dt->format_expr);
   RESOLVE_TAG (&tag_rec, dt->rec);
-  RESOLVE_TAG (&tag_spos, dt->rec);
+  RESOLVE_TAG (&tag_spos, dt->pos);
   RESOLVE_TAG (&tag_advance, dt->advance);
   RESOLVE_TAG (&tag_advance, dt->advance);
+  RESOLVE_TAG (&tag_id, dt->id);
   RESOLVE_TAG (&tag_iomsg, dt->iomsg);
   RESOLVE_TAG (&tag_iostat, dt->iostat);
   RESOLVE_TAG (&tag_size, dt->size);
   RESOLVE_TAG (&tag_iomsg, dt->iomsg);
   RESOLVE_TAG (&tag_iostat, dt->iostat);
   RESOLVE_TAG (&tag_size, dt->size);
+  RESOLVE_TAG (&tag_e_pad, dt->pad);
+  RESOLVE_TAG (&tag_e_delim, dt->delim);
+  RESOLVE_TAG (&tag_e_sign, dt->sign);
+  RESOLVE_TAG (&tag_e_round, dt->round);
+  RESOLVE_TAG (&tag_e_blank, dt->blank);
+  RESOLVE_TAG (&tag_e_decimal, dt->decimal);
+  RESOLVE_TAG (&tag_e_async, dt->asynchronous);
 
   e = dt->io_unit;
 
   e = dt->io_unit;
+  if (e == NULL)
+    {
+      gfc_error ("UNIT not specified at %L", loc);
+      return FAILURE;
+    }
+
   if (gfc_resolve_expr (e) == SUCCESS
       && (e->ts.type != BT_INTEGER
   if (gfc_resolve_expr (e) == SUCCESS
       && (e->ts.type != BT_INTEGER
-         && (e->ts.type != BT_CHARACTER
-             || e->expr_type != EXPR_VARIABLE)))
+         && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
     {
     {
-      gfc_error
-       ("UNIT specification at %L must be an INTEGER expression or a "
-        "CHARACTER variable", &e->where);
-      return FAILURE;
+      /* If there is no extra comma signifying the "format" form of the IO
+        statement, then this must be an error.  */
+      if (!dt->extra_comma)
+       {
+         gfc_error ("UNIT specification at %L must be an INTEGER expression "
+                    "or a CHARACTER variable", &e->where);
+         return FAILURE;
+       }
+      else
+       {
+         /* At this point, we have an extra comma.  If io_unit has arrived as
+            type character, we assume its really the "format" form of the I/O
+            statement.  We set the io_unit to the default unit and format to
+            the character expression.  See F95 Standard section 9.4.  */
+         io_kind k;
+         k = dt->extra_comma->value.iokind;
+         if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT))
+           {
+             dt->format_expr = dt->io_unit;
+             dt->io_unit = default_unit (k);
+
+             /* Free this pointer now so that a warning/error is not triggered
+                below for the "Extension".  */
+             gfc_free_expr (dt->extra_comma);
+             dt->extra_comma = NULL;
+           }
+
+         if (k == M_WRITE)
+           {
+             gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
+                        &dt->extra_comma->where);
+             return FAILURE;
+           }
+       }
     }
 
   if (e->ts.type == BT_CHARACTER)
     {
       if (gfc_has_vector_index (e))
        {
     }
 
   if (e->ts.type == BT_CHARACTER)
     {
       if (gfc_has_vector_index (e))
        {
-         gfc_error ("Internal unit with vector subscript at %L",
-                    &e->where);
+         gfc_error ("Internal unit with vector subscript at %L", &e->where);
          return FAILURE;
        }
     }
          return FAILURE;
        }
     }
@@ -2237,6 +2790,18 @@ gfc_resolve_dt (gfc_dt * dt)
       return FAILURE;
     }
 
       return FAILURE;
     }
 
+  if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER
+      && mpz_sgn (e->value.integer) < 0)
+    {
+      gfc_error ("UNIT number in statement at %L must be non-negative", &e->where);
+      return FAILURE;
+    }
+
+  if (dt->extra_comma
+      && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before i/o "
+                        "item list at %L", &dt->extra_comma->where) == FAILURE)
+    return FAILURE;
+
   if (dt->err)
     {
       if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
   if (dt->err)
     {
       if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
@@ -2278,7 +2843,7 @@ gfc_resolve_dt (gfc_dt * dt)
       && dt->format_label->defined == ST_LABEL_UNKNOWN)
     {
       gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
       && dt->format_label->defined == ST_LABEL_UNKNOWN)
     {
       gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
-                &dt->format_label->where);
+                &dt->format_label->where);
       return FAILURE;
     }
   return SUCCESS;
       return FAILURE;
     }
   return SUCCESS;
@@ -2321,12 +2886,12 @@ io_kind_name (io_kind k)
    which is equivalent to a single IO element.  This function is
    mutually recursive with match_io_element().  */
 
    which is equivalent to a single IO element.  This function is
    mutually recursive with match_io_element().  */
 
-static match match_io_element (io_kind k, gfc_code **);
+static match match_io_element (io_kind, gfc_code **);
 
 static match
 
 static match
-match_io_iterator (io_kind k, gfc_code ** result)
+match_io_iterator (io_kind k, gfc_code **result)
 {
 {
-  gfc_code *head, *tail, *new;
+  gfc_code *head, *tail, *new_code;
   gfc_iterator *iter;
   locus old_loc;
   match m;
   gfc_iterator *iter;
   locus old_loc;
   match m;
@@ -2362,7 +2927,7 @@ match_io_iterator (io_kind k, gfc_code ** result)
          break;
        }
 
          break;
        }
 
-      m = match_io_element (k, &new);
+      m = match_io_element (k, &new_code);
       if (m == MATCH_ERROR)
        goto cleanup;
       if (m == MATCH_NO)
       if (m == MATCH_ERROR)
        goto cleanup;
       if (m == MATCH_NO)
@@ -2372,7 +2937,7 @@ match_io_iterator (io_kind k, gfc_code ** result)
          goto cleanup;
        }
 
          goto cleanup;
        }
 
-      tail = gfc_append_code (tail, new);
+      tail = gfc_append_code (tail, new_code);
 
       if (gfc_match_char (',') != MATCH_YES)
        {
 
       if (gfc_match_char (',') != MATCH_YES)
        {
@@ -2386,15 +2951,15 @@ match_io_iterator (io_kind k, gfc_code ** result)
   if (gfc_match_char (')') != MATCH_YES)
     goto syntax;
 
   if (gfc_match_char (')') != MATCH_YES)
     goto syntax;
 
-  new = gfc_get_code ();
-  new->op = EXEC_DO;
-  new->ext.iterator = iter;
+  new_code = gfc_get_code ();
+  new_code->op = EXEC_DO;
+  new_code->ext.iterator = iter;
 
 
-  new->block = gfc_get_code ();
-  new->block->op = EXEC_DO;
-  new->block->next = head;
+  new_code->block = gfc_get_code ();
+  new_code->block->op = EXEC_DO;
+  new_code->block->next = head;
 
 
-  *result = new;
+  *result = new_code;
   return MATCH_YES;
 
 syntax:
   return MATCH_YES;
 
 syntax:
@@ -2413,7 +2978,7 @@ cleanup:
    expression or an IO Iterator.  */
 
 static match
    expression or an IO Iterator.  */
 
 static match
-match_io_element (io_kind k, gfc_code ** cpp)
+match_io_element (io_kind k, gfc_code **cpp)
 {
   gfc_expr *expr;
   gfc_code *cp;
 {
   gfc_expr *expr;
   gfc_code *cp;
@@ -2445,14 +3010,14 @@ match_io_element (io_kind k, gfc_code ** cpp)
       case M_READ:
        if (expr->symtree->n.sym->attr.intent == INTENT_IN)
          {
       case M_READ:
        if (expr->symtree->n.sym->attr.intent == INTENT_IN)
          {
-           gfc_error
-             ("Variable '%s' in input list at %C cannot be INTENT(IN)",
-              expr->symtree->n.sym->name);
+           gfc_error ("Variable '%s' in input list at %C cannot be "
+                      "INTENT(IN)", expr->symtree->n.sym->name);
            m = MATCH_ERROR;
          }
 
        if (gfc_pure (NULL)
            && gfc_impure_variable (expr->symtree->n.sym)
            m = MATCH_ERROR;
          }
 
        if (gfc_pure (NULL)
            && gfc_impure_variable (expr->symtree->n.sym)
+           && current_dt->io_unit
            && current_dt->io_unit->ts.type == BT_CHARACTER)
          {
            gfc_error ("Cannot read to variable '%s' in PURE procedure at %C",
            && current_dt->io_unit->ts.type == BT_CHARACTER)
          {
            gfc_error ("Cannot read to variable '%s' in PURE procedure at %C",
@@ -2466,14 +3031,15 @@ match_io_element (io_kind k, gfc_code ** cpp)
        break;
 
       case M_WRITE:
        break;
 
       case M_WRITE:
-       if (current_dt->io_unit->ts.type == BT_CHARACTER
+       if (current_dt->io_unit
+           && current_dt->io_unit->ts.type == BT_CHARACTER
            && gfc_pure (NULL)
            && current_dt->io_unit->expr_type == EXPR_VARIABLE
            && gfc_impure_variable (current_dt->io_unit->symtree->n.sym))
          {
            && gfc_pure (NULL)
            && current_dt->io_unit->expr_type == EXPR_VARIABLE
            && gfc_impure_variable (current_dt->io_unit->symtree->n.sym))
          {
-           gfc_error
-             ("Cannot write to internal file unit '%s' at %C inside a "
-              "PURE procedure", current_dt->io_unit->symtree->n.sym->name);
+           gfc_error ("Cannot write to internal file unit '%s' at %C "
+                      "inside a PURE procedure",
+                      current_dt->io_unit->symtree->n.sym->name);
            m = MATCH_ERROR;
          }
 
            m = MATCH_ERROR;
          }
 
@@ -2491,7 +3057,7 @@ match_io_element (io_kind k, gfc_code ** cpp)
 
   cp = gfc_get_code ();
   cp->op = EXEC_TRANSFER;
 
   cp = gfc_get_code ();
   cp->op = EXEC_TRANSFER;
-  cp->expr = expr;
+  cp->expr1 = expr;
 
   *cpp = cp;
   return MATCH_YES;
 
   *cpp = cp;
   return MATCH_YES;
@@ -2501,9 +3067,9 @@ match_io_element (io_kind k, gfc_code ** cpp)
 /* Match an I/O list, building gfc_code structures as we go.  */
 
 static match
 /* Match an I/O list, building gfc_code structures as we go.  */
 
 static match
-match_io_list (io_kind k, gfc_code ** head_p)
+match_io_list (io_kind k, gfc_code **head_p)
 {
 {
-  gfc_code *head, *tail, *new;
+  gfc_code *head, *tail, *new_code;
   match m;
 
   *head_p = head = tail = NULL;
   match m;
 
   *head_p = head = tail = NULL;
@@ -2512,15 +3078,15 @@ match_io_list (io_kind k, gfc_code ** head_p)
 
   for (;;)
     {
 
   for (;;)
     {
-      m = match_io_element (k, &new);
+      m = match_io_element (k, &new_code);
       if (m == MATCH_ERROR)
        goto cleanup;
       if (m == MATCH_NO)
        goto syntax;
 
       if (m == MATCH_ERROR)
        goto cleanup;
       if (m == MATCH_NO)
        goto syntax;
 
-      tail = gfc_append_code (tail, new);
+      tail = gfc_append_code (tail, new_code);
       if (head == NULL)
       if (head == NULL)
-       head = new;
+       head = new_code;
 
       if (gfc_match_eos () == MATCH_YES)
        break;
 
       if (gfc_match_eos () == MATCH_YES)
        break;
@@ -2543,7 +3109,7 @@ cleanup:
 /* Attach the data transfer end node.  */
 
 static void
 /* Attach the data transfer end node.  */
 
 static void
-terminate_io (gfc_code * io_code)
+terminate_io (gfc_code *io_code)
 {
   gfc_code *c;
 
 {
   gfc_code *c;
 
@@ -2564,7 +3130,8 @@ terminate_io (gfc_code * io_code)
    in resolve_tag and others in gfc_resolve_dt.  */
 
 static match
    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)
+check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
+                     locus *spec_end)
 {
 #define io_constraint(condition,msg,arg)\
 if (condition) \
 {
 #define io_constraint(condition,msg,arg)\
 if (condition) \
@@ -2574,14 +3141,19 @@ if (condition) \
   }
 
   match m;
   }
 
   match m;
-  gfc_expr * expr;
-  gfc_symbol * sym = NULL;
+  gfc_expr *expr;
+  gfc_symbol *sym = NULL;
+  bool warn, unformatted;
+
+  warn = (dt->err || dt->iostat) ? true : false;
+  unformatted = dt->format_expr == NULL && dt->format_label == NULL
+               && dt->namelist == NULL;
 
   m = MATCH_YES;
 
   expr = dt->io_unit;
   if (expr && expr->expr_type == EXPR_VARIABLE
 
   m = MATCH_YES;
 
   expr = dt->io_unit;
   if (expr && expr->expr_type == EXPR_VARIABLE
-       && expr->ts.type == BT_CHARACTER)
+      && expr->ts.type == BT_CHARACTER)
     {
       sym = expr->symtree->n.sym;
 
     {
       sym = expr->symtree->n.sym;
 
@@ -2596,14 +3168,26 @@ if (condition) \
       io_constraint (dt->rec != NULL,
                     "REC tag at %L is incompatible with internal file",
                     &dt->rec->where);
       io_constraint (dt->rec != NULL,
                     "REC tag at %L is incompatible with internal file",
                     &dt->rec->where);
+    
+      io_constraint (dt->pos != NULL,
+                    "POS tag at %L is incompatible with internal file",
+                    &dt->pos->where);
+
+      io_constraint (unformatted,
+                    "Unformatted I/O not allowed with internal unit at %L",
+                    &dt->io_unit->where);
+
+      io_constraint (dt->asynchronous != NULL,
+                    "ASYNCHRONOUS tag at %L not allowed with internal file",
+                    &dt->asynchronous->where);
 
       if (dt->namelist != NULL)
 
       if (dt->namelist != NULL)
-        {
-          if (gfc_notify_std(GFC_STD_F2003,
-                         "Fortran 2003: Internal file at %L with namelist",
-                         &expr->where) == FAILURE)
-            m = MATCH_ERROR;
-        }
+       {
+         if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Internal file "
+                             "at %L with namelist", &expr->where)
+             == FAILURE)
+           m = MATCH_ERROR;
+       }
 
       io_constraint (dt->advance != NULL,
                     "ADVANCE tag at %L is incompatible with internal file",
 
       io_constraint (dt->advance != NULL,
                     "ADVANCE tag at %L is incompatible with internal file",
@@ -2613,26 +3197,27 @@ if (condition) \
   if (expr && expr->ts.type != BT_CHARACTER)
     {
 
   if (expr && expr->ts.type != BT_CHARACTER)
     {
 
-      io_constraint (gfc_pure (NULL)
-                      && (k == M_READ || k == M_WRITE),
+      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));
     }
 
                     "IO UNIT in %s statement at %C must be "
                     "an internal file in a PURE procedure",
                     io_kind_name (k));
     }
 
-
   if (k != M_READ)
     {
   if (k != M_READ)
     {
-      io_constraint (dt->end,
-                    "END tag not allowed with output at %L",
+      io_constraint (dt->end, "END tag not allowed with output at %L",
                     &dt->end_where);
 
                     &dt->end_where);
 
-      io_constraint (dt->eor,
-                    "EOR tag not allowed with output at %L",
+      io_constraint (dt->eor, "EOR tag not allowed with output at %L",
                     &dt->eor_where);
 
                     &dt->eor_where);
 
-      io_constraint (k != M_READ && dt->size,
-                    "SIZE=specifier not allowed with output at %L",
+      io_constraint (dt->blank, "BLANK= specifier not allowed with output at %L",
+                    &dt->blank->where);
+
+      io_constraint (dt->pad, "PAD= specifier not allowed with output at %L",
+                    &dt->pad->where);
+
+      io_constraint (dt->size, "SIZE= specifier not allowed with output at %L",
                     &dt->size->where);
     }
   else
                     &dt->size->where);
     }
   else
@@ -2646,8 +3231,174 @@ if (condition) \
                     &dt->eor_where);
     }
 
                     &dt->eor_where);
     }
 
+  if (dt->asynchronous) 
+    {
+      static const char * asynchronous[] = { "YES", "NO", NULL };
+
+      if (gfc_reduce_init_expr (dt->asynchronous) != SUCCESS)
+       {
+         gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
+                    "expression", &dt->asynchronous->where);
+         return MATCH_ERROR;
+       }
+
+      if (!compare_to_allowed_values
+               ("ASYNCHRONOUS", asynchronous, NULL, NULL,
+                dt->asynchronous->value.character.string,
+                io_kind_name (k), warn))
+       return MATCH_ERROR;
+    }
+
+  if (dt->id)
+    {
+      bool not_yes
+       = !dt->asynchronous
+         || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3
+         || gfc_wide_strncasecmp (dt->asynchronous->value.character.string,
+                                  "yes", 3) != 0;
+      io_constraint (not_yes,
+                    "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
+                    "specifier", &dt->id->where);
+    }
+
+  if (dt->decimal)
+    {
+      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C "
+         "not allowed in Fortran 95") == FAILURE)
+       return MATCH_ERROR;
+
+      if (dt->decimal->expr_type == EXPR_CONSTANT)
+       {
+         static const char * decimal[] = { "COMMA", "POINT", NULL };
+
+         if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
+                                         dt->decimal->value.character.string,
+                                         io_kind_name (k), warn))
+           return MATCH_ERROR;
+
+         io_constraint (unformatted,
+                        "the DECIMAL= specifier at %L must be with an "
+                        "explicit format expression", &dt->decimal->where);
+       }
+    }
+  
+  if (dt->blank)
+    {
+      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C "
+         "not allowed in Fortran 95") == FAILURE)
+       return MATCH_ERROR;
+
+      if (dt->blank->expr_type == EXPR_CONSTANT)
+       {
+         static const char * blank[] = { "NULL", "ZERO", NULL };
+
+         if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
+                                         dt->blank->value.character.string,
+                                         io_kind_name (k), warn))
+           return MATCH_ERROR;
+
+         io_constraint (unformatted,
+                        "the BLANK= specifier at %L must be with an "
+                        "explicit format expression", &dt->blank->where);
+       }
+    }
+
+  if (dt->pad)
+    {
+      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PAD= at %C "
+         "not allowed in Fortran 95") == FAILURE)
+       return MATCH_ERROR;
+
+      if (dt->pad->expr_type == EXPR_CONSTANT)
+       {
+         static const char * pad[] = { "YES", "NO", NULL };
+
+         if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
+                                         dt->pad->value.character.string,
+                                         io_kind_name (k), warn))
+           return MATCH_ERROR;
+
+         io_constraint (unformatted,
+                        "the PAD= specifier at %L must be with an "
+                        "explicit format expression", &dt->pad->where);
+       }
+    }
+
+  if (dt->round)
+    {
+      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ROUND= at %C "
+         "not allowed in Fortran 95") == FAILURE)
+       return MATCH_ERROR;
+
+      if (dt->round->expr_type == EXPR_CONSTANT)
+       {
+         static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
+                                         "COMPATIBLE", "PROCESSOR_DEFINED",
+                                         NULL };
+
+         if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
+                                         dt->round->value.character.string,
+                                         io_kind_name (k), warn))
+           return MATCH_ERROR;
+       }
+    }
+  
+  if (dt->sign)
+    {
+      /* When implemented, change the following to use gfc_notify_std F2003.
+      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
+         "not allowed in Fortran 95") == FAILURE)
+       return MATCH_ERROR;  */
+      if (dt->sign->expr_type == EXPR_CONSTANT)
+       {
+         static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
+                                        NULL };
+
+         if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
+                                     dt->sign->value.character.string,
+                                     io_kind_name (k), warn))
+           return MATCH_ERROR;
 
 
+         io_constraint (unformatted,
+                        "SIGN= specifier at %L must be with an "
+                        "explicit format expression", &dt->sign->where);
 
 
+         io_constraint (k == M_READ,
+                        "SIGN= specifier at %L not allowed in a "
+                        "READ statement", &dt->sign->where);
+       }
+    }
+
+  if (dt->delim)
+    {
+      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C "
+         "not allowed in Fortran 95") == FAILURE)
+       return MATCH_ERROR;
+
+      if (dt->delim->expr_type == EXPR_CONSTANT)
+       {
+         static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
+
+         if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
+                                         dt->delim->value.character.string,
+                                         io_kind_name (k), warn))
+           return MATCH_ERROR;
+
+         io_constraint (k == M_READ,
+                        "DELIM= specifier at %L not allowed in a "
+                        "READ statement", &dt->delim->where);
+      
+         io_constraint (dt->format_label != &format_asterisk
+                        && dt->namelist == NULL,
+                        "DELIM= specifier at %L must have FMT=*",
+                        &dt->delim->where);
+
+         io_constraint (unformatted && dt->namelist == NULL,
+                        "DELIM= specifier at %L must be with FMT=* or "
+                        "NML= specifier ", &dt->delim->where);
+       }
+    }
+  
   if (dt->namelist)
     {
       io_constraint (io_code && dt->namelist,
   if (dt->namelist)
     {
       io_constraint (io_code && dt->namelist,
@@ -2656,7 +3407,7 @@ if (condition) \
 
       io_constraint (dt->format_expr,
                     "IO spec-list cannot contain both NAMELIST group name "
 
       io_constraint (dt->format_expr,
                     "IO spec-list cannot contain both NAMELIST group name "
-                    "and format specification at %L.",
+                    "and format specification at %L",
                     &dt->format_expr->where);
 
       io_constraint (dt->format_label,
                     &dt->format_expr->where);
 
       io_constraint (dt->format_label,
@@ -2664,24 +3415,27 @@ if (condition) \
                     "and format label at %L", spec_end);
 
       io_constraint (dt->rec,
                     "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);
+                    "NAMELIST IO is not allowed with a REC= specifier "
+                    "at %L", &dt->rec->where);
 
       io_constraint (dt->advance,
 
       io_constraint (dt->advance,
-                    "NAMELIST IO is not allowed with a ADVANCE=specifier "
-                    "at %L.", &dt->advance->where);
+                    "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 "
     }
 
   if (dt->rec)
     {
       io_constraint (dt->end,
                     "An END tag is not allowed with a "
-                    "REC=specifier at %L.", &dt->end_where);
-
+                    "REC= specifier at %L", &dt->end_where);
 
       io_constraint (dt->format_label == &format_asterisk,
 
       io_constraint (dt->format_label == &format_asterisk,
-                    "FMT=* is not allowed with a REC=specifier "
-                    "at %L.", spec_end);
+                    "FMT=* is not allowed with a REC= specifier "
+                    "at %L", spec_end);
+
+      io_constraint (dt->pos,
+                    "POS= is not allowed with REC= specifier "
+                    "at %L", &dt->pos->where);
     }
 
   if (dt->advance)
     }
 
   if (dt->advance)
@@ -2691,19 +3445,19 @@ if (condition) \
 
       io_constraint (dt->format_label == &format_asterisk,
                     "List directed format(*) is not allowed with a "
 
       io_constraint (dt->format_label == &format_asterisk,
                     "List directed format(*) is not allowed with a "
-                    "ADVANCE=specifier at %L.", &expr->where);
+                    "ADVANCE= specifier at %L.", &expr->where);
 
 
-      io_constraint (dt->format_expr == NULL
-                      && dt->format_label == NULL
-                      && dt->namelist == NULL,
-                    "the ADVANCE=specifier at %L must appear with an "
+      io_constraint (unformatted,
+                    "the ADVANCE= specifier at %L must appear with an "
                     "explicit format expression", &expr->where);
 
       if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
        {
                     "explicit format expression", &expr->where);
 
       if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
        {
-         const char * advance = expr->value.character.string;
-         not_no = strcasecmp (advance, "no") != 0;
-         not_yes = strcasecmp (advance, "yes") != 0;
+         const gfc_char_t *advance = expr->value.character.string;
+         not_no = gfc_wide_strlen (advance) != 2
+                  || gfc_wide_strncasecmp (advance, "no", 2) != 0;
+         not_yes = gfc_wide_strlen (advance) != 3
+                   || gfc_wide_strncasecmp (advance, "yes", 3) != 0;
        }
       else
        {
        }
       else
        {
@@ -2712,7 +3466,7 @@ if (condition) \
        }
 
       io_constraint (not_no && not_yes,
        }
 
       io_constraint (not_no && not_yes,
-                    "ADVANCE=specifier at %L must have value = "
+                    "ADVANCE= specifier at %L must have value = "
                     "YES or NO.", &expr->where);
 
       io_constraint (dt->size && not_no && k == M_READ,
                     "YES or NO.", &expr->where);
 
       io_constraint (dt->size && not_no && k == M_READ,
@@ -2725,13 +3479,15 @@ if (condition) \
     }
 
   expr = dt->format_expr;
     }
 
   expr = dt->format_expr;
-  if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
-    check_format_string (expr);
+  if (gfc_simplify_expr (expr, 0) == FAILURE
+      || check_format_string (expr, k == M_READ) == FAILURE)
+    return MATCH_ERROR;
 
   return m;
 }
 #undef io_constraint
 
 
   return m;
 }
 #undef io_constraint
 
+
 /* Match a READ, WRITE or PRINT statement.  */
 
 static match
 /* Match a READ, WRITE or PRINT statement.  */
 
 static match
@@ -2740,7 +3496,7 @@ match_io (io_kind k)
   char name[GFC_MAX_SYMBOL_LEN + 1];
   gfc_code *io_code;
   gfc_symbol *sym;
   char name[GFC_MAX_SYMBOL_LEN + 1];
   gfc_code *io_code;
   gfc_symbol *sym;
-  int comma_flag, c;
+  int comma_flag;
   locus where;
   locus spec_end;
   gfc_dt *dt;
   locus where;
   locus spec_end;
   gfc_dt *dt;
@@ -2748,7 +3504,7 @@ match_io (io_kind k)
 
   where = gfc_current_locus;
   comma_flag = 0;
 
   where = gfc_current_locus;
   comma_flag = 0;
-  current_dt = dt = gfc_getmem (sizeof (gfc_dt));
+  current_dt = dt = XCNEW (gfc_dt);
   m = gfc_match_char ('(');
   if (m == MATCH_NO)
     {
   m = gfc_match_char ('(');
   if (m == MATCH_NO)
     {
@@ -2758,7 +3514,7 @@ match_io (io_kind k)
       else if (k == M_PRINT)
        {
          /* Treat the non-standard case of PRINT namelist.  */
       else if (k == M_PRINT)
        {
          /* Treat the non-standard case of PRINT namelist.  */
-         if ((gfc_current_form == FORM_FIXED || gfc_peek_char () == ' ')
+         if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ')
              && gfc_match_name (name) == MATCH_YES)
            {
              gfc_find_symbol (name, NULL, 1, &sym);
              && gfc_match_name (name) == MATCH_YES)
            {
              gfc_find_symbol (name, NULL, 1, &sym);
@@ -2782,7 +3538,7 @@ match_io (io_kind k)
 
       if (gfc_current_form == FORM_FREE)
        {
 
       if (gfc_current_form == FORM_FREE)
        {
-         c = gfc_peek_char();
+         char c = gfc_peek_ascii_char ();
          if (c != ' ' && c != '*' && c != '\'' && c != '"')
            {
              m = MATCH_NO;
          if (c != ' ' && c != '*' && c != '\'' && c != '"')
            {
              m = MATCH_NO;
@@ -2804,7 +3560,6 @@ match_io (io_kind k)
     {
       /* Before issuing an error for a malformed 'print (1,*)' type of
         error, check for a default-char-expr of the form ('(I0)').  */
     {
       /* Before issuing an error for a malformed 'print (1,*)' type of
         error, check for a default-char-expr of the form ('(I0)').  */
-
       if (k == M_PRINT && m == MATCH_YES)
        {
          /* Reset current locus to get the initial '(' in an expression.  */
       if (k == M_PRINT && m == MATCH_YES)
        {
          /* Reset current locus to get the initial '(' in an expression.  */
@@ -2894,13 +3649,14 @@ get_io_list:
   /* Used in check_io_constraints, where no locus is available.  */
   spec_end = gfc_current_locus;
 
   /* 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
-      && k == M_WRITE
-      && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before output "
-                        "item list at %C is an extension") == FAILURE)
-    return MATCH_ERROR;
+  /* Optional leading comma (non-standard).  We use a gfc_expr structure here
+     to save the locus.  This is used later when resolving transfer statements
+     that might have a format expression without unit number.  */
+  if (!comma_flag && gfc_match_char (',') == MATCH_YES)
+    {
+      /* Save the iokind and locus for later use in resolution.  */
+      dt->extra_comma = gfc_get_iokind_expr (&gfc_current_locus, k);
+    }
 
   io_code = NULL;
   if (gfc_match_eos () != MATCH_YES)
 
   io_code = NULL;
   if (gfc_match_eos () != MATCH_YES)
@@ -2952,12 +3708,14 @@ gfc_match_read (void)
   return match_io (M_READ);
 }
 
   return match_io (M_READ);
 }
 
+
 match
 gfc_match_write (void)
 {
   return match_io (M_WRITE);
 }
 
 match
 gfc_match_write (void)
 {
   return match_io (M_WRITE);
 }
 
+
 match
 gfc_match_print (void)
 {
 match
 gfc_match_print (void)
 {
@@ -2980,7 +3738,7 @@ gfc_match_print (void)
 /* Free a gfc_inquire structure.  */
 
 void
 /* Free a gfc_inquire structure.  */
 
 void
-gfc_free_inquire (gfc_inquire * inquire)
+gfc_free_inquire (gfc_inquire *inquire)
 {
 
   if (inquire == NULL)
 {
 
   if (inquire == NULL)
@@ -3010,11 +3768,18 @@ gfc_free_inquire (gfc_inquire * inquire)
   gfc_free_expr (inquire->write);
   gfc_free_expr (inquire->readwrite);
   gfc_free_expr (inquire->delim);
   gfc_free_expr (inquire->write);
   gfc_free_expr (inquire->readwrite);
   gfc_free_expr (inquire->delim);
+  gfc_free_expr (inquire->encoding);
   gfc_free_expr (inquire->pad);
   gfc_free_expr (inquire->iolength);
   gfc_free_expr (inquire->convert);
   gfc_free_expr (inquire->strm_pos);
   gfc_free_expr (inquire->pad);
   gfc_free_expr (inquire->iolength);
   gfc_free_expr (inquire->convert);
   gfc_free_expr (inquire->strm_pos);
-
+  gfc_free_expr (inquire->asynchronous);
+  gfc_free_expr (inquire->decimal);
+  gfc_free_expr (inquire->pending);
+  gfc_free_expr (inquire->id);
+  gfc_free_expr (inquire->sign);
+  gfc_free_expr (inquire->size);
+  gfc_free_expr (inquire->round);
   gfc_free (inquire);
 }
 
   gfc_free (inquire);
 }
 
@@ -3024,7 +3789,7 @@ gfc_free_inquire (gfc_inquire * inquire)
 #define RETM   if (m != MATCH_NO) return m;
 
 static match
 #define RETM   if (m != MATCH_NO) return m;
 
 static match
-match_inquire_element (gfc_inquire * inquire)
+match_inquire_element (gfc_inquire *inquire)
 {
   match m;
 
 {
   match m;
 
@@ -3052,11 +3817,19 @@ match_inquire_element (gfc_inquire * inquire)
   RETM m = match_vtag (&tag_read, &inquire->read);
   RETM m = match_vtag (&tag_write, &inquire->write);
   RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
   RETM m = match_vtag (&tag_read, &inquire->read);
   RETM m = match_vtag (&tag_write, &inquire->write);
   RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
+  RETM m = match_vtag (&tag_s_async, &inquire->asynchronous);
   RETM m = match_vtag (&tag_s_delim, &inquire->delim);
   RETM m = match_vtag (&tag_s_delim, &inquire->delim);
+  RETM m = match_vtag (&tag_s_decimal, &inquire->decimal);
+  RETM m = match_vtag (&tag_size, &inquire->size);
+  RETM m = match_vtag (&tag_s_encoding, &inquire->encoding);
+  RETM m = match_vtag (&tag_s_round, &inquire->round);
+  RETM m = match_vtag (&tag_s_sign, &inquire->sign);
   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 m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
   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 m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
+  RETM m = match_vtag (&tag_pending, &inquire->pending);
+  RETM m = match_vtag (&tag_id, &inquire->id);
   RETM return MATCH_NO;
 }
 
   RETM return MATCH_NO;
 }
 
@@ -3075,7 +3848,7 @@ gfc_match_inquire (void)
   if (m == MATCH_NO)
     return m;
 
   if (m == MATCH_NO)
     return m;
 
-  inquire = gfc_getmem (sizeof (gfc_inquire));
+  inquire = XCNEW (gfc_inquire);
 
   loc = gfc_current_locus;
 
 
   loc = gfc_current_locus;
 
@@ -3104,7 +3877,7 @@ gfc_match_inquire (void)
        goto syntax;
 
       new_st.op = EXEC_IOLENGTH;
        goto syntax;
 
       new_st.op = EXEC_IOLENGTH;
-      new_st.expr = inquire->iolength;
+      new_st.expr1 = inquire->iolength;
       new_st.ext.inquire = inquire;
 
       if (gfc_pure (NULL))
       new_st.ext.inquire = inquire;
 
       if (gfc_pure (NULL))
@@ -3147,15 +3920,15 @@ gfc_match_inquire (void)
 
   if (inquire->unit != NULL && inquire->file != NULL)
     {
 
   if (inquire->unit != NULL && inquire->file != NULL)
     {
-      gfc_error ("INQUIRE statement at %L cannot contain both FILE and"
-                " UNIT specifiers", &loc);
+      gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
+                "UNIT specifiers", &loc);
       goto cleanup;
     }
 
   if (inquire->unit == NULL && inquire->file == NULL)
     {
       goto cleanup;
     }
 
   if (inquire->unit == NULL && inquire->file == NULL)
     {
-      gfc_error ("INQUIRE statement at %L requires either FILE or"
-                    " UNIT specifier", &loc);
+      gfc_error ("INQUIRE statement at %L requires either FILE or "
+                "UNIT specifier", &loc);
       goto cleanup;
     }
 
       goto cleanup;
     }
 
@@ -3164,6 +3937,13 @@ gfc_match_inquire (void)
       gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
       goto cleanup;
     }
       gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
       goto cleanup;
     }
+  
+  if (inquire->id != NULL && inquire->pending == NULL)
+    {
+      gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
+                "the ID= specifier", &loc);
+      goto cleanup;
+    }
 
   new_st.op = EXEC_INQUIRE;
   new_st.ext.inquire = inquire;
 
   new_st.op = EXEC_INQUIRE;
   new_st.ext.inquire = inquire;
@@ -3180,10 +3960,9 @@ cleanup:
 
 /* Resolve everything in a gfc_inquire structure.  */
 
 
 /* Resolve everything in a gfc_inquire structure.  */
 
-try
-gfc_resolve_inquire (gfc_inquire * inquire)
+gfc_try
+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_unit, inquire->unit);
   RESOLVE_TAG (&tag_file, inquire->file);
   RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
@@ -3209,12 +3988,134 @@ gfc_resolve_inquire (gfc_inquire * inquire)
   RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
   RESOLVE_TAG (&tag_s_delim, inquire->delim);
   RESOLVE_TAG (&tag_s_pad, inquire->pad);
   RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
   RESOLVE_TAG (&tag_s_delim, inquire->delim);
   RESOLVE_TAG (&tag_s_pad, inquire->pad);
+  RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
+  RESOLVE_TAG (&tag_s_round, inquire->round);
   RESOLVE_TAG (&tag_iolength, inquire->iolength);
   RESOLVE_TAG (&tag_convert, inquire->convert);
   RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
   RESOLVE_TAG (&tag_iolength, inquire->iolength);
   RESOLVE_TAG (&tag_convert, inquire->convert);
   RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
+  RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
+  RESOLVE_TAG (&tag_s_sign, inquire->sign);
+  RESOLVE_TAG (&tag_s_round, inquire->round);
+  RESOLVE_TAG (&tag_pending, inquire->pending);
+  RESOLVE_TAG (&tag_size, inquire->size);
+  RESOLVE_TAG (&tag_id, inquire->id);
 
   if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
     return FAILURE;
 
   return SUCCESS;
 }
 
   if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
     return FAILURE;
 
   return SUCCESS;
 }
+
+
+void
+gfc_free_wait (gfc_wait *wait)
+{
+  if (wait == NULL)
+    return;
+
+  gfc_free_expr (wait->unit);
+  gfc_free_expr (wait->iostat);
+  gfc_free_expr (wait->iomsg);
+  gfc_free_expr (wait->id);
+}
+
+
+gfc_try
+gfc_resolve_wait (gfc_wait *wait)
+{
+  RESOLVE_TAG (&tag_unit, wait->unit);
+  RESOLVE_TAG (&tag_iomsg, wait->iomsg);
+  RESOLVE_TAG (&tag_iostat, wait->iostat);
+  RESOLVE_TAG (&tag_id, wait->id);
+
+  if (gfc_reference_st_label (wait->err, ST_LABEL_TARGET) == FAILURE)
+    return FAILURE;
+  
+  if (gfc_reference_st_label (wait->end, ST_LABEL_TARGET) == FAILURE)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
+/* Match an element of a WAIT statement.  */
+
+#define RETM   if (m != MATCH_NO) return m;
+
+static match
+match_wait_element (gfc_wait *wait)
+{
+  match m;
+
+  m = match_etag (&tag_unit, &wait->unit);
+  RETM m = match_ltag (&tag_err, &wait->err);
+  RETM m = match_ltag (&tag_end, &wait->eor);
+  RETM m = match_ltag (&tag_eor, &wait->end);
+  RETM m = match_out_tag (&tag_iomsg, &wait->iomsg);
+  RETM m = match_out_tag (&tag_iostat, &wait->iostat);
+  RETM m = match_etag (&tag_id, &wait->id);
+  RETM return MATCH_NO;
+}
+
+#undef RETM
+
+
+match
+gfc_match_wait (void)
+{
+  gfc_wait *wait;
+  match m;
+
+  m = gfc_match_char ('(');
+  if (m == MATCH_NO)
+    return m;
+
+  wait = XCNEW (gfc_wait);
+
+  m = match_wait_element (wait);
+  if (m == MATCH_ERROR)
+    goto cleanup;
+  if (m == MATCH_NO)
+    {
+      m = gfc_match_expr (&wait->unit);
+      if (m == MATCH_ERROR)
+       goto cleanup;
+      if (m == MATCH_NO)
+       goto syntax;
+    }
+
+  for (;;)
+    {
+      if (gfc_match_char (')') == MATCH_YES)
+       break;
+      if (gfc_match_char (',') != MATCH_YES)
+       goto syntax;
+
+      m = match_wait_element (wait);
+      if (m == MATCH_ERROR)
+       goto cleanup;
+      if (m == MATCH_NO)
+       goto syntax;
+    }
+
+  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: WAIT at %C "
+         "not allowed in Fortran 95") == FAILURE)
+    goto cleanup;
+
+  if (gfc_pure (NULL))
+    {
+      gfc_error ("WAIT statement not allowed in PURE procedure at %C");
+      goto cleanup;
+    }
+
+  new_st.op = EXEC_WAIT;
+  new_st.ext.wait = wait;
+
+  return MATCH_YES;
+
+syntax:
+  gfc_syntax_error (ST_WAIT);
+
+cleanup:
+  gfc_free_wait (wait);
+  return MATCH_ERROR;
+}
About OSDN
Find Software
Develop Software
Help