-/* Copyright (C) 2002-2016 Free Software Foundation, Inc.
+/* Copyright (C) 2002-2018 Free Software Foundation, Inc.
Contributed by Andy Vaught
Namelist transfer functions contributed by Paul Thomas
F2003 I/O support contributed by Jerry DeLisle
#include "format.h"
#include "unix.h"
#include <string.h>
-#include <assert.h>
-#include <stdlib.h>
#include <errno.h>
extern void transfer_logical_write (st_parameter_dt *, void *, int);
export_proto(transfer_logical_write);
-extern void transfer_character (st_parameter_dt *, void *, int);
+extern void transfer_character (st_parameter_dt *, void *, gfc_charlen_type);
export_proto(transfer_character);
-extern void transfer_character_write (st_parameter_dt *, void *, int);
+extern void transfer_character_write (st_parameter_dt *, void *, gfc_charlen_type);
export_proto(transfer_character_write);
-extern void transfer_character_wide (st_parameter_dt *, void *, int, int);
+extern void transfer_character_wide (st_parameter_dt *, void *, gfc_charlen_type, int);
export_proto(transfer_character_wide);
extern void transfer_character_wide_write (st_parameter_dt *,
- void *, int, int);
+ void *, gfc_charlen_type, int);
export_proto(transfer_character_wide_write);
extern void transfer_complex (st_parameter_dt *, void *, int);
/* Read sequential file - internal unit */
static char *
-read_sf_internal (st_parameter_dt *dtp, int * length)
+read_sf_internal (st_parameter_dt *dtp, size_t *length)
{
static char *empty_string[0];
- char *base;
- int lorig;
+ char *base = NULL;
+ size_t lorig;
/* Zero size array gives internal unit len of 0. Nothing to read. */
if (dtp->internal_unit_len == 0
return (char*) empty_string;
}
+ /* There are some cases with mixed DTIO where we have read a character
+ and saved it in the last character buffer, so we need to backup. */
+ if (unlikely (dtp->u.p.current_unit->child_dtio > 0 &&
+ dtp->u.p.current_unit->last_char != EOF - 1))
+ {
+ dtp->u.p.current_unit->last_char = EOF - 1;
+ sseek (dtp->u.p.current_unit->s, -1, SEEK_CUR);
+ }
+
lorig = *length;
if (is_char4_unit(dtp))
{
- int i;
gfc_char4_t *p = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s,
length);
base = fbuf_alloc (dtp->u.p.current_unit, lorig);
- for (i = 0; i < *length; i++, p++)
+ for (size_t i = 0; i < *length; i++, p++)
base[i] = *p > 255 ? '?' : (unsigned char) *p;
}
else
dtp->u.p.current_unit->bytes_left -= *length;
- if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
- dtp->u.p.size_used += (GFC_IO_INT) *length;
+ if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
+ dtp->u.p.current_unit->has_size)
+ dtp->u.p.current_unit->size_used += (GFC_IO_INT) *length;
return base;
/* Read sequential file - external unit */
static char *
-read_sf (st_parameter_dt *dtp, int * length)
+read_sf (st_parameter_dt *dtp, size_t *length)
{
static char *empty_string[0];
+ size_t lorig, n;
int q, q2;
- int n, lorig, seen_comma;
+ int seen_comma;
/* If we have seen an eor previously, return a length of 0. The
caller is responsible for correctly padding the input field. */
return (char*) empty_string;
}
+ /* There are some cases with mixed DTIO where we have read a character
+ and saved it in the last character buffer, so we need to backup. */
+ if (unlikely (dtp->u.p.current_unit->child_dtio > 0 &&
+ dtp->u.p.current_unit->last_char != EOF - 1))
+ {
+ dtp->u.p.current_unit->last_char = EOF - 1;
+ fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR);
+ }
+
n = seen_comma = 0;
/* Read data into format buffer and scan through it. */
q = fbuf_getc (dtp->u.p.current_unit);
if (q == EOF)
break;
- else if (q == '\n' || q == '\r')
+ else if (dtp->u.p.current_unit->flags.cc != CC_NONE
+ && (q == '\n' || q == '\r'))
{
/* Unexpected end of line. Set the position. */
dtp->u.p.sf_seen_eor = 1;
dtp->u.p.current_unit->bytes_left -= n;
- if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
- dtp->u.p.size_used += (GFC_IO_INT) n;
+ if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
+ dtp->u.p.current_unit->has_size)
+ dtp->u.p.current_unit->size_used += (GFC_IO_INT) n;
/* We can't call fbuf_getptr before the loop doing fbuf_getc, because
fbuf_getc might reallocate the buffer. So return current pointer
short reads. */
void *
-read_block_form (st_parameter_dt *dtp, int * nbytes)
+read_block_form (st_parameter_dt *dtp, size_t *nbytes)
{
char *source;
- int norig;
+ size_t norig;
if (!is_stream_io (dtp))
{
/* For preconnected units with default record length, set bytes left
to unit record length and proceed, otherwise error. */
if (dtp->u.p.current_unit->unit_number == options.stdin_unit
- && dtp->u.p.current_unit->recl == DEFAULT_RECL)
+ && dtp->u.p.current_unit->recl == default_recl)
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
else
{
}
}
- if (unlikely (dtp->u.p.current_unit->bytes_left == 0
- && !is_internal_unit(dtp)))
+ if (is_internal_unit(dtp))
{
- hit_eof (dtp);
- return NULL;
+ if (*nbytes > 0 && dtp->u.p.current_unit->bytes_left == 0)
+ {
+ if (dtp->u.p.advance_status == ADVANCE_NO)
+ {
+ generate_error (&dtp->common, LIBERROR_EOR, NULL);
+ return NULL;
+ }
+ }
+ }
+ else
+ {
+ if (unlikely (dtp->u.p.current_unit->bytes_left == 0))
+ {
+ hit_eof (dtp);
+ return NULL;
+ }
}
*nbytes = dtp->u.p.current_unit->bytes_left;
source = fbuf_read (dtp->u.p.current_unit, nbytes);
fbuf_seek (dtp->u.p.current_unit, *nbytes, SEEK_CUR);
- if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
- dtp->u.p.size_used += (GFC_IO_INT) *nbytes;
+ if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
+ dtp->u.p.current_unit->has_size)
+ dtp->u.p.current_unit->size_used += (GFC_IO_INT) *nbytes;
if (norig != *nbytes)
{
a character(kind=4) variable. Note: Portions of this code borrowed from
read_sf_internal. */
void *
-read_block_form4 (st_parameter_dt *dtp, int * nbytes)
+read_block_form4 (st_parameter_dt *dtp, size_t *nbytes)
{
static gfc_char4_t *empty_string[0];
gfc_char4_t *source;
- int lorig;
+ size_t lorig;
if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
*nbytes = dtp->u.p.current_unit->bytes_left;
dtp->u.p.current_unit->bytes_left -= *nbytes;
- if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
- dtp->u.p.size_used += (GFC_IO_INT) *nbytes;
+ if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
+ dtp->u.p.current_unit->has_size)
+ dtp->u.p.current_unit->size_used += (GFC_IO_INT) *nbytes;
return source;
}
fill in. Returns NULL on error. */
void *
-write_block (st_parameter_dt *dtp, int length)
+write_block (st_parameter_dt *dtp, size_t length)
{
char *dest;
== options.stdout_unit
|| dtp->u.p.current_unit->unit_number
== options.stderr_unit)
- && dtp->u.p.current_unit->recl == DEFAULT_RECL))
+ && dtp->u.p.current_unit->recl == default_recl))
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
else
{
}
}
- if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
- dtp->u.p.size_used += (GFC_IO_INT) length;
+ if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
+ dtp->u.p.current_unit->has_size)
+ dtp->u.p.current_unit->size_used += (GFC_IO_INT) length;
dtp->u.p.current_unit->strm_pos += (gfc_offset) length;
}
+/* Check that the dtio procedure required for formatted IO is present. */
+
+static int
+check_dtio_proc (st_parameter_dt *dtp, const fnode *f)
+{
+ char buffer[BUFLEN];
+
+ if (dtp->u.p.fdtio_ptr != NULL)
+ return 0;
+
+ snprintf (buffer, BUFLEN,
+ "Missing DTIO procedure or intrinsic type passed for item %d "
+ "in formatted transfer",
+ dtp->u.p.item_count - 1);
+
+ format_error (dtp, f, buffer);
+ return 1;
+}
+
+
static int
require_numeric_type (st_parameter_dt *dtp, bt actual, const fnode *f)
{
return 1;
}
+static char *
+get_dt_format (char *p, gfc_charlen_type *length)
+{
+ char delim = p[-1]; /* The delimiter is always the first character back. */
+ char c, *q, *res;
+ gfc_charlen_type len = *length; /* This length already correct, less 'DT'. */
+
+ res = q = xmalloc (len + 2);
+
+ /* Set the beginning of the string to 'DT', length adjusted below. */
+ *q++ = 'D';
+ *q++ = 'T';
+
+ /* The string may contain doubled quotes so scan and skip as needed. */
+ for (; len > 0; len--)
+ {
+ c = *q++ = *p++;
+ if (c == delim)
+ p++; /* Skip the doubled delimiter. */
+ }
+
+ /* Adjust the string length by two now that we are done. */
+ *length += 2;
+
+ return res;
+}
+
/* This function is in the main loop for a formatted data transfer
statement. It would be natural to implement this as a coroutine
case FMT_DT:
if (n == 0)
goto need_read_data;
+
+ if (check_dtio_proc (dtp, f))
+ return;
if (require_type (dtp, BT_CLASS, type, f))
return;
int unit = dtp->u.p.current_unit->unit_number;
gfc_charlen_type child_iomsg_len;
int noiostat;
int *child_iostat = NULL;
- char *iotype = f->u.udf.string;
+ char *iotype;
gfc_charlen_type iotype_len = f->u.udf.string_len;
/* Build the iotype string. */
iotype = dt;
}
else
- {
- iotype_len += 2;
- iotype = xmalloc (iotype_len);
- iotype[0] = dt[0];
- iotype[1] = dt[1];
- memcpy (iotype + 2, f->u.udf.string, f->u.udf.string_len);
- }
+ iotype = get_dt_format (f->u.udf.string, &iotype_len);
/* Set iostat, intent(out). */
noiostat = 0;
/* Call the user defined formatted READ procedure. */
dtp->u.p.current_unit->child_dtio++;
+ dtp->u.p.current_unit->last_char = EOF - 1;
dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist,
child_iostat, child_iomsg,
iotype_len, child_iomsg_len);
dtp->u.p.current_unit->bytes_left -= dtp->u.p.sf_seen_eor;
dtp->u.p.skips -= dtp->u.p.sf_seen_eor;
bytes_used = pos;
- dtp->u.p.sf_seen_eor = 0;
+ if (dtp->u.p.pending_spaces == 0)
+ dtp->u.p.sf_seen_eor = 0;
}
if (dtp->u.p.skips < 0)
{
formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kind,
size_t size)
{
- int pos, bytes_used;
+ gfc_offset pos, bytes_used;
const fnode *f;
format_token t;
int n;
{
if (dtp->u.p.skips > 0)
{
- int tmp;
+ gfc_offset tmp;
write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
- tmp = (int)(dtp->u.p.current_unit->recl
- - dtp->u.p.current_unit->bytes_left);
+ tmp = dtp->u.p.current_unit->recl
+ - dtp->u.p.current_unit->bytes_left;
dtp->u.p.max_pos =
dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
dtp->u.p.skips = 0;
dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
}
- bytes_used = (int)(dtp->u.p.current_unit->recl
- - dtp->u.p.current_unit->bytes_left);
+ bytes_used = dtp->u.p.current_unit->recl
+ - dtp->u.p.current_unit->bytes_left;
if (is_stream_io(dtp))
bytes_used = 0;
gfc_charlen_type child_iomsg_len;
int noiostat;
int *child_iostat = NULL;
- char *iotype = f->u.udf.string;
+ char *iotype;
gfc_charlen_type iotype_len = f->u.udf.string_len;
/* Build the iotype string. */
iotype = dt;
}
else
- {
- iotype_len += 2;
- iotype = xmalloc (iotype_len);
- iotype[0] = dt[0];
- iotype[1] = dt[1];
- memcpy (iotype + 2, f->u.udf.string, f->u.udf.string_len);
- }
+ iotype = get_dt_format (f->u.udf.string, &iotype_len);
/* Set iostat, intent(out). */
noiostat = 0;
child_iomsg_len = IOMSG_LEN;
}
+ if (check_dtio_proc (dtp, f))
+ return;
+
/* Call the user defined formatted WRITE procedure. */
dtp->u.p.current_unit->child_dtio++;
+
dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist,
child_iostat, child_iomsg,
iotype_len, child_iomsg_len);
p = ((char *) p) + size;
}
- pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
+ pos = dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left;
dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
}
}
void
-transfer_character (st_parameter_dt *dtp, void *p, int len)
+transfer_character (st_parameter_dt *dtp, void *p, gfc_charlen_type len)
{
static char *empty_string[0];
}
void
-transfer_character_write (st_parameter_dt *dtp, void *p, int len)
+transfer_character_write (st_parameter_dt *dtp, void *p, gfc_charlen_type len)
{
transfer_character (dtp, p, len);
}
void
-transfer_character_wide (st_parameter_dt *dtp, void *p, int len, int kind)
+transfer_character_wide (st_parameter_dt *dtp, void *p, gfc_charlen_type len, int kind)
{
static char *empty_string[0];
}
void
-transfer_character_wide_write (st_parameter_dt *dtp, void *p, int len, int kind)
+transfer_character_wide_write (st_parameter_dt *dtp, void *p, gfc_charlen_type len, int kind)
{
transfer_character_wide (dtp, p, len, kind);
}
return;
iotype = (bt) GFC_DESCRIPTOR_TYPE (desc);
- size = iotype == BT_CHARACTER ? charlen : GFC_DESCRIPTOR_SIZE (desc);
+ size = iotype == BT_CHARACTER ? (index_type) charlen : GFC_DESCRIPTOR_SIZE (desc);
rank = GFC_DESCRIPTOR_RANK (desc);
for (n = 0; n < rank; n++)
dtp->u.p.ionml = ionml;
dtp->u.p.mode = read_flag ? READING : WRITING;
+ dtp->u.p.namelist_mode = 0;
+ dtp->u.p.cc.len = 0;
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
- if ((cf & IOPARM_DT_HAS_SIZE) != 0)
- dtp->u.p.size_used = 0; /* Initialize the count. */
-
dtp->u.p.current_unit = get_unit (dtp, 1);
- if (dtp->u.p.current_unit->s == NULL)
+ if (dtp->u.p.current_unit == NULL)
+ {
+ /* This means we tried to access an external unit < 0 without
+ having opened it first with NEWUNIT=. */
+ generate_error (&dtp->common, LIBERROR_BAD_OPTION,
+ "Unit number is negative and unit was not already "
+ "opened with OPEN(NEWUNIT=...)");
+ return;
+ }
+ else if (dtp->u.p.current_unit->s == NULL)
{ /* Open the unit with some default flags. */
st_parameter_open opp;
unit_convert conv;
- if (dtp->common.unit < 0 && !is_internal_unit (dtp))
- {
- close_unit (dtp->u.p.current_unit);
- dtp->u.p.current_unit = NULL;
- generate_error (&dtp->common, LIBERROR_BAD_OPTION,
- "Bad unit number in statement");
- return;
- }
memset (&u_flags, '\0', sizeof (u_flags));
u_flags.access = ACCESS_SEQUENTIAL;
u_flags.action = ACTION_READWRITE;
u_flags.async = ASYNC_UNSPECIFIED;
u_flags.round = ROUND_UNSPECIFIED;
u_flags.sign = SIGN_UNSPECIFIED;
+ u_flags.share = SHARE_UNSPECIFIED;
+ u_flags.cc = CC_UNSPECIFIED;
+ u_flags.readonly = 0;
u_flags.status = STATUS_UNKNOWN;
if (conv == GFC_CONVERT_NONE)
conv = compile_options.convert;
- /* We use big_endian, which is 0 on little-endian machines
- and 1 on big-endian machines. */
switch (conv)
{
case GFC_CONVERT_NATIVE:
break;
case GFC_CONVERT_BIG:
- conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
+ conv = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
break;
case GFC_CONVERT_LITTLE:
- conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
+ conv = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
break;
default:
return;
}
+ if (dtp->u.p.current_unit->child_dtio == 0)
+ {
+ if ((cf & IOPARM_DT_HAS_SIZE) != 0)
+ {
+ dtp->u.p.current_unit->has_size = true;
+ /* Initialize the count. */
+ dtp->u.p.current_unit->size_used = 0;
+ }
+ else
+ dtp->u.p.current_unit->has_size = false;
+ }
+ else if (dtp->u.p.current_unit->internal_unit_kind > 0)
+ dtp->u.p.unit_is_internal = 1;
+
/* Check the action. */
if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
return;
}
}
+
/* Process the ADVANCE option. */
dtp->u.p.advance_status
}
}
+ /* Child IO is non-advancing and any ADVANCE= specifier is ignored.
+ F2008 9.6.2.4 */
+ if (dtp->u.p.current_unit->child_dtio > 0)
+ dtp->u.p.advance_status = ADVANCE_NO;
+
if (read_flag)
{
dtp->u.p.current_unit->previous_nonadvancing_write = 0;
return;
}
- /* TODO: This is required to maintain compatibility between
- 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
-
- if (is_stream_io (dtp))
- dtp->u.p.current_unit->strm_pos = dtp->rec;
-
- /* TODO: Un-comment this code when ABI changes from 4.3.
if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
{
generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"Record number not allowed for stream access "
"data transfer");
return;
- } */
+ }
}
/* Bugware for badly written mixed C-Fortran I/O. */
position. */
static void
-skip_record (st_parameter_dt *dtp, ssize_t bytes)
+skip_record (st_parameter_dt *dtp, gfc_offset bytes)
{
ssize_t rlength, readb;
#define MAX_READ 4096
next_record_r (st_parameter_dt *dtp, int done)
{
gfc_offset record;
- int bytes_left;
char p;
int cc;
}
else
{
- bytes_left = (int) dtp->u.p.current_unit->bytes_left;
+ gfc_offset bytes_left = dtp->u.p.current_unit->bytes_left;
bytes_left = min_off (bytes_left,
ssize (dtp->u.p.current_unit->s)
- stell (dtp->u.p.current_unit->s));
}
break;
}
- else
+ else if (dtp->u.p.current_unit->flags.cc != CC_NONE)
{
do
{
/* Utility function like memset() but operating on streams. Return
value is same as for POSIX write(). */
-static ssize_t
-sset (stream * s, int c, ssize_t nbyte)
+static gfc_offset
+sset (stream *s, int c, gfc_offset nbyte)
{
#define WRITE_CHUNK 256
char p[WRITE_CHUNK];
- ssize_t bytes_left, trans;
+ gfc_offset bytes_left;
+ ssize_t trans;
if (nbyte < WRITE_CHUNK)
memset (p, c, nbyte);
}
+/* Finish up a record according to the legacy carriagecontrol type, based
+ on the first character in the record. */
+
+static void
+next_record_cc (st_parameter_dt *dtp)
+{
+ /* Only valid with CARRIAGECONTROL=FORTRAN. */
+ if (dtp->u.p.current_unit->flags.cc != CC_FORTRAN)
+ return;
+
+ fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
+ if (dtp->u.p.cc.len > 0)
+ {
+ char *p = fbuf_alloc (dtp->u.p.current_unit, dtp->u.p.cc.len);
+ if (!p)
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
+
+ /* Output CR for the first character with default CC setting. */
+ *(p++) = dtp->u.p.cc.u.end;
+ if (dtp->u.p.cc.len > 1)
+ *p = dtp->u.p.cc.u.end;
+ }
+}
+
/* Position to the next record in write mode. */
static void
next_record_w (st_parameter_dt *dtp, int done)
{
- gfc_offset m, record, max_pos;
- int length;
+ gfc_offset max_pos_off;
/* Zero counters for X- and T-editing. */
- max_pos = dtp->u.p.max_pos;
+ max_pos_off = dtp->u.p.max_pos;
dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
switch (current_mode (dtp))
case UNFORMATTED_DIRECT:
if (dtp->u.p.current_unit->bytes_left > 0)
{
- length = (int) dtp->u.p.current_unit->bytes_left;
+ gfc_offset length = dtp->u.p.current_unit->bytes_left;
if (sset (dtp->u.p.current_unit->s, 0, length) != length)
goto io_error;
}
if (is_internal_unit (dtp))
{
char *p;
+ /* Internal unit, so must fit in memory. */
+ size_t length, m, record;
+ size_t max_pos = max_pos_off;
if (is_array_io (dtp))
{
int finished;
- length = (int) dtp->u.p.current_unit->bytes_left;
+ length = dtp->u.p.current_unit->bytes_left;
/* If the farthest position reached is greater than current
position, adjust the position and set length to pad out
- dtp->u.p.current_unit->bytes_left;
if (max_pos > m)
{
- length = (int) (max_pos - m);
+ length = (max_pos - m);
if (sseek (dtp->u.p.current_unit->s,
length, SEEK_CUR) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
return;
}
- length = (int) (dtp->u.p.current_unit->recl - max_pos);
+ length = ((size_t) dtp->u.p.current_unit->recl - max_pos);
}
p = write_block (dtp, length);
dtp->u.p.current_unit->endfile = AT_ENDFILE;
/* Now seek to this record */
- record = record * dtp->u.p.current_unit->recl;
+ record = record * ((size_t) dtp->u.p.current_unit->recl);
if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
{
- dtp->u.p.current_unit->bytes_left;
if (max_pos > m)
{
- length = (int) (max_pos - m);
+ length = max_pos - m;
if (sseek (dtp->u.p.current_unit->s,
length, SEEK_CUR) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
return;
}
- length = (int) (dtp->u.p.current_unit->recl - max_pos);
+ length = (size_t) dtp->u.p.current_unit->recl
+ - max_pos;
}
else
- length = (int) dtp->u.p.current_unit->bytes_left;
+ length = dtp->u.p.current_unit->bytes_left;
}
if (length > 0)
{
}
}
}
+ /* Handle legacy CARRIAGECONTROL line endings. */
+ else if (dtp->u.p.current_unit->flags.cc == CC_FORTRAN)
+ next_record_cc (dtp);
else
{
+ /* Skip newlines for CC=CC_NONE. */
+ const int len = (dtp->u.p.current_unit->flags.cc == CC_NONE)
+ ? 0
#ifdef HAVE_CRLF
- const int len = 2;
+ : 2;
#else
- const int len = 1;
+ : 1;
#endif
- fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
- char * p = fbuf_alloc (dtp->u.p.current_unit, len);
- if (!p)
- goto io_error;
+ fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
+ if (dtp->u.p.current_unit->flags.cc != CC_NONE)
+ {
+ char *p = fbuf_alloc (dtp->u.p.current_unit, len);
+ if (!p)
+ goto io_error;
#ifdef HAVE_CRLF
- *(p++) = '\r';
+ *(p++) = '\r';
#endif
- *p = '\n';
+ *p = '\n';
+ }
if (is_stream_io (dtp))
{
dtp->u.p.current_unit->strm_pos += len;
else
next_record_w (dtp, done);
+ fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
+
if (!is_stream_io (dtp))
{
/* Since we have changed the position, set it to unspecified so
fp = stell (dtp->u.p.current_unit->s);
/* Calculate next record, rounding up partial records. */
dtp->u.p.current_unit->last_record =
- (fp + dtp->u.p.current_unit->recl - 1) /
- dtp->u.p.current_unit->recl;
+ (fp + dtp->u.p.current_unit->recl) /
+ dtp->u.p.current_unit->recl - 1;
}
else
dtp->u.p.current_unit->last_record++;
if (!done)
pre_position (dtp);
- fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
smarkeor (dtp->u.p.current_unit->s);
}
if ((dtp->u.p.ionml != NULL)
&& (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
{
+ dtp->u.p.namelist_mode = 1;
if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
namelist_read (dtp);
else
namelist_write (dtp);
}
- if (dtp->u.p.current_unit && (dtp->u.p.current_unit->child_dtio > 0))
- return;
-
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
- *dtp->size = dtp->u.p.size_used;
+ *dtp->size = dtp->u.p.current_unit->size_used;
if (dtp->u.p.eor_condition)
{
goto done;
}
+ if (dtp->u.p.current_unit && (dtp->u.p.current_unit->child_dtio > 0))
+ {
+ if (cf & IOPARM_DT_HAS_FORMAT)
+ {
+ free (dtp->u.p.fmt);
+ free (dtp->format);
+ }
+ return;
+ }
+
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
{
if (dtp->u.p.current_unit && current_mode (dtp) == UNFORMATTED_SEQUENTIAL)
fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
dtp->u.p.current_unit->saved_pos = 0;
-
+ dtp->u.p.current_unit->last_char = EOF - 1;
next_record (dtp, 1);
done:
+
+ if (dtp->u.p.unit_is_internal)
+ {
+ fbuf_destroy (dtp->u.p.current_unit);
+ if (dtp->u.p.current_unit
+ && (dtp->u.p.current_unit->child_dtio == 0)
+ && dtp->u.p.current_unit->s)
+ {
+ sclose (dtp->u.p.current_unit->s);
+ dtp->u.p.current_unit->s = NULL;
+ }
+ }
+
#ifdef HAVE_USELOCALE
if (dtp->u.p.old_locale != (locale_t) 0)
{
free_ionml (dtp);
/* If this is a parent READ statement we do not need to retain the
- internal unit structure for child use. Free it and stash the unit
- number for reuse. */
+ internal unit structure for child use. */
if (dtp->u.p.current_unit != NULL
&& dtp->u.p.current_unit->child_dtio == 0)
{
- if (is_internal_unit (dtp) &&
- (dtp->common.flags & IOPARM_DT_HAS_UDTIO) == 0)
- {
- free (dtp->u.p.current_unit->filename);
- dtp->u.p.current_unit->filename = NULL;
- free_format_hash_table (dtp->u.p.current_unit);
- free (dtp->u.p.current_unit->s);
- dtp->u.p.current_unit->s = NULL;
- if (dtp->u.p.current_unit->ls)
- free (dtp->u.p.current_unit->ls);
- dtp->u.p.current_unit->ls = NULL;
- stash_internal_unit (dtp);
+ if (dtp->u.p.unit_is_internal)
+ {
+ if ((dtp->common.flags & IOPARM_DT_HAS_UDTIO) == 0)
+ {
+ free (dtp->u.p.current_unit->filename);
+ dtp->u.p.current_unit->filename = NULL;
+ if (dtp->u.p.current_unit->ls)
+ free (dtp->u.p.current_unit->ls);
+ dtp->u.p.current_unit->ls = NULL;
+ }
+ newunit_free (dtp->common.unit);
}
- if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
+ if (dtp->u.p.unit_is_internal || dtp->u.p.format_not_saved)
{
free_format_data (dtp->u.p.fmt);
free_format (dtp);
free_ionml (dtp);
/* If this is a parent WRITE statement we do not need to retain the
- internal unit structure for child use. Free it and stash the
- unit number for reuse. */
- if (is_internal_unit (dtp) &&
- (dtp->common.flags & IOPARM_DT_HAS_UDTIO) == 0)
+ internal unit structure for child use. */
+ if (dtp->u.p.unit_is_internal)
{
- free (dtp->u.p.current_unit->filename);
- dtp->u.p.current_unit->filename = NULL;
- free_format_hash_table (dtp->u.p.current_unit);
- free (dtp->u.p.current_unit->s);
- dtp->u.p.current_unit->s = NULL;
- if (dtp->u.p.current_unit->ls)
- free (dtp->u.p.current_unit->ls);
- dtp->u.p.current_unit->ls = NULL;
- stash_internal_unit (dtp);
+ if ((dtp->common.flags & IOPARM_DT_HAS_UDTIO) == 0)
+ {
+ free (dtp->u.p.current_unit->filename);
+ dtp->u.p.current_unit->filename = NULL;
+ if (dtp->u.p.current_unit->ls)
+ free (dtp->u.p.current_unit->ls);
+ dtp->u.p.current_unit->ls = NULL;
+ }
+ newunit_free (dtp->common.unit);
}
- if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
+ if (dtp->u.p.unit_is_internal || dtp->u.p.format_not_saved)
{
free_format_data (dtp->u.p.fmt);
free_format (dtp);
in a linked list of namelist_info types. */
static void
-set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
+set_nml_var (st_parameter_dt *dtp, void *var_addr, char *var_name,
GFC_INTEGER_4 len, gfc_charlen_type string_length,
GFC_INTEGER_4 dtype, void *dtio_sub, void *vtable)
{
export_proto(st_set_nml_var);
void
-st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
+st_set_nml_var (st_parameter_dt *dtp, void *var_addr, char *var_name,
GFC_INTEGER_4 len, gfc_charlen_type string_length,
GFC_INTEGER_4 dtype)
{
void
-st_set_nml_dtio_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
+st_set_nml_dtio_var (st_parameter_dt *dtp, void *var_addr, char *var_name,
GFC_INTEGER_4 len, gfc_charlen_type string_length,
GFC_INTEGER_4 dtype, void *dtio_sub, void *vtable)
{
index_type stride, index_type lbound,
index_type ubound)
{
- namelist_info * nml;
+ namelist_info *nml;
int n;
n = (int)n_dim;
9.10.2 in F2003. */
void
-hit_eof (st_parameter_dt * dtp)
+hit_eof (st_parameter_dt *dtp)
{
dtp->u.p.current_unit->flags.position = POSITION_APPEND;