* 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
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=");
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=");
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=");
gfc_show_expr (i->file);
}
+ if (i->iomsg)
+ {
+ gfc_status (" IOMSG=");
+ gfc_show_expr (i->iomsg);
+ }
if (i->iostat)
{
gfc_status (" IOSTAT=");
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=");
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;
typedef struct
{
- gfc_expr *unit, *status, *iostat;
+ gfc_expr *unit, *status, *iostat, *iomsg;
gfc_st_label *err;
}
gfc_close;
typedef struct
{
- gfc_expr *unit, *iostat;
+ gfc_expr *unit, *iostat, *iomsg;
gfc_st_label *err;
}
gfc_filepos;
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;
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 */
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},
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;
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);
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);
{
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);
return;
gfc_free_expr (close->unit);
+ gfc_free_expr (close->iomsg);
gfc_free_expr (close->iostat);
gfc_free_expr (close->status);
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);
{
RESOLVE_TAG (&tag_unit, close->unit);
+ RESOLVE_TAG (&tag_iomsg, close->iomsg);
RESOLVE_TAG (&tag_iostat, close->iostat);
RESOLVE_TAG (&tag_status, close->status);
{
gfc_free_expr (fp->unit);
+ gfc_free_expr (fp->iomsg);
gfc_free_expr (fp->iostat);
gfc_free (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);
{
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;
}
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);
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);
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);
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);
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);
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);
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 */
ADD_STRING (namelist_name);
ADD_FIELD (namelist_read_mode, gfc_int4_type_node);
+ ADD_STRING (iomsg);
gfc_finish_type (ioparm_type);
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);
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);
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);
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);
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);
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);
+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
--- /dev/null
+! { 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
+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
CHARACTER (namelist_name);
GFC_INTEGER_4 namelist_read_mode;
+ /* iomsg */
+ CHARACTER (iomsg);
+
#undef CHARACTER
}
st_parameter;
/* 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. */
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)
{
/* Terminate the program */
- if (message == NULL)
- message =
- (family == ERROR_OS) ? get_oserror () : translate_error (family);
-
runtime_error (message);
}