This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [patch, fortran]PR25829 Add support for F2003 I/O features
- From: Jerry DeLisle <jvdelisle at verizon dot net>
- To: Tobias Burnus <tobias dot burnus at physik dot fu-berlin dot de>
- Cc: fortran at gcc dot gnu dot org, gcc-patches at gcc dot gnu dot org
- Date: Mon, 31 Mar 2008 21:30:14 -0700
- Subject: Re: [patch, fortran]PR25829 Add support for F2003 I/O features
- References: <20080329134426.GA15883@physik.fu-berlin.de>
On Sat, 2008-03-29 at 14:44 +0100, Tobias Burnus wrote:
> > - the matchers and checks for asynchronous, decimal, encoding,
> > pending, round, sign, size, id for OPEN, READ, WRITE, and INQUIRE.
> > - New WAIT statement.
>
>
> Remarks regarding diagnostics in the front end
> (Might go beyond your patch and might also regarding unimplemented
> things.)
>
> You should add checks which reject those with -std=f95: Both WAIT and
> DECIMAL= etc. are accepted with -std=f95.
>
> You should add checks for the arguments, the following is not rejected:
> write(99,asynchronous='yesS')
> (They are checked for OPEN not for READ/WRITE)
>
> The following is invalid. Asynchronous I/O is only allowed if io-unit is
> a file-unit-number (C925):
> character(10) :: aa
> WRITE(aa,'(a)',asynchronous='yes')
>
> The following is rejected because the ID= is not recognized:
> WRITE(99,asynchronous='no',id=j)
> (It should be rejected since ID= is invalid for asynchronous='NO')
>
> The following is invalid:
> WRITE(99,decimal="comma")
> The reasons is that only formatted I/O (including namelists) are allowed
> when DECIMAL=, BLANK= (blank is actually not recognized!), PAD=, SIGN=
> or ROUND= appear. (C928).
>
> For completeness:
> WRITE(99,'(a)',delim="zero")
> this is rejected since DELIM= does not seem to be recognized, but the
> example is also wrong: DELIM= is only valid for * or namelists.
>
> > - implements the DECIMAL= feature.
> It would be great if (e.g. in a follow up patch) you could also support
> DP and DC:
> write(*,'(DP,e12.4,DC,e12.4)') 1.2, 1.3
> (currently, they are already rejected by the front end)
>
> > - implements a do nothing stub for the WAIT statement.
> (The Fortran 2003 permits the use of synchronous I/O thus this is OK; but
> it should be in the release notes. Unless, your full implementation is
> almost ready to go in.)
>
> I'm inclined to having encoding=, round=, size= rejected with a not-
> implemented message (e.g. using sorry() of toplev.h or eith gfc_error).
>
The attached updated patch incorporates all constraints and checks
listed above in the front end. It also implements the DP and DC format
specifiers.
If not noticed before, I had an ID= specifier for the OPEN statement.
There is no such thing, so I have deleted that cute feature. Also, the
ID= is suppose to work similarly to IOSTAT only in two directions. The
value set in the transfer statement such as READ or WRITE and then that
variable is intened to be used in subsequent WAIT statements. I think I
have it fixed, but will study that some more. :)
Please give it a spin and test if you can. Any test cases people are
willing to submit would be welcome.
At this point I will begin to work on run time library side stuff and
fix any additional front end problems identified as we continue on here.
Help with testing much appreciated. Regression tested on
x86-64-linux-gnu.
Jerry
Index: gcc/fortran/dump-parse-tree.c
===================================================================
--- gcc/fortran/dump-parse-tree.c (revision 133782)
+++ gcc/fortran/dump-parse-tree.c (working copy)
@@ -1405,11 +1405,36 @@ gfc_show_code_node (int level, gfc_code
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
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
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');
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 133782)
+++ gcc/fortran/gfortran.h (working copy)
@@ -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);
Index: gcc/fortran/trans-stmt.h
===================================================================
--- gcc/fortran/trans-stmt.h (revision 133782)
+++ gcc/fortran/trans-stmt.h (working copy)
@@ -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 *);
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c (revision 133782)
+++ gcc/fortran/trans.c (working copy)
@@ -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;
Index: gcc/fortran/io.c
===================================================================
--- gcc/fortran/io.c (revision 133782)
+++ gcc/fortran/io.c (working copy)
@@ -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, "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, "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,18 +1555,16 @@ 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)
{
static const char * asynchronous[] = { "YES", "NO", NULL };
if (!compare_to_allowed_values
- ("action", asynchronous, NULL, NULL,
+ ("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)
{
@@ -1525,7 +1577,6 @@ gfc_match_open (void)
}
/* Checks on the DECIMAL specifier. */
- /* TODO: uncomment this code when DECIMAL support is added
if (open->decimal && open->decimal->expr_type == EXPR_CONSTANT)
{
static const char * decimal[] = { "COMMA", "POINT", NULL };
@@ -1534,7 +1585,7 @@ gfc_match_open (void)
open->decimal->value.character.string,
"OPEN", warn))
goto cleanup;
- } */
+ }
/* Checks on the DELIM specifier. */
if (open->delim && open->delim->expr_type == EXPR_CONSTANT)
@@ -1548,16 +1599,21 @@ gfc_match_open (void)
}
/* Checks on the ENCODING specifier. */
- /* TODO: uncomment this code when ENCODING support is added
if (open->encoding && open->encoding->expr_type == EXPR_CONSTANT)
{
- static const char * encoding[] = { "UTF-8", "DEFAULT", NULL };
+ /* When implemented, change the following to use gfc_notify_std F2003. */
+ gfc_error ("F2003 Feature: ENCODING=specifier at %C not implemented");
- if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
- open->encoding->value.character.string,
- "OPEN", warn))
- 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;
+ }
+ }
/* Checks on the FORM specifier. */
if (open->form && open->form->expr_type == EXPR_CONSTANT)
@@ -1593,30 +1649,40 @@ 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");
- 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 };
+ /* When implemented, change the following to use gfc_notify_std F2003. */
+ gfc_error ("F2003 Feature: SIGN=specifier at %C not implemented");
- if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
- open->sign->value.character.string,
- "OPEN", warn))
- 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(...) \
{ \
@@ -1674,11 +1740,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 +2266,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 +2352,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 +2376,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 +2747,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 +2773,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 +2803,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 +2811,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 +2831,170 @@ 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[] = { "COMMA", "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; */
+ gfc_error ("F2003 Feature: SIGN=specifier at %C not implemented");
+ 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 +3025,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 +3039,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 +3296,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 +3562,120 @@ gfc_resolve_inquire (gfc_inquire *inquir
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;
+}
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 133782)
+++ gcc/fortran/resolve.c (working copy)
@@ -5964,6 +5964,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_nam
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_namesp
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)
Index: gcc/fortran/st.c
===================================================================
--- gcc/fortran/st.c (revision 133782)
+++ gcc/fortran/st.c (working copy)
@@ -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);
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c (revision 133782)
+++ gcc/fortran/match.c (working copy)
@@ -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)
Index: gcc/fortran/trans-io.c
===================================================================
--- gcc/fortran/trans-io.c (revision 133782)
+++ gcc/fortran/trans-io.c (working copy)
@@ -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_param
{ "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);
Index: gcc/fortran/match.h
===================================================================
--- gcc/fortran/match.h (revision 133782)
+++ gcc/fortran/match.h (working copy)
@@ -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);
Index: gcc/fortran/ioparm.def
===================================================================
--- gcc/fortran/ioparm.def (revision 133782)
+++ gcc/fortran/ioparm.def (working copy)
@@ -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, char
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, c
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)
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c (revision 133782)
+++ gcc/fortran/parse.c (working copy)
@@ -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;
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map (revision 133782)
+++ libgfortran/gfortran.map (working copy)
@@ -950,6 +950,7 @@ GFORTRAN_1.0 {
_gfortran_st_set_nml_var_dim;
_gfortran_st_write;
_gfortran_st_write_done;
+ _gfortran_st_wait;
_gfortran_sum_c10;
_gfortran_sum_c16;
_gfortran_sum_c4;
Index: libgfortran/libgfortran.h
===================================================================
--- libgfortran/libgfortran.h (revision 133782)
+++ libgfortran/libgfortran.h (working copy)
@@ -507,6 +507,11 @@ st_parameter_common;
#define IOPARM_OPEN_HAS_DELIM (1 << 15)
#define IOPARM_OPEN_HAS_PAD (1 << 16)
#define IOPARM_OPEN_HAS_CONVERT (1 << 17)
+#define IOPARM_OPEN_HAS_DECIMAL (1 << 18)
+#define IOPARM_OPEN_HAS_ENCODING (1 << 19)
+#define IOPARM_OPEN_HAS_ROUND (1 << 20)
+#define IOPARM_OPEN_HAS_SIGN (1 << 21)
+#define IOPARM_OPEN_HAS_ASYNCHRONOUS (1 << 22)
/* library start function and end macro. These can be expanded if needed
in the future. cmp is st_parameter_common *cmp */
Index: libgfortran/io/open.c
===================================================================
--- libgfortran/io/open.c (revision 133782)
+++ libgfortran/io/open.c (working copy)
@@ -97,6 +97,39 @@ static const st_option pad_opt[] =
{ NULL, 0}
};
+static const st_option decimal_opt[] =
+{
+ { "point", DECIMAL_POINT},
+ { "comma", DECIMAL_COMMA},
+ { NULL, 0}
+};
+
+static const st_option encoding_opt[] =
+{
+ { "utf-8", ENCODING_UTF8},
+ { "default", ENCODING_DEFAULT},
+ { NULL, 0}
+};
+
+static const st_option round_opt[] =
+{
+ { "up", ROUND_UP},
+ { "down", ROUND_DOWN},
+ { "zero", ROUND_ZERO},
+ { "nearest", ROUND_NEAREST},
+ { "compatible", ROUND_COMPATIBLE},
+ { "processor_defined", ROUND_PROCDEFINED},
+ { NULL, 0}
+};
+
+static const st_option sign_opt[] =
+{
+ { "plus", SIGN_PLUS},
+ { "suppress", SIGN_SUPPRESS},
+ { "processor_defined", SIGN_PROCDEFINED},
+ { NULL, 0}
+};
+
static const st_option convert_opt[] =
{
{ "native", GFC_CONVERT_NATIVE},
@@ -106,6 +139,12 @@ static const st_option convert_opt[] =
{ NULL, 0}
};
+static const st_option async_opt[] =
+{
+ { "yes", ASYNC_YES},
+ { "no", ASYNC_NO},
+ { NULL, 0}
+};
/* Given a unit, test to see if the file is positioned at the terminal
point, and if so, change state from NO_ENDFILE flag to AT_ENDFILE.
@@ -179,6 +218,26 @@ edit_modes (st_parameter_open *opp, gfc_
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"PAD parameter conflicts with UNFORMATTED form in "
"OPEN statement");
+
+ if (flags->decimal != DECIMAL_UNSPECIFIED)
+ generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
+ "DECIMAL parameter conflicts with UNFORMATTED form in "
+ "OPEN statement");
+
+ if (flags->encoding != ENCODING_UNSPECIFIED)
+ generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
+ "ENCODING parameter conflicts with UNFORMATTED form in "
+ "OPEN statement");
+
+ if (flags->round != ROUND_UNSPECIFIED)
+ generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
+ "ROUND parameter conflicts with UNFORMATTED form in "
+ "OPEN statement");
+
+ if (flags->sign != SIGN_UNSPECIFIED)
+ generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
+ "SIGN parameter conflicts with UNFORMATTED form in "
+ "OPEN statement");
}
if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
@@ -190,6 +249,14 @@ edit_modes (st_parameter_open *opp, gfc_
u->flags.delim = flags->delim;
if (flags->pad != PAD_UNSPECIFIED)
u->flags.pad = flags->pad;
+ if (flags->decimal != DECIMAL_UNSPECIFIED)
+ u->flags.decimal = flags->decimal;
+ if (flags->encoding != ENCODING_UNSPECIFIED)
+ u->flags.encoding = flags->encoding;
+ if (flags->round != ROUND_UNSPECIFIED)
+ u->flags.round = flags->round;
+ if (flags->sign != SIGN_UNSPECIFIED)
+ u->flags.sign = flags->sign;
}
/* Reposition the file if necessary. */
@@ -289,6 +356,62 @@ new_unit (st_parameter_open *opp, gfc_un
}
}
+ if (flags->decimal == DECIMAL_UNSPECIFIED)
+ flags->decimal = DECIMAL_POINT;
+ else
+ {
+ if (flags->form == FORM_UNFORMATTED)
+ {
+ generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
+ "DECIMAL parameter conflicts with UNFORMATTED form "
+ "in OPEN statement");
+ goto fail;
+ }
+ }
+
+ if (flags->encoding == ENCODING_UNSPECIFIED)
+ flags->encoding = ENCODING_DEFAULT;
+ else
+ {
+ if (flags->form == FORM_UNFORMATTED)
+ {
+ generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
+ "ENCODING parameter conflicts with UNFORMATTED form in "
+ "OPEN statement");
+ goto fail;
+ }
+ }
+
+ /* NB: the value for ROUND when it's not specified by the user does not
+ have to be PROCESSOR_DEFINED; the standard says that it is
+ processor dependent, and requires that it is one of the
+ possible value (see F2003, 9.4.5.13). */
+ if (flags->round == ROUND_UNSPECIFIED)
+ flags->round = ROUND_PROCDEFINED;
+ else
+ {
+ if (flags->form == FORM_UNFORMATTED)
+ {
+ generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
+ "ROUND parameter conflicts with UNFORMATTED form in "
+ "OPEN statement");
+ goto fail;
+ }
+ }
+
+ if (flags->sign == SIGN_UNSPECIFIED)
+ flags->sign = SIGN_PROCDEFINED;
+ else
+ {
+ if (flags->form == FORM_UNFORMATTED)
+ {
+ generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
+ "SIGN parameter conflicts with UNFORMATTED form in "
+ "OPEN statement");
+ goto fail;
+ }
+ }
+
if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
{
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
@@ -607,6 +730,22 @@ st_open (st_parameter_open *opp)
find_option (&opp->common, opp->pad, opp->pad_len,
pad_opt, "Bad PAD parameter in OPEN statement");
+ flags.decimal = !(cf & IOPARM_OPEN_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
+ find_option (&opp->common, opp->decimal, opp->decimal_len,
+ decimal_opt, "Bad DECIMAL parameter in OPEN statement");
+
+ flags.encoding = !(cf & IOPARM_OPEN_HAS_ENCODING) ? ENCODING_UNSPECIFIED :
+ find_option (&opp->common, opp->encoding, opp->encoding_len,
+ encoding_opt, "Bad ENCODING parameter in OPEN statement");
+
+ flags.round = !(cf & IOPARM_OPEN_HAS_ROUND) ? ROUND_UNSPECIFIED :
+ find_option (&opp->common, opp->round, opp->round_len,
+ round_opt, "Bad ROUND parameter in OPEN statement");
+
+ flags.sign = !(cf & IOPARM_OPEN_HAS_SIGN) ? SIGN_UNSPECIFIED :
+ find_option (&opp->common, opp->sign, opp->sign_len,
+ sign_opt, "Bad SIGN parameter in OPEN statement");
+
flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
find_option (&opp->common, opp->form, opp->form_len,
form_opt, "Bad FORM parameter in OPEN statement");
Index: libgfortran/io/list_read.c
===================================================================
--- libgfortran/io/list_read.c (revision 133782)
+++ libgfortran/io/list_read.c (working copy)
@@ -52,12 +52,12 @@ Boston, MA 02110-1301, USA. */
case '5': case '6': case '7': case '8': case '9'
#define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
- case '\r'
+ case '\r': case ';'
/* This macro assumes that we're operating on a variable. */
#define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
- || c == '\t' || c == '\r')
+ || c == '\t' || c == '\r' || c == ';')
/* Maximum repeat count. Less than ten times the maximum signed int32. */
Index: libgfortran/io/read.c
===================================================================
--- libgfortran/io/read.c (revision 133782)
+++ libgfortran/io/read.c (working copy)
@@ -246,7 +246,8 @@ read_a (st_parameter_dt *dtp, const fnod
dtp->u.p.sf_read_comma = 0;
source = read_block (dtp, &w);
- dtp->u.p.sf_read_comma = 1;
+ dtp->u.p.sf_read_comma =
+ dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
if (source == NULL)
return;
if (w > length)
@@ -601,7 +602,7 @@ read_f (st_parameter_dt *dtp, const fnod
/* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D')
is required at this point */
- if (!isdigit (*p) && *p != '.' && *p != 'd' && *p != 'D'
+ if (!isdigit (*p) && *p != '.' && *p != ',' && *p != 'd' && *p != 'D'
&& *p != 'e' && *p != 'E')
goto bad_float;
@@ -614,6 +615,10 @@ read_f (st_parameter_dt *dtp, const fnod
{
switch (*p)
{
+ case ',':
+ if (dtp->u.p.decimal_status == DECIMAL_COMMA && *p == ',')
+ *p = '.';
+ /* Fall through */
case '.':
if (seen_dp)
goto bad_float;
@@ -852,10 +857,11 @@ read_x (st_parameter_dt *dtp, int n)
&& dtp->u.p.current_unit->bytes_left < n)
n = dtp->u.p.current_unit->bytes_left;
- dtp->u.p.sf_read_comma = 0;
+ dtp->u.p.sf_read_comma =
+ dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
if (n > 0)
read_sf (dtp, &n, 1);
- dtp->u.p.sf_read_comma = 1;
+ dtp->u.p.sf_read_comma = 0;
}
else
dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
Index: libgfortran/io/io.h
===================================================================
--- libgfortran/io/io.h (revision 133782)
+++ libgfortran/io/io.h (working copy)
@@ -35,6 +35,7 @@ Boston, MA 02110-1301, USA. */
#include <setjmp.h>
#include <gthr.h>
+#include <aio.h>
/* Basic types used in data transfers. */
@@ -44,7 +45,6 @@ typedef enum
}
bt;
-
struct st_parameter_dt;
typedef struct stream
@@ -61,6 +61,17 @@ typedef struct stream
}
stream;
+typedef struct gfc_aio
+{
+ int id;
+ struct aiocb *a;
+ struct gfc_aio *next;
+}
+gfc_aio;
+
+typedef enum
+{ SYNC_BUFFERED, SYNC_UNBUFFERED, ASYNC }
+io_mode;
/* Macros for doing file I/O given a stream. */
@@ -205,6 +216,23 @@ typedef enum
unit_pad;
typedef enum
+{ DECIMAL_POINT, DECIMAL_COMMA, DECIMAL_UNSPECIFIED }
+unit_decimal;
+
+typedef enum
+{ ENCODING_UTF8, ENCODING_DEFAULT, ENCODING_UNSPECIFIED }
+unit_encoding;
+
+typedef enum
+{ ROUND_UP, ROUND_DOWN, ROUND_ZERO, ROUND_NEAREST, ROUND_COMPATIBLE,
+ ROUND_PROCDEFINED, ROUND_UNSPECIFIED }
+unit_round;
+
+typedef enum
+{ SIGN_PLUS, SIGN_SUPPRESS, SIGN_PROCDEFINED, SIGN_UNSPECIFIED }
+unit_sign;
+
+typedef enum
{ ADVANCE_YES, ADVANCE_NO, ADVANCE_UNSPECIFIED }
unit_advance;
@@ -212,6 +240,10 @@ typedef enum
{READING, WRITING}
unit_mode;
+typedef enum
+{ ASYNC_YES, ASYNC_NO, AYSYNC_UNSPECIFIED }
+unit_async;
+
#define CHARACTER1(name) \
char * name; \
gfc_charlen_type name ## _len
@@ -233,6 +265,11 @@ typedef struct
CHARACTER1 (delim);
CHARACTER2 (pad);
CHARACTER1 (convert);
+ CHARACTER2 (decimal);
+ CHARACTER1 (encoding);
+ CHARACTER2 (round);
+ CHARACTER1 (sign);
+ CHARACTER2 (asynchronous);
}
st_parameter_open;
@@ -275,6 +312,16 @@ st_parameter_filepos;
#define IOPARM_INQUIRE_HAS_WRITE (1 << 28)
#define IOPARM_INQUIRE_HAS_READWRITE (1 << 29)
#define IOPARM_INQUIRE_HAS_CONVERT (1 << 30)
+#define IOPARM_INQUIRE_HAS_FLAGS2 (1 << 31)
+
+#define IOPARM_INQUIRE_HAS_ASYNCHRONOUS (1 << 0)
+#define IOPARM_INQUIRE_HAS_DECIMAL (1 << 1)
+#define IOPARM_INQUIRE_HAS_ENCODING (1 << 2)
+#define IOPARM_INQUIRE_HAS_PENDING (1 << 3)
+#define IOPARM_INQUIRE_HAS_ROUND (1 << 4)
+#define IOPARM_INQUIRE_HAS_SIGN (1 << 5)
+#define IOPARM_INQUIRE_HAS_SIZE (1 << 6)
+#define IOPARM_INQUIRE_HAS_ID (1 << 7)
typedef struct
{
@@ -299,6 +346,15 @@ typedef struct
CHARACTER1 (write);
CHARACTER2 (readwrite);
CHARACTER1 (convert);
+ GFC_INTEGER_4 flags2;
+ CHARACTER1 (asynchronous);
+ CHARACTER1 (decimal);
+ CHARACTER1 (encoding);
+ CHARACTER1 (pending);
+ CHARACTER1 (round);
+ CHARACTER1 (sign);
+ GFC_INTEGER_4 *size;
+ GFC_IO_INT id;
}
st_parameter_inquire;
@@ -314,6 +370,15 @@ struct format_data;
#define IOPARM_DT_HAS_ADVANCE (1 << 13)
#define IOPARM_DT_HAS_INTERNAL_UNIT (1 << 14)
#define IOPARM_DT_HAS_NAMELIST_NAME (1 << 15)
+#define IOPARM_DT_HAS_ID (1 << 16)
+#define IOPARM_DT_HAS_POS (1 << 17)
+#define IOPARM_DT_HAS_ASYNCHRONOUS (1 << 18)
+#define IOPARM_DT_HAS_BLANK (1 << 19)
+#define IOPARM_DT_HAS_DECIMAL (1 << 20)
+#define IOPARM_DT_HAS_DELIM (1 << 21)
+#define IOPARM_DT_HAS_PAD (1 << 22)
+#define IOPARM_DT_HAS_ROUND (1 << 23)
+#define IOPARM_DT_HAS_SIGN (1 << 24)
/* Internal use bit. */
#define IOPARM_DT_IONML_SET (1 << 31)
@@ -327,6 +392,15 @@ typedef struct st_parameter_dt
CHARACTER2 (advance);
CHARACTER1 (internal_unit);
CHARACTER2 (namelist_name);
+ GFC_IO_INT *id;
+ GFC_IO_INT pos;
+ CHARACTER1 (asynchronous);
+ CHARACTER2 (blank);
+ CHARACTER1 (decimal);
+ CHARACTER2 (delim);
+ CHARACTER1 (pad);
+ CHARACTER2 (round);
+ CHARACTER1 (sign);
/* Private part of the structure. The compiler just needs
to reserve enough space. */
union
@@ -341,7 +415,7 @@ typedef struct st_parameter_dt
int item_count;
unit_mode mode;
unit_blank blank_status;
- enum {SIGN_S, SIGN_SS, SIGN_SP} sign_status;
+ enum { SIGN_S, SIGN_SS, SIGN_SP } sign_status;
int scale_factor;
int max_pos; /* Maximum righthand column written to. */
/* Number of skips + spaces to be done for T and X-editing. */
@@ -354,6 +428,7 @@ typedef struct st_parameter_dt
2 if an EOR was encountered due to a 2-bytes marker (CRLF) */
int sf_seen_eor;
unit_advance advance_status;
+ unit_decimal decimal_status;
unsigned reversion_flag : 1; /* Format reversion has occurred. */
unsigned first_item : 1;
@@ -422,6 +497,16 @@ extern char check_st_parameter_dt[sizeof
>= sizeof (((st_parameter_dt *) 0)->u.p)
? 1 : -1];
+#define IOPARM_WAIT_HAS_ID (1 << 7)
+
+typedef struct
+{
+ st_parameter_common common;
+ CHARACTER1 (id);
+}
+st_parameter_wait;
+
+
#undef CHARACTER1
#undef CHARACTER2
@@ -436,8 +521,13 @@ typedef struct
unit_position position;
unit_status status;
unit_pad pad;
+ unit_decimal decimal;
+ unit_encoding encoding;
+ unit_round round;
+ unit_sign sign;
unit_convert convert;
int has_recl;
+ unit_async async;
}
unit_flags;
@@ -504,7 +594,8 @@ typedef enum
FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_T, FMT_TR, FMT_TL,
FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING,
FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F,
- FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END
+ FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC,
+ FMT_DP
}
format_token;
@@ -748,6 +839,9 @@ internal_proto(next_record);
extern void reverse_memcpy (void *, const void *, size_t);
internal_proto (reverse_memcpy);
+extern void st_wait (st_parameter_wait *);
+export_proto(st_wait);
+
/* read.c */
extern void set_integer (void *, GFC_INTEGER_LARGEST, int);
Index: libgfortran/io/unix.c
===================================================================
--- libgfortran/io/unix.c (revision 133782)
+++ libgfortran/io/unix.c (working copy)
@@ -93,8 +93,6 @@ id_from_fd (const int fd)
#endif
-
-
#ifndef SSIZE_MAX
#define SSIZE_MAX SHRT_MAX
#endif
@@ -153,7 +151,9 @@ typedef struct
int special_file; /* =1 if the fd refers to a special file */
- int unbuffered; /* =1 if the stream is not buffered */
+ io_mode method; /* Method of stream I/O being used */
+
+ gfc_aio *paio; /* Pointer to asynchronous I/O structure */
char *buffer;
char small_buffer[BUFFER_SIZE];
@@ -184,7 +184,8 @@ typedef struct
int special_file; /* =1 if the fd refers to a special file */
- int unbuffered; /* =1 if the stream is not buffered */
+ io_mode method; /* Method of stream I/O being used */
+ gfc_aio *paio; /* Pointer to asynchronous I/O structure */
char *buffer;
}
@@ -238,15 +239,15 @@ move_pos_offset (stream* st, int pos_off
str->logical_offset += pos_off;
if (str->dirty_offset + str->ndirty > str->logical_offset)
- {
- if (str->ndirty + pos_off > 0)
- str->ndirty += pos_off;
- else
- {
- str->dirty_offset += pos_off + pos_off;
- str->ndirty = 0;
- }
- }
+ {
+ if (str->ndirty + pos_off > 0)
+ str->ndirty += pos_off;
+ else
+ {
+ str->dirty_offset += pos_off + pos_off;
+ str->ndirty = 0;
+ }
+ }
return pos_off;
}
@@ -615,23 +616,23 @@ fd_alloc_w_at (unix_stream * s, int *len
|| where > s->dirty_offset + s->ndirty
|| s->dirty_offset > where + *len)
{ /* Discontiguous blocks, start with a clean buffer. */
- /* Flush the buffer. */
- if (s->ndirty != 0)
- fd_flush (s);
- s->dirty_offset = where;
- s->ndirty = *len;
+ /* Flush the buffer. */
+ if (s->ndirty != 0)
+ fd_flush (s);
+ s->dirty_offset = where;
+ s->ndirty = *len;
}
else
{
gfc_offset start; /* Merge with the existing data. */
if (where < s->dirty_offset)
- start = where;
+ start = where;
else
- start = s->dirty_offset;
+ start = s->dirty_offset;
if (where + *len > s->dirty_offset + s->ndirty)
- s->ndirty = where + *len - start;
+ s->ndirty = where + *len - start;
else
- s->ndirty = s->dirty_offset + s->ndirty - start;
+ s->ndirty = s->dirty_offset + s->ndirty - start;
s->dirty_offset = start;
}
@@ -655,7 +656,7 @@ fd_sfree (unix_stream * s)
{
if (s->ndirty != 0 &&
(s->buffer != s->small_buffer || options.all_unbuffered ||
- s->unbuffered))
+ s->method == SYNC_UNBUFFERED))
return fd_flush (s);
return SUCCESS;
@@ -777,7 +778,7 @@ fd_read (unix_stream * s, void * buf, si
void *p;
int tmp, status;
- if (*nbytes < BUFFER_SIZE && !s->unbuffered)
+ if (*nbytes < BUFFER_SIZE && s->method == SYNC_BUFFERED)
{
tmp = *nbytes;
p = fd_alloc_r_at (s, &tmp, -1);
@@ -825,7 +826,7 @@ fd_write (unix_stream * s, const void *
void *p;
int tmp, status;
- if (*nbytes < BUFFER_SIZE && !s->unbuffered)
+ if (*nbytes < BUFFER_SIZE && s->method == SYNC_BUFFERED)
{
tmp = *nbytes;
p = fd_alloc_w_at (s, &tmp, -1);
@@ -874,7 +875,7 @@ fd_close (unix_stream * s)
if (s->fd != STDOUT_FILENO && s->fd != STDERR_FILENO && s->fd != STDIN_FILENO)
{
if (close (s->fd) < 0)
- return FAILURE;
+ return FAILURE;
}
free_mem (s);
@@ -887,7 +888,9 @@ static void
fd_open (unix_stream * s)
{
if (isatty (s->fd))
- s->unbuffered = 1;
+ s->method = SYNC_UNBUFFERED;
+ else
+ s->method = SYNC_BUFFERED;
s->st.alloc_r_at = (void *) fd_alloc_r_at;
s->st.alloc_w_at = (void *) fd_alloc_w_at;
@@ -899,6 +902,7 @@ fd_open (unix_stream * s)
s->st.write = (void *) fd_write;
s->st.set = (void *) fd_sset;
+ s->paio = NULL;
s->buffer = NULL;
}
@@ -1097,6 +1101,7 @@ open_internal (char *base, int length, g
s = get_mem (sizeof (int_stream));
memset (s, '\0', sizeof (int_stream));
+ s->paio = NULL;
s->buffer = base;
s->buffer_offset = offset;
@@ -1224,7 +1229,7 @@ tempfile (st_parameter_open *opp)
do
#if defined(HAVE_CRLF) && defined(O_BINARY)
fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
- S_IREAD | S_IWRITE);
+ S_IREAD | S_IWRITE);
#else
fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IREAD | S_IWRITE);
#endif
@@ -1335,11 +1340,11 @@ regular_file (st_parameter_open *opp, un
if (fd >=0)
{
flags->action = ACTION_READ;
- return fd; /* success */
+ return fd; /* success */
}
if (errno != EACCES)
- return fd; /* failure */
+ return fd; /* failure */
/* retry for write-only access */
rwflag = O_WRONLY;
@@ -1347,9 +1352,9 @@ regular_file (st_parameter_open *opp, un
if (fd >=0)
{
flags->action = ACTION_WRITE;
- return fd; /* success */
+ return fd; /* success */
}
- return fd; /* failure */
+ return fd; /* failure */
}
@@ -1366,7 +1371,7 @@ open_external (st_parameter_open *opp, u
{
fd = tempfile (opp);
if (flags->action == ACTION_UNSPECIFIED)
- flags->action = ACTION_READWRITE;
+ flags->action = ACTION_READWRITE;
#if HAVE_UNLINK_OPEN_FILE
/* We can unlink scratch files now and it will go away when closed. */
@@ -1431,7 +1436,7 @@ output_stream (void)
s = fd_to_stream (STDOUT_FILENO, PROT_WRITE);
if (options.unbuffered_preconnected)
- ((unix_stream *) s)->unbuffered = 1;
+ ((unix_stream *) s)->method = SYNC_UNBUFFERED;
return s;
}
@@ -1450,7 +1455,7 @@ error_stream (void)
s = fd_to_stream (STDERR_FILENO, PROT_WRITE);
if (options.unbuffered_preconnected)
- ((unix_stream *) s)->unbuffered = 1;
+ ((unix_stream *) s)->method = SYNC_UNBUFFERED;
return s;
}
@@ -2050,13 +2055,13 @@ stream_offset (stream *s)
the solution used by f2c. Each record contains a pair of length
markers:
- Length of record n in bytes
- Data of record n
- Length of record n in bytes
-
- Length of record n+1 in bytes
- Data of record n+1
- Length of record n+1 in bytes
+ Length of record n in bytes
+ Data of record n
+ Length of record n in bytes
+
+ Length of record n+1 in bytes
+ Data of record n+1
+ Length of record n+1 in bytes
The length is stored at the end of a record to allow backspacing to the
previous record. Between data transfer statements, the file pointer
Index: libgfortran/io/transfer.c
===================================================================
--- libgfortran/io/transfer.c (revision 133782)
+++ libgfortran/io/transfer.c (working copy)
@@ -93,6 +93,13 @@ static const st_option advance_opt[] = {
};
+static const st_option decimal_opt[] = {
+ {"point", DECIMAL_POINT},
+ {"comma", DECIMAL_COMMA},
+ {NULL, 0}
+};
+
+
typedef enum
{ FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
@@ -910,7 +917,7 @@ formatted_transfer_scalar (st_parameter_
/* Set this flag so that commas in reads cause the read to complete before
the entire field has been read. The next read field will start right after
the comma in the stream. (Set to 0 for character reads). */
- dtp->u.p.sf_read_comma = 1;
+ dtp->u.p.sf_read_comma = dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
dtp->u.p.line_buffer = scratch;
for (;;)
@@ -923,7 +930,7 @@ formatted_transfer_scalar (st_parameter_
next_record (dtp, 0);
}
- consume_data_flag = 1 ;
+ consume_data_flag = 1;
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
break;
@@ -1162,7 +1169,7 @@ formatted_transfer_scalar (st_parameter_
break;
case FMT_STRING:
- consume_data_flag = 0 ;
+ consume_data_flag = 0;
if (dtp->u.p.mode == READING)
{
format_error (dtp, f, "Constant string in input format");
@@ -1278,17 +1285,17 @@ formatted_transfer_scalar (st_parameter_
break;
case FMT_S:
- consume_data_flag = 0 ;
+ consume_data_flag = 0;
dtp->u.p.sign_status = SIGN_S;
break;
case FMT_SS:
- consume_data_flag = 0 ;
+ consume_data_flag = 0;
dtp->u.p.sign_status = SIGN_SS;
break;
case FMT_SP:
- consume_data_flag = 0 ;
+ consume_data_flag = 0;
dtp->u.p.sign_status = SIGN_SP;
break;
@@ -1298,22 +1305,32 @@ formatted_transfer_scalar (st_parameter_
break;
case FMT_BZ:
- consume_data_flag = 0 ;
+ consume_data_flag = 0;
dtp->u.p.blank_status = BLANK_ZERO;
break;
+ case FMT_DC:
+ consume_data_flag = 0;
+ dtp->u.p.decimal_status = DECIMAL_COMMA;
+ break;
+
+ case FMT_DP:
+ consume_data_flag = 0;
+ dtp->u.p.decimal_status = DECIMAL_POINT;
+ break;
+
case FMT_P:
- consume_data_flag = 0 ;
+ consume_data_flag = 0;
dtp->u.p.scale_factor = f->u.k;
break;
case FMT_DOLLAR:
- consume_data_flag = 0 ;
+ consume_data_flag = 0;
dtp->u.p.seen_dollar = 1;
break;
case FMT_SLASH:
- consume_data_flag = 0 ;
+ consume_data_flag = 0;
dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
next_record (dtp, 0);
break;
@@ -1323,7 +1340,7 @@ formatted_transfer_scalar (st_parameter_
particular preventing another / descriptor from being
processed) unless there is another data item to be
transferred. */
- consume_data_flag = 0 ;
+ consume_data_flag = 0;
if (n == 0)
return;
break;
@@ -1769,6 +1786,10 @@ data_transfer_init (st_parameter_dt *dtp
u_flags.delim = DELIM_UNSPECIFIED;
u_flags.blank = BLANK_UNSPECIFIED;
u_flags.pad = PAD_UNSPECIFIED;
+ u_flags.decimal = DECIMAL_UNSPECIFIED;
+ u_flags.encoding = ENCODING_UNSPECIFIED;
+ u_flags.round = ROUND_UNSPECIFIED;
+ u_flags.sign = SIGN_UNSPECIFIED;
u_flags.status = STATUS_UNKNOWN;
conv = get_unformatted_convert (dtp->common.unit);
@@ -1958,6 +1979,16 @@ data_transfer_init (st_parameter_dt *dtp
if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
dtp->u.p.advance_status = ADVANCE_YES;
+ /* Check the decimal mode. */
+
+ dtp->u.p.decimal_status
+ = !(cf & IOPARM_DT_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
+ find_option (&dtp->common, dtp->decimal, dtp->decimal_len, decimal_opt,
+ "Bad DECIMAL parameter in data transfer statement");
+
+ if (dtp->u.p.decimal_status == DECIMAL_UNSPECIFIED)
+ dtp->u.p.decimal_status = dtp->u.p.current_unit->flags.decimal;
+
/* Sanity checks on the record number. */
if ((cf & IOPARM_DT_HAS_REC) != 0)
{
@@ -2926,6 +2957,16 @@ st_write_done (st_parameter_dt *dtp)
library_end ();
}
+
+/* F2003: This is a stub for the runtime portion of the WAIT statement. */
+void
+st_wait (st_parameter_wait *wtp)
+{
+ if (wtp != NULL)
+ *wtp->common.iostat = 0;
+}
+
+
/* Receives the scalar information for namelist objects and stores it
in a linked list of namelist_info types. */
Index: libgfortran/io/format.c
===================================================================
--- libgfortran/io/format.c (revision 133782)
+++ libgfortran/io/format.c (working copy)
@@ -395,7 +395,6 @@ format_lex (format_data *fmt)
unget_char (fmt);
break;
}
-
break;
case 'G':
@@ -415,7 +414,19 @@ format_lex (format_data *fmt)
break;
case 'D':
- token = FMT_D;
+ switch (next_char (fmt, 0))
+ {
+ case 'P':
+ token = FMT_DP;
+ break;
+ case 'C':
+ token = FMT_DC;
+ break;
+ default:
+ token = FMT_D;
+ unget_char (fmt);
+ break;
+ }
break;
case -1:
@@ -550,6 +561,11 @@ parse_format_list (st_parameter_dt *dtp)
tail->repeat = 1;
goto optional_comma;
+ case FMT_DC:
+ case FMT_DP:
+ notify_std (&dtp->common, GFC_STD_F2003, "DC or DP descriptor "
+ "not allowed");
+ /* Fall through. */
case FMT_S:
case FMT_SS:
case FMT_SP:
@@ -576,6 +592,7 @@ parse_format_list (st_parameter_dt *dtp)
notify_std (&dtp->common, GFC_STD_GNU, "Extension: $ descriptor");
goto between_desc;
+
case FMT_T:
case FMT_TL:
case FMT_TR:
Index: libgfortran/io/write.c
===================================================================
--- libgfortran/io/write.c (revision 133782)
+++ libgfortran/io/write.c (working copy)
@@ -361,7 +361,7 @@ write_decimal (st_parameter_dt *dtp, con
if (n < 0)
n = -n;
- nsign = sign == SIGN_NONE ? 0 : 1;
+ nsign = sign == S_NONE ? 0 : 1;
q = conv (n, itoa_buf, sizeof (itoa_buf));
digits = strlen (q);
@@ -395,13 +395,13 @@ write_decimal (st_parameter_dt *dtp, con
switch (sign)
{
- case SIGN_PLUS:
+ case S_PLUS:
*p++ = '+';
break;
- case SIGN_MINUS:
+ case S_MINUS:
*p++ = '-';
break;
- case SIGN_NONE:
+ case S_NONE:
break;
}
Index: libgfortran/io/write_float.def
===================================================================
--- libgfortran/io/write_float.def (revision 133782)
+++ libgfortran/io/write_float.def (working copy)
@@ -31,7 +31,7 @@ Boston, MA 02110-1301, USA. */
#include "config.h"
typedef enum
-{ SIGN_NONE, SIGN_MINUS, SIGN_PLUS }
+{ S_NONE, S_MINUS, S_PLUS }
sign_t;
/* Given a flag that indicates if a value is negative or not, return a
@@ -40,21 +40,21 @@ sign_t;
static sign_t
calculate_sign (st_parameter_dt *dtp, int negative_flag)
{
- sign_t s = SIGN_NONE;
+ sign_t s = S_NONE;
if (negative_flag)
- s = SIGN_MINUS;
+ s = S_MINUS;
else
switch (dtp->u.p.sign_status)
{
case SIGN_SP:
- s = SIGN_PLUS;
+ s = S_PLUS;
break;
case SIGN_SS:
- s = SIGN_NONE;
+ s = S_NONE;
break;
case SIGN_S:
- s = options.optional_plus ? SIGN_PLUS : SIGN_NONE;
+ s = options.optional_plus ? S_PLUS : S_NONE;
break;
}
@@ -336,7 +336,7 @@ output_float (st_parameter_dt *dtp, cons
/* Pick a field size if none was specified. */
if (w <= 0)
- w = nbefore + nzero + nafter + (sign != SIGN_NONE ? 2 : 1);
+ w = nbefore + nzero + nafter + (sign != S_NONE ? 2 : 1);
/* Create the ouput buffer. */
out = write_block (dtp, w);
@@ -362,7 +362,7 @@ output_float (st_parameter_dt *dtp, cons
/* Work out how much padding is needed. */
nblanks = w - (nbefore + nzero + nafter + edigits + 1);
- if (sign != SIGN_NONE)
+ if (sign != S_NONE)
nblanks--;
/* Check the value fits in the specified field width. */
@@ -390,9 +390,9 @@ output_float (st_parameter_dt *dtp, cons
}
/* Output the initial sign (if any). */
- if (sign == SIGN_PLUS)
+ if (sign == S_PLUS)
*(out++) = '+';
- else if (sign == SIGN_MINUS)
+ else if (sign == S_MINUS)
*(out++) = '-';
/* Output an optional leading zero. */
@@ -421,7 +421,7 @@ output_float (st_parameter_dt *dtp, cons
out += nbefore;
}
/* Output the decimal point. */
- *(out++) = '.';
+ *(out++) = dtp->u.p.decimal_status == DECIMAL_POINT ? '.' : ',';
/* Output leading zeros after the decimal point. */
if (nzero > 0)