PR fortran/87923 -- fix ICE when resolving I/O tags and simplify io.c

2020-04-06  Fritz Reese  <foreese@gcc.gnu.org>

This patch reorganizes I/O checking code. Checks which were done in the
matching phase which do not affect the match result are moved to the
resolution phase. Checks which were duplicated in both the matching phase
and resolution phase have been reduced to one check in the resolution phase.

Another section of code which used a global async_io_dt flag to check for
and assign the asynchronous attribute to variables used in asynchronous I/O
has been simplified.

Furthermore, this patch improves error reporting and expands test coverage
of I/O tags:

 - "TAG must be an initialization expression" reported by io.c
   (check_io_constraints) is replaced with an error from expr.c
   (gfc_reduce_init_expr) indicating _why_ the expression is not a valid
   initialization expression.

 - Several distinct error messages regarding the check for scalar
   + character + default kind have been unified to one message reported by
   resolve_tag or check_*_constraints.

gcc/fortran/ChangeLog:

2020-04-09  Fritz Reese  <foreese@gcc.gnu.org>

	PR fortran/87923
	* gfortran.h (gfc_resolve_open, gfc_resolve_close): Add
	locus parameter.
	(gfc_resolve_dt): Add code parameter.
	* io.c (async_io_dt, check_char_variable, is_char_type): Removed.
	(resolve_tag_format): Add locus to error message regarding
	zero-sized array in FORMAT tag.
	(check_open_constraints, check_close_constraints): New functions
	called at resolution time.
	(gfc_match_open, gfc_match_close, match_io): Move checks which don't
	affect the match result to new functions check_open_constraints,
	check_close_constraints, check_io_constraints.
	(gfc_resolve_open, gfc_resolve_close): Call new functions
	check_open_constraints, check_close_constraints after all tags have
	been independently resolved.  Remove duplicate constraints which are
	already verified by resolve_tag. Explicitly pass locus to all error
	reports.
	(compare_to_allowed_values): Add locus parameter and provide
	explicit locus all error reports.
	(match_open_element, match_close_element, match_file_element,
	match_dt_element, match_inquire_element): Remove redundant special
	cases for ASYNCHRONOUS and IOMSG tags.
	(gfc_resolve_dt): Remove redundant special case for format
	expression.  Call check_io_constraints, forwarding an I/O list as
	the io_code parameter if present.
	(check_io_constraints): Change return type to bool. Pass explicit
	locus to error reports. Move generic checks after tag-specific
	checks, since errors are no longer buffered.  Move simplification of
	format string to match_io.  Remove redundant checks which are
	verified by resolve_tag.  Remove usage of async_io_dt flag and
	explicitly mark symbols used in asynchronous I/O with the
	asynchronous attribute.
	* resolve.c (resolve_transfer, resolve_fl_namelist): Remove checks
	for async_io_dt flag. This is now done in io.c
	(check_io_constraints).
	(gfc_resolve_code): Pass code locus to gfc_resolve_open,
	gfc_resolve_close, gfc_resolve_dt.

gcc/testsuite/ChangeLog:

2020-04-09  Fritz Reese  <foreese@gcc.gnu.org>

	PR fortran/87923
	* gfortran.dg/f2003_io_8.f03: Fix expected error messages.
	* gfortran.dg/io_constraints_8.f90: Likewise.
	* gfortran.dg/iomsg_2.f90: Likewise.
	* gfortran.dg/pr66725.f90: Likewise.
	* gfortran.dg/pr88205.f90: Likewise.
	* gfortran.dg/write_check4.f90: Likewise.
	* gfortran.dg/asynchronous_5.f03: New test.
	* gfortran.dg/io_constraints_15.f90: Likewise.
	* gfortran.dg/io_constraints_16.f90: Likewise.
	* gfortran.dg/io_constraints_17.f90: Likewise.
	* gfortran.dg/io_constraints_18.f90: Likewise.
	* gfortran.dg/io_tags_1.f90: Likewise.
	* gfortran.dg/io_tags_10.f90: Likewise.
	* gfortran.dg/io_tags_2.f90: Likewise.
	* gfortran.dg/io_tags_3.f90: Likewise.
	* gfortran.dg/io_tags_4.f90: Likewise.
	* gfortran.dg/io_tags_5.f90: Likewise.
	* gfortran.dg/io_tags_6.f90: Likewise.
	* gfortran.dg/io_tags_7.f90: Likewise.
	* gfortran.dg/io_tags_8.f90: Likewise.
	* gfortran.dg/io_tags_9.f90: Likewise.
	* gfortran.dg/write_check5.f90: Likewise.

4 files changed, 426 insertions, 493 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index fdbb8da..e2ebb96 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,43 @@
+2020-04-09  Fritz Reese  <foreese@gcc.gnu.org>
+
+	PR fortran/87923
+	* gfortran.h (gfc_resolve_open, gfc_resolve_close): Add
+	locus parameter.
+	(gfc_resolve_dt): Add code parameter.
+	* io.c (async_io_dt, check_char_variable, is_char_type): Removed.
+	(resolve_tag_format): Add locus to error message regarding
+	zero-sized array in FORMAT tag.
+	(check_open_constraints, check_close_constraints): New functions
+	called at resolution time.
+	(gfc_match_open, gfc_match_close, match_io): Move checks which don't
+	affect the match result to new functions check_open_constraints,
+	check_close_constraints, check_io_constraints.
+	(gfc_resolve_open, gfc_resolve_close): Call new functions
+	check_open_constraints, check_close_constraints after all tags have
+	been independently resolved.  Remove duplicate constraints which are
+	already verified by resolve_tag.  Explicitly pass locus to all error
+	reports.
+	(compare_to_allowed_values): Add locus parameter and provide
+	explicit locus all error reports.
+	(match_open_element, match_close_element, match_file_element,
+	match_dt_element, match_inquire_element): Remove redundant special
+	cases for ASYNCHRONOUS and IOMSG tags.
+	(gfc_resolve_dt): Remove redundant special case for format
+	expression.  Call check_io_constraints, forwarding an I/O list as
+	the io_code parameter if present.
+	(check_io_constraints): Change return type to bool.  Pass explicit
+	locus to error reports.  Move generic checks after tag-specific
+	checks, since errors are no longer buffered.  Move simplification of
+	format string to match_io.  Remove redundant checks which are
+	verified by resolve_tag.  Remove usage of async_io_dt flag and
+	explicitly mark symbols used in asynchronous I/O with the
+	asynchronous attribute.
+	* resolve.c (resolve_transfer, resolve_fl_namelist): Remove checks
+	for async_io_dt flag.  This is now done in io.c.
+	(check_io_constraints).
+	(gfc_resolve_code): Pass code locus to gfc_resolve_open,
+	gfc_resolve_close, gfc_resolve_dt.
+
 2020-04-07  Fritz Reese  <foreese@gcc.gnu.org>
 	    Steven G. Kargl  <kargl@gcc.gnu.org>
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 70a6405..0d77386 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3476,18 +3476,17 @@ bool gfc_compare_actual_formal (gfc_actual_arglist **, gfc_formal_arglist *,
 extern gfc_st_label format_asterisk;
 
 void gfc_free_open (gfc_open *);
-bool gfc_resolve_open (gfc_open *);
+bool gfc_resolve_open (gfc_open *, locus *);
 void gfc_free_close (gfc_close *);
-bool gfc_resolve_close (gfc_close *);
+bool gfc_resolve_close (gfc_close *, locus *);
 void gfc_free_filepos (gfc_filepos *);
 bool gfc_resolve_filepos (gfc_filepos *, locus *);
 void gfc_free_inquire (gfc_inquire *);
 bool gfc_resolve_inquire (gfc_inquire *);
 void gfc_free_dt (gfc_dt *);
-bool gfc_resolve_dt (gfc_dt *, locus *);
+bool gfc_resolve_dt (gfc_code *, gfc_dt *, locus *);
 void gfc_free_wait (gfc_wait *);
 bool gfc_resolve_wait (gfc_wait *);
-extern bool async_io_dt;
 
 /* module.c */
 void gfc_module_init_2 (void);
diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index 59cd9ce..e066666 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -112,10 +112,6 @@ static gfc_dt *current_dt;
 
 #define RESOLVE_TAG(x, y) if (!resolve_tag (x, y)) return false;
 
-/* Are we currently processing an asynchronous I/O statement? */
-
-bool async_io_dt;
-
 /**************** Fortran 95 FORMAT parser  *****************/
 
 /* FORMAT tokens returned by format_lex().  */
@@ -1427,36 +1423,6 @@ gfc_match_format (void)
 }
 
 
