Skip to content

R
riscv-gcc-1
Commit 44facdb7 by Fritz Reese
Options

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.
parent ef529765
Showing with 1124 additions and 539 deletions
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.
2020-04-07 Fritz Reese <foreese@gcc.gnu.org> 2020-04-07 Fritz Reese <foreese@gcc.gnu.org>
Steven G. Kargl <kargl@gcc.gnu.org> Steven G. Kargl <kargl@gcc.gnu.org>
......
gcc/fortran/gfortran.h
...@@ -3476,18 +3476,17 @@ bool gfc_compare_actual_formal (gfc_actual_arglist **, gfc_formal_arglist *, ...@@ -3476,18 +3476,17 @@ bool gfc_compare_actual_formal (gfc_actual_arglist **, gfc_formal_arglist *,
extern gfc_st_label format_asterisk; extern gfc_st_label format_asterisk;
void gfc_free_open (gfc_open *); 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 *); 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 *); void gfc_free_filepos (gfc_filepos *);
bool gfc_resolve_filepos (gfc_filepos *, locus *); bool gfc_resolve_filepos (gfc_filepos *, locus *);
void gfc_free_inquire (gfc_inquire *); void gfc_free_inquire (gfc_inquire *);
bool gfc_resolve_inquire (gfc_inquire *); bool gfc_resolve_inquire (gfc_inquire *);
void gfc_free_dt (gfc_dt *); 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 *); void gfc_free_wait (gfc_wait *);
bool gfc_resolve_wait (gfc_wait *); bool gfc_resolve_wait (gfc_wait *);
extern bool async_io_dt;
/* module.c */ /* module.c */
void gfc_module_init_2 (void); void gfc_module_init_2 (void);
......
gcc/fortran/io.c
...@@ -112,10 +112,6 @@ static gfc_dt *current_dt; ...@@ -112,10 +112,6 @@ static gfc_dt *current_dt;
#define RESOLVE_TAG(x, y) if (!resolve_tag (x, y)) return false; #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 *****************/ /**************** Fortran 95 FORMAT parser *****************/
/* FORMAT tokens returned by format_lex(). */ /* FORMAT tokens returned by format_lex(). */
...@@ -1427,36 +1423,6 @@ gfc_match_format (void) ...@@ -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. */ /* Match an expression I/O tag of some sort. */
static match static match
...@@ -1725,7 +1691,8 @@ resolve_tag_format (gfc_expr *e) ...@@ -1725,7 +1691,8 @@ resolve_tag_format (gfc_expr *e)
if (e->value.constructor == NULL) 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; return false;
} }
...@@ -1919,16 +1886,12 @@ match_open_element (gfc_open *open) ...@@ -1919,16 +1886,12 @@ match_open_element (gfc_open *open)
match m; match m;
m = match_etag (&tag_e_async, &open->asynchronous); 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) if (m != MATCH_NO)
return m; return m;
m = match_etag (&tag_unit, &open->unit); m = match_etag (&tag_unit, &open->unit);
if (m != MATCH_NO) if (m != MATCH_NO)
return m; return m;
m = match_etag (&tag_iomsg, &open->iomsg); m = match_etag (&tag_iomsg, &open->iomsg);
if (m == MATCH_YES && !check_char_variable (open->iomsg))
return MATCH_ERROR;
if (m != MATCH_NO) if (m != MATCH_NO)
return m; return m;
m = match_out_tag (&tag_iostat, &open->iostat); m = match_out_tag (&tag_iostat, &open->iostat);
...@@ -2041,12 +2004,22 @@ gfc_free_open (gfc_open *open) ...@@ -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. */ /* Resolve everything in a gfc_open structure. */
bool bool
gfc_resolve_open (gfc_open *open) gfc_resolve_open (gfc_open *open, locus *where)
{ {
RESOLVE_TAG (&tag_unit, open->unit); RESOLVE_TAG (&tag_unit, open->unit);
RESOLVE_TAG (&tag_iomsg, open->iomsg); RESOLVE_TAG (&tag_iomsg, open->iomsg);
RESOLVE_TAG (&tag_iostat, open->iostat); RESOLVE_TAG (&tag_iostat, open->iostat);
...@@ -2073,7 +2046,7 @@ gfc_resolve_open (gfc_open *open) ...@@ -2073,7 +2046,7 @@ gfc_resolve_open (gfc_open *open)
if (!gfc_reference_st_label (open->err, ST_LABEL_TARGET)) if (!gfc_reference_st_label (open->err, ST_LABEL_TARGET))
return false; return false;
return true; return check_open_constraints (open, where);
} }
...@@ -2081,19 +2054,13 @@ gfc_resolve_open (gfc_open *open) ...@@ -2081,19 +2054,13 @@ gfc_resolve_open (gfc_open *open)
allowed in F95 or F2003, issuing an error message and returning a zero allowed in F95 or F2003, issuing an error message and returning a zero
value if it is not allowed. */ 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 static int
compare_to_allowed_values (const char *specifier, const char *allowed[], 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 *allowed_gnu[], gfc_char_t *value,
const char *statement, bool warn, int *num) const char *statement, bool warn, locus *where,
int *num)
{ {
int i; int i;
unsigned int len; unsigned int len;
...@@ -2116,6 +2083,9 @@ compare_to_allowed_values (const char *specifier, const char *allowed[], ...@@ -2116,6 +2083,9 @@ compare_to_allowed_values (const char *specifier, const char *allowed[],
return 1; return 1;
} }
if (!where)
where = &gfc_current_locus;
for (i = 0; allowed_f2003 && allowed_f2003[i]; i++) for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
if (len == strlen (allowed_f2003[i]) if (len == strlen (allowed_f2003[i])
&& gfc_wide_strncasecmp (value, allowed_f2003[i], && gfc_wide_strncasecmp (value, allowed_f2003[i],
...@@ -2125,8 +2095,8 @@ compare_to_allowed_values (const char *specifier, const char *allowed[], ...@@ -2125,8 +2095,8 @@ compare_to_allowed_values (const char *specifier, const char *allowed[],
if (n == WARNING || (warn && n == ERROR)) if (n == WARNING || (warn && n == ERROR))
{ {
gfc_warning (0, "Fortran 2003: %s specifier in %s statement at %C " gfc_warning (0, "Fortran 2003: %s specifier in %s statement at %L "
"has value %qs", specifier, statement, "has value %qs", specifier, statement, where,
allowed_f2003[i]); allowed_f2003[i]);
return 1; return 1;
} }
...@@ -2134,8 +2104,8 @@ compare_to_allowed_values (const char *specifier, const char *allowed[], ...@@ -2134,8 +2104,8 @@ compare_to_allowed_values (const char *specifier, const char *allowed[],
if (n == ERROR) if (n == ERROR)
{ {
gfc_notify_std (GFC_STD_F2003, "%s specifier in " gfc_notify_std (GFC_STD_F2003, "%s specifier in "
"%s statement at %C has value %qs", specifier, "%s statement at %L has value %qs", specifier,
statement, allowed_f2003[i]); statement, where, allowed_f2003[i]);
return 0; return 0;
} }
...@@ -2152,8 +2122,8 @@ compare_to_allowed_values (const char *specifier, const char *allowed[], ...@@ -2152,8 +2122,8 @@ compare_to_allowed_values (const char *specifier, const char *allowed[],
if (n == WARNING || (warn && n == ERROR)) if (n == WARNING || (warn && n == ERROR))
{ {
gfc_warning (0, "Extension: %s specifier in %s statement at %C " gfc_warning (0, "Extension: %s specifier in %s statement at %L "
"has value %qs", specifier, statement, "has value %qs", specifier, statement, where,
allowed_gnu[i]); allowed_gnu[i]);
return 1; return 1;
} }
...@@ -2161,8 +2131,8 @@ compare_to_allowed_values (const char *specifier, const char *allowed[], ...@@ -2161,8 +2131,8 @@ compare_to_allowed_values (const char *specifier, const char *allowed[],
if (n == ERROR) if (n == ERROR)
{ {
gfc_notify_std (GFC_STD_GNU, "%s specifier in " gfc_notify_std (GFC_STD_GNU, "%s specifier in "
"%s statement at %C has value %qs", specifier, "%s statement at %L has value %qs", specifier,
statement, allowed_gnu[i]); statement, where, allowed_gnu[i]);
return 0; return 0;
} }
...@@ -2174,74 +2144,42 @@ compare_to_allowed_values (const char *specifier, const char *allowed[], ...@@ -2174,74 +2144,42 @@ compare_to_allowed_values (const char *specifier, const char *allowed[],
{ {
char *s = gfc_widechar_to_char (value, -1); char *s = gfc_widechar_to_char (value, -1);
gfc_warning (0, gfc_warning (0,
"%s specifier in %s statement at %C has invalid value %qs", "%s specifier in %s statement at %L has invalid value %qs",
specifier, statement, s); specifier, statement, where, s);
free (s); free (s);
return 1; return 1;
} }
else else
{ {
char *s = gfc_widechar_to_char (value, -1); char *s = gfc_widechar_to_char (value, -1);
gfc_error ("%s specifier in %s statement at %C has invalid value %qs", gfc_error ("%s specifier in %s statement at %L has invalid value %qs",
specifier, statement, s); specifier, statement, where, s);
free (s); free (s);
return 0; 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 static bool
gfc_match_open (void) check_open_constraints (gfc_open *open, locus *where)
{ {
gfc_open *open; #define warn_or_error(...) \
match m; { \
bool warn; if (warn) \
gfc_warning (0, __VA_ARGS__); \
m = gfc_match_char ('('); else \
if (m == MATCH_NO) { \
return m; gfc_error (__VA_ARGS__); \
return false; \
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);
warn = (open->err || open->iostat) ? true : false; bool warn = (open->err || open->iostat) ? true : false;
/* Checks on the ACCESS specifier. */ /* Checks on the ACCESS specifier. */
if (open->access && open->access->expr_type == EXPR_CONSTANT) if (open->access && open->access->expr_type == EXPR_CONSTANT)
...@@ -2250,14 +2188,11 @@ gfc_match_open (void) ...@@ -2250,14 +2188,11 @@ gfc_match_open (void)
static const char *access_f2003[] = { "STREAM", NULL }; static const char *access_f2003[] = { "STREAM", NULL };
static const char *access_gnu[] = { "APPEND", 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, if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003,
access_gnu, access_gnu,
open->access->value.character.string, open->access->value.character.string,
"OPEN", warn)) "OPEN", warn, &open->access->where))
goto cleanup; return false;
} }
/* Checks on the ACTION specifier. */ /* Checks on the ACTION specifier. */
...@@ -2266,21 +2201,20 @@ gfc_match_open (void) ...@@ -2266,21 +2201,20 @@ gfc_match_open (void)
gfc_char_t *str = open->action->value.character.string; gfc_char_t *str = open->action->value.character.string;
static const char *action[] = { "READ", "WRITE", "READWRITE", NULL }; 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, if (!compare_to_allowed_values ("ACTION", action, NULL, NULL,
str, "OPEN", warn)) str, "OPEN", warn, &open->action->where))
goto cleanup; return false;
/* With READONLY, only allow ACTION='READ'. */ /* With READONLY, only allow ACTION='READ'. */
if (open->readonly && (gfc_wide_strlen (str) != 4 if (open->readonly && (gfc_wide_strlen (str) != 4
|| gfc_wide_strncasecmp (str, "READ", 4) != 0)) || gfc_wide_strncasecmp (str, "READ", 4) != 0))
{ {
gfc_error ("ACTION type conflicts with READONLY specifier at %C"); gfc_error ("ACTION type conflicts with READONLY specifier at %L",
goto cleanup; &open->action->where);
return false;
} }
} }
/* If we see READONLY and no ACTION, set ACTION='READ'. */ /* If we see READONLY and no ACTION, set ACTION='READ'. */
else if (open->readonly && open->action == NULL) else if (open->readonly && open->action == NULL)
{ {
...@@ -2291,27 +2225,10 @@ gfc_match_open (void) ...@@ -2291,27 +2225,10 @@ gfc_match_open (void)
/* Checks on the ASYNCHRONOUS specifier. */ /* Checks on the ASYNCHRONOUS specifier. */
if (open->asynchronous) if (open->asynchronous)
{ {
if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS= at %C " if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS= at %L "
"not allowed in Fortran 95")) "not allowed in Fortran 95",
goto cleanup; &open->asynchronous->where))
return false;
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 (open->asynchronous->expr_type == EXPR_CONSTANT) if (open->asynchronous->expr_type == EXPR_CONSTANT)
{ {
...@@ -2319,20 +2236,17 @@ gfc_match_open (void) ...@@ -2319,20 +2236,17 @@ gfc_match_open (void)
if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous, if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous,
NULL, NULL, open->asynchronous->value.character.string, NULL, NULL, open->asynchronous->value.character.string,
"OPEN", warn)) "OPEN", warn, &open->asynchronous->where))
goto cleanup; return false;
} }
} }
/* Checks on the BLANK specifier. */ /* Checks on the BLANK specifier. */
if (open->blank) if (open->blank)
{ {
if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %C " if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %L "
"not allowed in Fortran 95")) "not allowed in Fortran 95", &open->blank->where))
goto cleanup; return false;
if (!is_char_type ("BLANK", open->blank))
goto cleanup;
if (open->blank->expr_type == EXPR_CONSTANT) if (open->blank->expr_type == EXPR_CONSTANT)
{ {
...@@ -2340,36 +2254,27 @@ gfc_match_open (void) ...@@ -2340,36 +2254,27 @@ gfc_match_open (void)
if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL, if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
open->blank->value.character.string, open->blank->value.character.string,
"OPEN", warn)) "OPEN", warn, &open->blank->where))
goto cleanup; return false;
} }
} }
/* Checks on the CARRIAGECONTROL specifier. */ /* Checks on the CARRIAGECONTROL specifier. */
if (open->cc) if (open->cc && open->cc->expr_type == EXPR_CONSTANT)
{ {
if (!is_char_type ("CARRIAGECONTROL", open->cc)) static const char *cc[] = { "LIST", "FORTRAN", "NONE", NULL };
goto cleanup; if (!compare_to_allowed_values ("CARRIAGECONTROL", cc, NULL, NULL,
open->cc->value.character.string,
if (open->cc->expr_type == EXPR_CONSTANT) "OPEN", warn, &open->cc->where))
{ return false;
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;
}
} }
/* Checks on the DECIMAL specifier. */ /* Checks on the DECIMAL specifier. */
if (open->decimal) if (open->decimal)
{ {
if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C " if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %L "
"not allowed in Fortran 95")) "not allowed in Fortran 95", &open->decimal->where))
goto cleanup; return false;
if (!is_char_type ("DECIMAL", open->decimal))
goto cleanup;
if (open->decimal->expr_type == EXPR_CONSTANT) if (open->decimal->expr_type == EXPR_CONSTANT)
{ {
...@@ -2377,8 +2282,8 @@ gfc_match_open (void) ...@@ -2377,8 +2282,8 @@ gfc_match_open (void)
if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL, if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
open->decimal->value.character.string, open->decimal->value.character.string,
"OPEN", warn)) "OPEN", warn, &open->decimal->where))
goto cleanup; return false;
} }
} }
...@@ -2389,25 +2294,19 @@ gfc_match_open (void) ...@@ -2389,25 +2294,19 @@ gfc_match_open (void)
{ {
static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL }; 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, if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
open->delim->value.character.string, open->delim->value.character.string,
"OPEN", warn)) "OPEN", warn, &open->delim->where))
goto cleanup; return false;
} }
} }
/* Checks on the ENCODING specifier. */ /* Checks on the ENCODING specifier. */
if (open->encoding) if (open->encoding)
{ {
if (!gfc_notify_std (GFC_STD_F2003, "ENCODING= at %C " if (!gfc_notify_std (GFC_STD_F2003, "ENCODING= at %L "
"not allowed in Fortran 95")) "not allowed in Fortran 95", &open->encoding->where))
goto cleanup; return false;
if (!is_char_type ("ENCODING", open->encoding))
goto cleanup;
if (open->encoding->expr_type == EXPR_CONSTANT) if (open->encoding->expr_type == EXPR_CONSTANT)
{ {
...@@ -2415,8 +2314,8 @@ gfc_match_open (void) ...@@ -2415,8 +2314,8 @@ gfc_match_open (void)
if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL, if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
open->encoding->value.character.string, open->encoding->value.character.string,
"OPEN", warn)) "OPEN", warn, &open->encoding->where))
goto cleanup; return false;
} }
} }
...@@ -2425,13 +2324,10 @@ gfc_match_open (void) ...@@ -2425,13 +2324,10 @@ gfc_match_open (void)
{ {
static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL }; 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, if (!compare_to_allowed_values ("FORM", form, NULL, NULL,
open->form->value.character.string, open->form->value.character.string,
"OPEN", warn)) "OPEN", warn, &open->form->where))
goto cleanup; return false;
} }
/* Checks on the PAD specifier. */ /* Checks on the PAD specifier. */
...@@ -2439,13 +2335,10 @@ gfc_match_open (void) ...@@ -2439,13 +2335,10 @@ gfc_match_open (void)
{ {
static const char *pad[] = { "YES", "NO", NULL }; 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, if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
open->pad->value.character.string, open->pad->value.character.string,
"OPEN", warn)) "OPEN", warn, &open->pad->where))
goto cleanup; return false;
} }
/* Checks on the POSITION specifier. */ /* Checks on the POSITION specifier. */
...@@ -2453,24 +2346,18 @@ gfc_match_open (void) ...@@ -2453,24 +2346,18 @@ gfc_match_open (void)
{ {
static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL }; 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, if (!compare_to_allowed_values ("POSITION", position, NULL, NULL,
open->position->value.character.string, open->position->value.character.string,
"OPEN", warn)) "OPEN", warn, &open->position->where))
goto cleanup; return false;
} }
/* Checks on the ROUND specifier. */ /* Checks on the ROUND specifier. */
if (open->round) if (open->round)
{ {
if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %C " if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %L "
"not allowed in Fortran 95")) "not allowed in Fortran 95", &open->round->where))
goto cleanup; return false;
if (!is_char_type ("ROUND", open->round))
goto cleanup;
if (open->round->expr_type == EXPR_CONSTANT) if (open->round->expr_type == EXPR_CONSTANT)
{ {
...@@ -2480,36 +2367,27 @@ gfc_match_open (void) ...@@ -2480,36 +2367,27 @@ gfc_match_open (void)
if (!compare_to_allowed_values ("ROUND", round, NULL, NULL, if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
open->round->value.character.string, open->round->value.character.string,
"OPEN", warn)) "OPEN", warn, &open->round->where))
goto cleanup; return false;
} }
} }
/* Checks on the SHARE specifier. */ /* Checks on the SHARE specifier. */
if (open->share) if (open->share && open->share->expr_type == EXPR_CONSTANT)
{ {
if (!is_char_type ("SHARE", open->share)) static const char *share[] = { "DENYNONE", "DENYRW", NULL };
goto cleanup; if (!compare_to_allowed_values ("SHARE", share, NULL, NULL,
open->share->value.character.string,
if (open->share->expr_type == EXPR_CONSTANT) "OPEN", warn, &open->share->where))
{ return false;
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;
}
} }
/* Checks on the SIGN specifier. */ /* Checks on the SIGN specifier. */
if (open->sign) if (open->sign)
{ {
if (!gfc_notify_std (GFC_STD_F2003, "SIGN= at %C " if (!gfc_notify_std (GFC_STD_F2003, "SIGN= at %L "
"not allowed in Fortran 95")) "not allowed in Fortran 95", &open->sign->where))
goto cleanup; return false;
if (!is_char_type ("SIGN", open->sign))
goto cleanup;
if (open->sign->expr_type == EXPR_CONSTANT) if (open->sign->expr_type == EXPR_CONSTANT)
{ {
...@@ -2518,28 +2396,18 @@ gfc_match_open (void) ...@@ -2518,28 +2396,18 @@ gfc_match_open (void)
if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL, if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
open->sign->value.character.string, open->sign->value.character.string,
"OPEN", warn)) "OPEN", warn, &open->sign->where))
goto cleanup; 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. */ /* Checks on the RECL specifier. */
if (open->recl && open->recl->expr_type == EXPR_CONSTANT if (open->recl && open->recl->expr_type == EXPR_CONSTANT
&& open->recl->ts.type == BT_INTEGER && open->recl->ts.type == BT_INTEGER
&& mpz_sgn (open->recl->value.integer) != 1) && 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. */ /* Checks on the STATUS specifier. */
...@@ -2548,13 +2416,10 @@ gfc_match_open (void) ...@@ -2548,13 +2416,10 @@ gfc_match_open (void)
static const char *status[] = { "OLD", "NEW", "SCRATCH", static const char *status[] = { "OLD", "NEW", "SCRATCH",
"REPLACE", "UNKNOWN", NULL }; "REPLACE", "UNKNOWN", NULL };
if (!is_char_type ("STATUS", open->status))
goto cleanup;
if (!compare_to_allowed_values ("STATUS", status, NULL, NULL, if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
open->status->value.character.string, open->status->value.character.string,
"OPEN", warn)) "OPEN", warn, &open->status->where))
goto cleanup; return false;
/* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE, /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
the FILE= specifier shall appear. */ the FILE= specifier shall appear. */
...@@ -2566,8 +2431,9 @@ gfc_match_open (void) ...@@ -2566,8 +2431,9 @@ gfc_match_open (void)
{ {
char *s = gfc_widechar_to_char (open->status->value.character.string, char *s = gfc_widechar_to_char (open->status->value.character.string,
-1); -1);
warn_or_error ("The STATUS specified in OPEN statement at %C is " warn_or_error ("The STATUS specified in OPEN statement at %L is "
"%qs and no FILE specifier is present", s); "%qs and no FILE specifier is present",
&open->status->where, s);
free (s); free (s);
} }
...@@ -2576,9 +2442,9 @@ gfc_match_open (void) ...@@ -2576,9 +2442,9 @@ gfc_match_open (void)
if (gfc_wide_strncasecmp (open->status->value.character.string, if (gfc_wide_strncasecmp (open->status->value.character.string,
"scratch", 7) == 0 && open->file) "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 " "cannot have the value SCRATCH if a FILE specifier "
"is present"); "is present", &open->status->where);
} }
} }
...@@ -2587,8 +2453,9 @@ gfc_match_open (void) ...@@ -2587,8 +2453,9 @@ gfc_match_open (void)
{ {
if (open->unit) if (open->unit)
{ {
gfc_error ("UNIT specifier not allowed with NEWUNIT at %C"); gfc_error ("UNIT specifier not allowed with NEWUNIT at %L",
goto cleanup; &open->newunit->where);
return false;
} }
if (!open->file && if (!open->file &&
...@@ -2598,14 +2465,15 @@ gfc_match_open (void) ...@@ -2598,14 +2465,15 @@ gfc_match_open (void)
"scratch", 7) != 0))) "scratch", 7) != 0)))
{ {
gfc_error ("NEWUNIT specifier must have FILE= " gfc_error ("NEWUNIT specifier must have FILE= "
"or STATUS='scratch' at %C"); "or STATUS='scratch' at %L", &open->newunit->where);
goto cleanup; return false;
} }
} }
else if (!open->unit) else if (!open->unit)
{ {
gfc_error ("OPEN statement at %C must have UNIT or NEWUNIT specified"); gfc_error ("OPEN statement at %L must have UNIT or NEWUNIT specified",
goto cleanup; where);
return false;
} }
/* Things that are not allowed for unformatted I/O. */ /* Things that are not allowed for unformatted I/O. */
...@@ -2615,20 +2483,39 @@ gfc_match_open (void) ...@@ -2615,20 +2483,39 @@ gfc_match_open (void)
&& gfc_wide_strncasecmp (open->form->value.character.string, && gfc_wide_strncasecmp (open->form->value.character.string,
"unformatted", 11) == 0) "unformatted", 11) == 0)
{ {
const char *spec = (open->delim ? "DELIM " locus *loc;
: (open->pad ? "PAD " : open->blank const char *spec;
? "BLANK " : "")); 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 " warn_or_error ("%s specifier at %L not allowed in OPEN statement for "
"unformatted I/O", spec); "unformatted I/O", spec, loc);
} }
if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT
&& gfc_wide_strncasecmp (open->access->value.character.string, && gfc_wide_strncasecmp (open->access->value.character.string,
"stream", 6) == 0) "stream", 6) == 0)
{ {
warn_or_error ("RECL specifier not allowed in OPEN statement at %C for " warn_or_error ("RECL specifier not allowed in OPEN statement at %L for "
"stream I/O"); "stream I/O", &open->recl->where);
} }
if (open->position if (open->position
...@@ -2640,11 +2527,64 @@ gfc_match_open (void) ...@@ -2640,11 +2527,64 @@ gfc_match_open (void)
|| gfc_wide_strncasecmp (open->access->value.character.string, || gfc_wide_strncasecmp (open->access->value.character.string,
"append", 6) == 0)) "append", 6) == 0))
{ {
warn_or_error ("POSITION specifier in OPEN statement at %C only allowed " warn_or_error ("POSITION specifier in OPEN statement at %L only allowed "
"for stream or sequential ACCESS"); "for stream or sequential ACCESS", &open->position->where);
} }
return true;
#undef warn_or_error #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.op = EXEC_OPEN;
new_st.ext.open = open; new_st.ext.open = open;
...@@ -2689,8 +2629,6 @@ match_close_element (gfc_close *close) ...@@ -2689,8 +2629,6 @@ match_close_element (gfc_close *close)
if (m != MATCH_NO) if (m != MATCH_NO)
return m; return m;
m = match_etag (&tag_iomsg, &close->iomsg); m = match_etag (&tag_iomsg, &close->iomsg);
if (m == MATCH_YES && !check_char_variable (close->iomsg))
return MATCH_ERROR;
if (m != MATCH_NO) if (m != MATCH_NO)
return m; return m;
m = match_out_tag (&tag_iostat, &close->iostat); m = match_out_tag (&tag_iostat, &close->iostat);
...@@ -2711,7 +2649,6 @@ gfc_match_close (void) ...@@ -2711,7 +2649,6 @@ gfc_match_close (void)
{ {
gfc_close *close; gfc_close *close;
match m; match m;
bool warn;
m = gfc_match_char ('('); m = gfc_match_char ('(');
if (m == MATCH_NO) if (m == MATCH_NO)
...@@ -2757,22 +2694,6 @@ gfc_match_close (void) ...@@ -2757,22 +2694,6 @@ gfc_match_close (void)
gfc_unset_implicit_pure (NULL); 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.op = EXEC_CLOSE;
new_st.ext.close = close; new_st.ext.close = close;
return MATCH_YES; return MATCH_YES;
...@@ -2786,34 +2707,14 @@ cleanup: ...@@ -2786,34 +2707,14 @@ cleanup:
} }
/* Resolve everything in a gfc_close structure. */ static bool
check_close_constraints (gfc_close *close, locus *where)
bool
gfc_resolve_close (gfc_close *close)
{ {
RESOLVE_TAG (&tag_unit, close->unit); bool warn = (close->iostat || close->err) ? true : false;
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;
if (close->unit == NULL) if (close->unit == NULL)
{ {
/* Find a locus from one of the arguments to close, when UNIT is gfc_error ("CLOSE statement at %L requires a UNIT number", where);
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);
return false; return false;
} }
...@@ -2825,9 +2726,36 @@ gfc_resolve_close (gfc_close *close) ...@@ -2825,9 +2726,36 @@ gfc_resolve_close (gfc_close *close)
&close->unit->where); &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; 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. */ /* Free a gfc_filepos structure. */
...@@ -2852,8 +2780,6 @@ match_file_element (gfc_filepos *fp) ...@@ -2852,8 +2780,6 @@ match_file_element (gfc_filepos *fp)
if (m != MATCH_NO) if (m != MATCH_NO)
return m; return m;
m = match_etag (&tag_iomsg, &fp->iomsg); m = match_etag (&tag_iomsg, &fp->iomsg);
if (m == MATCH_YES && !check_char_variable (fp->iomsg))
return MATCH_ERROR;
if (m != MATCH_NO) if (m != MATCH_NO)
return m; return m;
m = match_out_tag (&tag_iostat, &fp->iostat); m = match_out_tag (&tag_iostat, &fp->iostat);
...@@ -3227,8 +3153,6 @@ match_dt_element (io_kind k, gfc_dt *dt) ...@@ -3227,8 +3153,6 @@ match_dt_element (io_kind k, gfc_dt *dt)
} }
m = match_etag (&tag_e_async, &dt->asynchronous); 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) if (m != MATCH_NO)
return m; return m;
m = match_etag (&tag_e_blank, &dt->blank); m = match_etag (&tag_e_blank, &dt->blank);
...@@ -3259,8 +3183,6 @@ match_dt_element (io_kind k, gfc_dt *dt) ...@@ -3259,8 +3183,6 @@ match_dt_element (io_kind k, gfc_dt *dt)
if (m != MATCH_NO) if (m != MATCH_NO)
return m; return m;
m = match_etag (&tag_iomsg, &dt->iomsg); m = match_etag (&tag_iomsg, &dt->iomsg);
if (m == MATCH_YES && !check_char_variable (dt->iomsg))
return MATCH_ERROR;
if (m != MATCH_NO) if (m != MATCH_NO)
return m; return m;
...@@ -3330,28 +3252,26 @@ gfc_free_dt (gfc_dt *dt) ...@@ -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. */ /* Resolve everything in a gfc_dt structure. */
bool bool
gfc_resolve_dt (gfc_dt *dt, locus *loc) gfc_resolve_dt (gfc_code *dt_code, gfc_dt *dt, locus *loc)
{ {
gfc_expr *e; gfc_expr *e;
io_kind k; io_kind k;
locus tmp;
/* This is set in any case. */ /* This is set in any case. */
gcc_assert (dt->dt_io_kind); gcc_assert (dt->dt_io_kind);
k = dt->dt_io_kind->value.iokind; k = dt->dt_io_kind->value.iokind;
tmp = gfc_current_locus; RESOLVE_TAG (&tag_format, dt->format_expr);
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_rec, dt->rec); RESOLVE_TAG (&tag_rec, dt->rec);
RESOLVE_TAG (&tag_spos, dt->pos); RESOLVE_TAG (&tag_spos, dt->pos);
RESOLVE_TAG (&tag_advance, dt->advance); RESOLVE_TAG (&tag_advance, dt->advance);
...@@ -3367,6 +3287,18 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc) ...@@ -3367,6 +3287,18 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
RESOLVE_TAG (&tag_e_decimal, dt->decimal); RESOLVE_TAG (&tag_e_decimal, dt->decimal);
RESOLVE_TAG (&tag_e_async, dt->asynchronous); 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; e = dt->io_unit;
if (e == NULL) if (e == NULL)
{ {
...@@ -3821,11 +3753,13 @@ terminate_io (gfc_code *io_code) ...@@ -3821,11 +3753,13 @@ terminate_io (gfc_code *io_code)
/* Check the constraints for a data transfer statement. The majority of the /* 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 constraints appearing in 9.4 of the standard appear here.
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. */
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, check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
locus *spec_end) locus *spec_end)
{ {
...@@ -3835,11 +3769,10 @@ if (condition) \ ...@@ -3835,11 +3769,10 @@ if (condition) \
if ((arg)->lb != NULL)\ if ((arg)->lb != NULL)\
gfc_error ((msg), (arg));\ gfc_error ((msg), (arg));\
else\ else\
gfc_error ((msg), &gfc_current_locus);\ gfc_error ((msg), spec_end);\
m = MATCH_ERROR;\ return false;\
} }
match m;
gfc_expr *expr; gfc_expr *expr;
gfc_symbol *sym = NULL; gfc_symbol *sym = NULL;
bool warn, unformatted; bool warn, unformatted;
...@@ -3848,8 +3781,6 @@ if (condition) \ ...@@ -3848,8 +3781,6 @@ if (condition) \
unformatted = dt->format_expr == NULL && dt->format_label == NULL unformatted = dt->format_expr == NULL && dt->format_label == NULL
&& dt->namelist == NULL; && dt->namelist == NULL;
m = MATCH_YES;
expr = dt->io_unit; expr = dt->io_unit;
if (expr && expr->expr_type == EXPR_VARIABLE if (expr && expr->expr_type == EXPR_VARIABLE
&& expr->ts.type == BT_CHARACTER) && expr->ts.type == BT_CHARACTER)
...@@ -3867,7 +3798,7 @@ if (condition) \ ...@@ -3867,7 +3798,7 @@ if (condition) \
io_constraint (dt->rec != NULL, io_constraint (dt->rec != NULL,
"REC tag at %L is incompatible with internal file", "REC tag at %L is incompatible with internal file",
&dt->rec->where); &dt->rec->where);
io_constraint (dt->pos != NULL, io_constraint (dt->pos != NULL,
"POS tag at %L is incompatible with internal file", "POS tag at %L is incompatible with internal file",
&dt->pos->where); &dt->pos->where);
...@@ -3884,7 +3815,7 @@ if (condition) \ ...@@ -3884,7 +3815,7 @@ if (condition) \
{ {
if (!gfc_notify_std (GFC_STD_F2003, "Internal file at %L with " if (!gfc_notify_std (GFC_STD_F2003, "Internal file at %L with "
"namelist", &expr->where)) "namelist", &expr->where))
m = MATCH_ERROR; return false;
} }
io_constraint (dt->advance != NULL, io_constraint (dt->advance != NULL,
...@@ -3897,87 +3828,57 @@ if (condition) \ ...@@ -3897,87 +3828,57 @@ if (condition) \
if (gfc_pure (NULL) && (k == M_READ || k == M_WRITE)) 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", "an internal file in a PURE procedure",
io_kind_name (k)); io_kind_name (k), &expr->where);
return MATCH_ERROR; return false;
} }
if (k == M_READ || k == M_WRITE) if (k == M_READ || k == M_WRITE)
gfc_unset_implicit_pure (NULL); gfc_unset_implicit_pure (NULL);
} }
if (k != M_READ) if (dt->asynchronous)
{
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)
{ {
int num; int num;
static const char * asynchronous[] = { "YES", "NO", NULL }; 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)) if (!gfc_reduce_init_expr (dt->asynchronous))
{ return false;
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;
}
if (!compare_to_allowed_values if (!compare_to_allowed_values
("ASYNCHRONOUS", asynchronous, NULL, NULL, ("ASYNCHRONOUS", asynchronous, NULL, NULL,
dt->asynchronous->value.character.string, dt->asynchronous->value.character.string,
io_kind_name (k), warn, &num)) io_kind_name (k), warn, &dt->asynchronous->where, &num))
return MATCH_ERROR; return false;
/* Best to put this here because the yes/no info is still around. */ /* For "YES", mark related symbols as asynchronous. */
async_io_dt = num == 0; if (num == 0)
if (async_io_dt && dt->size) {
dt->size->symtree->n.sym->attr.asynchronous = 1; /* 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) if (dt->id)
{ {
...@@ -3993,36 +3894,31 @@ if (condition) \ ...@@ -3993,36 +3894,31 @@ if (condition) \
if (dt->decimal) if (dt->decimal)
{ {
if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C " if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %L "
"not allowed in Fortran 95")) "not allowed in Fortran 95", &dt->decimal->where))
return MATCH_ERROR; return false;
if (dt->decimal->expr_type == EXPR_CONSTANT) if (dt->decimal->expr_type == EXPR_CONSTANT)
{ {
static const char * decimal[] = { "COMMA", "POINT", NULL }; 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, if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
dt->decimal->value.character.string, dt->decimal->value.character.string,
io_kind_name (k), warn)) io_kind_name (k), warn,
return MATCH_ERROR; &dt->decimal->where))
return false;
io_constraint (unformatted, io_constraint (unformatted,
"the DECIMAL= specifier at %L must be with an " "the DECIMAL= specifier at %L must be with an "
"explicit format expression", &dt->decimal->where); "explicit format expression", &dt->decimal->where);
} }
} }
if (dt->blank) if (dt->blank)
{ {
if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %C " if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %L "
"not allowed in Fortran 95")) "not allowed in Fortran 95", &dt->blank->where))
return MATCH_ERROR; return false;
if (!is_char_type ("BLANK", dt->blank))
return MATCH_ERROR;
if (dt->blank->expr_type == EXPR_CONSTANT) if (dt->blank->expr_type == EXPR_CONSTANT)
{ {
...@@ -4031,8 +3927,9 @@ if (condition) \ ...@@ -4031,8 +3927,9 @@ if (condition) \
if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL, if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
dt->blank->value.character.string, dt->blank->value.character.string,
io_kind_name (k), warn)) io_kind_name (k), warn,
return MATCH_ERROR; &dt->blank->where))
return false;
io_constraint (unformatted, io_constraint (unformatted,
"the BLANK= specifier at %L must be with an " "the BLANK= specifier at %L must be with an "
...@@ -4042,12 +3939,9 @@ if (condition) \ ...@@ -4042,12 +3939,9 @@ if (condition) \
if (dt->pad) if (dt->pad)
{ {
if (!gfc_notify_std (GFC_STD_F2003, "PAD= at %C " if (!gfc_notify_std (GFC_STD_F2003, "PAD= at %L "
"not allowed in Fortran 95")) "not allowed in Fortran 95", &dt->pad->where))
return MATCH_ERROR; return false;
if (!is_char_type ("PAD", dt->pad))
return MATCH_ERROR;
if (dt->pad->expr_type == EXPR_CONSTANT) if (dt->pad->expr_type == EXPR_CONSTANT)
{ {
...@@ -4055,8 +3949,9 @@ if (condition) \ ...@@ -4055,8 +3949,9 @@ if (condition) \
if (!compare_to_allowed_values ("PAD", pad, NULL, NULL, if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
dt->pad->value.character.string, dt->pad->value.character.string,
io_kind_name (k), warn)) io_kind_name (k), warn,
return MATCH_ERROR; &dt->pad->where))
return false;
io_constraint (unformatted, io_constraint (unformatted,
"the PAD= specifier at %L must be with an " "the PAD= specifier at %L must be with an "
...@@ -4066,12 +3961,9 @@ if (condition) \ ...@@ -4066,12 +3961,9 @@ if (condition) \
if (dt->round) if (dt->round)
{ {
if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %C " if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %L "
"not allowed in Fortran 95")) "not allowed in Fortran 95", &dt->round->where))
return MATCH_ERROR; return false;
if (!is_char_type ("ROUND", dt->round))
return MATCH_ERROR;
if (dt->round->expr_type == EXPR_CONSTANT) if (dt->round->expr_type == EXPR_CONSTANT)
{ {
...@@ -4081,20 +3973,18 @@ if (condition) \ ...@@ -4081,20 +3973,18 @@ if (condition) \
if (!compare_to_allowed_values ("ROUND", round, NULL, NULL, if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
dt->round->value.character.string, dt->round->value.character.string,
io_kind_name (k), warn)) io_kind_name (k), warn,
return MATCH_ERROR; &dt->round->where))
return false;
} }
} }
if (dt->sign) if (dt->sign)
{ {
/* When implemented, change the following to use gfc_notify_std F2003. /* When implemented, change the following to use gfc_notify_std F2003.
if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %C " if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %L "
"not allowed in Fortran 95") == false) "not allowed in Fortran 95", &dt->sign->where) == false)
return MATCH_ERROR; */ return false; */
if (!is_char_type ("SIGN", dt->sign))
return MATCH_ERROR;
if (dt->sign->expr_type == EXPR_CONSTANT) if (dt->sign->expr_type == EXPR_CONSTANT)
{ {
...@@ -4103,8 +3993,8 @@ if (condition) \ ...@@ -4103,8 +3993,8 @@ if (condition) \
if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL, if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
dt->sign->value.character.string, dt->sign->value.character.string,
io_kind_name (k), warn)) io_kind_name (k), warn, &dt->sign->where))
return MATCH_ERROR; return false;
io_constraint (unformatted, io_constraint (unformatted,
"SIGN= specifier at %L must be with an " "SIGN= specifier at %L must be with an "
...@@ -4118,12 +4008,9 @@ if (condition) \ ...@@ -4118,12 +4008,9 @@ if (condition) \
if (dt->delim) if (dt->delim)
{ {
if (!gfc_notify_std (GFC_STD_F2003, "DELIM= at %C " if (!gfc_notify_std (GFC_STD_F2003, "DELIM= at %L "
"not allowed in Fortran 95")) "not allowed in Fortran 95", &dt->delim->where))
return MATCH_ERROR; return false;
if (!is_char_type ("DELIM", dt->delim))
return MATCH_ERROR;
if (dt->delim->expr_type == EXPR_CONSTANT) if (dt->delim->expr_type == EXPR_CONSTANT)
{ {
...@@ -4131,13 +4018,14 @@ if (condition) \ ...@@ -4131,13 +4018,14 @@ if (condition) \
if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL, if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
dt->delim->value.character.string, dt->delim->value.character.string,
io_kind_name (k), warn)) io_kind_name (k), warn,
return MATCH_ERROR; &dt->delim->where))
return false;
io_constraint (k == M_READ, io_constraint (k == M_READ,
"DELIM= specifier at %L not allowed in a " "DELIM= specifier at %L not allowed in a "
"READ statement", &dt->delim->where); "READ statement", &dt->delim->where);
io_constraint (dt->format_label != &format_asterisk io_constraint (dt->format_label != &format_asterisk
&& dt->namelist == NULL, && dt->namelist == NULL,
"DELIM= specifier at %L must have FMT=*", "DELIM= specifier at %L must have FMT=*",
...@@ -4148,7 +4036,7 @@ if (condition) \ ...@@ -4148,7 +4036,7 @@ if (condition) \
"NML= specifier", &dt->delim->where); "NML= specifier", &dt->delim->where);
} }
} }
if (dt->namelist) if (dt->namelist)
{ {
io_constraint (io_code && dt->namelist, io_constraint (io_code && dt->namelist,
...@@ -4225,17 +4113,41 @@ if (condition) \ ...@@ -4225,17 +4113,41 @@ if (condition) \
io_constraint (dt->eor && not_no && k == M_READ, io_constraint (dt->eor && not_no && k == M_READ,
"EOR tag at %L requires an ADVANCE = %<NO%>", "EOR tag at %L requires an ADVANCE = %<NO%>",
&dt->eor_where); &dt->eor_where);
} }
expr = dt->format_expr; if (k != M_READ)
if (!gfc_simplify_expr (expr, 0) {
|| !check_format_string (expr, k == M_READ)) io_constraint (dt->end, "END tag not allowed with output at %L",
return MATCH_ERROR; &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 #undef io_constraint
}
/* Match a READ, WRITE or PRINT statement. */ /* Match a READ, WRITE or PRINT statement. */
...@@ -4248,7 +4160,7 @@ match_io (io_kind k) ...@@ -4248,7 +4160,7 @@ match_io (io_kind k)
gfc_symbol *sym; gfc_symbol *sym;
int comma_flag; int comma_flag;
locus where; locus where;
locus spec_end, control; locus control;
gfc_dt *dt; gfc_dt *dt;
match m; match m;
...@@ -4451,9 +4363,6 @@ loop: ...@@ -4451,9 +4363,6 @@ loop:
get_io_list: 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. */ /* Save the IO kind for later use. */
dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k); dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k);
...@@ -4485,12 +4394,11 @@ get_io_list: ...@@ -4485,12 +4394,11 @@ get_io_list:
if (flag_dec_format_defaults) if (flag_dec_format_defaults)
dt->dec_ext = 1; dt->dec_ext = 1;
/* A full IO statement has been matched. Check the constraints. spec_end is /* Check the format string now. */
supplied for cases where no locus is supplied. */ if (dt->format_expr
m = check_io_constraints (k, dt, io_code, &spec_end); && (!gfc_simplify_expr (dt->format_expr, 0)
|| !check_format_string (dt->format_expr, k == M_READ)))
if (m == MATCH_ERROR) return MATCH_ERROR;
goto cleanup;
new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE; new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
new_st.ext.dt = dt; new_st.ext.dt = dt;
...@@ -4610,8 +4518,6 @@ match_inquire_element (gfc_inquire *inquire) ...@@ -4610,8 +4518,6 @@ match_inquire_element (gfc_inquire *inquire)
RETM m = match_etag (&tag_file, &inquire->file); RETM m = match_etag (&tag_file, &inquire->file);
RETM m = match_ltag (&tag_err, &inquire->err); RETM m = match_ltag (&tag_err, &inquire->err);
RETM m = match_etag (&tag_iomsg, &inquire->iomsg); 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_out_tag (&tag_iostat, &inquire->iostat);
RETM m = match_vtag (&tag_exist, &inquire->exist); RETM m = match_vtag (&tag_exist, &inquire->exist);
RETM m = match_vtag (&tag_opened, &inquire->opened); RETM m = match_vtag (&tag_opened, &inquire->opened);
...@@ -4633,8 +4539,6 @@ match_inquire_element (gfc_inquire *inquire) ...@@ -4633,8 +4539,6 @@ match_inquire_element (gfc_inquire *inquire)
RETM m = match_vtag (&tag_write, &inquire->write); RETM m = match_vtag (&tag_write, &inquire->write);
RETM m = match_vtag (&tag_readwrite, &inquire->readwrite); RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
RETM m = match_vtag (&tag_s_async, &inquire->asynchronous); 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_delim, &inquire->delim);
RETM m = match_vtag (&tag_s_decimal, &inquire->decimal); RETM m = match_vtag (&tag_s_decimal, &inquire->decimal);
RETM m = match_out_tag (&tag_size, &inquire->size); RETM m = match_out_tag (&tag_size, &inquire->size);
...@@ -4914,8 +4818,6 @@ match_wait_element (gfc_wait *wait) ...@@ -4914,8 +4818,6 @@ match_wait_element (gfc_wait *wait)
RETM m = match_ltag (&tag_end, &wait->end); RETM m = match_ltag (&tag_end, &wait->end);
RETM m = match_ltag (&tag_eor, &wait->eor); RETM m = match_ltag (&tag_eor, &wait->eor);
RETM m = match_etag (&tag_iomsg, &wait->iomsg); 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_out_tag (&tag_iostat, &wait->iostat);
RETM m = match_etag (&tag_id, &wait->id); RETM m = match_etag (&tag_id, &wait->id);
RETM return MATCH_NO; RETM return MATCH_NO;
......
gcc/fortran/resolve.c
...@@ -9941,9 +9941,6 @@ resolve_transfer (gfc_code *code) ...@@ -9941,9 +9941,6 @@ resolve_transfer (gfc_code *code)
"an assumed-size array", &code->loc); "an assumed-size array", &code->loc);
return; return;
} }
if (async_io_dt && exp->expr_type == EXPR_VARIABLE)
exp->symtree->n.sym->attr.asynchronous = 1;
} }
...@@ -12003,14 +12000,14 @@ start: ...@@ -12003,14 +12000,14 @@ start:
break; break;
case EXEC_OPEN: case EXEC_OPEN:
if (!gfc_resolve_open (code->ext.open)) if (!gfc_resolve_open (code->ext.open, &code->loc))
break; break;
resolve_branch (code->ext.open->err, code); resolve_branch (code->ext.open->err, code);
break; break;
case EXEC_CLOSE: case EXEC_CLOSE:
if (!gfc_resolve_close (code->ext.close)) if (!gfc_resolve_close (code->ext.close, &code->loc))
break; break;
resolve_branch (code->ext.close->err, code); resolve_branch (code->ext.close->err, code);
...@@ -12052,7 +12049,7 @@ start: ...@@ -12052,7 +12049,7 @@ start:
case EXEC_READ: case EXEC_READ:
case EXEC_WRITE: case EXEC_WRITE:
if (!gfc_resolve_dt (code->ext.dt, &code->loc)) if (!gfc_resolve_dt (code, code->ext.dt, &code->loc))
break; break;
resolve_branch (code->ext.dt->err, code); resolve_branch (code->ext.dt->err, code);
...@@ -15009,11 +15006,6 @@ resolve_fl_namelist (gfc_symbol *sym) ...@@ -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; return true;
} }
......
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.
2020-04-09 Richard Sandiford <richard.sandiford@arm.com> 2020-04-09 Richard Sandiford <richard.sandiford@arm.com>
* gcc.target/aarch64/sve/acle/general/attributes_1.c: New test. * gcc.target/aarch64/sve/acle/general/attributes_1.c: New test.
......
gcc/testsuite/gfortran.dg/asynchronous_5.f03 0 → 100644
! { dg-do compile }
! { dg-options "-std=f2003" }
!
! Covers code introduced by the fix to PR fortran/87923.
! The idea is that the variables in a namelist or I/O list used for
! asynchronous I/O will be marked with the asynchronous attribute.
!
! At this time, "asynchronous" is treated as "volatile" (see trans-decl.c).
! Thus, every variable referenced in an "asynchronous=yes" I/O list
! should obtain the "volatile" specifier in its declaration.
!
type t
character(4) :: comp_async
end type
character(2) :: ccvar_async
type(t) :: dvar_async
integer :: ivar_async
real :: rvar_async
logical :: lvar_async
type(t), dimension(2) :: darrvar_async
integer :: ivar_noasync
namelist /names/ ivar_async, rvar_async, lvar_async
open(1, asynchronous="yes")
write(1, asynchronous="yes") dvar_async, ccvar_async
write(1, asynchronous="yes") dvar_async%comp_async, darrvar_async
read(1, asynchronous="yes", nml=names)
open(2, asynchronous="no")
read(2, asynchronous="no") ivar_noasync
end
! { dg-final { scan-tree-dump-times "volatile.*?ccvar_async" 1 "original" } }
! { dg-final { scan-tree-dump-times "volatile.*?dvar_async" 1 "original" } }
! { dg-final { scan-tree-dump-times "volatile.*?ivar_async" 1 "original" } }
! { dg-final { scan-tree-dump-times "volatile.*?rvar_async" 1 "original" } }
! { dg-final { scan-tree-dump-times "volatile.*?lvar_async" 1 "original" } }
! { dg-final { scan-tree-dump-times "volatile.*?darrvar_async" 1 "original" } }
! { dg-final { scan-tree-dump-not "volatile.*?ivar_noasync" "original" } }
gcc/testsuite/gfortran.dg/f2003_io_8.f03
...@@ -9,5 +9,5 @@ character(25) :: msg ...@@ -9,5 +9,5 @@ character(25) :: msg
open(10, file='mydata_f2003_io_8', asynchronous="yes", blank="null") open(10, file='mydata_f2003_io_8', asynchronous="yes", blank="null")
write(10,'(10f8.3)', asynchronous='no', decimal="comma", id=j) a ! { dg-error "must be with ASYNCHRONOUS=" } write(10,'(10f8.3)', asynchronous='no', decimal="comma", id=j) a ! { dg-error "must be with ASYNCHRONOUS=" }
read(10,'(10f8.3)', id=j, decimal="comma", blank="zero") b ! { dg-error "must be with ASYNCHRONOUS=" } read(10,'(10f8.3)', id=j, decimal="comma", blank="zero") b ! { dg-error "must be with ASYNCHRONOUS=" }
read(10,'(10f8.3)', asynchronous=msg, decimal="comma", blank="zero") b ! { dg-error "must be an initialization expression" } read(10,'(10f8.3)', asynchronous=msg, decimal="comma", blank="zero") b ! { dg-error "does not reduce to a constant expression" }
end end
gcc/testsuite/gfortran.dg/io_constraints_15.f90 0 → 100644
! { dg-do compile }
!
! PR fortran/87923
!
program p
open (1, blank=char(1000,4)) ! { dg-error "must be a character string of default kind" }
open (2, decimal=char(1000,4)) ! { dg-error "must be a character string of default kind" }
open (3, encoding=char(1000,4)) ! { dg-error "must be a character string of default kind" }
open (4, round=char(1000,4)) ! { dg-error "must be a character string of default kind" }
open (5, sign=char(1000,4)) ! { dg-error "must be a character string of default kind" }
end
gcc/testsuite/gfortran.dg/io_constraints_16.f90 0 → 100644
! { dg-do compile }
!
! PR fortran/87923
!
program p
read (1, blank=char(1000,4)) ! { dg-error "must be a character string of default kind" }
read (1, delim=char(1000,4)) ! { dg-error "must be a character string of default kind" }
read (1, pad=char(1000,4)) ! { dg-error "must be a character string of default kind" }
read (1, round=char(1000,4)) ! { dg-error "must be a character string of default kind" }
read (1, sign=char(1000,4)) ! { dg-error "must be a character string of default kind" }
end
gcc/testsuite/gfortran.dg/io_constraints_17.f90 0 → 100644
! { dg-do compile }
!
! PR fortran/87923
!
program p
write (1, blank=char(1000,4)) ! { dg-error "must be a character string of default kind" }
write (1, delim=char(1000,4)) ! { dg-error "must be a character string of default kind" }
write (1, pad=char(1000,4)) ! { dg-error "must be a character string of default kind" }
write (1, round=char(1000,4)) ! { dg-error "must be a character string of default kind" }
write (1, sign=char(1000,4)) ! { dg-error "must be a character string of default kind" }
end
gcc/testsuite/gfortran.dg/io_constraints_18.f90 0 → 100644
! { dg-options "-fdec" }
! { dg-do compile }
!
! PR fortran/87923
!
program p
open (1, carriagecontrol=char(1000,4)) ! { dg-error "must be a character string of default kind" }
open (2, share=char(1000,4)) ! { dg-error "must be a character string of default kind" }
end
gcc/testsuite/gfortran.dg/io_constraints_8.f90
...@@ -14,7 +14,7 @@ integer :: i ...@@ -14,7 +14,7 @@ integer :: i
OPEN(99, access=4_'direct') ! { dg-error "must be a character string of default kind" } OPEN(99, access=4_'direct') ! { dg-error "must be a character string of default kind" }
OPEN(99, action=4_'read') ! { dg-error "must be a character string of default kind" } OPEN(99, action=4_'read') ! { dg-error "must be a character string of default kind" }
OPEN(99, asynchronous=4_'no') ! { dg-error "must be of default CHARACTER kind" } OPEN(99, asynchronous=4_'no') ! { dg-error "must be a character string of default kind" }
OPEN(99, blank=4_'null') ! { dg-error "must be a character string of default kind" } OPEN(99, blank=4_'null') ! { dg-error "must be a character string of default kind" }
OPEN(99, decimal=4_'comma') ! { dg-error "must be a character string of default kind" } OPEN(99, decimal=4_'comma') ! { dg-error "must be a character string of default kind" }
OPEN(99, delim=4_'quote') ! { dg-error "must be a character string of default kind" } OPEN(99, delim=4_'quote') ! { dg-error "must be a character string of default kind" }
......
gcc/testsuite/gfortran.dg/io_tags_1.f90 0 → 100644
! { dg-do compile }
! { dg-options "-std=f2003" }
! Based on PR fortran/66724, also covers fortran/66725 and fortran/87923.
!
backspace (1, iomsg=1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
backspace (1, iomsg=1e1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
backspace (1, iomsg=1d1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
backspace (1, iomsg=.false.) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
backspace (1, iomsg='') ! { dg-error "Non-variable expression" }
backspace (1, iomsg='no') ! { dg-error "Non-variable expression" }
backspace (1, iomsg=null()) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
backspace (1, iomsg=(1)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
backspace (1, iomsg=(1., 0.)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
backspace (1, iomsg=[1]) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
backspace (1, iomsg=['']) ! { dg-error "IOMSG tag at ... must be scalar" }
backspace (1, iomsg=['no']) ! { dg-error "IOMSG tag at ... must be scalar" }
end
gcc/testsuite/gfortran.dg/io_tags_10.f90 0 → 100644
! { dg-do compile }
! { dg-options "-std=f2003" }
! Based on PR fortran/66724, also covers fortran/66725 and fortran/87923.
!
write (1, blank='') ! { dg-error "BLANK specifier in WRITE statement at ... has invalid value" }
write (1, asynchronous=1) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
write (1, asynchronous=1e1) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
write (1, asynchronous=1d1) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
write (1, asynchronous=.false.) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
write (1, asynchronous='') ! { dg-error "ASYNCHRONOUS specifier in WRITE statement at ... has invalid value" }
write (1, asynchronous='no')
write (1, asynchronous=null()) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
write (1, asynchronous=(1)) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
write (1, asynchronous=(1., 0.)) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
write (1, asynchronous=[1]) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
write (1, asynchronous=['']) ! { dg-error "ASYNCHRONOUS tag at ... must be scalar" }
write (1, blank=1) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
write (1, blank=1e1) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
write (1, blank=1d1) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
write (1, blank=.false.) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
write (1, blank='no') ! { dg-error "BLANK specifier in WRITE statement at ... has invalid value" }
write (1, blank=null()) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
write (1, blank=(1)) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
write (1, blank=(1., 0.)) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
write (1, blank=[1]) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
write (1, blank=['']) ! { dg-error "BLANK tag at ... must be scalar" }
write (1, delim=1) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
write (1, delim=1e1) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
write (1, delim=1d1) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
write (1, delim=.false.) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
write (1, delim='') ! { dg-error "DELIM specifier in WRITE statement at ... has invalid value" }
write (1, delim='no') ! { dg-error "DELIM specifier in WRITE statement at ... has invalid value" }
write (1, delim=null()) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
write (1, delim=(1)) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
write (1, delim=(1., 0.)) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
write (1, delim=[1]) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
write (1, delim=['']) ! { dg-error "DELIM tag at ... must be scalar" }
write (1, decimal=1) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
write (1, decimal=1e1) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
write (1, decimal=1d1) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
write (1, decimal=.false.) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
write (1, decimal='') ! { dg-error "DECIMAL specifier in WRITE statement at ... has invalid value" }
write (1, decimal='no') ! { dg-error "DECIMAL specifier in WRITE statement at ... has invalid value" }
write (1, decimal=null()) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
write (1, decimal=(1)) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
write (1, decimal=(1., 0.)) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
write (1, decimal=[1]) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
write (1, decimal=['']) ! { dg-error "DECIMAL tag at ... must be scalar" }
write (1, iomsg=1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
write (1, iomsg=1e1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
write (1, iomsg=1d1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
write (1, iomsg=.false.) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
write (1, iomsg='') ! { dg-error "Non-variable expression" }
write (1, iomsg='no') ! { dg-error "Non-variable expression" }
write (1, iomsg=null()) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
write (1, iomsg=(1)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
write (1, iomsg=(1., 0.)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
write (1, iomsg=[1]) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
write (1, iomsg=['']) ! { dg-error "IOMSG tag at ... must be scalar" }
write (1, pad=1) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
write (1, pad=1e1) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
write (1, pad=1d1) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
write (1, pad=.false.) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
write (1, pad='') ! { dg-error "PAD specifier in WRITE statement at ... has invalid value" }
write (1, pad='no') ! { dg-error "the PAD= specifier at ... must be with an explicit format expression" }
write (1, pad=null()) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
write (1, pad=(1)) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
write (1, pad=(1., 0.)) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
write (1, pad=[1]) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
write (1, pad=['']) ! { dg-error "PAD tag at ... must be scalar" }
write (1, round=1) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
write (1, round=1e1) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
write (1, round=1d1) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
write (1, round=.false.) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
write (1, round='') ! { dg-error "ROUND specifier in WRITE statement at ... has invalid value" }
write (1, round='no') ! { dg-error "ROUND specifier in WRITE statement at ... has invalid value" }
write (1, round=null()) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
write (1, round=(1)) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
write (1, round=(1., 0.)) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
write (1, round=[1]) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
write (1, round=['']) ! { dg-error "ROUND tag at ... must be scalar" }
write (1, sign=1) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
write (1, sign=1e1) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
write (1, sign=1d1) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
write (1, sign=.false.) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
write (1, sign='') ! { dg-error "SIGN specifier in WRITE statement at ... has invalid value" }
write (1, sign='no') ! { dg-error "SIGN specifier in WRITE statement at ... has invalid value" }
write (1, sign=null()) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
write (1, sign=(1)) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
write (1, sign=(1., 0.)) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
write (1, sign=[1]) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
write (1, sign=['']) ! { dg-error "SIGN tag at ... must be scalar" }
end
gcc/testsuite/gfortran.dg/io_tags_2.f90 0 → 100644
! { dg-do compile }
! { dg-options "-std=f2003" }
! Based on PR fortran/66724, also covers fortran/66725 and fortran/87923.
!
close (1, iomsg=1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
close (1, iomsg=1e1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
close (1, iomsg=1d1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
close (1, iomsg=.false.) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
close (1, iomsg='') ! { dg-error "Non-variable expression" }
close (1, iomsg='no') ! { dg-error "Non-variable expression" }
close (1, iomsg=null()) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
close (1, iomsg=(1)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
close (1, iomsg=(1., 0.)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
close (1, iomsg=[1]) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
close (1, iomsg=['']) ! { dg-error "IOMSG tag at ... must be scalar" }
close (1, iomsg=['no']) ! { dg-error "IOMSG tag at ... must be scalar" }
close (1, status=1) ! { dg-error "STATUS tag at ... must be of type CHARACTER" }
close (1, status=1e1) ! { dg-error "STATUS tag at ... must be of type CHARACTER" }
close (1, status=1d1) ! { dg-error "STATUS tag at ... must be of type CHARACTER" }
close (1, status=.false.) ! { dg-error "STATUS tag at ... must be of type CHARACTER" }
close (1, status='') ! { dg-error "STATUS specifier in CLOSE statement at ... has invalid value" }
close (1, status='no') ! { dg-error "STATUS specifier in CLOSE statement at ... has invalid value" }
close (1, status=null()) ! { dg-error "STATUS tag at ... must be of type CHARACTER" }
close (1, status=(1)) ! { dg-error "STATUS tag at ... must be of type CHARACTER" }
close (1, status=(1., 0.)) ! { dg-error "STATUS tag at ... must be of type CHARACTER" }
close (1, status=[1]) ! { dg-error "STATUS tag at ... must be of type CHARACTER" }
close (1, status=['']) ! { dg-error "STATUS tag at ... must be scalar" }
end
gcc/testsuite/gfortran.dg/io_tags_3.f90 0 → 100644
! { dg-do compile }
! { dg-options "-std=f2003" }
! Based on PR fortran/66724, also covers fortran/66725 and fortran/87923.
!
endfile (1, iomsg=1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
endfile (1, iomsg=1e1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
endfile (1, iomsg=1d1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
endfile (1, iomsg=.false.) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
endfile (1, iomsg='') ! { dg-error "Non-variable expression" }
endfile (1, iomsg='no') ! { dg-error "Non-variable expression" }
endfile (1, iomsg=null()) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
endfile (1, iomsg=(1)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
endfile (1, iomsg=(1., 0.)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
endfile (1, iomsg=[1]) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
endfile (1, iomsg=['']) ! { dg-error "IOMSG tag at ... must be scalar" }
end
gcc/testsuite/gfortran.dg/io_tags_4.f90 0 → 100644
! { dg-do compile }
! { dg-options "-std=f2003" }
! Based on PR fortran/66724, also covers fortran/66725 and fortran/87923.
!
flush (1, iomsg=1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
flush (1, iomsg=1e1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
flush (1, iomsg=1d1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
flush (1, iomsg=.false.) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
flush (1, iomsg='') ! { dg-error "Non-variable expression" }
flush (1, iomsg='no') ! { dg-error "Non-variable expression" }
flush (1, iomsg=null()) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
flush (1, iomsg=(1)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
flush (1, iomsg=(1., 0.)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
flush (1, iomsg=[1]) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
flush (1, iomsg=['']) ! { dg-error "IOMSG tag at ... must be scalar" }
end
gcc/testsuite/gfortran.dg/io_tags_5.f90 0 → 100644
! { dg-do compile }
! { dg-options "-std=f2003" }
! Based on PR fortran/66724, also covers fortran/66725 and fortran/87923.
!
inquire (1, iomsg=1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
inquire (1, iomsg=1e1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
inquire (1, iomsg=1d1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
inquire (1, iomsg=.false.) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
inquire (1, iomsg='') ! { dg-error "Non-variable expression" }
inquire (1, iomsg='no') ! { dg-error "Non-variable expression" }
inquire (1, iomsg=null()) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
inquire (1, iomsg=(1)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
inquire (1, iomsg=(1., 0.)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
inquire (1, iomsg=[1]) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
inquire (1, iomsg=['']) ! { dg-error "IOMSG tag at ... must be scalar" }
end
gcc/testsuite/gfortran.dg/io_tags_6.f90 0 → 100644
! { dg-do compile }
! { dg-options "-std=f2003" }
! Based on PR fortran/66724, also covers fortran/66725 and fortran/87923.
!
open (1, access=1) ! { dg-error "ACCESS tag at ... must be of type CHARACTER" }
open (1, access=1e1) ! { dg-error "ACCESS tag at ... must be of type CHARACTER" }
open (1, access=1d1) ! { dg-error "ACCESS tag at ... must be of type CHARACTER" }
open (1, access=.false.) ! { dg-error "ACCESS tag at ... must be of type CHARACTER" }
open (1, access='') ! { dg-error "ACCESS specifier in OPEN statement at ... has invalid value" }
open (1, access='no') ! { dg-error "ACCESS specifier in OPEN statement at ... has invalid value" }
open (1, access=null()) ! { dg-error "ACCESS tag at ... must be of type CHARACTER" }
open (1, access=(1)) ! { dg-error "ACCESS tag at ... must be of type CHARACTER" }
open (1, access=(1., 0.)) ! { dg-error "ACCESS tag at ... must be of type CHARACTER" }
open (1, access=[1]) ! { dg-error "ACCESS tag at ... must be of type CHARACTER" }
open (1, access=['']) ! { dg-error "ACCESS tag at ... must be scalar" }
open (1, action=1) ! { dg-error "ACTION tag at ... must be of type CHARACTER" }
open (1, action=1e1) ! { dg-error "ACTION tag at ... must be of type CHARACTER" }
open (1, action=1d1) ! { dg-error "ACTION tag at ... must be of type CHARACTER" }
open (1, action=.false.) ! { dg-error "ACTION tag at ... must be of type CHARACTER" }
open (1, action='') ! { dg-error "ACTION specifier in OPEN statement at ... has invalid value" }
open (1, action='no') ! { dg-error "ACTION specifier in OPEN statement at ... has invalid value" }
open (1, action=null()) ! { dg-error "ACTION tag at ... must be of type CHARACTER" }
open (1, action=(1)) ! { dg-error "ACTION tag at ... must be of type CHARACTER" }
open (1, action=(1., 0.)) ! { dg-error "ACTION tag at ... must be of type CHARACTER" }
open (1, action=[1]) ! { dg-error "ACTION tag at ... must be of type CHARACTER" }
open (1, action=['']) ! { dg-error "ACTION tag at ... must be scalar" }
open (1, asynchronous=1) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
open (1, asynchronous=1e1) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
open (1, asynchronous=1d1) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
open (1, asynchronous=.false.) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
open (1, asynchronous='') ! { dg-error "ASYNCHRONOUS specifier in OPEN statement at ... has invalid value" }
open (1, asynchronous='no')
open (1, asynchronous=null()) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
open (1, asynchronous=(1)) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
open (1, asynchronous=(1., 0.)) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
open (1, asynchronous=[1]) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
open (1, asynchronous=['']) ! { dg-error "ASYNCHRONOUS tag at ... must be scalar" }
open (1, blank=1) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
open (1, blank=1e1) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
open (1, blank=1d1) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
open (1, blank=.false.) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
open (1, blank='') ! { dg-error "BLANK specifier in OPEN statement at ... has invalid value" }
open (1, blank='no') ! { dg-error "BLANK specifier in OPEN statement at ... has invalid value" }
open (1, blank=null()) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
open (1, blank=(1)) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
open (1, blank=(1., 0.)) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
open (1, blank=[1]) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
open (1, blank=['']) ! { dg-error "BLANK tag at ... must be scalar" }
open (1, delim=1) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
open (1, delim=1e1) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
open (1, delim=1d1) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
open (1, delim=.false.) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
open (1, delim='') ! { dg-error "DELIM specifier in OPEN statement at ... has invalid value" }
open (1, delim='no') ! { dg-error "DELIM specifier in OPEN statement at ... has invalid value" }
open (1, delim=null()) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
open (1, delim=(1)) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
open (1, delim=(1., 0.)) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
open (1, delim=[1]) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
open (1, delim=['']) ! { dg-error "DELIM tag at ... must be scalar" }
open (1, decimal=1) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
open (1, decimal=1e1) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
open (1, decimal=1d1) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
open (1, decimal=.false.) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
open (1, decimal='') ! { dg-error "DECIMAL specifier in OPEN statement at ... has invalid value" }
open (1, decimal='no') ! { dg-error "DECIMAL specifier in OPEN statement at ... has invalid value" }
open (1, decimal=null()) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
open (1, decimal=(1)) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
open (1, decimal=(1., 0.)) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
open (1, decimal=[1]) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
open (1, decimal=['']) ! { dg-error "DECIMAL tag at ... must be scalar" }
open (1, encoding=1) ! { dg-error "ENCODING tag at ... must be of type CHARACTER" }
open (1, encoding=1e1) ! { dg-error "ENCODING tag at ... must be of type CHARACTER" }
open (1, encoding=1d1) ! { dg-error "ENCODING tag at ... must be of type CHARACTER" }
open (1, encoding=.false.) ! { dg-error "ENCODING tag at ... must be of type CHARACTER" }
open (1, encoding='') ! { dg-error "ENCODING specifier in OPEN statement at ... has invalid value" }
open (1, encoding='no') ! { dg-error "ENCODING specifier in OPEN statement at ... has invalid value" }
open (1, encoding=null()) ! { dg-error "ENCODING tag at ... must be of type CHARACTER" }
open (1, encoding=(1)) ! { dg-error "ENCODING tag at ... must be of type CHARACTER" }
open (1, encoding=(1., 0.)) ! { dg-error "ENCODING tag at ... must be of type CHARACTER" }
open (1, encoding=[1]) ! { dg-error "ENCODING tag at ... must be of type CHARACTER" }
open (1, encoding=['']) ! { dg-error "ENCODING tag at ... must be scalar" }
open (1, form=1) ! { dg-error "FORM tag at ... must be of type CHARACTER" }
open (1, form=1e1) ! { dg-error "FORM tag at ... must be of type CHARACTER" }
open (1, form=1d1) ! { dg-error "FORM tag at ... must be of type CHARACTER" }
open (1, form=.false.) ! { dg-error "FORM tag at ... must be of type CHARACTER" }
open (1, form='') ! { dg-error "FORM specifier in OPEN statement at ... has invalid value" }
open (1, form='no') ! { dg-error "FORM specifier in OPEN statement at ... has invalid value" }
open (1, form=null()) ! { dg-error "FORM tag at ... must be of type CHARACTER" }
open (1, form=(1)) ! { dg-error "FORM tag at ... must be of type CHARACTER" }
open (1, form=(1., 0.)) ! { dg-error "FORM tag at ... must be of type CHARACTER" }
open (1, form=[1]) ! { dg-error "FORM tag at ... must be of type CHARACTER" }
open (1, form=['']) ! { dg-error "FORM tag at ... must be scalar" }
open (1, iomsg=1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
open (1, iomsg=1e1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
open (1, iomsg=1d1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
open (1, iomsg=.false.) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
open (1, iomsg='') ! { dg-error "Non-variable expression" }
open (1, iomsg='no') ! { dg-error "Non-variable expression" }
open (1, iomsg=null()) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
open (1, iomsg=(1)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
open (1, iomsg=(1., 0.)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
open (1, iomsg=[1]) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
open (1, iomsg=['']) ! { dg-error "IOMSG tag at ... must be scalar" }
open (1, pad=1) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
open (1, pad=1e1) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
open (1, pad=1d1) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
open (1, pad=.false.) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
open (1, pad='') ! { dg-error "PAD specifier in OPEN statement at ... has invalid value" }
open (1, pad='no')
open (1, pad=null()) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
open (1, pad=(1)) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
open (1, pad=(1., 0.)) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
open (1, pad=[1]) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
open (1, pad=['']) ! { dg-error "PAD tag at ... must be scalar" }
open (1, position=1) ! { dg-error "POSITION tag at ... must be of type CHARACTER" }
open (1, position=1e1) ! { dg-error "POSITION tag at ... must be of type CHARACTER" }
open (1, position=1d1) ! { dg-error "POSITION tag at ... must be of type CHARACTER" }
open (1, position=.false.) ! { dg-error "POSITION tag at ... must be of type CHARACTER" }
open (1, position='') ! { dg-error "POSITION specifier in OPEN statement at ... has invalid value" }
open (1, position='no') ! { dg-error "POSITION specifier in OPEN statement at ... has invalid value" }
open (1, position=null()) ! { dg-error "POSITION tag at ... must be of type CHARACTER" }
open (1, position=(1)) ! { dg-error "POSITION tag at ... must be of type CHARACTER" }
open (1, position=(1., 0.)) ! { dg-error "POSITION tag at ... must be of type CHARACTER" }
open (1, position=[1]) ! { dg-error "POSITION tag at ... must be of type CHARACTER" }
open (1, position=['']) ! { dg-error "POSITION tag at ... must be scalar" }
open (1, round=1) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
open (1, round=1e1) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
open (1, round=1d1) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
open (1, round=.false.) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
open (1, round='') ! { dg-error "ROUND specifier in OPEN statement at ... has invalid value" }
open (1, round='no') ! { dg-error "ROUND specifier in OPEN statement at ... has invalid value" }
open (1, round=null()) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
open (1, round=(1)) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
open (1, round=(1., 0.)) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
open (1, round=[1]) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
open (1, round=['']) ! { dg-error "ROUND tag at ... must be scalar" }
open (1, sign=1) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
open (1, sign=1e1) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
open (1, sign=1d1) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
open (1, sign=.false.) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
open (1, sign='') ! { dg-error "SIGN specifier in OPEN statement at ... has invalid value" }
open (1, sign='no') ! { dg-error "SIGN specifier in OPEN statement at ... has invalid value" }
open (1, sign=null()) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
open (1, sign=(1)) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
open (1, sign=(1., 0.)) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
open (1, sign=[1]) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
open (1, sign=['']) ! { dg-error "SIGN tag at ... must be scalar" }
open (1, status=1) ! { dg-error "STATUS tag at ... must be of type CHARACTER" }
open (1, status=1e1) ! { dg-error "STATUS tag at ... must be of type CHARACTER" }
open (1, status=1d1) ! { dg-error "STATUS tag at ... must be of type CHARACTER" }
open (1, status=.false.) ! { dg-error "STATUS tag at ... must be of type CHARACTER" }
open (1, status='') ! { dg-error "STATUS specifier in OPEN statement at ... has invalid value" }
open (1, status='no') ! { dg-error "STATUS specifier in OPEN statement at ... has invalid value" }
open (1, status=null()) ! { dg-error "STATUS tag at ... must be of type CHARACTER" }
open (1, status=(1)) ! { dg-error "STATUS tag at ... must be of type CHARACTER" }
open (1, status=(1., 0.)) ! { dg-error "STATUS tag at ... must be of type CHARACTER" }
open (1, status=[1]) ! { dg-error "STATUS tag at ... must be of type CHARACTER" }
open (1, status=['']) ! { dg-error "STATUS tag at ... must be scalar" }
end
gcc/testsuite/gfortran.dg/io_tags_7.f90 0 → 100644
! { dg-do compile }
! { dg-options "-std=f2003" }
! Based on PR fortran/66724, also covers fortran/66725 and fortran/87923.
!
read (1, asynchronous=1) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
read (1, asynchronous=1e1) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
read (1, asynchronous=1d1) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
read (1, asynchronous=.false.) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
read (1, asynchronous='') ! { dg-error "ASYNCHRONOUS specifier in READ statement at ... has invalid value" }
read (1, asynchronous='no')
read (1, asynchronous=null()) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
read (1, asynchronous=(1)) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
read (1, asynchronous=(1., 0.)) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
read (1, asynchronous=[1]) ! { dg-error "ASYNCHRONOUS tag at ... must be of type CHARACTER" }
read (1, asynchronous=['']) ! { dg-error "ASYNCHRONOUS tag at ... must be scalar" }
read (1, blank=1) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
read (1, blank=1e1) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
read (1, blank=1d1) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
read (1, blank=.false.) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
read (1, blank='') ! { dg-error "BLANK specifier in READ statement at ... has invalid value" }
read (1, blank='no') ! { dg-error "BLANK specifier in READ statement at ... has invalid value" }
read (1, blank=null()) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
read (1, blank=(1)) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
read (1, blank=(1., 0.)) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
read (1, blank=[1]) ! { dg-error "BLANK tag at ... must be of type CHARACTER" }
read (1, blank=['']) ! { dg-error "BLANK tag at ... must be scalar" }
read (1, delim=1) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
read (1, delim=1e1) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
read (1, delim=1d1) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
read (1, delim=.false.) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
read (1, delim='') ! { dg-error "DELIM specifier in READ statement at ... has invalid value" }
read (1, delim='no') ! { dg-error "DELIM specifier in READ statement at ... has invalid value" }
read (1, delim=null()) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
read (1, delim=(1)) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
read (1, delim=(1., 0.)) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
read (1, delim=[1]) ! { dg-error "DELIM tag at ... must be of type CHARACTER" }
read (1, delim=['']) ! { dg-error "DELIM tag at ... must be scalar" }
read (1, decimal=1) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
read (1, decimal=1e1) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
read (1, decimal=1d1) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
read (1, decimal=.false.) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
read (1, decimal='') ! { dg-error "DECIMAL specifier in READ statement at ... has invalid value" }
read (1, decimal='no') ! { dg-error "DECIMAL specifier in READ statement at ... has invalid value" }
read (1, decimal=null()) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
read (1, decimal=(1)) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
read (1, decimal=(1., 0.)) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
read (1, decimal=[1]) ! { dg-error "DECIMAL tag at ... must be of type CHARACTER" }
read (1, decimal=['']) ! { dg-error "DECIMAL tag at ... must be scalar" }
read (1, iomsg=1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
read (1, iomsg=1e1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
read (1, iomsg=1d1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
read (1, iomsg=.false.) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
read (1, iomsg='') ! { dg-error "Non-variable expression" }
read (1, iomsg='no') ! { dg-error "Non-variable expression" }
read (1, iomsg=null()) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
read (1, iomsg=(1)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
read (1, iomsg=(1., 0.)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
read (1, iomsg=[1]) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
read (1, iomsg=['']) ! { dg-error "IOMSG tag at ... must be scalar" }
read (1, pad=1) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
read (1, pad=1e1) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
read (1, pad=1d1) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
read (1, pad=.false.) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
read (1, pad='') ! { dg-error "PAD specifier in READ statement at ... has invalid value" }
read (1, pad='no') ! { dg-error "the PAD= specifier at ... must be with an explicit format expression" }
read (1, pad=null()) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
read (1, pad=(1)) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
read (1, pad=(1., 0.)) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
read (1, pad=[1]) ! { dg-error "PAD tag at ... must be of type CHARACTER" }
read (1, pad=['']) ! { dg-error "PAD tag at ... must be scalar" }
read (1, round=1) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
read (1, round=1e1) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
read (1, round=1d1) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
read (1, round=.false.) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
read (1, round='') ! { dg-error "ROUND specifier in READ statement at ... has invalid value" }
read (1, round='no') ! { dg-error "ROUND specifier in READ statement at ... has invalid value" }
read (1, round=null()) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
read (1, round=(1)) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
read (1, round=(1., 0.)) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
read (1, round=[1]) ! { dg-error "ROUND tag at ... must be of type CHARACTER" }
read (1, round=['']) ! { dg-error "ROUND tag at ... must be scalar" }
read (1, sign=1) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
read (1, sign=1e1) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
read (1, sign=1d1) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
read (1, sign=.false.) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
read (1, sign='') ! { dg-error "SIGN specifier in READ statement at ... has invalid value" }
read (1, sign='no') ! { dg-error "SIGN specifier in READ statement at ... has invalid value" }
read (1, sign=null()) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
read (1, sign=(1)) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
read (1, sign=(1., 0.)) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
read (1, sign=[1]) ! { dg-error "SIGN tag at ... must be of type CHARACTER" }
read (1, sign=['']) ! { dg-error "SIGN tag at ... must be scalar" }
end
gcc/testsuite/gfortran.dg/io_tags_8.f90 0 → 100644
! { dg-do compile }
! { dg-options "-std=f2003" }
! Based on PR fortran/66724, also covers fortran/66725 and fortran/87923.
!
rewind (1, iomsg=1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
rewind (1, iomsg=1e1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
rewind (1, iomsg=1d1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
rewind (1, iomsg=.false.) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
rewind (1, iomsg='') ! { dg-error "Non-variable expression" }
rewind (1, iomsg='no') ! { dg-error "Non-variable expression" }
rewind (1, iomsg=null()) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
rewind (1, iomsg=(1)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
rewind (1, iomsg=(1., 0.)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
rewind (1, iomsg=[1]) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
rewind (1, iomsg=['']) ! { dg-error "IOMSG tag at ... must be scalar" }
end
gcc/testsuite/gfortran.dg/io_tags_9.f90 0 → 100644
! { dg-do compile }
! { dg-options "-std=f2003" }
! Based on PR fortran/66724, also covers fortran/66725 and fortran/87923.
!
wait (1, iomsg=1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
wait (1, iomsg=1e1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
wait (1, iomsg=1d1) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
wait (1, iomsg=.false.) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
wait (1, iomsg='') ! { dg-error "Non-variable expression" }
wait (1, iomsg='no') ! { dg-error "Non-variable expression" }
wait (1, iomsg=null()) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
wait (1, iomsg=(1)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
wait (1, iomsg=(1., 0.)) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
wait (1, iomsg=[1]) ! { dg-error "IOMSG tag at ... must be of type CHARACTER" }
wait (1, iomsg=['']) ! { dg-error "IOMSG tag at ... must be scalar" }
end
gcc/testsuite/gfortran.dg/iomsg_2.f90
...@@ -2,30 +2,30 @@ ...@@ -2,30 +2,30 @@
subroutine foo1 subroutine foo1
implicit none implicit none
integer i integer i
open(1, iomsg=666) ! { dg-error "IOMSG must be" } open(1, iomsg=666) ! { dg-error "must be of type CHARACTER" }
open(1, iomsg='sgk') ! { dg-error "IOMSG must be" } open(1, iomsg='sgk') ! { dg-error "Non-variable expression" }
open(1, iomsg=i) ! { dg-error "IOMSG must be" } open(1, iomsg=i) ! { dg-error "must be of type CHARACTER" }
close(1, iomsg=666) ! { dg-error "IOMSG must be" } close(1, iomsg=666) ! { dg-error "must be of type CHARACTER" }
close(1, iomsg='sgk') ! { dg-error "IOMSG must be" } close(1, iomsg='sgk') ! { dg-error "Non-variable expression" }
close(1, iomsg=i) ! { dg-error "IOMSG must be" } close(1, iomsg=i) ! { dg-error "must be of type CHARACTER" }
end subroutine foo1 end subroutine foo1
subroutine foo subroutine foo
implicit none implicit none
integer i integer i
real :: x = 1 real :: x = 1
write(1, *, iomsg='sgk') x ! { dg-error "IOMSG must be" } write(1, *, iomsg='sgk') x ! { dg-error "Non-variable expression" }
write(1, *, iomsg=i) x ! { dg-error "IOMSG must be" } write(1, *, iomsg=i) x ! { dg-error "must be of type CHARACTER" }
read(1, *, iomsg='sgk') x ! { dg-error "IOMSG must be" } read(1, *, iomsg='sgk') x ! { dg-error "Non-variable expression" }
read(1, *, iomsg=i) x ! { dg-error "IOMSG must be" } read(1, *, iomsg=i) x ! { dg-error "must be of type CHARACTER" }
flush(1, iomsg='sgk') ! { dg-error "IOMSG must be" } flush(1, iomsg='sgk') ! { dg-error "Non-variable expression" }
flush(1, iomsg=i) ! { dg-error "IOMSG must be" } flush(1, iomsg=i) ! { dg-error "must be of type CHARACTER" }
rewind(1, iomsg='sgk') ! { dg-error "IOMSG must be" } rewind(1, iomsg='sgk') ! { dg-error "Non-variable expression" }
rewind(1, iomsg=i) ! { dg-error "IOMSG must be" } rewind(1, iomsg=i) ! { dg-error "must be of type CHARACTER" }
backspace(1,iomsg='sgk') ! { dg-error "IOMSG must be" } backspace(1,iomsg='sgk') ! { dg-error "Non-variable expression" }
backspace(1,iomsg=i) ! { dg-error "IOMSG must be" } backspace(1,iomsg=i) ! { dg-error "must be of type CHARACTER" }
wait(1, iomsg='sgk') ! { dg-error "IOMSG must be" } wait(1, iomsg='sgk') ! { dg-error "Non-variable expression" }
wait(1, iomsg=i) ! { dg-error "IOMSG must be" } wait(1, iomsg=i) ! { dg-error "must be of type CHARACTER" }
end subroutine foo end subroutine foo
subroutine bar subroutine bar
......
gcc/testsuite/gfortran.dg/pr66725.f90
...@@ -3,29 +3,29 @@ ...@@ -3,29 +3,29 @@
! !
program foo program foo
open(unit=1,access = 999) ! { dg-error "ACCESS requires" } open(unit=1,access = 999) ! { dg-error "must be of type CHARACTER" }
open(unit=1,action = 999) ! { dg-error "ACTION requires" } open(unit=1,action = 999) ! { dg-error "must be of type CHARACTER" }
open(unit=1,asynchronous = 999) ! { dg-error "ASYNCHRONOUS requires" } open(unit=1,asynchronous = 999) ! { dg-error "must be of type CHARACTER" }
open(unit=1,blank = 999) ! { dg-error "BLANK requires" } open(unit=1,blank = 999) ! { dg-error "must be of type CHARACTER" }
open(unit=1,decimal = 999) ! { dg-error "DECIMAL requires" } open(unit=1,decimal = 999) ! { dg-error "must be of type CHARACTER" }
open(unit=1,delim = 999) ! { dg-error "DELIM requires" } open(unit=1,delim = 999) ! { dg-error "must be of type CHARACTER" }
open(unit=1,encoding = 999) ! { dg-error "ENCODING requires" } open(unit=1,encoding = 999) ! { dg-error "must be of type CHARACTER" }
open(unit=1,form = 999) ! { dg-error "FORM requires" } open(unit=1,form = 999) ! { dg-error "must be of type CHARACTER" }
open(unit=1,pad = 999) ! { dg-error "PAD requires" } open(unit=1,pad = 999) ! { dg-error "must be of type CHARACTER" }
open(unit=1,position = 999) ! { dg-error "POSITION requires" } open(unit=1,position = 999) ! { dg-error "must be of type CHARACTER" }
open(unit=1,round = 999) ! { dg-error "ROUND requires" } open(unit=1,round = 999) ! { dg-error "must be of type CHARACTER" }
open(unit=1,sign = 999) ! { dg-error "SIGN requires" } open(unit=1,sign = 999) ! { dg-error "must be of type CHARACTER" }
open(unit=1,status = 999) ! { dg-error "STATUS requires" } open(unit=1,status = 999) ! { dg-error "must be of type CHARACTER" }
close(unit=1, status=999) ! { dg-error "STATUS requires" } close(unit=1, status=999) ! { dg-error "must be of type CHARACTER" }
write (unit=1, asynchronous=257) ! { dg-error "ASYNCHRONOUS requires" } write (unit=1, asynchronous=257) ! { dg-error "must be of type CHARACTER" }
write (unit=1, delim=257) ! { dg-error "DELIM requires" } write (unit=1, delim=257) ! { dg-error "must be of type CHARACTER" }
write (unit=1, decimal=257) ! { dg-error "DECIMAL requires" } write (unit=1, decimal=257) ! { dg-error "must be of type CHARACTER" }
write (unit=1, round=257) ! { dg-error "ROUND requires" } write (unit=1, round=257) ! { dg-error "must be of type CHARACTER" }
write (unit=1, sign=257) ! { dg-error "SIGN requires" } write (unit=1, sign=257) ! { dg-error "must be of type CHARACTER" }
write (unit=1, blank=257) ! { dg-error "BLANK requires" } write (unit=1, blank=257) ! { dg-error "must be of type CHARACTER" }
write (unit=1, pad=257) ! { dg-error "PAD requires" } write (unit=1, pad=257) ! { dg-error "must be of type CHARACTER" }
end program foo end program foo
gcc/testsuite/gfortran.dg/pr88205.f90
...@@ -2,13 +2,13 @@ ...@@ -2,13 +2,13 @@
! PR fortran/88205 ! PR fortran/88205
subroutine s1 subroutine s1
real, parameter :: status = 0 real, parameter :: status = 0
open (newunit=n, status=status) ! { dg-error "STATUS requires" } open (newunit=n, status=status) ! { dg-error "must be of type CHARACTER" }
end end
subroutine s2 subroutine s2
complex, parameter :: status = 0 complex, parameter :: status = 0
open (newunit=n, status=status) ! { dg-error "STATUS requires" } open (newunit=n, status=status) ! { dg-error "must be of type CHARACTER" }
end end
program p program p
logical, parameter :: status = .false. logical, parameter :: status = .false.
open (newunit=a, status=status) ! { dg-error "STATUS requires" } open (newunit=a, status=status) ! { dg-error "must be of type CHARACTER" }
end end
gcc/testsuite/gfortran.dg/write_check4.f90
...@@ -11,7 +11,7 @@ ...@@ -11,7 +11,7 @@
no = "no" no = "no"
open (unit=10, asynchronous = no) ! Ok, it isn't a transfer stmt open (unit=10, asynchronous = no) ! Ok, it isn't a transfer stmt
write(*,*, asynchronous="Y"//"E"//trim("S ")) ! Ok, it is an init expr write(*,*, asynchronous="Y"//"E"//trim("S ")) ! Ok, it is an init expr
write(*,*, asynchronous=no) ! { dg-error "must be an initialization expression" } write(*,*, asynchronous=no) ! { dg-error "does not reduce to a constant expression" }
read (*,*, asynchronous="Y"//"e"//trim("S ")) read (*,*, asynchronous="Y"//"e"//trim("S "))
read (*,*, asynchronous=no) ! { dg-error "must be an initialization expression" } read (*,*, asynchronous=no) ! { dg-error "does not reduce to a constant expression" }
end end
gcc/testsuite/gfortran.dg/write_check5.f90 0 → 100644
! { dg-do compile }
!
! The asynchronous specifier for a data transfer statement shall be
! an initialization expression
!
module write_check5
contains
function no()
implicit none
character(3) :: no
no = "yes"
endfunction
end module
use write_check5
implicit none
open (unit=10, asynchronous=no()) ! Ok, it isn't a transfer stmt
write(*,*, asynchronous=no()) ! { dg-error "must be an intrinsic function" }
read (*,*, asynchronous=no()) ! { dg-error "must be an intrinsic function" }
end
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment