blob: e44b2df6058b7afa49086c38c7bf9b277ba86b07 [file] [log] [blame]
/* Copyright (C) 2002-2021 Free Software Foundation, Inc.
Contributed by Andy Vaught
Namelist transfer functions contributed by Paul Thomas
F2003 I/O support contributed by Jerry DeLisle
This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
/* transfer.c -- Top level handling of data transfer statements. */
#include "io.h"
#include "fbuf.h"
#include "format.h"
#include "unix.h"
#include "async.h"
#include <string.h>
#include <errno.h>
/* Calling conventions: Data transfer statements are unlike other
library calls in that they extend over several calls.
The first call is always a call to st_read() or st_write(). These
subroutines return no status unless a namelist read or write is
being done, in which case there is the usual status. No further
calls are necessary in this case.
For other sorts of data transfer, there are zero or more data
transfer statement that depend on the format of the data transfer
statement. For READ (and for backwards compatibily: for WRITE), one has
transfer_integer
transfer_logical
transfer_character
transfer_character_wide
transfer_real
transfer_complex
transfer_real128
transfer_complex128
and for WRITE
transfer_integer_write
transfer_logical_write
transfer_character_write
transfer_character_wide_write
transfer_real_write
transfer_complex_write
transfer_real128_write
transfer_complex128_write
These subroutines do not return status. The *128 functions
are in the file transfer128.c.
The last call is a call to st_[read|write]_done(). While
something can easily go wrong with the initial st_read() or
st_write(), an error inhibits any data from actually being
transferred. */
extern void transfer_integer (st_parameter_dt *, void *, int);
export_proto(transfer_integer);
extern void transfer_integer_write (st_parameter_dt *, void *, int);
export_proto(transfer_integer_write);
extern void transfer_real (st_parameter_dt *, void *, int);
export_proto(transfer_real);
extern void transfer_real_write (st_parameter_dt *, void *, int);
export_proto(transfer_real_write);
extern void transfer_logical (st_parameter_dt *, void *, int);
export_proto(transfer_logical);
extern void transfer_logical_write (st_parameter_dt *, void *, int);
export_proto(transfer_logical_write);
extern void transfer_character (st_parameter_dt *, void *, gfc_charlen_type);
export_proto(transfer_character);
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 *, gfc_charlen_type, int);
export_proto(transfer_character_wide);
extern void transfer_character_wide_write (st_parameter_dt *,
void *, gfc_charlen_type, int);
export_proto(transfer_character_wide_write);
extern void transfer_complex (st_parameter_dt *, void *, int);
export_proto(transfer_complex);
extern void transfer_complex_write (st_parameter_dt *, void *, int);
export_proto(transfer_complex_write);
extern void transfer_array (st_parameter_dt *, gfc_array_char *, int,
gfc_charlen_type);
export_proto(transfer_array);
extern void transfer_array_write (st_parameter_dt *, gfc_array_char *, int,
gfc_charlen_type);
export_proto(transfer_array_write);
/* User defined derived type input/output. */
extern void
transfer_derived (st_parameter_dt *dtp, void *dtio_source, void *dtio_proc);
export_proto(transfer_derived);
extern void
transfer_derived_write (st_parameter_dt *dtp, void *dtio_source, void *dtio_proc);
export_proto(transfer_derived_write);
static void us_read (st_parameter_dt *, int);
static void us_write (st_parameter_dt *, int);
static void next_record_r_unf (st_parameter_dt *, int);
static void next_record_w_unf (st_parameter_dt *, int);
static const st_option advance_opt[] = {
{"yes", ADVANCE_YES},
{"no", ADVANCE_NO},
{NULL, 0}
};
static const st_option decimal_opt[] = {
{"point", DECIMAL_POINT},
{"comma", DECIMAL_COMMA},
{NULL, 0}
};
static const st_option round_opt[] = {
{"up", ROUND_UP},
{"down", ROUND_DOWN},
{"zero", ROUND_ZERO},
{"nearest", ROUND_NEAREST},
{"compatible", ROUND_COMPATIBLE},
{"processor_defined", ROUND_PROCDEFINED},
{NULL, 0}
};
static const st_option sign_opt[] = {
{"plus", SIGN_SP},
{"suppress", SIGN_SS},
{"processor_defined", SIGN_S},
{NULL, 0}
};
static const st_option blank_opt[] = {
{"null", BLANK_NULL},
{"zero", BLANK_ZERO},
{NULL, 0}
};
static const st_option delim_opt[] = {
{"apostrophe", DELIM_APOSTROPHE},
{"quote", DELIM_QUOTE},
{"none", DELIM_NONE},
{NULL, 0}
};
static const st_option pad_opt[] = {
{"yes", PAD_YES},
{"no", PAD_NO},
{NULL, 0}
};
static const st_option async_opt[] = {
{"yes", ASYNC_YES},
{"no", ASYNC_NO},
{NULL, 0}
};
typedef enum
{ FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM,
UNFORMATTED_STREAM, FORMATTED_UNSPECIFIED
}
file_mode;
static file_mode
current_mode (st_parameter_dt *dtp)
{
file_mode m;
m = FORMATTED_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 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;
}
/* Mid level data transfer statements. */
/* Read sequential file - internal unit */
static char *
read_sf_internal (st_parameter_dt *dtp, size_t *length)
{
static char *empty_string[0];
char *base = NULL;
size_t lorig;
/* Zero size array gives internal unit len of 0. Nothing to read. */
if (dtp->internal_unit_len == 0
&& dtp->u.p.current_unit->pad_status == PAD_NO)
hit_eof (dtp);
/* 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);
}
/* To support legacy code we have to scan the input string one byte
at a time because we don't know where an early comma may be and the
requested length could go past the end of a comma shortened
string. We only do this if -std=legacy was given at compile
time. We also do not support this on kind=4 strings. */
if (unlikely(compile_options.warn_std == 0)) // the slow legacy way.
{
size_t n;
size_t tmp = 1;
char *q;
/* If we have seen an eor previously, return a length of 0. The
caller is responsible for correctly padding the input field. */
if (dtp->u.p.sf_seen_eor)
{
*length = 0;
/* Just return something that isn't a NULL pointer, otherwise the
caller thinks an error occurred. */
return (char*) empty_string;
}
/* Get the first character of the string to establish the base
address and check for comma or end-of-record condition. */
base = mem_alloc_r (dtp->u.p.current_unit->s, &tmp);
if (tmp == 0)
{
dtp->u.p.sf_seen_eor = 1;
*length = 0;
return (char*) empty_string;
}
if (*base == ',')
{
dtp->u.p.current_unit->bytes_left--;
*length = 0;
return (char*) empty_string;
}
/* Now we scan the rest and deal with either an end-of-file
condition or a comma, as needed. */
for (n = 1; n < *length; n++)
{
q = mem_alloc_r (dtp->u.p.current_unit->s, &tmp);
if (tmp == 0)
{
hit_eof (dtp);
return NULL;
}
if (*q == ',')
{
dtp->u.p.current_unit->bytes_left -= n;
*length = n;
break;
}
}
}
else // the fast way
{
lorig = *length;
if (is_char4_unit(dtp))
{
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 (size_t i = 0; i < *length; i++, p++)
base[i] = *p > 255 ? '?' : (unsigned char) *p;
}
else
base = mem_alloc_r (dtp->u.p.current_unit->s, length);
if (unlikely (lorig > *length))
{
hit_eof (dtp);
return NULL;
}
}
dtp->u.p.current_unit->bytes_left -= *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;
}
/* When reading sequential formatted records we have a problem. We
don't know how long the line is until we read the trailing newline,
and we don't want to read too much. If we read too much, we might
have to do a physical seek backwards depending on how much data is
present, and devices like terminals aren't seekable and would cause
an I/O error.
Given this, the solution is to read a byte at a time, stopping if
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. */
/* Read sequential file - external unit */
static char *
read_sf (st_parameter_dt *dtp, size_t *length)
{
static char *empty_string[0];
size_t lorig, n;
int q, q2;
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. */
if (dtp->u.p.sf_seen_eor)
{
*length = 0;
/* Just return something that isn't a NULL pointer, otherwise the
caller thinks an error occurred. */
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. */
lorig = *length;
while (n < *length)
{
q = fbuf_getc (dtp->u.p.current_unit);
if (q == EOF)
break;
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;
/* If we see an EOR during non-advancing I/O, we need to skip
the rest of the I/O statement. Set the corresponding flag. */
if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
dtp->u.p.eor_condition = 1;
/* If we encounter a CR, it might be a CRLF. */
if (q == '\r') /* Probably a CRLF */
{
/* See if there is an LF. */
q2 = fbuf_getc (dtp->u.p.current_unit);
if (q2 == '\n')
dtp->u.p.sf_seen_eor = 2;
else if (q2 != EOF) /* Oops, seek back. */
fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR);
}
/* Without padding, terminate the I/O statement without assigning
the value. With padding, the value still needs to be assigned,
so we can just continue with a short read. */
if (dtp->u.p.current_unit->pad_status == PAD_NO)
{
generate_error (&dtp->common, LIBERROR_EOR, NULL);
return NULL;
}
*length = n;
goto done;
}
/* Short circuit the read if a comma is found during numeric input.
The flag is set to zero during character reads so that commas in
strings are not ignored */
else if (q == ',')
if (dtp->u.p.sf_read_comma == 1)
{
seen_comma = 1;
notify_std (&dtp->common, GFC_STD_GNU,
"Comma in formatted numeric read.");
break;
}
n++;
}
*length = n;
/* A short read implies we hit EOF, unless we hit EOR, a comma, or
some other stuff. Set the relevant flags. */
if (lorig > *length && !dtp->u.p.sf_seen_eor && !seen_comma)
{
if (n > 0)
{
if (dtp->u.p.advance_status == ADVANCE_NO)
{
if (dtp->u.p.current_unit->pad_status == PAD_NO)
{
hit_eof (dtp);
return NULL;
}
else
dtp->u.p.eor_condition = 1;
}
else
dtp->u.p.at_eof = 1;
}
else if (dtp->u.p.advance_status == ADVANCE_NO
|| dtp->u.p.current_unit->pad_status == PAD_NO
|| dtp->u.p.current_unit->bytes_left
== dtp->u.p.current_unit->recl)
{
hit_eof (dtp);
return NULL;
}
}
done:
dtp->u.p.current_unit->bytes_left -= 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
minus all the advances, which is n plus up to two characters
of newline or comma. */
return fbuf_getptr (dtp->u.p.current_unit)
- n - dtp->u.p.sf_seen_eor - seen_comma;
}
/* Function for reading the next couple of bytes from the current
file, advancing the current position. We return NULL on end of record or
end of file. This function is only for formatted I/O, unformatted uses
read_block_direct.
If the read is short, then it is because the current record does not
have enough data to satisfy the read request and the file was
opened with PAD=YES. The caller must assume trailing spaces for
short reads. */
void *
read_block_form (st_parameter_dt *dtp, size_t *nbytes)
{
char *source;
size_t norig;
if (!is_stream_io (dtp))
{
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.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 (unlikely (dtp->u.p.current_unit->pad_status == PAD_NO)
&& !is_internal_unit (dtp))
{
/* Not enough data left. */
generate_error (&dtp->common, LIBERROR_EOR, NULL);
return NULL;
}
}
if (is_internal_unit(dtp))
{
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;
}
}
if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
(dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL ||
dtp->u.p.current_unit->flags.access == ACCESS_STREAM))
{
if (is_internal_unit (dtp))
source = read_sf_internal (dtp, nbytes);
else
source = read_sf (dtp, nbytes);
dtp->u.p.current_unit->strm_pos +=
(gfc_offset) (*nbytes + dtp->u.p.sf_seen_eor);
return source;
}
/* If we reach here, we can assume it's direct access. */
dtp->u.p.current_unit->bytes_left -= (gfc_offset) *nbytes;
norig = *nbytes;
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.current_unit->has_size)
dtp->u.p.current_unit->size_used += (GFC_IO_INT) *nbytes;
if (norig != *nbytes)
{
/* Short read, this shouldn't happen. */
if (dtp->u.p.current_unit->pad_status == PAD_NO)
{
generate_error (&dtp->common, LIBERROR_EOR, NULL);
source = NULL;
}
}
dtp->u.p.current_unit->strm_pos += (gfc_offset) *nbytes;
return source;
}
/* Read a block from a character(kind=4) internal unit, to be transferred into
a character(kind=4) variable. Note: Portions of this code borrowed from
read_sf_internal. */
void *
read_block_form4 (st_parameter_dt *dtp, size_t *nbytes)
{
static gfc_char4_t *empty_string[0];
gfc_char4_t *source;
size_t lorig;
if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
*nbytes = dtp->u.p.current_unit->bytes_left;
/* Zero size array gives internal unit len of 0. Nothing to read. */
if (dtp->internal_unit_len == 0
&& dtp->u.p.current_unit->pad_status == PAD_NO)
hit_eof (dtp);
/* If we have seen an eor previously, return a length of 0. The
caller is responsible for correctly padding the input field. */
if (dtp->u.p.sf_seen_eor)
{
*nbytes = 0;
/* Just return something that isn't a NULL pointer, otherwise the
caller thinks an error occurred. */
return empty_string;
}
lorig = *nbytes;
source = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s, nbytes);
if (unlikely (lorig > *nbytes))
{
hit_eof (dtp);
return NULL;
}
dtp->u.p.current_unit->bytes_left -= *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;
}
/* Reads a block directly into application data space. This is for
unformatted files. */
static void
read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes)
{
ssize_t to_read_record;
ssize_t have_read_record;
ssize_t to_read_subrecord;
ssize_t have_read_subrecord;
int short_record;
if (is_stream_io (dtp))
{
have_read_record = sread (dtp->u.p.current_unit->s, buf,
nbytes);
if (unlikely (have_read_record < 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return;
}
dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record;
if (unlikely ((ssize_t) nbytes != have_read_record))
{
/* Short read, e.g. if we hit EOF. For stream files,
we have to set the end-of-file condition. */
hit_eof (dtp);
}
return;
}
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{
if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)
{
short_record = 1;
to_read_record = dtp->u.p.current_unit->bytes_left;
nbytes = to_read_record;
}
else
{
short_record = 0;
to_read_record = nbytes;
}
dtp->u.p.current_unit->bytes_left -= to_read_record;
to_read_record = sread (dtp->u.p.current_unit->s, buf, to_read_record);
if (unlikely (to_read_record < 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return;
}
if (to_read_record != (ssize_t) nbytes)
{
/* Short read, e.g. if we hit EOF. Apparently, we read
more than was written to the last record. */
return;
}
if (unlikely (short_record))
{
generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
}
return;
}
/* Unformatted sequential. We loop over the subrecords, reading
until the request has been fulfilled or the record has run out
of continuation subrecords. */
/* Check whether we exceed the total record length. */
if (dtp->u.p.current_unit->flags.has_recl
&& ((gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left))
{
to_read_record = dtp->u.p.current_unit->bytes_left;
short_record = 1;
}
else
{
to_read_record = nbytes;
short_record = 0;
}
have_read_record = 0;
while(1)
{
if (dtp->u.p.current_unit->bytes_left_subrecord
< (gfc_offset) to_read_record)
{
to_read_subrecord = dtp->u.p.current_unit->bytes_left_subrecord;
to_read_record -= to_read_subrecord;
}
else
{
to_read_subrecord = to_read_record;
to_read_record = 0;
}
dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord;
have_read_subrecord = sread (dtp->u.p.current_unit->s,
buf + have_read_record, to_read_subrecord);
if (unlikely (have_read_subrecord < 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return;
}
have_read_record += have_read_subrecord;
if (unlikely (to_read_subrecord != have_read_subrecord))
{
/* Short read, e.g. if we hit EOF. This means the record
structure has been corrupted, or the trailing record
marker would still be present. */
generate_error (&dtp->common, LIBERROR_CORRUPT_FILE, NULL);
return;
}
if (to_read_record > 0)
{
if (likely (dtp->u.p.current_unit->continued))
{
next_record_r_unf (dtp, 0);
us_read (dtp, 1);
}
else
{
/* Let's make sure the file position is correctly pre-positioned
for the next read statement. */
dtp->u.p.current_unit->current_record = 0;
next_record_r_unf (dtp, 0);
generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
return;
}
}
else
{
/* Normal exit, the read request has been fulfilled. */
break;
}
}
dtp->u.p.current_unit->bytes_left -= have_read_record;
if (unlikely (short_record))
{
generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
return;
}
return;
}
/* Function for writing a block of bytes to the current file at the
current position, advancing the file pointer. We are given a length
and return a pointer to a buffer that the caller must (completely)
fill in. Returns NULL on error. */
void *
write_block (st_parameter_dt *dtp, size_t length)
{
char *dest;
if (!is_stream_io (dtp))
{
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 (likely ((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, LIBERROR_EOR, NULL);
return NULL;
}
}
dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
}
if (is_internal_unit (dtp))
{
if (is_char4_unit(dtp)) /* char4 internel unit. */
{
gfc_char4_t *dest4;
dest4 = mem_alloc_w4 (dtp->u.p.current_unit->s, &length);
if (dest4 == NULL)
{
generate_error (&dtp->common, LIBERROR_END, NULL);
return NULL;
}
return dest4;
}
else
dest = mem_alloc_w (dtp->u.p.current_unit->s, &length);
if (dest == NULL)
{
generate_error (&dtp->common, LIBERROR_END, NULL);
return NULL;
}
if (unlikely (dtp->u.p.current_unit->endfile == AT_ENDFILE))
generate_error (&dtp->common, LIBERROR_END, NULL);
}
else
{
dest = fbuf_alloc (dtp->u.p.current_unit, length);
if (dest == NULL)
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return NULL;
}
}
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;
return dest;
}
/* High level interface to swrite(), taking care of errors. This is only
called for unformatted files. There are three cases to consider:
Stream I/O, unformatted direct, unformatted sequential. */
static bool
write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
{
ssize_t have_written;
ssize_t to_write_subrecord;
int short_record;
/* Stream I/O. */
if (is_stream_io (dtp))
{
have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes);
if (unlikely (have_written < 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return false;
}
dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written;
return true;
}
/* Unformatted direct access. */
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{
if (unlikely (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes))
{
generate_error (&dtp->common, LIBERROR_DIRECT_EOR, NULL);
return false;
}
if (buf == NULL && nbytes == 0)
return true;
have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes);
if (unlikely (have_written < 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return false;
}
dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written;
dtp->u.p.current_unit->bytes_left -= (gfc_offset) have_written;
return true;
}
/* Unformatted sequential. */
have_written = 0;
if (dtp->u.p.current_unit->flags.has_recl
&& (gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left)
{
nbytes = dtp->u.p.current_unit->bytes_left;
short_record = 1;
}
else
{
short_record = 0;
}
while (1)
{
to_write_subrecord =
(size_t) dtp->u.p.current_unit->bytes_left_subrecord < nbytes ?
(size_t) dtp->u.p.current_unit->bytes_left_subrecord : nbytes;
dtp->u.p.current_unit->bytes_left_subrecord -=
(gfc_offset) to_write_subrecord;
to_write_subrecord = swrite (dtp->u.p.current_unit->s,
buf + have_written, to_write_subrecord);
if (unlikely (to_write_subrecord < 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return false;
}
dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord;
nbytes -= to_write_subrecord;
have_written += to_write_subrecord;
if (nbytes == 0)
break;
next_record_w_unf (dtp, 1);
us_write (dtp, 1);
}
dtp->u.p.current_unit->bytes_left -= have_written;
if (unlikely (short_record))
{
generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
return false;
}
return true;
}
/* Reverse memcpy - used for byte swapping. */
static void
reverse_memcpy (void *dest, const void *src, size_t n)
{
char *d, *s;
size_t i;
d = (char *) dest;
s = (char *) src + n - 1;
/* Write with ascending order - this is likely faster
on modern architectures because of write combining. */
for (i=0; i<n; i++)
*(d++) = *(s--);
}
/* Utility function for byteswapping an array, using the bswap
builtins if possible. dest and src can overlap completely, or then
they must point to separate objects; partial overlaps are not
allowed. */
static void
bswap_array (void *dest, const void *src, size_t size, size_t nelems)
{
const char *ps;
char *pd;
switch (size)
{
case 1:
break;
case 2:
for (size_t i = 0; i < nelems; i++)
((uint16_t*)dest)[i] = __builtin_bswap16 (((uint16_t*)src)[i]);
break;
case 4:
for (size_t i = 0; i < nelems; i++)
((uint32_t*)dest)[i] = __builtin_bswap32 (((uint32_t*)src)[i]);
break;
case 8:
for (size_t i = 0; i < nelems; i++)
((uint64_t*)dest)[i] = __builtin_bswap64 (((uint64_t*)src)[i]);
break;
case 12:
ps = src;
pd = dest;
for (size_t i = 0; i < nelems; i++)
{
uint32_t tmp;
memcpy (&tmp, ps, 4);
*(uint32_t*)pd = __builtin_bswap32 (*(uint32_t*)(ps + 8));
*(uint32_t*)(pd + 4) = __builtin_bswap32 (*(uint32_t*)(ps + 4));
*(uint32_t*)(pd + 8) = __builtin_bswap32 (tmp);
ps += size;
pd += size;
}
break;
case 16:
ps = src;
pd = dest;
for (size_t i = 0; i < nelems; i++)
{
uint64_t tmp;
memcpy (&tmp, ps, 8);
*(uint64_t*)pd = __builtin_bswap64 (*(uint64_t*)(ps + 8));
*(uint64_t*)(pd + 8) = __builtin_bswap64 (tmp);
ps += size;
pd += size;
}
break;
default:
pd = dest;
if (dest != src)
{
ps = src;
for (size_t i = 0; i < nelems; i++)
{
reverse_memcpy (pd, ps, size);
ps += size;
pd += size;
}
}
else
{
/* In-place byte swap. */
for (size_t i = 0; i < nelems; i++)
{
char tmp, *low = pd, *high = pd + size - 1;
for (size_t j = 0; j < size/2; j++)
{
tmp = *low;
*low = *high;
*high = tmp;
low++;
high--;
}
pd += size;
}
}
}
}
/* Master function for unformatted reads. */
static void
unformatted_read (st_parameter_dt *dtp, bt type,
void *dest, int kind, size_t size, size_t nelems)
{
if (type == BT_CLASS)
{
int unit = dtp->u.p.current_unit->unit_number;
char tmp_iomsg[IOMSG_LEN] = "";
char *child_iomsg;
gfc_charlen_type child_iomsg_len;
int noiostat;
int *child_iostat = NULL;
/* Set iostat, intent(out). */
noiostat = 0;
child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
dtp->common.iostat : &noiostat;
/* Set iomsg, intent(inout). */
if (dtp->common.flags & IOPARM_HAS_IOMSG)
{
child_iomsg = dtp->common.iomsg;
child_iomsg_len = dtp->common.iomsg_len;
}
else
{
child_iomsg = tmp_iomsg;
child_iomsg_len = IOMSG_LEN;
}
/* Call the user defined unformatted READ procedure. */
dtp->u.p.current_unit->child_dtio++;
dtp->u.p.ufdtio_ptr (dest, &unit, child_iostat, child_iomsg,
child_iomsg_len);
dtp->u.p.current_unit->child_dtio--;
return;
}
if (type == BT_CHARACTER)
size *= GFC_SIZE_OF_CHAR_KIND(kind);
read_block_direct (dtp, dest, size * nelems);
if (unlikely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_SWAP)
&& kind != 1)
{
/* Handle wide chracters. */
if (type == BT_CHARACTER)
{
nelems *= size;
size = kind;
}
/* Break up complex into its constituent reals. */
else if (type == BT_COMPLEX)
{
nelems *= 2;
size /= 2;
}
bswap_array (dest, dest, size, nelems);
}
}
/* Master function for unformatted writes. NOTE: For kind=10 the size is 16
bytes on 64 bit machines. The unused bytes are not initialized and never
used, which can show an error with memory checking analyzers like
valgrind. We us BT_CLASS to denote a User Defined I/O call. */
static void
unformatted_write (st_parameter_dt *dtp, bt type,
void *source, int kind, size_t size, size_t nelems)
{
if (type == BT_CLASS)
{
int unit = dtp->u.p.current_unit->unit_number;
char tmp_iomsg[IOMSG_LEN] = "";
char *child_iomsg;
gfc_charlen_type child_iomsg_len;
int noiostat;
int *child_iostat = NULL;
/* Set iostat, intent(out). */
noiostat = 0;
child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
dtp->common.iostat : &noiostat;
/* Set iomsg, intent(inout). */
if (dtp->common.flags & IOPARM_HAS_IOMSG)
{
child_iomsg = dtp->common.iomsg;
child_iomsg_len = dtp->common.iomsg_len;
}
else
{
child_iomsg = tmp_iomsg;
child_iomsg_len = IOMSG_LEN;
}
/* Call the user defined unformatted WRITE procedure. */
dtp->u.p.current_unit->child_dtio++;
dtp->u.p.ufdtio_ptr (source, &unit, child_iostat, child_iomsg,
child_iomsg_len);
dtp->u.p.current_unit->child_dtio--;
return;
}
if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
|| kind == 1)
{
size_t stride = type == BT_CHARACTER ?
size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
write_buf (dtp, source, stride * nelems);
}
else
{
#define BSWAP_BUFSZ 512
char buffer[BSWAP_BUFSZ];
char *p;
size_t nrem;
p = source;
/* Handle wide chracters. */
if (type == BT_CHARACTER && kind != 1)
{
nelems *= size;
size = kind;
}
/* Break up complex into its constituent reals. */
if (type == BT_COMPLEX)
{
nelems *= 2;
size /= 2;
}
/* By now, all complex variables have been split into their
constituent reals. */
nrem = nelems;
do
{
size_t nc;
if (size * nrem > BSWAP_BUFSZ)
nc = BSWAP_BUFSZ / size;
else
nc = nrem;
bswap_array (buffer, p, size, nc);
write_buf (dtp, buffer, size * nc);
p += size * nc;
nrem -= nc;
}
while (nrem > 0);
}
}
/* Return a pointer to the name of a type. */
const char *
type_name (bt type)
{
const char *p;
switch (type)
{
case BT_INTEGER:
p = "INTEGER";
break;
case BT_LOGICAL:
p = "LOGICAL";
break;
case BT_CHARACTER:
p = "CHARACTER";
break;
case BT_REAL:
p = "REAL";
break;
case BT_COMPLEX:
p = "COMPLEX";
break;
case BT_CLASS:
p = "CLASS or DERIVED";
break;
default:
internal_error (NULL, "type_name(): Bad type");
}
return p;
}
/* Write a constant string to the output.
This is complicated because the string can have doubled delimiters
in it. The length in the format node is the true length. */
static void
write_constant_string (st_parameter_dt *dtp, const fnode *f)
{
char c, delimiter, *p, *q;
int length;
length = f->u.string.length;
if (length == 0)
return;
p = write_block (dtp, length);
if (p == NULL)
return;
q = f->u.string.p;
delimiter = q[-1];
for (; length > 0; length--)
{
c = *p++ = *q++;
if (c == delimiter && c != 'H' && c != 'h')
q++; /* Skip the doubled delimiter. */
}
}
/* Given actual and expected types in a formatted data transfer, make
sure they agree. If not, an error message is generated. Returns
nonzero if something went wrong. */
static int
require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
{
#define BUFLEN 100
char buffer[BUFLEN];
if (actual == expected)
return 0;
/* Adjust item_count before emitting error message. */
snprintf (buffer, BUFLEN,
"Expected %s for item %d in formatted transfer, got %s",
type_name (expected), dtp->u.p.item_count - 1, type_name (actual));
format_error (dtp, f, buffer);
return 1;
}
/* 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)
{
#define BUFLEN 100
char buffer[BUFLEN];
if (actual == BT_INTEGER || actual == BT_REAL || actual == BT_COMPLEX)
return 0;
/* Adjust item_count before emitting error message. */
snprintf (buffer, BUFLEN,
"Expected numeric type for item %d in formatted transfer, got %s",
dtp->u.p.item_count - 1, type_name (actual));
format_error (dtp, f, buffer);
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
with the user program, but C makes that awkward. We loop,
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 function that supplies the address and type
of the next element, then comes back here to process it. */
static void
formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind,
size_t size)
{
int pos, bytes_used;
const fnode *f;
format_token t;
int n;
int consume_data_flag;
/* Change a complex data item into a pair of reals. */
n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
if (type == BT_COMPLEX)
{
type = BT_REAL;
size /= 2;
}
/* If there's an EOR condition, we simulate finalizing the transfer
by doing nothing. */
if (dtp->u.p.eor_condition)
return;
/* Set this flag so that commas in reads cause the read to complete before
the entire field has been read. The next read field will start right after
the comma in the stream. (Set to 0 for character reads). */
dtp->u.p.sf_read_comma =
dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
for (;;)
{
/* If reversion has occurred and there is another real data item,
then we have to move to the next record. */
if (dtp->u.p.reversion_flag && n > 0)
{
dtp->u.p.reversion_flag = 0;
next_record (dtp, 0);
}
consume_data_flag = 1;
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
break;
f = next_format (dtp);
if (f == NULL)
{
/* No data descriptors left. */
if (unlikely (n > 0))
generate_error (&dtp->common, LIBERROR_FORMAT,
"Insufficient data descriptors in format after reversion");
return;
}
t = f->format;
bytes_used = (int)(dtp->u.p.current_unit->recl
- dtp->u.p.current_unit->bytes_left);
if (is_stream_io(dtp))
bytes_used = 0;
switch (t)
{
case FMT_I:
if (n == 0)
goto need_read_data;
if (require_type (dtp, BT_INTEGER, type, f))
return;
read_decimal (dtp, f, p, kind);
break;
case FMT_B:
if (n == 0)
goto need_read_data;
if (!(compile_options.allow_std & GFC_STD_GNU)
&& require_numeric_type (dtp, type, f))
return;
if (!(compile_options.allow_std & GFC_STD_F2008)
&& require_type (dtp, BT_INTEGER, type, f))
return;
read_radix (dtp, f, p, kind, 2);
break;
case FMT_O:
if (n == 0)
goto need_read_data;
if (!(compile_options.allow_std & GFC_STD_GNU)
&& require_numeric_type (dtp, type, f))
return;
if (!(compile_options.allow_std & GFC_STD_F2008)
&& require_type (dtp, BT_INTEGER, type, f))
return;
read_radix (dtp, f, p, kind, 8);
break;
case FMT_Z:
if (n == 0)
goto need_read_data;
if (!(compile_options.allow_std & GFC_STD_GNU)
&& require_numeric_type (dtp, type, f))
return;
if (!(compile_options.allow_std & GFC_STD_F2008)
&& require_type (dtp, BT_INTEGER, type, f))
return;
read_radix (dtp, f, p, kind, 16);
break;
case FMT_A:
if (n == 0)
goto need_read_data;
/* It is possible to have FMT_A with something not BT_CHARACTER such
as when writing out hollerith strings, so check both type
and kind before calling wide character routines. */
if (type == BT_CHARACTER && kind == 4)
read_a_char4 (dtp, f, p, size);
else
read_a (dtp, f, p, size);
break;
case FMT_L:
if (n == 0)
goto need_read_data;
read_l (dtp, f, p, kind);
break;
case FMT_D:
if (n == 0)
goto need_read_data;
if (require_type (dtp, BT_REAL, type, f))
return;
read_f (dtp, f, p, kind);
break;
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;
char dt[] = "DT";
char tmp_iomsg[IOMSG_LEN] = "";
char *child_iomsg;
gfc_charlen_type child_iomsg_len;
int noiostat;
int *child_iostat = NULL;
char *iotype;
gfc_charlen_type iotype_len = f->u.udf.string_len;
/* Build the iotype string. */
if (iotype_len == 0)
{
iotype_len = 2;
iotype = dt;
}
else
iotype = get_dt_format (f->u.udf.string, &iotype_len);
/* Set iostat, intent(out). */
noiostat = 0;
child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
dtp->common.iostat : &noiostat;
/* Set iomsg, intent(inout). */
if (dtp->common.flags & IOPARM_HAS_IOMSG)
{
child_iomsg = dtp->common.iomsg;
child_iomsg_len = dtp->common.iomsg_len;
}
else
{
child_iomsg = tmp_iomsg;
child_iomsg_len = IOMSG_LEN;
}
/* 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->child_dtio--;
if (f->u.udf.string_len != 0)
free (iotype);
/* Note: vlist is freed in free_format_data. */
break;
case FMT_E:
if (n == 0)
goto need_read_data;
if (require_type (dtp, BT_REAL, type, f))
return;
read_f (dtp, f, p, kind);
break;
case FMT_EN:
if (n == 0)
goto need_read_data;
if (require_type (dtp, BT_REAL, type, f))
return;
read_f (dtp, f, p, kind);
break;
case FMT_ES:
if (n == 0)
goto need_read_data;
if (require_type (dtp, BT_REAL, type, f))
return;
read_f (dtp, f, p, kind);
break;
case FMT_F:
if (n == 0)
goto need_read_data;
if (require_type (dtp, BT_REAL, type, f))
return;
read_f (dtp, f, p, kind);
break;
case FMT_G:
if (n == 0)
goto need_read_data;
switch (type)
{
case BT_INTEGER:
read_decimal (dtp, f, p, kind);
break;
case BT_LOGICAL:
read_l (dtp, f, p, kind);
break;
case BT_CHARACTER:
if (kind == 4)
read_a_char4 (dtp, f, p, size);
else
read_a (dtp, f, p, size);
break;
case BT_REAL:
read_f (dtp, f, p, kind);
break;
default:
internal_error (&dtp->common,
"formatted_transfer (): Bad type");
}
break;
case FMT_STRING:
consume_data_flag = 0;
format_error (dtp, f, "Constant string in input format");
return;
/* Format codes that don't transfer data. */
case FMT_X:
case FMT_TR:
consume_data_flag = 0;
dtp->u.p.skips += f->u.n;
pos = bytes_used + dtp->u.p.skips - 1;
dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1;
read_x (dtp, f->u.n);
break;
case FMT_TL:
case FMT_T:
consume_data_flag = 0;
if (f->format == FMT_TL)
{
/* Handle the special case when no bytes have been used yet.
Cannot go below zero. */
if (bytes_used == 0)
{
dtp->u.p.pending_spaces -= f->u.n;
dtp->u.p.skips -= f->u.n;
dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
}
pos = bytes_used - f->u.n;
}
else /* FMT_T */
pos = f->u.n - 1;
/* Standard 10.6.1.1: excessive left tabbing is reset to the
left tab limit. We do not check if the position has gone
beyond the end of record because a subsequent tab could
bring us back again. */
pos = pos < 0 ? 0 : pos;
dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
+ pos - dtp->u.p.max_pos;
dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
? 0 : dtp->u.p.pending_spaces;
if (dtp->u.p.skips == 0)
break;
/* Adjust everything for end-of-record condition */
if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
{
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;
if (dtp->u.p.pending_spaces == 0)
dtp->u.p.sf_seen_eor = 0;
}
if (dtp->u.p.skips < 0)
{
if (is_internal_unit (dtp))
sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
else
fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
}
else
read_x (dtp, dtp->u.p.skips);
break;
case FMT_S:
consume_data_flag = 0;
dtp->u.p.sign_status = SIGN_PROCDEFINED;
break;
case FMT_SS:
consume_data_flag = 0;
dtp->u.p.sign_status = SIGN_SUPPRESS;
break;
case FMT_SP:
consume_data_flag = 0;
dtp->u.p.sign_status = SIGN_PLUS;
break;
case FMT_BN:
consume_data_flag = 0 ;
dtp->u.p.blank_status = BLANK_NULL;
break;
case FMT_BZ:
consume_data_flag = 0;
dtp->u.p.blank_status = BLANK_ZERO;
break;
case FMT_DC:
consume_data_flag = 0;
dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA;
break;
case FMT_DP:
consume_data_flag = 0;
dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
break;
case FMT_RC:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
break;
case FMT_RD:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_DOWN;
break;
case FMT_RN:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_NEAREST;
break;
case FMT_RP:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED;
break;
case FMT_RU:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_UP;
break;
case FMT_RZ:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_ZERO;
break;
case FMT_P:
consume_data_flag = 0;
dtp->u.p.scale_factor = f->u.k;
break;
case FMT_DOLLAR:
consume_data_flag = 0;
dtp->u.p.seen_dollar = 1;
break;
case FMT_SLASH:
consume_data_flag = 0;
dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
next_record (dtp, 0);
break;
case FMT_COLON:
/* A colon descriptor causes us to exit this loop (in
particular preventing another / descriptor from being
processed) unless there is another data item to be
transferred. */
consume_data_flag = 0;
if (n == 0)
return;
break;
default:
internal_error (&dtp->common, "Bad format node");
}
/* Adjust the item count and data pointer. */
if ((consume_data_flag > 0) && (n > 0))
{
n--;
p = ((char *) p) + size;
}
dtp->u.p.skips = 0;
pos = (int)(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;
}
return;
/* Come here when we need a data descriptor but don't have one. We
push the current format node back onto the input, then return and
let the user program call us back with the data. */
need_read_data:
unget_format (dtp, f);
}
static void
formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kind,
size_t size)
{
gfc_offset pos, bytes_used;
const fnode *f;
format_token t;
int n;
int consume_data_flag;
/* Change a complex data item into a pair of reals. */
n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
if (type == BT_COMPLEX)
{
type = BT_REAL;
size /= 2;
}
/* If there's an EOR condition, we simulate finalizing the transfer
by doing nothing. */
if (dtp->u.p.eor_condition)
return;
/* Set this flag so that commas in reads cause the read to complete before
the entire field has been read. The next read field will start right after
the comma in the stream. (Set to 0 for character reads). */
dtp->u.p.sf_read_comma =
dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
for (;;)
{
/* If reversion has occurred and there is another real data item,
then we have to move to the next record. */
if (dtp->u.p.reversion_flag && n > 0)
{
dtp->u.p.reversion_flag = 0;
next_record (dtp, 0);
}
consume_data_flag = 1;
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
break;
f = next_format (dtp);
if (f == NULL)
{
/* No data descriptors left. */
if (unlikely (n > 0))
generate_error (&dtp->common, LIBERROR_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. */
t = f->format;
if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
&& ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
|| t == FMT_Z || t == FMT_F || t == FMT_E
|| t == FMT_EN || t == FMT_ES || t == FMT_G
|| t == FMT_L || t == FMT_A || t == FMT_D
|| t == FMT_DT))
|| t == FMT_STRING))
{
if (dtp->u.p.skips > 0)
{
gfc_offset tmp;
write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
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;
}
if (dtp->u.p.skips < 0)
{
if (is_internal_unit (dtp))
sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
else
fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
}
dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
}
bytes_used = dtp->u.p.current_unit->recl
- dtp->u.p.current_unit->bytes_left;
if (is_stream_io(dtp))
bytes_used = 0;
switch (t)
{
case FMT_I:
if (n == 0)
goto need_data;
if (require_type (dtp, BT_INTEGER, type, f))
return;
write_i (dtp, f, p, kind);
break;
case FMT_B:
if (n == 0)
goto need_data;
if (!(compile_options.allow_std & GFC_STD_GNU)
&& require_numeric_type (dtp, type, f))
return;
if (!(compile_options.allow_std & GFC_STD_F2008)
&& require_type (dtp, BT_INTEGER, type, f))
return;
write_b (dtp, f, p, kind);
break;
case FMT_O:
if (n == 0)
goto need_data;
if (!(compile_options.allow_std & GFC_STD_GNU)
&& require_numeric_type (dtp, type, f))
return;
if (!(compile_options.allow_std & GFC_STD_F2008)
&& require_type (dtp, BT_INTEGER, type, f))
return;
write_o (dtp, f, p, kind);
break;
case FMT_Z:
if (n == 0)
goto need_data;
if (!(compile_options.allow_std & GFC_STD_GNU)
&& require_numeric_type (dtp, type, f))
return;
if (!(compile_options.allow_std & GFC_STD_F2008)
&& require_type (dtp, BT_INTEGER, type, f))
return;
write_z (dtp, f, p, kind);
break;
case FMT_A:
if (n == 0)
goto need_data;
/* It is possible to have FMT_A with something not BT_CHARACTER such
as when writing out hollerith strings, so check both type
and kind before calling wide character routines. */
if (type == BT_CHARACTER && kind == 4)
write_a_char4 (dtp, f, p, size);
else
write_a (dtp, f, p, size);
break;
case FMT_L:
if (n == 0)
goto need_data;
write_l (dtp, f, p, kind);
break;
case FMT_D:
if (n == 0)
goto need_data;
if (require_type (dtp, BT_REAL, type, f))
return;
if (f->u.real.w == 0)
write_real_w0 (dtp, p, kind, f);
else
write_d (dtp, f, p, kind);
break;
case FMT_DT:
if (n == 0)
goto need_data;
int unit = dtp->u.p.current_unit->unit_number;
char dt[] = "DT";
char tmp_iomsg[IOMSG_LEN] = "";
char *child_iomsg;
gfc_charlen_type child_iomsg_len;
int noiostat;
int *child_iostat = NULL;
char *iotype;
gfc_charlen_type iotype_len = f->u.udf.string_len;
/* Build the iotype string. */
if (iotype_len == 0)
{
iotype_len = 2;
iotype = dt;
}
else
iotype = get_dt_format (f->u.udf.string, &iotype_len);
/* Set iostat, intent(out). */
noiostat = 0;
child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
dtp->common.iostat : &noiostat;
/* Set iomsg, intent(inout). */
if (dtp->common.flags & IOPARM_HAS_IOMSG)
{
child_iomsg = dtp->common.iomsg;
child_iomsg_len = dtp->common.iomsg_len;
}
else
{
child_iomsg = tmp_iomsg;
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);
dtp->u.p.current_unit->child_dtio--;
if (f->u.udf.string_len != 0)
free (iotype);
/* Note: vlist is freed in free_format_data. */
break;
case FMT_E:
if (n == 0)
goto need_data;
if (require_type (dtp, BT_REAL, type, f))
return;
if (f->u.real.w == 0)
write_real_w0 (dtp, p, kind, f);
else
write_e (dtp, f, p, kind);
break;
case FMT_EN:
if (n == 0)
goto need_data;
if (require_type (dtp, BT_REAL, type, f))
return;
if (f->u.real.w == 0)
write_real_w0 (dtp, p, kind, f);
else
write_en (dtp, f, p, kind);
break;
case FMT_ES:
if (n == 0)
goto need_data;
if (require_type (dtp, BT_REAL, type, f))
return;
if (f->u.real.w == 0)
write_real_w0 (dtp, p, kind, f);
else
write_es (dtp, f, p, kind);
break;
case FMT_F:
if (n == 0)
goto need_data;
if (require_type (dtp, BT_REAL, type, f))
return;
write_f (dtp, f, p, kind);
break;
case FMT_G:
if (n == 0)
goto need_data;
switch (type)
{
case BT_INTEGER:
write_i (dtp, f, p, kind);
break;
case BT_LOGICAL:
write_l (dtp, f, p, kind);
break;
case BT_CHARACTER:
if (kind == 4)
write_a_char4 (dtp, f, p, size);
else
write_a (dtp, f, p, size);
break;
case BT_REAL:
if (f->u.real.w == 0)
write_real_w0 (dtp, p, kind, f);
else
write_d (dtp, f, p, kind);
break;
default:
internal_error (&dtp->common,
"formatted_transfer (): Bad type");
}
break;
case FMT_STRING:
consume_data_flag = 0;
write_constant_string (dtp, f);
break;
/* Format codes that don't transfer data. */
case FMT_X:
case FMT_TR:
consume_data_flag = 0;
dtp->u.p.skips += f->u.n;
pos = bytes_used + dtp->u.p.skips - 1;
dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1;
/* Writes occur just before the switch on f->format, above, so
that trailing blanks are suppressed, unless we are doing a
non-advancing write in which case we want to output the blanks
now. */
if (dtp->u.p.advance_status == ADVANCE_NO)
{
write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
}
break;
case FMT_TL:
case FMT_T:
consume_data_flag = 0;
if (f->format == FMT_TL)
{
/* Handle the special case when no bytes have been used yet.
Cannot go below zero. */
if (bytes_used == 0)
{
dtp->u.p.pending_spaces -= f->u.n;
dtp->u.p.skips -= f->u.n;
dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
}
pos = bytes_used - f->u.n;
}
else /* FMT_T */
pos = f->u.n - dtp->u.p.pending_spaces - 1;
/* Standard 10.6.1.1: excessive left tabbing is reset to the
left tab limit. We do not check if the position has gone
beyond the end of record because a subsequent tab could
bring us back again. */
pos = pos < 0 ? 0 : pos;
dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
+ pos - dtp->u.p.max_pos;
dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
? 0 : dtp->u.p.pending_spaces;
break;
case FMT_S:
consume_data_flag = 0;
dtp->u.p.sign_status = SIGN_PROCDEFINED;
break;
case FMT_SS:
consume_data_flag = 0;
dtp->u.p.sign_status = SIGN_SUPPRESS;
break;
case FMT_SP:
consume_data_flag = 0;
dtp->u.p.sign_status = SIGN_PLUS;
break;
case FMT_BN:
consume_data_flag = 0 ;
dtp->u.p.blank_status = BLANK_NULL;
break;
case FMT_BZ:
consume_data_flag = 0;
dtp->u.p.blank_status = BLANK_ZERO;
break;
case FMT_DC:
consume_data_flag = 0;
dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA;
break;
case FMT_DP:
consume_data_flag = 0;
dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
break;
case FMT_RC:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
break;
case FMT_RD:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_DOWN;
break;
case FMT_RN:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_NEAREST;
break;
case FMT_RP:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED;
break;
case FMT_RU:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_UP;
break;
case FMT_RZ:
consume_data_flag = 0;
dtp->u.p.current_unit->round_status = ROUND_ZERO;
break;
case FMT_P:
consume_data_flag = 0;
dtp->u.p.scale_factor = f->u.k;
break;
case FMT_DOLLAR:
consume_data_flag = 0;
dtp->u.p.seen_dollar = 1;
break;
case FMT_SLASH:
consume_data_flag = 0;
dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
next_record (dtp, 0);
break;
case FMT_COLON:
/* A colon descriptor causes us to exit this loop (in
particular preventing another / descriptor from being
processed) unless there is another data item to be
transferred. */
consume_data_flag = 0;
if (n == 0)
return;
break;
default:
internal_error (&dtp->common, "Bad format node");
}
/* Adjust the item count and data pointer. */
if ((consume_data_flag > 0) && (n > 0))
{
n--;
p = ((char *) p) + size;
}
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;
}
return;
/* Come here when we need a data descriptor but don't have one. We
push the current format node back onto the input, then return and
let the user program call us back with the data. */
need_data:
unget_format (dtp, f);
}
/* This function is first called from data_init_transfer to initiate the loop
over each item in the format, transferring data as required. Subsequent
calls to this function occur for each data item foound in the READ/WRITE
statement. The item_count is incremented for each call. Since the first
call is from data_transfer_init, the item_count is always one greater than
the actual count number of the item being transferred. */
static void
formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
size_t size, size_t nelems)
{
size_t elem;
char *tmp;
tmp = (char *) p;
size_t stride = type == BT_CHARACTER ?
size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
if (dtp->u.p.mode == READING)
{
/* Big loop over all the elements. */
for (elem = 0; elem < nelems; elem++)
{
dtp->u.p.item_count++;
formatted_transfer_scalar_read (dtp, type, tmp + stride*elem, kind, size);
}
}
else
{
/* Big loop over all the elements. */
for (elem = 0; elem < nelems; elem++)
{
dtp->u.p.item_count++;
formatted_transfer_scalar_write (dtp, type, tmp + stride*elem, kind, size);
}
}
}
/* Wrapper function for I/O of scalar types. If this should be an async I/O
request, queue it. For a synchronous write on an async unit, perform the
wait operation and return an error. For all synchronous writes, call the
right transfer function. */
static void
wrap_scalar_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
size_t size, size_t n_elem)
{
if (dtp->u.p.current_unit && dtp->u.p.current_unit->au)
{
if (dtp->u.p.async)
{
transfer_args args;
args.scalar.transfer = dtp->u.p.transfer;
args.scalar.arg_bt = type;
args.scalar.data = p;
args.scalar.i = kind;
args.scalar.s1 = size;
args.scalar.s2 = n_elem;
enqueue_transfer (dtp->u.p.current_unit->au, &args,
AIO_TRANSFER_SCALAR);
return;
}
}
/* Come here if there was no asynchronous I/O to be scheduled. */
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
dtp->u.p.transfer (dtp, type, p, kind, size, 1);
}
/* Data transfer entry points. The type of the data entity is
implicit in the subroutine call. This prevents us from having to
share a common enum with the compiler. */
void
transfer_integer (st_parameter_dt *dtp, void *p, int kind)
{
wrap_scalar_transfer (dtp, BT_INTEGER, p, kind, kind, 1);
}
void
transfer_integer_write (st_parameter_dt *dtp, void *p, int kind)
{
transfer_integer (dtp, p, kind);
}
void
transfer_real (st_parameter_dt *dtp, void *p, int kind)
{
size_t size;
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
size = size_from_real_kind (kind);
wrap_scalar_transfer (dtp, BT_REAL, p, kind, size, 1);
}
void
transfer_real_write (st_parameter_dt *dtp, void *p, int kind)
{
transfer_real (dtp, p, kind);
}
void
transfer_logical (st_parameter_dt *dtp, void *p, int kind)
{
wrap_scalar_transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
}
void
transfer_logical_write (st_parameter_dt *dtp, void *p, int kind)
{
transfer_logical (dtp, p, kind);
}
void
transfer_character (st_parameter_dt *dtp, void *p, gfc_charlen_type len)
{
static char *empty_string[0];
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
/* Strings of zero length can have p == NULL, which confuses the
transfer routines into thinking we need more data elements. To avoid
this, we give them a nice pointer. */
if (len == 0 && p == NULL)
p = empty_string;
/* Set kind here to 1. */
wrap_scalar_transfer (dtp, BT_CHARACTER, p, 1, len, 1);
}
void
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, gfc_charlen_type len, int kind)
{
static char *empty_string[0];
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
/* Strings of zero length can have p == NULL, which confuses the
transfer routines into thinking we need more data elements. To avoid
this, we give them a nice pointer. */
if (len == 0 && p == NULL)
p = empty_string;
/* Here we pass the actual kind value. */
wrap_scalar_transfer (dtp, BT_CHARACTER, p, kind, len, 1);
}
void
transfer_character_wide_write (st_parameter_dt *dtp, void *p, gfc_charlen_type len, int kind)
{
transfer_character_wide (dtp, p, len, kind);
}
void
transfer_complex (st_parameter_dt *dtp, void *p, int kind)
{
size_t size;
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
size = size_from_complex_kind (kind);
wrap_scalar_transfer (dtp, BT_COMPLEX, p, kind, size, 1);
}
void
transfer_complex_write (st_parameter_dt *dtp, void *p, int kind)
{
transfer_complex (dtp, p, kind);
}
void
transfer_array_inner (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
gfc_charlen_type charlen)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type stride[GFC_MAX_DIMENSIONS];
index_type stride0, rank, size, n;
size_t tsize;
char *data;
bt iotype;
/* Adjust item_count before emitting error message. */
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
iotype = (bt) GFC_DESCRIPTOR_TYPE (desc);
size = iotype == BT_CHARACTER ? charlen : GFC_DESCRIPTOR_SIZE (desc);
rank = GFC_DESCRIPTOR_RANK (desc);
for (n = 0; n < rank; n++)
{
count[n] = 0;
stride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(desc,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(desc,n);
/* If the extent of even one dimension is zero, then the entire
array section contains zero elements, so we return after writing
a zero array record. */
if (extent[n] <= 0)
{
data = NULL;
tsize = 0;
dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
return;
}
}
stride0 = stride[0];
/* If the innermost dimension has a stride of 1, we can do the transfer
in contiguous chunks. */
if (stride0 == size)
tsize = extent[0];
else
tsize = 1;
data = GFC_DESCRIPTOR_DATA (desc);
/* When reading, we need to check endfile conditions so we do not miss
an END=label. Make this separate so we do not have an extra test
in a tight loop when it is not needed. */
if (dtp->u.p.current_unit && dtp->u.p.mode == READING)
{
while (data)
{
if (unlikely (dtp->u.p.current_unit->endfile == AFTER_ENDFILE))
return;
dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
data += stride0 * tsize;
count[0] += tsize;
n = 0;
while (count[n] == extent[n])
{
count[n] = 0;
data -= stride[n] * extent[n];
n++;
if (n == rank)
{
data = NULL;
break;
}
else
{
count[n]++;
data += stride[n];
}
}
}
}
else
{
while (data)
{
dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
data += stride0 * tsize;
count[0] += tsize;
n = 0;
while (count[n] == extent[n])
{
count[n] = 0;
data -= stride[n] * extent[n];
n++;
if (n == rank)
{
data = NULL;
break;
}
else
{
count[n]++;
data += stride[n];
}
}
}
}
}
void
transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
gfc_charlen_type charlen)
{
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
if (dtp->u.p.current_unit && dtp->u.p.current_unit->au)
{
if (dtp->u.p.async)
{
transfer_args args;
size_t sz = sizeof (gfc_array_char)
+ sizeof (descriptor_dimension)
* GFC_DESCRIPTOR_RANK (desc);
args.array.desc = xmalloc (sz);
NOTE ("desc = %p", (void *) args.array.desc);
memcpy (args.array.desc, desc, sz);
args.array.kind = kind;
args.array.charlen = charlen;
enqueue_transfer (dtp->u.p.current_unit->au, &args,
AIO_TRANSFER_ARRAY);
return;
}
}
/* Come here if there was no asynchronous I/O to be scheduled. */
transfer_array_inner (dtp, desc, kind, charlen);
}
void
transfer_array_write (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
gfc_charlen_type charlen)
{
transfer_array (dtp, desc, kind, charlen);
}
/* User defined input/output iomsg. */
#define IOMSG_LEN 256
void
transfer_derived (st_parameter_dt *parent, void *dtio_source, void *dtio_proc)
{
if (parent->u.p.current_unit)
{
if (parent->u.p.current_unit->flags.form == FORM_UNFORMATTED)
parent->u.p.ufdtio_ptr = (unformatted_dtio) dtio_proc;
else
parent->u.p.fdtio_ptr = (formatted_dtio) dtio_proc;
}
wrap_scalar_transfer (parent, BT_CLASS, dtio_source, 0, 0, 1);
}
/* Preposition a sequential unformatted file while reading. */
static void
us_read (st_parameter_dt *dtp, int continued)
{
ssize_t n, nr;
GFC_INTEGER_4 i4;
GFC_INTEGER_8 i8;
gfc_offset i;
if (compile_options.record_marker == 0)
n = sizeof (GFC_INTEGER_4);
else
n = compile_options.record_marker;
nr = sread (dtp->u.p.current_unit->s, &i, n);
if (unlikely (nr < 0))
{
generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
return;
}
else if (nr == 0)
{
hit_eof (dtp);
return; /* end of file */
}
else if (unlikely (n != nr))
{
generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
return;
}
/* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE))
{
switch (nr)
{
case sizeof(GFC_INTEGER_4):
memcpy (&i4, &i, sizeof (i4));
i = i4;
break;
case sizeof(GFC_INTEGER_8):
memcpy (&i8, &i, sizeof (i8));
i = i8;
break;
default:
runtime_error ("Illegal value for record marker");
break;
}
}
else
{
uint32_t u32;
uint64_t u64;
switch (nr)
{
case sizeof(GFC_INTEGER_4):
memcpy (&u32, &i, sizeof (u32));
u32 = __builtin_bswap32 (u32);
memcpy (&i4, &u32, sizeof (i4));
i = i4;
break;
case sizeof(GFC_INTEGER_8):
memcpy (&u64, &i, sizeof (u64));
u64 = __builtin_bswap64 (u64);
memcpy (&i8, &u64, sizeof (i8));
i = i8;
break;
default:
runtime_error ("Illegal value for record marker");
break;
}
}
if (i >= 0)
{
dtp->u.p.current_unit->bytes_left_subrecord = i;
dtp->u.p.current_unit->continued = 0;
}
else
{
dtp->u.p.current_unit->bytes_left_subrecord = -i;
dtp->u.p.current_unit->continued = 1;
}
if (! continued)
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
}
/* Preposition a sequential unformatted file while writing. This
amount to writing a bogus length that will be filled in later. */
static void
us_write (st_parameter_dt *dtp, int continued)
{
ssize_t nbytes;
gfc_offset dummy;
dummy = 0;
if (compile_options.record_marker == 0)
nbytes = sizeof (GFC_INTEGER_4);
else
nbytes = compile_options.record_marker ;
if (swrite (dtp->u.p.current_unit->s, &dummy, nbytes) != nbytes)
generate_error (&dtp->common, LIBERROR_OS, NULL);
/* For sequential unformatted, if RECL= was not specified in the OPEN
we write until we have more bytes than can fit in the subrecord
markers, then we write a new subrecord. */
dtp->u.p.current_unit->bytes_left_subrecord =
dtp->u.p.current_unit->recl_subrecord;
dtp->u.p.current_unit->continued = continued;
}
/* Position to the next record prior to transfer. We are assumed to
be before the next record. We also calculate the bytes in the next
record. */
static void
pre_position (st_parameter_dt *dtp)
{
if (dtp->u.p.current_unit->current_record)
return; /* Already positioned. */
switch (current_mode (dtp))
{
case FORMATTED_STREAM:
case UNFORMATTED_STREAM:
/* There are no records with stream I/O. If the position was specified
data_transfer_init has already positioned the file. If no position
was specified, we continue from where we last left off. I.e.
there is nothing to do here. */
break;
case UNFORMATTED_SEQUENTIAL:
if (dtp->u.p.mode == READING)
us_read (dtp, 0);
else
us_write (dtp, 0);
break;
case FORMATTED_SEQUENTIAL:
case FORMATTED_DIRECT:
case UNFORMATTED_DIRECT:
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
break;
case FORMATTED_UNSPECIFIED:
gcc_unreachable ();
}
dtp->u.p.current_unit->current_record = 1;
}
/* Initialize things for a data transfer. This code is common for
both reading and writing. */
static void
data_transfer_init (st_parameter_dt *dtp, int read_flag)
{
unit_flags u_flags; /* Used for creating a unit if needed. */
GFC_INTEGER_4 cf = dtp->common.flags;
namelist_info *ionml;
async_unit *au;
NOTE ("data_transfer_init");
ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
memset (&dtp->u.p, 0, sizeof (dtp->u.p));
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;
dtp->u.p.current_unit = get_unit (dtp, 1);
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;
NOTE ("Open the unit with some default flags.");
memset (&u_flags, '\0', sizeof (u_flags));
u_flags.access = ACCESS_SEQUENTIAL;
u_flags.action = ACTION_READWRITE;
/* Is it unformatted? */
if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
| IOPARM_DT_IONML_SET)))
u_flags.form = FORM_UNFORMATTED;
else
u_flags.form = FORM_UNSPECIFIED;
u_flags.delim = DELIM_UNSPECIFIED;
u_flags.blank = BLANK_UNSPECIFIED;
u_flags.pad = PAD_UNSPECIFIED;
u_flags.decimal = DECIMAL_UNSPECIFIED;
u_flags.encoding = ENCODING_UNSPECIFIED;
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;
conv = get_unformatted_convert (dtp->common.unit);
if (conv == GFC_CONVERT_NONE)
conv = compile_options.convert;
switch (conv)
{
case GFC_CONVERT_NATIVE:
case GFC_CONVERT_SWAP:
break;
case GFC_CONVERT_BIG:
conv = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
break;
case GFC_CONVERT_LITTLE:
conv = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? GFC_CONVERT_SWAP : GFC_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);
dtp->common.flags &= ~IOPARM_COMMON_MASK;
dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
if (dtp->u.p.current_unit == NULL)
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;
if ((cf & IOPARM_DT_HAS_ASYNCHRONOUS) != 0)
{
int f;
f = find_option (&dtp->common, dtp->asynchronous, dtp->asynchronous_len,
async_opt, "Bad ASYNCHRONOUS in data transfer "
"statement");
if (f == ASYNC_YES && dtp->u.p.current_unit->flags.async != ASYNC_YES)
{
generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"ASYNCHRONOUS transfer without "
"ASYHCRONOUS='YES' in OPEN");
return;
}
dtp->u.p.async = f == ASYNC_YES;
}
au = dtp->u.p.current_unit->au;
if (au)
{
if (dtp->u.p.async)
{
/* If this is an asynchronous I/O statement, collect errors and
return if there are any. */
if (collect_async_errors (&dtp->common, au))
return;
}
else
{
/* Synchronous statement: Perform a wait operation for any pending
asynchronous I/O. This needs to be done before all other error
checks. See F2008, 9.6.4.1. */
if (async_wait (&(dtp->common), au))
return;
}
}
/* Check the action. */
if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
{
generate_error (&dtp->common, LIBERROR_BAD_ACTION,
"Cannot read from file opened for WRITE");
return;
}
if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ)
{
generate_error (&dtp->common, LIBERROR_BAD_ACTION,
"Cannot write to file opened for READ");
return;
}
dtp->u.p.first_item = 1;
/* Check the format. */
if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
parse_format (dtp);
if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
&& (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
!= 0)
{
generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"Format present for UNFORMATTED data transfer");
return;
}
if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
{
if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
{
generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"A format cannot be specified with a namelist");
return;
}
}
else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
{
generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"Missing format for FORMATTED data transfer");
return;
}
if (is_internal_unit (dtp)
&& dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
{
generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"Internal file cannot be accessed by UNFORMATTED "
"data transfer");
return;
}
/* Check the record or position number. */
if (dtp->u.p.current_unit->flags