-/* Check for a CHARACTER variable.  The check for scalar is done in
-   resolve_tag.  */
-
-static bool
-check_char_variable (gfc_expr *e)
-{
-  if (e->expr_type != EXPR_VARIABLE || e->ts.type != BT_CHARACTER)
-    {
-      gfc_error("IOMSG must be a scalar-default-char-variable at %L", &e->where);
-      return false;
-    }
-  return true;
-}
-
-
-static bool
-is_char_type (const char *name, gfc_expr *e)
-{
-  gfc_resolve_expr (e);
-
-  if (e->ts.type != BT_CHARACTER)
-    {
-      gfc_error ("%s requires a scalar-default-char-expr at %L",
-		   name, &e->where);
-      return false;
-    }
-  return true;
-}
-
-
 /* Match an expression I/O tag of some sort.  */
 
 static match
@@ -1725,7 +1691,8 @@ resolve_tag_format (gfc_expr *e)
 
 	  if (e->value.constructor == NULL)
 	   {
-	     gfc_error ("FORMAT tag at %C cannot be a zero-sized array");
+	     gfc_error ("FORMAT tag at %L cannot be a zero-sized array",
+			&e->where);
 	     return false;
 	   }
 
@@ -1919,16 +1886,12 @@ match_open_element (gfc_open *open)
   match m;
 
   m = match_etag (&tag_e_async, &open->asynchronous);
-  if (m == MATCH_YES && !is_char_type ("ASYNCHRONOUS", open->asynchronous))
-    return MATCH_ERROR;
   if (m != MATCH_NO)
     return m;
   m = match_etag (&tag_unit, &open->unit);
   if (m != MATCH_NO)
     return m;
   m = match_etag (&tag_iomsg, &open->iomsg);
-  if (m == MATCH_YES && !check_char_variable (open->iomsg))
-    return MATCH_ERROR;
   if (m != MATCH_NO)
     return m;
   m = match_out_tag (&tag_iostat, &open->iostat);
@@ -2041,12 +2004,22 @@ gfc_free_open (gfc_open *open)
 }
 
 
+static int
+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, locus *where,
+			   int *num = NULL);
+
+
+static bool
+check_open_constraints (gfc_open *open, locus *where);
+
 /* Resolve everything in a gfc_open structure.  */
 
 bool
-gfc_resolve_open (gfc_open *open)
+gfc_resolve_open (gfc_open *open, locus *where)
 {
-
   RESOLVE_TAG (&tag_unit, open->unit);
   RESOLVE_TAG (&tag_iomsg, open->iomsg);
   RESOLVE_TAG (&tag_iostat, open->iostat);
@@ -2073,7 +2046,7 @@ gfc_resolve_open (gfc_open *open)
   if (!gfc_reference_st_label (open->err, ST_LABEL_TARGET))
     return false;
 
-  return true;
+  return check_open_constraints (open, where);
 }
 
 
@@ -2081,19 +2054,13 @@ gfc_resolve_open (gfc_open *open)
    allowed in F95 or F2003, issuing an error message and returning a zero
    value if it is not allowed.  */
 
