gfortran.h: Add iomsg to gfc_open, gfc_close, gfc_filepos, gfc_inquire and gfc_dt.
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. From-SVN: r104102
This commit is contained in:
Thomas Koenig
Thomas Koenig
parent
2360a4c1a6
commit
7aba8abebf
@ -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=");
|
||||
|
||||
@ -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 */
|
||||
|
||||
@ -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);
|
||||
|
||||
@ -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);
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
28
gcc/testsuite/gfortran.dg/iomsg_1.f90
Executable file
28
gcc/testsuite/gfortran.dg/iomsg_1.f90
Executable file
@ -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
|
||||
@ -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
|
||||
|
||||
@ -263,6 +263,9 @@ typedef struct
|
||||
CHARACTER (namelist_name);
|
||||
GFC_INTEGER_4 namelist_read_mode;
|
||||
|
||||
/* iomsg */
|
||||
CHARACTER (iomsg);
|
||||
|
||||
#undef CHARACTER
|
||||
}
|
||||
st_parameter;
|
||||
|
||||
@ -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);
|
||||
}
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user