X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Fio.c;h=7191a58382ec9f82760b4a345f0a3f24bd7945a0;hb=1cc51d4d0164baa1f4e8d86699c3243363ae3c44;hp=11907a72a89d55d7323e0f00ede09df5b75d17e3;hpb=15618afa3684a0333833cafed1c03b2ebbcf1ae5;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 11907a72a89..7191a58382e 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -1,5 +1,5 @@ /* Deal with I/O statements & related stuff. - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -38,8 +38,8 @@ typedef struct io_tag; static const io_tag - tag_file = { "FILE", " file =", " %e", BT_CHARACTER }, - tag_status = { "STATUS", " status =", " %e", BT_CHARACTER}, + tag_file = {"FILE", " file =", " %e", BT_CHARACTER }, + tag_status = {"STATUS", " status =", " %e", BT_CHARACTER}, tag_e_access = {"ACCESS", " access =", " %e", BT_CHARACTER}, tag_e_form = {"FORM", " form =", " %e", BT_CHARACTER}, tag_e_recl = {"RECL", " recl =", " %e", BT_INTEGER}, @@ -94,7 +94,8 @@ static const io_tag tag_end = {"END", " end =", " %l", BT_UNKNOWN}, tag_eor = {"EOR", " eor =", " %l", BT_UNKNOWN}, tag_id = {"ID", " id =", " %v", BT_INTEGER}, - tag_pending = {"PENDING", " pending =", " %v", BT_LOGICAL}; + tag_pending = {"PENDING", " pending =", " %v", BT_LOGICAL}, + tag_newunit = {"NEWUNIT", " newunit =", " %v", BT_INTEGER}; static gfc_dt *current_dt; @@ -107,18 +108,22 @@ static gfc_dt *current_dt; typedef enum { FMT_NONE, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD, - FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_POS, FMT_LPAREN, + FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F, - FMT_E, FMT_EXT, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_ERROR, FMT_DC, - FMT_DP + FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, + FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR } format_token; /* Local variables for checking format strings. The saved_token is used to back up by a single format token during the parsing process. */ -static char *format_string; +static gfc_char_t *format_string; +static int format_string_pos; static int format_length, use_last_char; +static int starting_format_length; +static char error_element; +static locus format_locus; static format_token saved_token; @@ -132,7 +137,7 @@ mode; static char next_char (int in_string) { - static char c; + static gfc_char_t c; if (use_last_char) { @@ -153,18 +158,11 @@ next_char (int in_string) if (gfc_option.flag_backslash && c == '\\') { - int tmp; locus old_locus = gfc_current_locus; - /* Use a temp variable to avoid side effects from gfc_match_special_char - since it uses an int * for its argument. */ - tmp = (int)c; - - if (gfc_match_special_char (&tmp) == MATCH_NO) + if (gfc_match_special_char (&c) == MATCH_NO) gfc_current_locus = old_locus; - c = (char)tmp; - if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings) gfc_warning ("Extension: backslash character at %C"); } @@ -172,7 +170,12 @@ next_char (int in_string) if (mode == MODE_COPY) *format_string++ = c; - c = TOUPPER (c); + if (mode != MODE_STRING) + format_locus = gfc_current_locus; + + format_string_pos++; + + c = gfc_wide_toupper (c); return c; } @@ -193,7 +196,7 @@ next_char_not_space (bool *error) char c; do { - c = next_char (0); + error_element = c = next_char (0); if (c == '\t') { if (gfc_option.allow_std & GFC_STD_GNU) @@ -316,10 +319,18 @@ format_lex (void) case 'T': c = next_char_not_space (&error); - if (c != 'L' && c != 'R') - unget_char (); - - token = FMT_POS; + switch (c) + { + case 'L': + token = FMT_TL; + break; + case 'R': + token = FMT_TR; + break; + default: + token = FMT_T; + unget_char (); + } break; case '(': @@ -406,8 +417,10 @@ format_lex (void) case 'E': c = next_char_not_space (&error); - if (c == 'N' || c == 'S') - token = FMT_EXT; + if (c == 'N' ) + token = FMT_EN; + else if (c == 'S') + token = FMT_ES; else { token = FMT_E; @@ -438,14 +451,14 @@ format_lex (void) { if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DP format " "specifier not allowed at %C") == FAILURE) - return FMT_ERROR; + return FMT_ERROR; token = FMT_DP; } else if (c == 'C') { if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DC format " "specifier not allowed at %C") == FAILURE) - return FMT_ERROR; + return FMT_ERROR; token = FMT_DC; } else @@ -459,6 +472,10 @@ format_lex (void) token = FMT_END; break; + case '*': + token = FMT_STAR; + break; + default: token = FMT_UNKNOWN; break; @@ -471,30 +488,53 @@ format_lex (void) } +static const char * +token_to_string (format_token t) +{ + switch (t) + { + case FMT_D: + return "D"; + case FMT_G: + return "G"; + case FMT_E: + return "E"; + case FMT_EN: + return "EN"; + case FMT_ES: + return "ES"; + default: + return ""; + } +} + /* Check a format statement. The format string, either from a FORMAT statement or a constant in an I/O statement has already been parsed by itself, and we are checking it for validity. The dual origin means that the warning message is a little less than great. */ -static try +static gfc_try check_format (bool is_input) { const char *posint_required = _("Positive width required"); const char *nonneg_required = _("Nonnegative width required"); - const char *unexpected_element = _("Unexpected element"); + const char *unexpected_element = _("Unexpected element '%c' in format string" + " at %L"); const char *unexpected_end = _("Unexpected end of format string"); + const char *zero_width = _("Zero width in format descriptor"); const char *error; format_token t, u; int level; int repeat; - try rv; + gfc_try rv; use_last_char = 0; saved_token = FMT_NONE; level = 0; repeat = 0; rv = SUCCESS; + format_string_pos = 0; t = format_lex (); if (t == FMT_ERROR) @@ -520,6 +560,19 @@ format_item: format_item_1: switch (t) { + case FMT_STAR: + repeat = -1; + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + if (t == FMT_LPAREN) + { + level++; + goto format_item; + } + error = _("Left parenthesis required after '*'"); + goto syntax; + case FMT_POSINT: repeat = value; t = format_lex (); @@ -562,7 +615,7 @@ format_item_1: case FMT_X: /* X requires a prior number if we're being pedantic. */ if (gfc_notify_std (GFC_STD_GNU, "Extension: X descriptor " - "requires leading space count at %C") + "requires leading space count at %L", &format_locus) == FAILURE) return FAILURE; goto between_desc; @@ -585,22 +638,26 @@ format_item_1: if (t == FMT_ERROR) goto fail; - if (gfc_notify_std (GFC_STD_GNU, "Extension: $ descriptor at %C") - == FAILURE) + if (gfc_notify_std (GFC_STD_GNU, "Extension: $ descriptor at %L", + &format_locus) == FAILURE) return FAILURE; if (t != FMT_RPAREN || level > 0) { - gfc_warning ("$ should be the last specifier in format at %C"); + gfc_warning ("$ should be the last specifier in format at %L", + &format_locus); goto optional_comma_1; } goto finished; - case FMT_POS: + case FMT_T: + case FMT_TL: + case FMT_TR: case FMT_IBOZ: case FMT_F: case FMT_E: - case FMT_EXT: + case FMT_EN: + case FMT_ES: case FMT_G: case FMT_L: case FMT_A: @@ -630,23 +687,48 @@ data_desc: break; case FMT_P: - if (pedantic) + /* Comma after P is allowed only for F, E, EN, ES, D, or G. + 10.1.1 (1). */ + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + if (gfc_option.allow_std < GFC_STD_F2003 && t != FMT_COMMA + && t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES + && t != FMT_D && t != FMT_G) + { + error = _("Comma required after P descriptor"); + goto syntax; + } + if (t != FMT_COMMA) { - t = format_lex (); - if (t == FMT_ERROR) - goto fail; if (t == FMT_POSINT) { - error = _("Repeat count cannot follow P descriptor"); + t = format_lex (); + if (t == FMT_ERROR) + goto fail; + } + if (t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES && t != FMT_D + && t != FMT_G) + { + error = _("Comma required after P descriptor"); goto syntax; } - - saved_token = t; } + saved_token = t; goto optional_comma; - case FMT_POS: + case FMT_T: + case FMT_TL: + case FMT_TR: + t = format_lex (); + if (t != FMT_POSINT) + { + error = _("Positive width required with T descriptor"); + goto syntax; + } + break; + case FMT_L: t = format_lex (); if (t == FMT_ERROR) @@ -657,8 +739,10 @@ data_desc: switch (gfc_notification_std (GFC_STD_GNU)) { case WARNING: + if (mode != MODE_FORMAT) + format_locus.nextc += format_string_pos; gfc_warning ("Extension: Missing positive width after L " - "descriptor at %C"); + "descriptor at %L", &format_locus); saved_token = t; break; @@ -679,6 +763,11 @@ data_desc: t = format_lex (); if (t == FMT_ERROR) goto fail; + if (t == FMT_ZERO) + { + error = zero_width; + goto syntax; + } if (t != FMT_POSINT) saved_token = t; break; @@ -686,14 +775,49 @@ data_desc: case FMT_D: case FMT_E: case FMT_G: - case FMT_EXT: + case FMT_EN: + case FMT_ES: u = format_lex (); - if (u == FMT_ERROR) - goto fail; + if (t == FMT_G && u == FMT_ZERO) + { + if (is_input) + { + error = zero_width; + goto syntax; + } + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: 'G0' in " + "format at %L", &format_locus) == FAILURE) + return FAILURE; + u = format_lex (); + if (u != FMT_PERIOD) + { + saved_token = u; + break; + } + u = format_lex (); + if (u != FMT_POSINT) + { + error = posint_required; + goto syntax; + } + u = format_lex (); + if (u == FMT_E) + { + error = _("E specifier not allowed with g0 descriptor"); + goto syntax; + } + saved_token = u; + break; + } + if (u != FMT_POSINT) { - error = posint_required; - goto syntax; + format_locus.nextc += format_string_pos; + gfc_error_now ("Positive width required in format " + "specifier %s at %L", token_to_string (t), + &format_locus); + saved_token = u; + goto finished; } u = format_lex (); @@ -702,10 +826,19 @@ data_desc: if (u != FMT_PERIOD) { /* Warn if -std=legacy, otherwise error. */ + format_locus.nextc += format_string_pos; if (gfc_option.warn_std != 0) - gfc_error_now ("Period required in format specifier at %C"); + { + gfc_error_now ("Period required in format " + "specifier %s at %L", token_to_string (t), + &format_locus); + saved_token = u; + goto finished; + } else - gfc_warning ("Period required in format specifier at %C"); + gfc_warning ("Period required in format " + "specifier %s at %L", token_to_string (t), + &format_locus); saved_token = u; break; } @@ -766,9 +899,14 @@ data_desc: { /* Warn if -std=legacy, otherwise error. */ if (gfc_option.warn_std != 0) - gfc_error_now ("Period required in format specifier at %C"); - else - gfc_warning ("Period required in format specifier at %C"); + { + error = _("Period required in format specifier"); + goto syntax; + } + if (mode != MODE_FORMAT) + format_locus.nextc += format_string_pos; + gfc_warning ("Period required in format specifier at %L", + &format_locus); saved_token = t; break; } @@ -786,22 +924,17 @@ data_desc: case FMT_H: if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings) - gfc_warning ("The H format specifier at %C is" - " a Fortran 95 deleted feature"); - - if(mode == MODE_STRING) { - format_string += value; - format_length -= value; - } - else - { - while (repeat >0) - { - next_char (1); - repeat -- ; - } + if (mode != MODE_FORMAT) + format_locus.nextc += format_string_pos; + gfc_warning ("The H format specifier at %L is" + " a Fortran 95 deleted feature", &format_locus); } + while (repeat >0) + { + next_char (1); + repeat -- ; + } break; case FMT_IBOZ: @@ -871,8 +1004,10 @@ between_desc: goto syntax; default: - if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %C") - == FAILURE) + if (mode != MODE_FORMAT) + format_locus.nextc += format_string_pos; + if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %L", + &format_locus) == FAILURE) return FAILURE; goto format_item_1; } @@ -928,23 +1063,35 @@ extension_optional_comma: goto syntax; default: - if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %C") - == FAILURE) + if (mode != MODE_FORMAT) + format_locus.nextc += format_string_pos; + if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %L", + &format_locus) == FAILURE) return FAILURE; saved_token = t; break; } goto format_item; - + syntax: - gfc_error ("%s in format string at %C", error); + if (mode != MODE_FORMAT) + format_locus.nextc += format_string_pos; + if (error == unexpected_element) + gfc_error (error, error_element, &format_locus); + else + gfc_error ("%s in format string at %L", error, &format_locus); fail: - /* TODO: More elaborate measures are needed to show where a problem - is within a format string that has been calculated. */ rv = FAILURE; finished: + /* check for extraneous characters at end of valid format string */ + if ( starting_format_length > format_length ) + { + format_locus.nextc += format_length + 1; /* point to the extra */ + gfc_warning ("Extraneous characters in format at %L", &format_locus); + } + return rv; } @@ -952,7 +1099,7 @@ finished: /* Given an expression node that is a constant string, see if it looks like a format string. */ -static try +static gfc_try check_format_string (gfc_expr *e, bool is_input) { if (!e || e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT) @@ -960,6 +1107,12 @@ check_format_string (gfc_expr *e, bool is_input) mode = MODE_STRING; format_string = e->value.character.string; + starting_format_length = e->value.character.length; + /* More elaborate measures are needed to show where a problem is within a + format string that has been calculated, but that's probably not worth the + effort. */ + format_locus = e->where; + return check_format (is_input); } @@ -1017,7 +1170,8 @@ gfc_match_format (void) e->ts.type = BT_CHARACTER; e->ts.kind = gfc_default_character_kind; e->where = start; - e->value.character.string = format_string = gfc_getmem (format_length + 1); + e->value.character.string = format_string + = gfc_get_wide_string (format_length + 1); e->value.character.length = format_length; gfc_statement_label->format = e; @@ -1088,14 +1242,15 @@ match_vtag (const io_tag *tag, gfc_expr **v) if (result->symtree->n.sym->attr.intent == INTENT_IN) { - gfc_error ("Variable tag cannot be INTENT(IN) at %C"); + gfc_error ("Variable %s cannot be INTENT(IN) at %C", tag->name); gfc_free_expr (result); return MATCH_ERROR; } if (gfc_pure (NULL) && gfc_impure_variable (result->symtree->n.sym)) { - gfc_error ("Variable tag cannot be assigned in PURE procedure at %C"); + gfc_error ("Variable %s cannot be assigned in PURE procedure at %C", + tag->name); gfc_free_expr (result); return MATCH_ERROR; } @@ -1108,13 +1263,13 @@ match_vtag (const io_tag *tag, gfc_expr **v) /* Match I/O tags that cause variables to become redefined. */ static match -match_out_tag(const io_tag *tag, gfc_expr **result) +match_out_tag (const io_tag *tag, gfc_expr **result) { match m; - m = match_vtag(tag, result); + m = match_vtag (tag, result); if (m == MATCH_YES) - gfc_check_do_variable((*result)->symtree); + gfc_check_do_variable ((*result)->symtree); return m; } @@ -1155,7 +1310,7 @@ match_ltag (const io_tag *tag, gfc_st_label ** label) /* Resolution of the FORMAT tag, to be called from resolve_tag. */ -static try +static gfc_try resolve_tag_format (const gfc_expr *e) { if (e->expr_type == EXPR_CONSTANT @@ -1170,8 +1325,11 @@ resolve_tag_format (const gfc_expr *e) /* If e's rank is zero and e is not an element of an array, it should be of integer or character type. The integer variable should be ASSIGNED. */ - if (e->symtree == NULL || e->symtree->n.sym->as == NULL - || e->symtree->n.sym->as->rank == 0) + if (e->rank == 0 + && (e->expr_type != EXPR_VARIABLE + || e->symtree == NULL + || e->symtree->n.sym->as == NULL + || e->symtree->n.sym->as->rank == 0)) { if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER) { @@ -1202,20 +1360,34 @@ resolve_tag_format (const gfc_expr *e) return SUCCESS; } - /* If rank is nonzero, we allow the type to be character under GFC_STD_GNU - and other type under GFC_STD_LEGACY. It may be assigned an Hollerith - constant. */ - if (e->ts.type == BT_CHARACTER) - { - if (gfc_notify_std (GFC_STD_GNU, "Extension: Character array " - "in FORMAT tag at %L", &e->where) == FAILURE) - return FAILURE; - } - else + /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY. + It may be assigned an Hollerith constant. */ + if (e->ts.type != BT_CHARACTER) { if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character " "in FORMAT tag at %L", &e->where) == FAILURE) return FAILURE; + + if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE) + { + gfc_error ("Non-character assumed shape array element in FORMAT" + " tag at %L", &e->where); + return FAILURE; + } + + if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE) + { + gfc_error ("Non-character assumed size array element in FORMAT" + " tag at %L", &e->where); + return FAILURE; + } + + if (e->rank == 0 && e->symtree->n.sym->attr.pointer) + { + gfc_error ("Non-character pointer array element in FORMAT tag at %L", + &e->where); + return FAILURE; + } } return SUCCESS; @@ -1224,7 +1396,7 @@ resolve_tag_format (const gfc_expr *e) /* Do expression resolution and type-checking on an expression tag. */ -static try +static gfc_try resolve_tag (const io_tag *tag, gfc_expr *e) { if (e == NULL) @@ -1343,6 +1515,9 @@ match_open_element (gfc_open *open) m = match_etag (&tag_convert, &open->convert); if (m != MATCH_NO) return m; + m = match_out_tag (&tag_newunit, &open->newunit); + if (m != MATCH_NO) + return m; return MATCH_NO; } @@ -1375,13 +1550,14 @@ gfc_free_open (gfc_open *open) gfc_free_expr (open->sign); gfc_free_expr (open->convert); gfc_free_expr (open->asynchronous); + gfc_free_expr (open->newunit); gfc_free (open); } /* Resolve everything in a gfc_open structure. */ -try +gfc_try gfc_resolve_open (gfc_open *open) { @@ -1404,6 +1580,7 @@ gfc_resolve_open (gfc_open *open) RESOLVE_TAG (&tag_e_round, open->round); RESOLVE_TAG (&tag_e_sign, open->sign); RESOLVE_TAG (&tag_convert, open->convert); + RESOLVE_TAG (&tag_newunit, open->newunit); if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE) return FAILURE; @@ -1419,13 +1596,13 @@ gfc_resolve_open (gfc_open *open) static int compare_to_allowed_values (const char *specifier, const char *allowed[], const char *allowed_f2003[], - const char *allowed_gnu[], char *value, + const char *allowed_gnu[], gfc_char_t *value, const char *statement, bool warn) { int i; unsigned int len; - len = strlen (value); + len = gfc_wide_strlen (value); if (len > 0) { for (len--; len > 0; len--) @@ -1436,13 +1613,13 @@ compare_to_allowed_values (const char *specifier, const char *allowed[], for (i = 0; allowed[i]; i++) if (len == strlen (allowed[i]) - && strncasecmp (value, allowed[i], strlen (allowed[i])) == 0) + && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0) return 1; for (i = 0; allowed_f2003 && allowed_f2003[i]; i++) if (len == strlen (allowed_f2003[i]) - && strncasecmp (value, allowed_f2003[i], strlen (allowed_f2003[i])) - == 0) + && gfc_wide_strncasecmp (value, allowed_f2003[i], + strlen (allowed_f2003[i])) == 0) { notification n = gfc_notification_std (GFC_STD_F2003); @@ -1468,7 +1645,8 @@ compare_to_allowed_values (const char *specifier, const char *allowed[], for (i = 0; allowed_gnu && allowed_gnu[i]; i++) if (len == strlen (allowed_gnu[i]) - && strncasecmp (value, allowed_gnu[i], strlen (allowed_gnu[i])) == 0) + && gfc_wide_strncasecmp (value, allowed_gnu[i], + strlen (allowed_gnu[i])) == 0) { notification n = gfc_notification_std (GFC_STD_GNU); @@ -1494,14 +1672,18 @@ compare_to_allowed_values (const char *specifier, const char *allowed[], if (warn) { + char *s = gfc_widechar_to_char (value, -1); gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'", - specifier, statement, value); + specifier, statement, s); + gfc_free (s); return 1; } else { + char *s = gfc_widechar_to_char (value, -1); gfc_error ("%s specifier in %s statement at %C has invalid value '%s'", - specifier, statement, value); + specifier, statement, s); + gfc_free (s); return 0; } } @@ -1520,7 +1702,7 @@ gfc_match_open (void) if (m == MATCH_NO) return m; - open = gfc_getmem (sizeof (gfc_open)); + open = XCNEW (gfc_open); m = match_open_element (open); @@ -1559,6 +1741,26 @@ gfc_match_open (void) } warn = (open->err || open->iostat) ? true : false; + + /* Checks on NEWUNIT specifier. */ + if (open->newunit) + { + if (open->unit) + { + gfc_error ("UNIT specifier not allowed with NEWUNIT at %C"); + goto cleanup; + } + + if (!(open->file || (open->status + && gfc_wide_strncasecmp (open->status->value.character.string, + "scratch", 7) == 0))) + { + gfc_error ("NEWUNIT specifier must have FILE= " + "or STATUS='scratch' at %C"); + goto cleanup; + } + } + /* Checks on the ACCESS specifier. */ if (open->access && open->access->expr_type == EXPR_CONSTANT) { @@ -1665,8 +1867,7 @@ gfc_match_open (void) if (open->encoding->expr_type == EXPR_CONSTANT) { - /* TODO: Implement UTF-8 here. */ - static const char * encoding[] = { "DEFAULT", NULL }; + static const char * encoding[] = { "DEFAULT", "UTF-8", NULL }; if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL, open->encoding->value.character.string, @@ -1712,7 +1913,7 @@ gfc_match_open (void) if (open->round) { /* When implemented, change the following to use gfc_notify_std F2003. */ - gfc_error ("F2003 Feature: ROUND= specifier at %C not implemented"); + gfc_error ("Fortran F2003: ROUND= specifier at %C not implemented"); goto cleanup; if (open->round->expr_type == EXPR_CONSTANT) @@ -1780,20 +1981,22 @@ gfc_match_open (void) /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE, the FILE= specifier shall appear. */ if (open->file == NULL - && (strncasecmp (open->status->value.character.string, "replace", 7) - == 0 - || strncasecmp (open->status->value.character.string, "new", 3) - == 0)) + && (gfc_wide_strncasecmp (open->status->value.character.string, + "replace", 7) == 0 + || gfc_wide_strncasecmp (open->status->value.character.string, + "new", 3) == 0)) { + char *s = gfc_widechar_to_char (open->status->value.character.string, + -1); warn_or_error ("The STATUS specified in OPEN statement at %C is " - "'%s' and no FILE specifier is present", - open->status->value.character.string); + "'%s' and no FILE specifier is present", s); + gfc_free (s); } /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH, the FILE= specifier shall not appear. */ - if (strncasecmp (open->status->value.character.string, "scratch", 7) - == 0 && open->file) + if (gfc_wide_strncasecmp (open->status->value.character.string, + "scratch", 7) == 0 && open->file) { warn_or_error ("The STATUS specified in OPEN statement at %C " "cannot have the value SCRATCH if a FILE specifier " @@ -1805,8 +2008,8 @@ gfc_match_open (void) if (open->form && open->form->expr_type == EXPR_CONSTANT && (open->delim || open->decimal || open->encoding || open->round || open->sign || open->pad || open->blank) - && strncasecmp (open->form->value.character.string, - "unformatted", 11) == 0) + && gfc_wide_strncasecmp (open->form->value.character.string, + "unformatted", 11) == 0) { const char *spec = (open->delim ? "DELIM " : (open->pad ? "PAD " : open->blank @@ -1817,7 +2020,8 @@ gfc_match_open (void) } if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT - && strncasecmp (open->access->value.character.string, "stream", 6) == 0) + && gfc_wide_strncasecmp (open->access->value.character.string, + "stream", 6) == 0) { warn_or_error ("RECL specifier not allowed in OPEN statement at %C for " "stream I/O"); @@ -1825,12 +2029,12 @@ gfc_match_open (void) if (open->position && open->access && open->access->expr_type == EXPR_CONSTANT - && !(strncasecmp (open->access->value.character.string, - "sequential", 10) == 0 - || strncasecmp (open->access->value.character.string, - "stream", 6) == 0 - || strncasecmp (open->access->value.character.string, - "append", 6) == 0)) + && !(gfc_wide_strncasecmp (open->access->value.character.string, + "sequential", 10) == 0 + || gfc_wide_strncasecmp (open->access->value.character.string, + "stream", 6) == 0 + || gfc_wide_strncasecmp (open->access->value.character.string, + "append", 6) == 0)) { warn_or_error ("POSITION specifier in OPEN statement at %C only allowed " "for stream or sequential ACCESS"); @@ -1907,7 +2111,7 @@ gfc_match_close (void) if (m == MATCH_NO) return m; - close = gfc_getmem (sizeof (gfc_close)); + close = XCNEW (gfc_close); m = match_close_element (close); @@ -1973,7 +2177,7 @@ cleanup: /* Resolve everything in a gfc_close structure. */ -try +gfc_try gfc_resolve_close (gfc_close *close) { RESOLVE_TAG (&tag_unit, close->unit); @@ -1984,6 +2188,14 @@ gfc_resolve_close (gfc_close *close) if (gfc_reference_st_label (close->err, ST_LABEL_TARGET) == FAILURE) return FAILURE; + if (close->unit->expr_type == EXPR_CONSTANT + && close->unit->ts.type == BT_INTEGER + && mpz_sgn (close->unit->value.integer) < 0) + { + gfc_error ("UNIT number in CLOSE statement at %L must be non-negative", + &close->unit->where); + } + return SUCCESS; } @@ -2033,7 +2245,7 @@ match_filepos (gfc_statement st, gfc_exec_op op) gfc_filepos *fp; match m; - fp = gfc_getmem (sizeof (gfc_filepos)); + fp = XCNEW (gfc_filepos); if (gfc_match_char ('(') == MATCH_NO) { @@ -2097,7 +2309,7 @@ cleanup: } -try +gfc_try gfc_resolve_filepos (gfc_filepos *fp) { RESOLVE_TAG (&tag_unit, fp->unit); @@ -2106,6 +2318,14 @@ gfc_resolve_filepos (gfc_filepos *fp) if (gfc_reference_st_label (fp->err, ST_LABEL_TARGET) == FAILURE) return FAILURE; + if (fp->unit->expr_type == EXPR_CONSTANT + && fp->unit->ts.type == BT_INTEGER + && mpz_sgn (fp->unit->value.integer) < 0) + { + gfc_error ("UNIT number in statement at %L must be non-negative", + &fp->unit->where); + } + return SUCCESS; } @@ -2143,11 +2363,6 @@ gfc_match_flush (void) /******************** Data Transfer Statements *********************/ -typedef enum -{ M_READ, M_WRITE, M_PRINT, M_INQUIRE } -io_kind; - - /* Return a default unit number. */ static gfc_expr * @@ -2356,7 +2571,7 @@ match_dt_element (io_kind k, gfc_dt *dt) m = match_etag (&tag_rec, &dt->rec); if (m != MATCH_NO) return m; - m = match_etag (&tag_spos, &dt->rec); + m = match_etag (&tag_spos, &dt->pos); if (m != MATCH_NO) return m; m = match_out_tag (&tag_iomsg, &dt->iomsg); @@ -2421,21 +2636,24 @@ gfc_free_dt (gfc_dt *dt) gfc_free_expr (dt->round); gfc_free_expr (dt->blank); gfc_free_expr (dt->decimal); + gfc_free_expr (dt->extra_comma); + gfc_free_expr (dt->pos); gfc_free (dt); } /* Resolve everything in a gfc_dt structure. */ -try -gfc_resolve_dt (gfc_dt *dt) +gfc_try +gfc_resolve_dt (gfc_dt *dt, locus *loc) { gfc_expr *e; RESOLVE_TAG (&tag_format, dt->format_expr); RESOLVE_TAG (&tag_rec, dt->rec); - RESOLVE_TAG (&tag_spos, dt->rec); + RESOLVE_TAG (&tag_spos, dt->pos); RESOLVE_TAG (&tag_advance, dt->advance); + RESOLVE_TAG (&tag_id, dt->id); RESOLVE_TAG (&tag_iomsg, dt->iomsg); RESOLVE_TAG (&tag_iostat, dt->iostat); RESOLVE_TAG (&tag_size, dt->size); @@ -2445,15 +2663,53 @@ gfc_resolve_dt (gfc_dt *dt) RESOLVE_TAG (&tag_e_round, dt->round); RESOLVE_TAG (&tag_e_blank, dt->blank); RESOLVE_TAG (&tag_e_decimal, dt->decimal); + RESOLVE_TAG (&tag_e_async, dt->asynchronous); e = dt->io_unit; + if (e == NULL) + { + gfc_error ("UNIT not specified at %L", loc); + return FAILURE; + } + if (gfc_resolve_expr (e) == SUCCESS && (e->ts.type != BT_INTEGER && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE))) { - gfc_error ("UNIT specification at %L must be an INTEGER expression " - "or a CHARACTER variable", &e->where); - return FAILURE; + /* If there is no extra comma signifying the "format" form of the IO + statement, then this must be an error. */ + if (!dt->extra_comma) + { + gfc_error ("UNIT specification at %L must be an INTEGER expression " + "or a CHARACTER variable", &e->where); + return FAILURE; + } + else + { + /* At this point, we have an extra comma. If io_unit has arrived as + type character, we assume its really the "format" form of the I/O + statement. We set the io_unit to the default unit and format to + the character expression. See F95 Standard section 9.4. */ + io_kind k; + k = dt->extra_comma->value.iokind; + if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT)) + { + dt->format_expr = dt->io_unit; + dt->io_unit = default_unit (k); + + /* Free this pointer now so that a warning/error is not triggered + below for the "Extension". */ + gfc_free_expr (dt->extra_comma); + dt->extra_comma = NULL; + } + + if (k == M_WRITE) + { + gfc_error ("Invalid form of WRITE statement at %L, UNIT required", + &dt->extra_comma->where); + return FAILURE; + } + } } if (e->ts.type == BT_CHARACTER) @@ -2471,6 +2727,18 @@ gfc_resolve_dt (gfc_dt *dt) return FAILURE; } + if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER + && mpz_sgn (e->value.integer) < 0) + { + gfc_error ("UNIT number in statement at %L must be non-negative", &e->where); + return FAILURE; + } + + if (dt->extra_comma + && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before i/o " + "item list at %L", &dt->extra_comma->where) == FAILURE) + return FAILURE; + if (dt->err) { if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE) @@ -2560,7 +2828,7 @@ static match match_io_element (io_kind, gfc_code **); static match match_io_iterator (io_kind k, gfc_code **result) { - gfc_code *head, *tail, *new; + gfc_code *head, *tail, *new_code; gfc_iterator *iter; locus old_loc; match m; @@ -2596,7 +2864,7 @@ match_io_iterator (io_kind k, gfc_code **result) break; } - m = match_io_element (k, &new); + m = match_io_element (k, &new_code); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) @@ -2606,7 +2874,7 @@ match_io_iterator (io_kind k, gfc_code **result) goto cleanup; } - tail = gfc_append_code (tail, new); + tail = gfc_append_code (tail, new_code); if (gfc_match_char (',') != MATCH_YES) { @@ -2620,15 +2888,15 @@ match_io_iterator (io_kind k, gfc_code **result) if (gfc_match_char (')') != MATCH_YES) goto syntax; - new = gfc_get_code (); - new->op = EXEC_DO; - new->ext.iterator = iter; + new_code = gfc_get_code (); + new_code->op = EXEC_DO; + new_code->ext.iterator = iter; - new->block = gfc_get_code (); - new->block->op = EXEC_DO; - new->block->next = head; + new_code->block = gfc_get_code (); + new_code->block->op = EXEC_DO; + new_code->block->next = head; - *result = new; + *result = new_code; return MATCH_YES; syntax: @@ -2686,6 +2954,7 @@ match_io_element (io_kind k, gfc_code **cpp) if (gfc_pure (NULL) && gfc_impure_variable (expr->symtree->n.sym) + && current_dt->io_unit && current_dt->io_unit->ts.type == BT_CHARACTER) { gfc_error ("Cannot read to variable '%s' in PURE procedure at %C", @@ -2699,7 +2968,8 @@ match_io_element (io_kind k, gfc_code **cpp) break; case M_WRITE: - if (current_dt->io_unit->ts.type == BT_CHARACTER + if (current_dt->io_unit + && current_dt->io_unit->ts.type == BT_CHARACTER && gfc_pure (NULL) && current_dt->io_unit->expr_type == EXPR_VARIABLE && gfc_impure_variable (current_dt->io_unit->symtree->n.sym)) @@ -2724,7 +2994,7 @@ match_io_element (io_kind k, gfc_code **cpp) cp = gfc_get_code (); cp->op = EXEC_TRANSFER; - cp->expr = expr; + cp->expr1 = expr; *cpp = cp; return MATCH_YES; @@ -2736,7 +3006,7 @@ match_io_element (io_kind k, gfc_code **cpp) static match match_io_list (io_kind k, gfc_code **head_p) { - gfc_code *head, *tail, *new; + gfc_code *head, *tail, *new_code; match m; *head_p = head = tail = NULL; @@ -2745,15 +3015,15 @@ match_io_list (io_kind k, gfc_code **head_p) for (;;) { - m = match_io_element (k, &new); + m = match_io_element (k, &new_code); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) goto syntax; - tail = gfc_append_code (tail, new); + tail = gfc_append_code (tail, new_code); if (head == NULL) - head = new; + head = new_code; if (gfc_match_eos () == MATCH_YES) break; @@ -2835,6 +3105,10 @@ 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); io_constraint (unformatted, "Unformatted I/O not allowed with internal unit at %L", @@ -2898,7 +3172,7 @@ if (condition) \ { static const char * asynchronous[] = { "YES", "NO", NULL }; - if (dt->asynchronous->expr_type != EXPR_CONSTANT) + if (gfc_reduce_init_expr (dt->asynchronous) != SUCCESS) { gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization " "expression", &dt->asynchronous->where); @@ -2914,9 +3188,12 @@ if (condition) \ if (dt->id) { - io_constraint (!dt->asynchronous - || strcmp (dt->asynchronous->value.character.string, - "yes"), + bool not_yes + = !dt->asynchronous + || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3 + || gfc_wide_strncasecmp (dt->asynchronous->value.character.string, + "yes", 3) != 0; + io_constraint (not_yes, "ID= specifier at %L must be with ASYNCHRONOUS='yes' " "specifier", &dt->id->where); } @@ -3070,7 +3347,7 @@ if (condition) \ io_constraint (dt->format_expr, "IO spec-list cannot contain both NAMELIST group name " - "and format specification at %L.", + "and format specification at %L", &dt->format_expr->where); io_constraint (dt->format_label, @@ -3079,22 +3356,26 @@ if (condition) \ io_constraint (dt->rec, "NAMELIST IO is not allowed with a REC= specifier " - "at %L.", &dt->rec->where); + "at %L", &dt->rec->where); io_constraint (dt->advance, "NAMELIST IO is not allowed with a ADVANCE= specifier " - "at %L.", &dt->advance->where); + "at %L", &dt->advance->where); } if (dt->rec) { io_constraint (dt->end, "An END tag is not allowed with a " - "REC= specifier at %L.", &dt->end_where); + "REC= specifier at %L", &dt->end_where); io_constraint (dt->format_label == &format_asterisk, "FMT=* is not allowed with a REC= specifier " - "at %L.", spec_end); + "at %L", spec_end); + + io_constraint (dt->pos, + "POS= is not allowed with REC= specifier " + "at %L", &dt->pos->where); } if (dt->advance) @@ -3112,9 +3393,11 @@ if (condition) \ if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER) { - const char * advance = expr->value.character.string; - not_no = strcasecmp (advance, "no") != 0; - not_yes = strcasecmp (advance, "yes") != 0; + const gfc_char_t *advance = expr->value.character.string; + not_no = gfc_wide_strlen (advance) != 2 + || gfc_wide_strncasecmp (advance, "no", 2) != 0; + not_yes = gfc_wide_strlen (advance) != 3 + || gfc_wide_strncasecmp (advance, "yes", 3) != 0; } else { @@ -3153,7 +3436,7 @@ match_io (io_kind k) char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_code *io_code; gfc_symbol *sym; - int comma_flag, c; + int comma_flag; locus where; locus spec_end; gfc_dt *dt; @@ -3161,7 +3444,7 @@ match_io (io_kind k) where = gfc_current_locus; comma_flag = 0; - current_dt = dt = gfc_getmem (sizeof (gfc_dt)); + current_dt = dt = XCNEW (gfc_dt); m = gfc_match_char ('('); if (m == MATCH_NO) { @@ -3171,7 +3454,7 @@ match_io (io_kind k) else if (k == M_PRINT) { /* Treat the non-standard case of PRINT namelist. */ - if ((gfc_current_form == FORM_FIXED || gfc_peek_char () == ' ') + if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ') && gfc_match_name (name) == MATCH_YES) { gfc_find_symbol (name, NULL, 1, &sym); @@ -3195,7 +3478,7 @@ match_io (io_kind k) if (gfc_current_form == FORM_FREE) { - c = gfc_peek_char(); + char c = gfc_peek_ascii_char (); if (c != ' ' && c != '*' && c != '\'' && c != '"') { m = MATCH_NO; @@ -3306,12 +3589,23 @@ get_io_list: /* Used in check_io_constraints, where no locus is available. */ spec_end = gfc_current_locus; - /* Optional leading comma (non-standard). */ - if (!comma_flag - && gfc_match_char (',') == MATCH_YES - && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before i/o " - "item list at %C") == FAILURE) - return MATCH_ERROR; + /* Optional leading comma (non-standard). We use a gfc_expr structure here + to save the locus. This is used later when resolving transfer statements + that might have a format expression without unit number. */ + if (!comma_flag && gfc_match_char (',') == MATCH_YES) + { + dt->extra_comma = gfc_get_expr (); + + /* Set the types to something compatible with iokind. This is needed to + get through gfc_free_expr later since iokind really has no Basic Type, + BT, of its own. */ + dt->extra_comma->expr_type = EXPR_CONSTANT; + dt->extra_comma->ts.type = BT_LOGICAL; + + /* Save the iokind and locus for later use in resolution. */ + dt->extra_comma->value.iokind = k; + dt->extra_comma->where = gfc_current_locus; + } io_code = NULL; if (gfc_match_eos () != MATCH_YES) @@ -3429,9 +3723,11 @@ gfc_free_inquire (gfc_inquire *inquire) gfc_free_expr (inquire->convert); gfc_free_expr (inquire->strm_pos); gfc_free_expr (inquire->asynchronous); + gfc_free_expr (inquire->decimal); gfc_free_expr (inquire->pending); gfc_free_expr (inquire->id); gfc_free_expr (inquire->sign); + gfc_free_expr (inquire->size); gfc_free_expr (inquire->round); gfc_free (inquire); } @@ -3473,7 +3769,7 @@ match_inquire_element (gfc_inquire *inquire) RETM m = match_vtag (&tag_s_async, &inquire->asynchronous); RETM m = match_vtag (&tag_s_delim, &inquire->delim); RETM m = match_vtag (&tag_s_decimal, &inquire->decimal); - RETM m = match_vtag (&tag_s_blank, &inquire->blank); + RETM m = match_vtag (&tag_size, &inquire->size); RETM m = match_vtag (&tag_s_encoding, &inquire->encoding); RETM m = match_vtag (&tag_s_round, &inquire->round); RETM m = match_vtag (&tag_s_sign, &inquire->sign); @@ -3501,7 +3797,7 @@ gfc_match_inquire (void) if (m == MATCH_NO) return m; - inquire = gfc_getmem (sizeof (gfc_inquire)); + inquire = XCNEW (gfc_inquire); loc = gfc_current_locus; @@ -3530,7 +3826,7 @@ gfc_match_inquire (void) goto syntax; new_st.op = EXEC_IOLENGTH; - new_st.expr = inquire->iolength; + new_st.expr1 = inquire->iolength; new_st.ext.inquire = inquire; if (gfc_pure (NULL)) @@ -3613,7 +3909,7 @@ cleanup: /* Resolve everything in a gfc_inquire structure. */ -try +gfc_try gfc_resolve_inquire (gfc_inquire *inquire) { RESOLVE_TAG (&tag_unit, inquire->unit); @@ -3650,6 +3946,7 @@ gfc_resolve_inquire (gfc_inquire *inquire) RESOLVE_TAG (&tag_s_sign, inquire->sign); RESOLVE_TAG (&tag_s_round, inquire->round); RESOLVE_TAG (&tag_pending, inquire->pending); + RESOLVE_TAG (&tag_size, inquire->size); RESOLVE_TAG (&tag_id, inquire->id); if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE) @@ -3672,7 +3969,7 @@ gfc_free_wait (gfc_wait *wait) } -try +gfc_try gfc_resolve_wait (gfc_wait *wait) { RESOLVE_TAG (&tag_unit, wait->unit); @@ -3722,7 +4019,7 @@ gfc_match_wait (void) if (m == MATCH_NO) return m; - wait = gfc_getmem (sizeof (gfc_wait)); + wait = XCNEW (gfc_wait); loc = gfc_current_locus;