-static int
-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 *num = NULL);
-
 
 static int
 compare_to_allowed_values (const char *specifier, const char *allowed[],
-			   const char *allowed_f2003[], 
+			   const char *allowed_f2003[],
 			   const char *allowed_gnu[], gfc_char_t *value,
-			   const char *statement, bool warn, int *num)
+			   const char *statement, bool warn, locus *where,
+			   int *num)
 {
   int i;
   unsigned int len;
@@ -2116,6 +2083,9 @@ compare_to_allowed_values (const char *specifier, const char *allowed[],
       return 1;
       }
 
+  if (!where)
+    where = &gfc_current_locus;
+
   for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
     if (len == strlen (allowed_f2003[i])
 	&& gfc_wide_strncasecmp (value, allowed_f2003[i],
@@ -2125,8 +2095,8 @@ compare_to_allowed_values (const char *specifier, const char *allowed[],
 
 	if (n == WARNING || (warn && n == ERROR))
 	  {
-	    gfc_warning (0, "Fortran 2003: %s specifier in %s statement at %C "
-			 "has value %qs", specifier, statement,
+	    gfc_warning (0, "Fortran 2003: %s specifier in %s statement at %L "
+			 "has value %qs", specifier, statement, where,
 			 allowed_f2003[i]);
 	    return 1;
 	  }
@@ -2134,8 +2104,8 @@ compare_to_allowed_values (const char *specifier, const char *allowed[],
 	  if (n == ERROR)
 	    {
 	      gfc_notify_std (GFC_STD_F2003, "%s specifier in "
-			      "%s statement at %C has value %qs", specifier,
-			      statement, allowed_f2003[i]);
+			      "%s statement at %L has value %qs", specifier,
+			      statement, where, allowed_f2003[i]);
 	      return 0;
 	    }
 
@@ -2152,8 +2122,8 @@ compare_to_allowed_values (const char *specifier, const char *allowed[],
 
 	if (n == WARNING || (warn && n == ERROR))
 	  {
-	    gfc_warning (0, "Extension: %s specifier in %s statement at %C "
-			 "has value %qs", specifier, statement,
+	    gfc_warning (0, "Extension: %s specifier in %s statement at %L "
+			 "has value %qs", specifier, statement, where,
 			 allowed_gnu[i]);
 	    return 1;
 	  }
@@ -2161,8 +2131,8 @@ compare_to_allowed_values (const char *specifier, const char *allowed[],
 	  if (n == ERROR)
 	    {
 	      gfc_notify_std (GFC_STD_GNU, "%s specifier in "
-			      "%s statement at %C has value %qs", specifier,
-			      statement, allowed_gnu[i]);
+			      "%s statement at %L has value %qs", specifier,
+			      statement, where, allowed_gnu[i]);
 	      return 0;
 	    }
 
@@ -2174,74 +2144,42 @@ compare_to_allowed_values (const char *specifier, const char *allowed[],
     {
       char *s = gfc_widechar_to_char (value, -1);
       gfc_warning (0,
-		   "%s specifier in %s statement at %C has invalid value %qs",
-		   specifier, statement, s);
+		   "%s specifier in %s statement at %L has invalid value %qs",
+		   specifier, statement, where, s);
       free (s);
       return 1;
     }
   else
     {
       char *s = gfc_widechar_to_char (value, -1);
-      gfc_error ("%s specifier in %s statement at %C has invalid value %qs",
-		 specifier, statement, s);
+      gfc_error ("%s specifier in %s statement at %L has invalid value %qs",
+		 specifier, statement, where, s);
       free (s);
       return 0;
     }
 }
 
 
-/* Match an OPEN statement.  */
+/* Check constraints on the OPEN statement.
+   Similar to check_io_constraints for data transfer statements.
+   At this point all tags have already been resolved via resolve_tag, which,
+   among other things, verifies that BT_CHARACTER tags are of default kind.  */
 
-match
-gfc_match_open (void)
+static bool
+check_open_constraints (gfc_open *open, locus *where)
 {
-  gfc_open *open;
-  match m;
-  bool warn;
-
-  m = gfc_match_char ('(');
-  if (m == MATCH_NO)
-    return m;
-
-  open = XCNEW (gfc_open);
-
-  m = match_open_element (open);
-
-  if (m == MATCH_ERROR)
-    goto cleanup;
-  if (m == MATCH_NO)
-    {
-      m = gfc_match_expr (&open->unit);
-      if (m == MATCH_ERROR)
-	goto cleanup;
-    }
-
-  for (;;)
-    {
-      if (gfc_match_char (')') == MATCH_YES)
-	break;
-      if (gfc_match_char (',') != MATCH_YES)
-	goto syntax;
-
-      m = match_open_element (open);
-      if (m == MATCH_ERROR)
-	goto cleanup;
-      if (m == MATCH_NO)
-	goto syntax;
-    }
-
-  if (gfc_match_eos () == MATCH_NO)
-    goto syntax;
-
-  if (gfc_pure (NULL))
-    {
-      gfc_error ("OPEN statement not allowed in PURE procedure at %C");
-      goto cleanup;
-    }
-
-  gfc_unset_implicit_pure (NULL);
+#define warn_or_error(...) \
+{ \
+  if (warn) \
+    gfc_warning (0, __VA_ARGS__); \
+  else \
+    { \
+      gfc_error (__VA_ARGS__); \
+      return false; \
+    } \
+}
 
-  warn = (open->err || open->iostat) ? true : false;
+  bool warn = (open->err || open->iostat) ? true : false;
 
   /* Checks on the ACCESS specifier.  */
   if (open->access && open->access->expr_type == EXPR_CONSTANT)
@@ -2250,14 +2188,11 @@ gfc_match_open (void)
       static const char *access_f2003[] = { "STREAM", NULL };
       static const char *access_gnu[] = { "APPEND", NULL };
 
-      if (!is_char_type ("ACCESS", open->access))
-	goto cleanup;
-
       if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003,
 				      access_gnu,
 				      open->access->value.character.string,
-				      "OPEN", warn))
-	goto cleanup;
+				      "OPEN", warn, &open->access->where))
+	return false;
     }
 
   /* Checks on the ACTION specifier.  */
@@ -2266,21 +2201,20 @@ gfc_match_open (void)
       gfc_char_t *str = open->action->value.character.string;
       static const char *action[] = { "READ", "WRITE", "READWRITE", NULL };
 
-      if (!is_char_type ("ACTION", open->action))
-	goto cleanup;
-
       if (!compare_to_allowed_values ("ACTION", action, NULL, NULL,
-				      str, "OPEN", warn))
-	goto cleanup;
+				      str, "OPEN", warn, &open->action->where))
+	return false;
 
       /* With READONLY, only allow ACTION='READ'.  */
       if (open->readonly && (gfc_wide_strlen (str) != 4
 			     || gfc_wide_strncasecmp (str, "READ", 4) != 0))
 	{
-	  gfc_error ("ACTION type conflicts with READONLY specifier at %C");
-	  goto cleanup;
+	  gfc_error ("ACTION type conflicts with READONLY specifier at %L",
+		     &open->action->where);
+	  return false;
 	}
     }
+
   /* If we see READONLY and no ACTION, set ACTION='READ'.  */
   else if (open->readonly && open->action == NULL)
     {
@@ -2291,27 +2225,10 @@ gfc_match_open (void)
   /* Checks on the ASYNCHRONOUS specifier.  */
   if (open->asynchronous)
     {
-      if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS= at %C "
-			   "not allowed in Fortran 95"))
-	goto cleanup;
-
-      if (!is_char_type ("ASYNCHRONOUS", open->asynchronous))
-	goto cleanup;
-
-      if (open->asynchronous->ts.kind != 1)
-	{
-	  gfc_error ("ASYNCHRONOUS= specifier at %L must be of default "
-		     "CHARACTER kind", &open->asynchronous->where);
-	  return MATCH_ERROR;
-	}
-
-      if (open->asynchronous->expr_type == EXPR_ARRAY
-	  || open->asynchronous->expr_type == EXPR_STRUCTURE)
-	{
-	  gfc_error ("ASYNCHRONOUS= specifier at %L must be scalar",
-		     &open->asynchronous->where);
-	  return MATCH_ERROR;
-	}
+      if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS= at %L "
+			   "not allowed in Fortran 95",
+			   &open->asynchronous->where))
+	return false;
 
       if (open->asynchronous->expr_type == EXPR_CONSTANT)
 	{
@@ -2319,20 +2236,17 @@ gfc_match_open (void)
 
 	  if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous,
 			NULL, NULL, open->asynchronous->value.character.string,
-			"OPEN", warn))
-	    goto cleanup;
+			"OPEN", warn, &open->asynchronous->where))
+	    return false;
 	}
     }
 
   /* Checks on the BLANK specifier.  */
   if (open->blank)
     {
-      if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %C "
-			   "not allowed in Fortran 95"))
-	goto cleanup;
-
-      if (!is_char_type ("BLANK", open->blank))
-	goto cleanup;
+      if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %L "
+			   "not allowed in Fortran 95", &open->blank->where))
+	return false;
 
       if (open->blank->expr_type == EXPR_CONSTANT)
 	{
@@ -2340,36 +2254,27 @@ gfc_match_open (void)
 
 	  if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
 					  open->blank->value.character.string,
-					  "OPEN", warn))
-	    goto cleanup;
+					  "OPEN", warn, &open->blank->where))
+	    return false;
 	}
     }
 
   /* Checks on the CARRIAGECONTROL specifier.  */
-  if (open->cc)
+  if (open->cc && open->cc->expr_type == EXPR_CONSTANT)
     {
-      if (!is_char_type ("CARRIAGECONTROL", open->cc))
-	goto cleanup;
-
-      if (open->cc->expr_type == EXPR_CONSTANT)
-	{
-	  static const char *cc[] = { "LIST", "FORTRAN", "NONE", NULL };
-	  if (!compare_to_allowed_values ("CARRIAGECONTROL", cc, NULL, NULL,
-					  open->cc->value.character.string,
-					  "OPEN", warn))
-	    goto cleanup;
-	}
+      static const char *cc[] = { "LIST", "FORTRAN", "NONE", NULL };
+      if (!compare_to_allowed_values ("CARRIAGECONTROL", cc, NULL, NULL,
+				      open->cc->value.character.string,
+				      "OPEN", warn, &open->cc->where))
+	return false;
     }
 
   /* Checks on the DECIMAL specifier.  */
   if (open->decimal)
     {
-      if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C "
-			   "not allowed in Fortran 95"))
-	goto cleanup;
-
-      if (!is_char_type ("DECIMAL", open->decimal))
-	goto cleanup;
+      if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %L "
+			   "not allowed in Fortran 95", &open->decimal->where))
+	return false;
 
       if (open->decimal->expr_type == EXPR_CONSTANT)
 	{
@@ -2377,8 +2282,8 @@ gfc_match_open (void)
 
 	  if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
 					  open->decimal->value.character.string,
-					  "OPEN", warn))
-	    goto cleanup;
+					  "OPEN", warn, &open->decimal->where))
+	    return false;
 	}
     }
 
@@ -2389,25 +2294,19 @@ gfc_match_open (void)
 	{
 	  static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
 
-	  if (!is_char_type ("DELIM", open->delim))
-	    goto cleanup;
-
 	  if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
 					  open->delim->value.character.string,
-					  "OPEN", warn))
-	  goto cleanup;
+					  "OPEN", warn, &open->delim->where))
+	    return false;
 	}
     }
 
   /* Checks on the ENCODING specifier.  */
   if (open->encoding)
     {
-      if (!gfc_notify_std (GFC_STD_F2003, "ENCODING= at %C "
-			   "not allowed in Fortran 95"))
-	goto cleanup;
-
-      if (!is_char_type ("ENCODING", open->encoding))
-	goto cleanup;
+      if (!gfc_notify_std (GFC_STD_F2003, "ENCODING= at %L "
+			   "not allowed in Fortran 95", &open->encoding->where))
+	return false;
 
       if (open->encoding->expr_type == EXPR_CONSTANT)
 	{
@@ -2415,8 +2314,8 @@ gfc_match_open (void)
 
 	  if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
 					  open->encoding->value.character.string,
-					  "OPEN", warn))
-	  goto cleanup;
+					  "OPEN", warn, &open->encoding->where))
+	    return false;
 	}
     }
 
@@ -2425,13 +2324,10 @@ gfc_match_open (void)
     {
       static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL };
 
-      if (!is_char_type ("FORM", open->form))
-	goto cleanup;
-
       if (!compare_to_allowed_values ("FORM", form, NULL, NULL,
 				      open->form->value.character.string,
-				      "OPEN", warn))
-	goto cleanup;
+				      "OPEN", warn, &open->form->where))
+	return false;
     }
 
   /* Checks on the PAD specifier.  */
@@ -2439,13 +2335,10 @@ gfc_match_open (void)
     {
       static const char *pad[] = { "YES", "NO", NULL };
 
-      if (!is_char_type ("PAD", open->pad))
-	goto cleanup;
-
       if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
 				      open->pad->value.character.string,
-				      "OPEN", warn))
-	goto cleanup;
+				      "OPEN", warn, &open->pad->where))
+	return false;
     }
 
   /* Checks on the POSITION specifier.  */
@@ -2453,24 +2346,18 @@ gfc_match_open (void)
     {
       static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL };
 
-      if (!is_char_type ("POSITION", open->position))
-	goto cleanup;
-
       if (!compare_to_allowed_values ("POSITION", position, NULL, NULL,
 				      open->position->value.character.string,
-				      "OPEN", warn))
-	goto cleanup;
+				      "OPEN", warn, &open->position->where))
+	return false;
     }
 
   /* Checks on the ROUND specifier.  */
   if (open->round)
     {
-      if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %C "
-			   "not allowed in Fortran 95"))
-      goto cleanup;
-
-      if (!is_char_type ("ROUND", open->round))
-	goto cleanup;
+      if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %L "
+			   "not allowed in Fortran 95", &open->round->where))
+	return false;
 
       if (open->round->expr_type == EXPR_CONSTANT)
 	{
@@ -2480,36 +2367,27 @@ gfc_match_open (void)
 
 	  if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
 					  open->round->value.character.string,
-					  "OPEN", warn))
-	  goto cleanup;
+					  "OPEN", warn, &open->round->where))
+	    return false;
 	}
     }
 
   /* Checks on the SHARE specifier.  */
-  if (open->share)
+  if (open->share && open->share->expr_type == EXPR_CONSTANT)
     {
-      if (!is_char_type ("SHARE", open->share))
-	goto cleanup;
-
-      if (open->share->expr_type == EXPR_CONSTANT)
-	{
-	  static const char *share[] = { "DENYNONE", "DENYRW", NULL };
-	  if (!compare_to_allowed_values ("SHARE", share, NULL, NULL,
-					  open->share->value.character.string,
-					  "OPEN", warn))
-	    goto cleanup;
-	}
+      static const char *share[] = { "DENYNONE", "DENYRW", NULL };
+      if (!compare_to_allowed_values ("SHARE", share, NULL, NULL,
+				      open->share->value.character.string,
+				      "OPEN", warn, &open->share->where))
+	return false;
     }
 
   /* Checks on the SIGN specifier.  */
-  if (open->sign) 
+  if (open->sign)
     {
-      if (!gfc_notify_std (GFC_STD_F2003, "SIGN= at %C "
-			   "not allowed in Fortran 95"))
-	goto cleanup;
-
-      if (!is_char_type ("SIGN", open->sign))
-	goto cleanup;
+      if (!gfc_notify_std (GFC_STD_F2003, "SIGN= at %L "
+			   "not allowed in Fortran 95", &open->sign->where))
+	return false;
 
       if (open->sign->expr_type == EXPR_CONSTANT)
 	{
@@ -2518,28 +2396,18 @@ gfc_match_open (void)
 
 	  if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
 					  open->sign->value.character.string,
-					  "OPEN", warn))
-	  goto cleanup;
+					  "OPEN", warn, &open->sign->where))
+	    return false;
 	}
     }
 
-#define warn_or_error(...) \
-{ \
-  if (warn) \
-    gfc_warning (0, __VA_ARGS__); \
-  else \
-    { \
-      gfc_error (__VA_ARGS__); \
-      goto cleanup; \
-    } \
-}
-
   /* Checks on the RECL specifier.  */
   if (open->recl && open->recl->expr_type == EXPR_CONSTANT
       && open->recl->ts.type == BT_INTEGER
       && mpz_sgn (open->recl->value.integer) != 1)
     {
-      warn_or_error ("RECL in OPEN statement at %C must be positive");
+      warn_or_error ("RECL in OPEN statement at %L must be positive",
+		     &open->recl->where);
     }
 
   /* Checks on the STATUS specifier.  */
@@ -2548,13 +2416,10 @@ gfc_match_open (void)
       static const char *status[] = { "OLD", "NEW", "SCRATCH",
 	"REPLACE", "UNKNOWN", NULL };
 
-      if (!is_char_type ("STATUS", open->status))
-	goto cleanup;
-
       if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
 				      open->status->value.character.string,
-				      "OPEN", warn))
-	goto cleanup;
+				      "OPEN", warn, &open->status->where))
+	return false;
 
       /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
 	 the FILE= specifier shall appear.  */
@@ -2566,8 +2431,9 @@ gfc_match_open (void)
 	{
 	  char *s = gfc_widechar_to_char (open->status->value.character.string,
 					  -1);
-	  warn_or_error ("The STATUS specified in OPEN statement at %C is "
-			 "%qs and no FILE specifier is present", s);
+	  warn_or_error ("The STATUS specified in OPEN statement at %L is "
+			 "%qs and no FILE specifier is present",
+			 &open->status->where, s);
 	  free (s);
 	}
 
@@ -2576,9 +2442,9 @@ gfc_match_open (void)
       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 "
+	  warn_or_error ("The STATUS specified in OPEN statement at %L "
 			 "cannot have the value SCRATCH if a FILE specifier "
-			 "is present");
+			 "is present", &open->status->where);
 	}
     }
 
@@ -2587,8 +2453,9 @@ gfc_match_open (void)
     {
       if (open->unit)
 	{
-	  gfc_error ("UNIT specifier not allowed with NEWUNIT at %C");
-	  goto cleanup;
+	  gfc_error ("UNIT specifier not allowed with NEWUNIT at %L",
+		     &open->newunit->where);
+	  return false;
 	}
 
       if (!open->file &&
@@ -2598,14 +2465,15 @@ gfc_match_open (void)
 				      "scratch", 7) != 0)))
 	{
 	     gfc_error ("NEWUNIT specifier must have FILE= "
-			"or STATUS='scratch' at %C");
-	     goto cleanup;
+			"or STATUS='scratch' at %L", &open->newunit->where);
+	     return false;
 	}
     }
   else if (!open->unit)
     {
-      gfc_error ("OPEN statement at %C must have UNIT or NEWUNIT specified");
-      goto cleanup;
+      gfc_error ("OPEN statement at %L must have UNIT or NEWUNIT specified",
+		 where);
+      return false;
     }
 
   /* Things that are not allowed for unformatted I/O.  */
@@ -2615,20 +2483,39 @@ gfc_match_open (void)
       && gfc_wide_strncasecmp (open->form->value.character.string,
 			       "unformatted", 11) == 0)
     {
-      const char *spec = (open->delim ? "DELIM "
-				      : (open->pad ? "PAD " : open->blank
-							    ? "BLANK " : ""));
+      locus *loc;
+      const char *spec;
+      if (open->delim)
+	{
+	  loc = &open->delim->where;
+	  spec = "DELIM ";
+	}
+      else if (open->pad)
+	{
+	  loc = &open->pad->where;
+	  spec = "PAD ";
+	}
+      else if (open->blank)
+	{
+	  loc = &open->blank->where;
+	  spec = "BLANK ";
+	}
+      else
+	{
+	  loc = where;
+	  spec = "";
+	}
 
-      warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
-		     "unformatted I/O", spec);
+      warn_or_error ("%s specifier at %L not allowed in OPEN statement for "
+		     "unformatted I/O", spec, loc);
     }
 
   if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT
       && 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 %L for "
+		     "stream I/O", &open->recl->where);
     }
 
   if (open->position
@@ -2640,11 +2527,64 @@ gfc_match_open (void)
 	   || 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 %L only allowed "
+		     "for stream or sequential ACCESS", &open->position->where);
     }
 
+  return true;
 #undef warn_or_error
+}
+
+
+/* Match an OPEN statement.  */
+
+match
+gfc_match_open (void)
+{
+  gfc_open *open;
+  match m;
+
+  m = gfc_match_char ('(');
+  if (m == MATCH_NO)
+    return m;
+
+  open = XCNEW (gfc_open);
+
+  m = match_open_element (open);
+
+  if (m == MATCH_ERROR)
+    goto cleanup;
+  if (m == MATCH_NO)
+    {
+      m = gfc_match_expr (&open->unit);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+    }
+
+  for (;;)
+    {
+      if (gfc_match_char (')') == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+
+      m = match_open_element (open);
+      if (m == MATCH_ERROR)
+	goto cleanup;
+      if (m == MATCH_NO)
+	goto syntax;
+    }
+
+  if (gfc_match_eos () == MATCH_NO)
+    goto syntax;
+
+  if (gfc_pure (NULL))
+    {
+      gfc_error ("OPEN statement not allowed in PURE procedure at %C");
+      goto cleanup;
+    }
+
+  gfc_unset_implicit_pure (NULL);
 
   new_st.op = EXEC_OPEN;
   new_st.ext.open = open;
@@ -2689,8 +2629,6 @@ match_close_element (gfc_close *close)
   if (m != MATCH_NO)
     return m;
   m = match_etag (&tag_iomsg, &close->iomsg);
-  if (m == MATCH_YES && !check_char_variable (close->iomsg))
-    return MATCH_ERROR;
   if (m != MATCH_NO)
     return m;
   m = match_out_tag (&tag_iostat, &close->iostat);
@@ -2711,7 +2649,6 @@ gfc_match_close (void)
 {
   gfc_close *close;
   match m;
-  bool warn;
 
   m = gfc_match_char ('(');
   if (m == MATCH_NO)
@@ -2757,22 +2694,6 @@ gfc_match_close (void)
 
   gfc_unset_implicit_pure (NULL);
 
-  warn = (close->iostat || close->err) ? true : false;
-
-  /* Checks on the STATUS specifier.  */
-  if (close->status && close->status->expr_type == EXPR_CONSTANT)
-    {
-      static const char *status[] = { "KEEP", "DELETE", NULL };
-
-      if (!is_char_type ("STATUS", close->status))
-	goto cleanup;
-
-      if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
-				      close->status->value.character.string,
-				      "CLOSE", warn))
-	goto cleanup;
-    }
-
   new_st.op = EXEC_CLOSE;
   new_st.ext.close = close;
   return MATCH_YES;
@@ -2786,34 +2707,14 @@ cleanup:
 }
 
 
-/* Resolve everything in a gfc_close structure.  */
-
-bool
-gfc_resolve_close (gfc_close *close)
+static bool
+check_close_constraints (gfc_close *close, locus *where)
 {
-  RESOLVE_TAG (&tag_unit, close->unit);
-  RESOLVE_TAG (&tag_iomsg, close->iomsg);
-  RESOLVE_TAG (&tag_iostat, close->iostat);
-  RESOLVE_TAG (&tag_status, close->status);
-
-  if (!gfc_reference_st_label (close->err, ST_LABEL_TARGET))
-    return false;
+  bool warn = (close->iostat || close->err) ? true : false;
 
   if (close->unit == NULL)
     {
-      /* Find a locus from one of the arguments to close, when UNIT is
-	 not specified.  */
-      locus loc = gfc_current_locus;
-      if (close->status)
-	loc = close->status->where;
-      else if (close->iostat)
-	loc = close->iostat->where;
-      else if (close->iomsg)
-	loc = close->iomsg->where;
-      else if (close->err)
-	loc = close->err->where;
-
-      gfc_error ("CLOSE statement at %L requires a UNIT number", &loc);
+      gfc_error ("CLOSE statement at %L requires a UNIT number", where);
       return false;
     }
 
@@ -2825,9 +2726,36 @@ gfc_resolve_close (gfc_close *close)
 		 &close->unit->where);
     }
 
