Skip to content

R
riscv-gcc-1
Commit 6f0f0b2e by Jerry DeLisle
Options

PR fortran/25829 28655 

2008-04-05  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
	    Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>

	PR fortran/25829 28655
	* dump-parse-tree.c (gfc_show_code_node): Show new I/O parameters.
	* gfortran.h (gfc_statement): Add ST_WAIT enumerator.
	(gfc_open): Add pointers for decimal, encoding, round, sign,
	asynchronous. (gfc_inquire): Add pointers for asynchronous, decimal,
	encoding, pending, round, sign, size, id.
	(gfc_wait): New typedef struct. (gfc_dt): Add pointers for id, pos,
	asynchronous, blank, decimal, delim, pad, round, sign.
	(gfc_exec_op): Add EXEC_WAIT enumerator. (gfc_code): Add pointer for
	wait. (gfc_free_wait), (gfc_resolve_wait): New function prototypes.
	* trans-stmt.h (gfc_trans_wait): New function prototype.
	* trans.c (gfc_trans_code): Add case for EXEC_WAIT.
	* io.c (io_tag): Add new tags for DECIMAL, ENCODING, ROUND, SIGN,
	ASYCHRONOUS, ID. (match_open_element): Add matchers for new tags.
	(gfc_free_open): Free new pointers. (gfc_resolve_open): Resolve new
	tags. (gfc_resolve_open): Remove comment around check for allowed
	values and ASYNCHRONOUS, update it.  Likewise for DECIMAL, ENCODING,
	ROUND, and SIGN. (match_dt_element): Add matching for new tags.
	(gfc_free_wait): New function. (gfc_resolve_wait): New function.
	(match_wait_element): New function. (gfc_match_wait): New function.
	* resolve.c (gfc_resolve_blocks): Add case for EXEC_WAIT.
	(resolve_code): Add case for EXEC_WAIT. 
	* st.c (gfc_free_statement): Add case for EXEC_WAIT.
	* trans-io.c (ioparam_type): Add IOPARM_ptype_wait. (gfc_st_parameter):
	Add "wait" entry. (iocall): Add IOCALL_WAIT enumerator.
	(gfc_build_io_library_fndecls): Add function declaration for st_wait.
	(gfc_trans_open): Add mask bits for new I/O tags.
	(gfc_trans_inquire): Add mask bits for new I/O tags.
	(gfc_trans_wait): New translation function.
	(build_dt): Add mask bits for new I/O tags.
	* match.c (gfc_match_if) Add matcher for "wait".
	* match.h (gfc_match_wait): Prototype for new function.
	* ioparm.def: Add new I/O parameter definitions.
	* parse.c (decode_statement): Add match for "wait" statement.
	(next_statement): Add case for ST_WAIT. (gfc_ascii_statement): Same.

Co-Authored-By: Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>

