diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 88e4d9236f3..f830e7cecc7 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3468,18 +3468,17 @@ bool gfc_compare_actual_formal (gfc_actual_arglist **, gfc_formal_arglist *, extern gfc_st_label format_asterisk; void gfc_free_open (gfc_open *); -bool gfc_resolve_open (gfc_open *); +bool gfc_resolve_open (gfc_open *, locus *); void gfc_free_close (gfc_close *); -bool gfc_resolve_close (gfc_close *); +bool gfc_resolve_close (gfc_close *, locus *); void gfc_free_filepos (gfc_filepos *); bool gfc_resolve_filepos (gfc_filepos *, locus *); void gfc_free_inquire (gfc_inquire *); bool gfc_resolve_inquire (gfc_inquire *); void gfc_free_dt (gfc_dt *); -bool gfc_resolve_dt (gfc_dt *, locus *); +bool gfc_resolve_dt (gfc_code *, gfc_dt *, locus *); void gfc_free_wait (gfc_wait *); bool gfc_resolve_wait (gfc_wait *); -extern bool async_io_dt; /* module.c */ void gfc_module_init_2 (void); diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 59cd9cee3f0..d0310a63df1 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -112,10 +112,6 @@ static gfc_dt *current_dt; #define RESOLVE_TAG(x, y) if (!resolve_tag (x, y)) return false; -/* Are we currently processing an asynchronous I/O statement? */ - -bool async_io_dt; - /**************** Fortran 95 FORMAT parser *****************/ /* FORMAT tokens returned by format_lex(). */ @@ -1427,36 +1423,6 @@ gfc_match_format (void) } -/* Check for a CHARACTER variable. The check for scalar is done in - resolve_tag. */ - -static bool -check_char_variable (gfc_expr *e) -{ - if (e->expr_type != EXPR_VARIABLE || e->ts.type != BT_CHARACTER) - { - gfc_error("IOMSG must be a scalar-default-char-variable at %L", &e->where); - return false; - } - return true; -} - - -static bool -is_char_type (const char *name, gfc_expr *e) -{ - gfc_resolve_expr (e); - - if (e->ts.type != BT_CHARACTER) - { - gfc_error ("%s requires a scalar-default-char-expr at %L", - name, &e->where); - return false; - } - return true; -} - - /* Match an expression I/O tag of some sort. */ static match @@ -1725,7 +1691,8 @@ resolve_tag_format (gfc_expr *e) if (e->value.constructor == NULL) { - gfc_error ("FORMAT tag at %C cannot be a zero-sized array"); + gfc_error ("FORMAT tag at %L cannot be a zero-sized array", + &e->where); return false; } @@ -1919,16 +1886,12 @@ match_open_element (gfc_open *open) match m; m = match_etag (&tag_e_async, &open->asynchronous); - if (m == MATCH_YES && !is_char_type ("ASYNCHRONOUS", open->asynchronous)) - return MATCH_ERROR; if (m != MATCH_NO) return m; m = match_etag (&tag_unit, &open->unit); if (m != MATCH_NO) return m; m = match_etag (&tag_iomsg, &open->iomsg); - if (m == MATCH_YES && !check_char_variable (open->iomsg)) - return MATCH_ERROR; if (m != MATCH_NO) return m; m = match_out_tag (&tag_iostat, &open->iostat); @@ -2041,12 +2004,22 @@ gfc_free_open (gfc_open *open) } +static int +compare_to_allowed_values (const char *specifier, const char *allowed[], + const char *allowed_f2003[], + const char *allowed_gnu[], gfc_char_t *value, + const char *statement, bool warn, locus *where, + int *num = NULL); + + +static bool +check_open_constraints (gfc_open *open, locus *where); + /* Resolve everything in a gfc_open structure. */ bool -gfc_resolve_open (gfc_open *open) +gfc_resolve_open (gfc_open *open, locus *where) { - RESOLVE_TAG (&tag_unit, open->unit); RESOLVE_TAG (&tag_iomsg, open->iomsg); RESOLVE_TAG (&tag_iostat, open->iostat); @@ -2073,7 +2046,7 @@ gfc_resolve_open (gfc_open *open) if (!gfc_reference_st_label (open->err, ST_LABEL_TARGET)) return false; - return true; + return check_open_constraints (open, where); } @@ -2081,19 +2054,13 @@ gfc_resolve_open (gfc_open *open) allowed in F95 or F2003, issuing an error message and returning a zero value if it is not allowed. */ -static int -compare_to_allowed_values (const char *specifier, const char *allowed[], - const char *allowed_f2003[], - const char *allowed_gnu[], gfc_char_t *value, - const char *statement, bool warn, - int *num = NULL); - static int compare_to_allowed_values (const char *specifier, const char *allowed[], - const char *allowed_f2003[], + const char *allowed_f2003[], const char *allowed_gnu[], gfc_char_t *value, - const char *statement, bool warn, int *num) + const char *statement, bool warn, locus *where, + int *num) { int i; unsigned int len; @@ -2116,6 +2083,9 @@ compare_to_allowed_values (const char *specifier, const char *allowed[], return 1; } + if (!where) + where = &gfc_current_locus; + for (i = 0; allowed_f2003 && allowed_f2003[i]; i++) if (len == strlen (allowed_f2003[i]) && gfc_wide_strncasecmp (value, allowed_f2003[i], @@ -2125,8 +2095,8 @@ compare_to_allowed_values (const char *specifier, const char *allowed[], if (n == WARNING || (warn && n == ERROR)) { - gfc_warning (0, "Fortran 2003: %s specifier in %s statement at %C " - "has value %qs", specifier, statement, + gfc_warning (0, "Fortran 2003: %s specifier in %s statement at %L " + "has value %qs", specifier, statement, where, allowed_f2003[i]); return 1; } @@ -2134,8 +2104,8 @@ compare_to_allowed_values (const char *specifier, const char *allowed[], if (n == ERROR) { gfc_notify_std (GFC_STD_F2003, "%s specifier in " - "%s statement at %C has value %qs", specifier, - statement, allowed_f2003[i]); + "%s statement at %L has value %qs", specifier, + statement, where, allowed_f2003[i]); return 0; } @@ -2152,8 +2122,8 @@ compare_to_allowed_values (const char *specifier, const char *allowed[], if (n == WARNING || (warn && n == ERROR)) { - gfc_warning (0, "Extension: %s specifier in %s statement at %C " - "has value %qs", specifier, statement, + gfc_warning (0, "Extension: %s specifier in %s statement at %L " + "has value %qs", specifier, statement, where, allowed_gnu[i]); return 1; } @@ -2161,8 +2131,8 @@ compare_to_allowed_values (const char *specifier, const char *allowed[], if (n == ERROR) { gfc_notify_std (GFC_STD_GNU, "%s specifier in " - "%s statement at %C has value %qs", specifier, - statement, allowed_gnu[i]); + "%s statement at %L has value %qs", specifier, + statement, where, allowed_gnu[i]); return 0; } @@ -2174,74 +2144,42 @@ compare_to_allowed_values (const char *specifier, const char *allowed[], { char *s = gfc_widechar_to_char (value, -1); gfc_warning (0, - "%s specifier in %s statement at %C has invalid value %qs", - specifier, statement, s); + "%s specifier in %s statement at %L has invalid value %qs", + specifier, statement, where, s); free (s); return 1; } else { char *s = gfc_widechar_to_char (value, -1); - gfc_error ("%s specifier in %s statement at %C has invalid value %qs", - specifier, statement, s); + gfc_error ("%s specifier in %s statement at %L has invalid value %qs", + specifier, statement, where, s); free (s); return 0; } } -/* Match an OPEN statement. */ +/* Check constraints on the OPEN statement. + Similar to check_io_constraints for data transfer statements. + At this point all tags have already been resolved via resolve_tag, which, + among other things, verifies that BT_CHARACTER tags are of default kind. */ -match -gfc_match_open (void) +static bool +check_open_constraints (gfc_open *open, locus *where) { - gfc_open *open; - match m; - bool warn; - - m = gfc_match_char ('('); - if (m == MATCH_NO) - return m; - - open = XCNEW (gfc_open); - - m = match_open_element (open); - - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - { - m = gfc_match_expr (&open->unit); - if (m == MATCH_ERROR) - goto cleanup; - } - - for (;;) - { - if (gfc_match_char (')') == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - - m = match_open_element (open); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - } - - if (gfc_match_eos () == MATCH_NO) - goto syntax; - - if (gfc_pure (NULL)) - { - gfc_error ("OPEN statement not allowed in PURE procedure at %C"); - goto cleanup; - } - - gfc_unset_implicit_pure (NULL); +#define warn_or_error(...) \ +{ \ + if (warn) \ + gfc_warning (0, __VA_ARGS__); \ + else \ + { \ + gfc_error (__VA_ARGS__); \ + return false; \ + } \ +} - warn = (open->err || open->iostat) ? true : false; + bool warn = (open->err || open->iostat) ? true : false; /* Checks on the ACCESS specifier. */ if (open->access && open->access->expr_type == EXPR_CONSTANT) @@ -2250,14 +2188,11 @@ gfc_match_open (void) static const char *access_f2003[] = { "STREAM", NULL }; static const char *access_gnu[] = { "APPEND", NULL }; - if (!is_char_type ("ACCESS", open->access)) - goto cleanup; - if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003, access_gnu, open->access->value.character.string, - "OPEN", warn)) - goto cleanup; + "OPEN", warn, &open->access->where)) + return false; } /* Checks on the ACTION specifier. */ @@ -2266,21 +2201,20 @@ gfc_match_open (void) gfc_char_t *str = open->action->value.character.string; static const char *action[] = { "READ", "WRITE", "READWRITE", NULL }; - if (!is_char_type ("ACTION", open->action)) - goto cleanup; - if (!compare_to_allowed_values ("ACTION", action, NULL, NULL, - str, "OPEN", warn)) - goto cleanup; + str, "OPEN", warn, &open->action->where)) + return false; /* With READONLY, only allow ACTION='READ'. */ if (open->readonly && (gfc_wide_strlen (str) != 4 || gfc_wide_strncasecmp (str, "READ", 4) != 0)) { - gfc_error ("ACTION type conflicts with READONLY specifier at %C"); - goto cleanup; + gfc_error ("ACTION type conflicts with READONLY specifier at %L", + &open->action->where); + return false; } } + /* If we see READONLY and no ACTION, set ACTION='READ'. */ else if (open->readonly && open->action == NULL) { @@ -2291,27 +2225,10 @@ gfc_match_open (void) /* Checks on the ASYNCHRONOUS specifier. */ if (open->asynchronous) { - if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS= at %C " - "not allowed in Fortran 95")) - goto cleanup; - - if (!is_char_type ("ASYNCHRONOUS", open->asynchronous)) - goto cleanup; - - if (open->asynchronous->ts.kind != 1) - { - gfc_error ("ASYNCHRONOUS= specifier at %L must be of default " - "CHARACTER kind", &open->asynchronous->where); - return MATCH_ERROR; - } - - if (open->asynchronous->expr_type == EXPR_ARRAY - || open->asynchronous->expr_type == EXPR_STRUCTURE) - { - gfc_error ("ASYNCHRONOUS= specifier at %L must be scalar", - &open->asynchronous->where); - return MATCH_ERROR; - } + if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS= at %L " + "not allowed in Fortran 95", + &open->asynchronous->where)) + return false; if (open->asynchronous->expr_type == EXPR_CONSTANT) { @@ -2319,20 +2236,17 @@ gfc_match_open (void) if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous, NULL, NULL, open->asynchronous->value.character.string, - "OPEN", warn)) - goto cleanup; + "OPEN", warn, &open->asynchronous->where)) + return false; } } /* Checks on the BLANK specifier. */ if (open->blank) { - if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %C " - "not allowed in Fortran 95")) - goto cleanup; - - if (!is_char_type ("BLANK", open->blank)) - goto cleanup; + if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %L " + "not allowed in Fortran 95", &open->blank->where)) + return false; if (open->blank->expr_type == EXPR_CONSTANT) { @@ -2340,36 +2254,27 @@ gfc_match_open (void) if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL, open->blank->value.character.string, - "OPEN", warn)) - goto cleanup; + "OPEN", warn, &open->blank->where)) + return false; } } /* Checks on the CARRIAGECONTROL specifier. */ - if (open->cc) + if (open->cc && open->cc->expr_type == EXPR_CONSTANT) { - if (!is_char_type ("CARRIAGECONTROL", open->cc)) - goto cleanup; - - if (open->cc->expr_type == EXPR_CONSTANT) - { - static const char *cc[] = { "LIST", "FORTRAN", "NONE", NULL }; - if (!compare_to_allowed_values ("CARRIAGECONTROL", cc, NULL, NULL, - open->cc->value.character.string, - "OPEN", warn)) - goto cleanup; - } + static const char *cc[] = { "LIST", "FORTRAN", "NONE", NULL }; + if (!compare_to_allowed_values ("CARRIAGECONTROL", cc, NULL, NULL, + open->cc->value.character.string, + "OPEN", warn, &open->cc->where)) + return false; } /* Checks on the DECIMAL specifier. */ if (open->decimal) { - if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C " - "not allowed in Fortran 95")) - goto cleanup; - - if (!is_char_type ("DECIMAL", open->decimal)) - goto cleanup; + if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %L " + "not allowed in Fortran 95", &open->decimal->where)) + return false; if (open->decimal->expr_type == EXPR_CONSTANT) { @@ -2377,8 +2282,8 @@ gfc_match_open (void) if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL, open->decimal->value.character.string, - "OPEN", warn)) - goto cleanup; + "OPEN", warn, &open->decimal->where)) + return false; } } @@ -2389,25 +2294,19 @@ gfc_match_open (void) { static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL }; - if (!is_char_type ("DELIM", open->delim)) - goto cleanup; - if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL, open->delim->value.character.string, - "OPEN", warn)) - goto cleanup; + "OPEN", warn, &open->delim->where)) + return false; } } /* Checks on the ENCODING specifier. */ if (open->encoding) { - if (!gfc_notify_std (GFC_STD_F2003, "ENCODING= at %C " - "not allowed in Fortran 95")) - goto cleanup; - - if (!is_char_type ("ENCODING", open->encoding)) - goto cleanup; + if (!gfc_notify_std (GFC_STD_F2003, "ENCODING= at %L " + "not allowed in Fortran 95", &open->encoding->where)) + return false; if (open->encoding->expr_type == EXPR_CONSTANT) { @@ -2415,8 +2314,8 @@ gfc_match_open (void) if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL, open->encoding->value.character.string, - "OPEN", warn)) - goto cleanup; + "OPEN", warn, &open->encoding->where)) + return false; } } @@ -2425,13 +2324,10 @@ gfc_match_open (void) { static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL }; - if (!is_char_type ("FORM", open->form)) - goto cleanup; - if (!compare_to_allowed_values ("FORM", form, NULL, NULL, open->form->value.character.string, - "OPEN", warn)) - goto cleanup; + "OPEN", warn, &open->form->where)) + return false; } /* Checks on the PAD specifier. */ @@ -2439,13 +2335,10 @@ gfc_match_open (void) { static const char *pad[] = { "YES", "NO", NULL }; - if (!is_char_type ("PAD", open->pad)) - goto cleanup; - if (!compare_to_allowed_values ("PAD", pad, NULL, NULL, open->pad->value.character.string, - "OPEN", warn)) - goto cleanup; + "OPEN", warn, &open->pad->where)) + return false; } /* Checks on the POSITION specifier. */ @@ -2453,24 +2346,18 @@ gfc_match_open (void) { static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL }; - if (!is_char_type ("POSITION", open->position)) - goto cleanup; - if (!compare_to_allowed_values ("POSITION", position, NULL, NULL, open->position->value.character.string, - "OPEN", warn)) - goto cleanup; + "OPEN", warn, &open->position->where)) + return false; } /* Checks on the ROUND specifier. */ if (open->round) { - if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %C " - "not allowed in Fortran 95")) - goto cleanup; - - if (!is_char_type ("ROUND", open->round)) - goto cleanup; + if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %L " + "not allowed in Fortran 95", &open->round->where)) + return false; if (open->round->expr_type == EXPR_CONSTANT) { @@ -2480,36 +2367,27 @@ gfc_match_open (void) if (!compare_to_allowed_values ("ROUND", round, NULL, NULL, open->round->value.character.string, - "OPEN", warn)) - goto cleanup; + "OPEN", warn, &open->round->where)) + return false; } } /* Checks on the SHARE specifier. */ - if (open->share) + if (open->share && open->share->expr_type == EXPR_CONSTANT) { - if (!is_char_type ("SHARE", open->share)) - goto cleanup; - - if (open->share->expr_type == EXPR_CONSTANT) - { - static const char *share[] = { "DENYNONE", "DENYRW", NULL }; - if (!compare_to_allowed_values ("SHARE", share, NULL, NULL, - open->share->value.character.string, - "OPEN", warn)) - goto cleanup; - } + static const char *share[] = { "DENYNONE", "DENYRW", NULL }; + if (!compare_to_allowed_values ("SHARE", share, NULL, NULL, + open->share->value.character.string, + "OPEN", warn, &open->share->where)) + return false; } /* Checks on the SIGN specifier. */ - if (open->sign) + if (open->sign) { - if (!gfc_notify_std (GFC_STD_F2003, "SIGN= at %C " - "not allowed in Fortran 95")) - goto cleanup; - - if (!is_char_type ("SIGN", open->sign)) - goto cleanup; + if (!gfc_notify_std (GFC_STD_F2003, "SIGN= at %L " + "not allowed in Fortran 95", &open->sign->where)) + return false; if (open->sign->expr_type == EXPR_CONSTANT) { @@ -2518,28 +2396,18 @@ gfc_match_open (void) if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL, open->sign->value.character.string, - "OPEN", warn)) - goto cleanup; + "OPEN", warn, &open->sign->where)) + return false; } } -#define warn_or_error(...) \ -{ \ - if (warn) \ - gfc_warning (0, __VA_ARGS__); \ - else \ - { \ - gfc_error (__VA_ARGS__); \ - goto cleanup; \ - } \ -} - /* Checks on the RECL specifier. */ if (open->recl && open->recl->expr_type == EXPR_CONSTANT && open->recl->ts.type == BT_INTEGER && mpz_sgn (open->recl->value.integer) != 1) { - warn_or_error ("RECL in OPEN statement at %C must be positive"); + warn_or_error ("RECL in OPEN statement at %L must be positive", + &open->recl->where); } /* Checks on the STATUS specifier. */ @@ -2548,13 +2416,10 @@ gfc_match_open (void) static const char *status[] = { "OLD", "NEW", "SCRATCH", "REPLACE", "UNKNOWN", NULL }; - if (!is_char_type ("STATUS", open->status)) - goto cleanup; - if (!compare_to_allowed_values ("STATUS", status, NULL, NULL, open->status->value.character.string, - "OPEN", warn)) - goto cleanup; + "OPEN", warn, &open->status->where)) + return false; /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE, the FILE= specifier shall appear. */ @@ -2566,8 +2431,9 @@ gfc_match_open (void) { char *s = gfc_widechar_to_char (open->status->value.character.string, -1); - warn_or_error ("The STATUS specified in OPEN statement at %C is " - "%qs and no FILE specifier is present", s); + warn_or_error ("The STATUS specified in OPEN statement at %L is " + "%qs and no FILE specifier is present", + &open->status->where, s); free (s); } @@ -2576,9 +2442,9 @@ gfc_match_open (void) if (gfc_wide_strncasecmp (open->status->value.character.string, "scratch", 7) == 0 && open->file) { - warn_or_error ("The STATUS specified in OPEN statement at %C " + warn_or_error ("The STATUS specified in OPEN statement at %L " "cannot have the value SCRATCH if a FILE specifier " - "is present"); + "is present", &open->status->where); } } @@ -2587,8 +2453,9 @@ gfc_match_open (void) { if (open->unit) { - gfc_error ("UNIT specifier not allowed with NEWUNIT at %C"); - goto cleanup; + gfc_error ("UNIT specifier not allowed with NEWUNIT at %L", + &open->newunit->where); + return false; } if (!open->file && @@ -2598,14 +2465,15 @@ gfc_match_open (void) "scratch", 7) != 0))) { gfc_error ("NEWUNIT specifier must have FILE= " - "or STATUS='scratch' at %C"); - goto cleanup; + "or STATUS='scratch' at %L", &open->newunit->where); + return false; } } else if (!open->unit) { - gfc_error ("OPEN statement at %C must have UNIT or NEWUNIT specified"); - goto cleanup; + gfc_error ("OPEN statement at %L must have UNIT or NEWUNIT specified", + where); + return false; } /* Things that are not allowed for unformatted I/O. */ @@ -2615,20 +2483,39 @@ gfc_match_open (void) && gfc_wide_strncasecmp (open->form->value.character.string, "unformatted", 11) == 0) { - const char *spec = (open->delim ? "DELIM " - : (open->pad ? "PAD " : open->blank - ? "BLANK " : "")); + locus *loc; + const char *spec; + if (open->delim) + { + loc = &open->delim->where; + spec = "DELIM "; + } + else if (open->pad) + { + loc = &open->pad->where; + spec = "PAD "; + } + else if (open->blank) + { + loc = &open->blank->where; + spec = "BLANK "; + } + else + { + loc = where; + spec = ""; + } - warn_or_error ("%s specifier at %C not allowed in OPEN statement for " - "unformatted I/O", spec); + warn_or_error ("%s specifier at %L not allowed in OPEN statement for " + "unformatted I/O", spec, loc); } if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT && gfc_wide_strncasecmp (open->access->value.character.string, "stream", 6) == 0) { - warn_or_error ("RECL specifier not allowed in OPEN statement at %C for " - "stream I/O"); + warn_or_error ("RECL specifier not allowed in OPEN statement at %L for " + "stream I/O", &open->recl->where); } if (open->position @@ -2640,11 +2527,64 @@ gfc_match_open (void) || gfc_wide_strncasecmp (open->access->value.character.string, "append", 6) == 0)) { - warn_or_error ("POSITION specifier in OPEN statement at %C only allowed " - "for stream or sequential ACCESS"); + warn_or_error ("POSITION specifier in OPEN statement at %L only allowed " + "for stream or sequential ACCESS", &open->position->where); } + return true; #undef warn_or_error +} + + +/* Match an OPEN statement. */ + +match +gfc_match_open (void) +{ + gfc_open *open; + match m; + + m = gfc_match_char ('('); + if (m == MATCH_NO) + return m; + + open = XCNEW (gfc_open); + + m = match_open_element (open); + + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + m = gfc_match_expr (&open->unit); + if (m == MATCH_ERROR) + goto cleanup; + } + + for (;;) + { + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + m = match_open_element (open); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } + + if (gfc_match_eos () == MATCH_NO) + goto syntax; + + if (gfc_pure (NULL)) + { + gfc_error ("OPEN statement not allowed in PURE procedure at %C"); + goto cleanup; + } + + gfc_unset_implicit_pure (NULL); new_st.op = EXEC_OPEN; new_st.ext.open = open; @@ -2689,8 +2629,6 @@ match_close_element (gfc_close *close) if (m != MATCH_NO) return m; m = match_etag (&tag_iomsg, &close->iomsg); - if (m == MATCH_YES && !check_char_variable (close->iomsg)) - return MATCH_ERROR; if (m != MATCH_NO) return m; m = match_out_tag (&tag_iostat, &close->iostat); @@ -2711,7 +2649,6 @@ gfc_match_close (void) { gfc_close *close; match m; - bool warn; m = gfc_match_char ('('); if (m == MATCH_NO) @@ -2757,22 +2694,6 @@ gfc_match_close (void) gfc_unset_implicit_pure (NULL); - warn = (close->iostat || close->err) ? true : false; - - /* Checks on the STATUS specifier. */ - if (close->status && close->status->expr_type == EXPR_CONSTANT) - { - static const char *status[] = { "KEEP", "DELETE", NULL }; - - if (!is_char_type ("STATUS", close->status)) - goto cleanup; - - if (!compare_to_allowed_values ("STATUS", status, NULL, NULL, - close->status->value.character.string, - "CLOSE", warn)) - goto cleanup; - } - new_st.op = EXEC_CLOSE; new_st.ext.close = close; return MATCH_YES; @@ -2786,34 +2707,14 @@ cleanup: } -/* Resolve everything in a gfc_close structure. */ - -bool -gfc_resolve_close (gfc_close *close) +static bool +check_close_constraints (gfc_close *close, locus *where) { - RESOLVE_TAG (&tag_unit, close->unit); - RESOLVE_TAG (&tag_iomsg, close->iomsg); - RESOLVE_TAG (&tag_iostat, close->iostat); - RESOLVE_TAG (&tag_status, close->status); - - if (!gfc_reference_st_label (close->err, ST_LABEL_TARGET)) - return false; + bool warn = (close->iostat || close->err) ? true : false; if (close->unit == NULL) { - /* Find a locus from one of the arguments to close, when UNIT is - not specified. */ - locus loc = gfc_current_locus; - if (close->status) - loc = close->status->where; - else if (close->iostat) - loc = close->iostat->where; - else if (close->iomsg) - loc = close->iomsg->where; - else if (close->err) - loc = close->err->where; - - gfc_error ("CLOSE statement at %L requires a UNIT number", &loc); + gfc_error ("CLOSE statement at %L requires a UNIT number", where); return false; } @@ -2825,9 +2726,36 @@ gfc_resolve_close (gfc_close *close) &close->unit->where); } + /* Checks on the STATUS specifier. */ + if (close->status && close->status->expr_type == EXPR_CONSTANT) + { + static const char *status[] = { "KEEP", "DELETE", NULL }; + + if (!compare_to_allowed_values ("STATUS", status, NULL, NULL, + close->status->value.character.string, + "CLOSE", warn, &close->status->where)) + return false; + } + return true; } +/* Resolve everything in a gfc_close structure. */ + +bool +gfc_resolve_close (gfc_close *close, locus *where) +{ + RESOLVE_TAG (&tag_unit, close->unit); + RESOLVE_TAG (&tag_iomsg, close->iomsg); + RESOLVE_TAG (&tag_iostat, close->iostat); + RESOLVE_TAG (&tag_status, close->status); + + if (!gfc_reference_st_label (close->err, ST_LABEL_TARGET)) + return false; + + return check_close_constraints (close, where); +} + /* Free a gfc_filepos structure. */ @@ -2852,8 +2780,6 @@ match_file_element (gfc_filepos *fp) if (m != MATCH_NO) return m; m = match_etag (&tag_iomsg, &fp->iomsg); - if (m == MATCH_YES && !check_char_variable (fp->iomsg)) - return MATCH_ERROR; if (m != MATCH_NO) return m; m = match_out_tag (&tag_iostat, &fp->iostat); @@ -3227,8 +3153,6 @@ match_dt_element (io_kind k, gfc_dt *dt) } m = match_etag (&tag_e_async, &dt->asynchronous); - if (m == MATCH_YES && !is_char_type ("ASYNCHRONOUS", dt->asynchronous)) - return MATCH_ERROR; if (m != MATCH_NO) return m; m = match_etag (&tag_e_blank, &dt->blank); @@ -3259,8 +3183,6 @@ match_dt_element (io_kind k, gfc_dt *dt) if (m != MATCH_NO) return m; m = match_etag (&tag_iomsg, &dt->iomsg); - if (m == MATCH_YES && !check_char_variable (dt->iomsg)) - return MATCH_ERROR; if (m != MATCH_NO) return m; @@ -3330,28 +3252,26 @@ gfc_free_dt (gfc_dt *dt) } +static const char * +io_kind_name (io_kind k); + +static bool +check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code, + locus *spec_end); + /* Resolve everything in a gfc_dt structure. */ bool -gfc_resolve_dt (gfc_dt *dt, locus *loc) +gfc_resolve_dt (gfc_code *dt_code, gfc_dt *dt, locus *loc) { gfc_expr *e; io_kind k; - locus tmp; /* This is set in any case. */ gcc_assert (dt->dt_io_kind); k = dt->dt_io_kind->value.iokind; - tmp = gfc_current_locus; - gfc_current_locus = *loc; - if (!resolve_tag (&tag_format, dt->format_expr)) - { - gfc_current_locus = tmp; - return false; - } - gfc_current_locus = tmp; - + RESOLVE_TAG (&tag_format, dt->format_expr); RESOLVE_TAG (&tag_rec, dt->rec); RESOLVE_TAG (&tag_spos, dt->pos); RESOLVE_TAG (&tag_advance, dt->advance); @@ -3367,6 +3287,18 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc) RESOLVE_TAG (&tag_e_decimal, dt->decimal); RESOLVE_TAG (&tag_e_async, dt->asynchronous); + /* Check I/O constraints. + To validate NAMELIST we need to check if we were also given an I/O list, + which is stored in code->block->next with op EXEC_TRANSFER. + Note that the I/O list was already resolved from resolve_transfer. */ + gfc_code *io_code = NULL; + if (dt_code && dt_code->block && dt_code->block->next + && dt_code->block->next->op == EXEC_TRANSFER) + io_code = dt_code->block->next; + + if (!check_io_constraints (k, dt, io_code, loc)) + return false; + e = dt->io_unit; if (e == NULL) { @@ -3821,11 +3753,15 @@ terminate_io (gfc_code *io_code) /* Check the constraints for a data transfer statement. The majority of the - constraints appearing in 9.4 of the standard appear here. Some are handled - in resolve_tag and others in gfc_resolve_dt. Also set the async_io_dt flag - and, if necessary, the asynchronous flag on the SIZE argument. */ + constraints appearing in 9.4 of the standard appear here. -static match + Tag expressions are already resolved by resolve_tag, which includes + verifying the type, that they are scalar, and verifying that BT_CHARACTER + tags are of default kind. + + */ + +static bool check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code, locus *spec_end) { @@ -3835,11 +3771,10 @@ if (condition) \ if ((arg)->lb != NULL)\ gfc_error ((msg), (arg));\ else\ - gfc_error ((msg), &gfc_current_locus);\ - m = MATCH_ERROR;\ + gfc_error ((msg), spec_end);\ + return false;\ } - match m; gfc_expr *expr; gfc_symbol *sym = NULL; bool warn, unformatted; @@ -3848,8 +3783,6 @@ if (condition) \ unformatted = dt->format_expr == NULL && dt->format_label == NULL && dt->namelist == NULL; - m = MATCH_YES; - expr = dt->io_unit; if (expr && expr->expr_type == EXPR_VARIABLE && expr->ts.type == BT_CHARACTER) @@ -3867,7 +3800,7 @@ if (condition) \ io_constraint (dt->rec != NULL, "REC tag at %L is incompatible with internal file", &dt->rec->where); - + io_constraint (dt->pos != NULL, "POS tag at %L is incompatible with internal file", &dt->pos->where); @@ -3884,7 +3817,7 @@ if (condition) \ { if (!gfc_notify_std (GFC_STD_F2003, "Internal file at %L with " "namelist", &expr->where)) - m = MATCH_ERROR; + return false; } io_constraint (dt->advance != NULL, @@ -3897,87 +3830,57 @@ if (condition) \ if (gfc_pure (NULL) && (k == M_READ || k == M_WRITE)) { - gfc_error ("IO UNIT in %s statement at %C must be " + gfc_error ("IO UNIT in %s statement at %L must be " "an internal file in a PURE procedure", - io_kind_name (k)); - return MATCH_ERROR; + io_kind_name (k), &expr->where); + return false; } - + if (k == M_READ || k == M_WRITE) gfc_unset_implicit_pure (NULL); } - if (k != M_READ) - { - io_constraint (dt->end, "END tag not allowed with output at %L", - &dt->end_where); - - io_constraint (dt->eor, "EOR tag not allowed with output at %L", - &dt->eor_where); - - io_constraint (dt->blank, "BLANK= specifier not allowed with output at %L", - &dt->blank->where); - - io_constraint (dt->pad, "PAD= specifier not allowed with output at %L", - &dt->pad->where); - - io_constraint (dt->size, "SIZE= specifier not allowed with output at %L", - &dt->size->where); - } - else - { - io_constraint (dt->size && dt->advance == NULL, - "SIZE tag at %L requires an ADVANCE tag", - &dt->size->where); - - io_constraint (dt->eor && dt->advance == NULL, - "EOR tag at %L requires an ADVANCE tag", - &dt->eor_where); - } - - if (dt->asynchronous) + if (dt->asynchronous) { int num; static const char * asynchronous[] = { "YES", "NO", NULL }; + /* Note: gfc_reduce_init_expr reports an error if not init-expr. */ if (!gfc_reduce_init_expr (dt->asynchronous)) - { - gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization " - "expression", &dt->asynchronous->where); - return MATCH_ERROR; - } - - if (!is_char_type ("ASYNCHRONOUS", dt->asynchronous)) - return MATCH_ERROR; - - if (dt->asynchronous->ts.kind != 1) - { - gfc_error ("ASYNCHRONOUS= specifier at %L must be of default " - "CHARACTER kind", &dt->asynchronous->where); - return MATCH_ERROR; - } - - if (dt->asynchronous->expr_type == EXPR_ARRAY - || dt->asynchronous->expr_type == EXPR_STRUCTURE) - { - gfc_error ("ASYNCHRONOUS= specifier at %L must be scalar", - &dt->asynchronous->where); - return MATCH_ERROR; - } + return false; if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous, NULL, NULL, dt->asynchronous->value.character.string, - io_kind_name (k), warn, &num)) - return MATCH_ERROR; + io_kind_name (k), warn, &dt->asynchronous->where, &num)) + return false; - /* Best to put this here because the yes/no info is still around. */ - async_io_dt = num == 0; - if (async_io_dt && dt->size) - dt->size->symtree->n.sym->attr.asynchronous = 1; + /* For "YES", mark related symbols as asynchronous. */ + if (num == 0) + { + /* SIZE variable. */ + if (dt->size) + dt->size->symtree->n.sym->attr.asynchronous = 1; + + /* Variables in a NAMELIST. */ + if (dt->namelist) + for (gfc_namelist *nl = dt->namelist->namelist; nl; nl = nl->next) + nl->sym->attr.asynchronous = 1; + + /* Variables in an I/O list. */ + for (gfc_code *xfer = io_code; xfer && xfer->op == EXEC_TRANSFER; + xfer = xfer->next) + { + gfc_expr *expr = xfer->expr1; + while (expr != NULL && expr->expr_type == EXPR_OP + && expr->value.op.op == INTRINSIC_PARENTHESES) + expr = expr->value.op.op1; + + if (expr && expr->expr_type == EXPR_VARIABLE) + expr->symtree->n.sym->attr.asynchronous = 1; + } + } } - else - async_io_dt = false; if (dt->id) { @@ -3993,36 +3896,31 @@ if (condition) \ if (dt->decimal) { - if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C " - "not allowed in Fortran 95")) - return MATCH_ERROR; + if (!gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %L " + "not allowed in Fortran 95", &dt->decimal->where)) + return false; if (dt->decimal->expr_type == EXPR_CONSTANT) { static const char * decimal[] = { "COMMA", "POINT", NULL }; - if (!is_char_type ("DECIMAL", dt->decimal)) - return MATCH_ERROR; - if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL, dt->decimal->value.character.string, - io_kind_name (k), warn)) - return MATCH_ERROR; + io_kind_name (k), warn, + &dt->decimal->where)) + return false; io_constraint (unformatted, "the DECIMAL= specifier at %L must be with an " "explicit format expression", &dt->decimal->where); } } - + if (dt->blank) { - if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %C " - "not allowed in Fortran 95")) - return MATCH_ERROR; - - if (!is_char_type ("BLANK", dt->blank)) - return MATCH_ERROR; + if (!gfc_notify_std (GFC_STD_F2003, "BLANK= at %L " + "not allowed in Fortran 95", &dt->blank->where)) + return false; if (dt->blank->expr_type == EXPR_CONSTANT) { @@ -4031,8 +3929,9 @@ if (condition) \ if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL, dt->blank->value.character.string, - io_kind_name (k), warn)) - return MATCH_ERROR; + io_kind_name (k), warn, + &dt->blank->where)) + return false; io_constraint (unformatted, "the BLANK= specifier at %L must be with an " @@ -4042,12 +3941,9 @@ if (condition) \ if (dt->pad) { - if (!gfc_notify_std (GFC_STD_F2003, "PAD= at %C " - "not allowed in Fortran 95")) - return MATCH_ERROR; - - if (!is_char_type ("PAD", dt->pad)) - return MATCH_ERROR; + if (!gfc_notify_std (GFC_STD_F2003, "PAD= at %L " + "not allowed in Fortran 95", &dt->pad->where)) + return false; if (dt->pad->expr_type == EXPR_CONSTANT) { @@ -4055,8 +3951,9 @@ if (condition) \ if (!compare_to_allowed_values ("PAD", pad, NULL, NULL, dt->pad->value.character.string, - io_kind_name (k), warn)) - return MATCH_ERROR; + io_kind_name (k), warn, + &dt->pad->where)) + return false; io_constraint (unformatted, "the PAD= specifier at %L must be with an " @@ -4066,12 +3963,9 @@ if (condition) \ if (dt->round) { - if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %C " - "not allowed in Fortran 95")) - return MATCH_ERROR; - - if (!is_char_type ("ROUND", dt->round)) - return MATCH_ERROR; + if (!gfc_notify_std (GFC_STD_F2003, "ROUND= at %L " + "not allowed in Fortran 95", &dt->round->where)) + return false; if (dt->round->expr_type == EXPR_CONSTANT) { @@ -4081,20 +3975,18 @@ if (condition) \ if (!compare_to_allowed_values ("ROUND", round, NULL, NULL, dt->round->value.character.string, - io_kind_name (k), warn)) - return MATCH_ERROR; + io_kind_name (k), warn, + &dt->round->where)) + return false; } } - + if (dt->sign) { /* When implemented, change the following to use gfc_notify_std F2003. - if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %C " - "not allowed in Fortran 95") == false) - return MATCH_ERROR; */ - - if (!is_char_type ("SIGN", dt->sign)) - return MATCH_ERROR; + if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %L " + "not allowed in Fortran 95", &dt->sign->where) == false) + return false; */ if (dt->sign->expr_type == EXPR_CONSTANT) { @@ -4103,8 +3995,8 @@ if (condition) \ if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL, dt->sign->value.character.string, - io_kind_name (k), warn)) - return MATCH_ERROR; + io_kind_name (k), warn, &dt->sign->where)) + return false; io_constraint (unformatted, "SIGN= specifier at %L must be with an " @@ -4118,12 +4010,9 @@ if (condition) \ if (dt->delim) { - if (!gfc_notify_std (GFC_STD_F2003, "DELIM= at %C " - "not allowed in Fortran 95")) - return MATCH_ERROR; - - if (!is_char_type ("DELIM", dt->delim)) - return MATCH_ERROR; + if (!gfc_notify_std (GFC_STD_F2003, "DELIM= at %L " + "not allowed in Fortran 95", &dt->delim->where)) + return false; if (dt->delim->expr_type == EXPR_CONSTANT) { @@ -4131,13 +4020,14 @@ if (condition) \ if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL, dt->delim->value.character.string, - io_kind_name (k), warn)) - return MATCH_ERROR; + io_kind_name (k), warn, + &dt->delim->where)) + return false; io_constraint (k == M_READ, "DELIM= specifier at %L not allowed in a " "READ statement", &dt->delim->where); - + io_constraint (dt->format_label != &format_asterisk && dt->namelist == NULL, "DELIM= specifier at %L must have FMT=*", @@ -4148,7 +4038,7 @@ if (condition) \ "NML= specifier", &dt->delim->where); } } - + if (dt->namelist) { io_constraint (io_code && dt->namelist, @@ -4225,17 +4115,40 @@ if (condition) \ io_constraint (dt->eor && not_no && k == M_READ, "EOR tag at %L requires an ADVANCE = %", - &dt->eor_where); + &dt->eor_where); } - expr = dt->format_expr; - if (!gfc_simplify_expr (expr, 0) - || !check_format_string (expr, k == M_READ)) - return MATCH_ERROR; + if (k != M_READ) + { + io_constraint (dt->end, "END tag not allowed with output at %L", + &dt->end_where); - return m; -} + io_constraint (dt->eor, "EOR tag not allowed with output at %L", + &dt->eor_where); + + io_constraint (dt->blank, "BLANK= specifier not allowed with output at %L", + &dt->blank->where); + + io_constraint (dt->pad, "PAD= specifier not allowed with output at %L", + &dt->pad->where); + + io_constraint (dt->size, "SIZE= specifier not allowed with output at %L", + &dt->size->where); + } + else + { + io_constraint (dt->size && dt->advance == NULL, + "SIZE tag at %L requires an ADVANCE tag", + &dt->size->where); + + io_constraint (dt->eor && dt->advance == NULL, + "EOR tag at %L requires an ADVANCE tag", + &dt->eor_where); + } + + return true; #undef io_constraint +} /* Match a READ, WRITE or PRINT statement. */ @@ -4248,7 +4161,7 @@ match_io (io_kind k) gfc_symbol *sym; int comma_flag; locus where; - locus spec_end, control; + locus control; gfc_dt *dt; match m; @@ -4451,9 +4364,6 @@ loop: get_io_list: - /* Used in check_io_constraints, where no locus is available. */ - spec_end = gfc_current_locus; - /* Save the IO kind for later use. */ dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k); @@ -4485,12 +4395,11 @@ get_io_list: if (flag_dec_format_defaults) dt->dec_ext = 1; - /* A full IO statement has been matched. Check the constraints. spec_end is - supplied for cases where no locus is supplied. */ - m = check_io_constraints (k, dt, io_code, &spec_end); - - if (m == MATCH_ERROR) - goto cleanup; + /* Check the format string now. */ + if (dt->format_expr + && (!gfc_simplify_expr (dt->format_expr, 0) + || !check_format_string (dt->format_expr, k == M_READ))) + return MATCH_ERROR; new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE; new_st.ext.dt = dt; @@ -4610,8 +4519,6 @@ match_inquire_element (gfc_inquire *inquire) RETM m = match_etag (&tag_file, &inquire->file); RETM m = match_ltag (&tag_err, &inquire->err); RETM m = match_etag (&tag_iomsg, &inquire->iomsg); - if (m == MATCH_YES && !check_char_variable (inquire->iomsg)) - return MATCH_ERROR; RETM m = match_out_tag (&tag_iostat, &inquire->iostat); RETM m = match_vtag (&tag_exist, &inquire->exist); RETM m = match_vtag (&tag_opened, &inquire->opened); @@ -4633,8 +4540,6 @@ match_inquire_element (gfc_inquire *inquire) RETM m = match_vtag (&tag_write, &inquire->write); RETM m = match_vtag (&tag_readwrite, &inquire->readwrite); RETM m = match_vtag (&tag_s_async, &inquire->asynchronous); - if (m == MATCH_YES && !is_char_type ("ASYNCHRONOUS", inquire->asynchronous)) - return MATCH_ERROR; RETM m = match_vtag (&tag_s_delim, &inquire->delim); RETM m = match_vtag (&tag_s_decimal, &inquire->decimal); RETM m = match_out_tag (&tag_size, &inquire->size); @@ -4914,8 +4819,6 @@ match_wait_element (gfc_wait *wait) RETM m = match_ltag (&tag_end, &wait->end); RETM m = match_ltag (&tag_eor, &wait->eor); RETM m = match_etag (&tag_iomsg, &wait->iomsg); - if (m == MATCH_YES && !check_char_variable (wait->iomsg)) - return MATCH_ERROR; RETM m = match_out_tag (&tag_iostat, &wait->iostat); RETM m = match_etag (&tag_id, &wait->id); RETM return MATCH_NO; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 97de6ddce84..ccd2a5e3b7d 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -9941,9 +9941,6 @@ resolve_transfer (gfc_code *code) "an assumed-size array", &code->loc); return; } - - if (async_io_dt && exp->expr_type == EXPR_VARIABLE) - exp->symtree->n.sym->attr.asynchronous = 1; } @@ -12003,14 +12000,14 @@ start: break; case EXEC_OPEN: - if (!gfc_resolve_open (code->ext.open)) + if (!gfc_resolve_open (code->ext.open, &code->loc)) break; resolve_branch (code->ext.open->err, code); break; case EXEC_CLOSE: - if (!gfc_resolve_close (code->ext.close)) + if (!gfc_resolve_close (code->ext.close, &code->loc)) break; resolve_branch (code->ext.close->err, code); @@ -12052,7 +12049,7 @@ start: case EXEC_READ: case EXEC_WRITE: - if (!gfc_resolve_dt (code->ext.dt, &code->loc)) + if (!gfc_resolve_dt (code, code->ext.dt, &code->loc)) break; resolve_branch (code->ext.dt->err, code); @@ -15009,11 +15006,6 @@ resolve_fl_namelist (gfc_symbol *sym) } } - if (async_io_dt) - { - for (nl = sym->namelist; nl; nl = nl->next) - nl->sym->attr.asynchronous = 1; - } return true; } diff --git a/gcc/testsuite/gfortran.dg/asynchronous_5.f03 b/gcc/testsuite/gfortran.dg/asynchronous_5.f03 new file mode 100644 index 00000000000..fcd281d5001 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/asynchronous_5.f03 @@ -0,0 +1,43 @@ +! { 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" } } diff --git a/gcc/testsuite/gfortran.dg/f2003_io_8.f03 b/gcc/testsuite/gfortran.dg/f2003_io_8.f03 index 4d2f002fd0e..5604e0413e2 100644 --- a/gcc/testsuite/gfortran.dg/f2003_io_8.f03 +++ b/gcc/testsuite/gfortran.dg/f2003_io_8.f03 @@ -9,5 +9,5 @@ character(25) :: msg 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=" } 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 diff --git a/gcc/testsuite/gfortran.dg/io_constraints_15.f90 b/gcc/testsuite/gfortran.dg/io_constraints_15.f90 new file mode 100644 index 00000000000..47a5bf6923f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/io_constraints_15.f90 @@ -0,0 +1,11 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/io_constraints_16.f90 b/gcc/testsuite/gfortran.dg/io_constraints_16.f90 new file mode 100644 index 00000000000..dcbbbae17c0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/io_constraints_16.f90 @@ -0,0 +1,11 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/io_constraints_17.f90 b/gcc/testsuite/gfortran.dg/io_constraints_17.f90 new file mode 100644 index 00000000000..5864351debc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/io_constraints_17.f90 @@ -0,0 +1,11 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/io_constraints_18.f90 b/gcc/testsuite/gfortran.dg/io_constraints_18.f90 new file mode 100644 index 00000000000..1694871c5f6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/io_constraints_18.f90 @@ -0,0 +1,9 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/io_constraints_8.f90 b/gcc/testsuite/gfortran.dg/io_constraints_8.f90 index 216a41b758b..e3272e4a388 100644 --- a/gcc/testsuite/gfortran.dg/io_constraints_8.f90 +++ b/gcc/testsuite/gfortran.dg/io_constraints_8.f90 @@ -14,7 +14,7 @@ integer :: i 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, 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, 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" } diff --git a/gcc/testsuite/gfortran.dg/io_tags_1.f90 b/gcc/testsuite/gfortran.dg/io_tags_1.f90 new file mode 100644 index 00000000000..2ada161310c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/io_tags_1.f90 @@ -0,0 +1,19 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/io_tags_10.f90 b/gcc/testsuite/gfortran.dg/io_tags_10.f90 new file mode 100644 index 00000000000..377ac616680 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/io_tags_10.f90 @@ -0,0 +1,103 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/io_tags_2.f90 b/gcc/testsuite/gfortran.dg/io_tags_2.f90 new file mode 100644 index 00000000000..3eb11376fb4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/io_tags_2.f90 @@ -0,0 +1,30 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/io_tags_3.f90 b/gcc/testsuite/gfortran.dg/io_tags_3.f90 new file mode 100644 index 00000000000..198342b0672 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/io_tags_3.f90 @@ -0,0 +1,17 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/io_tags_4.f90 b/gcc/testsuite/gfortran.dg/io_tags_4.f90 new file mode 100644 index 00000000000..9396ef443a0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/io_tags_4.f90 @@ -0,0 +1,17 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/io_tags_5.f90 b/gcc/testsuite/gfortran.dg/io_tags_5.f90 new file mode 100644 index 00000000000..a6026619dba --- /dev/null +++ b/gcc/testsuite/gfortran.dg/io_tags_5.f90 @@ -0,0 +1,17 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/io_tags_6.f90 b/gcc/testsuite/gfortran.dg/io_tags_6.f90 new file mode 100644 index 00000000000..a8cc38300b6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/io_tags_6.f90 @@ -0,0 +1,175 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/io_tags_7.f90 b/gcc/testsuite/gfortran.dg/io_tags_7.f90 new file mode 100644 index 00000000000..12e3189ec10 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/io_tags_7.f90 @@ -0,0 +1,103 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/io_tags_8.f90 b/gcc/testsuite/gfortran.dg/io_tags_8.f90 new file mode 100644 index 00000000000..f37210ef5cc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/io_tags_8.f90 @@ -0,0 +1,18 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/io_tags_9.f90 b/gcc/testsuite/gfortran.dg/io_tags_9.f90 new file mode 100644 index 00000000000..55f9545f51d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/io_tags_9.f90 @@ -0,0 +1,18 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/iomsg_2.f90 b/gcc/testsuite/gfortran.dg/iomsg_2.f90 index 29500ed01ae..5023692daef 100644 --- a/gcc/testsuite/gfortran.dg/iomsg_2.f90 +++ b/gcc/testsuite/gfortran.dg/iomsg_2.f90 @@ -2,30 +2,30 @@ subroutine foo1 implicit none integer i - open(1, iomsg=666) ! { dg-error "IOMSG must be" } - open(1, iomsg='sgk') ! { dg-error "IOMSG must be" } - open(1, iomsg=i) ! { dg-error "IOMSG must be" } - close(1, iomsg=666) ! { dg-error "IOMSG must be" } - close(1, iomsg='sgk') ! { dg-error "IOMSG must be" } - close(1, iomsg=i) ! { dg-error "IOMSG must be" } + open(1, iomsg=666) ! { dg-error "must be of type CHARACTER" } + open(1, iomsg='sgk') ! { dg-error "Non-variable expression" } + open(1, iomsg=i) ! { dg-error "must be of type CHARACTER" } + close(1, iomsg=666) ! { dg-error "must be of type CHARACTER" } + close(1, iomsg='sgk') ! { dg-error "Non-variable expression" } + close(1, iomsg=i) ! { dg-error "must be of type CHARACTER" } end subroutine foo1 subroutine foo implicit none integer i real :: x = 1 - write(1, *, iomsg='sgk') x ! { dg-error "IOMSG must be" } - write(1, *, iomsg=i) x ! { dg-error "IOMSG must be" } - read(1, *, iomsg='sgk') x ! { dg-error "IOMSG must be" } - read(1, *, iomsg=i) x ! { dg-error "IOMSG must be" } - flush(1, iomsg='sgk') ! { dg-error "IOMSG must be" } - flush(1, iomsg=i) ! { dg-error "IOMSG must be" } - rewind(1, iomsg='sgk') ! { dg-error "IOMSG must be" } - rewind(1, iomsg=i) ! { dg-error "IOMSG must be" } - backspace(1,iomsg='sgk') ! { dg-error "IOMSG must be" } - backspace(1,iomsg=i) ! { dg-error "IOMSG must be" } - wait(1, iomsg='sgk') ! { dg-error "IOMSG must be" } - wait(1, iomsg=i) ! { dg-error "IOMSG must be" } + write(1, *, iomsg='sgk') x ! { dg-error "Non-variable expression" } + write(1, *, iomsg=i) x ! { dg-error "must be of type CHARACTER" } + read(1, *, iomsg='sgk') x ! { dg-error "Non-variable expression" } + read(1, *, iomsg=i) x ! { dg-error "must be of type CHARACTER" } + flush(1, iomsg='sgk') ! { dg-error "Non-variable expression" } + flush(1, iomsg=i) ! { dg-error "must be of type CHARACTER" } + rewind(1, iomsg='sgk') ! { dg-error "Non-variable expression" } + rewind(1, iomsg=i) ! { dg-error "must be of type CHARACTER" } + backspace(1,iomsg='sgk') ! { dg-error "Non-variable expression" } + backspace(1,iomsg=i) ! { dg-error "must be of type CHARACTER" } + wait(1, iomsg='sgk') ! { dg-error "Non-variable expression" } + wait(1, iomsg=i) ! { dg-error "must be of type CHARACTER" } end subroutine foo subroutine bar diff --git a/gcc/testsuite/gfortran.dg/pr66725.f90 b/gcc/testsuite/gfortran.dg/pr66725.f90 index 8ad97f7e18d..d845646cf79 100644 --- a/gcc/testsuite/gfortran.dg/pr66725.f90 +++ b/gcc/testsuite/gfortran.dg/pr66725.f90 @@ -3,29 +3,29 @@ ! program foo - open(unit=1,access = 999) ! { dg-error "ACCESS requires" } - open(unit=1,action = 999) ! { dg-error "ACTION requires" } - open(unit=1,asynchronous = 999) ! { dg-error "ASYNCHRONOUS requires" } - open(unit=1,blank = 999) ! { dg-error "BLANK requires" } - open(unit=1,decimal = 999) ! { dg-error "DECIMAL requires" } - open(unit=1,delim = 999) ! { dg-error "DELIM requires" } - open(unit=1,encoding = 999) ! { dg-error "ENCODING requires" } - open(unit=1,form = 999) ! { dg-error "FORM requires" } - open(unit=1,pad = 999) ! { dg-error "PAD requires" } - open(unit=1,position = 999) ! { dg-error "POSITION requires" } - open(unit=1,round = 999) ! { dg-error "ROUND requires" } - open(unit=1,sign = 999) ! { dg-error "SIGN requires" } - open(unit=1,status = 999) ! { dg-error "STATUS requires" } + open(unit=1,access = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,action = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,asynchronous = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,blank = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,decimal = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,delim = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,encoding = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,form = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,pad = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,position = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,round = 999) ! { dg-error "must be of type CHARACTER" } + open(unit=1,sign = 999) ! { dg-error "must be of type CHARACTER" } + 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, delim=257) ! { dg-error "DELIM requires" } - write (unit=1, decimal=257) ! { dg-error "DECIMAL requires" } - write (unit=1, round=257) ! { dg-error "ROUND requires" } - write (unit=1, sign=257) ! { dg-error "SIGN requires" } + write (unit=1, asynchronous=257) ! { dg-error "must be of type CHARACTER" } + write (unit=1, delim=257) ! { dg-error "must be of type CHARACTER" } + write (unit=1, decimal=257) ! { dg-error "must be of type CHARACTER" } + write (unit=1, round=257) ! { dg-error "must be of type CHARACTER" } + write (unit=1, sign=257) ! { dg-error "must be of type CHARACTER" } - write (unit=1, blank=257) ! { dg-error "BLANK requires" } - write (unit=1, pad=257) ! { dg-error "PAD requires" } + write (unit=1, blank=257) ! { dg-error "must be of type CHARACTER" } + write (unit=1, pad=257) ! { dg-error "must be of type CHARACTER" } end program foo diff --git a/gcc/testsuite/gfortran.dg/pr88205.f90 b/gcc/testsuite/gfortran.dg/pr88205.f90 index d9e08069109..419bad37156 100644 --- a/gcc/testsuite/gfortran.dg/pr88205.f90 +++ b/gcc/testsuite/gfortran.dg/pr88205.f90 @@ -2,13 +2,13 @@ ! PR fortran/88205 subroutine s1 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 subroutine s2 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 program p 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 diff --git a/gcc/testsuite/gfortran.dg/write_check4.f90 b/gcc/testsuite/gfortran.dg/write_check4.f90 index f418ba8fbf0..107baca2c31 100644 --- a/gcc/testsuite/gfortran.dg/write_check4.f90 +++ b/gcc/testsuite/gfortran.dg/write_check4.f90 @@ -11,7 +11,7 @@ no = "no" 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=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=no) ! { dg-error "must be an initialization expression" } + read (*,*, asynchronous=no) ! { dg-error "does not reduce to a constant expression" } end diff --git a/gcc/testsuite/gfortran.dg/write_check5.f90 b/gcc/testsuite/gfortran.dg/write_check5.f90 new file mode 100644 index 00000000000..296c51a1962 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/write_check5.f90 @@ -0,0 +1,24 @@ +! { 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