mirror/gcc
1
0
Fork 0
mirror of https://github.com/gcc-mirror/gcc.git synced 2024-11-21 13:40:47 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Fortran: Add user defined error messages for UDTIO.

Browse Source 
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.
This commit is contained in:
Jerry DeLisle 2024-03-05 20:49:23 -08:00
parent b0d11bb02a
commit 21edfb0051
9 changed files with 343 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
gcc/testsuite/gfortran.dg/pr105456-nmlr.f90 Normal file
View File

@ -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" }

60
gcc/testsuite/gfortran.dg/pr105456-nmlw.f90 Normal file
View File

@ -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" }

36
gcc/testsuite/gfortran.dg/pr105456-ruf.f90 Normal file
View File

@ -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" }

34
gcc/testsuite/gfortran.dg/pr105456-wf.f90 Normal file
View File

@ -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" }

34
gcc/testsuite/gfortran.dg/pr105456-wuf.f90 Normal file
View File

@ -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" }

7
libgfortran/io/io.h
View File

@ -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 *,

81
libgfortran/io/list_read.c
View File

@ -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 + 1];
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 + 1];
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;
}

49
libgfortran/io/transfer.c
View File

@ -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 + 1];
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 + 1];
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 + 1];
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 + 1];
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. */

26
libgfortran/io/write.c
View File

@ -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 + 1];
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 + 1];
/* 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;
}