From-SVN: r133944
parent 10256cbe
Showing with 877 additions and 93 deletions
gcc/fortran/ChangeLog
2008-04-05 Jerry DeLisle <jvdelisle@gcc.gnu.org>
Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/25829 28655
* dump-parse-tree.c (gfc_show_code_node): Show new I/O parameters.
* gfortran.h (gfc_statement): Add ST_WAIT enumerator.
(gfc_open): Add pointers for decimal, encoding, round, sign,
asynchronous. (gfc_inquire): Add pointers for asynchronous, decimal,
encoding, pending, round, sign, size, id.
(gfc_wait): New typedef struct. (gfc_dt): Add pointers for id, pos,
asynchronous, blank, decimal, delim, pad, round, sign.
(gfc_exec_op): Add EXEC_WAIT enumerator. (gfc_code): Add pointer for
wait. (gfc_free_wait), (gfc_resolve_wait): New function prototypes.
* trans-stmt.h (gfc_trans_wait): New function prototype.
* trans.c (gfc_trans_code): Add case for EXEC_WAIT.
* io.c (io_tag): Add new tags for DECIMAL, ENCODING, ROUND, SIGN,
ASYCHRONOUS, ID. (match_open_element): Add matchers for new tags.
(gfc_free_open): Free new pointers. (gfc_resolve_open): Resolve new
tags. (gfc_resolve_open): Remove comment around check for allowed
values and ASYNCHRONOUS, update it. Likewise for DECIMAL, ENCODING,
ROUND, and SIGN. (match_dt_element): Add matching for new tags.
(gfc_free_wait): New function. (gfc_resolve_wait): New function.
(match_wait_element): New function. (gfc_match_wait): New function.
* resolve.c (gfc_resolve_blocks): Add case for EXEC_WAIT.
(resolve_code): Add case for EXEC_WAIT.
* st.c (gfc_free_statement): Add case for EXEC_WAIT.
* trans-io.c (ioparam_type): Add IOPARM_ptype_wait. (gfc_st_parameter):
Add "wait" entry. (iocall): Add IOCALL_WAIT enumerator.
(gfc_build_io_library_fndecls): Add function declaration for st_wait.
(gfc_trans_open): Add mask bits for new I/O tags.
(gfc_trans_inquire): Add mask bits for new I/O tags.
(gfc_trans_wait): New translation function.
(build_dt): Add mask bits for new I/O tags.
* match.c (gfc_match_if) Add matcher for "wait".
* match.h (gfc_match_wait): Prototype for new function.
* ioparm.def: Add new I/O parameter definitions.
* parse.c (decode_statement): Add match for "wait" statement.
(next_statement): Add case for ST_WAIT. (gfc_ascii_statement): Same.
2008-04-03 Jakub Jelinek <jakub@redhat.com>
PR fortran/35786
......
gcc/fortran/dump-parse-tree.c
......@@ -1405,11 +1405,36 @@ gfc_show_code_node (int level, gfc_code *c)
gfc_status (" PAD=");
gfc_show_expr (open->pad);
}
if (open->decimal)
{
gfc_status (" DECIMAL=");
gfc_show_expr (open->decimal);
}
if (open->encoding)
{
gfc_status (" ENCODING=");
gfc_show_expr (open->encoding);
}
if (open->round)
{
gfc_status (" ROUND=");
gfc_show_expr (open->round);
}
if (open->sign)
{
gfc_status (" SIGN=");
gfc_show_expr (open->sign);
}
if (open->convert)
{
gfc_status (" CONVERT=");
gfc_show_expr (open->convert);
}
if (open->asynchronous)
{
gfc_status (" ASYNCHRONOUS=");
gfc_show_expr (open->asynchronous);
}
if (open->err != NULL)
gfc_status (" ERR=%d", open->err->value);
......@@ -1616,6 +1641,46 @@ gfc_show_code_node (int level, gfc_code *c)
gfc_status (" CONVERT=");
gfc_show_expr (i->convert);
}
if (i->asynchronous)
{
gfc_status (" ASYNCHRONOUS=");
gfc_show_expr (i->asynchronous);
}
if (i->decimal)
{
gfc_status (" DECIMAL=");
gfc_show_expr (i->decimal);
}
if (i->encoding)
{
gfc_status (" ENCODING=");
gfc_show_expr (i->encoding);
}
if (i->pending)
{
gfc_status (" PENDING=");
gfc_show_expr (i->pending);
}
if (i->round)
{
gfc_status (" ROUND=");
gfc_show_expr (i->round);
}
if (i->sign)
{
gfc_status (" SIGN=");
gfc_show_expr (i->sign);
}
if (i->size)
{
gfc_status (" SIZE=");
gfc_show_expr (i->size);
}
if (i->id)
{
gfc_status (" ID=");
gfc_show_expr (i->id);
}
if (i->err != NULL)
gfc_status (" ERR=%d", i->err->value);
......@@ -1678,6 +1743,51 @@ gfc_show_code_node (int level, gfc_code *c)
gfc_status (" ADVANCE=");
gfc_show_expr (dt->advance);
}
if (dt->id)
{
gfc_status (" ID=");
gfc_show_expr (dt->id);
}
if (dt->pos)
{
gfc_status (" POS=");
gfc_show_expr (dt->pos);
}
if (dt->asynchronous)
{
gfc_status (" ASYNCHRONOUS=");
gfc_show_expr (dt->asynchronous);
}
if (dt->blank)
{
gfc_status (" BLANK=");
gfc_show_expr (dt->blank);
}
if (dt->decimal)
{
gfc_status (" DECIMAL=");
gfc_show_expr (dt->decimal);
}
if (dt->delim)
{
gfc_status (" DELIM=");
gfc_show_expr (dt->delim);
}
if (dt->pad)
{
gfc_status (" PAD=");
gfc_show_expr (dt->pad);
}
if (dt->round)
{
gfc_status (" ROUND=");
gfc_show_expr (dt->round);
}
if (dt->sign)
{
gfc_status (" SIGN=");
gfc_show_expr (dt->sign);
}
show_dt_code:
gfc_status_char ('\n');
......
gcc/fortran/gfortran.h
......@@ -211,8 +211,8 @@ typedef enum
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,
......@@ -1635,7 +1635,8 @@ gfc_alloc;
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;
......@@ -1662,7 +1663,8 @@ typedef struct
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;
......@@ -1672,7 +1674,17 @@ gfc_inquire;
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 */
......@@ -1701,7 +1713,7 @@ typedef enum
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,
......@@ -1738,6 +1750,7 @@ typedef struct gfc_code
gfc_close *close;
gfc_filepos *filepos;
gfc_inquire *inquire;
gfc_wait *wait;
gfc_dt *dt;
gfc_forall_iterator *forall_iterator;
struct gfc_code *whichloop;
......@@ -2323,6 +2336,8 @@ void gfc_free_inquire (gfc_inquire *);
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);
......
gcc/fortran/io.c
......@@ -48,6 +48,10 @@ static const io_tag
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},
......@@ -82,7 +86,9 @@ static const io_tag
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;
......@@ -97,7 +103,8 @@ 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_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;
......@@ -420,7 +427,26 @@ format_lex (void)
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':
......@@ -537,6 +563,8 @@ format_item_1:
case FMT_SIGN:
case FMT_BLANK:
case FMT_DP:
case FMT_DC:
goto between_desc;
case FMT_CHAR:
......@@ -590,6 +618,8 @@ data_desc:
{
case FMT_SIGN:
case FMT_BLANK:
case FMT_DP:
case FMT_DC:
case FMT_X:
break;
......@@ -1224,6 +1254,9 @@ match_open_element (gfc_open *open)
{
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;
......@@ -1263,6 +1296,18 @@ match_open_element (gfc_open *open)
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);
if (m != MATCH_NO)
return m;
......@@ -1295,7 +1340,12 @@ gfc_free_open (gfc_open *open)
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);
}
......@@ -1319,6 +1369,10 @@ gfc_resolve_open (gfc_open *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)
......@@ -1501,63 +1555,97 @@ gfc_match_open (void)
}
/* 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)
......@@ -1593,30 +1681,43 @@ gfc_match_open (void)
}
/* 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(...) \
{ \
......@@ -1648,8 +1749,8 @@ gfc_match_open (void)
"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
......@@ -1661,8 +1762,8 @@ gfc_match_open (void)
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)
{
......@@ -1674,11 +1775,8 @@ gfc_match_open (void)
/* 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)
{
......@@ -2203,6 +2301,30 @@ match_dt_element (io_kind k, gfc_dt *dt)
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;
......@@ -2265,6 +2387,12 @@ gfc_free_dt (gfc_dt *dt)
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);
}
......@@ -2283,6 +2411,12 @@ gfc_resolve_dt (gfc_dt *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
......@@ -2648,6 +2782,11 @@ if (condition) \
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;
......@@ -2669,11 +2808,14 @@ if (condition) \
"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 "
......@@ -2696,7 +2838,6 @@ if (condition) \
io_kind_name (k));
}
if (k != M_READ)
{
io_constraint (dt->end, "END tag not allowed with output at %L",
......@@ -2705,8 +2846,13 @@ if (condition) \
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
......@@ -2720,8 +2866,167 @@ if (condition) \
&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,
......@@ -2752,7 +3057,6 @@ if (condition) \
"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);
......@@ -2767,8 +3071,7 @@ if (condition) \
"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);
......@@ -3025,12 +3328,14 @@ gfc_match_read (void)
return match_io (M_READ);
}
match
gfc_match_write (void)
{
return match_io (M_WRITE);
}
match
gfc_match_print (void)
{
......@@ -3289,3 +3594,120 @@ gfc_resolve_inquire (gfc_inquire *inquire)
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;
}
gcc/fortran/ioparm.def
......@@ -8,10 +8,10 @@
#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)
......@@ -25,7 +25,12 @@ IOPARM (open, position, 1 << 13, char1)
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)
......@@ -53,7 +58,18 @@ IOPARM (inquire, unformatted, 1 << 26, char1)
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)
......@@ -67,4 +83,13 @@ IOPARM (dt, format, 1 << 12, char1)
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)
gcc/fortran/match.c
......@@ -1533,6 +1533,7 @@ gfc_match_if (gfc_statement *if_type)
match ("return", gfc_match_return, ST_RETURN)
match ("rewind", gfc_match_rewind, ST_REWIND)
match ("stop", gfc_match_stop, ST_STOP)
match ("wait", gfc_match_wait, ST_WAIT)
match ("where", match_simple_where, ST_WHERE)
match ("write", gfc_match_write, ST_WRITE)
......
gcc/fortran/match.h
......@@ -212,6 +212,7 @@ match gfc_match_rewind (void);
match gfc_match_flush (void);
match gfc_match_inquire (void);
match gfc_match_read (void);
match gfc_match_wait (void);
match gfc_match_write (void);
match gfc_match_print (void);
......
gcc/fortran/parse.c
......@@ -440,6 +440,7 @@ decode_statement (void)
break;
case 'w':
match ("wait", gfc_match_wait, ST_WAIT);
match ("write", gfc_match_write, ST_WRITE);
break;
}
......@@ -861,9 +862,9 @@ next_statement (void)
case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
case ST_PAUSE: case ST_STOP: case ST_WRITE: case ST_ASSIGNMENT: \
case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
case ST_OMP_BARRIER
......@@ -1268,6 +1269,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_WHERE:
p = "WHERE";
break;
case ST_WAIT:
p = "WAIT";
break;
case ST_WRITE:
p = "WRITE";
break;
......
gcc/fortran/resolve.c
......@@ -5964,6 +5964,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
case EXEC_READ:
case EXEC_WRITE:
case EXEC_IOLENGTH:
case EXEC_WAIT:
break;
case EXEC_OMP_ATOMIC:
......@@ -6373,6 +6374,15 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
resolve_branch (code->ext.inquire->err, code);
break;
case EXEC_WAIT:
if (gfc_resolve_wait (code->ext.wait) == FAILURE)
break;
resolve_branch (code->ext.wait->err, code);
resolve_branch (code->ext.wait->end, code);
resolve_branch (code->ext.wait->eor, code);
break;
case EXEC_READ:
case EXEC_WRITE:
if (gfc_resolve_dt (code->ext.dt) == FAILURE)
......
gcc/fortran/st.c
......@@ -146,6 +146,10 @@ gfc_free_statement (gfc_code *p)
gfc_free_inquire (p->ext.inquire);
break;
case EXEC_WAIT:
gfc_free_wait (p->ext.wait);
break;
case EXEC_READ:
case EXEC_WRITE:
gfc_free_dt (p->ext.dt);
......
gcc/fortran/trans-io.c
......@@ -45,6 +45,7 @@ enum ioparam_type
IOPARM_ptype_filepos,
IOPARM_ptype_inquire,
IOPARM_ptype_dt,
IOPARM_ptype_wait,
IOPARM_ptype_num
};
......@@ -96,7 +97,8 @@ static GTY(()) gfc_st_parameter st_parameter[] =
{ "close", NULL },
{ "filepos", NULL },
{ "inquire", NULL },
{ "dt", NULL }
{ "dt", NULL },
{ "wait", NULL }
};
static GTY(()) gfc_st_parameter_field st_parameter_field[] =
......@@ -133,6 +135,7 @@ enum iocall
IOCALL_FLUSH,
IOCALL_SET_NML_VAL,
IOCALL_SET_NML_VAL_DIM,
IOCALL_WAIT,
IOCALL_NUM
};
......@@ -372,6 +375,11 @@ gfc_build_io_library_fndecls (void)
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")),
......@@ -921,6 +929,24 @@ gfc_trans_open (gfc_code * code)
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);
......@@ -1117,7 +1143,7 @@ gfc_trans_inquire (gfc_code * code)
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);
......@@ -1248,6 +1274,43 @@ gfc_trans_inquire (gfc_code * code)
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)
......@@ -1266,6 +1329,56 @@ gfc_trans_inquire (gfc_code * code)
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)
{
......@@ -1583,6 +1696,41 @@ build_dt (tree function, gfc_code * code)
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);
......
gcc/fortran/trans-stmt.h
......@@ -69,3 +69,4 @@ tree gfc_trans_flush (gfc_code *);
tree gfc_trans_transfer (gfc_code *);
tree gfc_trans_dt_end (gfc_code *);
tree gfc_trans_wait (gfc_code *);
gcc/fortran/trans.c
......@@ -1108,6 +1108,10 @@ gfc_trans_code (gfc_code * code)
res = gfc_trans_inquire (code);
break;
case EXEC_WAIT:
res = gfc_trans_wait (code);
break;
case EXEC_REWIND:
res = gfc_trans_rewind (code);
break;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment