ST_IF_BLOCK, ST_IMPLICIT, ST_IMPLICIT_NONE, ST_IMPORT, ST_INQUIRE, ST_INTERFACE,
ST_PARAMETER, ST_MODULE, ST_MODULE_PROC, ST_NAMELIST, ST_NULLIFY, ST_OPEN,
ST_PAUSE, ST_PRIVATE, ST_PROGRAM, ST_PUBLIC, ST_READ, ST_RETURN, ST_REWIND,
- ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WRITE,
- ST_ASSIGNMENT, ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE,
+ ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WAIT,
+ ST_WRITE, ST_ASSIGNMENT, ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE,
ST_SIMPLE_IF, ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_LABEL_ASSIGNMENT,
ST_ENUM, ST_ENUMERATOR, ST_END_ENUM,
ST_OMP_ATOMIC, ST_OMP_BARRIER, ST_OMP_CRITICAL, ST_OMP_END_CRITICAL,
typedef struct
{
gfc_expr *unit, *file, *status, *access, *form, *recl,
- *blank, *position, *action, *delim, *pad, *iostat, *iomsg, *convert;
+ *blank, *position, *action, *delim, *pad, *iostat, *iomsg, *convert,
+ *decimal, *encoding, *round, *sign, *asynchronous, *id;
gfc_st_label *err;
}
gfc_open;
gfc_expr *unit, *file, *iostat, *exist, *opened, *number, *named,
*name, *access, *sequential, *direct, *form, *formatted,
*unformatted, *recl, *nextrec, *blank, *position, *action, *read,
- *write, *readwrite, *delim, *pad, *iolength, *iomsg, *convert, *strm_pos;
+ *write, *readwrite, *delim, *pad, *iolength, *iomsg, *convert, *strm_pos,
+ *asynchronous, *decimal, *encoding, *pending, *round, *sign, *size, *id;
gfc_st_label *err;
typedef struct
{
- gfc_expr *io_unit, *format_expr, *rec, *advance, *iostat, *size, *iomsg;
+ gfc_expr *unit, *iostat, *iomsg, *id;
+ gfc_st_label *err, *end, *eor;
+}
+gfc_wait;
+
+
+typedef struct
+{
+ gfc_expr *io_unit, *format_expr, *rec, *advance, *iostat, *size, *iomsg,
+ *id, *pos, *asynchronous, *blank, *decimal, *delim, *pad, *round,
+ *sign;
gfc_symbol *namelist;
/* A format_label of `format_asterisk' indicates the "*" format */
EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT,
EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT,
EXEC_ALLOCATE, EXEC_DEALLOCATE,
- EXEC_OPEN, EXEC_CLOSE,
+ EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT,
EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END,
EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH,
EXEC_OMP_CRITICAL, EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER,
gfc_close *close;
gfc_filepos *filepos;
gfc_inquire *inquire;
+ gfc_wait *wait;
gfc_dt *dt;
gfc_forall_iterator *forall_iterator;
struct gfc_code *whichloop;
try gfc_resolve_inquire (gfc_inquire *);
void gfc_free_dt (gfc_dt *);
try gfc_resolve_dt (gfc_dt *);
+void gfc_free_wait (gfc_wait *);
+try gfc_resolve_wait (gfc_wait *);
/* module.c */
void gfc_module_init_2 (void);
tag_e_action = {"ACTION", " action = %e", BT_CHARACTER},
tag_e_delim = {"DELIM", " delim = %e", BT_CHARACTER},
tag_e_pad = {"PAD", " pad = %e", BT_CHARACTER},
+ tag_e_decimal = {"DECIMAL", " decimal = %e", BT_CHARACTER},
+ tag_e_encoding = {"ENCODING", " encoding = %e", BT_CHARACTER},
+ tag_e_round = {"ROUND", " round = %e", BT_CHARACTER},
+ tag_e_sign = {"SIGN", " sign = %e", BT_CHARACTER},
tag_unit = {"UNIT", " unit = %e", BT_INTEGER},
tag_advance = {"ADVANCE", " advance = %e", BT_CHARACTER},
tag_rec = {"REC", " rec = %e", BT_INTEGER},
tag_strm_out = {"POS", " pos = %v", BT_INTEGER},
tag_err = {"ERR", " err = %l", BT_UNKNOWN},
tag_end = {"END", " end = %l", BT_UNKNOWN},
- tag_eor = {"EOR", " eor = %l", BT_UNKNOWN};
+ tag_eor = {"EOR", " eor = %l", BT_UNKNOWN},
+ tag_async = {"ASYNCHRONOUS", " asynchronous = %e", BT_CHARACTER},
+ tag_id = {"ID", " id = %v", BT_INTEGER};
static gfc_dt *current_dt;
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_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_E, FMT_EXT, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_ERROR, FMT_DC,
+ FMT_DP
}
format_token;
break;
case 'D':
- token = FMT_D;
+ c = next_char_not_space (&error);
+ if (c == 'P')
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DP format "
+ "specifier not allowed at %C") == FAILURE)
+ 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;
+ token = FMT_DC;
+ }
+ else
+ {
+ token = FMT_D;
+ unget_char ();
+ }
break;
case '\0':
case FMT_SIGN:
case FMT_BLANK:
+ case FMT_DP:
+ case FMT_DC:
goto between_desc;
case FMT_CHAR:
{
case FMT_SIGN:
case FMT_BLANK:
+ case FMT_DP:
+ case FMT_DC:
case FMT_X:
break;
{
match m;
+ m = match_etag (&tag_async, &open->asynchronous);
+ if (m != MATCH_NO)
+ return m;
m = match_etag (&tag_unit, &open->unit);
if (m != MATCH_NO)
return m;
if (m != MATCH_NO)
return m;
m = match_etag (&tag_e_pad, &open->pad);
+ if (m != MATCH_NO)
+ return m;
+ m = match_etag (&tag_e_decimal, &open->decimal);
+ if (m != MATCH_NO)
+ return m;
+ m = match_etag (&tag_e_encoding, &open->encoding);
+ if (m != MATCH_NO)
+ return m;
+ m = match_etag (&tag_e_round, &open->round);
+ if (m != MATCH_NO)
+ return m;
+ m = match_etag (&tag_e_sign, &open->sign);
if (m != MATCH_NO)
return m;
m = match_ltag (&tag_err, &open->err);
gfc_free_expr (open->action);
gfc_free_expr (open->delim);
gfc_free_expr (open->pad);
+ gfc_free_expr (open->decimal);
+ gfc_free_expr (open->encoding);
+ gfc_free_expr (open->round);
+ gfc_free_expr (open->sign);
gfc_free_expr (open->convert);
+ gfc_free_expr (open->asynchronous);
gfc_free (open);
}
RESOLVE_TAG (&tag_e_action, open->action);
RESOLVE_TAG (&tag_e_delim, open->delim);
RESOLVE_TAG (&tag_e_pad, open->pad);
+ RESOLVE_TAG (&tag_e_decimal, open->decimal);
+ RESOLVE_TAG (&tag_e_encoding, open->encoding);
+ RESOLVE_TAG (&tag_e_round, open->round);
+ RESOLVE_TAG (&tag_e_sign, open->sign);
RESOLVE_TAG (&tag_convert, open->convert);
if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE)
}
/* Checks on the ASYNCHRONOUS specifier. */
- /* TODO: code is ready, just needs uncommenting when async I/O support
- is added ;-)
- if (open->asynchronous && open->asynchronous->expr_type == EXPR_CONSTANT)
+ if (open->asynchronous)
{
- static const char * asynchronous[] = { "YES", "NO", NULL };
-
- if (!compare_to_allowed_values
- ("action", asynchronous, NULL, NULL,
- open->asynchronous->value.character.string, "OPEN", warn))
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASYNCHRONOUS= at %C "
+ "not allowed in Fortran 95") == FAILURE)
goto cleanup;
- }*/
-
+
+ if (open->asynchronous->expr_type == EXPR_CONSTANT)
+ {
+ static const char * asynchronous[] = { "YES", "NO", NULL };
+
+ if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous,
+ NULL, NULL, open->asynchronous->value.character.string,
+ "OPEN", warn))
+ goto cleanup;
+ }
+ }
+
/* Checks on the BLANK specifier. */
- if (open->blank && open->blank->expr_type == EXPR_CONSTANT)
+ if (open->blank)
{
- static const char *blank[] = { "ZERO", "NULL", NULL };
-
- if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
- open->blank->value.character.string,
- "OPEN", warn))
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C "
+ "not allowed in Fortran 95") == FAILURE)
goto cleanup;
+
+ if (open->blank->expr_type == EXPR_CONSTANT)
+ {
+ static const char *blank[] = { "ZERO", "NULL", NULL };
+
+ if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
+ open->blank->value.character.string,
+ "OPEN", warn))
+ goto cleanup;
+ }
}
/* Checks on the DECIMAL specifier. */
- /* TODO: uncomment this code when DECIMAL support is added
- if (open->decimal && open->decimal->expr_type == EXPR_CONSTANT)
+ if (open->decimal)
{
- static const char * decimal[] = { "COMMA", "POINT", NULL };
-
- if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
- open->decimal->value.character.string,
- "OPEN", warn))
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C "
+ "not allowed in Fortran 95") == FAILURE)
goto cleanup;
- } */
+
+ if (open->decimal->expr_type == EXPR_CONSTANT)
+ {
+ static const char * decimal[] = { "COMMA", "POINT", NULL };
+
+ if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
+ open->decimal->value.character.string,
+ "OPEN", warn))
+ goto cleanup;
+ }
+ }
/* Checks on the DELIM specifier. */
- if (open->delim && open->delim->expr_type == EXPR_CONSTANT)
+ if (open->delim)
{
- static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
-
- if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
- open->delim->value.character.string,
- "OPEN", warn))
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C "
+ "not allowed in Fortran 95") == FAILURE)
goto cleanup;
+
+ if (open->delim->expr_type == EXPR_CONSTANT)
+ {
+ static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
+
+ if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
+ open->delim->value.character.string,
+ "OPEN", warn))
+ goto cleanup;
+ }
}
/* Checks on the ENCODING specifier. */
- /* TODO: uncomment this code when ENCODING support is added
- if (open->encoding && open->encoding->expr_type == EXPR_CONSTANT)
+ if (open->encoding)
{
- static const char * encoding[] = { "UTF-8", "DEFAULT", NULL };
+ /* When implemented, change the following to use gfc_notify_std F2003.
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENCODING= at %C "
+ "not allowed in Fortran 95") == FAILURE)
+ goto cleanup; */
+ gfc_error ("F2003 Feature: ENCODING=specifier at %C not implemented");
+ goto cleanup;
+
+ if (open->encoding->expr_type == EXPR_CONSTANT)
+ {
+ static const char * encoding[] = { "UTF-8", "DEFAULT", NULL };
- if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
- open->encoding->value.character.string,
- "OPEN", warn))
- goto cleanup;
- } */
+ if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
+ open->encoding->value.character.string,
+ "OPEN", warn))
+ goto cleanup;
+ }
+ }
/* Checks on the FORM specifier. */
if (open->form && open->form->expr_type == EXPR_CONSTANT)
}
/* Checks on the ROUND specifier. */
- /* TODO: uncomment this code when ROUND support is added
- if (open->round && open->round->expr_type == EXPR_CONSTANT)
+ if (open->round)
{
- static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
- "COMPATIBLE", "PROCESSOR_DEFINED", NULL };
+ /* When implemented, change the following to use gfc_notify_std F2003. */
+ gfc_error ("F2003 Feature: ROUND=specifier at %C not implemented");
+ goto cleanup;
- if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
- open->round->value.character.string,
- "OPEN", warn))
- goto cleanup;
- } */
+ if (open->round->expr_type == EXPR_CONSTANT)
+ {
+ static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
+ "COMPATIBLE", "PROCESSOR_DEFINED",
+ NULL };
+
+ if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
+ open->round->value.character.string,
+ "OPEN", warn))
+ goto cleanup;
+ }
+ }
/* Checks on the SIGN specifier. */
- /* TODO: uncomment this code when SIGN support is added
- if (open->sign && open->sign->expr_type == EXPR_CONSTANT)
+ if (open->sign)
{
- static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
- NULL };
-
- if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
- open->sign->value.character.string,
- "OPEN", warn))
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
+ "not allowed in Fortran 95") == FAILURE)
goto cleanup;
- } */
+
+ if (open->sign->expr_type == EXPR_CONSTANT)
+ {
+ static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
+ NULL };
+
+ if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
+ open->sign->value.character.string,
+ "OPEN", warn))
+ goto cleanup;
+ }
+ }
#define warn_or_error(...) \
{ \
"OPEN", warn))
goto cleanup;
- /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
- the FILE= specifier shall appear. */
+ /* 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
open->status->value.character.string);
}
- /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
- the FILE= specifier shall not appear. */
+ /* 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)
{
/* Things that are not allowed for unformatted I/O. */
if (open->form && open->form->expr_type == EXPR_CONSTANT
- && (open->delim
- /* TODO uncomment this code when F2003 support is finished */
- /* || open->decimal || open->encoding || open->round
- || open->sign */
- || open->pad || open->blank)
+ && (open->delim || open->decimal || open->encoding || open->round
+ || open->sign || open->pad || open->blank)
&& strncasecmp (open->form->value.character.string,
"unformatted", 11) == 0)
{
return MATCH_YES;
}
+ m = match_etag (&tag_async, &dt->asynchronous);
+ if (m != MATCH_NO)
+ return m;
+ m = match_etag (&tag_e_blank, &dt->blank);
+ if (m != MATCH_NO)
+ return m;
+ m = match_etag (&tag_e_delim, &dt->delim);
+ if (m != MATCH_NO)
+ return m;
+ m = match_etag (&tag_e_pad, &dt->pad);
+ if (m != MATCH_NO)
+ return m;
+ m = match_etag (&tag_e_sign, &dt->sign);
+ if (m != MATCH_NO)
+ return m;
+ m = match_etag (&tag_e_round, &dt->round);
+ if (m != MATCH_NO)
+ return m;
+ m = match_out_tag (&tag_id, &dt->id);
+ if (m != MATCH_NO)
+ return m;
+ m = match_etag (&tag_e_decimal, &dt->decimal);
+ if (m != MATCH_NO)
+ return m;
m = match_etag (&tag_rec, &dt->rec);
if (m != MATCH_NO)
return m;
gfc_free_expr (dt->iomsg);
gfc_free_expr (dt->iostat);
gfc_free_expr (dt->size);
+ gfc_free_expr (dt->pad);
+ gfc_free_expr (dt->delim);
+ gfc_free_expr (dt->sign);
+ gfc_free_expr (dt->round);
+ gfc_free_expr (dt->blank);
+ gfc_free_expr (dt->decimal);
gfc_free (dt);
}
RESOLVE_TAG (&tag_iomsg, dt->iomsg);
RESOLVE_TAG (&tag_iostat, dt->iostat);
RESOLVE_TAG (&tag_size, dt->size);
+ RESOLVE_TAG (&tag_e_pad, dt->pad);
+ RESOLVE_TAG (&tag_e_delim, dt->delim);
+ RESOLVE_TAG (&tag_e_sign, dt->sign);
+ RESOLVE_TAG (&tag_e_round, dt->round);
+ RESOLVE_TAG (&tag_e_blank, dt->blank);
+ RESOLVE_TAG (&tag_e_decimal, dt->decimal);
e = dt->io_unit;
if (gfc_resolve_expr (e) == SUCCESS
match m;
gfc_expr *expr;
gfc_symbol *sym = NULL;
+ bool warn, unformatted;
+
+ warn = (dt->err || dt->iostat) ? true : false;
+ unformatted = dt->format_expr == NULL && dt->format_label == NULL
+ && dt->namelist == NULL;
m = MATCH_YES;
"REC tag at %L is incompatible with internal file",
&dt->rec->where);
- io_constraint (dt->format_expr == NULL && dt->format_label == NULL
- && dt->namelist == NULL,
+ io_constraint (unformatted,
"Unformatted I/O not allowed with internal unit at %L",
&dt->io_unit->where);
+ io_constraint (dt->asynchronous != NULL,
+ "ASYNCHRONOUS tag at %L not allowed with internal file",
+ &dt->asynchronous->where);
+
if (dt->namelist != NULL)
{
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Internal file "
io_kind_name (k));
}
-
if (k != M_READ)
{
io_constraint (dt->end, "END tag not allowed with output at %L",
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",
+ 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
&dt->eor_where);
}
+ if (dt->asynchronous && dt->asynchronous->expr_type == EXPR_CONSTANT)
+ {
+ static const char * asynchronous[] = { "YES", "NO", NULL };
+
+ if (!compare_to_allowed_values
+ ("ASYNCHRONOUS", asynchronous, NULL, NULL,
+ dt->asynchronous->value.character.string,
+ io_kind_name (k), warn))
+ return MATCH_ERROR;
+ }
+
+ if (dt->id)
+ {
+ io_constraint (dt->asynchronous
+ && strcmp (dt->asynchronous->value.character.string,
+ "yes"),
+ "ID=specifier at %L must be with ASYNCHRONOUS='yes' "
+ "specifier", &dt->id->where);
+ }
+
+ if (dt->decimal)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C "
+ "not allowed in Fortran 95") == FAILURE)
+ return MATCH_ERROR;
+
+ if (dt->decimal->expr_type == EXPR_CONSTANT)
+ {
+ static const char * decimal[] = { "COMMA", "POINT", NULL };
+
+ if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
+ dt->decimal->value.character.string,
+ io_kind_name (k), warn))
+ return MATCH_ERROR;
+
+ 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, "Fortran 2003: BLANK= at %C "
+ "not allowed in Fortran 95") == FAILURE)
+ return MATCH_ERROR;
+
+ if (dt->blank->expr_type == EXPR_CONSTANT)
+ {
+ static const char * blank[] = { "NULL", "ZERO", NULL };
+
+ if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
+ dt->blank->value.character.string,
+ io_kind_name (k), warn))
+ return MATCH_ERROR;
+
+ io_constraint (unformatted,
+ "the BLANK=specifier at %L must be with an "
+ "explicit format expression", &dt->blank->where);
+ }
+ }
+
+ if (dt->pad)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PAD= at %C "
+ "not allowed in Fortran 95") == FAILURE)
+ return MATCH_ERROR;
+
+ if (dt->pad->expr_type == EXPR_CONSTANT)
+ {
+ static const char * pad[] = { "YES", "NO", NULL };
+
+ if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
+ dt->pad->value.character.string,
+ io_kind_name (k), warn))
+ return MATCH_ERROR;
+
+ io_constraint (unformatted,
+ "the PAD=specifier at %L must be with an "
+ "explicit format expression", &dt->pad->where);
+ }
+ }
+
+ 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;
+
+ if (dt->round->expr_type == EXPR_CONSTANT)
+ {
+ static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
+ "COMPATIBLE", "PROCESSOR_DEFINED",
+ NULL };
+
+ if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
+ dt->round->value.character.string,
+ io_kind_name (k), warn))
+ return MATCH_ERROR;
+ }
+ }
+
+ if (dt->sign)
+ {
+ /* When implemented, change the following to use gfc_notify_std F2003.
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
+ "not allowed in Fortran 95") == FAILURE)
+ return MATCH_ERROR; */
+ if (dt->sign->expr_type == EXPR_CONSTANT)
+ {
+ static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
+ NULL };
+
+ if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
+ dt->sign->value.character.string,
+ io_kind_name (k), warn))
+ return MATCH_ERROR;
+
+ io_constraint (unformatted,
+ "SIGN=specifier at %L must be with an "
+ "explicit format expression", &dt->sign->where);
+ io_constraint (k == M_READ,
+ "SIGN=specifier at %L not allowed in a "
+ "READ statement", &dt->sign->where);
+ }
+ }
+
+ if (dt->delim)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C "
+ "not allowed in Fortran 95") == FAILURE)
+ return MATCH_ERROR;
+ if (dt->delim->expr_type == EXPR_CONSTANT)
+ {
+ static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
+
+ if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
+ dt->delim->value.character.string,
+ io_kind_name (k), warn))
+ return MATCH_ERROR;
+
+ 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=*",
+ &dt->delim->where);
+
+ io_constraint (unformatted && dt->namelist == NULL,
+ "DELIM=specifier at %L must be with FMT=* or "
+ "NML=specifier ", &dt->delim->where);
+ }
+ }
+
if (dt->namelist)
{
io_constraint (io_code && dt->namelist,
"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);
"List directed format(*) is not allowed with a "
"ADVANCE=specifier at %L.", &expr->where);
- io_constraint (dt->format_expr == NULL && dt->format_label == NULL
- && dt->namelist == NULL,
+ io_constraint (unformatted,
"the ADVANCE=specifier at %L must appear with an "
"explicit format expression", &expr->where);
return match_io (M_READ);
}
+
match
gfc_match_write (void)
{
return match_io (M_WRITE);
}
+
match
gfc_match_print (void)
{
return SUCCESS;
}
+
+
+void
+gfc_free_wait (gfc_wait *wait)
+{
+ if (wait == NULL)
+ return;
+
+ gfc_free_expr (wait->unit);
+ gfc_free_expr (wait->iostat);
+ gfc_free_expr (wait->iomsg);
+ gfc_free_expr (wait->id);
+}
+
+
+try
+gfc_resolve_wait (gfc_wait *wait)
+{
+ RESOLVE_TAG (&tag_unit, wait->unit);
+ RESOLVE_TAG (&tag_iomsg, wait->iomsg);
+ RESOLVE_TAG (&tag_iostat, wait->iostat);
+ RESOLVE_TAG (&tag_id, wait->id);
+
+ if (gfc_reference_st_label (wait->err, ST_LABEL_TARGET) == FAILURE)
+ return FAILURE;
+
+ if (gfc_reference_st_label (wait->end, ST_LABEL_TARGET) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+/* Match an element of a WAIT statement. */
+
+#define RETM if (m != MATCH_NO) return m;
+
+static match
+match_wait_element (gfc_wait *wait)
+{
+ match m;
+
+ m = match_etag (&tag_unit, &wait->unit);
+ RETM m = match_ltag (&tag_err, &wait->err);
+ RETM m = match_ltag (&tag_end, &wait->eor);
+ RETM m = match_ltag (&tag_eor, &wait->end);
+ RETM m = match_out_tag (&tag_iomsg, &wait->iomsg);
+ RETM m = match_out_tag (&tag_iostat, &wait->iostat);
+ RETM m = match_etag (&tag_id, &wait->id);
+ RETM return MATCH_NO;
+}
+
+#undef RETM
+
+
+match
+gfc_match_wait (void)
+{
+ gfc_wait *wait;
+ match m;
+ locus loc;
+
+ m = gfc_match_char ('(');
+ if (m == MATCH_NO)
+ return m;
+
+ wait = gfc_getmem (sizeof (gfc_wait));
+
+ loc = gfc_current_locus;
+
+ m = match_wait_element (wait);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_NO)
+ {
+ m = gfc_match_expr (&wait->unit);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_NO)
+ goto syntax;
+ }
+
+ for (;;)
+ {
+ if (gfc_match_char (')') == MATCH_YES)
+ break;
+ if (gfc_match_char (',') != MATCH_YES)
+ goto syntax;
+
+ m = match_wait_element (wait);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_NO)
+ goto syntax;
+ }
+
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: WAIT at %C "
+ "not allowed in Fortran 95") == FAILURE)
+ goto cleanup;
+
+ if (gfc_pure (NULL))
+ {
+ gfc_error ("WAIT statement not allowed in PURE procedure at %C");
+ goto cleanup;
+ }
+
+ new_st.op = EXEC_WAIT;
+ new_st.ext.wait = wait;
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (ST_WAIT);
+
+cleanup:
+ gfc_free_wait (wait);
+ return MATCH_ERROR;
+}
#define IOPARM_common_end (1 << 3)
#define IOPARM_common_eor (1 << 4)
#endif
-IOPARM (common, flags, 0, int4)
-IOPARM (common, unit, 0, int4)
-IOPARM (common, filename, 0, pchar)
-IOPARM (common, line, 0, int4)
+IOPARM (common, flags, 0, int4)
+IOPARM (common, unit, 0, int4)
+IOPARM (common, filename, 0, pchar)
+IOPARM (common, line, 0, int4)
IOPARM (common, iomsg, 1 << 6, char2)
IOPARM (common, iostat, 1 << 5, pint4)
IOPARM (open, common, 0, common)
IOPARM (open, action, 1 << 14, char2)
IOPARM (open, delim, 1 << 15, char1)
IOPARM (open, pad, 1 << 16, char2)
-IOPARM (open, convert, 1 << 17, char1)
+IOPARM (open, convert, 1 << 17, char1)
+IOPARM (open, decimal, 1 << 18, char2)
+IOPARM (open, encoding, 1 << 19, char1)
+IOPARM (open, round, 1 << 20, char2)
+IOPARM (open, sign, 1 << 21, char1)
+IOPARM (open, asynchronous, 1 << 22, char2)
IOPARM (close, common, 0, common)
IOPARM (close, status, 1 << 7, char1)
IOPARM (filepos, common, 0, common)
IOPARM (inquire, read, 1 << 27, char2)
IOPARM (inquire, write, 1 << 28, char1)
IOPARM (inquire, readwrite, 1 << 29, char2)
-IOPARM (inquire, convert, 1 << 30, char1)
+IOPARM (inquire, convert, 1 << 30, char1)
+IOPARM (inquire, flags2, 1 << 31, int4)
+IOPARM (inquire, asynchronous, 1 << 0, char1)
+IOPARM (inquire, decimal, 1 << 1, char2)
+IOPARM (inquire, encoding, 1 << 2, char1)
+IOPARM (inquire, round, 1 << 3, char2)
+IOPARM (inquire, sign, 1 << 4, char1)
+IOPARM (inquire, pending, 1 << 5, pint4)
+IOPARM (inquire, size, 1 << 6, pint4)
+IOPARM (inquire, id, 1 << 7, pint4)
+IOPARM (wait, common, 0, common)
+IOPARM (wait, id, 1 << 7, pint4)
#ifndef IOPARM_dt_list_format
#define IOPARM_dt_list_format (1 << 7)
#define IOPARM_dt_namelist_read_mode (1 << 8)
IOPARM (dt, advance, 1 << 13, char2)
IOPARM (dt, internal_unit, 1 << 14, char1)
IOPARM (dt, namelist_name, 1 << 15, char2)
-IOPARM (dt, u, 0, pad)
+IOPARM (dt, id, 1 << 16, pint4)
+IOPARM (dt, pos, 1 << 17, intio)
+IOPARM (dt, asynchronous, 1 << 18, char1)
+IOPARM (dt, blank, 1 << 19, char2)
+IOPARM (dt, decimal, 1 << 20, char1)
+IOPARM (dt, delim, 1 << 21, char2)
+IOPARM (dt, pad, 1 << 22, char1)
+IOPARM (dt, round, 1 << 23, char2)
+IOPARM (dt, sign, 1 << 24, char1)
+IOPARM (dt, u, 0, pad)
IOPARM_ptype_filepos,
IOPARM_ptype_inquire,
IOPARM_ptype_dt,
+ IOPARM_ptype_wait,
IOPARM_ptype_num
};
{ "close", NULL },
{ "filepos", NULL },
{ "inquire", NULL },
- { "dt", NULL }
+ { "dt", NULL },
+ { "wait", NULL }
};
static GTY(()) gfc_st_parameter_field st_parameter_field[] =
IOCALL_FLUSH,
IOCALL_SET_NML_VAL,
IOCALL_SET_NML_VAL_DIM,
+ IOCALL_WAIT,
IOCALL_NUM
};
gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
void_type_node, 1, dt_parm_type);
+ parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type);
+ iocall[IOCALL_WAIT] =
+ gfc_build_library_function_decl (get_identifier (PREFIX("st_wait")),
+ gfc_int4_type_node, 1, parm_type);
+
parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
iocall[IOCALL_REWIND] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
if (p->pad)
mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
+ if (p->decimal)
+ mask |= set_string (&block, &post_block, var, IOPARM_open_decimal,
+ p->decimal);
+
+ if (p->encoding)
+ mask |= set_string (&block, &post_block, var, IOPARM_open_encoding,
+ p->encoding);
+
+ if (p->round)
+ mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round);
+
+ if (p->sign)
+ mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign);
+
+ if (p->asynchronous)
+ mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous,
+ p->asynchronous);
+
if (p->convert)
mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
p->convert);
stmtblock_t block, post_block;
gfc_inquire *p;
tree tmp, var;
- unsigned int mask = 0;
+ unsigned int mask = 0, mask2 = 0;
gfc_start_block (&block);
gfc_init_block (&post_block);
mask |= set_parameter_ref (&block, &post_block, var,
IOPARM_inquire_strm_pos_out, p->strm_pos);
+ /* The second series of flags. */
+ if (p->asynchronous)
+ mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous,
+ p->asynchronous);
+
+ if (p->decimal)
+ mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal,
+ p->decimal);
+
+ if (p->encoding)
+ mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding,
+ p->encoding);
+
+ if (p->round)
+ mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round,
+ p->round);
+
+ if (p->sign)
+ mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign,
+ p->sign);
+
+ if (p->pending)
+ mask2 |= set_parameter_ref (&block, &post_block, var,
+ IOPARM_inquire_pending, p->pending);
+
+ if (p->size)
+ mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size,
+ p->size);
+
+ if (p->id)
+ mask2 |= set_parameter_value (&block, var, IOPARM_inquire_id, p->id);
+
+ set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);
+
+ if (mask2)
+ mask |= IOPARM_inquire_flags2;
+
set_parameter_const (&block, var, IOPARM_common_flags, mask);
if (p->unit)
return gfc_finish_block (&block);
}
+
+tree
+gfc_trans_wait (gfc_code * code)
+{
+ stmtblock_t block, post_block;
+ gfc_wait *p;
+ tree tmp, var;
+ unsigned int mask = 0;
+
+ gfc_start_block (&block);
+ gfc_init_block (&post_block);
+
+ var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type,
+ "wait_parm");
+
+ set_error_locus (&block, var, &code->loc);
+ p = code->ext.wait;
+
+ /* Set parameters here. */
+ if (p->iomsg)
+ mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+ p->iomsg);
+
+ if (p->iostat)
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+ p->iostat);
+
+ if (p->err)
+ mask |= IOPARM_common_err;
+
+ if (p->id)
+ mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id);
+
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+ if (p->unit)
+ set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+
+ tmp = build_fold_addr_expr (var);
+ tmp = build_call_expr (iocall[IOCALL_WAIT], 1, tmp);
+ gfc_add_expr_to_block (&block, tmp);
+
+ gfc_add_block_to_block (&block, &post_block);
+
+ io_result (&block, var, p->err, NULL, NULL);
+
+ return gfc_finish_block (&block);
+
+}
+
static gfc_expr *
gfc_new_nml_name_expr (const char * name)
{
if (dt->end)
mask |= IOPARM_common_end;
+ if (dt->id)
+ mask |= set_parameter_ref (&block, &post_end_block, var,
+ IOPARM_dt_id, dt->id);
+
+ if (dt->pos)
+ mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos);
+
+ if (dt->asynchronous)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_asynchronous,
+ dt->asynchronous);
+
+ if (dt->blank)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
+ dt->blank);
+
+ if (dt->decimal)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
+ dt->decimal);
+
+ if (dt->delim)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
+ dt->delim);
+
+ if (dt->pad)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
+ dt->pad);
+
+ if (dt->round)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
+ dt->round);
+
+ if (dt->sign)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
+ dt->sign);
+
if (dt->rec)
mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
projects / gcc.git / commitdiff