/* Deal with I/O statements & related stuff.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+ 2009, 2010
Free Software Foundation, Inc.
Contributed by Andy Vaught
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_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END,
- FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR
+ FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC,
+ FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ
}
format_token;
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;
}
break;
+ case 'R':
+ c = next_char_not_space (&error);
+ switch (c)
+ {
+ case 'C':
+ token = FMT_RC;
+ break;
+ case 'D':
+ token = FMT_RD;
+ break;
+ case 'N':
+ token = FMT_RN;
+ break;
+ case 'P':
+ token = FMT_RP;
+ break;
+ case 'U':
+ token = FMT_RU;
+ break;
+ case 'Z':
+ token = FMT_RZ;
+ break;
+ default:
+ token = FMT_UNKNOWN;
+ unget_char ();
+ break;
+ }
+ break;
+
case '\0':
token = FMT_END;
break;
case FMT_X:
/* X requires a prior number if we're being pedantic. */
+ if (mode != MODE_FORMAT)
+ format_locus.nextc += format_string_pos;
if (gfc_notify_std (GFC_STD_GNU, "Extension: X descriptor "
"requires leading space count at %L", &format_locus)
== FAILURE)
case FMT_BLANK:
case FMT_DP:
case FMT_DC:
+ case FMT_RC:
+ case FMT_RD:
+ case FMT_RN:
+ case FMT_RP:
+ case FMT_RU:
+ case FMT_RZ:
goto between_desc;
case FMT_CHAR:
break;
case FMT_P:
- /* Comma after P is allowed only for F, E, EN, ES, D, or G.
+ /* No comma after P allowed only for F, E, EN, ES, D, or G.
10.1.1 (1). */
t = format_lex ();
if (t == FMT_ERROR)
if (u != FMT_POSINT)
{
format_locus.nextc += format_string_pos;
- gfc_error_now ("Positive width required in format "
+ gfc_error ("Positive width required in format "
"specifier %s at %L", token_to_string (t),
&format_locus);
saved_token = u;
- goto finished;
+ goto fail;
}
u = format_lex ();
format_locus.nextc += format_string_pos;
if (gfc_option.warn_std != 0)
{
- gfc_error_now ("Period required in format "
+ gfc_error ("Period required in format "
"specifier %s at %L", token_to_string (t),
&format_locus);
saved_token = u;
- goto finished;
+ goto fail;
}
else
gfc_warning ("Period required in format "
gfc_warning ("The H format specifier at %L is"
" a Fortran 95 deleted feature", &format_locus);
}
- while (repeat >0)
- {
- next_char (1);
- repeat -- ;
- }
+ if (mode == MODE_STRING)
+ {
+ format_string += value;
+ format_length -= value;
+ format_string_pos += repeat;
+ }
+ else
+ {
+ while (repeat >0)
+ {
+ next_char (1);
+ repeat -- ;
+ }
+ }
break;
case FMT_IBOZ:
default:
if (mode != MODE_FORMAT)
- format_locus.nextc += format_string_pos;
+ format_locus.nextc += format_string_pos - 1;
if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %L",
&format_locus) == FAILURE)
return FAILURE;
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;
}
static gfc_try
check_format_string (gfc_expr *e, bool is_input)
{
+ gfc_try rv;
+ int i;
if (!e || e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
return SUCCESS;
mode = MODE_STRING;
format_string = e->value.character.string;
- 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);
+ rv = check_format (is_input);
+ /* check for extraneous characters at the end of an otherwise valid format
+ string, like '(A10,I3)F5'
+ start at the end and move back to the last character processed,
+ spaces are OK */
+ if (rv == SUCCESS && e->value.character.length > format_string_pos)
+ for (i=e->value.character.length-1;i>format_string_pos-1;i--)
+ if (e->value.character.string[i] != ' ')
+ {
+ format_locus.nextc += format_length + 1;
+ gfc_warning ("Extraneous characters in format at %L", &format_locus);
+ break;
+ }
+ return rv;
}
new_st.loc = start;
new_st.op = EXEC_NOP;
- e = gfc_get_expr();
- e->expr_type = EXPR_CONSTANT;
- e->ts.type = BT_CHARACTER;
- e->ts.kind = gfc_default_character_kind;
- e->where = start;
- e->value.character.string = format_string
- = gfc_get_wide_string (format_length + 1);
- e->value.character.length = format_length;
+ e = gfc_get_character_expr (gfc_default_character_kind, &start,
+ NULL, format_length);
+ format_string = e->value.character.string;
gfc_statement_label->format = e;
mode = MODE_COPY;
if (m == MATCH_NO)
{
m = gfc_match_expr (&open->unit);
- if (m == MATCH_NO)
- goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
}
goto cleanup;
}
}
+ else if (!open->unit)
+ {
+ gfc_error ("OPEN statement at %C must have UNIT or NEWUNIT specified");
+ goto cleanup;
+ }
/* Checks on the ACCESS specifier. */
if (open->access && open->access->expr_type == EXPR_CONSTANT)
/* Checks on the ROUND specifier. */
if (open->round)
{
- /* When implemented, change the following to use gfc_notify_std F2003. */
- gfc_error ("Fortran F2003: ROUND= specifier at %C not implemented");
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran F2003: ROUND= at %C "
+ "not allowed in Fortran 95") == FAILURE)
goto cleanup;
if (open->round->expr_type == EXPR_CONSTANT)
else
unit = 6;
- return gfc_int_expr (unit);
+ return gfc_get_int_expr (gfc_default_integer_kind, NULL, unit);
}
if (dt->round)
{
- /* When implemented, change the following to use gfc_notify_std F2003.
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ROUND= at %C "
"not allowed in Fortran 95") == FAILURE)
- return MATCH_ERROR; */
- gfc_error ("F2003 Feature: ROUND= specifier at %C not implemented");
- return MATCH_ERROR;
+ return MATCH_ERROR;
if (dt->round->expr_type == EXPR_CONSTANT)
{
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;
+ dt->extra_comma = gfc_get_iokind_expr (&gfc_current_locus, k);
}
io_code = NULL;
{
gfc_wait *wait;
match m;
- locus loc;
m = gfc_match_char ('(');
if (m == MATCH_NO)
wait = XCNEW (gfc_wait);
- loc = gfc_current_locus;
-
m = match_wait_element (wait);
if (m == MATCH_ERROR)
goto cleanup;
OSDN Git Service