+  /* Checks on the STATUS specifier.  */
+  if (close->status && close->status->expr_type == EXPR_CONSTANT)
+    {
+      static const char *status[] = { "KEEP", "DELETE", NULL };
+
+      if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
+				      close->status->value.character.string,
+				      "CLOSE", warn, &close->status->where))
+	return false;
+    }
+
   return true;
 }
 
+/* Resolve everything in a gfc_close structure.  */
+
+bool
+gfc_resolve_close (gfc_close *close, locus *where)
+{
+  RESOLVE_TAG (&tag_unit, close->unit);
+  RESOLVE_TAG (&tag_iomsg, close->iomsg);
+  RESOLVE_TAG (&tag_iostat, close->iostat);
+  RESOLVE_TAG (&tag_status, close->status);
+
+  if (!gfc_reference_st_label (close->err, ST_LABEL_TARGET))
+    return false;
+
+  return check_close_constraints (close, where);
+}
+
 
 /* Free a gfc_filepos structure.  */
 
@@ -2852,8 +2780,6 @@ match_file_element (gfc_filepos *fp)
   if (m != MATCH_NO)
     return m;
   m = match_etag (&tag_iomsg, &fp->iomsg);
-  if (m == MATCH_YES && !check_char_variable (fp->iomsg))
-    return MATCH_ERROR;
   if (m != MATCH_NO)
     return m;
   m = match_out_tag (&tag_iostat, &fp->iostat);
@@ -3227,8 +3153,6 @@ match_dt_element (io_kind k, gfc_dt *dt)
     }
 
   m = match_etag (&tag_e_async, &dt->asynchronous);
-  if (m == MATCH_YES && !is_char_type ("ASYNCHRONOUS", dt->asynchronous))
-    return MATCH_ERROR;
   if (m != MATCH_NO)
     return m;
   m = match_etag (&tag_e_blank, &dt->blank);
@@ -3259,8 +3183,6 @@ match_dt_element (io_kind k, gfc_dt *dt)
   if (m != MATCH_NO)
     return m;
   m = match_etag (&tag_iomsg, &dt->iomsg);
-  if (m == MATCH_YES && !check_char_variable (dt->iomsg))
-    return MATCH_ERROR;
   if (m != MATCH_NO)
     return m;
 
@@ -3330,28 +3252,26 @@ gfc_free_dt (gfc_dt *dt)
 }
 
 
+static const char *
+io_kind_name (io_kind k);
+
+static bool
+check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
+		      locus *spec_end);
+
 /* Resolve everything in a gfc_dt structure.  */
 
 bool
-gfc_resolve_dt (gfc_dt *dt, locus *loc)
+gfc_resolve_dt (gfc_code *dt_code, gfc_dt *dt, locus *loc)
 {
   gfc_expr *e;
   io_kind k;
-  locus tmp;
 
   /* This is set in any case.  */
   gcc_assert (dt->dt_io_kind);
   k = dt->dt_io_kind->value.iokind;
 
-  tmp = gfc_current_locus;
-  gfc_current_locus = *loc;
-  if (!resolve_tag (&tag_format, dt->format_expr))
-    {
-      gfc_current_locus = tmp;
-      return false;
-    }
-  gfc_current_locus = tmp;
-
+  RESOLVE_TAG (&tag_format, dt->format_expr);
   RESOLVE_TAG (&tag_rec, dt->rec);
   RESOLVE_TAG (&tag_spos, dt->pos);
   RESOLVE_TAG (&tag_advance, dt->advance);
@@ -3367,6 +3287,18 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
   RESOLVE_TAG (&tag_e_decimal, dt->decimal);
   RESOLVE_TAG (&tag_e_async, dt->asynchronous);
 
+  /* Check I/O constraints.
+     To validate NAMELIST we need to check if we were also given an I/O list,
+     which is stored in code->block->next with op EXEC_TRANSFER.
+     Note that the I/O list was already resolved from resolve_transfer.  */
+  gfc_code *io_code = NULL;
+  if (dt_code && dt_code->block && dt_code->block->next
+      && dt_code->block->next->op == EXEC_TRANSFER)
+    io_code = dt_code->block->next;
+
+  if (!check_io_constraints (k, dt, io_code, loc))
+    return false;
+
   e = dt->io_unit;
   if (e == NULL)
     {
@@ -3821,11 +3753,13 @@ terminate_io (gfc_code *io_code)
 
 
 /* Check the constraints for a data transfer statement.  The majority of the
-   constraints appearing in 9.4 of the standard appear here.  Some are handled
-   in resolve_tag and others in gfc_resolve_dt.  Also set the async_io_dt flag
-   and, if necessary, the asynchronous flag on the SIZE argument.  */
+   constraints appearing in 9.4 of the standard appear here.
 
-static match
+   Tag expressions are already resolved by resolve_tag, which includes
+   verifying the type, that they are scalar, and verifying that BT_CHARACTER
+   tags are of default kind.  */
+
+static bool
 check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
 		      locus *spec_end)
 {
@@ -3835,11 +3769,10 @@ if (condition) \
     if ((arg)->lb != NULL)\
       gfc_error ((msg), (arg));\
     else\
-      gfc_error ((msg), &gfc_current_locus);\
-    m = MATCH_ERROR;\
+      gfc_error ((msg), spec_end);\
+    return false;\
   }
 
-  match m;
   gfc_expr *expr;
   gfc_symbol *sym = NULL;
   bool warn, unformatted;
@@ -3848,8 +3781,6 @@ if (condition) \
   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
       && expr->ts.type == BT_CHARACTER)
@@ -3867,7 +3798,7 @@ if (condition) \
       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);
@@ -3884,7 +3815,7 @@ if (condition) \
 	{
 	  if (!gfc_notify_std (GFC_STD_F2003, "Internal file at %L with "
 			       "namelist", &expr->where))
-	    m = MATCH_ERROR;
+	    return false;
 	}
 
       io_constraint (dt->advance != NULL,
@@ -3897,87 +3828,57 @@ if (condition) \
 
       if (gfc_pure (NULL) && (k == M_READ || k == M_WRITE))
 	{
-	  gfc_error ("IO UNIT in %s statement at %C must be "
+	  gfc_error ("IO UNIT in %s statement at %L must be "
 		     "an internal file in a PURE procedure",
-		     io_kind_name (k));
-	  return MATCH_ERROR;
+		     io_kind_name (k), &expr->where);
+	  return false;
 	}
-	  
+
       if (k == M_READ || k == M_WRITE)
 	gfc_unset_implicit_pure (NULL);
     }
 
-  if (k != M_READ)
-    {
-      io_constraint (dt->end, "END tag not allowed with output at %L",
-		     &dt->end_where);
-
-      io_constraint (dt->eor, "EOR tag not allowed with output at %L",
-		     &dt->eor_where);
-
-      io_constraint (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
-    {
-      io_constraint (dt->size && dt->advance == NULL,
-		     "SIZE tag at %L requires an ADVANCE tag",
-		     &dt->size->where);
-
-      io_constraint (dt->eor && dt->advance == NULL,
-		     "EOR tag at %L requires an ADVANCE tag",
-		     &dt->eor_where);
-    }
-
-  if (dt->asynchronous) 
+  if (dt->asynchronous)
     {
       int num;
       static const char * asynchronous[] = { "YES", "NO", NULL };
 
+      /* Note: gfc_reduce_init_expr reports an error if not init-expr.  */
       if (!gfc_reduce_init_expr (dt->asynchronous))
-	{
-	  gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
-		     "expression", &dt->asynchronous->where);
-	  return MATCH_ERROR;
-	}
-
-      if (!is_char_type ("ASYNCHRONOUS", dt->asynchronous))
-	return MATCH_ERROR;
-
-      if (dt->asynchronous->ts.kind != 1)
-	{
-	  gfc_error ("ASYNCHRONOUS= specifier at %L must be of default "
-		     "CHARACTER kind", &dt->asynchronous->where);
-	  return MATCH_ERROR;
-	}
-
-      if (dt->asynchronous->expr_type == EXPR_ARRAY
-	  || dt->asynchronous->expr_type == EXPR_STRUCTURE)
-	{
-	  gfc_error ("ASYNCHRONOUS= specifier at %L must be scalar",
-		     &dt->asynchronous->where);
-	  return MATCH_ERROR;
-	}
+	return false;
 
       if (!compare_to_allowed_values
 		("ASYNCHRONOUS", asynchronous, NULL, NULL,
 		 dt->asynchronous->value.character.string,
-		 io_kind_name (k), warn, &num))
-	return MATCH_ERROR;
+		 io_kind_name (k), warn, &dt->asynchronous->where, &num))
+	return false;
 
-      /* Best to put this here because the yes/no info is still around.  */
-      async_io_dt = num == 0;
-      if (async_io_dt && dt->size)
-	dt->size->symtree->n.sym->attr.asynchronous = 1;
+      /* For "YES", mark related symbols as asynchronous.  */
+      if (num == 0)
+	{
+	  /* SIZE variable.  */
+	  if (dt->size)
+	    dt->size->symtree->n.sym->attr.asynchronous = 1;
+
+	  /* Variables in a NAMELIST.  */
+	  if (dt->namelist)
+	    for (gfc_namelist *nl = dt->namelist->namelist; nl; nl = nl->next)
+	      nl->sym->attr.asynchronous = 1;
+
+	  /* Variables in an I/O list.  */
+	  for (gfc_code *xfer = io_code; xfer && xfer->op == EXEC_TRANSFER;
+	       xfer = xfer->next)
+	    {
+	      gfc_expr *expr = xfer->expr1;
+	      while (expr != NULL && expr->expr_type == EXPR_OP
+		     && expr->value.op.op == INTRINSIC_PARENTHESES)
+		expr = expr->value.op.op1;
+
+	      if (expr && expr->expr_type == EXPR_VARIABLE)
+		expr->symtree->n.sym->attr.asynchronous = 1;
+	    }
+	}
     }
-  else
-    async_io_dt = false;
 
   if (dt->id)
     {
@@ -3993,36 +3894,31 @@ if (condition) \
 
   if (dt->decimal)
     {
-      if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C "
-			   "not allowed in Fortran 95"))
-	return MATCH_ERROR;
+      if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %L "
+			   "not allowed in Fortran 95", &dt->decimal->where))
+	return false;
 
       if (dt->decimal->expr_type == EXPR_CONSTANT)
 	{
 	  static const char * decimal[] = { "COMMA", "POINT", NULL };
 
-      if (!is_char_type ("DECIMAL", dt->decimal))
-	return MATCH_ERROR;
-
 	  if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
 					  dt->decimal->value.character.string,
-					  io_kind_name (k), warn))
-	    return MATCH_ERROR;
+					  io_kind_name (k), warn,
+					  &dt->decimal->where))
+	    return false;
 
 	  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, "BLANK= at %C "
-			   "not allowed in Fortran 95"))
-	return MATCH_ERROR;
-
-      if (!is_char_type ("BLANK", dt->blank))
-	return MATCH_ERROR;
+      if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %L "
+			   "not allowed in Fortran 95", &dt->blank->where))
+	return false;
 
       if (dt->blank->expr_type == EXPR_CONSTANT)
 	{
@@ -4031,8 +3927,9 @@ if (condition) \
 
 	  if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
 					  dt->blank->value.character.string,
-					  io_kind_name (k), warn))
-	    return MATCH_ERROR;
+					  io_kind_name (k), warn,
+					  &dt->blank->where))
+	    return false;
 
 	  io_constraint (unformatted,
 			 "the BLANK= specifier at %L must be with an "
@@ -4042,12 +3939,9 @@ if (condition) \
 
   if (dt->pad)
     {
-      if (!gfc_notify_std (GFC_STD_F2003, "PAD= at %C "
-			   "not allowed in Fortran 95"))
-	return MATCH_ERROR;
-
-      if (!is_char_type ("PAD", dt->pad))
-	return MATCH_ERROR;
+      if (!gfc_notify_std (GFC_STD_F2003, "PAD= at %L "
+			   "not allowed in Fortran 95", &dt->pad->where))
+	return false;
 
       if (dt->pad->expr_type == EXPR_CONSTANT)
 	{
@@ -4055,8 +3949,9 @@ if (condition) \
 
 	  if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
 					  dt->pad->value.character.string,
-					  io_kind_name (k), warn))
-	    return MATCH_ERROR;
+					  io_kind_name (k), warn,
+					  &dt->pad->where))
+	    return false;
 
 	  io_constraint (unformatted,
 			 "the PAD= specifier at %L must be with an "
@@ -4066,12 +3961,9 @@ if (condition) \
 
   if (dt->round)
     {
-      if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %C "
-			   "not allowed in Fortran 95"))
-	return MATCH_ERROR;
-
-      if (!is_char_type ("ROUND", dt->round))
-	return MATCH_ERROR;
+      if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %L "
+			   "not allowed in Fortran 95", &dt->round->where))
+	return false;
 
       if (dt->round->expr_type == EXPR_CONSTANT)
 	{
@@ -4081,20 +3973,18 @@ if (condition) \
 
 	  if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
 					  dt->round->value.character.string,
-					  io_kind_name (k), warn))
-	    return MATCH_ERROR;
+					  io_kind_name (k), warn,
+					  &dt->round->where))
+	    return false;
 	}
     }
