#include "config.h"
#include <string.h>
#include <assert.h>
#include "libgfortran.h"
#include "io.h"
extern void transfer_integer (st_parameter_dt *, void *, int);
export_proto(transfer_integer);
extern void transfer_real (st_parameter_dt *, void *, int);
export_proto(transfer_real);
extern void transfer_logical (st_parameter_dt *, void *, int);
export_proto(transfer_logical);
extern void transfer_character (st_parameter_dt *, void *, int);
export_proto(transfer_character);
extern void transfer_complex (st_parameter_dt *, void *, int);
export_proto(transfer_complex);
extern void transfer_array (st_parameter_dt *, gfc_array_char *, int,
gfc_charlen_type);
export_proto(transfer_array);
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}
};
typedef enum
{ FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
}
file_mode;
static file_mode
current_mode (st_parameter_dt *dtp)
{
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 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;
}
char *
read_sf (st_parameter_dt *dtp, int *length, int no_error)
{
char *base, *p, *q;
int n, readlen, crlf;
gfc_offset pos;
if (*length > SCRATCH_SIZE)
dtp->u.p.line_buffer = get_mem (*length);
p = base = dtp->u.p.line_buffer;
if (dtp->u.p.sf_seen_eor)
{
*length = 0;
return base;
}
readlen = 1;
n = 0;
do
{
if (is_internal_unit (dtp))
{
readlen = 1;
}
q = salloc_r (dtp->u.p.current_unit->s, &readlen);
if (q == NULL)
break;
if (readlen < 1 && n == 0)
{
if (no_error)
break;
generate_error (&dtp->common, ERROR_END, NULL);
return NULL;
}
if (readlen < 1 || *q == '\n' || *q == '\r')
{
if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
dtp->u.p.eor_condition = 1;
crlf = 0;
if (*q == '\r')
{
readlen = 1;
pos = stream_offset (dtp->u.p.current_unit->s);
q = salloc_r (dtp->u.p.current_unit->s, &readlen);
if (*q != '\n' && readlen == 1)
sseek (dtp->u.p.current_unit->s, pos);
else
crlf = 1;
}
if (dtp->u.p.current_unit->flags.pad == PAD_NO)
{
if (no_error)
break;
generate_error (&dtp->common, ERROR_EOR, NULL);
return NULL;
}
*length = n;
dtp->u.p.sf_seen_eor = (crlf ? 2 : 1);
break;
}
if (*q == ',')
if (dtp->u.p.sf_read_comma == 1)
{
notify_std (&dtp->common, GFC_STD_GNU,
"Comma in formatted numeric read.");
*length = n;
break;
}
n++;
*p++ = *q;
dtp->u.p.sf_seen_eor = 0;
}
while (n < *length);
dtp->u.p.current_unit->bytes_left -= *length;
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
dtp->u.p.size_used += (gfc_offset) *length;
return base;
}
void *
read_block (st_parameter_dt *dtp, int *length)
{
char *source;
int nread;
if (is_stream_io (dtp))
{
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;
}
}
else
{
if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *length)
{
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)
{
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;
}
}
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))
{
source = read_sf (dtp, length, 0);
dtp->u.p.current_unit->strm_pos +=
(gfc_offset) (*length + dtp->u.p.sf_seen_eor);
return source;
}
dtp->u.p.current_unit->bytes_left -= (gfc_offset) *length;
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)
{
if (dtp->u.p.current_unit->flags.pad == PAD_YES)
*length = nread;
else
{
generate_error (&dtp->common, ERROR_EOR, NULL);
source = NULL;
}
}
dtp->u.p.current_unit->strm_pos += (gfc_offset) nread;
return source;
}
static void
read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
{
size_t to_read_record;
size_t have_read_record;
size_t to_read_subrecord;
size_t have_read_subrecord;
int short_record;
if (is_stream_io (dtp))
{
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;
}
to_read_record = *nbytes;
have_read_record = to_read_record;
if (sread (dtp->u.p.current_unit->s, buf, &have_read_record) != 0)
{
generate_error (&dtp->common, ERROR_OS, NULL);
return;
}
dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record;
if (to_read_record != have_read_record)
{
generate_error (&dtp->common, ERROR_END, NULL);
return;
}
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 = (size_t) 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;
if (sread (dtp->u.p.current_unit->s, buf, &to_read_record) != 0)
{
generate_error (&dtp->common, ERROR_OS, NULL);
return;
}
if (to_read_record != *nbytes)
{
*nbytes = to_read_record;
return;
}
if (short_record)
{
generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
return;
}
return;
}
if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
{
generate_error (&dtp->common, ERROR_END, NULL);
return;
}
if (dtp->u.p.current_unit->flags.has_recl
&& (*nbytes > (size_t) dtp->u.p.current_unit->bytes_left))
{
to_read_record = (size_t) 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 = (size_t) 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 = to_read_subrecord;
if (sread (dtp->u.p.current_unit->s, buf + have_read_record,
&have_read_subrecord) != 0)
{
generate_error (&dtp->common, ERROR_OS, NULL);
return;
}
have_read_record += have_read_subrecord;
if (to_read_subrecord != have_read_subrecord)
{
*nbytes = have_read_record;
generate_error (&dtp->common, ERROR_CORRUPT_FILE, NULL);
return;
}
if (to_read_record > 0)
{
if (dtp->u.p.current_unit->continued)
{
next_record_r_unf (dtp, 0);
us_read (dtp, 1);
}
else
{
dtp->u.p.current_unit->current_record = 0;
next_record_r_unf (dtp, 0);
generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
return;
}
}
else
{
break;
}
}
dtp->u.p.current_unit->bytes_left -= have_read_record;
if (short_record)
{
generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
return;
}
return;
}
void *
write_block (st_parameter_dt *dtp, int length)
{
char *dest;
if (is_stream_io (dtp))
{
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;
}
}
else
{
if (dtp->u.p.current_unit->bytes_left < (gfc_offset) length)
{
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;
}
dest = salloc_w (dtp->u.p.current_unit->s, &length);
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;
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)
{
size_t have_written, to_write_subrecord;
int short_record;
if (is_stream_io (dtp))
{
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)
{
generate_error (&dtp->common, ERROR_OS, NULL);
return FAILURE;
}
dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
return SUCCESS;
}
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{
if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)
{
generate_error (&dtp->common, ERROR_DIRECT_EOR, NULL);
return FAILURE;
}
if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
{
generate_error (&dtp->common, ERROR_OS, NULL);
return FAILURE;
}
dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
return SUCCESS;
}
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;
if (swrite (dtp->u.p.current_unit->s, buf + have_written,
&to_write_subrecord) != 0)
{
generate_error (&dtp->common, ERROR_OS, NULL);
return FAILURE;
}
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 (short_record)
{
generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
return FAILURE;
}
return SUCCESS;
}
static void
unformatted_read (st_parameter_dt *dtp, bt type,
void *dest, int kind,
size_t size, size_t nelems)
{
size_t i, sz;
if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE
|| size == 1 || type == BT_CHARACTER)
{
sz = size * nelems;
read_block_direct (dtp, dest, &sz);
}
else
{
char buffer[16];
char *p;
if (type == BT_COMPLEX)
{
nelems *= 2;
size /= 2;
}
p = dest;
if (type == BT_REAL || type == BT_COMPLEX)
sz = size_from_real_kind (kind);
else
sz = kind;
for (i=0; i<nelems; i++)
{
read_block_direct (dtp, buffer, &sz);
reverse_memcpy (p, buffer, sz);
p += size;
}
}
}
static void
unformatted_write (st_parameter_dt *dtp, bt type,
void *source, int kind,
size_t size, size_t nelems)
{
if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE ||
size == 1 || type == BT_CHARACTER)
{
size *= nelems;
write_buf (dtp, source, size);
}
else
{
char buffer[16];
char *p;
size_t i, sz;
if (type == BT_COMPLEX)
{
nelems *= 2;
size /= 2;
}
p = source;
if (type == BT_REAL || type == BT_COMPLEX)
sz = size_from_real_kind (kind);
else
sz = kind;
for (i=0; i<nelems; i++)
{
reverse_memcpy(buffer, p, size);
p+= size;
write_buf (dtp, buffer, sz);
}
}
}
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;
default:
internal_error (NULL, "type_name(): Bad type");
}
return p;
}
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++;
}
}
static int
require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
{
char buffer[100];
if (actual == expected)
return 0;
st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
type_name (expected), dtp->u.p.item_count, type_name (actual));
format_error (dtp, f, buffer);
return 1;
}
static void
formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
size_t size)
{
char scratch[SCRATCH_SIZE];
int pos, bytes_used;
const fnode *f;
format_token t;
int n;
int consume_data_flag;
n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
if (type == BT_COMPLEX)
{
type = BT_REAL;
size /= 2;
}
if (dtp->u.p.eor_condition)
return;
dtp->u.p.sf_read_comma = 1;
dtp->u.p.line_buffer = scratch;
for (;;)
{
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)
{
if (n > 0)
generate_error (&dtp->common, ERROR_FORMAT,
"Insufficient data descriptors in format after reversion");
return;
}
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_STRING))
{
if (dtp->u.p.skips > 0)
{
write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
dtp->u.p.max_pos = (int)(dtp->u.p.current_unit->recl
- dtp->u.p.current_unit->bytes_left);
}
if (dtp->u.p.skips < 0)
{
move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
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 = (int)(dtp->u.p.current_unit->recl
- dtp->u.p.current_unit->bytes_left);
switch (t)
{
case FMT_I:
if (n == 0)
goto need_data;
if (require_type (dtp, BT_INTEGER, type, f))
return;
if (dtp->u.p.mode == READING)
read_decimal (dtp, f, p, len);
else
write_i (dtp, f, p, len);
break;
case FMT_B:
if (n == 0)
goto need_data;
if (require_type (dtp, BT_INTEGER, type, f))
return;
if (dtp->u.p.mode == READING)
read_radix (dtp, f, p, len, 2);
else
write_b (dtp, f, p, len);
break;
case FMT_O:
if (n == 0)
goto need_data;
if (dtp->u.p.mode == READING)
read_radix (dtp, f, p, len, 8);
else
write_o (dtp, f, p, len);
break;
case FMT_Z:
if (n == 0)
goto need_data;
if (dtp->u.p.mode == READING)
read_radix (dtp, f, p, len, 16);
else
write_z (dtp, f, p, len);
break;
case FMT_A:
if (n == 0)
goto need_data;
if (dtp->u.p.mode == READING)
read_a (dtp, f, p, len);
else
write_a (dtp, f, p, len);
break;
case FMT_L:
if (n == 0)
goto need_data;
if (dtp->u.p.mode == READING)
read_l (dtp, f, p, len);
else
write_l (dtp, f, p, len);
break;
case FMT_D:
if (n == 0)
goto need_data;
if (require_type (dtp, BT_REAL, type, f))
return;
if (dtp->u.p.mode == READING)
read_f (dtp, f, p, len);
else
write_d (dtp, f, p, len);
break;
case FMT_E:
if (n == 0)
goto need_data;
if (require_type (dtp, BT_REAL, type, f))
return;
if (dtp->u.p.mode == READING)
read_f (dtp, f, p, len);
else
write_e (dtp, f, p, len);
break;
case FMT_EN:
if (n == 0)
goto need_data;
if (require_type (dtp, BT_REAL, type, f))
return;
if (dtp->u.p.mode == READING)
read_f (dtp, f, p, len);
else
write_en (dtp, f, p, len);
break;
case FMT_ES:
if (n == 0)
goto need_data;
if (require_type (dtp, BT_REAL, type, f))
return;
if (dtp->u.p.mode == READING)
read_f (dtp, f, p, len);
else
write_es (dtp, f, p, len);
break;
case FMT_F:
if (n == 0)
goto need_data;
if (require_type (dtp, BT_REAL, type, f))
return;
if (dtp->u.p.mode == READING)
read_f (dtp, f, p, len);
else
write_f (dtp, f, p, len);
break;
case FMT_G:
if (n == 0)
goto need_data;
if (dtp->u.p.mode == READING)
switch (type)
{
case BT_INTEGER:
read_decimal (dtp, f, p, len);
break;
case BT_LOGICAL:
read_l (dtp, f, p, len);
break;
case BT_CHARACTER:
read_a (dtp, f, p, len);
break;
case BT_REAL:
read_f (dtp, f, p, len);
break;
default:
goto bad_type;
}
else
switch (type)
{
case BT_INTEGER:
write_i (dtp, f, p, len);
break;
case BT_LOGICAL:
write_l (dtp, f, p, len);
break;
case BT_CHARACTER:
write_a (dtp, f, p, len);
break;
case BT_REAL:
write_d (dtp, f, p, len);
break;
default:
bad_type:
internal_error (&dtp->common,
"formatted_transfer(): Bad type");
}
break;
case FMT_STRING:
consume_data_flag = 0 ;
if (dtp->u.p.mode == READING)
{
format_error (dtp, f, "Constant string in input format");
return;
}
write_constant_string (dtp, f);
break;
case FMT_X:
case FMT_TR:
consume_data_flag = 0;
pos = bytes_used + f->u.n + dtp->u.p.skips;
dtp->u.p.skips = f->u.n + dtp->u.p.skips;
dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos;
if (dtp->u.p.mode == WRITING
&& 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;
}
if (dtp->u.p.mode == READING)
read_x (dtp, f->u.n);
break;
case FMT_TL:
case FMT_T:
consume_data_flag = 0;
if (f->format == FMT_TL)
{
if (bytes_used == 0)
{
dtp->u.p.pending_spaces -= f->u.n;
dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0 ? 0
: dtp->u.p.pending_spaces;
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
{
if (dtp->u.p.mode == READING)
pos = f->u.n - 1;
else
pos = f->u.n - dtp->u.p.pending_spaces - 1;
}
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;
if (dtp->u.p.skips == 0)
break;
if (dtp->u.p.mode == READING)
{
if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
{
if (dtp->u.p.sf_seen_eor == 2)
{
dtp->u.p.current_unit->bytes_left -= 2;
dtp->u.p.skips -= 2;
}
else
{
dtp->u.p.current_unit->bytes_left--;
dtp->u.p.skips--;
}
bytes_used = pos;
dtp->u.p.sf_seen_eor = 0;
}
if (dtp->u.p.skips < 0)
{
move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
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_S;
break;
case FMT_SS:
consume_data_flag = 0 ;
dtp->u.p.sign_status = SIGN_SS;
break;
case FMT_SP:
consume_data_flag = 0 ;
dtp->u.p.sign_status = SIGN_SP;
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_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:
consume_data_flag = 0 ;
if (n == 0)
return;
break;
default:
internal_error (&dtp->common, "Bad format node");
}
if (dtp->u.p.line_buffer != scratch)
{
free_mem (dtp->u.p.line_buffer);
dtp->u.p.line_buffer = scratch;
}
if ((consume_data_flag > 0) && (n > 0))
{
n--;
p = ((char *) p) + size;
}
if (dtp->u.p.mode == READING)
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;
need_data:
unget_format (dtp, f);
}
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;
for (elem = 0; elem < nelems; elem++)
{
dtp->u.p.item_count++;
formatted_transfer_scalar (dtp, type, tmp + size*elem, kind, size);
}
}
void
transfer_integer (st_parameter_dt *dtp, void *p, int kind)
{
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
}
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);
dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
}
void
transfer_logical (st_parameter_dt *dtp, void *p, int kind)
{
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
}
void
transfer_character (st_parameter_dt *dtp, void *p, int len)
{
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
dtp->u.p.transfer (dtp, BT_CHARACTER, p, len, len, 1);
}
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);
dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
}
void
transfer_array (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, type, n;
size_t tsize;
char *data;
bt iotype;
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
type = GFC_DESCRIPTOR_TYPE (desc);
size = GFC_DESCRIPTOR_SIZE (desc);
switch (type)
{
case GFC_DTYPE_UNKNOWN:
iotype = BT_NULL;
break;
case GFC_DTYPE_INTEGER:
iotype = BT_INTEGER;
break;
case GFC_DTYPE_LOGICAL:
iotype = BT_LOGICAL;
break;
case GFC_DTYPE_REAL:
iotype = BT_REAL;
break;
case GFC_DTYPE_COMPLEX:
iotype = BT_COMPLEX;
break;
case GFC_DTYPE_CHARACTER:
iotype = BT_CHARACTER;
size = charlen;
kind = charlen;
break;
case GFC_DTYPE_DERIVED:
internal_error (&dtp->common,
"Derived type I/O should have been handled via the frontend.");
break;
default:
internal_error (&dtp->common, "transfer_array(): Bad type");
}
rank = GFC_DESCRIPTOR_RANK (desc);
for (n = 0; n < rank; n++)
{
count[n] = 0;
stride[n] = desc->dim[n].stride;
extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound;
if (extent[n] <= 0)
return;
}
stride0 = stride[0];
if (stride0 == 1)
tsize = extent[0];
else
tsize = 1;
data = GFC_DESCRIPTOR_DATA (desc);
while (data)
{
dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
data += stride0 * size * tsize;
count[0] += tsize;
n = 0;
while (count[n] == extent[n])
{
count[n] = 0;
data -= stride[n] * extent[n] * size;
n++;
if (n == rank)
{
data = NULL;
break;
}
else
{
count[n]++;
data += stride[n] * size;
}
}
}
}
static void
us_read (st_parameter_dt *dtp, int continued)
{
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;
if (compile_options.record_marker == 0)
n = sizeof (GFC_INTEGER_4);
else
n = compile_options.record_marker;
nr = n;
p = salloc_r (dtp->u.p.current_unit->s, &n);
if (n == 0)
{
dtp->u.p.current_unit->endfile = AT_ENDFILE;
return;
}
if (p == NULL || n != nr)
{
generate_error (&dtp->common, ERROR_BAD_US, NULL);
return;
}
if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
{
switch (nr)
{
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
switch (nr)
{
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;
}
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;
}
static void
us_write (st_parameter_dt *dtp, int continued)
{
size_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) != 0)
generate_error (&dtp->common, ERROR_OS, NULL);
dtp->u.p.current_unit->bytes_left_subrecord =
dtp->u.p.current_unit->recl_subrecord;
dtp->u.p.current_unit->continued = continued;
}
static void
pre_position (st_parameter_dt *dtp)
{
if (dtp->u.p.current_unit->current_record)
return;
switch (current_mode (dtp))
{
case FORMATTED_STREAM:
case UNFORMATTED_STREAM:
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, 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;
}
dtp->u.p.current_unit->current_record = 1;
}
static void
data_transfer_init (st_parameter_dt *dtp, int read_flag)
{
unit_flags u_flags;
GFC_INTEGER_4 cf = dtp->common.flags;
namelist_info *ionml;
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;
if ((cf & IOPARM_DT_HAS_SIZE) != 0)
dtp->u.p.size_used = 0;
dtp->u.p.current_unit = get_unit (dtp, 1);
if (dtp->u.p.current_unit->s == NULL)
{
st_parameter_open opp;
unit_convert conv;
if (dtp->common.unit < 0)
{
close_unit (dtp->u.p.current_unit);
dtp->u.p.current_unit = NULL;
generate_error (&dtp->common, ERROR_BAD_OPTION,
"Bad unit number in OPEN statement");
return;
}
memset (&u_flags, '\0', sizeof (u_flags));
u_flags.access = ACCESS_SEQUENTIAL;
u_flags.action = ACTION_READWRITE;
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.status = STATUS_UNKNOWN;
conv = get_unformatted_convert (dtp->common.unit);
if (conv == CONVERT_NONE)
conv = compile_options.convert;
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);
dtp->common.flags &= ~IOPARM_COMMON_MASK;
dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
if (dtp->u.p.current_unit == NULL)
return;
}
if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
{
generate_error (&dtp->common, ERROR_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, ERROR_BAD_ACTION,
"Cannot write to file opened for READ");
return;
}
dtp->u.p.first_item = 1;
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, ERROR_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, ERROR_OPTION_CONFLICT,
"A format cannot be specified with a namelist");
}
else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
{
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");
return;
}
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
&& (cf & IOPARM_DT_HAS_REC) == 0)
{
generate_error (&dtp->common, ERROR_MISSING_OPTION,
"Direct access data transfer requires record number");
return;
}
if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
&& (cf & IOPARM_DT_HAS_REC) != 0)
{
generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"Record number not allowed for sequential access data transfer");
return;
}
dtp->u.p.advance_status
= !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED :
find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt,
"Bad ADVANCE parameter in data transfer statement");
if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED)
{
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{
generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"ADVANCE specification conflicts with sequential access");
return;
}
if (is_internal_unit (dtp))
{
generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"ADVANCE specification conflicts with internal file");
return;
}
if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
!= IOPARM_DT_HAS_FORMAT)
{
generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"ADVANCE specification requires an explicit format");
return;
}
}
if (read_flag)
{
if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
{
generate_error (&dtp->common, ERROR_MISSING_OPTION,
"EOR specification requires an ADVANCE specification "
"of NO");
return;
}
if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
{
generate_error (&dtp->common, ERROR_MISSING_OPTION,
"SIZE specification requires an ADVANCE specification of NO");
return;
}
}
else
{
if ((cf & IOPARM_END) != 0)
{
generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"END specification cannot appear in a write statement");
return;
}
if ((cf & IOPARM_EOR) != 0)
{
generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"EOR specification cannot appear in a write statement");
return;
}
if ((cf & IOPARM_DT_HAS_SIZE) != 0)
{
generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
"SIZE specification cannot appear in a write statement");
return;
}
}
if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
dtp->u.p.advance_status = ADVANCE_YES;
if ((cf & IOPARM_DT_HAS_REC) != 0)
{
if (dtp->rec <= 0)
{
generate_error (&dtp->common, ERROR_BAD_OPTION,
"Record number must be positive");
return;
}
if (dtp->rec >= dtp->u.p.current_unit->maxrec)
{
generate_error (&dtp->common, ERROR_BAD_OPTION,
"Record number too large");
return;
}
if (dtp->u.p.mode == READING
&& dtp->u.p.current_unit->mode == WRITING
&& !is_internal_unit (dtp))
flush(dtp->u.p.current_unit->s);
if (dtp->u.p.mode == READING && (dtp->rec -1)
* dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s))
{
generate_error (&dtp->common, ERROR_BAD_OPTION,
"Non-existing record number");
return;
}
if (!is_stream_io (dtp))
{
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;
}
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))
struncate(dtp->u.p.current_unit->s);
flush_if_preconnected(dtp->u.p.current_unit->s);
dtp->u.p.current_unit->mode = dtp->u.p.mode;
dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
dtp->u.p.sign_status = SIGN_S;
pre_position (dtp);
if (read_flag)
{
if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
dtp->u.p.transfer = unformatted_read;
else
{
if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
dtp->u.p.transfer = list_formatted_read;
else
dtp->u.p.transfer = formatted_transfer;
}
}
else
{
if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
dtp->u.p.transfer = unformatted_write;
else
{
if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
dtp->u.p.transfer = list_formatted_write;
else
dtp->u.p.transfer = formatted_transfer;
}
}
if (read_flag)
{
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");
return;
}
}
else
{
if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar)
dtp->u.p.current_unit->read_bad = 1;
}
if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
&& ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0)
&& dtp->u.p.ionml == NULL)
formatted_transfer (dtp, 0, NULL, 0, 0, 1);
}
gfc_offset
init_loop_spec (gfc_array_char *desc, array_loop_spec *ls)
{
int rank = GFC_DESCRIPTOR_RANK(desc);
int i;
gfc_offset index;
index = 1;
for (i=0; i<rank; i++)
{
ls[i].idx = desc->dim[i].lbound;
ls[i].start = desc->dim[i].lbound;
ls[i].end = desc->dim[i].ubound;
ls[i].step = desc->dim[i].stride;
index += (desc->dim[i].ubound - desc->dim[i].lbound)
* desc->dim[i].stride;
}
return index;
}
gfc_offset
next_array_record (st_parameter_dt *dtp, array_loop_spec *ls)
{
int i, carry;
gfc_offset index;
carry = 1;
index = 0;
for (i = 0; i < dtp->u.p.current_unit->rank; i++)
{
if (carry)
{
ls[i].idx++;
if (ls[i].idx > ls[i].end)
{
ls[i].idx = ls[i].start;
carry = 1;
}
else
carry = 0;
}
index = index + (ls[i].idx - ls[i].start) * ls[i].step;
}
return index;
}
#define MAX_READ 4096
static void
skip_record (st_parameter_dt *dtp, size_t bytes)
{
gfc_offset new;
int rlength, length;
char *p;
dtp->u.p.current_unit->bytes_left_subrecord += bytes;
if (dtp->u.p.current_unit->bytes_left_subrecord == 0)
return;
if (is_seekable (dtp->u.p.current_unit->s))
{
new = file_position (dtp->u.p.current_unit->s)
+ dtp->u.p.current_unit->bytes_left_subrecord;
if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
generate_error (&dtp->common, ERROR_OS, NULL);
}
else
{
while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
{
rlength = length =
(MAX_READ > dtp->u.p.current_unit->bytes_left_subrecord) ?
MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord;
p = salloc_r (dtp->u.p.current_unit->s, &rlength);
if (p == NULL)
{
generate_error (&dtp->common, ERROR_OS, NULL);
return;
}
dtp->u.p.current_unit->bytes_left_subrecord -= length;
}
}
}
#undef MAX_READ
static void
next_record_r_unf (st_parameter_dt *dtp, int complete_record)
{
size_t bytes;
bytes = compile_options.record_marker == 0 ?
sizeof (GFC_INTEGER_4) : compile_options.record_marker;
while(1)
{
skip_record (dtp, bytes);
if ( ! (complete_record && dtp->u.p.current_unit->continued))
return;
us_read (dtp, 1);
}
}
static void
next_record_r (st_parameter_dt *dtp)
{
gfc_offset record;
int length, bytes_left;
char *p;
switch (current_mode (dtp))
{
case UNFORMATTED_STREAM:
return;
case UNFORMATTED_SEQUENTIAL:
next_record_r_unf (dtp, 1);
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
break;
case FORMATTED_DIRECT:
case UNFORMATTED_DIRECT:
skip_record (dtp, 0);
break;
case FORMATTED_STREAM:
case FORMATTED_SEQUENTIAL:
length = 1;
if (dtp->u.p.sf_seen_eor)
{
dtp->u.p.sf_seen_eor = 0;
break;
}
if (is_internal_unit (dtp))
{
if (is_array_io (dtp))
{
record = next_array_record (dtp, dtp->u.p.current_unit->ls);
record = record * dtp->u.p.current_unit->recl;
if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
{
generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
break;
}
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
}
else
{
bytes_left = (int) dtp->u.p.current_unit->bytes_left;
p = salloc_r (dtp->u.p.current_unit->s, &bytes_left);
if (p != NULL)
dtp->u.p.current_unit->bytes_left
= dtp->u.p.current_unit->recl;
}
break;
}
else do
{
p = salloc_r (dtp->u.p.current_unit->s, &length);
if (p == NULL)
{
generate_error (&dtp->common, ERROR_OS, NULL);
break;
}
if (length == 0)
{
dtp->u.p.current_unit->endfile = AT_ENDFILE;
break;
}
if (is_stream_io (dtp))
dtp->u.p.current_unit->strm_pos++;
}
while (*p != '\n');
break;
}
if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
test_endfile (dtp->u.p.current_unit);
}
inline static int
write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
{
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_INTEGER_4);
else
len = compile_options.record_marker;
if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
{
switch (len)
{
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 (len)
{
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_8));
return swrite (dtp->u.p.current_unit->s, p, &len);
break;
default:
runtime_error ("Illegal value for record marker");
break;
}
}
}
static void
next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
{
gfc_offset c, m, m_write;
size_t record_marker;
m = dtp->u.p.current_unit->recl_subrecord
- dtp->u.p.current_unit->bytes_left_subrecord;
c = file_position (dtp->u.p.current_unit->s);
if (dtp->u.p.current_unit->continued)
m_write = -m;
else
m_write = m;
if (write_us_marker (dtp, m_write) != 0)
goto io_error;
if (compile_options.record_marker == 0)
record_marker = sizeof (GFC_INTEGER_4);
else
record_marker = compile_options.record_marker;
if (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
== FAILURE)
goto io_error;
if (next_subrecord)
m_write = -m;
else
m_write = m;
if (write_us_marker (dtp, m_write) != 0)
goto io_error;
if (sseek (dtp->u.p.current_unit->s, c + record_marker) == FAILURE)
goto io_error;
return;
io_error:
generate_error (&dtp->common, ERROR_OS, NULL);
return;
}
static void
next_record_w (st_parameter_dt *dtp, int done)
{
gfc_offset m, record, max_pos;
int length;
char *p;
max_pos = dtp->u.p.max_pos;
dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
switch (current_mode (dtp))
{
case UNFORMATTED_STREAM:
return;
case FORMATTED_DIRECT:
if (dtp->u.p.current_unit->bytes_left == 0)
break;
if (sset (dtp->u.p.current_unit->s, ' ',
dtp->u.p.current_unit->bytes_left) == FAILURE)
goto io_error;
break;
case UNFORMATTED_DIRECT:
if (sfree (dtp->u.p.current_unit->s) == FAILURE)
goto io_error;
break;
case UNFORMATTED_SEQUENTIAL:
next_record_w_unf (dtp, 0);
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
break;
case FORMATTED_STREAM:
case FORMATTED_SEQUENTIAL:
if (is_internal_unit (dtp))
{
if (is_array_io (dtp))
{
length = (int) dtp->u.p.current_unit->bytes_left;
m = dtp->u.p.current_unit->recl
- dtp->u.p.current_unit->bytes_left;
if (max_pos > m)
{
length = (int) (max_pos - m);
p = salloc_w (dtp->u.p.current_unit->s, &length);
length = (int) (dtp->u.p.current_unit->recl - max_pos);
}
if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
{
generate_error (&dtp->common, ERROR_END, NULL);
return;
}
record = next_array_record (dtp, dtp->u.p.current_unit->ls);
if (record == 0)
dtp->u.p.current_unit->endfile = AT_ENDFILE;
record = record * dtp->u.p.current_unit->recl;
if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
{
generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
return;
}
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
}
else
{
length = 1;
if (done)
{
m = dtp->u.p.current_unit->recl
- dtp->u.p.current_unit->bytes_left;
if (max_pos > m)
{
length = (int) (max_pos - m);
p = salloc_w (dtp->u.p.current_unit->s, &length);
length = (int) (dtp->u.p.current_unit->recl - max_pos);
}
else
length = (int) dtp->u.p.current_unit->bytes_left;
}
if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
{
generate_error (&dtp->common, ERROR_END, NULL);
return;
}
}
}
else
{
if (done)
{
m = dtp->u.p.current_unit->recl -
dtp->u.p.current_unit->bytes_left;
if (max_pos > m)
{
length = (int) (max_pos - m);
p = salloc_w (dtp->u.p.current_unit->s, &length);
}
}
size_t len;
const char crlf[] = "\r\n";
#ifdef HAVE_CRLF
len = 2;
#else
len = 1;
#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;
io_error:
generate_error (&dtp->common, ERROR_OS, NULL);
break;
}
}
void
next_record (st_parameter_dt *dtp, int done)
{
gfc_offset fp;
dtp->u.p.current_unit->read_bad = 0;
if (dtp->u.p.mode == READING)
next_record_r (dtp);
else
next_record_w (dtp, done);
if (!is_stream_io (dtp))
{
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);
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);
}
static void
finalize_transfer (st_parameter_dt *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);
return;
}
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
if ((dtp->u.p.ionml != NULL)
&& (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
{
if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
namelist_read (dtp);
else
namelist_write (dtp);
}
dtp->u.p.transfer = NULL;
if (dtp->u.p.current_unit == NULL)
return;
dtp->u.p.eof_jump = &eof_jump;
if (setjmp (eof_jump))
{
generate_error (&dtp->common, ERROR_END, NULL);
return;
}
if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
{
finish_list_read (dtp);
sfree (dtp->u.p.current_unit->s);
return;
}
if (is_stream_io (dtp))
{
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);
return;
}
dtp->u.p.current_unit->current_record = 0;
if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar)
{
dtp->u.p.seen_dollar = 0;
sfree (dtp->u.p.current_unit->s);
return;
}
if (dtp->u.p.advance_status == ADVANCE_NO)
{
flush (dtp->u.p.current_unit->s);
return;
}
next_record (dtp, 1);
sfree (dtp->u.p.current_unit->s);
}
static void
iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
void *dest __attribute__ ((unused)),
int kind __attribute__((unused)),
size_t size, size_t nelems)
{
if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
*dtp->iolength += (GFC_INTEGER_4) size * nelems;
}
static void
iolength_transfer_init (st_parameter_dt *dtp)
{
if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
*dtp->iolength = 0;
memset (&dtp->u.p, 0, sizeof (dtp->u.p));
dtp->u.p.transfer = iolength_transfer;
}
extern void st_iolength (st_parameter_dt *);
export_proto(st_iolength);
void
st_iolength (st_parameter_dt *dtp)
{
library_start (&dtp->common);
iolength_transfer_init (dtp);
}
extern void st_iolength_done (st_parameter_dt *);
export_proto(st_iolength_done);
void
st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
{
free_ionml (dtp);
if (dtp->u.p.scratch != NULL)
free_mem (dtp->u.p.scratch);
library_end ();
}
extern void st_read (st_parameter_dt *);
export_proto(st_read);
void
st_read (st_parameter_dt *dtp)
{
library_start (&dtp->common);
data_transfer_init (dtp, 1);
if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
switch (dtp->u.p.current_unit->endfile)
{
case NO_ENDFILE:
break;
case AT_ENDFILE:
if (!is_internal_unit (dtp))
{
generate_error (&dtp->common, ERROR_END, NULL);
dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
dtp->u.p.current_unit->current_record = 0;
}
break;
case AFTER_ENDFILE:
generate_error (&dtp->common, ERROR_ENDFILE, NULL);
dtp->u.p.current_unit->current_record = 0;
break;
}
}
extern void st_read_done (st_parameter_dt *);
export_proto(st_read_done);
void
st_read_done (st_parameter_dt *dtp)
{
finalize_transfer (dtp);
free_format_data (dtp);
free_ionml (dtp);
if (dtp->u.p.scratch != NULL)
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 ();
}
extern void st_write (st_parameter_dt *);
export_proto(st_write);
void
st_write (st_parameter_dt *dtp)
{
library_start (&dtp->common);
data_transfer_init (dtp, 0);
}
extern void st_write_done (st_parameter_dt *);
export_proto(st_write_done);
void
st_write_done (st_parameter_dt *dtp)
{
finalize_transfer (dtp);
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:
break;
case AFTER_ENDFILE:
dtp->u.p.current_unit->endfile = AT_ENDFILE;
break;
case NO_ENDFILE:
if (!is_internal_unit (dtp))
{
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_format_data (dtp);
free_ionml (dtp);
if (dtp->u.p.scratch != NULL)
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 ();
}
extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
export_proto(st_set_nml_var);
void
st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
GFC_INTEGER_4 len, gfc_charlen_type string_length,
GFC_INTEGER_4 dtype)
{
namelist_info *t1 = NULL;
namelist_info *nml;
nml = (namelist_info*) get_mem (sizeof (namelist_info));
nml->mem_pos = var_addr;
nml->var_name = (char*) get_mem (strlen (var_name) + 1);
strcpy (nml->var_name, var_name);
nml->len = (int) len;
nml->string_length = (index_type) string_length;
nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
if (nml->var_rank > 0)
{
nml->dim = (descriptor_dimension*)
get_mem (nml->var_rank * sizeof (descriptor_dimension));
nml->ls = (array_loop_spec*)
get_mem (nml->var_rank * sizeof (array_loop_spec));
}
else
{
nml->dim = NULL;
nml->ls = NULL;
}
nml->next = NULL;
if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
{
dtp->common.flags |= IOPARM_DT_IONML_SET;
dtp->u.p.ionml = nml;
}
else
{
for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
t1->next = nml;
}
}
extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
GFC_INTEGER_4, GFC_INTEGER_4,
GFC_INTEGER_4);
export_proto(st_set_nml_var_dim);
void
st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
GFC_INTEGER_4 stride, GFC_INTEGER_4 lbound,
GFC_INTEGER_4 ubound)
{
namelist_info * nml;
int n;
n = (int)n_dim;
for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
nml->dim[n].stride = (ssize_t)stride;
nml->dim[n].lbound = (ssize_t)lbound;
nml->dim[n].ubound = (ssize_t)ubound;
}
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;
for (i=0; i<n; i++)
*(d++) = *(s--);
}