On 3/1/24 11:24 AM, rep.dot....@gmail.com wrote:
Hi Jerry and Steve,
On 29 February 2024 19:28:19 CET, Jerry D <jvdelis...@gmail.com> wrote:
On 2/29/24 10:13 AM, Steve Kargl wrote:
On Thu, Feb 29, 2024 at 09:36:43AM -0800, Jerry D wrote:
On 2/29/24 1:47 AM, Bernhard Reutner-Fischer wrote:
And, just for my own education, the length limitation of iomsg to 255
chars is not backed by the standard AFAICS, right? It's just our
STRERR_MAXSZ?
Yes, its what we have had for a long lone time. Once you throw an error
things get very processor dependent. I found MSGLEN set to 100 and IOMSG_len
to 256. Nothing magic about it.
There is no restriction on the length for the iomsg-variable
that receives the generated error message. In fact, if the
iomsg-variable has a deferred-length type parameter, then
(re)-allocation to the exact length is expected.
F2023
12.11.6 IOMSG= specifier
If an error, end-of-file, or end-of-record condition occurs during
execution of an input/output statement, iomsg-variable is assigned
an explanatory message, as if by intrinsic assignment. If no such
condition occurs, the definition status and value of iomsg-variable
are unchanged.
character(len=23) emsg
read(fd,*,iomsg=emsg)
Here, the generated iomsg is either truncated to a length of 23
or padded with blanks to a length of 23.
character(len=:), allocatable :: emsg
read(fd,*,iomsg=emsg)
Here, emsg should have the length of whatever error message was
generated.
HTH
Well, currently, if someone uses a larger string than 256 we are going to chop
it off.
Do we want to process this differently now?
Yes. There is some odd hunk about discrepancy of passed len and actual len
afterwards in 22-007-r1, IIRC. Didn't look closely though.
--- snip ---
Attached is the revised patch using the already available
string_len_trim function.
This hunk is only executed if a user has not passed an iostat or iomsg
variable in the parent I/O statement and an error is triggered which
terminates execution of the program. In this case, the iomsg string is
provided in the usual error message in a "processor defined" way.
(F2023):
12.6.4.8.3 Executing defined input/output data transfers
---
11 If the iostat argument of the defined input/output procedure has a
nonzero value when that procedure returns, and the processor therefore
terminates execution of the program as described in 12.11, the processor
shall make the value of the iomsg argument available in a
processor-dependent manner.
---
OK for trunk?
Regards,
Jerry
commit 51a24ace512e96b425bcde46c056e816c4606784
Author: Jerry DeLisle <jvdeli...@gcc.gnu.org>
Date: Mon Mar 4 18:45:49 2024 -0800
Fortran: Add user defined error messages for UDTIO.
The defines IOMSG_LEN and MSGLEN were redundant so these are combined
into IOMSG_LEN as defined in io.h.
The remainder of the patch adds checks for when a user defined
derived type IO procedure sets the IOSTAT or IOMSG variables
independent of the librrary defined I/O messages.
PR libfortran/105456
libgfortran/ChangeLog:
* io/io.h (IOMSG_LEN): Moved to here.
* io/list_read.c (MSGLEN): Removed MSGLEN.
(convert_integer): Changed MSGLEN to IOMSG_LEN.
(parse_repeat): Likewise.
(read_logical): Likewise.
(read_integer): Likewise.
(read_character): Likewise.
(parse_real): Likewise.
(read_complex): Likewise.
(read_real): Likewise.
(check_type): Likewise.
(list_formatted_read_scalar): Adjust to IOMSG_LEN.
(nml_read_obj): Add user defined error message.
* io/transfer.c (unformatted_read): Add user defined error
message.
(unformatted_write): Add user defined error message.
(formatted_transfer_scalar_read): Add user defined error message.
(formatted_transfer_scalar_write): Add user defined error message.
* io/write.c (list_formatted_write_scalar): Add user defined error message.
(nml_write_obj): Add user defined error message.
gcc/testsuite/ChangeLog:
* gfortran.dg/pr105456-nmlr.f90: New test.
* gfortran.dg/pr105456-nmlw.f90: New test.
* gfortran.dg/pr105456-ruf.f90: New test.
* gfortran.dg/pr105456-wf.f90: New test.
* gfortran.dg/pr105456-wuf.f90: New test.
diff --git a/gcc/testsuite/gfortran.dg/pr105456-nmlr.f90 b/gcc/testsuite/gfortran.dg/pr105456-nmlr.f90
new file mode 100644
index 00000000000..5ce5d082133
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr105456-nmlr.f90
@@ -0,0 +1,60 @@
+! { dg-do run }
+! { dg-shouldfail "The users message" }
+module m
+ implicit none
+ type :: t
+ character :: c
+ integer :: k
+ contains
+ procedure :: write_formatted
+ generic :: write(formatted) => write_formatted
+ procedure :: read_formatted
+ generic :: read(formatted) => read_formatted
+ end type
+contains
+ subroutine write_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
+ class(t), intent(in) :: dtv
+ integer, intent(in) :: unit
+ character(*), intent(in) :: iotype
+ integer, intent(in) :: v_list(:)
+ integer, intent(out) :: iostat
+ character(*), intent(inout) :: iomsg
+ if (iotype.eq."NAMELIST") then
+ write (unit, '(a1,a1,i3)') dtv%c,',', dtv%k
+ else
+ write (unit,*) dtv%c, dtv%k
+ end if
+ end subroutine
+ subroutine read_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
+ class(t), intent(inout) :: dtv
+ integer, intent(in) :: unit
+ character(*), intent(in) :: iotype
+ integer, intent(in) :: v_list(:)
+ integer, intent(out) :: iostat
+ character(*), intent(inout) :: iomsg
+ character :: comma
+ if (iotype.eq."NAMELIST") then
+ read (unit, '(a1,a1,i3)') dtv%c, comma, dtv%k
+ else
+ read (unit,*) dtv%c, comma, dtv%k
+ endif
+ iostat = 42
+ iomsg = "The users message"
+ if (comma /= ',') STOP 1
+ end subroutine
+end module
+
+program p
+ use m
+ implicit none
+ character(len=50) :: buffer
+ type(t) :: x
+ namelist /nml/ x
+ x = t('a', 5)
+ write (buffer, nml)
+ if (buffer.ne.' &NML X=a, 5 /') STOP 1
+ x = t('x', 0)
+ read (buffer, nml)
+ if (x%c.ne.'a'.or. x%k.ne.5) STOP 2
+end
+! { dg-output "Fortran runtime error: The users message" }
diff --git a/gcc/testsuite/gfortran.dg/pr105456-nmlw.f90 b/gcc/testsuite/gfortran.dg/pr105456-nmlw.f90
new file mode 100644
index 00000000000..2c496e611f4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr105456-nmlw.f90
@@ -0,0 +1,60 @@
+! { dg-do run }
+! { dg-shouldfail "The users message" }
+module m
+ implicit none
+ type :: t
+ character :: c
+ integer :: k
+ contains
+ procedure :: write_formatted
+ generic :: write(formatted) => write_formatted
+ procedure :: read_formatted
+ generic :: read(formatted) => read_formatted
+ end type
+contains
+ subroutine write_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
+ class(t), intent(in) :: dtv
+ integer, intent(in) :: unit
+ character(*), intent(in) :: iotype
+ integer, intent(in) :: v_list(:)
+ integer, intent(out) :: iostat
+ character(*), intent(inout) :: iomsg
+ if (iotype.eq."NAMELIST") then
+ write (unit, '(a1,a1,i3)') dtv%c,',', dtv%k
+ else
+ write (unit,*) dtv%c, dtv%k
+ end if
+ iostat = 42
+ iomsg = "The users message"
+ end subroutine
+ subroutine read_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
+ class(t), intent(inout) :: dtv
+ integer, intent(in) :: unit
+ character(*), intent(in) :: iotype
+ integer, intent(in) :: v_list(:)
+ integer, intent(out) :: iostat
+ character(*), intent(inout) :: iomsg
+ character :: comma
+ if (iotype.eq."NAMELIST") then
+ read (unit, '(a1,a1,i3)') dtv%c, comma, dtv%k
+ else
+ read (unit,*) dtv%c, comma, dtv%k
+ end if
+ if (comma /= ',') STOP 1
+ end subroutine
+end module
+
+program p
+ use m
+ implicit none
+ character(len=50) :: buffer
+ type(t) :: x
+ namelist /nml/ x
+ x = t('a', 5)
+ write (buffer, nml)
+ if (buffer.ne.' &NML X=a, 5 /') STOP 1
+ x = t('x', 0)
+ read (buffer, nml)
+ if (x%c.ne.'a'.or. x%k.ne.5) STOP 2
+end
+! { dg-output "Fortran runtime error: The users message" }
diff --git a/gcc/testsuite/gfortran.dg/pr105456-ruf.f90 b/gcc/testsuite/gfortran.dg/pr105456-ruf.f90
new file mode 100644
index 00000000000..c176c4aa18c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr105456-ruf.f90
@@ -0,0 +1,36 @@
+! { dg-do run }
+! { dg-shouldfail "The users message" }
+module sk1
+ implicit none
+ type char
+ character :: ch
+ end type char
+ interface read (unformatted)
+ module procedure read_unformatted
+ end interface read (unformatted)
+contains
+ subroutine read_unformatted (dtv, unit, piostat, piomsg)
+ class (char), intent(inout) :: dtv
+ integer, intent(in) :: unit
+ !character (len=*), intent(in) :: iotype
+ !integer, intent(in) :: vlist(:)
+ integer, intent(out) :: piostat
+ character (len=*), intent(inout) :: piomsg
+ read (unit,fmt='(A1)', advance="no", iostat=piostat, iomsg=piomsg) dtv%ch
+ piostat = 42
+ piomsg="The users message"
+ end subroutine read_unformatted
+end module sk1
+
+program skip1
+ use sk1
+ implicit none
+ type (char) :: x
+ x%ch = 'X'
+ open (10, form='unformatted', status='scratch')
+ write (10) 'X'
+ rewind (10)
+ read (10) x
+end program skip1
+! { dg-output ".*(unit = 10, file = .*)" }
+! { dg-output "Fortran runtime error: The users message" }
diff --git a/gcc/testsuite/gfortran.dg/pr105456-wf.f90 b/gcc/testsuite/gfortran.dg/pr105456-wf.f90
new file mode 100644
index 00000000000..f1c5350cc00
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr105456-wf.f90
@@ -0,0 +1,34 @@
+! { dg-do run }
+! { dg-shouldfail "The users message" }
+module sk1
+ implicit none
+ type char
+ character :: ch
+ end type char
+ interface write (formatted)
+ module procedure write_formatted
+ end interface write (formatted)
+contains
+ subroutine write_formatted (dtv, unit, iotype, vlist, piostat, piomsg)
+ class (char), intent(in) :: dtv
+ integer, intent(in) :: unit
+ character (len=*), intent(in) :: iotype
+ integer, intent(in) :: vlist(:)
+ integer, intent(out) :: piostat
+ character (len=*), intent(inout) :: piomsg
+ write (unit,fmt='(A1)', advance="no", iostat=piostat, iomsg=piomsg) dtv%ch
+ piostat = 42
+ piomsg="The users message"
+ end subroutine write_formatted
+end module sk1
+
+program skip1
+ use sk1
+ implicit none
+ type (char) :: x
+ x%ch = 'X'
+ open (10, status='scratch')
+ write (10,*) x
+end program skip1
+! { dg-output ".*(unit = 10, file = .*)" }
+! { dg-output "Fortran runtime error: The users message" }
diff --git a/gcc/testsuite/gfortran.dg/pr105456-wuf.f90 b/gcc/testsuite/gfortran.dg/pr105456-wuf.f90
new file mode 100644
index 00000000000..2b637b704a4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr105456-wuf.f90
@@ -0,0 +1,34 @@
+! { dg-do run }
+! { dg-shouldfail "The users message" }
+module sk1
+ implicit none
+ type char
+ character :: ch
+ end type char
+ interface write (unformatted)
+ module procedure write_unformatted
+ end interface write (unformatted)
+contains
+ subroutine write_unformatted (dtv, unit, piostat, piomsg)
+ class (char), intent(in) :: dtv
+ integer, intent(in) :: unit
+ !character (len=*), intent(in) :: iotype
+ !integer, intent(in) :: vlist(:)
+ integer, intent(out) :: piostat
+ character (len=*), intent(inout) :: piomsg
+ write (unit,fmt='(A1)', advance="no", iostat=piostat, iomsg=piomsg) dtv%ch
+ piostat = 42
+ piomsg="The users message"
+ end subroutine write_unformatted
+end module sk1
+
+program skip1
+ use sk1
+ implicit none
+ type (char) :: x
+ x%ch = 'X'
+ open (10, form='unformatted', status='scratch')
+ write (10) x
+end program skip1
+! { dg-output ".*(unit = 10, file = .*)" }
+! { dg-output "Fortran runtime error: The users message" }
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index 59bc19ee815..1c23676cc4c 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -34,6 +34,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#define gcc_unreachable() __builtin_unreachable ()
+/* Used for building error message strings. */
+#define IOMSG_LEN 256
+
/* POSIX 2008 specifies that the extended locale stuff is found in
locale.h, but some systems have them in xlocale.h. */
@@ -99,10 +102,6 @@ typedef struct array_loop_spec
}
array_loop_spec;
-/* User defined input/output iomsg length. */
-
-#define IOMSG_LEN 256
-
/* Subroutine formatted_dtio (struct, unit, iotype, v_list, iostat,
iomsg, (_iotype), (_iomsg)) */
typedef void (*formatted_dtio)(void *, GFC_INTEGER_4 *, char *,
diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index ee3ab713519..3d374f55027 100644
--- a/libgfortran/io/list_read.c
+++ b/libgfortran/io/list_read.c
@@ -64,10 +64,6 @@ typedef unsigned char uchar;
#define MAX_REPEAT 200000000
-
-#define MSGLEN 100
-
-
/* Wrappers for calling the current worker functions. */
#define next_char(dtp) ((dtp)->u.p.current_unit->next_char_fn_ptr (dtp))
@@ -632,7 +628,7 @@ nml_bad_return (st_parameter_dt *dtp, char c)
static int
convert_integer (st_parameter_dt *dtp, int length, int negative)
{
- char c, *buffer, message[MSGLEN];
+ char c, *buffer, message[IOMSG_LEN];
int m;
GFC_UINTEGER_LARGEST v, max, max10;
GFC_INTEGER_LARGEST value;
@@ -682,7 +678,7 @@ convert_integer (st_parameter_dt *dtp, int length, int negative)
if (dtp->u.p.repeat_count == 0)
{
- snprintf (message, MSGLEN, "Zero repeat count in item %d of list input",
+ snprintf (message, IOMSG_LEN, "Zero repeat count in item %d of list input",
dtp->u.p.item_count);
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
@@ -695,10 +691,10 @@ convert_integer (st_parameter_dt *dtp, int length, int negative)
overflow:
if (length == -1)
- snprintf (message, MSGLEN, "Repeat count overflow in item %d of list input",
+ snprintf (message, IOMSG_LEN, "Repeat count overflow in item %d of list input",
dtp->u.p.item_count);
else
- snprintf (message, MSGLEN, "Integer overflow while reading item %d",
+ snprintf (message, IOMSG_LEN, "Integer overflow while reading item %d",
dtp->u.p.item_count);
free_saved (dtp);
@@ -715,7 +711,7 @@ convert_integer (st_parameter_dt *dtp, int length, int negative)
static int
parse_repeat (st_parameter_dt *dtp)
{
- char message[MSGLEN];
+ char message[IOMSG_LEN];
int c, repeat;
if ((c = next_char (dtp)) == EOF)
@@ -746,7 +742,7 @@ parse_repeat (st_parameter_dt *dtp)
if (repeat > MAX_REPEAT)
{
- snprintf (message, MSGLEN,
+ snprintf (message, IOMSG_LEN,
"Repeat count overflow in item %d of list input",
dtp->u.p.item_count);
@@ -759,7 +755,7 @@ parse_repeat (st_parameter_dt *dtp)
case '*':
if (repeat == 0)
{
- snprintf (message, MSGLEN,
+ snprintf (message, IOMSG_LEN,
"Zero repeat count in item %d of list input",
dtp->u.p.item_count);
@@ -789,7 +785,7 @@ parse_repeat (st_parameter_dt *dtp)
}
else
eat_line (dtp);
- snprintf (message, MSGLEN, "Bad repeat count in item %d of list input",
+ snprintf (message, IOMSG_LEN, "Bad repeat count in item %d of list input",
dtp->u.p.item_count);
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
return 1;
@@ -816,7 +812,7 @@ l_push_char (st_parameter_dt *dtp, char c)
static void
read_logical (st_parameter_dt *dtp, int length)
{
- char message[MSGLEN];
+ char message[IOMSG_LEN];
int c, i, v;
if (parse_repeat (dtp))
@@ -953,7 +949,7 @@ read_logical (st_parameter_dt *dtp, int length)
}
else if (c != '\n')
eat_line (dtp);
- snprintf (message, MSGLEN, "Bad logical value while reading item %d",
+ snprintf (message, IOMSG_LEN, "Bad logical value while reading item %d",
dtp->u.p.item_count);
free_line (dtp);
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
@@ -977,7 +973,7 @@ read_logical (st_parameter_dt *dtp, int length)
static void
read_integer (st_parameter_dt *dtp, int length)
{
- char message[MSGLEN];
+ char message[IOMSG_LEN];
int c, negative;
negative = 0;
@@ -1112,7 +1108,7 @@ read_integer (st_parameter_dt *dtp, int length)
else if (c != '\n')
eat_line (dtp);
- snprintf (message, MSGLEN, "Bad integer for item %d in list input",
+ snprintf (message, IOMSG_LEN, "Bad integer for item %d in list input",
dtp->u.p.item_count);
free_line (dtp);
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
@@ -1140,7 +1136,7 @@ read_integer (st_parameter_dt *dtp, int length)
static void
read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
{
- char quote, message[MSGLEN];
+ char quote, message[IOMSG_LEN];
int c;
quote = ' '; /* Space means no quote character. */
@@ -1286,7 +1282,7 @@ read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
else
{
free_saved (dtp);
- snprintf (message, MSGLEN, "Invalid string input in item %d",
+ snprintf (message, IOMSG_LEN, "Invalid string input in item %d",
dtp->u.p.item_count);
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
}
@@ -1306,7 +1302,7 @@ read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
static int
parse_real (st_parameter_dt *dtp, void *buffer, int length)
{
- char message[MSGLEN];
+ char message[IOMSG_LEN];
int c, m, seen_dp;
if ((c = next_char (dtp)) == EOF)
@@ -1521,7 +1517,7 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
else if (c != '\n')
eat_line (dtp);
- snprintf (message, MSGLEN, "Bad complex floating point "
+ snprintf (message, IOMSG_LEN, "Bad complex floating point "
"number for item %d", dtp->u.p.item_count);
free_line (dtp);
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
@@ -1536,7 +1532,7 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
static void
read_complex (st_parameter_dt *dtp, void *dest, int kind, size_t size)
{
- char message[MSGLEN];
+ char message[IOMSG_LEN];
int c;
if (parse_repeat (dtp))
@@ -1633,7 +1629,7 @@ eol_4:
else if (c != '\n')
eat_line (dtp);
- snprintf (message, MSGLEN, "Bad complex value in item %d of list input",
+ snprintf (message, IOMSG_LEN, "Bad complex value in item %d of list input",
dtp->u.p.item_count);
free_line (dtp);
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
@@ -1645,7 +1641,7 @@ eol_4:
static void
read_real (st_parameter_dt *dtp, void *dest, int length)
{
- char message[MSGLEN];
+ char message[IOMSG_LEN];
int c;
int seen_dp;
int is_inf;
@@ -2059,7 +2055,7 @@ read_real (st_parameter_dt *dtp, void *dest, int length)
else if (c != '\n')
eat_line (dtp);
- snprintf (message, MSGLEN, "Bad real number in item %d of list input",
+ snprintf (message, IOMSG_LEN, "Bad real number in item %d of list input",
dtp->u.p.item_count);
free_line (dtp);
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
@@ -2072,11 +2068,11 @@ read_real (st_parameter_dt *dtp, void *dest, int length)
static int
check_type (st_parameter_dt *dtp, bt type, int kind)
{
- char message[MSGLEN];
+ char message[IOMSG_LEN];
if (dtp->u.p.saved_type != BT_UNKNOWN && dtp->u.p.saved_type != type)
{
- snprintf (message, MSGLEN, "Read type %s where %s was expected for item %d",
+ snprintf (message, IOMSG_LEN, "Read type %s where %s was expected for item %d",
type_name (dtp->u.p.saved_type), type_name (type),
dtp->u.p.item_count);
free_line (dtp);
@@ -2090,7 +2086,7 @@ check_type (st_parameter_dt *dtp, bt type, int kind)
if ((type != BT_COMPLEX && dtp->u.p.saved_length != kind)
|| (type == BT_COMPLEX && dtp->u.p.saved_length != kind*2))
{
- snprintf (message, MSGLEN,
+ snprintf (message, IOMSG_LEN,
"Read kind %d %s where kind %d is required for item %d",
type == BT_COMPLEX ? dtp->u.p.saved_length / 2
: dtp->u.p.saved_length,
@@ -2138,7 +2134,6 @@ static int
list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p,
int kind, size_t size)
{
- char message[MSGLEN];
gfc_char4_t *q, *r;
size_t m;
int c;
@@ -2233,7 +2228,7 @@ list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p,
GFC_INTEGER_4 unit = dtp->u.p.current_unit->unit_number;
char iotype[] = "LISTDIRECTED";
gfc_charlen_type iotype_len = 12;
- char tmp_iomsg[IOMSG_LEN] = "";
+ char tmp_iomsg[IOMSG_LEN];
char *child_iomsg;
gfc_charlen_type child_iomsg_len;
GFC_INTEGER_4 noiostat;
@@ -2267,20 +2262,13 @@ list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p,
iotype_len, child_iomsg_len);
dtp->u.p.child_saved_iostat = *child_iostat;
dtp->u.p.current_unit->child_dtio--;
-
-
+
if ((dtp->u.p.child_saved_iostat != 0) &&
!(dtp->common.flags & IOPARM_HAS_IOMSG) &&
!(dtp->common.flags & IOPARM_HAS_IOSTAT))
{
- /* Trim trailing spaces from the message. */
- for(int i = IOMSG_LEN - 1; i > 0; i--)
- if (!isspace(child_iomsg[i]))
- {
- /* Add two to get back to the end of child_iomsg. */
- child_iomsg_len = i+2;
- break;
- }
+ char message[IOMSG_LEN];
+ child_iomsg_len = string_len_trim (IOMSG_LEN, child_iomsg) + 1;
free_line (dtp);
snprintf (message, child_iomsg_len, child_iomsg);
generate_error (&dtp->common, dtp->u.p.child_saved_iostat,
@@ -3060,7 +3048,7 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info *nl, index_type offset,
GFC_DESCRIPTOR_DATA(&vlist) = NULL;
GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
-
+
list_obj.vptr = nl->vtable;
list_obj.len = 0;
@@ -3088,6 +3076,19 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info *nl, index_type offset,
iotype_len, child_iomsg_len);
dtp->u.p.child_saved_iostat = *child_iostat;
dtp->u.p.current_unit->child_dtio--;
+
+ if ((dtp->u.p.child_saved_iostat != 0) &&
+ !(dtp->common.flags & IOPARM_HAS_IOMSG) &&
+ !(dtp->common.flags & IOPARM_HAS_IOSTAT))
+ {
+ char message[IOMSG_LEN];
+ child_iomsg_len = string_len_trim (IOMSG_LEN, child_iomsg) + 1;
+ snprintf (message, child_iomsg_len, child_iomsg);
+ generate_error (&dtp->common, dtp->u.p.child_saved_iostat,
+ message);
+ goto nml_err_ret;
+ }
+
goto incr_idx;
}
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 01db4122d16..8a094a6aa09 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -1120,7 +1120,20 @@ unformatted_read (st_parameter_dt *dtp, bt type,
dtp->u.p.current_unit->child_dtio++;
dtp->u.p.ufdtio_ptr (dest, &unit, child_iostat, child_iomsg,
child_iomsg_len);
+ dtp->u.p.child_saved_iostat = *child_iostat;
dtp->u.p.current_unit->child_dtio--;
+
+ if ((dtp->u.p.child_saved_iostat != 0) &&
+ !(dtp->common.flags & IOPARM_HAS_IOMSG) &&
+ !(dtp->common.flags & IOPARM_HAS_IOSTAT))
+ {
+ char message[IOMSG_LEN];
+ child_iomsg_len = string_len_trim (IOMSG_LEN, child_iomsg) + 1;
+ snprintf (message, child_iomsg_len, child_iomsg);
+ generate_error (&dtp->common, dtp->u.p.child_saved_iostat,
+ message);
+ }
+
return;
}
@@ -1250,7 +1263,19 @@ unformatted_write (st_parameter_dt *dtp, bt type,
dtp->u.p.current_unit->child_dtio++;
dtp->u.p.ufdtio_ptr (source, &unit, child_iostat, child_iomsg,
child_iomsg_len);
+ dtp->u.p.child_saved_iostat = *child_iostat;
dtp->u.p.current_unit->child_dtio--;
+
+ if ((dtp->u.p.child_saved_iostat != 0) &&
+ !(dtp->common.flags & IOPARM_HAS_IOMSG) &&
+ !(dtp->common.flags & IOPARM_HAS_IOSTAT))
+ {
+ char message[IOMSG_LEN];
+ child_iomsg_len = string_len_trim (IOMSG_LEN, child_iomsg) + 1;
+ snprintf (message, child_iomsg_len, child_iomsg);
+ generate_error (&dtp->common, dtp->u.p.child_saved_iostat,
+ message);
+ }
return;
}
@@ -1730,8 +1755,20 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist,
child_iostat, child_iomsg,
iotype_len, child_iomsg_len);
+ dtp->u.p.child_saved_iostat = *child_iostat;
dtp->u.p.current_unit->child_dtio--;
+ if ((dtp->u.p.child_saved_iostat != 0) &&
+ !(dtp->common.flags & IOPARM_HAS_IOMSG) &&
+ !(dtp->common.flags & IOPARM_HAS_IOSTAT))
+ {
+ char message[IOMSG_LEN];
+ child_iomsg_len = string_len_trim (IOMSG_LEN, child_iomsg) + 1;
+ snprintf (message, child_iomsg_len, child_iomsg);
+ generate_error (&dtp->common, dtp->u.p.child_saved_iostat,
+ message);
+ }
+
if (f->u.udf.string_len != 0)
free (iotype);
/* Note: vlist is freed in free_format_data. */
@@ -2214,8 +2251,20 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist,
child_iostat, child_iomsg,
iotype_len, child_iomsg_len);
+ dtp->u.p.child_saved_iostat = *child_iostat;
dtp->u.p.current_unit->child_dtio--;
+ if ((dtp->u.p.child_saved_iostat != 0) &&
+ !(dtp->common.flags & IOPARM_HAS_IOMSG) &&
+ !(dtp->common.flags & IOPARM_HAS_IOSTAT))
+ {
+ char message[IOMSG_LEN];
+ child_iomsg_len = string_len_trim (IOMSG_LEN, child_iomsg) + 1;
+ snprintf (message, child_iomsg_len, child_iomsg);
+ generate_error (&dtp->common, dtp->u.p.child_saved_iostat,
+ message);
+ }
+
if (f->u.udf.string_len != 0)
free (iotype);
/* Note: vlist is freed in free_format_data. */
diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c
index 1a7c12345f9..913369db486 100644
--- a/libgfortran/io/write.c
+++ b/libgfortran/io/write.c
@@ -1991,7 +1991,19 @@ list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
dtp->u.p.fdtio_ptr (p, &unit, iotype, &vlist,
child_iostat, child_iomsg,
iotype_len, child_iomsg_len);
+ dtp->u.p.child_saved_iostat = *child_iostat;
dtp->u.p.current_unit->child_dtio--;
+
+ if ((dtp->u.p.child_saved_iostat != 0) &&
+ !(dtp->common.flags & IOPARM_HAS_IOMSG) &&
+ !(dtp->common.flags & IOPARM_HAS_IOSTAT))
+ {
+ char message[IOMSG_LEN];
+ child_iomsg_len = string_len_trim (IOMSG_LEN, child_iomsg) + 1;
+ snprintf (message, child_iomsg_len, child_iomsg);
+ generate_error (&dtp->common, dtp->u.p.child_saved_iostat,
+ message);
+ }
}
break;
default:
@@ -2330,8 +2342,22 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info *obj, index_type offset,
child_iostat, child_iomsg,
iotype_len, child_iomsg_len);
}
+ dtp->u.p.child_saved_iostat = *child_iostat;
dtp->u.p.current_unit->child_dtio--;
+ if ((dtp->u.p.child_saved_iostat != 0) &&
+ !(dtp->common.flags & IOPARM_HAS_IOMSG) &&
+ !(dtp->common.flags & IOPARM_HAS_IOSTAT))
+ {
+ char message[IOMSG_LEN];
+
+ /* Trim trailing spaces from the message. */
+ child_iomsg_len = string_len_trim (IOMSG_LEN, child_iomsg) + 1;
+ snprintf (message, child_iomsg_len, child_iomsg);
+ generate_error (&dtp->common, dtp->u.p.child_saved_iostat,
+ message);
+ }
+
goto obj_loop;
}
