* [patch, fortran]PR25829 Add support for F2003 I/O features
@ 2008-03-16 21:48 Jerry DeLisle
2008-03-16 22:03 ` FX Coudert
0 siblings, 1 reply; 19+ messages in thread
From: Jerry DeLisle @ 2008-03-16 21:48 UTC (permalink / raw)
To: Fortran List; +Cc: gcc-patches
[-- Attachment #1: Type: text/plain, Size: 5552 bytes --]
:ADDPATCH fortran:
This is a lengthy patch. It was initiated by FX quite some time ago and I have
have taken and advanced it to be useful.
I would like this to go into 4.4 branch for several reasons.
1. So we don't lose it and it is in sync with trunk.
2. It will allow others to see and augment this with any missing checks and
features.
3. It will allow others to exercise and test it.
4. Get the configury magic figured out for using aio.h for systems that support
it. (need help from others on this)
For the gfortran front end the patch implements:
- the matchers and checks for asynchronous, decimal, encoding, pending, round,
sign, size, id for OPEN, READ, WRITE, and INQUIRE.
- New WAIT statement.
For the runtime library:
- implements a do nothing stub for the WAIT statement. I plan another patch
after this that will implement the actual asynchronous I/O.
- implements the DECIMAL= feature.
- Update the handling of sign.
Some very rough beginnings of test cases included.
Regression tested on x86-64. OK for trunk after we get the configury stuff
added for aio.h?
Jerry
2008-03-16 Jerry DeLisle <jvdelisle@gcc.gnu.org>
Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/25829
* 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.
* gfortran.map: Add symbol for _gfortran_st_wait.
2008-03-16 Jerry DeLisle <jvdelisle@gcc.gnu.org>
Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/25829
* libgfortran.h (st_paramter_common): Add new I/O parameters.
* open.c (st_option decimal_opt[], st_option encoding_opt[],
st_option round_opt[], st_option sign_opt[], st_option async_opt[]): New
parameter option arrays. (edit_modes): Add checks for new parameters.
(new_unit): Likewise. (st_open): Likewise.
* list_read.c (CASE_SEPERATORS): Add ';' as a valid seprator.
* read.c (read_a): Use decimal status flag to allow comma in place of a
decimal point. (read_f): Allow comma as acceptable character in float.
According to decimal flag, substitute a period for a comma.
(read_x): If decimal status flag is comma, disable the read_comma flag,
not allowing comma as a delimiter, an extension otherwise.
* io.h: Include aio.h for future asynchronous support.
(gfc_aio): New structure for tracking the aio control block.
(io_mode): New enumerator for keeping track of whether we are doing
the usual synchronous I/O or the new asychronous.
(unit_decimal, unit_encoding, unit_round, unit_sign, unit_async): New
enumerators. Add all new I/O parameters.
* unix.c (unix_stream, int_stream): Add io_mode and pointer for
asychronous I/O control structure.
(move_pos_offset, fd_alloc_w_at): Fix some whitespace.
(fd_sfree): Use new enumerator. (fd_read): Likewise.
(fd_write): Likewise. (fd_close): Fix whitespace.
(fd_open): Use new enumertors and set paio pointer to NULL.
(open_internal): Set paio pointer to NULL. (tempfile, regular_file,
open_external): Fix whitespace. (output_stream, error_stream): Set
method. (stream_offset): Fix whitespace.
* transfer.c (st_option decimal_opt[]): New option array.
(formatted_transfer_scalar): Set sf_read_comma flag based on new
decimal_status flag. (data_transfer_init): Initialize new parameters.
Add checks for decimal mode. (st_wait): Add new stub for WAIT.
* write.c (write_decimal): Use new sign enumerators to set the sign.
* write_float.def: Revise sign enumerators. (calculate_sign): Use new
sign enumerators. (output_float): Likewise. Use new decimal_status flag
to set the decimal character to a point or a comma.
[-- Attachment #2: f2003-io-RevC.diff --]
[-- Type: text/x-patch, Size: 55255 bytes --]
Index: gcc/fortran/dump-parse-tree.c
===================================================================
--- gcc/fortran/dump-parse-tree.c (revision 133275)
+++ 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 133275)
+++ 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;
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 133275)
+++ 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 133275)
+++ 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 133275)
+++ 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 = %e", BT_INTEGER};
static gfc_dt *current_dt;
@@ -1224,6 +1230,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 +1272,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,6 +1316,10 @@ 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 (open);
}
@@ -1319,6 +1344,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->sign);
+ RESOLVE_TAG (&tag_e_encoding, open->round);
+ RESOLVE_TAG (&tag_e_round, open->encoding);
+ RESOLVE_TAG (&tag_e_sign, open->decimal);
RESOLVE_TAG (&tag_convert, open->convert);
if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE)
@@ -1501,17 +1530,15 @@ 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 +1552,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 +1560,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,7 +1574,6 @@ 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 };
@@ -1557,7 +1582,7 @@ gfc_match_open (void)
open->encoding->value.character.string,
"OPEN", warn))
goto cleanup;
- } */
+ }
/* Checks on the FORM specifier. */
if (open->form && open->form->expr_type == EXPR_CONSTANT)
@@ -1593,7 +1618,6 @@ 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)
{
static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
@@ -1603,10 +1627,9 @@ gfc_match_open (void)
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)
{
static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
@@ -1616,7 +1639,7 @@ gfc_match_open (void)
open->sign->value.character.string,
"OPEN", warn))
goto cleanup;
- } */
+ }
#define warn_or_error(...) \
{ \
@@ -1674,11 +1697,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 +2223,12 @@ 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_decimal, &dt->decimal);
+ if (m != MATCH_NO)
+ return m;
m = match_etag (&tag_rec, &dt->rec);
if (m != MATCH_NO)
return m;
@@ -3025,12 +3051,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 +3317,116 @@ 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_pure (NULL))
+ {
+ gfc_error ("WAIT statement not allowed in PURE procedure at %C");
+ return MATCH_ERROR;
+ }
+
+ 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 133275)
+++ gcc/fortran/resolve.c (working copy)
@@ -5997,6 +5997,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:
@@ -6406,6 +6407,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 133275)
+++ 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/trans-io.c
===================================================================
--- gcc/fortran/trans-io.c (revision 133275)
+++ 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.c
===================================================================
--- gcc/fortran/match.c (revision 133275)
+++ 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/match.h
===================================================================
--- gcc/fortran/match.h (revision 133275)
+++ 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 133275)
+++ 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, intio)
+IOPARM (wait, common, 0, common)
+IOPARM (wait, id, 1 << 7, intio)
#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, pintio)
+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 133275)
+++ 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 133275)
+++ libgfortran/gfortran.map (working copy)
@@ -954,6 +954,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 133275)
+++ libgfortran/libgfortran.h (working copy)
@@ -447,6 +447,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 133275)
+++ 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 133275)
+++ 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 133275)
+++ 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 133275)
+++ 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;
@@ -748,6 +838,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 133275)
+++ 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)
{
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 133275)
+++ 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
@@ -915,7 +922,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 (;;)
@@ -1774,6 +1781,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);
@@ -1963,6 +1974,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)
{
@@ -2922,6 +2943,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/write.c
===================================================================
--- libgfortran/io/write.c (revision 133275)
+++ 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 133275)
+++ 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)
[-- Attachment #3: test1.f90 --]
[-- Type: text/x-fortran, Size: 613 bytes --]
real :: a(10), b(10)
real :: c
integer :: istat
character(25) :: msg
a = 23.45
open(10, file='mydata', asynchronous="yes")
write(10,'(10f8.3)', asynchronous="yes", decimal="comma") a
rewind(10)
read(10,'(10f8.3)', asynchronous="yes", decimal="comma") b
print *, b
c = 3.14
write(*, *, decimal="comma") c
rewind(10)
write(10,'(10f8.3)', asynchronous="yes", decimal="point") a
rewind(10)
read(10,'(10f8.3)', asynchronous="yes", decimal="point") b
write(*, *, decimal="comma") b
! Do some stuff b
wait(unit=10, err=25, iostat=istat, iomsg=msg, end=35, id=27)
! Do some stuff with a
25 continue
35 continue
end
[-- Attachment #4: test2.f90 --]
[-- Type: text/x-fortran, Size: 374 bytes --]
integer :: istat
character(25) :: msg
real, dimension(10) :: a, b
a = 43.21
open(10, file='mydata', asynchronous="yes")
write(10,'(10f8.3)', asynchronous="yes", decimal="comma") a
rewind(10)
read(10,'(10f8.3)', asynchronous="yes", decimal="comma") b
istat = 123456
wait(unit=10, err=25, iostat=istat, iomsg=msg, end=35, id=27)
print *, istat
25 continue
35 continue
end
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [patch, fortran]PR25829 Add support for F2003 I/O features
2008-03-16 21:48 [patch, fortran]PR25829 Add support for F2003 I/O features Jerry DeLisle
@ 2008-03-16 22:03 ` FX Coudert
2008-03-17 0:25 ` Jerry DeLisle
0 siblings, 1 reply; 19+ messages in thread
From: FX Coudert @ 2008-03-16 22:03 UTC (permalink / raw)
To: Jerry DeLisle; +Cc: Fortran List, gcc-patches
> I would like this to go into 4.4 branch for several reasons.
>
> 1. So we don't lose it and it is in sync with trunk.
> 2. It will allow others to see and augment this with any missing
> checks and features.
> 3. It will allow others to exercise and test it.
I'd like to know a few things before making my mind: for example, in
its current form, does it introduce new wrong-code or rejects-valid
issues? (I suppose it does, for example with ROUND or SIZE, but I'm
not sure.) If yes, then maybe getting it in a branch while it matures
might be indicated.
Another unrelated question is: does it break ABI compatibility?
> 4. Get the configury magic figured out for using aio.h for systems
> that support it. (need help from others on this)
I'm willing to help here.
Real life has me terribly busy for the weeks to come, but I'll try to
find some time (train or plane) to look into this, even if someone
already has reviewed it.
Thanks,
FX
--
François-Xavier Coudert
http://www.homepages.ucl.ac.uk/~uccafco/
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [patch, fortran]PR25829 Add support for F2003 I/O features
2008-03-16 22:03 ` FX Coudert
@ 2008-03-17 0:25 ` Jerry DeLisle
2008-03-17 7:52 ` Janne Blomqvist
0 siblings, 1 reply; 19+ messages in thread
From: Jerry DeLisle @ 2008-03-17 0:25 UTC (permalink / raw)
To: FX Coudert; +Cc: Fortran List, gcc-patches
FX Coudert wrote:
>> I would like this to go into 4.4 branch for several reasons.
>>
>> 1. So we don't lose it and it is in sync with trunk.
>> 2. It will allow others to see and augment this with any missing
>> checks and features.
>> 3. It will allow others to exercise and test it.
>
> I'd like to know a few things before making my mind: for example, in its
> current form, does it introduce new wrong-code or rejects-valid issues?
> (I suppose it does, for example with ROUND or SIZE, but I'm not sure.)
> If yes, then maybe getting it in a branch while it matures might be
> indicated.
>
I do not believe it will cause any new wrong code issues or reject-valids. The
ROUND and SIZE features, for example are not implemented. If specified, they
would be ignored. In that sense, if someone tried to use them, they would not
get what they might expect. However, we could address that in release notes or
documentation. Or, we could add some simple, "not implemented yet" errors at
compile time for those. Remember there are not too many F2003 compilers around
yet. :)
> Another unrelated question is: does it break ABI compatibility?
AFAICT we can avoid breaking ABI, All the async workings will occur in unix.c
and uses the revised unix_stream structure which is allocated at run time.
Similarly, we have changes in gfc_unit which are allocated at run time, the dtp
structure is changed. It adds decimal_status. If ABI is critical, we can move
that to gfc_unit or do it a little differently. We do add one new symbol to
gfortran.map which we should version, but otherwise no impact.
The approach I am planning will hide asynchronous operations in unix.c. The
standard allows a lot of flexibility here, including ignoring the requests and
waiting for I/O to complete as we are now, or only doing it when we want, for
example, on large arrays only.
>
>> 4. Get the configury magic figured out for using aio.h for systems
>> that support it. (need help from others on this)
>
> I'm willing to help here.
Yes, I need help with this. We need a HAVE_AIO defined so that we do not
compile the the new stuff if not supported or at least address it. I can't
include aio.h if it does not exist.
>
Thanks for questions. Its a start.
Jerry
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [patch, fortran]PR25829 Add support for F2003 I/O features
2008-03-17 0:25 ` Jerry DeLisle
@ 2008-03-17 7:52 ` Janne Blomqvist
0 siblings, 0 replies; 19+ messages in thread
From: Janne Blomqvist @ 2008-03-17 7:52 UTC (permalink / raw)
To: Jerry DeLisle; +Cc: FX Coudert, Fortran List, gcc-patches
Jerry DeLisle wrote:
> AFAICT we can avoid breaking ABI, All the async workings will occur in
> unix.c and uses the revised unix_stream structure which is allocated at
> run time. Similarly, we have changes in gfc_unit which are allocated at
> run time, the dtp structure is changed. It adds decimal_status. If ABI
> is critical, we can move that to gfc_unit or do it a little
> differently.
IMHO ABI compatibility is critical. Having to recompile every single
piece of Fortran code in order to upgrade the compiler is a problem for
some people. Not to say that upgrading might be downright impossible if
they use some library delivered in binary form (e.g. ACML).
The C++ library has some ABI tests in
libstdc++-v3/testsuite/libstdc++-abi , perhaps libgfortran could do
something similar? Another option could be to run the 4.3 testsuite
using the libgfortran from 4.4 (maybe as easy as copying the 4.4
libgfortran into the directory where 4.3 is installed?).
> We do add one new symbol to gfortran.map which we should
> version, but otherwise no impact.
For 4.4 we should put new symbols into a new version node GFORTRAN_1.1
as documented at http://gcc.gnu.org/wiki/SymbolVersioning
> The approach I am planning will hide asynchronous operations in unix.c.
> The standard allows a lot of flexibility here, including ignoring the
> requests and waiting for I/O to complete as we are now, or only doing it
> when we want, for example, on large arrays only.
IIRC on Linux AIO requires that the file is opened with O_DIRECT, and
that all I/O is page size (typically 4 KB) aligned. The AIO syscalls do
work if these conditions are not met, but internally they fall back to a
normal synchronous I/O. I think there are some efforts to rectify this,
but I don't think they have been committed to the mainline kernel yet.
Just something to keep in mind when you want to benchmark the
implementation.
--
Janne Blomqvist
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [patch, fortran]PR25829 Add support for F2003 I/O features
[not found] ` <1207454811.15229.2.camel@lenova.localdomain>
@ 2008-04-06 10:00 ` Tobias Burnus
0 siblings, 0 replies; 19+ messages in thread
From: Tobias Burnus @ 2008-04-06 10:00 UTC (permalink / raw)
To: Jerry DeLisle; +Cc: gcc-patches, 'fortran@gcc.gnu.org'
Jerry DeLisle wrote:
>> PAD= in the open statement works, but PAD= in the read statement seems
>> to be ignored
>
> The main patch is committed. Here is a patch that enables the PAD=
> feature. Regression testing.
>
OK. Thanks for the quick fix.
Tobias
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [patch, fortran]PR25829 Add support for F2003 I/O features
2008-04-05 17:31 ` NightStrike
@ 2008-04-05 17:58 ` Jerry DeLisle
0 siblings, 0 replies; 19+ messages in thread
From: Jerry DeLisle @ 2008-04-05 17:58 UTC (permalink / raw)
To: NightStrike; +Cc: Tobias Burnus, fortran, gcc-patches
On Sat, 2008-04-05 at 12:29 -0400, NightStrike wrote:
> On 4/5/08, Jerry DeLisle <jvdelisle@verizon.net> wrote:
> > After the commit, I will start on the items identified by Tobias.
> >
> > Thanks for review and test case examples.
> >
> > Jerry
> >
> >
>
> Could you also update the Wiki: http://gcc.gnu.org/wiki/Fortran2003 ?
>
> I ask only because I am actively using that wiki to demonstrate the
> current status and capability of gfortran over other solutions.
Yes, we plan to do so.
Jerry
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [patch, fortran]PR25829 Add support for F2003 I/O features
2008-04-05 16:30 ` Jerry DeLisle
@ 2008-04-05 17:31 ` NightStrike
2008-04-05 17:58 ` Jerry DeLisle
[not found] ` <47F7FE02.3070407@net-b.de>
1 sibling, 1 reply; 19+ messages in thread
From: NightStrike @ 2008-04-05 17:31 UTC (permalink / raw)
To: Jerry DeLisle; +Cc: Tobias Burnus, fortran, gcc-patches
On 4/5/08, Jerry DeLisle <jvdelisle@verizon.net> wrote:
> After the commit, I will start on the items identified by Tobias.
>
> Thanks for review and test case examples.
>
> Jerry
>
>
Could you also update the Wiki: http://gcc.gnu.org/wiki/Fortran2003 ?
I ask only because I am actively using that wiki to demonstrate the
current status and capability of gfortran over other solutions.
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [patch, fortran]PR25829 Add support for F2003 I/O features
2008-04-05 12:21 Tobias Burnus
@ 2008-04-05 16:30 ` Jerry DeLisle
2008-04-05 17:31 ` NightStrike
[not found] ` <47F7FE02.3070407@net-b.de>
0 siblings, 2 replies; 19+ messages in thread
From: Jerry DeLisle @ 2008-04-05 16:30 UTC (permalink / raw)
To: Tobias Burnus; +Cc: fortran, gcc-patches
On Sat, 2008-04-05 at 13:32 +0200, Tobias Burnus wrote:
> Hi Jerry,
>
> > The patch is getting too big so i do not want to add any more until we
> > get this in trunk,
> > With that said, I have attached the latest patch and 7 new test cases.
> > OK for trunk.
>
> I think the patch is OK.
>
> I added some more items below, but they can be fixed later.
> (a), (b) and (c) are relatively simply, (d) needs more effort.
> And (e) can be postponed or included in the (a) to (c) patch.
>
Yes all of these of course. Most should be straight forward at this
point. It takes some tedium to do. An example to watch out for is the
sign status mechanism. There are two different enumerators being used.
The original is embedded in the dtp structure. The other is unit_sign in
io.h. The unit_sign is the way to go, however, if it is not ordered
correctly, things break. (I will add that it took some time to figure
that out) Fixing this is on my list.
I plan to commit the patch after the following:
1) clean up ChangeLogs
2) Version the st_wait symbol
3) Cross test the libraries with 4.3
After the commit, I will start on the items identified by Tobias.
Thanks for review and test case examples.
Jerry
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [patch, fortran]PR25829 Add support for F2003 I/O features
@ 2008-04-05 12:21 Tobias Burnus
2008-04-05 16:30 ` Jerry DeLisle
0 siblings, 1 reply; 19+ messages in thread
From: Tobias Burnus @ 2008-04-05 12:21 UTC (permalink / raw)
To: Jerry DeLisle, fortran, gcc-patches
Hi Jerry,
> The patch is getting too big so i do not want to add any more until we
> get this in trunk,
> With that said, I have attached the latest patch and 7 new test cases.
> OK for trunk.
I think the patch is OK.
I added some more items below, but they can be fixed later.
(a), (b) and (c) are relatively simply, (d) needs more effort.
And (e) can be postponed or included in the (a) to (c) patch.
> I forgot a couple of things. I still need to version the new symbol in
> gfortran,map and i still need to test for ABI breakage. I will do this
> while the patch is being reviewed and report back here.
Thanks for remembering this.
a) First test case. The error message of sunf95 is clear and correct
(see C926) (it shows also another error message which is wrong...):
write(10,'(10f8.3)', decimal="comma", id=j) a
^
"test.f90", Line = 13, Column = 43: ERROR: This ID= specifier requires
ASYNCHRONOUS='YES' specifier as well.
Expected: A correct test case and an error message
(Don't forget the asynchronous == 'Yes' check.)
b) The following is invalid as asynchronous= in data-transfer statements (!)
requires an initialization expression; see R913. (In OPEN it does not.)
character(len=10) :: a = 'No'
WRITE(*,*,asynchronous=a) ! invalid
END
The reason is to allow for a faster implemenation as this allows to
generate different code in the front end for READ/WRITE with
and without asynchronous.
c) write(6,*,delim='quote') 'Hello'
Should print "Hello" (with quotes) and not Hello
d) INQUIRE has some problems (-> Follow up patch)
Not recognized: asynchronous=str, decimal=str, encoding=str,
pending=<logical>, round=str, sign=str, size=<integer>
inquire(99,id=j)
-> not recognized, but also invalid without pending=<logical>
!-----------------------------------------------------------
implicit none
character(len=10) :: a,b,c,d,e,f
logical :: log
integer :: id,j
inquire(99,asynchronous=a,blank=b,decimal=c,encoding=d,id=id,pending=log, &
round=E,sign=f,size=j)
print *, 'asynchronous=',a,' blank=',b,' decimal=',c,' encoding=',d, &
' id=',id, ' pending=',log,' round=',E,' sign=',f,'
size=',j
! Expected: all strings 'UNDEFINED' and pending = .false.
END
!-----------------------------------------------------------
e) rounding edit decriptors (ru, rd, etc.) are not recognized by neither
the back nor the front end. Maybe one could recognize them and error out
with a not-implemented message?
Tobias
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [patch, fortran]PR25829 Add support for F2003 I/O features
2008-04-05 9:24 ` Jerry DeLisle
@ 2008-04-05 9:27 ` Jerry DeLisle
0 siblings, 0 replies; 19+ messages in thread
From: Jerry DeLisle @ 2008-04-05 9:27 UTC (permalink / raw)
To: Tobias Burnus; +Cc: Fortran List, gcc-patches
On Sat, 2008-04-05 at 00:48 -0700, Jerry DeLisle wrote:
> I have implemented all of this and then sime. BLANK=, SIGN=, FMT=
> s,ss,sp, dp, dc.
>
> The patch is getting too big so i do not want to add any more until we
> get this in trunk,
>
> With that said, I have attached the latest patch and 7 new test cases.
>
> Regression tested on x86-64-linux-gnu. I will update the ChangeLog from
> the original submit.
>
> OK for trunk.
I forgot a couple of things. I still need to version the new symbol in
gfortran,map and i still need to test for ABI breakage. I will do this
while the patch is being reviewed and report back here.
Thanks for reviews and testing,
Jerry
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [patch, fortran]PR25829 Add support for F2003 I/O features
[not found] ` <47F494AC.30003@net-b.de>
@ 2008-04-05 9:24 ` Jerry DeLisle
2008-04-05 9:27 ` Jerry DeLisle
0 siblings, 1 reply; 19+ messages in thread
From: Jerry DeLisle @ 2008-04-05 9:24 UTC (permalink / raw)
To: Tobias Burnus; +Cc: Fortran List, gcc-patches
[-- Attachment #1: Type: text/plain, Size: 2431 bytes --]
On Thu, 2008-04-03 at 10:26 +0200, Tobias Burnus wrote:
> Jerry DeLisle wrote:
> > On Tue, 2008-04-01 at 13:47 +0200, Tobias Burnus wrote:
> >
> >> Jerry DeLisle wrote:
> >>
> >>> The attached updated patch incorporates all constraints and checks
> >>> listed above in the front end. It also implements the DP and DC format
> >>> specifiers.
> >>>
> >> Thanks. Some more issues and remarks. I will try to review the patch later.
> >>
> > OK, I will work through these. The checks in place now are for EXPR_CONSTANT and not addressing the broader case.
> >
>
> Probably something not yet implemented, but the example from PR 28655
> still fails. (See also references in links in there).
>
> program iotests
> implicit none
> character(len=45) :: a
> real, parameter :: pi = 3.14159265358979323846
> ! write(*,'(f10.3,s,f10.3,sp,f10.3,ss,f10.3)',SIGN='PLUS') pi, pi, pi, pi
> ! write(*,'(f10.3,dc,f10.3,dp,f10.3)',DECIMAL='COMMA') pi, pi, pi
> ! write(6,*,delim='quote') 'Hello'
> open(99,file='test.dat',form='formatted',status='new')
> write(99,'(a)') 'hello'
> close(99)
> open(99,file="test.dat",form='formatted',status='old', &
> PAD='YES',BLANK='NULL',ENCODING='DEFAULT')
> read(99,*,PAD='NO',BLANK='NULL') a
> close(99)
> end program iotests
>
>
>
> read(99,*,PAD='NO',BLANK='NULL') a
> 1
> Error: BLANK specifier in READ statement at (1) has invalid value 'NULL'
>
> Which is invalid as 'ZERO' and 'NULL' are allowed. (By the way German
> "null" is English "zero", which makes the option a bit funny; "null"
> comes from Latin "nullus" none; 'blank'/'zero' would have been better in
> my opinion.)
>
> (However, note: "C912 (R913) A BLANK=, PAD=, END=, EOR=, or SIZE=
> specifier shall not appear in a write-stmt.")
>
> * * *
>
> For completeness, the following edit descriptors are still unsupported
> in the FE / library: ss, sp, s (10.7.4) for sign; ru, rd, rz, rn, rc, rp
> for round; bn, bz for blank. (dc and dp for decimal already fully work :-)
I have implemented all of this and then sime. BLANK=, SIGN=, FMT=
s,ss,sp, dp, dc.
The patch is getting too big so i do not want to add any more until we
get this in trunk,
With that said, I have attached the latest patch and 7 new test cases.
Regression tested on x86-64-linux-gnu. I will update the ChangeLog from
the original submit.
OK for trunk.
Jerry
[-- Attachment #2: f2003_io_1.f90 --]
[-- Type: text/x-fortran, Size: 824 bytes --]
! { dg-do run }
! { dg-options "-std=gnu" }
! Test case prepared by Jerry DeLisle <jvdelisle@gcc.gnu.org>
real :: a(4), b(4)
real :: c
integer :: istat, j
character(25) :: msg
a = 23.45
b = 0.0
open(10, file='mydata', asynchronous="yes", blank="null")
write(10,'(10f8.3)', decimal="comma", id=j) a
rewind(10)
read(10,'(10f8.3)', asynchronous="yes", decimal="comma", blank="zero") b
if (any(b.ne.23.45)) call abort
c = 3.14
write(msg, *, decimal="comma") c
if (msg(1:7).ne." 3,14") call abort
b = 0.0
rewind(10)
write(10,'(10f8.3)', asynchronous="yes", decimal="point") a
rewind(10)
read(10,'(10f8.3)', asynchronous="yes", decimal="point") b
if (any(b.ne.23.45)) call abort
wait(unit=10, err=25, iostat=istat, iomsg=msg, end=35, id=j)
! do some stuff with a
25 continue
35 continue
close(10, status="delete")
end
[-- Attachment #3: f2003_io_2.f90 --]
[-- Type: text/x-fortran, Size: 508 bytes --]
! { dg-do compile }
! { dg-options "-std=f2003" }
! Test case prepared by Jerry DeLisle <jvdelisle@gcc.gnu.org>
integer :: istat, idvar
character(25) :: msg
real, dimension(10) :: a, b
a = 43.21
open(10, file='mydata', asynchronous="yes")
write(10,'(10f8.3)', asynchronous="yes", decimal="comma") a
rewind(10)
read(10,'(10f8.3)', asynchronous="yes", decimal="comma", id=idvar) b
istat = 123456
wait(unit=10, err=25, iostat=istat, iomsg=msg, end=35, id=idvar)
print *, istat
25 continue
35 continue
end
[-- Attachment #4: f2003_io_3.f90 --]
[-- Type: text/x-fortran, Size: 537 bytes --]
! { dg-do compile }
! { dg-options "-std=f2003" }
! Test case prepared by Jerry DeLisle <jvdelisle@gcc.gnu.org>
integer :: istat
character(25) :: msg
real, dimension(10) :: a, b
namelist /mynml/ a, b
msg = "null"
a = 43.21
WRITE(99,'(10f8.3)',decimal="comma") a
rewind(99)
read(99,'(dc,10f8.3)',blank=msg) b
write(99,'(dp,10f8.3)',round="up") ! { dg-error "not implemented" }
rewind(99)
read(99,'(10f8.3)',pad="yes")
msg="suppress"
write(99,'(10f8.3)',sign=msg)
write(99,delim="apostrophe", fmt=*)
write(99,nml=mynml,delim="none")
end
[-- Attachment #5: f2003_io_4.f90 --]
[-- Type: text/x-fortran, Size: 706 bytes --]
! { dg-do run }
! Test case prepared by Jerry DeLisle <jvdelisle@gcc.gnu.org>
! Test of decimal= feature
integer :: istat
character(80) :: msg
real, dimension(4) :: a, b, c
namelist /mynml/ a, b
msg = "yes"
a = 43.21
b = 3.131
c = 5.432
open(99, decimal="comma")
write(99,'(10f8.3)') a
a = 0.0
rewind(99)
read(99,'(10f8.3)') a
if (any(a.ne.43.21)) call abort
write(msg,'(dp,f8.3,dc,f8.2,dp,f8.3)', decimal="comma") a(1), b(1), c(1)
if (trim(msg).ne." 43.210 3,13 5.432") call abort
close(99, status="delete")
open(99, decimal="comma")
write(99,nml=mynml)
a = 0.0
b = 0.0
rewind(99)
read(99,nml=mynml)
if (any(a.ne.43.21)) call abort
if (any(b.ne.3.131)) call abort
close(99, status="delete")
end
[-- Attachment #6: f2003_io_5.f90 --]
[-- Type: text/x-fortran, Size: 714 bytes --]
! { dg-do run }
! Test case prepared by Jerry DeLisle <jvdelisle@gcc.gnu.org>
! Test of decimal="comma" in namelist and complex
integer :: i
real :: a(10) = [ (i*1.3, i=1,10) ]
real :: b(10)
complex :: c
character(34) :: complex
namelist /nm/ a
open(99,file="mynml",form="formatted",decimal="point",status="replace")
write(99,nml=nm,decimal="comma")
a = 5.55
rewind(99)
read(99,nml=nm,decimal="comma")
if (any (a /= [ (i*1.3, i=1,10) ])) call abort
close(99, status="delete")
c = (3.123,4.456)
write(complex,*,decimal="comma") c
if (complex.ne." ( 3,1229999 ; 4,4559999 )") call abort
c = (0.0, 0.0)
read(complex,*,decimal="comma") c
if (complex.ne." ( 3,1229999 ; 4,4559999 )") call abort
end
[-- Attachment #7: f2003_io_6.f03 --]
[-- Type: text/plain, Size: 350 bytes --]
! { dg-do run }
! Test case prepared by Jerry DeLisle <jvdelisle@gcc.gnu.org>
! Test of decimal="comma" in namelist, checks separators
implicit none
integer :: i
real :: a(6) = 0.0
character(len=30) :: str = '&nm a = 1,3; 4, 5; 5; 7; /'
namelist /nm/ a
read(str,nml=nm,decimal='comma')
if (any(a.ne.[ 1.3, 4.0, 5.0, 5.0, 7.0, 0.0 ])) call abort
end
[-- Attachment #8: f2003_io_7.f03 --]
[-- Type: text/plain, Size: 939 bytes --]
! { dg-do run }
! Test case prepared by Jerry DeLisle <jvdelisle@gcc.gnu.org>
! Test of sign=, decimal=, and blank= .
program iotests
implicit none
character(len=45) :: a
character(len=4) :: mode = "what"
real, parameter :: pi = 3.14159265358979323846
real(kind=8), dimension(3) :: b
!
write(a,'(f10.3,s,f10.3,sp,f10.3,ss,f10.3)',SIGN='PLUS') pi, pi, pi, pi
if (a /= " +3.142 3.142 +3.142 3.142") call abort
!
open(8,sign="plus")
write(8,'(f10.3,dc,f10.3,dp,f10.3)',DECIMAL='COMMA',&
& sign="suppress") pi, pi, pi
rewind(8)
read(8,'(a)') a
if (a /= " 3,142 3,142 3.142") call abort
close(8,status="delete")
!
! "123456789 123456789 12345678901
write(a,'(a)') "53 256.84, 2 2 2. ; 33.3 3 1 "
read(a, '(f9.2,1x,f8.2,2x,f11.7)', blank="zero") b(1),b(2),b(3)
if (any(abs(b - [530256.84, 20202.00, 33.3030001]) > .03)) call abort
end program iotests
[-- Attachment #9: f2003-io-RevG.diff --]
[-- Type: text/x-patch, Size: 81523 bytes --]
Index: gcc/fortran/dump-parse-tree.c
===================================================================
--- gcc/fortran/dump-parse-tree.c (revision 133930)
+++ 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 133930)
+++ 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 133930)
+++ 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 133930)
+++ 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 133930)
+++ 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, "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 *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 133930)
+++ 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 133930)
+++ 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 133930)
+++ 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 133930)
+++ 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 133930)
+++ 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 133930)
+++ 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 133930)
+++ 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 133930)
+++ 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 133930)
+++ 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 133930)
+++ 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 133930)
+++ 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. */
@@ -323,6 +323,13 @@ eat_separator (st_parameter_dt *dtp)
switch (c)
{
case ',':
+ if (dtp->u.p.decimal_status == DECIMAL_COMMA)
+ {
+ unget_char (dtp, c);
+ break;
+ }
+ /* Fall through. */
+ case ';':
dtp->u.p.comma_flag = 1;
eat_spaces (dtp);
break;
@@ -666,6 +673,7 @@ read_logical (st_parameter_dt *dtp, int
unget_char (dtp, c);
break;
+
case '.':
c = tolower (next_char (dtp));
switch (c)
@@ -1115,6 +1123,9 @@ parse_real (st_parameter_dt *dtp, void *
c = next_char (dtp);
}
+ if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+ c = '.';
+
if (!isdigit (c) && c != '.')
{
if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
@@ -1130,6 +1141,8 @@ parse_real (st_parameter_dt *dtp, void *
for (;;)
{
c = next_char (dtp);
+ if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+ c = '.';
switch (c)
{
CASE_DIGITS:
@@ -1299,7 +1312,8 @@ eol_1:
else
unget_char (dtp, c);
- if (next_char (dtp) != ',')
+ if (next_char (dtp)
+ != (dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';'))
goto bad_complex;
eol_2:
@@ -1353,6 +1367,8 @@ read_real (st_parameter_dt *dtp, int len
seen_dp = 0;
c = next_char (dtp);
+ if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+ c = '.';
switch (c)
{
CASE_DIGITS:
@@ -1388,6 +1404,8 @@ read_real (st_parameter_dt *dtp, int len
for (;;)
{
c = next_char (dtp);
+ if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+ c = '.';
switch (c)
{
CASE_DIGITS:
@@ -1395,8 +1413,8 @@ read_real (st_parameter_dt *dtp, int len
break;
case '.':
- if (seen_dp)
- goto bad_real;
+ if (seen_dp)
+ goto bad_real;
seen_dp = 1;
push_char (dtp, c);
@@ -1420,7 +1438,7 @@ read_real (st_parameter_dt *dtp, int len
goto got_repeat;
CASE_SEPARATORS:
- if (c != '\n' && c != ',' && c != '\r')
+ if (c != '\n' && c != ',' && c != '\r' && c != ';')
unget_char (dtp, c);
goto done;
@@ -1452,6 +1470,9 @@ read_real (st_parameter_dt *dtp, int len
c = next_char (dtp);
}
+ if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+ c = '.';
+
if (!isdigit (c) && c != '.')
{
if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
@@ -1474,6 +1495,8 @@ read_real (st_parameter_dt *dtp, int len
for (;;)
{
c = next_char (dtp);
+ if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+ c = '.';
switch (c)
{
CASE_DIGITS:
Index: libgfortran/io/read.c
===================================================================
--- libgfortran/io/read.c (revision 133930)
+++ 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 133930)
+++ 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,25 @@ 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;
+
+/* NOTE: unit_sign must correspond with the sign_status enumerator in
+ st_parameter_dt to not break the ABI. */
+typedef enum
+{ SIGN_PROCDEFINED, SIGN_SUPPRESS, SIGN_PLUS, SIGN_UNSPECIFIED }
+unit_sign;
+
+typedef enum
{ ADVANCE_YES, ADVANCE_NO, ADVANCE_UNSPECIFIED }
unit_advance;
@@ -212,6 +242,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 +267,11 @@ typedef struct
CHARACTER1 (delim);
CHARACTER2 (pad);
CHARACTER1 (convert);
+ CHARACTER2 (decimal);
+ CHARACTER1 (encoding);
+ CHARACTER2 (round);
+ CHARACTER1 (sign);
+ CHARACTER2 (asynchronous);
}
st_parameter_open;
@@ -275,6 +314,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 +348,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 +372,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 +394,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 +417,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 +430,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 +499,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 +523,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 +596,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 +841,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/unit.c
===================================================================
--- libgfortran/io/unit.c (revision 133930)
+++ libgfortran/io/unit.c (working copy)
@@ -430,6 +430,7 @@ get_internal_unit (st_parameter_dt *dtp)
iunit->maxrec=0;
iunit->current_record=0;
iunit->read_bad = 0;
+ iunit->endfile = NO_ENDFILE;
/* Set flags for the internal unit. */
@@ -438,7 +439,9 @@ get_internal_unit (st_parameter_dt *dtp)
iunit->flags.form = FORM_FORMATTED;
iunit->flags.pad = PAD_YES;
iunit->flags.status = STATUS_UNSPECIFIED;
- iunit->endfile = NO_ENDFILE;
+ iunit->flags.sign = SIGN_SUPPRESS;
+ iunit->flags.decimal = DECIMAL_POINT;
+ iunit->flags.encoding = ENCODING_DEFAULT;
/* Initialize the data transfer parameters. */
@@ -524,6 +527,9 @@ init_units (void)
u->flags.blank = BLANK_NULL;
u->flags.pad = PAD_YES;
u->flags.position = POSITION_ASIS;
+ u->flags.sign = SIGN_SUPPRESS;
+ u->flags.decimal = DECIMAL_POINT;
+ u->flags.encoding = ENCODING_DEFAULT;
u->recl = options.default_recl;
u->endfile = NO_ENDFILE;
@@ -547,6 +553,9 @@ init_units (void)
u->flags.status = STATUS_OLD;
u->flags.blank = BLANK_NULL;
u->flags.position = POSITION_ASIS;
+ u->flags.sign = SIGN_SUPPRESS;
+ u->flags.decimal = DECIMAL_POINT;
+ u->flags.encoding = ENCODING_DEFAULT;
u->recl = options.default_recl;
u->endfile = AT_ENDFILE;
@@ -570,6 +579,9 @@ init_units (void)
u->flags.status = STATUS_OLD;
u->flags.blank = BLANK_NULL;
u->flags.position = POSITION_ASIS;
+ u->flags.sign = SIGN_SUPPRESS;
+ u->flags.decimal = DECIMAL_POINT;
+ u->flags.encoding = ENCODING_DEFAULT;
u->recl = options.default_recl;
u->endfile = AT_ENDFILE;
Index: libgfortran/io/unix.c
===================================================================
--- libgfortran/io/unix.c (revision 133930)
+++ 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 133930)
+++ libgfortran/io/transfer.c (working copy)
@@ -93,6 +93,26 @@ static const st_option advance_opt[] = {
};
+static const st_option decimal_opt[] = {
+ {"point", DECIMAL_POINT},
+ {"comma", DECIMAL_COMMA},
+ {NULL, 0}
+};
+
+
+static const st_option sign_opt[] = {
+ {"plus", SIGN_SP},
+ {"suppress", SIGN_SS},
+ {"processor_defined", SIGN_S},
+ {NULL, 0}
+};
+
+static const st_option blank_opt[] = {
+ {"null", BLANK_NULL},
+ {"zero", BLANK_ZERO},
+ {NULL, 0}
+};
+
typedef enum
{ FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
@@ -910,7 +930,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 +943,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 +1182,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 +1298,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 +1318,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 +1353,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 +1799,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 +1992,35 @@ 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;
+
+ /* Check the sign mode. */
+ dtp->u.p.sign_status
+ = !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
+ find_option (&dtp->common, dtp->sign, dtp->sign_len, sign_opt,
+ "Bad SIGN parameter in data transfer statement");
+
+ if (dtp->u.p.sign_status == SIGN_UNSPECIFIED)
+ dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign;
+
+ /* Check the blank mode. */
+ dtp->u.p.blank_status
+ = !(cf & IOPARM_DT_HAS_BLANK) ? BLANK_UNSPECIFIED :
+ find_option (&dtp->common, dtp->blank, dtp->blank_len, blank_opt,
+ "Bad BLANK parameter in data transfer statement");
+
+ if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
+ dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
+
+
/* Sanity checks on the record number. */
if ((cf & IOPARM_DT_HAS_REC) != 0)
{
@@ -2023,11 +2086,6 @@ data_transfer_init (st_parameter_dt *dtp
dtp->u.p.current_unit->mode = dtp->u.p.mode;
- /* Set the initial value of flags. */
-
- dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
- dtp->u.p.sign_status = SIGN_S;
-
/* Set the maximum position reached from the previous I/O operation. This
could be greater than zero from a previous non-advancing write. */
dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos;
@@ -2926,6 +2984,14 @@ 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 __attribute__((unused)))
+{
+}
+
+
/* 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 133930)
+++ 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, "Fortran 2003: 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 133930)
+++ 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;
}
@@ -729,11 +729,13 @@ write_real (st_parameter_dt *dtp, const
static void
write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
{
+ char semi_comma = dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';';
+
if (write_char (dtp, '('))
return;
write_real (dtp, source, kind);
- if (write_char (dtp, ','))
+ if (write_char (dtp, semi_comma))
return;
write_real (dtp, source + size / 2, kind);
@@ -869,6 +871,11 @@ nml_write_obj (st_parameter_dt *dtp, nam
size_t base_var_name_len;
size_t tot_len;
unit_delim tmp_delim;
+
+ /* Set the character to be used to separate values
+ to a comma or semi-colon. */
+
+ char semi_comma = dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';';
/* Write namelist variable names in upper case. If a derived type,
nothing is output. If a component, base and base_name are set. */
@@ -1075,12 +1082,12 @@ nml_write_obj (st_parameter_dt *dtp, nam
internal_error (&dtp->common, "Bad type for namelist write");
}
- /* Reset the leading blank suppression, write a comma and, if 5
- values have been output, write a newline and advance to column
- 2. Reset the repeat counter. */
+ /* Reset the leading blank suppression, write a comma (or semi-colon)
+ and, if 5 values have been output, write a newline and advance
+ to column 2. Reset the repeat counter. */
dtp->u.p.no_leading_blank = 0;
- write_character (dtp, ",", 1);
+ write_character (dtp, &semi_comma, 1);
if (num > 5)
{
num = 0;
Index: libgfortran/io/write_float.def
===================================================================
--- libgfortran/io/write_float.def (revision 133930)
+++ 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;
+ case SIGN_SP: /* Show sign. */
+ s = S_PLUS;
break;
- case SIGN_SS:
- s = SIGN_NONE;
+ case SIGN_SS: /* Suppress sign. */
+ s = S_NONE;
break;
- case SIGN_S:
- s = options.optional_plus ? SIGN_PLUS : SIGN_NONE;
+ case SIGN_S: /* Processor defined. */
+ 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)
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [patch, fortran]PR25829 Add support for F2003 I/O features
2008-04-01 21:10 Tobias Burnus
@ 2008-04-04 4:53 ` Jerry DeLisle
0 siblings, 0 replies; 19+ messages in thread
From: Jerry DeLisle @ 2008-04-04 4:53 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc-patches, fortran
On Tue, 2008-04-01 at 23:10 +0200, Tobias Burnus wrote:
> > Please give it a spin and test if you can. Any test cases people are
> > willing to submit would be welcome.
>
> DECIMAL="comma" does not work properly:
>
> integer :: i
> real :: a(10) = [ (i*1.3, i=1,10) ]
> namelist /nm/ a
> write(*,nml=nm,decimal='comma')
> end
>
> This should print
> &nm a = 1,3; 2,6; ...
> but it prints:
> &nm a = 1,3, 2,6, ...
>
> * * *
>
> The following program should print:
> 1.3 4.0 5.0 5.0 7.0 0.0
> but gfortran has:
> Fortran runtime error: Cannot match namelist object name
>
> implicit none
> integer :: i
> real :: a(6) = 0.0
> character(len=30) :: str = '&nm a = 1,3; 4, 5; 5; 7; /'
> namelist /nm/ a
> read(str,nml=nm,decimal='comma')
> print *, a
> end
>
> * * *
>
> + notify_std (&dtp->common, GFC_STD_F2003, "DC or DP descriptor "
>
> Please use also in libgfortran the "Fortran 2003:" prefix.
>
> * * *
>
> The patch looks otherwise OK. It would be great if some others could
> do some tests or code review as well. The code is too big to quickly
> see whether everything is correct or whether checks are missing or ...
>
> Tobias,
> who is looking forward to the updated patch
I have all these cases working. Doing more testing.
Jerry
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [patch, fortran]PR25829 Add support for F2003 I/O features
@ 2008-04-01 21:10 Tobias Burnus
2008-04-04 4:53 ` Jerry DeLisle
0 siblings, 1 reply; 19+ messages in thread
From: Tobias Burnus @ 2008-04-01 21:10 UTC (permalink / raw)
To: Jerry DeLisle, gcc-patches, fortran
> Please give it a spin and test if you can. Any test cases people are
> willing to submit would be welcome.
DECIMAL="comma" does not work properly:
integer :: i
real :: a(10) = [ (i*1.3, i=1,10) ]
namelist /nm/ a
write(*,nml=nm,decimal='comma')
end
This should print
&nm a = 1,3; 2,6; ...
but it prints:
&nm a = 1,3, 2,6, ...
* * *
The following program should print:
1.3 4.0 5.0 5.0 7.0 0.0
but gfortran has:
Fortran runtime error: Cannot match namelist object name
implicit none
integer :: i
real :: a(6) = 0.0
character(len=30) :: str = '&nm a = 1,3; 4, 5; 5; 7; /'
namelist /nm/ a
read(str,nml=nm,decimal='comma')
print *, a
end
* * *
+ notify_std (&dtp->common, GFC_STD_F2003, "DC or DP descriptor "
Please use also in libgfortran the "Fortran 2003:" prefix.
* * *
The patch looks otherwise OK. It would be great if some others could
do some tests or code review as well. The code is too big to quickly
see whether everything is correct or whether checks are missing or ...
Tobias,
who is looking forward to the updated patch
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [patch, fortran]PR25829 Add support for F2003 I/O features
2008-04-01 11:47 ` Tobias Burnus
2008-04-01 14:15 ` Jerry DeLisle
@ 2008-04-01 14:15 ` Jerry DeLisle
[not found] ` <47F494AC.30003@net-b.de>
1 sibling, 1 reply; 19+ messages in thread
From: Jerry DeLisle @ 2008-04-01 14:15 UTC (permalink / raw)
To: Tobias Burnus; +Cc: fortran, gcc-patches
On Tue, 2008-04-01 at 13:47 +0200, Tobias Burnus wrote:
> Jerry DeLisle wrote:
> > The attached updated patch incorporates all constraints and checks
> > listed above in the front end. It also implements the DP and DC format
> > specifiers.
> >
> Thanks. Some more issues and remarks. I will try to review the patch later.
>
OK, I will work through these. The checks in place now are for EXPR_CONSTANT and not addressing the broader case.
Thanks for continued review.
Jerry
> * There should be a "Fortran 2003:" in the error message.
> + if (gfc_notify_std (GFC_STD_F2003, "DP format specifier not
> allowed "
>
>
> * decimal= in INQUIRE does not seem to be supported:
> inquire(unit=99, decimal=d)
> Same for:
> inquire(99,encoding=str)
> I also think the error messages can be improved:
> inquire(99, BLANK='foo')
> 1
> Error: Syntax error in INQUIRE statement at (1)
> NAG has a better error message: "Item for i/o keyword BLANK is not a
> variable"
>
>
> * write(99,decimal=foo) 4.4, 3.3
> This gives a run-time error message, but it can be detected at compile
> time. NAG f95 has:
> Error: DECIMAL= is incompatible with unformatted i/o
> Actually, the run-time error message is also a bit misleading:
> Fortran runtime error: Missing format for FORMATTED data transfer
>
>
> * Analogously for the following:
> write(99,DELIM=str)
> which is also not allowed for unformatted I/O
>
>
> * "Error: F2003 Feature: SIGN=specifier at (1) not implemented"
> Can you add a space after the "=" sign?
>
> * write(99,id=id)
> This is invalid as asynchronous="yes" needs to be specified as well.
> However, this is not enforced in the front end (or library).
>
> * The following program crashes in _gfortran_st_wait (transfer.c:2966)
> ("Invalid write of size 4"):
> integer :: id
> open(99, asynchronous='yes')
> write(99,asynchronous='yes',id=id,fmt=*)
> wait(99,id=id)
> end
>
> * The following program is invalid, but only detectable at run time.
> Should there be a run-time check? Maybe one should postpone this until
> the real asynchronous is available:
> integer :: id
> open(99, asynchronous='no')
> write(99,asynchronous='yes',id=id,fmt=*)
> end
> But I think we need such a check for the real implementation.
>
> I played a bit around with the decimal comma support and it nicely works :-)
>
> Tobias
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [patch, fortran]PR25829 Add support for F2003 I/O features
2008-04-01 11:47 ` Tobias Burnus
@ 2008-04-01 14:15 ` Jerry DeLisle
2008-04-01 14:15 ` Jerry DeLisle
1 sibling, 0 replies; 19+ messages in thread
From: Jerry DeLisle @ 2008-04-01 14:15 UTC (permalink / raw)
To: Tobias Burnus; +Cc: fortran, gcc-patches
On Tue, 2008-04-01 at 13:47 +0200, Tobias Burnus wrote:
> Jerry DeLisle wrote:
> > The attached updated patch incorporates all constraints and checks
> > listed above in the front end. It also implements the DP and DC format
> > specifiers.
> >
> Thanks. Some more issues and remarks. I will try to review the patch later.
>
OK, I will work through these.
Thanks for continued review.
Jerry
> * There should be a "Fortran 2003:" in the error message.
> + if (gfc_notify_std (GFC_STD_F2003, "DP format specifier not
> allowed "
>
>
> * decimal= in INQUIRE does not seem to be supported:
> inquire(unit=99, decimal=d)
> Same for:
> inquire(99,encoding=str)
> I also think the error messages can be improved:
> inquire(99, BLANK='foo')
> 1
> Error: Syntax error in INQUIRE statement at (1)
> NAG has a better error message: "Item for i/o keyword BLANK is not a
> variable"
>
>
> * write(99,decimal=foo) 4.4, 3.3
> This gives a run-time error message, but it can be detected at compile
> time. NAG f95 has:
> Error: DECIMAL= is incompatible with unformatted i/o
> Actually, the run-time error message is also a bit misleading:
> Fortran runtime error: Missing format for FORMATTED data transfer
>
>
> * Analogously for the following:
> write(99,DELIM=str)
> which is also not allowed for unformatted I/O
>
>
> * "Error: F2003 Feature: SIGN=specifier at (1) not implemented"
> Can you add a space after the "=" sign?
>
> * write(99,id=id)
> This is invalid as asynchronous="yes" needs to be specified as well.
> However, this is not enforced in the front end (or library).
>
> * The following program crashes in _gfortran_st_wait (transfer.c:2966)
> ("Invalid write of size 4"):
> integer :: id
> open(99, asynchronous='yes')
> write(99,asynchronous='yes',id=id,fmt=*)
> wait(99,id=id)
> end
>
> * The following program is invalid, but only detectable at run time.
> Should there be a run-time check? Maybe one should postpone this until
> the real asynchronous is available:
> integer :: id
> open(99, asynchronous='no')
> write(99,asynchronous='yes',id=id,fmt=*)
> end
> But I think we need such a check for the real implementation.
>
> I played a bit around with the decimal comma support and it nicely works :-)
>
> Tobias
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [patch, fortran]PR25829 Add support for F2003 I/O features
2008-04-01 4:31 ` Jerry DeLisle
@ 2008-04-01 11:47 ` Tobias Burnus
2008-04-01 14:15 ` Jerry DeLisle
2008-04-01 14:15 ` Jerry DeLisle
0 siblings, 2 replies; 19+ messages in thread
From: Tobias Burnus @ 2008-04-01 11:47 UTC (permalink / raw)
To: Jerry DeLisle; +Cc: fortran, gcc-patches
Jerry DeLisle wrote:
> The attached updated patch incorporates all constraints and checks
> listed above in the front end. It also implements the DP and DC format
> specifiers.
>
Thanks. Some more issues and remarks. I will try to review the patch later.
* There should be a "Fortran 2003:" in the error message.
+ if (gfc_notify_std (GFC_STD_F2003, "DP format specifier not
allowed "
* decimal= in INQUIRE does not seem to be supported:
inquire(unit=99, decimal=d)
Same for:
inquire(99,encoding=str)
I also think the error messages can be improved:
inquire(99, BLANK='foo')
1
Error: Syntax error in INQUIRE statement at (1)
NAG has a better error message: "Item for i/o keyword BLANK is not a
variable"
* write(99,decimal=foo) 4.4, 3.3
This gives a run-time error message, but it can be detected at compile
time. NAG f95 has:
Error: DECIMAL= is incompatible with unformatted i/o
Actually, the run-time error message is also a bit misleading:
Fortran runtime error: Missing format for FORMATTED data transfer
* Analogously for the following:
write(99,DELIM=str)
which is also not allowed for unformatted I/O
* "Error: F2003 Feature: SIGN=specifier at (1) not implemented"
Can you add a space after the "=" sign?
* write(99,id=id)
This is invalid as asynchronous="yes" needs to be specified as well.
However, this is not enforced in the front end (or library).
* The following program crashes in _gfortran_st_wait (transfer.c:2966)
("Invalid write of size 4"):
integer :: id
open(99, asynchronous='yes')
write(99,asynchronous='yes',id=id,fmt=*)
wait(99,id=id)
end
* The following program is invalid, but only detectable at run time.
Should there be a run-time check? Maybe one should postpone this until
the real asynchronous is available:
integer :: id
open(99, asynchronous='no')
write(99,asynchronous='yes',id=id,fmt=*)
end
But I think we need such a check for the real implementation.
I played a bit around with the decimal comma support and it nicely works :-)
Tobias
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [patch, fortran]PR25829 Add support for F2003 I/O features
2008-03-29 17:45 Tobias Burnus
2008-03-29 19:57 ` Jerry DeLisle
@ 2008-04-01 4:31 ` Jerry DeLisle
2008-04-01 11:47 ` Tobias Burnus
1 sibling, 1 reply; 19+ messages in thread
From: Jerry DeLisle @ 2008-04-01 4:31 UTC (permalink / raw)
To: Tobias Burnus; +Cc: fortran, gcc-patches
[-- Attachment #1: Type: text/plain, Size: 2924 bytes --]
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
[-- Attachment #2: f2003-io-RevE.diff --]
[-- Type: text/x-patch, Size: 70779 bytes --]
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)
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [patch, fortran]PR25829 Add support for F2003 I/O features
2008-03-29 17:45 Tobias Burnus
@ 2008-03-29 19:57 ` Jerry DeLisle
2008-04-01 4:31 ` Jerry DeLisle
1 sibling, 0 replies; 19+ messages in thread
From: Jerry DeLisle @ 2008-03-29 19:57 UTC (permalink / raw)
To: Tobias Burnus; +Cc: fortran, gcc-patches
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.)
Thanks for taking the time to look at this. I have made no progress on
the run time portions because of time constraints. However, let me work
on your comments for the constraints and checks, etc. I will then submit
an updated patch.
Jerry
^ permalink raw reply [flat|nested] 19+ messages in thread
* Re: [patch, fortran]PR25829 Add support for F2003 I/O features
@ 2008-03-29 17:45 Tobias Burnus
2008-03-29 19:57 ` Jerry DeLisle
2008-04-01 4:31 ` Jerry DeLisle
0 siblings, 2 replies; 19+ messages in thread
From: Tobias Burnus @ 2008-03-29 17:45 UTC (permalink / raw)
To: Jerry DeLisle, fortran, gcc-patches
> - 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 rest looked ok, though I have only skimmed over the libgfortran
part.
Tobias
^ permalink raw reply [flat|nested] 19+ messages in thread
end of thread, other threads:[~2008-04-06 9:25 UTC | newest]
Thread overview: 19+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2008-03-16 21:48 [patch, fortran]PR25829 Add support for F2003 I/O features Jerry DeLisle
2008-03-16 22:03 ` FX Coudert
2008-03-17 0:25 ` Jerry DeLisle
2008-03-17 7:52 ` Janne Blomqvist
2008-03-29 17:45 Tobias Burnus
2008-03-29 19:57 ` Jerry DeLisle
2008-04-01 4:31 ` Jerry DeLisle
2008-04-01 11:47 ` Tobias Burnus
2008-04-01 14:15 ` Jerry DeLisle
2008-04-01 14:15 ` Jerry DeLisle
[not found] ` <47F494AC.30003@net-b.de>
2008-04-05 9:24 ` Jerry DeLisle
2008-04-05 9:27 ` Jerry DeLisle
2008-04-01 21:10 Tobias Burnus
2008-04-04 4:53 ` Jerry DeLisle
2008-04-05 12:21 Tobias Burnus
2008-04-05 16:30 ` Jerry DeLisle
2008-04-05 17:31 ` NightStrike
2008-04-05 17:58 ` Jerry DeLisle
[not found] ` <47F7FE02.3070407@net-b.de>
[not found] ` <1207454811.15229.2.camel@lenova.localdomain>
2008-04-06 10:00 ` Tobias Burnus
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).