-  
+
   if (dt->sign)
     {
       /* When implemented, change the following to use gfc_notify_std F2003.
-      if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %C "
-	  "not allowed in Fortran 95") == false)
-	return MATCH_ERROR;  */
-
-      if (!is_char_type ("SIGN", dt->sign))
-	return MATCH_ERROR;
+      if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %L "
+	  "not allowed in Fortran 95", &dt->sign->where) == false)
+	return false;  */
 
       if (dt->sign->expr_type == EXPR_CONSTANT)
 	{
@@ -4103,8 +3993,8 @@ if (condition) \
 
 	  if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
 				      dt->sign->value.character.string,
-				      io_kind_name (k), warn))
-	    return MATCH_ERROR;
+				      io_kind_name (k), warn, &dt->sign->where))
+	    return false;
 
 	  io_constraint (unformatted,
 			 "SIGN= specifier at %L must be with an "
@@ -4118,12 +4008,9 @@ if (condition) \
 
   if (dt->delim)
     {
-      if (!gfc_notify_std (GFC_STD_F2003, "DELIM= at %C "
-			   "not allowed in Fortran 95"))
-	return MATCH_ERROR;
-
-      if (!is_char_type ("DELIM", dt->delim))
-	return MATCH_ERROR;
+      if (!gfc_notify_std (GFC_STD_F2003, "DELIM= at %L "
+			   "not allowed in Fortran 95", &dt->delim->where))
+	return false;
 
       if (dt->delim->expr_type == EXPR_CONSTANT)
 	{
@@ -4131,13 +4018,14 @@ if (condition) \
 
 	  if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
 					  dt->delim->value.character.string,
-					  io_kind_name (k), warn))
-	    return MATCH_ERROR;
+					  io_kind_name (k), warn,
+					  &dt->delim->where))
+	    return false;
 
 	  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=*",
@@ -4148,7 +4036,7 @@ if (condition) \
 			 "NML= specifier", &dt->delim->where);
 	}
     }
-  
+
   if (dt->namelist)
     {
       io_constraint (io_code && dt->namelist,
@@ -4225,17 +4113,41 @@ if (condition) \
 
       io_constraint (dt->eor && not_no && k == M_READ,
 		     "EOR tag at %L requires an ADVANCE = %<NO%>",
-		     &dt->eor_where);      
+		     &dt->eor_where);
     }
 
-  expr = dt->format_expr;
-  if (!gfc_simplify_expr (expr, 0)
-      || !check_format_string (expr, k == M_READ))
-    return MATCH_ERROR;
+  if (k != M_READ)
+    {
+      io_constraint (dt->end, "END tag not allowed with output at %L",
+		     &dt->end_where);
 
-  return m;
-}
+      io_constraint (dt->eor, "EOR tag not allowed with output at %L",
+		     &dt->eor_where);
+
+      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
+    {
+      io_constraint (dt->size && dt->advance == NULL,
+		     "SIZE tag at %L requires an ADVANCE tag",
+		     &dt->size->where);
+
+      io_constraint (dt->eor && dt->advance == NULL,
+		     "EOR tag at %L requires an ADVANCE tag",
+		     &dt->eor_where);
+    }
+
+  return true;
 #undef io_constraint
+}
 
 
 /* Match a READ, WRITE or PRINT statement.  */
@@ -4248,7 +4160,7 @@ match_io (io_kind k)
   gfc_symbol *sym;
   int comma_flag;
   locus where;
-  locus spec_end, control;
+  locus control;
   gfc_dt *dt;
   match m;
 
@@ -4451,9 +4363,6 @@ loop:
 
 get_io_list:
 
-  /* Used in check_io_constraints, where no locus is available.  */
-  spec_end = gfc_current_locus;
-
   /* Save the IO kind for later use.  */
   dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k);
 
@@ -4485,12 +4394,11 @@ get_io_list:
   if (flag_dec_format_defaults)
     dt->dec_ext = 1;
 
-  /* A full IO statement has been matched.  Check the constraints.  spec_end is
-     supplied for cases where no locus is supplied.  */
-  m = check_io_constraints (k, dt, io_code, &spec_end);
-
-  if (m == MATCH_ERROR)
-    goto cleanup;
+  /* Check the format string now.  */
+  if (dt->format_expr
+      && (!gfc_simplify_expr (dt->format_expr, 0)
+	  || !check_format_string (dt->format_expr, k == M_READ)))
+    return MATCH_ERROR;
 
   new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
   new_st.ext.dt = dt;
@@ -4610,8 +4518,6 @@ match_inquire_element (gfc_inquire *inquire)
   RETM m = match_etag (&tag_file, &inquire->file);
   RETM m = match_ltag (&tag_err, &inquire->err);
   RETM m = match_etag (&tag_iomsg, &inquire->iomsg);
-  if (m == MATCH_YES && !check_char_variable (inquire->iomsg))
-    return MATCH_ERROR;
   RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
   RETM m = match_vtag (&tag_exist, &inquire->exist);
   RETM m = match_vtag (&tag_opened, &inquire->opened);
@@ -4633,8 +4539,6 @@ match_inquire_element (gfc_inquire *inquire)
   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);
-  if (m == MATCH_YES && !is_char_type ("ASYNCHRONOUS", inquire->asynchronous))
-    return MATCH_ERROR;
   RETM m = match_vtag (&tag_s_delim, &inquire->delim);
   RETM m = match_vtag (&tag_s_decimal, &inquire->decimal);
   RETM m = match_out_tag (&tag_size, &inquire->size);
@@ -4914,8 +4818,6 @@ match_wait_element (gfc_wait *wait)
   RETM m = match_ltag (&tag_end, &wait->end);
   RETM m = match_ltag (&tag_eor, &wait->eor);
   RETM m = match_etag (&tag_iomsg, &wait->iomsg);
-  if (m == MATCH_YES && !check_char_variable (wait->iomsg))
-    return MATCH_ERROR;
   RETM m = match_out_tag (&tag_iostat, &wait->iostat);
   RETM m = match_etag (&tag_id, &wait->id);
   RETM return MATCH_NO;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 97de6dd..ccd2a5e 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -9941,9 +9941,6 @@ resolve_transfer (gfc_code *code)
 		 "an assumed-size array", &code->loc);
       return;
     }
-
-  if (async_io_dt && exp->expr_type == EXPR_VARIABLE)
-    exp->symtree->n.sym->attr.asynchronous = 1;
 }
 
 
@@ -12003,14 +12000,14 @@ start:
 	  break;
 
 	case EXEC_OPEN:
-	  if (!gfc_resolve_open (code->ext.open))
+	  if (!gfc_resolve_open (code->ext.open, &code->loc))
 	    break;
 
 	  resolve_branch (code->ext.open->err, code);
 	  break;
 
 	case EXEC_CLOSE:
-	  if (!gfc_resolve_close (code->ext.close))
+	  if (!gfc_resolve_close (code->ext.close, &code->loc))
 	    break;
 
 	  resolve_branch (code->ext.close->err, code);
@@ -12052,7 +12049,7 @@ start:
 
 	case EXEC_READ:
 	case EXEC_WRITE:
-	  if (!gfc_resolve_dt (code->ext.dt, &code->loc))
+	  if (!gfc_resolve_dt (code, code->ext.dt, &code->loc))
 	    break;
 
 	  resolve_branch (code->ext.dt->err, code);
@@ -15009,11 +15006,6 @@ resolve_fl_namelist (gfc_symbol *sym)
 	}
     }
 
-  if (async_io_dt)
-    {
-      for (nl = sym->namelist; nl; nl = nl->next)
-	nl->sym->attr.asynchronous = 1;
-    }
   return true;
 }