--- /dev/null
+! { 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" }
--- /dev/null
+! { 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" }
--- /dev/null
+! { 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" }
--- /dev/null
+! { 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" }
--- /dev/null
+! { 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" }
#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. */
}
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 *,
#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))
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;
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);
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);
static int
parse_repeat (st_parameter_dt *dtp)
{
- char message[MSGLEN];
+ char message[IOMSG_LEN];
int c, repeat;
if ((c = next_char (dtp)) == EOF)
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);
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);
}
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;
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))
}
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);
static void
read_integer (st_parameter_dt *dtp, int length)
{
- char message[MSGLEN];
+ char message[IOMSG_LEN];
int c, negative;
negative = 0;
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);
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. */
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);
}
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)
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);
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))
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);
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;
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);
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);
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,
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;
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;
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,
GFC_DESCRIPTOR_DATA(&vlist) = NULL;
GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
-
+
list_obj.vptr = nl->vtable;
list_obj.len = 0;
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;
}
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;
}
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;
}
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. */
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. */
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:
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;
}
projects / thirdparty / gcc.git / commitdiff
