From 65f9e5fc730d0ed1763b00efb53144ab9d5b0b1d Mon Sep 17 00:00:00 2001
From: tkoenig <tkoenig@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Fri, 9 Sep 2005 18:21:45 +0000
Subject: [PATCH] 2005-09-09 Thomas Koenig <Thomas.Koenig@online.de>
* gfortran.h: Add iomsg to gfc_open, gfc_close, gfc_filepos,
gfc_inquire and gfc_dt.
* dump-parse-tree.c (gfc_show_code_node): Add iomsg
for open, close, file positioning, inquire and namelist.
* io.c (io_tag): Add tag_iomsg.
(resolve_tag): Add standards warning for iomsg.
(match_open_element): Add iomsg.
(gfc_free_open): Add iomsg.
(gfc_resolve_open): Add iomsg.
(gfc_free_close): Add iomsg.
(match_close_element): Add iomsg.
(gfc_resolve_close): Add iomsg.
(gfc_free_filepos): Add iomsg.
(match_file_element): Add iomsg.
(gfc_resolve_filepos): Add iostat and iomsg.
(match-dt_element): Add iomsg.
(gfc_free_dt): Add iomsg.
(gfc_resolve_dt): Add iomsg.
(gfc_free_inquire): Add iomsg.
(match_inquire_element): Add iomsg.
(gfc_resolve_inquire): Add iomsg.
* trans_io.c: Add ioparm_iomsg and ioparm_iomsg_len.
(gfc_build_io_library_fndecls): Add iomsg as last field.
(gfc_trans_open): Add iomsg.
(gfc_trans_close): Add iomsg.
(build_fileos): Call set_string for iomsg.
(gfc_trans_inquire): Add iomsg.
(build_dt): Add iomsg.
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 Thomas Koenig <Thomas.Koenig@online.de>
* gfortran.dg/iomsg_1.f90: New test case.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@104102 138bc75d-0d04-0410-961f-82ee72b054a4
---
gcc/fortran/dump-parse-tree.c | 26 ++++++++++++++++++++++
gcc/fortran/gfortran.h | 10 ++++-----
gcc/fortran/io.c | 31 +++++++++++++++++++++++++++
gcc/fortran/trans-io.c | 28 +++++++++++++++++++++++-
gcc/testsuite/ChangeLog | 4 ++++
gcc/testsuite/gfortran.dg/iomsg_1.f90 | 28 ++++++++++++++++++++++++
libgfortran/ChangeLog | 6 ++++++
libgfortran/io/io.h | 3 +++
libgfortran/runtime/error.c | 19 +++++++++-------
9 files changed, 141 insertions(+), 14 deletions(-)
create mode 100755 gcc/testsuite/gfortran.dg/iomsg_1.f90
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 8f039d2f364d..2d708f7efed4 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 59e1bead1119..301afac2ef59 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 37a7493f7867..0ffc13d2205b 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;
@@ -1049,6 +1056,9 @@ match_open_element (gfc_open * open)
match m;
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);
@@ -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);
@@ -1235,6 +1248,9 @@ match_close_element (gfc_close * close)
if (m != MATCH_NO)
return m;
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);
@@ -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);
}
@@ -1348,6 +1366,9 @@ match_file_element (gfc_filepos * fp)
match m;
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);
@@ -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;
@@ -1664,6 +1687,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);
@@ -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 b25e80a98f52..e9a9c600f0a0 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 db903b134c11..da40a5921999 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 000000000000..6a5819d043e3
--- /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 5edab98b3226..6e45ee0ea29e 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 06825df8c297..6f4023b9e33d 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 2a84edf16248..3c1686d947d7 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);
}
--
GitLab