/* Deal with I/O statements & related stuff.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
- Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
+ Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
#include "parse.h"
gfc_st_label format_asterisk =
- { -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL, 0,
- {NULL, NULL}, NULL, NULL};
+ {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL,
+ 0, {NULL, NULL}};
typedef struct
{
tag_s_delim = {"DELIM", " delim = %v", BT_CHARACTER},
tag_s_pad = {"PAD", " pad = %v", BT_CHARACTER},
tag_iolength = {"IOLENGTH", " iolength = %v", BT_INTEGER},
+ tag_convert = {"CONVERT", " convert = %e", BT_CHARACTER},
tag_err = {"ERR", " err = %l", BT_UNKNOWN},
tag_end = {"END", " end = %l", BT_UNKNOWN},
tag_eor = {"EOR", " eor = %l", BT_UNKNOWN};
use_last_char = 1;
}
+/* Eat up the spaces and return a character. */
+
+static char
+next_char_not_space(void)
+{
+ char c;
+ do
+ {
+ c = next_char (0);
+ }
+ while (gfc_is_whitespace (c));
+ return c;
+}
+
static int value = 0;
/* Simple lexical analyzer for getting the next token in a FORMAT
return token;
}
- do
- {
- c = next_char (0);
- }
- while (gfc_is_whitespace (c));
-
+ c = next_char_not_space ();
+
negative_flag = 0;
switch (c)
{
case '-':
negative_flag = 1;
case '+':
- c = next_char (0);
+ c = next_char_not_space ();
if (!ISDIGIT (c))
{
token = FMT_UNKNOWN;
do
{
- c = next_char (0);
+ c = next_char_not_space ();
if(ISDIGIT (c))
value = 10 * value + c - '0';
}
do
{
- c = next_char (0);
+ c = next_char_not_space ();
if (c != '0')
zflag = 0;
if (ISDIGIT (c))
break;
case 'T':
- c = next_char (0);
+ c = next_char_not_space ();
if (c != 'L' && c != 'R')
unget_char ();
break;
case 'S':
- c = next_char (0);
+ c = next_char_not_space ();
if (c != 'P' && c != 'S')
unget_char ();
break;
case 'B':
- c = next_char (0);
+ c = next_char_not_space ();
if (c == 'N' || c == 'Z')
token = FMT_BLANK;
else
break;
case 'E':
- c = next_char (0);
+ c = next_char_not_space ();
if (c == 'N' || c == 'S')
token = FMT_EXT;
else
if (t == FMT_POSINT)
break;
- error = posint_required;
- goto syntax;
+ switch (gfc_notification_std (GFC_STD_GNU))
+ {
+ case WARNING:
+ gfc_warning
+ ("Extension: Missing positive width after L descriptor at %C");
+ saved_token = t;
+ break;
+
+ case ERROR:
+ error = posint_required;
+ goto syntax;
+
+ case SILENT:
+ saved_token = t;
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+ break;
case FMT_A:
t = format_lex ();
gfc_expr *e;
locus start;
+ if (gfc_current_ns->proc_name
+ && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+ {
+ gfc_error ("Format statement in module main block at %C.");
+ return MATCH_ERROR;
+ }
+
if (gfc_statement_label == NULL)
{
gfc_error ("Missing format label at %C");
return MATCH_ERROR;
}
+ if (m == MATCH_YES
+ && gfc_reference_st_label (*label, ST_LABEL_TARGET) == FAILURE)
+ return MATCH_ERROR;
+
return m;
}
gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
return FAILURE;
}
+
if (tag == &tag_iomsg)
{
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IOMSG tag at %L",
&e->where) == FAILURE)
return FAILURE;
}
+
+ if (tag == &tag_iostat && e->ts.kind != gfc_default_integer_kind)
+ {
+ if (gfc_notify_std (GFC_STD_GNU, "Fortran 95 requires default "
+ "INTEGER in IOSTAT tag at %L",
+ &e->where) == FAILURE)
+ return FAILURE;
+ }
+
+ if (tag == &tag_size && e->ts.kind != gfc_default_integer_kind)
+ {
+ if (gfc_notify_std (GFC_STD_GNU, "Fortran 95 requires default "
+ "INTEGER in SIZE tag at %L",
+ &e->where) == FAILURE)
+ return FAILURE;
+ }
+
+ if (tag == &tag_convert)
+ {
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L",
+ &e->where) == FAILURE)
+ return FAILURE;
+ }
}
return SUCCESS;
m = match_ltag (&tag_err, &open->err);
if (m != MATCH_NO)
return m;
+ m = match_etag (&tag_convert, &open->convert);
+ if (m != MATCH_NO)
+ return m;
return MATCH_NO;
}
gfc_free_expr (open->action);
gfc_free_expr (open->delim);
gfc_free_expr (open->pad);
+ gfc_free_expr (open->convert);
gfc_free (open);
}
RESOLVE_TAG (&tag_iostat, open->iostat);
RESOLVE_TAG (&tag_file, open->file);
RESOLVE_TAG (&tag_status, open->status);
+ RESOLVE_TAG (&tag_e_access, open->access);
RESOLVE_TAG (&tag_e_form, open->form);
RESOLVE_TAG (&tag_e_recl, open->recl);
RESOLVE_TAG (&tag_e_action, open->action);
RESOLVE_TAG (&tag_e_delim, open->delim);
RESOLVE_TAG (&tag_e_pad, open->pad);
+ RESOLVE_TAG (&tag_convert, open->convert);
if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE)
return FAILURE;
return MATCH_YES;
}
- if (gfc_match_st_label (&label, 0) == MATCH_YES)
+ if (gfc_match_st_label (&label) == MATCH_YES)
{
if (dt->format_expr != NULL || dt->format_label != NULL)
{
if (m != MATCH_NO)
return m;
m = match_ltag (&tag_err, &dt->err);
+ if (m == MATCH_YES)
+ dt->err_where = gfc_current_locus;
if (m != MATCH_NO)
return m;
m = match_etag (&tag_advance, &dt->advance);
return FAILURE;
}
- /* Sanity checks on data transfer statements. */
if (e->ts.type == BT_CHARACTER)
{
- if (dt->rec != NULL)
- {
- gfc_error ("REC tag at %L is incompatible with internal file",
- &dt->rec->where);
- return FAILURE;
- }
-
- if (dt->namelist != NULL)
+ if (gfc_has_vector_index (e))
{
- gfc_error ("Internal file at %L is incompatible with namelist",
- &dt->io_unit->where);
+ gfc_error ("Internal unit with vector subscript at %L",
+ &e->where);
return FAILURE;
}
+ }
- if (dt->advance != NULL)
- {
- gfc_error ("ADVANCE tag at %L is incompatible with internal file",
- &dt->advance->where);
- return FAILURE;
- }
+ if (e->rank && e->ts.type != BT_CHARACTER)
+ {
+ gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
+ return FAILURE;
}
- if (dt->rec != NULL)
+ if (dt->err)
{
- if (dt->end != NULL)
+ if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
+ return FAILURE;
+ if (dt->err->defined == ST_LABEL_UNKNOWN)
{
- gfc_error ("REC tag at %L is incompatible with END tag",
- &dt->rec->where);
+ gfc_error ("ERR tag label %d at %L not defined",
+ dt->err->value, &dt->err_where);
return FAILURE;
}
+ }
- if (dt->format_label == &format_asterisk)
+ if (dt->end)
+ {
+ if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE)
+ return FAILURE;
+ if (dt->end->defined == ST_LABEL_UNKNOWN)
{
- gfc_error
- ("END tag at %L is incompatible with list directed format (*)",
- &dt->end_where);
+ gfc_error ("END tag label %d at %L not defined",
+ dt->end->value, &dt->end_where);
return FAILURE;
}
+ }
- if (dt->namelist != NULL)
+ if (dt->eor)
+ {
+ if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE)
+ return FAILURE;
+ if (dt->eor->defined == ST_LABEL_UNKNOWN)
{
- gfc_error ("REC tag at %L is incompatible with namelist",
- &dt->rec->where);
+ gfc_error ("EOR tag label %d at %L not defined",
+ dt->eor->value, &dt->eor_where);
return FAILURE;
}
}
- if (dt->advance != NULL && dt->format_label == &format_asterisk)
- {
- gfc_error ("ADVANCE tag at %L is incompatible with list directed "
- "format (*)", &dt->advance->where);
- return FAILURE;
- }
-
- if (dt->eor != 0 && dt->advance == NULL)
- {
- gfc_error ("EOR tag at %L requires an ADVANCE tag", &dt->eor_where);
- return FAILURE;
- }
-
- if (dt->size != NULL && dt->advance == NULL)
- {
- gfc_error ("SIZE tag at %L requires an ADVANCE tag", &dt->size->where);
- return FAILURE;
- }
-
- /* TODO: Make sure the ADVANCE tag is 'yes' or 'no' if it is a string
- constant. */
-
- if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
- return FAILURE;
-
- if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE)
- return FAILURE;
-
- if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE)
- return FAILURE;
-
/* Check the format label actually exists. */
if (dt->format_label && dt->format_label != &format_asterisk
&& dt->format_label->defined == ST_LABEL_UNKNOWN)
gfc_code *c;
if (io_code == NULL)
- io_code = &new_st;
+ io_code = new_st.block;
c = gfc_get_code ();
c->op = EXEC_DT_END;
}
+/* 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. */
+
+static match
+check_io_constraints (io_kind k, gfc_dt *dt, gfc_code * io_code, locus * spec_end)
+{
+#define io_constraint(condition,msg,arg)\
+if (condition) \
+ {\
+ gfc_error(msg,arg);\
+ m = MATCH_ERROR;\
+ }
+
+ match m;
+ gfc_expr * expr;
+ gfc_symbol * sym = NULL;
+
+ m = MATCH_YES;
+
+ expr = dt->io_unit;
+ if (expr && expr->expr_type == EXPR_VARIABLE
+ && expr->ts.type == BT_CHARACTER)
+ {
+ sym = expr->symtree->n.sym;
+
+ io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
+ "Internal file at %L must not be INTENT(IN)",
+ &expr->where);
+
+ io_constraint (gfc_has_vector_index (dt->io_unit),
+ "Internal file incompatible with vector subscript at %L",
+ &expr->where);
+
+ io_constraint (dt->rec != NULL,
+ "REC tag at %L is incompatible with internal file",
+ &dt->rec->where);
+
+ io_constraint (dt->namelist != NULL,
+ "Internal file at %L is incompatible with namelist",
+ &expr->where);
+
+ io_constraint (dt->advance != NULL,
+ "ADVANCE tag at %L is incompatible with internal file",
+ &dt->advance->where);
+ }
+
+ if (expr && expr->ts.type != BT_CHARACTER)
+ {
+
+ io_constraint (gfc_pure (NULL)
+ && (k == M_READ || k == M_WRITE),
+ "IO UNIT in %s statement at %C must be "
+ "an internal file in a PURE procedure",
+ io_kind_name (k));
+ }
+
+
+ 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 (k != M_READ && 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->namelist)
+ {
+ io_constraint (io_code && dt->namelist,
+ "NAMELIST cannot be followed by IO-list at %L",
+ &io_code->loc);
+
+ io_constraint (dt->format_expr,
+ "IO spec-list cannot contain both NAMELIST group name "
+ "and format specification at %L.",
+ &dt->format_expr->where);
+
+ io_constraint (dt->format_label,
+ "IO spec-list cannot contain both NAMELIST group name "
+ "and format label at %L", spec_end);
+
+ io_constraint (dt->rec,
+ "NAMELIST IO is not allowed with a REC=specifier "
+ "at %L.", &dt->rec->where);
+
+ io_constraint (dt->advance,
+ "NAMELIST IO is not allowed with a ADVANCE=specifier "
+ "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);
+
+
+ io_constraint (dt->format_label == &format_asterisk,
+ "FMT=* is not allowed with a REC=specifier "
+ "at %L.", spec_end);
+ }
+
+ if (dt->advance)
+ {
+ int not_yes, not_no;
+ expr = dt->advance;
+
+ io_constraint (dt->format_label == &format_asterisk,
+ "List directed format(*) is not allowed with a "
+ "ADVANCE=specifier at %L.", &expr->where);
+
+ if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
+ {
+ const char * advance = expr->value.character.string;
+ not_no = strncasecmp (advance, "no", 2) != 0;
+ not_yes = strncasecmp (advance, "yes", 2) != 0;
+ }
+ else
+ {
+ not_no = 0;
+ not_yes = 0;
+ }
+
+ io_constraint (not_no && not_yes,
+ "ADVANCE=specifier at %L must have value = "
+ "YES or NO.", &expr->where);
+
+ io_constraint (dt->size && not_no && k == M_READ,
+ "SIZE tag at %L requires an ADVANCE = 'NO'",
+ &dt->size->where);
+
+ io_constraint (dt->eor && not_no && k == M_READ,
+ "EOR tag at %L requires an ADVANCE = 'NO'",
+ &dt->eor_where);
+ }
+
+ expr = dt->format_expr;
+ if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
+ check_format_string (expr);
+
+ return m;
+}
+#undef io_constraint
+
/* Match a READ, WRITE or PRINT statement. */
static match
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_code *io_code;
gfc_symbol *sym;
- gfc_expr *expr;
int comma_flag, c;
locus where;
+ locus spec_end;
gfc_dt *dt;
match m;
+ where = gfc_current_locus;
comma_flag = 0;
current_dt = dt = gfc_getmem (sizeof (gfc_dt));
if (gfc_match_char ('(') == MATCH_NO)
m = MATCH_ERROR;
goto cleanup;
}
- if (gfc_match_eos () == MATCH_NO)
- {
- gfc_error ("Namelist followed by I/O list at %C");
- m = MATCH_ERROR;
- goto cleanup;
- }
dt->io_unit = default_unit (k);
dt->namelist = sym;
}
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
goto syntax;
}
- /* A full IO statement has been matched. */
- if (dt->io_unit->expr_type == EXPR_VARIABLE
- && k == M_WRITE
- && dt->io_unit->ts.type == BT_CHARACTER
- && dt->io_unit->symtree->n.sym->attr.intent == INTENT_IN)
- {
- gfc_error ("Internal file '%s' at %L is INTENT(IN)",
- dt->io_unit->symtree->n.sym->name, &dt->io_unit->where);
- m = MATCH_ERROR;
- goto cleanup;
- }
-
- expr = dt->format_expr;
+ /* 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 (expr != NULL && expr->expr_type == EXPR_CONSTANT)
- check_format_string (expr);
-
- if (gfc_pure (NULL)
- && (k == M_READ || k == M_WRITE)
- && dt->io_unit->ts.type != BT_CHARACTER)
- {
- gfc_error
- ("io-unit in %s statement at %C must be an internal file in a "
- "PURE procedure", io_kind_name (k));
- m = MATCH_ERROR;
- goto cleanup;
- }
+ if (m == MATCH_ERROR)
+ goto cleanup;
new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
new_st.ext.dt = dt;
- new_st.next = io_code;
+ new_st.block = gfc_get_code ();
+ new_st.block->op = new_st.op;
+ new_st.block->next = io_code;
terminate_io (io_code);
gfc_free_expr (inquire->delim);
gfc_free_expr (inquire->pad);
gfc_free_expr (inquire->iolength);
+ gfc_free_expr (inquire->convert);
gfc_free (inquire);
}
RETM m = match_vtag (&tag_s_delim, &inquire->delim);
RETM m = match_vtag (&tag_s_pad, &inquire->pad);
RETM m = match_vtag (&tag_iolength, &inquire->iolength);
+ RETM m = match_vtag (&tag_convert, &inquire->convert);
RETM return MATCH_NO;
}
if (m == MATCH_NO)
goto syntax;
- terminate_io (code);
-
new_st.op = EXEC_IOLENGTH;
new_st.expr = inquire->iolength;
new_st.ext.inquire = inquire;
return MATCH_ERROR;
}
- new_st.next = code;
+ new_st.block = gfc_get_code ();
+ new_st.block->op = EXEC_IOLENGTH;
+ terminate_io (code);
+ new_st.block->next = code;
return MATCH_YES;
}
RESOLVE_TAG (&tag_s_delim, inquire->delim);
RESOLVE_TAG (&tag_s_pad, inquire->pad);
RESOLVE_TAG (&tag_iolength, inquire->iolength);
+ RESOLVE_TAG (&tag_convert, inquire->convert);
if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
return FAILURE;
OSDN Git Service
