diff options
| -rw-r--r-- | gcc/fortran/dump-parse-tree.c | 26 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 10 | ||||
| -rw-r--r-- | gcc/fortran/io.c | 31 | ||||
| -rw-r--r-- | gcc/fortran/trans-io.c | 28 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 4 | ||||
| -rwxr-xr-x | gcc/testsuite/gfortran.dg/iomsg_1.f90 | 28 | ||||
| -rw-r--r-- | libgfortran/ChangeLog | 6 | ||||
| -rw-r--r-- | libgfortran/io/io.h | 3 | ||||
| -rw-r--r-- | libgfortran/runtime/error.c | 19 |
9 files changed, 141 insertions, 14 deletions
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 8f039d2..2d708f7 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -1084,6 +1084,11 @@ gfc_show_code_node (int level, gfc_code * c) gfc_status (" UNIT="); gfc_show_expr (open->unit); } + if (open->iomsg) + { + gfc_status (" IOMSG="); + gfc_show_expr (open->iomsg); + } if (open->iostat) { gfc_status (" IOSTAT="); @@ -1153,6 +1158,11 @@ gfc_show_code_node (int level, gfc_code * c) gfc_status (" UNIT="); gfc_show_expr (close->unit); } + if (close->iomsg) + { + gfc_status (" IOMSG="); + gfc_show_expr (close->iomsg); + } if (close->iostat) { gfc_status (" IOSTAT="); @@ -1190,6 +1200,11 @@ gfc_show_code_node (int level, gfc_code * c) gfc_status (" UNIT="); gfc_show_expr (fp->unit); } + if (fp->iomsg) + { + gfc_status (" IOMSG="); + gfc_show_expr (fp->iomsg); + } if (fp->iostat) { gfc_status (" IOSTAT="); @@ -1214,6 +1229,11 @@ gfc_show_code_node (int level, gfc_code * c) gfc_show_expr (i->file); } + if (i->iomsg) + { + gfc_status (" IOMSG="); + gfc_show_expr (i->iomsg); + } if (i->iostat) { gfc_status (" IOSTAT="); @@ -1360,6 +1380,12 @@ gfc_show_code_node (int level, gfc_code * c) gfc_status (" FMT=%d", dt->format_label->value); if (dt->namelist) gfc_status (" NML=%s", dt->namelist->name); + + if (dt->iomsg) + { + gfc_status (" IOMSG="); + gfc_show_expr (dt->iomsg); + } if (dt->iostat) { gfc_status (" IOSTAT="); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 59e1bea..301afac 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1270,7 +1270,7 @@ gfc_alloc; typedef struct { gfc_expr *unit, *file, *status, *access, *form, *recl, - *blank, *position, *action, *delim, *pad, *iostat; + *blank, *position, *action, *delim, *pad, *iostat, *iomsg; gfc_st_label *err; } gfc_open; @@ -1278,7 +1278,7 @@ gfc_open; typedef struct { - gfc_expr *unit, *status, *iostat; + gfc_expr *unit, *status, *iostat, *iomsg; gfc_st_label *err; } gfc_close; @@ -1286,7 +1286,7 @@ gfc_close; typedef struct { - gfc_expr *unit, *iostat; + gfc_expr *unit, *iostat, *iomsg; gfc_st_label *err; } gfc_filepos; @@ -1297,7 +1297,7 @@ 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; + *write, *readwrite, *delim, *pad, *iolength, *iomsg; gfc_st_label *err; @@ -1307,7 +1307,7 @@ gfc_inquire; typedef struct { - gfc_expr *io_unit, *format_expr, *rec, *advance, *iostat, *size; + gfc_expr *io_unit, *format_expr, *rec, *advance, *iostat, *size, *iomsg; gfc_symbol *namelist; /* A format_label of `format_asterisk' indicates the "*" format */ diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 37a7493..0ffc13d 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -53,6 +53,7 @@ static const io_tag tag_advance = {"ADVANCE", " advance = %e", BT_CHARACTER}, tag_rec = {"REC", " rec = %e", BT_INTEGER}, tag_format = {"FORMAT", NULL, BT_CHARACTER}, + tag_iomsg = {"IOMSG", " iomsg = %e", BT_CHARACTER}, tag_iostat = {"IOSTAT", " iostat = %v", BT_INTEGER}, tag_size = {"SIZE", " size = %v", BT_INTEGER}, tag_exist = {"EXIST", " exist = %v", BT_LOGICAL}, @@ -1035,6 +1036,12 @@ resolve_tag (const io_tag * tag, gfc_expr * e) gfc_error ("%s tag at %L must be scalar", tag->name, &e->where); return FAILURE; } + if (tag == &tag_iomsg) + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IOMSG tag at %L", + &e->where) == FAILURE) + return FAILURE; + } } return SUCCESS; @@ -1051,6 +1058,9 @@ match_open_element (gfc_open * open) m = match_etag (&tag_unit, &open->unit); if (m != MATCH_NO) return m; + m = match_out_tag (&tag_iomsg, &open->iomsg); + if (m != MATCH_NO) + return m; m = match_out_tag (&tag_iostat, &open->iostat); if (m != MATCH_NO) return m; @@ -1102,6 +1112,7 @@ gfc_free_open (gfc_open * open) return; gfc_free_expr (open->unit); + gfc_free_expr (open->iomsg); gfc_free_expr (open->iostat); gfc_free_expr (open->file); gfc_free_expr (open->status); @@ -1125,6 +1136,7 @@ gfc_resolve_open (gfc_open * open) { RESOLVE_TAG (&tag_unit, open->unit); + RESOLVE_TAG (&tag_iomsg, open->iomsg); RESOLVE_TAG (&tag_iostat, open->iostat); RESOLVE_TAG (&tag_file, open->file); RESOLVE_TAG (&tag_status, open->status); @@ -1217,6 +1229,7 @@ gfc_free_close (gfc_close * close) return; gfc_free_expr (close->unit); + gfc_free_expr (close->iomsg); gfc_free_expr (close->iostat); gfc_free_expr (close->status); @@ -1237,6 +1250,9 @@ match_close_element (gfc_close * close) m = match_etag (&tag_status, &close->status); if (m != MATCH_NO) return m; + m = match_out_tag (&tag_iomsg, &close->iomsg); + if (m != MATCH_NO) + return m; m = match_out_tag (&tag_iostat, &close->iostat); if (m != MATCH_NO) return m; @@ -1318,6 +1334,7 @@ gfc_resolve_close (gfc_close * close) { RESOLVE_TAG (&tag_unit, close->unit); + RESOLVE_TAG (&tag_iomsg, close->iomsg); RESOLVE_TAG (&tag_iostat, close->iostat); RESOLVE_TAG (&tag_status, close->status); @@ -1335,6 +1352,7 @@ gfc_free_filepos (gfc_filepos * fp) { gfc_free_expr (fp->unit); + gfc_free_expr (fp->iomsg); gfc_free_expr (fp->iostat); gfc_free (fp); } @@ -1350,6 +1368,9 @@ match_file_element (gfc_filepos * fp) m = match_etag (&tag_unit, &fp->unit); if (m != MATCH_NO) return m; + m = match_out_tag (&tag_iomsg, &fp->iomsg); + if (m != MATCH_NO) + return m; m = match_out_tag (&tag_iostat, &fp->iostat); if (m != MATCH_NO) return m; @@ -1439,6 +1460,8 @@ gfc_resolve_filepos (gfc_filepos * fp) { RESOLVE_TAG (&tag_unit, fp->unit); + RESOLVE_TAG (&tag_iostat, fp->iostat); + RESOLVE_TAG (&tag_iomsg, fp->iomsg); if (gfc_reference_st_label (fp->err, ST_LABEL_TARGET) == FAILURE) return FAILURE; @@ -1666,6 +1689,9 @@ match_dt_element (io_kind k, gfc_dt * dt) m = match_etag (&tag_rec, &dt->rec); if (m != MATCH_NO) return m; + m = match_out_tag (&tag_iomsg, &dt->iomsg); + if (m != MATCH_NO) + return m; m = match_out_tag (&tag_iostat, &dt->iostat); if (m != MATCH_NO) return m; @@ -1715,6 +1741,7 @@ gfc_free_dt (gfc_dt * dt) gfc_free_expr (dt->format_expr); gfc_free_expr (dt->rec); gfc_free_expr (dt->advance); + gfc_free_expr (dt->iomsg); gfc_free_expr (dt->iostat); gfc_free_expr (dt->size); @@ -1732,6 +1759,7 @@ gfc_resolve_dt (gfc_dt * dt) RESOLVE_TAG (&tag_format, dt->format_expr); RESOLVE_TAG (&tag_rec, dt->rec); RESOLVE_TAG (&tag_advance, dt->advance); + RESOLVE_TAG (&tag_iomsg, dt->iomsg); RESOLVE_TAG (&tag_iostat, dt->iostat); RESOLVE_TAG (&tag_size, dt->size); @@ -2364,6 +2392,7 @@ gfc_free_inquire (gfc_inquire * inquire) gfc_free_expr (inquire->unit); gfc_free_expr (inquire->file); + gfc_free_expr (inquire->iomsg); gfc_free_expr (inquire->iostat); gfc_free_expr (inquire->exist); gfc_free_expr (inquire->opened); @@ -2404,6 +2433,7 @@ match_inquire_element (gfc_inquire * inquire) m = match_etag (&tag_unit, &inquire->unit); RETM m = match_etag (&tag_file, &inquire->file); RETM m = match_ltag (&tag_err, &inquire->err); + RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg); RETM m = match_out_tag (&tag_iostat, &inquire->iostat); RETM m = match_vtag (&tag_exist, &inquire->exist); RETM m = match_vtag (&tag_opened, &inquire->opened); @@ -2555,6 +2585,7 @@ gfc_resolve_inquire (gfc_inquire * inquire) RESOLVE_TAG (&tag_unit, inquire->unit); RESOLVE_TAG (&tag_file, inquire->file); + RESOLVE_TAG (&tag_iomsg, inquire->iomsg); RESOLVE_TAG (&tag_iostat, inquire->iostat); RESOLVE_TAG (&tag_exist, inquire->exist); RESOLVE_TAG (&tag_opened, inquire->opened); diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index b25e80a..e9a9c60 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -98,6 +98,8 @@ static GTY(()) tree ioparm_readwrite_len; static GTY(()) tree ioparm_namelist_name; static GTY(()) tree ioparm_namelist_name_len; static GTY(()) tree ioparm_namelist_read_mode; +static GTY(()) tree ioparm_iomsg; +static GTY(()) tree ioparm_iomsg_len; /* The global I/O variables */ @@ -213,6 +215,7 @@ gfc_build_io_library_fndecls (void) ADD_STRING (namelist_name); ADD_FIELD (namelist_read_mode, gfc_int4_type_node); + ADD_STRING (iomsg); gfc_finish_type (ioparm_type); @@ -642,6 +645,10 @@ gfc_trans_open (gfc_code * code) if (p->pad) set_string (&block, &post_block, ioparm_pad, ioparm_pad_len, p->pad); + if (p->iomsg) + set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len, + p->iomsg); + if (p->iostat) set_parameter_ref (&block, ioparm_iostat, p->iostat); @@ -681,6 +688,10 @@ gfc_trans_close (gfc_code * code) set_string (&block, &post_block, ioparm_status, ioparm_status_len, p->status); + if (p->iomsg) + set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len, + p->iomsg); + if (p->iostat) set_parameter_ref (&block, ioparm_iostat, p->iostat); @@ -703,19 +714,24 @@ gfc_trans_close (gfc_code * code) static tree build_filepos (tree function, gfc_code * code) { - stmtblock_t block; + stmtblock_t block, post_block; gfc_filepos *p; tree tmp; p = code->ext.filepos; gfc_init_block (&block); + gfc_init_block (&post_block); set_error_locus (&block, &code->loc); if (p->unit) set_parameter_value (&block, ioparm_unit, p->unit); + if (p->iomsg) + set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len, + p->iomsg); + if (p->iostat) set_parameter_ref (&block, ioparm_iostat, p->iostat); @@ -725,6 +741,8 @@ build_filepos (tree function, gfc_code * code) tmp = gfc_build_function_call (function, NULL); gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&block, &post_block); + io_result (&block, p->err, NULL, NULL); return gfc_finish_block (&block); @@ -796,6 +814,10 @@ gfc_trans_inquire (gfc_code * code) if (p->file) set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file); + if (p->iomsg) + set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len, + p->iomsg); + if (p->iostat) set_parameter_ref (&block, ioparm_iostat, p->iostat); @@ -1179,6 +1201,10 @@ build_dt (tree * function, gfc_code * code) ioparm_format_len, dt->format_label->format); } + if (dt->iomsg) + set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len, + dt->iomsg); + if (dt->iostat) set_parameter_ref (&block, ioparm_iostat, dt->iostat); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index db903b1..da40a59 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2005-09-09 Thomas Koenig <Thomas.Koenig@online.de> + + * gfortran.dg/iomsg_1.f90: New test case. + 2005-09-09 Richard Guenther <rguenther@suse.de> PR c++/23624 diff --git a/gcc/testsuite/gfortran.dg/iomsg_1.f90 b/gcc/testsuite/gfortran.dg/iomsg_1.f90 new file mode 100755 index 0000000..6a5819d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/iomsg_1.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! Test implementation of the iomsg tag. +program iomsg_test + character(len=70) ch + + ! Test that iomsg is left unchanged with no error + ch = 'asdf' + open(10, status='scratch', iomsg=ch, iostat=i) ! { dg-warning "Fortran 2003: IOMSG tag" } + if (ch .ne. 'asdf') call abort + + ! Test iomsg with data transfer statement + read(10,'(I2)', iomsg=ch, end=100) k ! { dg-warning "Fortran 2003: IOMSG tag" } + call abort +100 continue + if (ch .ne. 'End of file') call abort + + ! Test iomsg with open + open (-3, err=200, iomsg=ch) ! { dg-warning "Fortran 2003: IOMSG tag" } + + call abort +200 continue + if (ch .ne. 'Bad unit number in OPEN statement') call abort + + ! Test iomsg with close + close(23,status="no_idea", err=500, iomsg=ch) ! { dg-warning "Fortran 2003: IOMSG tag" } +500 continue + if (ch .ne. "Bad STATUS parameter in CLOSE statement") call abort +end program iomsg_test diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 5edab98..6e45ee0 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,9 @@ +2005-09-09 Thomas Koenig <Thomas.Koenig@online.de> + + * io/io.h: Add iomsg as last field of st_parameter. + * runtime/error.c (generate_error): If iomsg is present, copy + the message there. + 2005-09-09 Richard Sandiford <richard@codesourcery.com> PR fortran/12840 diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index 06825df..6f4023b 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -263,6 +263,9 @@ typedef struct CHARACTER (namelist_name); GFC_INTEGER_4 namelist_read_mode; + /* iomsg */ + CHARACTER (iomsg); + #undef CHARACTER } st_parameter; diff --git a/libgfortran/runtime/error.c b/libgfortran/runtime/error.c index 2a84edf..3c1686d 100644 --- a/libgfortran/runtime/error.c +++ b/libgfortran/runtime/error.c @@ -441,10 +441,10 @@ translate_error (int code) /* generate_error()-- Come here when an error happens. This - * subroutine is called if it is possible to continue on after the - * error. If an IOSTAT variable exists, we set it. If the IOSTAT or - * ERR label is present, we return, otherwise we terminate the program - * after print a message. The error code is always required but the + * subroutine is called if it is possible to continue on after the error. + * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or + * ERR labels are present, we return, otherwise we terminate the program + * after printing a message. The error code is always required but the * message parameter can be NULL, in which case a string describing * the most recent operating system error is used. */ @@ -455,6 +455,13 @@ generate_error (int family, const char *message) if (ioparm.iostat != NULL) *ioparm.iostat = family; + if (message == NULL) + message = + (family == ERROR_OS) ? get_oserror () : translate_error (family); + + if (ioparm.iomsg) + cf_strcpy (ioparm.iomsg, ioparm.iomsg_len, message); + /* Report status back to the compiler. */ switch (family) { @@ -483,10 +490,6 @@ generate_error (int family, const char *message) /* Terminate the program */ - if (message == NULL) - message = - (family == ERROR_OS) ? get_oserror () : translate_error (family); - runtime_error (message); } |