commit 51a24ace512e96b425bcde46c056e816c4606784 Author: Jerry DeLisle 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; }