diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 39 | ||||
| -rw-r--r-- | gcc/fortran/dump-parse-tree.c | 110 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 27 | ||||
| -rw-r--r-- | gcc/fortran/io.c | 574 | ||||
| -rw-r--r-- | gcc/fortran/ioparm.def | 39 | ||||
| -rw-r--r-- | gcc/fortran/match.c | 1 | ||||
| -rw-r--r-- | gcc/fortran/match.h | 1 | ||||
| -rw-r--r-- | gcc/fortran/parse.c | 8 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 10 | ||||
| -rw-r--r-- | gcc/fortran/st.c | 4 | ||||
| -rw-r--r-- | gcc/fortran/trans-io.c | 152 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.h | 1 | ||||
| -rw-r--r-- | gcc/fortran/trans.c | 4 |
13 files changed, 877 insertions, 93 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 851008e..b534d8e 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,42 @@ +2008-04-05 Jerry DeLisle <jvdelisle@gcc.gnu.org> + Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/25829 28655 + * dump-parse-tree.c (gfc_show_code_node): Show new I/O parameters. + * gfortran.h (gfc_statement): Add ST_WAIT enumerator. + (gfc_open): Add pointers for decimal, encoding, round, sign, + asynchronous. (gfc_inquire): Add pointers for asynchronous, decimal, + encoding, pending, round, sign, size, id. + (gfc_wait): New typedef struct. (gfc_dt): Add pointers for id, pos, + asynchronous, blank, decimal, delim, pad, round, sign. + (gfc_exec_op): Add EXEC_WAIT enumerator. (gfc_code): Add pointer for + wait. (gfc_free_wait), (gfc_resolve_wait): New function prototypes. + * trans-stmt.h (gfc_trans_wait): New function prototype. + * trans.c (gfc_trans_code): Add case for EXEC_WAIT. + * io.c (io_tag): Add new tags for DECIMAL, ENCODING, ROUND, SIGN, + ASYCHRONOUS, ID. (match_open_element): Add matchers for new tags. + (gfc_free_open): Free new pointers. (gfc_resolve_open): Resolve new + tags. (gfc_resolve_open): Remove comment around check for allowed + values and ASYNCHRONOUS, update it. Likewise for DECIMAL, ENCODING, + ROUND, and SIGN. (match_dt_element): Add matching for new tags. + (gfc_free_wait): New function. (gfc_resolve_wait): New function. + (match_wait_element): New function. (gfc_match_wait): New function. + * resolve.c (gfc_resolve_blocks): Add case for EXEC_WAIT. + (resolve_code): Add case for EXEC_WAIT. + * st.c (gfc_free_statement): Add case for EXEC_WAIT. + * trans-io.c (ioparam_type): Add IOPARM_ptype_wait. (gfc_st_parameter): + Add "wait" entry. (iocall): Add IOCALL_WAIT enumerator. + (gfc_build_io_library_fndecls): Add function declaration for st_wait. + (gfc_trans_open): Add mask bits for new I/O tags. + (gfc_trans_inquire): Add mask bits for new I/O tags. + (gfc_trans_wait): New translation function. + (build_dt): Add mask bits for new I/O tags. + * match.c (gfc_match_if) Add matcher for "wait". + * match.h (gfc_match_wait): Prototype for new function. + * ioparm.def: Add new I/O parameter definitions. + * parse.c (decode_statement): Add match for "wait" statement. + (next_statement): Add case for ST_WAIT. (gfc_ascii_statement): Same. + 2008-04-03 Jakub Jelinek <jakub@redhat.com> PR fortran/35786 diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 4f4a77c..dc3ab32 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -1405,11 +1405,36 @@ gfc_show_code_node (int level, gfc_code *c) gfc_status (" PAD="); gfc_show_expr (open->pad); } + if (open->decimal) + { + gfc_status (" DECIMAL="); + gfc_show_expr (open->decimal); + } + if (open->encoding) + { + gfc_status (" ENCODING="); + gfc_show_expr (open->encoding); + } + if (open->round) + { + gfc_status (" ROUND="); + gfc_show_expr (open->round); + } + if (open->sign) + { + gfc_status (" SIGN="); + gfc_show_expr (open->sign); + } if (open->convert) { gfc_status (" CONVERT="); gfc_show_expr (open->convert); } + if (open->asynchronous) + { + gfc_status (" ASYNCHRONOUS="); + gfc_show_expr (open->asynchronous); + } if (open->err != NULL) gfc_status (" ERR=%d", open->err->value); @@ -1616,6 +1641,46 @@ gfc_show_code_node (int level, gfc_code *c) gfc_status (" CONVERT="); gfc_show_expr (i->convert); } + if (i->asynchronous) + { + gfc_status (" ASYNCHRONOUS="); + gfc_show_expr (i->asynchronous); + } + if (i->decimal) + { + gfc_status (" DECIMAL="); + gfc_show_expr (i->decimal); + } + if (i->encoding) + { + gfc_status (" ENCODING="); + gfc_show_expr (i->encoding); + } + if (i->pending) + { + gfc_status (" PENDING="); + gfc_show_expr (i->pending); + } + if (i->round) + { + gfc_status (" ROUND="); + gfc_show_expr (i->round); + } + if (i->sign) + { + gfc_status (" SIGN="); + gfc_show_expr (i->sign); + } + if (i->size) + { + gfc_status (" SIZE="); + gfc_show_expr (i->size); + } + if (i->id) + { + gfc_status (" ID="); + gfc_show_expr (i->id); + } if (i->err != NULL) gfc_status (" ERR=%d", i->err->value); @@ -1678,6 +1743,51 @@ gfc_show_code_node (int level, gfc_code *c) gfc_status (" ADVANCE="); gfc_show_expr (dt->advance); } + if (dt->id) + { + gfc_status (" ID="); + gfc_show_expr (dt->id); + } + if (dt->pos) + { + gfc_status (" POS="); + gfc_show_expr (dt->pos); + } + if (dt->asynchronous) + { + gfc_status (" ASYNCHRONOUS="); + gfc_show_expr (dt->asynchronous); + } + if (dt->blank) + { + gfc_status (" BLANK="); + gfc_show_expr (dt->blank); + } + if (dt->decimal) + { + gfc_status (" DECIMAL="); + gfc_show_expr (dt->decimal); + } + if (dt->delim) + { + gfc_status (" DELIM="); + gfc_show_expr (dt->delim); + } + if (dt->pad) + { + gfc_status (" PAD="); + gfc_show_expr (dt->pad); + } + if (dt->round) + { + gfc_status (" ROUND="); + gfc_show_expr (dt->round); + } + if (dt->sign) + { + gfc_status (" SIGN="); + gfc_show_expr (dt->sign); + } show_dt_code: gfc_status_char ('\n'); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 07518ee..009dbc8 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -211,8 +211,8 @@ typedef enum ST_IF_BLOCK, ST_IMPLICIT, ST_IMPLICIT_NONE, ST_IMPORT, ST_INQUIRE, ST_INTERFACE, ST_PARAMETER, ST_MODULE, ST_MODULE_PROC, ST_NAMELIST, ST_NULLIFY, ST_OPEN, ST_PAUSE, ST_PRIVATE, ST_PROGRAM, ST_PUBLIC, ST_READ, ST_RETURN, ST_REWIND, - ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WRITE, - ST_ASSIGNMENT, ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE, + ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WAIT, + ST_WRITE, ST_ASSIGNMENT, ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE, ST_SIMPLE_IF, ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_LABEL_ASSIGNMENT, ST_ENUM, ST_ENUMERATOR, ST_END_ENUM, ST_OMP_ATOMIC, ST_OMP_BARRIER, ST_OMP_CRITICAL, ST_OMP_END_CRITICAL, @@ -1635,7 +1635,8 @@ gfc_alloc; typedef struct { gfc_expr *unit, *file, *status, *access, *form, *recl, - *blank, *position, *action, *delim, *pad, *iostat, *iomsg, *convert; + *blank, *position, *action, *delim, *pad, *iostat, *iomsg, *convert, + *decimal, *encoding, *round, *sign, *asynchronous, *id; gfc_st_label *err; } gfc_open; @@ -1662,7 +1663,8 @@ typedef struct gfc_expr *unit, *file, *iostat, *exist, *opened, *number, *named, *name, *access, *sequential, *direct, *form, *formatted, *unformatted, *recl, *nextrec, *blank, *position, *action, *read, - *write, *readwrite, *delim, *pad, *iolength, *iomsg, *convert, *strm_pos; + *write, *readwrite, *delim, *pad, *iolength, *iomsg, *convert, *strm_pos, + *asynchronous, *decimal, *encoding, *pending, *round, *sign, *size, *id; gfc_st_label *err; @@ -1672,7 +1674,17 @@ gfc_inquire; typedef struct { - gfc_expr *io_unit, *format_expr, *rec, *advance, *iostat, *size, *iomsg; + gfc_expr *unit, *iostat, *iomsg, *id; + gfc_st_label *err, *end, *eor; +} +gfc_wait; + + +typedef struct +{ + gfc_expr *io_unit, *format_expr, *rec, *advance, *iostat, *size, *iomsg, + *id, *pos, *asynchronous, *blank, *decimal, *delim, *pad, *round, + *sign; gfc_symbol *namelist; /* A format_label of `format_asterisk' indicates the "*" format */ @@ -1701,7 +1713,7 @@ typedef enum EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT, EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, EXEC_ALLOCATE, EXEC_DEALLOCATE, - EXEC_OPEN, EXEC_CLOSE, + EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT, EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END, EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH, EXEC_OMP_CRITICAL, EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER, @@ -1738,6 +1750,7 @@ typedef struct gfc_code gfc_close *close; gfc_filepos *filepos; gfc_inquire *inquire; + gfc_wait *wait; gfc_dt *dt; gfc_forall_iterator *forall_iterator; struct gfc_code *whichloop; @@ -2323,6 +2336,8 @@ void gfc_free_inquire (gfc_inquire *); try gfc_resolve_inquire (gfc_inquire *); void gfc_free_dt (gfc_dt *); try gfc_resolve_dt (gfc_dt *); +void gfc_free_wait (gfc_wait *); +try gfc_resolve_wait (gfc_wait *); /* module.c */ void gfc_module_init_2 (void); diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index decd819..917acc3 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -48,6 +48,10 @@ static const io_tag tag_e_action = {"ACTION", " action = %e", BT_CHARACTER}, tag_e_delim = {"DELIM", " delim = %e", BT_CHARACTER}, tag_e_pad = {"PAD", " pad = %e", BT_CHARACTER}, + tag_e_decimal = {"DECIMAL", " decimal = %e", BT_CHARACTER}, + tag_e_encoding = {"ENCODING", " encoding = %e", BT_CHARACTER}, + tag_e_round = {"ROUND", " round = %e", BT_CHARACTER}, + tag_e_sign = {"SIGN", " sign = %e", BT_CHARACTER}, tag_unit = {"UNIT", " unit = %e", BT_INTEGER}, tag_advance = {"ADVANCE", " advance = %e", BT_CHARACTER}, tag_rec = {"REC", " rec = %e", BT_INTEGER}, @@ -82,7 +86,9 @@ static const io_tag tag_strm_out = {"POS", " pos = %v", BT_INTEGER}, tag_err = {"ERR", " err = %l", BT_UNKNOWN}, tag_end = {"END", " end = %l", BT_UNKNOWN}, - tag_eor = {"EOR", " eor = %l", BT_UNKNOWN}; + tag_eor = {"EOR", " eor = %l", BT_UNKNOWN}, + tag_async = {"ASYNCHRONOUS", " asynchronous = %e", BT_CHARACTER}, + tag_id = {"ID", " id = %v", BT_INTEGER}; static gfc_dt *current_dt; @@ -97,7 +103,8 @@ typedef enum FMT_NONE, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD, FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_POS, FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F, - FMT_E, FMT_EXT, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_ERROR + FMT_E, FMT_EXT, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_ERROR, FMT_DC, + FMT_DP } format_token; @@ -420,7 +427,26 @@ format_lex (void) break; case 'D': - token = FMT_D; + c = next_char_not_space (&error); + if (c == 'P') + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DP format " + "specifier not allowed at %C") == FAILURE) + return FMT_ERROR; + token = FMT_DP; + } + else if (c == 'C') + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DC format " + "specifier not allowed at %C") == FAILURE) + return FMT_ERROR; + token = FMT_DC; + } + else + { + token = FMT_D; + unget_char (); + } break; case '\0': @@ -537,6 +563,8 @@ format_item_1: case FMT_SIGN: case FMT_BLANK: + case FMT_DP: + case FMT_DC: goto between_desc; case FMT_CHAR: @@ -590,6 +618,8 @@ data_desc: { case FMT_SIGN: case FMT_BLANK: + case FMT_DP: + case FMT_DC: case FMT_X: break; @@ -1224,6 +1254,9 @@ match_open_element (gfc_open *open) { match m; + m = match_etag (&tag_async, &open->asynchronous); + if (m != MATCH_NO) + return m; m = match_etag (&tag_unit, &open->unit); if (m != MATCH_NO) return m; @@ -1263,6 +1296,18 @@ match_open_element (gfc_open *open) m = match_etag (&tag_e_pad, &open->pad); if (m != MATCH_NO) return m; + m = match_etag (&tag_e_decimal, &open->decimal); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_encoding, &open->encoding); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_round, &open->round); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_sign, &open->sign); + if (m != MATCH_NO) + return m; m = match_ltag (&tag_err, &open->err); if (m != MATCH_NO) return m; @@ -1295,7 +1340,12 @@ gfc_free_open (gfc_open *open) gfc_free_expr (open->action); gfc_free_expr (open->delim); gfc_free_expr (open->pad); + gfc_free_expr (open->decimal); + gfc_free_expr (open->encoding); + gfc_free_expr (open->round); + gfc_free_expr (open->sign); gfc_free_expr (open->convert); + gfc_free_expr (open->asynchronous); gfc_free (open); } @@ -1319,6 +1369,10 @@ gfc_resolve_open (gfc_open *open) RESOLVE_TAG (&tag_e_action, open->action); RESOLVE_TAG (&tag_e_delim, open->delim); RESOLVE_TAG (&tag_e_pad, open->pad); + RESOLVE_TAG (&tag_e_decimal, open->decimal); + RESOLVE_TAG (&tag_e_encoding, open->encoding); + RESOLVE_TAG (&tag_e_round, open->round); + RESOLVE_TAG (&tag_e_sign, open->sign); RESOLVE_TAG (&tag_convert, open->convert); if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE) @@ -1501,63 +1555,97 @@ gfc_match_open (void) } /* Checks on the ASYNCHRONOUS specifier. */ - /* TODO: code is ready, just needs uncommenting when async I/O support - is added ;-) - if (open->asynchronous && open->asynchronous->expr_type == EXPR_CONSTANT) + if (open->asynchronous) { - static const char * asynchronous[] = { "YES", "NO", NULL }; - - if (!compare_to_allowed_values - ("action", asynchronous, NULL, NULL, - open->asynchronous->value.character.string, "OPEN", warn)) + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASYNCHRONOUS= at %C " + "not allowed in Fortran 95") == FAILURE) goto cleanup; - }*/ - + + if (open->asynchronous->expr_type == EXPR_CONSTANT) + { + static const char * asynchronous[] = { "YES", "NO", NULL }; + + if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous, + NULL, NULL, open->asynchronous->value.character.string, + "OPEN", warn)) + goto cleanup; + } + } + /* Checks on the BLANK specifier. */ - if (open->blank && open->blank->expr_type == EXPR_CONSTANT) + if (open->blank) { - static const char *blank[] = { "ZERO", "NULL", NULL }; - - if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL, - open->blank->value.character.string, - "OPEN", warn)) + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C " + "not allowed in Fortran 95") == FAILURE) goto cleanup; + + if (open->blank->expr_type == EXPR_CONSTANT) + { + static const char *blank[] = { "ZERO", "NULL", NULL }; + + if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL, + open->blank->value.character.string, + "OPEN", warn)) + goto cleanup; + } } /* Checks on the DECIMAL specifier. */ - /* TODO: uncomment this code when DECIMAL support is added - if (open->decimal && open->decimal->expr_type == EXPR_CONSTANT) + if (open->decimal) { - static const char * decimal[] = { "COMMA", "POINT", NULL }; - - if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL, - open->decimal->value.character.string, - "OPEN", warn)) + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C " + "not allowed in Fortran 95") == FAILURE) goto cleanup; - } */ + + if (open->decimal->expr_type == EXPR_CONSTANT) + { + static const char * decimal[] = { "COMMA", "POINT", NULL }; + + if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL, + open->decimal->value.character.string, + "OPEN", warn)) + goto cleanup; + } + } /* Checks on the DELIM specifier. */ - if (open->delim && open->delim->expr_type == EXPR_CONSTANT) + if (open->delim) { - static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL }; - - if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL, - open->delim->value.character.string, - "OPEN", warn)) + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C " + "not allowed in Fortran 95") == FAILURE) goto cleanup; + + if (open->delim->expr_type == EXPR_CONSTANT) + { + static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL }; + + if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL, + open->delim->value.character.string, + "OPEN", warn)) + goto cleanup; + } } /* Checks on the ENCODING specifier. */ - /* TODO: uncomment this code when ENCODING support is added - if (open->encoding && open->encoding->expr_type == EXPR_CONSTANT) + if (open->encoding) { - static const char * encoding[] = { "UTF-8", "DEFAULT", NULL }; + /* When implemented, change the following to use gfc_notify_std F2003. + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENCODING= at %C " + "not allowed in Fortran 95") == FAILURE) + goto cleanup; */ + gfc_error ("F2003 Feature: ENCODING=specifier at %C not implemented"); + goto cleanup; + + if (open->encoding->expr_type == EXPR_CONSTANT) + { + static const char * encoding[] = { "UTF-8", "DEFAULT", NULL }; - if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL, - open->encoding->value.character.string, - "OPEN", warn)) - goto cleanup; - } */ + if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL, + open->encoding->value.character.string, + "OPEN", warn)) + goto cleanup; + } + } /* Checks on the FORM specifier. */ if (open->form && open->form->expr_type == EXPR_CONSTANT) @@ -1593,30 +1681,43 @@ gfc_match_open (void) } /* Checks on the ROUND specifier. */ - /* TODO: uncomment this code when ROUND support is added - if (open->round && open->round->expr_type == EXPR_CONSTANT) + if (open->round) { - static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST", - "COMPATIBLE", "PROCESSOR_DEFINED", NULL }; + /* When implemented, change the following to use gfc_notify_std F2003. */ + gfc_error ("F2003 Feature: ROUND=specifier at %C not implemented"); + goto cleanup; - if (!compare_to_allowed_values ("ROUND", round, NULL, NULL, - open->round->value.character.string, - "OPEN", warn)) - goto cleanup; - } */ + if (open->round->expr_type == EXPR_CONSTANT) + { + static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST", + "COMPATIBLE", "PROCESSOR_DEFINED", + NULL }; + + if (!compare_to_allowed_values ("ROUND", round, NULL, NULL, + open->round->value.character.string, + "OPEN", warn)) + goto cleanup; + } + } /* Checks on the SIGN specifier. */ - /* TODO: uncomment this code when SIGN support is added - if (open->sign && open->sign->expr_type == EXPR_CONSTANT) + if (open->sign) { - static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED", - NULL }; - - if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL, - open->sign->value.character.string, - "OPEN", warn)) + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C " + "not allowed in Fortran 95") == FAILURE) goto cleanup; - } */ + + if (open->sign->expr_type == EXPR_CONSTANT) + { + static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED", + NULL }; + + if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL, + open->sign->value.character.string, + "OPEN", warn)) + goto cleanup; + } + } #define warn_or_error(...) \ { \ @@ -1648,8 +1749,8 @@ gfc_match_open (void) "OPEN", warn)) goto cleanup; - /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE, - the FILE= specifier shall appear. */ + /* F2003, 9.4.5: If the STATUS=specifier has the value NEW or REPLACE, + the FILE=specifier shall appear. */ if (open->file == NULL && (strncasecmp (open->status->value.character.string, "replace", 7) == 0 @@ -1661,8 +1762,8 @@ gfc_match_open (void) open->status->value.character.string); } - /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH, - the FILE= specifier shall not appear. */ + /* F2003, 9.4.5: If the STATUS=specifier has the value SCRATCH, + the FILE=specifier shall not appear. */ if (strncasecmp (open->status->value.character.string, "scratch", 7) == 0 && open->file) { @@ -1674,11 +1775,8 @@ gfc_match_open (void) /* Things that are not allowed for unformatted I/O. */ if (open->form && open->form->expr_type == EXPR_CONSTANT - && (open->delim - /* TODO uncomment this code when F2003 support is finished */ - /* || open->decimal || open->encoding || open->round - || open->sign */ - || open->pad || open->blank) + && (open->delim || open->decimal || open->encoding || open->round + || open->sign || open->pad || open->blank) && strncasecmp (open->form->value.character.string, "unformatted", 11) == 0) { @@ -2203,6 +2301,30 @@ match_dt_element (io_kind k, gfc_dt *dt) return MATCH_YES; } + m = match_etag (&tag_async, &dt->asynchronous); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_blank, &dt->blank); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_delim, &dt->delim); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_pad, &dt->pad); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_sign, &dt->sign); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_round, &dt->round); + if (m != MATCH_NO) + return m; + m = match_out_tag (&tag_id, &dt->id); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_decimal, &dt->decimal); + if (m != MATCH_NO) + return m; m = match_etag (&tag_rec, &dt->rec); if (m != MATCH_NO) return m; @@ -2265,6 +2387,12 @@ gfc_free_dt (gfc_dt *dt) gfc_free_expr (dt->iomsg); gfc_free_expr (dt->iostat); gfc_free_expr (dt->size); + gfc_free_expr (dt->pad); + gfc_free_expr (dt->delim); + gfc_free_expr (dt->sign); + gfc_free_expr (dt->round); + gfc_free_expr (dt->blank); + gfc_free_expr (dt->decimal); gfc_free (dt); } @@ -2283,6 +2411,12 @@ gfc_resolve_dt (gfc_dt *dt) RESOLVE_TAG (&tag_iomsg, dt->iomsg); RESOLVE_TAG (&tag_iostat, dt->iostat); RESOLVE_TAG (&tag_size, dt->size); + RESOLVE_TAG (&tag_e_pad, dt->pad); + RESOLVE_TAG (&tag_e_delim, dt->delim); + RESOLVE_TAG (&tag_e_sign, dt->sign); + RESOLVE_TAG (&tag_e_round, dt->round); + RESOLVE_TAG (&tag_e_blank, dt->blank); + RESOLVE_TAG (&tag_e_decimal, dt->decimal); e = dt->io_unit; if (gfc_resolve_expr (e) == SUCCESS @@ -2648,6 +2782,11 @@ if (condition) \ match m; gfc_expr *expr; gfc_symbol *sym = NULL; + bool warn, unformatted; + + warn = (dt->err || dt->iostat) ? true : false; + unformatted = dt->format_expr == NULL && dt->format_label == NULL + && dt->namelist == NULL; m = MATCH_YES; @@ -2669,11 +2808,14 @@ if (condition) \ "REC tag at %L is incompatible with internal file", &dt->rec->where); - io_constraint (dt->format_expr == NULL && dt->format_label == NULL - && dt->namelist == NULL, + io_constraint (unformatted, "Unformatted I/O not allowed with internal unit at %L", &dt->io_unit->where); + io_constraint (dt->asynchronous != NULL, + "ASYNCHRONOUS tag at %L not allowed with internal file", + &dt->asynchronous->where); + if (dt->namelist != NULL) { if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Internal file " @@ -2696,7 +2838,6 @@ if (condition) \ io_kind_name (k)); } - if (k != M_READ) { io_constraint (dt->end, "END tag not allowed with output at %L", @@ -2705,8 +2846,13 @@ if (condition) \ io_constraint (dt->eor, "EOR tag not allowed with output at %L", &dt->eor_where); - io_constraint (k != M_READ && dt->size, - "SIZE=specifier not allowed with output at %L", + io_constraint (dt->blank, "BLANK=specifier not allowed with output at %L", + &dt->blank->where); + + io_constraint (dt->pad, "PAD=specifier not allowed with output at %L", + &dt->pad->where); + + io_constraint (dt->size, "SIZE=specifier not allowed with output at %L", &dt->size->where); } else @@ -2720,8 +2866,167 @@ if (condition) \ &dt->eor_where); } + if (dt->asynchronous && dt->asynchronous->expr_type == EXPR_CONSTANT) + { + static const char * asynchronous[] = { "YES", "NO", NULL }; + + if (!compare_to_allowed_values + ("ASYNCHRONOUS", asynchronous, NULL, NULL, + dt->asynchronous->value.character.string, + io_kind_name (k), warn)) + return MATCH_ERROR; + } + + if (dt->id) + { + io_constraint (dt->asynchronous + && strcmp (dt->asynchronous->value.character.string, + "yes"), + "ID=specifier at %L must be with ASYNCHRONOUS='yes' " + "specifier", &dt->id->where); + } + + if (dt->decimal) + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C " + "not allowed in Fortran 95") == FAILURE) + return MATCH_ERROR; + + if (dt->decimal->expr_type == EXPR_CONSTANT) + { + static const char * decimal[] = { "COMMA", "POINT", NULL }; + + if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL, + dt->decimal->value.character.string, + io_kind_name (k), warn)) + return MATCH_ERROR; + + io_constraint (unformatted, + "the DECIMAL=specifier at %L must be with an " + "explicit format expression", &dt->decimal->where); + } + } + + if (dt->blank) + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C " + "not allowed in Fortran 95") == FAILURE) + return MATCH_ERROR; + + if (dt->blank->expr_type == EXPR_CONSTANT) + { + static const char * blank[] = { "NULL", "ZERO", NULL }; + + if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL, + dt->blank->value.character.string, + io_kind_name (k), warn)) + return MATCH_ERROR; + + io_constraint (unformatted, + "the BLANK=specifier at %L must be with an " + "explicit format expression", &dt->blank->where); + } + } + + if (dt->pad) + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PAD= at %C " + "not allowed in Fortran 95") == FAILURE) + return MATCH_ERROR; + + if (dt->pad->expr_type == EXPR_CONSTANT) + { + static const char * pad[] = { "YES", "NO", NULL }; + + if (!compare_to_allowed_values ("PAD", pad, NULL, NULL, + dt->pad->value.character.string, + io_kind_name (k), warn)) + return MATCH_ERROR; + + io_constraint (unformatted, + "the PAD=specifier at %L must be with an " + "explicit format expression", &dt->pad->where); + } + } + + if (dt->round) + { + /* When implemented, change the following to use gfc_notify_std F2003. + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ROUND= at %C " + "not allowed in Fortran 95") == FAILURE) + return MATCH_ERROR; */ + gfc_error ("F2003 Feature: ROUND=specifier at %C not implemented"); + return MATCH_ERROR; + + if (dt->round->expr_type == EXPR_CONSTANT) + { + static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST", + "COMPATIBLE", "PROCESSOR_DEFINED", + NULL }; + + if (!compare_to_allowed_values ("ROUND", round, NULL, NULL, + dt->round->value.character.string, + io_kind_name (k), warn)) + return MATCH_ERROR; + } + } + + if (dt->sign) + { + /* When implemented, change the following to use gfc_notify_std F2003. + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C " + "not allowed in Fortran 95") == FAILURE) + return MATCH_ERROR; */ + if (dt->sign->expr_type == EXPR_CONSTANT) + { + static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED", + NULL }; + + if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL, + dt->sign->value.character.string, + io_kind_name (k), warn)) + return MATCH_ERROR; + + io_constraint (unformatted, + "SIGN=specifier at %L must be with an " + "explicit format expression", &dt->sign->where); + io_constraint (k == M_READ, + "SIGN=specifier at %L not allowed in a " + "READ statement", &dt->sign->where); + } + } + + if (dt->delim) + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C " + "not allowed in Fortran 95") == FAILURE) + return MATCH_ERROR; + if (dt->delim->expr_type == EXPR_CONSTANT) + { + static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL }; + + if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL, + dt->delim->value.character.string, + io_kind_name (k), warn)) + return MATCH_ERROR; + + io_constraint (k == M_READ, + "DELIM=specifier at %L not allowed in a " + "READ statement", &dt->delim->where); + + io_constraint (dt->format_label != &format_asterisk + && dt->namelist == NULL, + "DELIM=specifier at %L must have FMT=*", + &dt->delim->where); + + io_constraint (unformatted && dt->namelist == NULL, + "DELIM=specifier at %L must be with FMT=* or " + "NML=specifier ", &dt->delim->where); + } + } + if (dt->namelist) { io_constraint (io_code && dt->namelist, @@ -2752,7 +3057,6 @@ if (condition) \ "An END tag is not allowed with a " "REC=specifier at %L.", &dt->end_where); - io_constraint (dt->format_label == &format_asterisk, "FMT=* is not allowed with a REC=specifier " "at %L.", spec_end); @@ -2767,8 +3071,7 @@ if (condition) \ "List directed format(*) is not allowed with a " "ADVANCE=specifier at %L.", &expr->where); - io_constraint (dt->format_expr == NULL && dt->format_label == NULL - && dt->namelist == NULL, + io_constraint (unformatted, "the ADVANCE=specifier at %L must appear with an " "explicit format expression", &expr->where); @@ -3025,12 +3328,14 @@ gfc_match_read (void) return match_io (M_READ); } + match gfc_match_write (void) { return match_io (M_WRITE); } + match gfc_match_print (void) { @@ -3289,3 +3594,120 @@ gfc_resolve_inquire (gfc_inquire *inquire) return SUCCESS; } + + +void +gfc_free_wait (gfc_wait *wait) +{ + if (wait == NULL) + return; + + gfc_free_expr (wait->unit); + gfc_free_expr (wait->iostat); + gfc_free_expr (wait->iomsg); + gfc_free_expr (wait->id); +} + + +try +gfc_resolve_wait (gfc_wait *wait) +{ + RESOLVE_TAG (&tag_unit, wait->unit); + RESOLVE_TAG (&tag_iomsg, wait->iomsg); + RESOLVE_TAG (&tag_iostat, wait->iostat); + RESOLVE_TAG (&tag_id, wait->id); + + if (gfc_reference_st_label (wait->err, ST_LABEL_TARGET) == FAILURE) + return FAILURE; + + if (gfc_reference_st_label (wait->end, ST_LABEL_TARGET) == FAILURE) + return FAILURE; + + return SUCCESS; +} + +/* Match an element of a WAIT statement. */ + +#define RETM if (m != MATCH_NO) return m; + +static match +match_wait_element (gfc_wait *wait) +{ + match m; + + m = match_etag (&tag_unit, &wait->unit); + RETM m = match_ltag (&tag_err, &wait->err); + RETM m = match_ltag (&tag_end, &wait->eor); + RETM m = match_ltag (&tag_eor, &wait->end); + RETM m = match_out_tag (&tag_iomsg, &wait->iomsg); + RETM m = match_out_tag (&tag_iostat, &wait->iostat); + RETM m = match_etag (&tag_id, &wait->id); + RETM return MATCH_NO; +} + +#undef RETM + + +match +gfc_match_wait (void) +{ + gfc_wait *wait; + match m; + locus loc; + + m = gfc_match_char ('('); + if (m == MATCH_NO) + return m; + + wait = gfc_getmem (sizeof (gfc_wait)); + + loc = gfc_current_locus; + + m = match_wait_element (wait); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + m = gfc_match_expr (&wait->unit); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } + + for (;;) + { + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + m = match_wait_element (wait); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } + + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: WAIT at %C " + "not allowed in Fortran 95") == FAILURE) + goto cleanup; + + if (gfc_pure (NULL)) + { + gfc_error ("WAIT statement not allowed in PURE procedure at %C"); + goto cleanup; + } + + new_st.op = EXEC_WAIT; + new_st.ext.wait = wait; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_WAIT); + +cleanup: + gfc_free_wait (wait); + return MATCH_ERROR; +} diff --git a/gcc/fortran/ioparm.def b/gcc/fortran/ioparm.def index 57a5db9..b16fcb5 100644 --- a/gcc/fortran/ioparm.def +++ b/gcc/fortran/ioparm.def @@ -8,10 +8,10 @@ #define IOPARM_common_end (1 << 3) #define IOPARM_common_eor (1 << 4) #endif -IOPARM (common, flags, 0, int4) -IOPARM (common, unit, 0, int4) -IOPARM (common, filename, 0, pchar) -IOPARM (common, line, 0, int4) +IOPARM (common, flags, 0, int4) +IOPARM (common, unit, 0, int4) +IOPARM (common, filename, 0, pchar) +IOPARM (common, line, 0, int4) IOPARM (common, iomsg, 1 << 6, char2) IOPARM (common, iostat, 1 << 5, pint4) IOPARM (open, common, 0, common) @@ -25,7 +25,12 @@ IOPARM (open, position, 1 << 13, char1) IOPARM (open, action, 1 << 14, char2) IOPARM (open, delim, 1 << 15, char1) IOPARM (open, pad, 1 << 16, char2) -IOPARM (open, convert, 1 << 17, char1) +IOPARM (open, convert, 1 << 17, char1) +IOPARM (open, decimal, 1 << 18, char2) +IOPARM (open, encoding, 1 << 19, char1) +IOPARM (open, round, 1 << 20, char2) +IOPARM (open, sign, 1 << 21, char1) +IOPARM (open, asynchronous, 1 << 22, char2) IOPARM (close, common, 0, common) IOPARM (close, status, 1 << 7, char1) IOPARM (filepos, common, 0, common) @@ -53,7 +58,18 @@ IOPARM (inquire, unformatted, 1 << 26, char1) IOPARM (inquire, read, 1 << 27, char2) IOPARM (inquire, write, 1 << 28, char1) IOPARM (inquire, readwrite, 1 << 29, char2) -IOPARM (inquire, convert, 1 << 30, char1) +IOPARM (inquire, convert, 1 << 30, char1) +IOPARM (inquire, flags2, 1 << 31, int4) +IOPARM (inquire, asynchronous, 1 << 0, char1) +IOPARM (inquire, decimal, 1 << 1, char2) +IOPARM (inquire, encoding, 1 << 2, char1) +IOPARM (inquire, round, 1 << 3, char2) +IOPARM (inquire, sign, 1 << 4, char1) +IOPARM (inquire, pending, 1 << 5, pint4) +IOPARM (inquire, size, 1 << 6, pint4) +IOPARM (inquire, id, 1 << 7, pint4) +IOPARM (wait, common, 0, common) +IOPARM (wait, id, 1 << 7, pint4) #ifndef IOPARM_dt_list_format #define IOPARM_dt_list_format (1 << 7) #define IOPARM_dt_namelist_read_mode (1 << 8) @@ -67,4 +83,13 @@ IOPARM (dt, format, 1 << 12, char1) IOPARM (dt, advance, 1 << 13, char2) IOPARM (dt, internal_unit, 1 << 14, char1) IOPARM (dt, namelist_name, 1 << 15, char2) -IOPARM (dt, u, 0, pad) +IOPARM (dt, id, 1 << 16, pint4) +IOPARM (dt, pos, 1 << 17, intio) +IOPARM (dt, asynchronous, 1 << 18, char1) +IOPARM (dt, blank, 1 << 19, char2) +IOPARM (dt, decimal, 1 << 20, char1) +IOPARM (dt, delim, 1 << 21, char2) +IOPARM (dt, pad, 1 << 22, char1) +IOPARM (dt, round, 1 << 23, char2) +IOPARM (dt, sign, 1 << 24, char1) +IOPARM (dt, u, 0, pad) diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 25edd4a..8512d03 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1533,6 +1533,7 @@ gfc_match_if (gfc_statement *if_type) match ("return", gfc_match_return, ST_RETURN) match ("rewind", gfc_match_rewind, ST_REWIND) match ("stop", gfc_match_stop, ST_STOP) + match ("wait", gfc_match_wait, ST_WAIT) match ("where", match_simple_where, ST_WHERE) match ("write", gfc_match_write, ST_WRITE) diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 34f1af1..4a3776e 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -212,6 +212,7 @@ match gfc_match_rewind (void); match gfc_match_flush (void); match gfc_match_inquire (void); match gfc_match_read (void); +match gfc_match_wait (void); match gfc_match_write (void); match gfc_match_print (void); diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index ff1d565..d7d81a1 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -440,6 +440,7 @@ decode_statement (void) break; case 'w': + match ("wait", gfc_match_wait, ST_WAIT); match ("write", gfc_match_write, ST_WRITE); break; } @@ -861,9 +862,9 @@ next_statement (void) case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \ case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \ case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \ - case ST_PAUSE: case ST_STOP: case ST_WRITE: case ST_ASSIGNMENT: \ + case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \ case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \ - case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \ + case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \ case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \ case ST_OMP_BARRIER @@ -1268,6 +1269,9 @@ gfc_ascii_statement (gfc_statement st) case ST_WHERE: p = "WHERE"; break; + case ST_WAIT: + p = "WAIT"; + break; case ST_WRITE: p = "WRITE"; break; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index af9ef55..65d1a16 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5964,6 +5964,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) case EXEC_READ: case EXEC_WRITE: case EXEC_IOLENGTH: + case EXEC_WAIT: break; case EXEC_OMP_ATOMIC: @@ -6373,6 +6374,15 @@ resolve_code (gfc_code *code, gfc_namespace *ns) resolve_branch (code->ext.inquire->err, code); break; + case EXEC_WAIT: + if (gfc_resolve_wait (code->ext.wait) == FAILURE) + break; + + resolve_branch (code->ext.wait->err, code); + resolve_branch (code->ext.wait->end, code); + resolve_branch (code->ext.wait->eor, code); + break; + case EXEC_READ: case EXEC_WRITE: if (gfc_resolve_dt (code->ext.dt) == FAILURE) diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index 5f65846..0f0e481 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -146,6 +146,10 @@ gfc_free_statement (gfc_code *p) gfc_free_inquire (p->ext.inquire); break; + case EXEC_WAIT: + gfc_free_wait (p->ext.wait); + break; + case EXEC_READ: case EXEC_WRITE: gfc_free_dt (p->ext.dt); diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index f5f1df0..6bc41e1 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -45,6 +45,7 @@ enum ioparam_type IOPARM_ptype_filepos, IOPARM_ptype_inquire, IOPARM_ptype_dt, + IOPARM_ptype_wait, IOPARM_ptype_num }; @@ -96,7 +97,8 @@ static GTY(()) gfc_st_parameter st_parameter[] = { "close", NULL }, { "filepos", NULL }, { "inquire", NULL }, - { "dt", NULL } + { "dt", NULL }, + { "wait", NULL } }; static GTY(()) gfc_st_parameter_field st_parameter_field[] = @@ -133,6 +135,7 @@ enum iocall IOCALL_FLUSH, IOCALL_SET_NML_VAL, IOCALL_SET_NML_VAL_DIM, + IOCALL_WAIT, IOCALL_NUM }; @@ -372,6 +375,11 @@ gfc_build_io_library_fndecls (void) gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")), void_type_node, 1, dt_parm_type); + parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type); + iocall[IOCALL_WAIT] = + gfc_build_library_function_decl (get_identifier (PREFIX("st_wait")), + gfc_int4_type_node, 1, parm_type); + parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type); iocall[IOCALL_REWIND] = gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")), @@ -921,6 +929,24 @@ gfc_trans_open (gfc_code * code) if (p->pad) mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad); + if (p->decimal) + mask |= set_string (&block, &post_block, var, IOPARM_open_decimal, + p->decimal); + + if (p->encoding) + mask |= set_string (&block, &post_block, var, IOPARM_open_encoding, + p->encoding); + + if (p->round) + mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round); + + if (p->sign) + mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign); + + if (p->asynchronous) + mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous, + p->asynchronous); + if (p->convert) mask |= set_string (&block, &post_block, var, IOPARM_open_convert, p->convert); @@ -1117,7 +1143,7 @@ gfc_trans_inquire (gfc_code * code) stmtblock_t block, post_block; gfc_inquire *p; tree tmp, var; - unsigned int mask = 0; + unsigned int mask = 0, mask2 = 0; gfc_start_block (&block); gfc_init_block (&post_block); @@ -1248,6 +1274,43 @@ gfc_trans_inquire (gfc_code * code) mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_strm_pos_out, p->strm_pos); + /* The second series of flags. */ + if (p->asynchronous) + mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous, + p->asynchronous); + + if (p->decimal) + mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal, + p->decimal); + + if (p->encoding) + mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding, + p->encoding); + + if (p->round) + mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round, + p->round); + + if (p->sign) + mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign, + p->sign); + + if (p->pending) + mask2 |= set_parameter_ref (&block, &post_block, var, + IOPARM_inquire_pending, p->pending); + + if (p->size) + mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size, + p->size); + + if (p->id) + mask2 |= set_parameter_value (&block, var, IOPARM_inquire_id, p->id); + + set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2); + + if (mask2) + mask |= IOPARM_inquire_flags2; + set_parameter_const (&block, var, IOPARM_common_flags, mask); if (p->unit) @@ -1266,6 +1329,56 @@ gfc_trans_inquire (gfc_code * code) return gfc_finish_block (&block); } + +tree +gfc_trans_wait (gfc_code * code) +{ + stmtblock_t block, post_block; + gfc_wait *p; + tree tmp, var; + unsigned int mask = 0; + + gfc_start_block (&block); + gfc_init_block (&post_block); + + var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type, + "wait_parm"); + + set_error_locus (&block, var, &code->loc); + p = code->ext.wait; + + /* Set parameters here. */ + if (p->iomsg) + mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, + p->iomsg); + + if (p->iostat) + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, + p->iostat); + + if (p->err) + mask |= IOPARM_common_err; + + if (p->id) + mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id); + + set_parameter_const (&block, var, IOPARM_common_flags, mask); + + if (p->unit) + set_parameter_value (&block, var, IOPARM_common_unit, p->unit); + + tmp = build_fold_addr_expr (var); + tmp = build_call_expr (iocall[IOCALL_WAIT], 1, tmp); + gfc_add_expr_to_block (&block, tmp); + + gfc_add_block_to_block (&block, &post_block); + + io_result (&block, var, p->err, NULL, NULL); + + return gfc_finish_block (&block); + +} + static gfc_expr * gfc_new_nml_name_expr (const char * name) { @@ -1583,6 +1696,41 @@ build_dt (tree function, gfc_code * code) if (dt->end) mask |= IOPARM_common_end; + if (dt->id) + mask |= set_parameter_ref (&block, &post_end_block, var, + IOPARM_dt_id, dt->id); + + if (dt->pos) + mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos); + + if (dt->asynchronous) + mask |= set_string (&block, &post_block, var, IOPARM_dt_asynchronous, + dt->asynchronous); + + if (dt->blank) + mask |= set_string (&block, &post_block, var, IOPARM_dt_blank, + dt->blank); + + if (dt->decimal) + mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal, + dt->decimal); + + if (dt->delim) + mask |= set_string (&block, &post_block, var, IOPARM_dt_delim, + dt->delim); + + if (dt->pad) + mask |= set_string (&block, &post_block, var, IOPARM_dt_pad, + dt->pad); + + if (dt->round) + mask |= set_string (&block, &post_block, var, IOPARM_dt_round, + dt->round); + + if (dt->sign) + mask |= set_string (&block, &post_block, var, IOPARM_dt_sign, + dt->sign); + if (dt->rec) mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec); diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index f2b9b84..5d92a9c 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -69,3 +69,4 @@ tree gfc_trans_flush (gfc_code *); tree gfc_trans_transfer (gfc_code *); tree gfc_trans_dt_end (gfc_code *); +tree gfc_trans_wait (gfc_code *); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 36a7f12..a9951e4 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1108,6 +1108,10 @@ gfc_trans_code (gfc_code * code) res = gfc_trans_inquire (code); break; + case EXEC_WAIT: + res = gfc_trans_wait (code); + break; + case EXEC_REWIND: res = gfc_trans_rewind (code); break; |