typedef enum
{ FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
- FORMATTED_DIRECT, UNFORMATTED_DIRECT
+ FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
}
file_mode;
{
file_mode m;
+ m = FORM_UNSPECIFIED;
+
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{
m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
FORMATTED_DIRECT : UNFORMATTED_DIRECT;
}
- else
+ else if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
{
m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
}
+ else if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
+ {
+ m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
+ FORMATTED_STREAM : UNFORMATTED_STREAM;
+ }
return m;
}
an I/O error.
Given this, the solution is to read a byte at a time, stopping if
- we hit the newline. For small locations, we use a static buffer.
+ we hit the newline. For small allocations, we use a static buffer.
For larger allocations, we are forced to allocate memory on the
heap. Hopefully this won't happen very often. */
-static char *
-read_sf (st_parameter_dt *dtp, int *length)
+char *
+read_sf (st_parameter_dt *dtp, int *length, int no_error)
{
char *base, *p, *q;
int n, readlen, crlf;
EOR below. */
if (readlen < 1 && n == 0)
{
+ if (no_error)
+ break;
generate_error (&dtp->common, ERROR_END, NULL);
return NULL;
}
so we can just continue with a short read. */
if (dtp->u.p.current_unit->flags.pad == PAD_NO)
{
+ if (no_error)
+ break;
generate_error (&dtp->common, ERROR_EOR, NULL);
return NULL;
}
if (*q == ',')
if (dtp->u.p.sf_read_comma == 1)
{
- notify_std (GFC_STD_GNU, "Comma in formatted numeric read.");
+ notify_std (&dtp->common, GFC_STD_GNU,
+ "Comma in formatted numeric read.");
*length = n;
break;
}
dtp->u.p.current_unit->bytes_left -= *length;
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
- *dtp->size += *length;
+ dtp->u.p.size_used += (gfc_offset) *length;
return base;
}
char *source;
int nread;
- if (dtp->u.p.current_unit->bytes_left < *length)
+ if (!is_stream_io (dtp))
{
- if (dtp->u.p.current_unit->flags.pad == PAD_NO)
+ if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *length)
{
- generate_error (&dtp->common, ERROR_EOR, NULL);
- /* Not enough data left. */
- return NULL;
+ /* 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->bytes_left = dtp->u.p.current_unit->recl;
+ else
+ {
+ if (dtp->u.p.current_unit->flags.pad == PAD_NO)
+ {
+ /* Not enough data left. */
+ generate_error (&dtp->common, ERROR_EOR, NULL);
+ return NULL;
+ }
+ }
+
+ if (dtp->u.p.current_unit->bytes_left == 0)
+ {
+ dtp->u.p.current_unit->endfile = AT_ENDFILE;
+ generate_error (&dtp->common, ERROR_END, NULL);
+ return NULL;
+ }
+
+ *length = dtp->u.p.current_unit->bytes_left;
}
- *length = dtp->u.p.current_unit->bytes_left;
- }
+ if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
+ dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+ return read_sf (dtp, length, 0); /* Special case. */
- if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
- dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
- return read_sf (dtp, length); /* Special case. */
+ dtp->u.p.current_unit->bytes_left -= (gfc_offset) *length;
- dtp->u.p.current_unit->bytes_left -= *length;
+ nread = *length;
+ source = salloc_r (dtp->u.p.current_unit->s, &nread);
- nread = *length;
- source = salloc_r (dtp->u.p.current_unit->s, &nread);
+ if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+ dtp->u.p.size_used += (gfc_offset) nread;
- if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
- *dtp->size += nread;
+ if (nread != *length)
+ { /* Short read, this shouldn't happen. */
+ if (dtp->u.p.current_unit->flags.pad == PAD_YES)
+ *length = nread;
+ else
+ {
+ generate_error (&dtp->common, ERROR_EOR, NULL);
+ source = NULL;
+ }
+ }
+ }
+ else
+ {
+ if (sseek (dtp->u.p.current_unit->s,
+ dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
+ {
+ generate_error (&dtp->common, ERROR_END, NULL);
+ return NULL;
+ }
- if (nread != *length)
- { /* Short read, this shouldn't happen. */
- if (dtp->u.p.current_unit->flags.pad == PAD_YES)
- *length = nread;
- else
+ if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
{
- generate_error (&dtp->common, ERROR_EOR, NULL);
- source = NULL;
+ source = read_sf (dtp, length, 0);
+ dtp->u.p.current_unit->strm_pos +=
+ (gfc_offset) (*length + dtp->u.p.sf_seen_eor);
+ return source;
+ }
+ nread = *length;
+ source = salloc_r (dtp->u.p.current_unit->s, &nread);
+
+ if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+ dtp->u.p.size_used += (gfc_offset) nread;
+
+ if (nread != *length)
+ { /* Short read, this shouldn't happen. */
+ if (dtp->u.p.current_unit->flags.pad == PAD_YES)
+ *length = nread;
+ else
+ {
+ generate_error (&dtp->common, ERROR_END, NULL);
+ source = NULL;
+ }
}
- }
+ dtp->u.p.current_unit->strm_pos += (gfc_offset) nread;
+ }
return source;
}
void *data;
size_t nread;
- if (dtp->u.p.current_unit->bytes_left < *nbytes)
+ if (!is_stream_io (dtp))
{
- if (dtp->u.p.current_unit->flags.pad == PAD_NO)
+ if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
{
- /* Not enough data left. */
- generate_error (&dtp->common, ERROR_EOR, NULL);
+ /* 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->bytes_left = dtp->u.p.current_unit->recl;
+ else
+ {
+ if (dtp->u.p.current_unit->flags.pad == PAD_NO)
+ {
+ /* Not enough data left. */
+ generate_error (&dtp->common, ERROR_EOR, NULL);
+ return;
+ }
+ }
+
+ if (dtp->u.p.current_unit->bytes_left == 0)
+ {
+ dtp->u.p.current_unit->endfile = AT_ENDFILE;
+ generate_error (&dtp->common, ERROR_END, NULL);
+ return;
+ }
+
+ *nbytes = (size_t) dtp->u.p.current_unit->bytes_left;
+ }
+
+ if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
+ dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+ {
+ length = (int *) nbytes;
+ data = read_sf (dtp, length, 0); /* Special case. */
+ memcpy (buf, data, (size_t) *length);
return;
}
- *nbytes = dtp->u.p.current_unit->bytes_left;
+ dtp->u.p.current_unit->bytes_left -= (gfc_offset) *nbytes;
}
-
- if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
- dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+ else
{
- length = (int *) nbytes;
- data = read_sf (dtp, length); /* Special case. */
- memcpy (buf, data, (size_t) *length);
- return;
+ if (sseek (dtp->u.p.current_unit->s,
+ dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
+ {
+ generate_error (&dtp->common, ERROR_END, NULL);
+ return;
+ }
}
- dtp->u.p.current_unit->bytes_left -= *nbytes;
-
nread = *nbytes;
if (sread (dtp->u.p.current_unit->s, buf, &nread) != 0)
{
return;
}
- if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
- *dtp->size += (GFC_INTEGER_4) nread;
+ if (!is_stream_io (dtp))
+ {
+ if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+ dtp->u.p.size_used += (gfc_offset) nread;
+ }
+ else
+ dtp->u.p.current_unit->strm_pos += (gfc_offset) nread;
- if (nread != *nbytes)
- { /* Short read, e.g. if we hit EOF. */
- if (dtp->u.p.current_unit->flags.pad == PAD_YES)
- {
- memset (((char *) buf) + nread, ' ', *nbytes - nread);
- *nbytes = nread;
- }
- else
+ if (nread != *nbytes) /* Short read, e.g. if we hit EOF. */
+ {
+ if (!is_stream_io (dtp))
generate_error (&dtp->common, ERROR_EOR, NULL);
+ else
+ generate_error (&dtp->common, ERROR_END, NULL);
}
}
write_block (st_parameter_dt *dtp, int length)
{
char *dest;
-
- if (dtp->u.p.current_unit->bytes_left < length)
+
+ if (!is_stream_io (dtp))
{
- generate_error (&dtp->common, ERROR_EOR, NULL);
- return NULL;
- }
+ if (dtp->u.p.current_unit->bytes_left < (gfc_offset) length)
+ {
+ /* 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.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->bytes_left = dtp->u.p.current_unit->recl;
+ else
+ {
+ generate_error (&dtp->common, ERROR_EOR, NULL);
+ return NULL;
+ }
+ }
+
+ dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
- dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
- dest = salloc_w (dtp->u.p.current_unit->s, &length);
+
+ dest = salloc_w (dtp->u.p.current_unit->s, &length);
- if (dest == NULL)
- {
- generate_error (&dtp->common, ERROR_END, NULL);
- return NULL;
+ if (dest == NULL)
+ {
+ generate_error (&dtp->common, ERROR_END, NULL);
+ return NULL;
+ }
+
+ if (is_internal_unit (dtp) && dtp->u.p.current_unit->endfile == AT_ENDFILE)
+ generate_error (&dtp->common, ERROR_END, NULL);
+
+ if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+ dtp->u.p.size_used += (gfc_offset) length;
}
+ else
+ {
+ if (sseek (dtp->u.p.current_unit->s,
+ dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
+ {
+ generate_error (&dtp->common, ERROR_OS, NULL);
+ return NULL;
+ }
- if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
- *dtp->size += length;
+ dest = salloc_w (dtp->u.p.current_unit->s, &length);
+
+ if (dest == NULL)
+ {
+ generate_error (&dtp->common, ERROR_END, NULL);
+ return NULL;
+ }
+
+ dtp->u.p.current_unit->strm_pos += (gfc_offset) length;
+ }
return dest;
}
static try
write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
{
- if (dtp->u.p.current_unit->bytes_left < nbytes)
+ if (!is_stream_io (dtp))
{
- generate_error (&dtp->common, ERROR_EOR, NULL);
- return FAILURE;
- }
+ if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)
+ {
+ /* 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.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->bytes_left = dtp->u.p.current_unit->recl;
+ else
+ {
+ if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
+ generate_error (&dtp->common, ERROR_DIRECT_EOR, NULL);
+ else
+ generate_error (&dtp->common, ERROR_EOR, NULL);
+ return FAILURE;
+ }
+ }
- dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
+ dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
+ }
+ else
+ {
+ if (sseek (dtp->u.p.current_unit->s,
+ dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
+ {
+ generate_error (&dtp->common, ERROR_OS, NULL);
+ return FAILURE;
+ }
+ }
if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
{
return FAILURE;
}
- if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+ if (!is_stream_io (dtp))
{
- *dtp->size += (GFC_INTEGER_4) nbytes;
- return FAILURE;
+ if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+ dtp->u.p.size_used += (gfc_offset) nbytes;
}
+ else
+ dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
return SUCCESS;
}
void *dest, int kind,
size_t size, size_t nelems)
{
+ size_t i, sz;
+
/* Currently, character implies size=1. */
if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE
|| size == 1 || type == BT_CHARACTER)
{
- size *= nelems;
- read_block_direct (dtp, dest, &size);
+ sz = size * nelems;
+ read_block_direct (dtp, dest, &sz);
}
else
{
char buffer[16];
char *p;
- size_t i, sz;
/* Break up complex into its constituent reals. */
if (type == BT_COMPLEX)
/* This subroutine is the main loop for a formatted data transfer
statement. It would be natural to implement this as a coroutine
with the user program, but C makes that awkward. We loop,
- processesing format elements. When we actually have to transfer
+ processing format elements. When we actually have to transfer
data instead of just setting flags, we return control to the user
program which calls a subroutine that supplies the address and type
of the next element, then comes back here to process it. */
f = next_format (dtp);
if (f == NULL)
- return; /* No data descriptors left (already raised). */
+ {
+ /* No data descriptors left. */
+ if (n > 0)
+ generate_error (&dtp->common, ERROR_FORMAT,
+ "Insufficient data descriptors in format after reversion");
+ return;
+ }
/* Now discharge T, TR and X movements to the right. This is delayed
until a data producing format to suppress trailing spaces. */
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 = (int)(dtp->u.p.current_unit->recl
+ - dtp->u.p.current_unit->bytes_left);
switch (t)
{
case FMT_B:
if (n == 0)
goto need_data;
- if (require_type (dtp, BT_INTEGER, type, f))
+
+ if (compile_options.allow_std < GFC_STD_GNU
+ && require_type (dtp, BT_INTEGER, type, f))
return;
if (dtp->u.p.mode == READING)
case FMT_O:
if (n == 0)
- goto need_data;
+ goto need_data;
+
+ if (compile_options.allow_std < GFC_STD_GNU
+ && require_type (dtp, BT_INTEGER, type, f))
+ return;
if (dtp->u.p.mode == READING)
read_radix (dtp, f, p, len, 8);
if (n == 0)
goto need_data;
+ if (compile_options.allow_std < GFC_STD_GNU
+ && require_type (dtp, BT_INTEGER, type, f))
+ return;
+
if (dtp->u.p.mode == READING)
read_radix (dtp, f, p, len, 16);
else
internal_error (&dtp->common, "transfer_array(): Bad type");
}
- if (desc->dim[0].stride == 0)
- desc->dim[0].stride = 1;
-
rank = GFC_DESCRIPTOR_RANK (desc);
for (n = 0; n < rank; n++)
{
{
char *p;
int n;
+ int nr;
+ GFC_INTEGER_4 i4;
+ GFC_INTEGER_8 i8;
gfc_offset i;
if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
return;
- n = sizeof (gfc_offset);
+ if (compile_options.record_marker == 0)
+ n = sizeof (gfc_offset);
+ else
+ n = compile_options.record_marker;
+
+ nr = n;
+
p = salloc_r (dtp->u.p.current_unit->s, &n);
if (n == 0)
return; /* end of file */
}
- if (p == NULL || n != sizeof (gfc_offset))
+ if (p == NULL || n != nr)
{
generate_error (&dtp->common, ERROR_BAD_US, NULL);
return;
/* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
- memcpy (&i, p, sizeof (gfc_offset));
+ {
+ switch (compile_options.record_marker)
+ {
+ case 0:
+ memcpy (&i, p, sizeof(gfc_offset));
+ break;
+
+ case sizeof(GFC_INTEGER_4):
+ memcpy (&i4, p, sizeof (i4));
+ i = i4;
+ break;
+
+ case sizeof(GFC_INTEGER_8):
+ memcpy (&i8, p, sizeof (i8));
+ i = i8;
+ break;
+
+ default:
+ runtime_error ("Illegal value for record marker");
+ break;
+ }
+ }
else
- reverse_memcpy (&i, p, sizeof (gfc_offset));
-
+ switch (compile_options.record_marker)
+ {
+ case 0:
+ reverse_memcpy (&i, p, sizeof(gfc_offset));
+ break;
+
+ case sizeof(GFC_INTEGER_4):
+ reverse_memcpy (&i4, p, sizeof (i4));
+ i = i4;
+ break;
+
+ case sizeof(GFC_INTEGER_8):
+ reverse_memcpy (&i8, p, sizeof (i8));
+ i = i8;
+ break;
+
+ default:
+ runtime_error ("Illegal value for record marker");
+ break;
+ }
+
dtp->u.p.current_unit->bytes_left = i;
}
gfc_offset dummy;
dummy = 0;
- nbytes = sizeof (gfc_offset);
+
+ if (compile_options.record_marker == 0)
+ nbytes = sizeof (gfc_offset);
+ else
+ nbytes = compile_options.record_marker ;
if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0)
generate_error (&dtp->common, ERROR_OS, NULL);
switch (current_mode (dtp))
{
+ case FORMATTED_STREAM:
+ case UNFORMATTED_STREAM:
+ /* There are no records with stream I/O. Set the default position
+ to the beginning of the file if no position was specified. */
+ if ((dtp->common.flags & IOPARM_DT_HAS_REC) == 0)
+ dtp->u.p.current_unit->strm_pos = 1;
+ break;
+
case UNFORMATTED_SEQUENTIAL:
if (dtp->u.p.mode == READING)
us_read (dtp);
dtp->u.p.mode = read_flag ? READING : WRITING;
if ((cf & IOPARM_DT_HAS_SIZE) != 0)
- *dtp->size = 0; /* Initialize the count. */
+ 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)
{ /* Open the unit with some default flags. */
st_parameter_open opp;
+ unit_convert conv;
+
if (dtp->common.unit < 0)
{
close_unit (dtp->u.p.current_unit);
u_flags.blank = BLANK_UNSPECIFIED;
u_flags.pad = PAD_UNSPECIFIED;
u_flags.status = STATUS_UNKNOWN;
+
+ conv = get_unformatted_convert (dtp->common.unit);
+
+ if (conv == CONVERT_NONE)
+ conv = compile_options.convert;
+
+ /* We use l8_to_l4_offset, which is 0 on little-endian machines
+ and 1 on big-endian machines. */
+ switch (conv)
+ {
+ case CONVERT_NATIVE:
+ case CONVERT_SWAP:
+ break;
+
+ case CONVERT_BIG:
+ conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP;
+ break;
+
+ case CONVERT_LITTLE:
+ conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE;
+ break;
+
+ default:
+ internal_error (&opp.common, "Illegal value for CONVERT");
+ break;
+ }
+
+ u_flags.convert = conv;
+
opp.common = dtp->common;
opp.common.flags &= IOPARM_COMMON_MASK;
dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags);
generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"Missing format for FORMATTED data transfer");
-
if (is_internal_unit (dtp)
&& dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"Internal file cannot be accessed by UNFORMATTED data transfer");
- /* Check the record number. */
+ /* Check the record or position number. */
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
&& (cf & IOPARM_DT_HAS_REC) == 0)
return;
/* Sanity checks on the record number. */
-
if ((cf & IOPARM_DT_HAS_REC) != 0)
{
if (dtp->rec <= 0)
/* Check to see if we might be reading what we wrote before */
- if (dtp->u.p.mode == READING && dtp->u.p.current_unit->mode == WRITING)
+ if (dtp->u.p.mode == READING
+ && dtp->u.p.current_unit->mode == WRITING
+ && !is_internal_unit (dtp))
flush(dtp->u.p.current_unit->s);
/* Check whether the record exists to be read. Only
}
/* Position the file. */
- if (sseek (dtp->u.p.current_unit->s,
- (dtp->rec - 1) * dtp->u.p.current_unit->recl) == FAILURE)
+ if (!is_stream_io (dtp))
{
- generate_error (&dtp->common, ERROR_OS, NULL);
- return;
+ if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
+ * dtp->u.p.current_unit->recl) == FAILURE)
+ {
+ generate_error (&dtp->common, ERROR_OS, NULL);
+ return;
+ }
}
+ else
+ dtp->u.p.current_unit->strm_pos = dtp->rec;
+
}
/* Overwriting an existing sequential file ?
it is always safe to truncate the file on the first write */
if (dtp->u.p.mode == WRITING
&& dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
- && dtp->u.p.current_unit->last_record == 0 && !is_preconnected(dtp->u.p.current_unit->s))
+ && dtp->u.p.current_unit->last_record == 0
+ && !is_preconnected(dtp->u.p.current_unit->s))
struncate(dtp->u.p.current_unit->s);
/* Bugware for badly written mixed C-Fortran I/O. */
if (read_flag)
{
- if (dtp->u.p.current_unit->read_bad)
+ if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp))
{
generate_error (&dtp->common, ERROR_BAD_OPTION,
"Cannot READ after a nonadvancing WRITE");
switch (current_mode (dtp))
{
+ /* No records in unformatted STREAM I/O. */
+ case UNFORMATTED_STREAM:
+ return;
+
case UNFORMATTED_SEQUENTIAL:
/* Skip over tail */
- dtp->u.p.current_unit->bytes_left += sizeof (gfc_offset);
+ dtp->u.p.current_unit->bytes_left +=
+ compile_options.record_marker == 0 ?
+ sizeof (gfc_offset) : compile_options.record_marker;
/* Fall through... */
}
break;
+ case FORMATTED_STREAM:
case FORMATTED_SEQUENTIAL:
length = 1;
/* sf_read has already terminated input because of an '\n' */
dtp->u.p.current_unit->endfile = AT_ENDFILE;
break;
}
+
+ if (is_stream_io (dtp))
+ dtp->u.p.current_unit->strm_pos++;
}
while (*p != '\n');
/* Small utility function to write a record marker, taking care of
- byte swapping. */
+ byte swapping and of choosing the correct size. */
inline static int
write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
{
- size_t len = sizeof (gfc_offset);
+ size_t len;
+ GFC_INTEGER_4 buf4;
+ GFC_INTEGER_8 buf8;
+ char p[sizeof (GFC_INTEGER_8)];
+
+ if (compile_options.record_marker == 0)
+ len = sizeof (gfc_offset);
+ else
+ len = compile_options.record_marker;
+
/* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
- return swrite (dtp->u.p.current_unit->s, &buf, &len);
- else {
- gfc_offset p;
- reverse_memcpy (&p, &buf, sizeof (gfc_offset));
- return swrite (dtp->u.p.current_unit->s, &p, &len);
- }
+ {
+ switch (compile_options.record_marker)
+ {
+ case 0:
+ return swrite (dtp->u.p.current_unit->s, &buf, &len);
+ break;
+
+ case sizeof (GFC_INTEGER_4):
+ buf4 = buf;
+ return swrite (dtp->u.p.current_unit->s, &buf4, &len);
+ break;
+
+ case sizeof (GFC_INTEGER_8):
+ buf8 = buf;
+ return swrite (dtp->u.p.current_unit->s, &buf8, &len);
+ break;
+
+ default:
+ runtime_error ("Illegal value for record marker");
+ break;
+ }
+ }
+ else
+ {
+ switch (compile_options.record_marker)
+ {
+ case 0:
+ reverse_memcpy (p, &buf, sizeof (gfc_offset));
+ return swrite (dtp->u.p.current_unit->s, p, &len);
+ break;
+
+ case sizeof (GFC_INTEGER_4):
+ buf4 = buf;
+ reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4));
+ return swrite (dtp->u.p.current_unit->s, p, &len);
+ break;
+
+ case sizeof (GFC_INTEGER_8):
+ buf8 = buf;
+ reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_4));
+ return swrite (dtp->u.p.current_unit->s, p, &len);
+ break;
+
+ default:
+ runtime_error ("Illegal value for record marker");
+ break;
+ }
+ }
+
}
gfc_offset c, m, record, max_pos;
int length;
char *p;
+ size_t record_marker;
/* Zero counters for X- and T-editing. */
max_pos = dtp->u.p.max_pos;
switch (current_mode (dtp))
{
+ /* No records in unformatted STREAM I/O. */
+ case UNFORMATTED_STREAM:
+ return;
+
case FORMATTED_DIRECT:
if (dtp->u.p.current_unit->bytes_left == 0)
break;
if (write_us_marker (dtp, m) != 0)
goto io_error;
+ if (compile_options.record_marker == 4)
+ record_marker = sizeof(GFC_INTEGER_4);
+ else
+ record_marker = sizeof (gfc_offset);
+
/* Seek to the head and overwrite the bogus length with the real
length. */
- if (sseek (dtp->u.p.current_unit->s, c - m - sizeof (gfc_offset))
- == FAILURE)
+ if (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
+ == FAILURE)
goto io_error;
if (write_us_marker (dtp, m) != 0)
/* Seek past the end of the current record. */
- if (sseek (dtp->u.p.current_unit->s, c + sizeof (gfc_offset)) == FAILURE)
+ if (sseek (dtp->u.p.current_unit->s, c + record_marker) == FAILURE)
goto io_error;
break;
+ case FORMATTED_STREAM:
case FORMATTED_SEQUENTIAL:
- if (dtp->u.p.current_unit->bytes_left == 0)
- break;
-
if (is_internal_unit (dtp))
{
if (is_array_io (dtp))
/* Now that the current record has been padded out,
determine where the next record in the array is. */
record = next_array_record (dtp, dtp->u.p.current_unit->ls);
-
+ if (record == 0)
+ dtp->u.p.current_unit->endfile = AT_ENDFILE;
+
/* Now seek to this record */
record = record * dtp->u.p.current_unit->recl;
}
else
{
+
/* If this is the last call to next_record move to the farthest
position reached in preparation for completing the record.
(for file unit) */
#endif
if (swrite (dtp->u.p.current_unit->s, &crlf[2-len], &len) != 0)
goto io_error;
+
+ if (is_stream_io (dtp))
+ dtp->u.p.current_unit->strm_pos += len;
}
break;
else
next_record_w (dtp, done);
- /* keep position up to date for INQUIRE */
- dtp->u.p.current_unit->flags.position = POSITION_ASIS;
-
- dtp->u.p.current_unit->current_record = 0;
- if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
- {
- fp = file_position (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;
- }
- else
- dtp->u.p.current_unit->last_record++;
+ if (!is_stream_io (dtp))
+ {
+ /* keep position up to date for INQUIRE */
+ dtp->u.p.current_unit->flags.position = POSITION_ASIS;
+ dtp->u.p.current_unit->current_record = 0;
+ if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
+ {
+ fp = file_position (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;
+ }
+ else
+ dtp->u.p.current_unit->last_record++;
+ }
if (!done)
pre_position (dtp);
jmp_buf eof_jump;
GFC_INTEGER_4 cf = dtp->common.flags;
+ if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+ *dtp->size = (GFC_INTEGER_4) dtp->u.p.size_used;
+
if (dtp->u.p.eor_condition)
{
generate_error (&dtp->common, ERROR_EOR, NULL);
if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
finish_list_read (dtp);
- else
+ else if (!is_stream_io (dtp))
{
dtp->u.p.current_unit->current_record = 0;
if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
{
/* Most systems buffer lines, so force the partial record
to be written out. */
- flush (dtp->u.p.current_unit->s);
+ if (!is_internal_unit (dtp))
+ flush (dtp->u.p.current_unit->s);
dtp->u.p.seen_dollar = 0;
return;
}
-
next_record (dtp, 1);
}
-
- sfree (dtp->u.p.current_unit->s);
-
- if (is_internal_unit (dtp))
+ else
{
- if (is_array_io (dtp) && dtp->u.p.current_unit->ls != NULL)
- free_mem (dtp->u.p.current_unit->ls);
- sclose (dtp->u.p.current_unit->s);
+ if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
+ next_record (dtp, 1);
+ flush (dtp->u.p.current_unit->s);
}
-}
+ sfree (dtp->u.p.current_unit->s);
+}
/* Transfer function for IOLENGTH. It doesn't actually do any
data transfer, it just updates the length counter. */
void
st_read (st_parameter_dt *dtp)
{
-
library_start (&dtp->common);
data_transfer_init (dtp, 1);
free_mem (dtp->u.p.scratch);
if (dtp->u.p.current_unit != NULL)
unlock_unit (dtp->u.p.current_unit);
+
+ free_internal_unit (dtp);
+
library_end ();
}
/* Deal with endfile conditions associated with sequential files. */
- if (dtp->u.p.current_unit != NULL && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+ if (dtp->u.p.current_unit != NULL
+ && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
switch (dtp->u.p.current_unit->endfile)
{
case AT_ENDFILE: /* Remain at the endfile record. */
break;
case NO_ENDFILE:
- if (dtp->u.p.current_unit->current_record > dtp->u.p.current_unit->last_record)
+ /* Get rid of whatever is after this record. */
+ if (!is_internal_unit (dtp))
{
- /* Get rid of whatever is after this record. */
+ flush (dtp->u.p.current_unit->s);
if (struncate (dtp->u.p.current_unit->s) == FAILURE)
generate_error (&dtp->common, ERROR_OS, NULL);
}
-
dtp->u.p.current_unit->endfile = AT_ENDFILE;
break;
}
free_mem (dtp->u.p.scratch);
if (dtp->u.p.current_unit != NULL)
unlock_unit (dtp->u.p.current_unit);
+
+ free_internal_unit (dtp);
+
library_end ();
}
OSDN Git Service
