-/* Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ 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 95 runtime library (libgfortran).
/* transfer.c -- Top level handling of data transfer statements. */
-#include "config.h"
+#include "io.h"
#include <string.h>
#include <assert.h>
-#include "libgfortran.h"
-#include "io.h"
+#include <stdlib.h>
/* Calling conventions: Data transfer statements are unlike other
transfer_integer
transfer_logical
transfer_character
+ transfer_character_wide
transfer_real
transfer_complex
extern void transfer_character (st_parameter_dt *, void *, int);
export_proto(transfer_character);
+extern void transfer_character_wide (st_parameter_dt *, void *, int, int);
+export_proto(transfer_character_wide);
+
extern void transfer_complex (st_parameter_dt *, void *, int);
export_proto(transfer_complex);
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},
};
+static const st_option decimal_opt[] = {
+ {"point", DECIMAL_POINT},
+ {"comma", DECIMAL_COMMA},
+ {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}
+};
+
typedef enum
{ FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
- FORMATTED_DIRECT, UNFORMATTED_DIRECT
+ FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
}
file_mode;
{
file_mode m;
+ m = FORM_UNSPECIFIED;
+
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{
m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
FORMATTED_DIRECT : UNFORMATTED_DIRECT;
}
- else
+ else if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
{
m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
}
+ else if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
+ {
+ m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
+ FORMATTED_STREAM : UNFORMATTED_STREAM;
+ }
return m;
}
an I/O error.
Given this, the solution is to read a byte at a time, stopping if
- we hit the newline. For small locations, we use a static buffer.
+ we hit the newline. For small allocations, we use a static buffer.
For larger allocations, we are forced to allocate memory on the
heap. Hopefully this won't happen very often. */
-static char *
-read_sf (st_parameter_dt *dtp, int *length)
+char *
+read_sf (st_parameter_dt *dtp, int *length, int no_error)
{
- char *base, *p, *q;
- int n, readlen, crlf;
+ char *base, *p, q;
+ int n, crlf;
gfc_offset pos;
+ size_t readlen;
if (*length > SCRATCH_SIZE)
dtp->u.p.line_buffer = get_mem (*length);
return base;
}
+ if (is_internal_unit (dtp))
+ {
+ readlen = *length;
+ if (sread (dtp->u.p.current_unit->s, p, &readlen) != 0 || readlen < (size_t) *length)
+ {
+ generate_error (&dtp->common, LIBERROR_END, NULL);
+ return NULL;
+ }
+
+ goto done;
+ }
+
readlen = 1;
n = 0;
do
{
- if (is_internal_unit (dtp))
- {
- /* readlen may be modified inside salloc_r if
- is_internal_unit (dtp) is true. */
- readlen = 1;
+ if (sread (dtp->u.p.current_unit->s, &q, &readlen) != 0)
+ {
+ generate_error (&dtp->common, LIBERROR_END, NULL);
+ return NULL;
}
- q = salloc_r (dtp->u.p.current_unit->s, &readlen);
- if (q == NULL)
- break;
-
/* If we have a line without a terminating \n, drop through to
EOR below. */
if (readlen < 1 && n == 0)
{
- generate_error (&dtp->common, ERROR_END, NULL);
+ if (no_error)
+ break;
+ generate_error (&dtp->common, LIBERROR_END, NULL);
return NULL;
}
- if (readlen < 1 || *q == '\n' || *q == '\r')
+ if (readlen < 1 || q == '\n' || q == '\r')
{
/* Unexpected end of line. */
crlf = 0;
/* If we encounter a CR, it might be a CRLF. */
- if (*q == '\r') /* Probably a CRLF */
+ if (q == '\r') /* Probably a CRLF */
{
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) /* Not a CRLF after all. */
+ if (sread (dtp->u.p.current_unit->s, &q, &readlen) != 0)
+ {
+ generate_error (&dtp->common, LIBERROR_END, NULL);
+ return NULL;
+ }
+ if (q != '\n' && readlen == 1) /* Not a CRLF after all. */
sseek (dtp->u.p.current_unit->s, pos);
else
crlf = 1;
/* 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->flags.pad == PAD_NO)
+ if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
+ && dtp->u.p.pad_status == PAD_NO)
{
- generate_error (&dtp->common, ERROR_EOR, NULL);
+ if (no_error)
+ break;
+ generate_error (&dtp->common, LIBERROR_EOR, NULL);
return NULL;
}
/* 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 */
- if (*q == ',')
+ if (q == ',')
if (dtp->u.p.sf_read_comma == 1)
{
- notify_std (GFC_STD_GNU, "Comma in formatted numeric read.");
+ notify_std (&dtp->common, GFC_STD_GNU,
+ "Comma in formatted numeric read.");
*length = n;
break;
}
n++;
- *p++ = *q;
+ *p++ = q;
dtp->u.p.sf_seen_eor = 0;
}
while (n < *length);
+
+ done:
dtp->u.p.current_unit->bytes_left -= *length;
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
- *dtp->size += *length;
+ dtp->u.p.size_used += (gfc_offset) *length;
return base;
}
/* Function for reading the next couple of bytes from the current
- file, advancing the current position. We return a pointer to a
- buffer containing the bytes. We return NULL on end of record or
- end of file.
+ file, advancing the current position. We return FAILURE 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 tailing spaces for
short reads. */
-void *
-read_block (st_parameter_dt *dtp, int *length)
+try
+read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes)
{
char *source;
- int nread;
+ size_t nread;
+ int nb;
- if (dtp->u.p.current_unit->bytes_left < *length)
+ if (!is_stream_io (dtp))
{
- if (dtp->u.p.current_unit->flags.pad == PAD_NO)
+ if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
{
- generate_error (&dtp->common, ERROR_EOR, NULL);
- /* Not enough data left. */
- return NULL;
- }
+ /* For preconnected units with default record length, set bytes left
+ to unit record length and proceed, otherwise error. */
+ if (dtp->u.p.current_unit->unit_number == options.stdin_unit
+ && dtp->u.p.current_unit->recl == DEFAULT_RECL)
+ dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+ else
+ {
+ if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
+ && dtp->u.p.pad_status == PAD_NO)
+ {
+ /* Not enough data left. */
+ generate_error (&dtp->common, LIBERROR_EOR, NULL);
+ return FAILURE;
+ }
+ }
+
+ if (dtp->u.p.current_unit->bytes_left == 0)
+ {
+ dtp->u.p.current_unit->endfile = AT_ENDFILE;
+ generate_error (&dtp->common, LIBERROR_END, NULL);
+ return FAILURE;
+ }
- *length = dtp->u.p.current_unit->bytes_left;
+ *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)
- return read_sf (dtp, length); /* Special case. */
-
- dtp->u.p.current_unit->bytes_left -= *length;
+ (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL ||
+ dtp->u.p.current_unit->flags.access == ACCESS_STREAM))
+ {
+ nb = *nbytes;
+ source = read_sf (dtp, &nb, 0);
+ *nbytes = nb;
+ dtp->u.p.current_unit->strm_pos +=
+ (gfc_offset) (*nbytes + dtp->u.p.sf_seen_eor);
+ if (source == NULL)
+ return FAILURE;
+ memcpy (buf, source, *nbytes);
+ return SUCCESS;
+ }
+ dtp->u.p.current_unit->bytes_left -= (gfc_offset) *nbytes;
- nread = *length;
- source = salloc_r (dtp->u.p.current_unit->s, &nread);
+ nread = *nbytes;
+ if (sread (dtp->u.p.current_unit->s, buf, &nread) != 0)
+ {
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
+ return FAILURE;
+ }
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
- *dtp->size += nread;
+ dtp->u.p.size_used += (gfc_offset) nread;
- if (nread != *length)
+ if (nread != *nbytes)
{ /* Short read, this shouldn't happen. */
- if (dtp->u.p.current_unit->flags.pad == PAD_YES)
- *length = nread;
+ if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
+ && dtp->u.p.pad_status == PAD_YES)
+ *nbytes = nread;
else
{
- generate_error (&dtp->common, ERROR_EOR, NULL);
+ generate_error (&dtp->common, LIBERROR_EOR, NULL);
source = NULL;
}
}
- return source;
+ dtp->u.p.current_unit->strm_pos += (gfc_offset) nread;
+
+ return SUCCESS;
}
-/* Reads a block directly into application data space. */
+/* 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)
{
- int *length;
- void *data;
- size_t nread;
+ size_t to_read_record;
+ size_t have_read_record;
+ size_t to_read_subrecord;
+ size_t have_read_subrecord;
+ int short_record;
- if (dtp->u.p.current_unit->bytes_left < *nbytes)
+ if (is_stream_io (dtp))
{
- if (dtp->u.p.current_unit->flags.pad == PAD_NO)
+ to_read_record = *nbytes;
+ have_read_record = to_read_record;
+ if (sread (dtp->u.p.current_unit->s, buf, &have_read_record) != 0)
{
- /* Not enough data left. */
- generate_error (&dtp->common, ERROR_EOR, NULL);
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
return;
}
- *nbytes = dtp->u.p.current_unit->bytes_left;
+ dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record;
+
+ if (to_read_record != have_read_record)
+ {
+ /* Short read, e.g. if we hit EOF. For stream files,
+ we have to set the end-of-file condition. */
+ generate_error (&dtp->common, LIBERROR_END, NULL);
+ return;
+ }
+ return;
}
- if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
- dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+ if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{
- length = (int *) nbytes;
- data = read_sf (dtp, length); /* Special case. */
- memcpy (buf, data, (size_t) *length);
+ 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, LIBERROR_OS, NULL);
+ return;
+ }
+
+ if (to_read_record != *nbytes)
+ {
+ /* Short read, e.g. if we hit EOF. Apparently, we read
+ more than was written to the last record. */
+ *nbytes = to_read_record;
+ return;
+ }
+
+ if (short_record)
+ {
+ generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
+ return;
+ }
return;
}
- dtp->u.p.current_unit->bytes_left -= *nbytes;
+ /* Unformatted sequential. We loop over the subrecords, reading
+ until the request has been fulfilled or the record has run out
+ of continuation subrecords. */
- nread = *nbytes;
- if (sread (dtp->u.p.current_unit->s, buf, &nread) != 0)
+ if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
{
- generate_error (&dtp->common, ERROR_OS, NULL);
+ generate_error (&dtp->common, LIBERROR_END, NULL);
return;
}
- if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
- *dtp->size += (GFC_INTEGER_4) nread;
+ /* Check whether we exceed the total record length. */
- if (nread != *nbytes)
- { /* Short read, e.g. if we hit EOF. */
- if (dtp->u.p.current_unit->flags.pad == PAD_YES)
+ 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, LIBERROR_OS, NULL);
+ return;
+ }
+
+ have_read_record += have_read_subrecord;
+
+ if (to_read_subrecord != have_read_subrecord)
+
{
- memset (((char *) buf) + nread, ' ', *nbytes - nread);
- *nbytes = nread;
+ /* 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. */
+
+ *nbytes = have_read_record;
+ generate_error (&dtp->common, LIBERROR_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
+ {
+ /* 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
- generate_error (&dtp->common, ERROR_EOR, NULL);
+ {
+ /* Normal exit, the read request has been fulfilled. */
+ break;
+ }
+ }
+
+ dtp->u.p.current_unit->bytes_left -= have_read_record;
+ if (short_record)
+ {
+ generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
+ return;
}
+ return;
}
write_block (st_parameter_dt *dtp, int length)
{
char *dest;
-
- if (dtp->u.p.current_unit->bytes_left < length)
+
+ if (!is_stream_io (dtp))
{
- generate_error (&dtp->common, ERROR_EOR, NULL);
- return NULL;
+ if (dtp->u.p.current_unit->bytes_left < (gfc_offset) length)
+ {
+ /* For preconnected units with default record length, set bytes left
+ to unit record length and proceed, otherwise error. */
+ if ((dtp->u.p.current_unit->unit_number == options.stdout_unit
+ || dtp->u.p.current_unit->unit_number == options.stderr_unit)
+ && dtp->u.p.current_unit->recl == DEFAULT_RECL)
+ dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+ else
+ {
+ generate_error (&dtp->common, LIBERROR_EOR, NULL);
+ return NULL;
+ }
+ }
+
+ dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
}
- dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
- dest = salloc_w (dtp->u.p.current_unit->s, &length);
-
- if (dest == NULL)
+ if (is_internal_unit (dtp))
{
- generate_error (&dtp->common, ERROR_END, NULL);
- return NULL;
- }
+ dest = salloc_w (dtp->u.p.current_unit->s, &length);
+ if (dest == NULL)
+ {
+ generate_error (&dtp->common, LIBERROR_END, NULL);
+ return NULL;
+ }
+
+ if (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->size += length;
+ dtp->u.p.size_used += (gfc_offset) length;
+
+ dtp->u.p.current_unit->strm_pos += (gfc_offset) length;
return dest;
}
-/* High level interface to swrite(), taking care of errors. */
+/* 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 try
write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
{
- if (dtp->u.p.current_unit->bytes_left < nbytes)
+
+ size_t have_written, to_write_subrecord;
+ int short_record;
+
+ /* Stream I/O. */
+
+ if (is_stream_io (dtp))
{
- generate_error (&dtp->common, ERROR_EOR, NULL);
- return FAILURE;
+ if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
+ {
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
+ return FAILURE;
+ }
+
+ dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
+
+ return SUCCESS;
}
- dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
+ /* Unformatted direct access. */
- if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
+ if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{
- generate_error (&dtp->common, ERROR_OS, NULL);
- return FAILURE;
+ if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)
+ {
+ generate_error (&dtp->common, LIBERROR_DIRECT_EOR, NULL);
+ return FAILURE;
+ }
+
+ if (buf == NULL && nbytes == 0)
+ return SUCCESS;
+
+ if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
+ {
+ generate_error (&dtp->common, LIBERROR_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;
}
- if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+ /* Unformatted sequential. */
+
+ have_written = 0;
+
+ if (dtp->u.p.current_unit->flags.has_recl
+ && (gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left)
{
- *dtp->size += (GFC_INTEGER_4) nbytes;
- return FAILURE;
+ 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, LIBERROR_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, LIBERROR_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)
+ void *dest, int kind, size_t size, size_t nelems)
{
- /* Currently, character implies size=1. */
- if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE
- || size == 1 || type == BT_CHARACTER)
+ size_t i, sz;
+
+ if (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE
+ || size == 1)
{
- size *= nelems;
- read_block_direct (dtp, dest, &size);
+ sz = size * nelems;
+ if (type == BT_CHARACTER)
+ sz *= GFC_SIZE_OF_CHAR_KIND(kind);
+ read_block_direct (dtp, dest, &sz);
}
else
{
char buffer[16];
char *p;
- size_t i, sz;
-
+
+ p = dest;
+
+ /* 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;
}
- p = dest;
/* By now, all complex variables have been split into their
- constituent reals. For types with padding, we only need to
- read kind bytes. We don't care about the contents
- of the padding. */
+ constituent reals. */
- sz = kind;
- for (i=0; i<nelems; i++)
+ for (i = 0; i < nelems; i++)
{
- read_block_direct (dtp, buffer, &sz);
- reverse_memcpy (p, buffer, sz);
+ read_block_direct (dtp, buffer, &size);
+ reverse_memcpy (p, buffer, size);
p += size;
}
}
}
-/* Master function for unformatted writes. */
+/* 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. */
static void
unformatted_write (st_parameter_dt *dtp, bt type,
- void *source, int kind,
- size_t size, size_t nelems)
+ 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)
+ if (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE ||
+ size == 1)
{
- size *= nelems;
+ size_t stride = type == BT_CHARACTER ?
+ size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
- write_buf (dtp, source, size);
+ write_buf (dtp, source, stride * nelems);
}
else
{
char buffer[16];
char *p;
- size_t i, sz;
+ size_t i;
+
+ 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)
size /= 2;
}
- p = source;
-
/* By now, all complex variables have been split into their
- constituent reals. For types with padding, we only need to
- read kind bytes. We don't care about the contents
- of the padding. */
+ constituent reals. */
- sz = kind;
- for (i=0; i<nelems; i++)
+ for (i = 0; i < nelems; i++)
{
reverse_memcpy(buffer, p, size);
- p+= size;
- write_buf (dtp, buffer, sz);
+ p += size;
+ write_buf (dtp, buffer, size);
}
}
}
write_constant_string (st_parameter_dt *dtp, const fnode *f)
{
char c, delimiter, *p, *q;
- int length;
+ int length;
length = f->u.string.length;
if (length == 0)
p = write_block (dtp, length);
if (p == NULL)
return;
-
+
q = f->u.string.p;
delimiter = q[-1];
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));
+ 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;
/* This subroutine is the main loop for a formatted data transfer
statement. It would be natural to implement this as a coroutine
with the user program, but C makes that awkward. We loop,
- processesing format elements. When we actually have to transfer
+ processing format elements. When we actually have to transfer
data instead of just setting flags, we return control to the user
program which calls a subroutine that supplies the address and type
of the next element, then comes back here to process it. */
static void
-formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
+formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
size_t size)
{
char scratch[SCRATCH_SIZE];
the comma in the stream. (Set to 0 for character reads). */
dtp->u.p.sf_read_comma = 1;
+ if (dtp->common.flags & IOPARM_DT_HAS_F2003)
+ dtp->u.p.sf_read_comma = dtp->u.p.decimal_status == DECIMAL_COMMA ? 0 : 1;
+
dtp->u.p.line_buffer = scratch;
+
for (;;)
{
/* If reversion has occurred and there is another real data item,
next_record (dtp, 0);
}
- consume_data_flag = 1 ;
+ consume_data_flag = 1;
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
break;
f = next_format (dtp);
if (f == NULL)
- return; /* No data descriptors left (already raised). */
+ {
+ /* No data descriptors left. */
+ if (n > 0)
+ generate_error (&dtp->common, 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. */
{
if (dtp->u.p.skips > 0)
{
+ int tmp;
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);
+ tmp = (int)(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;
}
if (dtp->u.p.skips < 0)
{
- move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
+ if (is_internal_unit (dtp))
+ move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
+ else
+ fbuf_seek (dtp->u.p.current_unit, 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);
+ 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)
{
return;
if (dtp->u.p.mode == READING)
- read_decimal (dtp, f, p, len);
+ read_decimal (dtp, f, p, kind);
else
- write_i (dtp, f, p, len);
+ write_i (dtp, f, p, kind);
break;
case FMT_B:
if (n == 0)
goto need_data;
- if (require_type (dtp, BT_INTEGER, type, f))
+
+ if (compile_options.allow_std < GFC_STD_GNU
+ && require_type (dtp, BT_INTEGER, type, f))
return;
if (dtp->u.p.mode == READING)
- read_radix (dtp, f, p, len, 2);
+ read_radix (dtp, f, p, kind, 2);
else
- write_b (dtp, f, p, len);
+ write_b (dtp, f, p, kind);
break;
case FMT_O:
if (n == 0)
- goto need_data;
+ goto need_data;
+
+ if (compile_options.allow_std < GFC_STD_GNU
+ && require_type (dtp, BT_INTEGER, type, f))
+ return;
if (dtp->u.p.mode == READING)
- read_radix (dtp, f, p, len, 8);
+ read_radix (dtp, f, p, kind, 8);
else
- write_o (dtp, f, p, len);
+ write_o (dtp, f, p, kind);
break;
if (n == 0)
goto need_data;
+ if (compile_options.allow_std < GFC_STD_GNU
+ && require_type (dtp, BT_INTEGER, type, f))
+ return;
+
if (dtp->u.p.mode == READING)
- read_radix (dtp, f, p, len, 16);
+ read_radix (dtp, f, p, kind, 16);
else
- write_z (dtp, f, p, len);
+ write_z (dtp, f, p, kind);
break;
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 (dtp->u.p.mode == READING)
- read_a (dtp, f, p, len);
+ {
+ if (type == BT_CHARACTER && kind == 4)
+ read_a_char4 (dtp, f, p, size);
+ else
+ read_a (dtp, f, p, size);
+ }
else
- write_a (dtp, f, p, len);
-
+ {
+ if (type == BT_CHARACTER && kind == 4)
+ write_a_char4 (dtp, f, p, size);
+ else
+ write_a (dtp, f, p, size);
+ }
break;
case FMT_L:
goto need_data;
if (dtp->u.p.mode == READING)
- read_l (dtp, f, p, len);
+ read_l (dtp, f, p, kind);
else
- write_l (dtp, f, p, len);
+ write_l (dtp, f, p, kind);
break;
return;
if (dtp->u.p.mode == READING)
- read_f (dtp, f, p, len);
+ read_f (dtp, f, p, kind);
else
- write_d (dtp, f, p, len);
+ write_d (dtp, f, p, kind);
break;
return;
if (dtp->u.p.mode == READING)
- read_f (dtp, f, p, len);
+ read_f (dtp, f, p, kind);
else
- write_e (dtp, f, p, len);
+ write_e (dtp, f, p, kind);
break;
case FMT_EN:
return;
if (dtp->u.p.mode == READING)
- read_f (dtp, f, p, len);
+ read_f (dtp, f, p, kind);
else
- write_en (dtp, f, p, len);
+ write_en (dtp, f, p, kind);
break;
return;
if (dtp->u.p.mode == READING)
- read_f (dtp, f, p, len);
+ read_f (dtp, f, p, kind);
else
- write_es (dtp, f, p, len);
+ write_es (dtp, f, p, kind);
break;
return;
if (dtp->u.p.mode == READING)
- read_f (dtp, f, p, len);
+ read_f (dtp, f, p, kind);
else
- write_f (dtp, f, p, len);
+ write_f (dtp, f, p, kind);
break;
switch (type)
{
case BT_INTEGER:
- read_decimal (dtp, f, p, len);
+ read_decimal (dtp, f, p, kind);
break;
case BT_LOGICAL:
- read_l (dtp, f, p, len);
+ read_l (dtp, f, p, kind);
break;
case BT_CHARACTER:
- read_a (dtp, f, p, len);
+ 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, len);
+ read_f (dtp, f, p, kind);
break;
default:
goto bad_type;
switch (type)
{
case BT_INTEGER:
- write_i (dtp, f, p, len);
+ write_i (dtp, f, p, kind);
break;
case BT_LOGICAL:
- write_l (dtp, f, p, len);
+ write_l (dtp, f, p, kind);
break;
case BT_CHARACTER:
- write_a (dtp, f, p, len);
+ if (kind == 4)
+ write_a_char4 (dtp, f, p, size);
+ else
+ write_a (dtp, f, p, size);
break;
case BT_REAL:
- write_d (dtp, f, p, len);
+ if (f->u.real.w == 0)
+ {
+ if (f->u.real.d == 0)
+ write_real (dtp, p, kind);
+ else
+ write_real_g0 (dtp, p, kind, f->u.real.d);
+ }
+ else
+ write_d (dtp, f, p, kind);
break;
default:
bad_type:
break;
case FMT_STRING:
- consume_data_flag = 0 ;
+ consume_data_flag = 0;
if (dtp->u.p.mode == READING)
{
format_error (dtp, f, "Constant string in input format");
/* Format codes that don't transfer data. */
case FMT_X:
case FMT_TR:
- consume_data_flag = 0 ;
+ 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;
+ 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
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);
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;
}
}
else /* FMT_T */
{
- consume_data_flag = 0;
- pos = f->u.n - 1;
+ if (dtp->u.p.mode == READING)
+ pos = f->u.n - 1;
+ else
+ pos = f->u.n - dtp->u.p.pending_spaces - 1;
}
/* Standard 10.6.1.1: excessive left tabbing is reset to the
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;
break;
case FMT_S:
- consume_data_flag = 0 ;
+ consume_data_flag = 0;
dtp->u.p.sign_status = SIGN_S;
break;
case FMT_SS:
- consume_data_flag = 0 ;
+ consume_data_flag = 0;
dtp->u.p.sign_status = SIGN_SS;
break;
case FMT_SP:
- consume_data_flag = 0 ;
+ consume_data_flag = 0;
dtp->u.p.sign_status = SIGN_SP;
break;
break;
case FMT_BZ:
- consume_data_flag = 0 ;
+ 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;
+ case FMT_DC:
+ consume_data_flag = 0;
+ dtp->u.p.decimal_status = DECIMAL_COMMA;
break;
- case FMT_DOLLAR:
- consume_data_flag = 0 ;
+ case FMT_DP:
+ consume_data_flag = 0;
+ dtp->u.p.decimal_status = DECIMAL_POINT;
+ 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 ;
+ consume_data_flag = 0;
dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
next_record (dtp, 0);
break;
particular preventing another / descriptor from being
processed) unless there is another data item to be
transferred. */
- consume_data_flag = 0 ;
+ consume_data_flag = 0;
if (n == 0)
return;
break;
char *tmp;
tmp = (char *) p;
-
+ size_t stride = type == BT_CHARACTER ?
+ size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
/* Big loop over all the elements. */
for (elem = 0; elem < nelems; elem++)
{
dtp->u.p.item_count++;
- formatted_transfer_scalar (dtp, type, tmp + size*elem, kind, size);
+ formatted_transfer_scalar (dtp, type, tmp + stride*elem, kind, size);
}
}
void
transfer_character (st_parameter_dt *dtp, void *p, int 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. */
+ dtp->u.p.transfer (dtp, BT_CHARACTER, p, 1, len, 1);
+}
+
+void
+transfer_character_wide (st_parameter_dt *dtp, void *p, int len, int kind)
+{
+ static char *empty_string[0];
+
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
- /* Currently we support only 1 byte chars, and the library is a bit
- confused of character kind vs. length, so we kludge it by setting
- kind = length. */
- dtp->u.p.transfer (dtp, BT_CHARACTER, p, len, len, 1);
+
+ /* 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. */
+ dtp->u.p.transfer (dtp, BT_CHARACTER, p, kind, len, 1);
}
break;
case GFC_DTYPE_CHARACTER:
iotype = BT_CHARACTER;
- /* FIXME: Currently dtype contains the charlen, which is
- clobbered if charlen > 2**24. That's why we use a separate
- argument for the charlen. However, if we want to support
- non-8-bit charsets we need to fix dtype to contain
- sizeof(chartype) and fix the code below. */
size = charlen;
- kind = charlen;
break;
case GFC_DTYPE_DERIVED:
internal_error (&dtp->common,
internal_error (&dtp->common, "transfer_array(): Bad type");
}
- if (desc->dim[0].stride == 0)
- desc->dim[0].stride = 1;
-
rank = GFC_DESCRIPTOR_RANK (desc);
for (n = 0; n < rank; n++)
{
count[n] = 0;
- stride[n] = desc->dim[n].stride;
+ stride[n] = iotype == BT_CHARACTER ?
+ desc->dim[n].stride * GFC_SIZE_OF_CHAR_KIND(kind) :
+ desc->dim[n].stride;
extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound;
/* If the extent of even one dimension is zero, then the entire
- array section contains zero elements, so we return. */
- if (extent[n] == 0)
- return;
+ 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];
/* Preposition a sequential unformatted file while reading. */
static void
-us_read (st_parameter_dt *dtp)
+us_read (st_parameter_dt *dtp, int continued)
{
- char *p;
- int n;
+ size_t n, nr;
+ GFC_INTEGER_4 i4;
+ GFC_INTEGER_8 i8;
gfc_offset i;
if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
return;
- n = sizeof (gfc_offset);
- p = salloc_r (dtp->u.p.current_unit->s, &n);
+ if (compile_options.record_marker == 0)
+ n = sizeof (GFC_INTEGER_4);
+ else
+ n = compile_options.record_marker;
+
+ nr = n;
+
+ if (sread (dtp->u.p.current_unit->s, &i, &n) != 0)
+ {
+ generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
+ return;
+ }
if (n == 0)
{
return; /* end of file */
}
- if (p == NULL || n != sizeof (gfc_offset))
+ if (n != nr)
{
- generate_error (&dtp->common, ERROR_BAD_US, NULL);
+ generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
return;
}
- /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
- if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
- memcpy (&i, p, sizeof (gfc_offset));
+ /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
+ if (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
- reverse_memcpy (&i, p, sizeof (gfc_offset));
-
- dtp->u.p.current_unit->bytes_left = i;
+ switch (nr)
+ {
+ case sizeof(GFC_INTEGER_4):
+ reverse_memcpy (&i4, &i, sizeof (i4));
+ i = i4;
+ break;
+
+ case sizeof(GFC_INTEGER_8):
+ reverse_memcpy (&i8, &i, 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;
}
amount to writing a bogus length that will be filled in later. */
static void
-us_write (st_parameter_dt *dtp)
+us_write (st_parameter_dt *dtp, int continued)
{
size_t nbytes;
gfc_offset dummy;
dummy = 0;
- nbytes = sizeof (gfc_offset);
+
+ 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);
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
- /* For sequential unformatted, we write until we have more bytes
- than can fit in the record markers. If disk space runs out first,
- it will error on the write. */
- dtp->u.p.current_unit->recl = max_offset;
+ /* 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 = dtp->u.p.current_unit->recl;
+ dtp->u.p.current_unit->bytes_left_subrecord =
+ dtp->u.p.current_unit->recl_subrecord;
+ dtp->u.p.current_unit->continued = continued;
}
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);
+ us_read (dtp, 0);
else
- us_write (dtp);
+ us_write (dtp, 0);
break;
namelist_info *ionml;
ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
- memset (&dtp->u.p, 0, sizeof (dtp->u.p));
+
+ /* To maintain ABI, &transfer is the start of the private memory area in
+ in st_parameter_dt. Memory from the beginning of the structure to this
+ point is set by the front end and must not be touched. The number of
+ bytes to clear must stay within the sizeof q to avoid over-writing. */
+ memset (&dtp->u.p.transfer, 0, sizeof (dtp->u.q));
+
dtp->u.p.ionml = ionml;
dtp->u.p.mode = read_flag ? READING : WRITING;
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+ return;
+
if ((cf & IOPARM_DT_HAS_SIZE) != 0)
- *dtp->size = 0; /* Initialize the count. */
+ dtp->u.p.size_used = 0; /* Initialize the count. */
dtp->u.p.current_unit = get_unit (dtp, 1);
if (dtp->u.p.current_unit->s == NULL)
{ /* Open the unit with some default flags. */
st_parameter_open opp;
- 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;
-
- /* 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.status = STATUS_UNKNOWN;
+ 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, LIBERROR_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;
+
+ /* 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.status = STATUS_UNKNOWN;
+
+ conv = get_unformatted_convert (dtp->common.unit);
+
+ if (conv == GFC_CONVERT_NONE)
+ conv = compile_options.convert;
+
+ /* We use big_endian, which is 0 on little-endian machines
+ and 1 on big-endian machines. */
+ switch (conv)
+ {
+ case GFC_CONVERT_NATIVE:
+ case GFC_CONVERT_SWAP:
+ break;
+
+ case GFC_CONVERT_BIG:
+ conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
+ break;
+
+ case GFC_CONVERT_LITTLE:
+ conv = 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);
/* Check the action. */
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");
+ {
+ 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, ERROR_BAD_ACTION,
- "Cannot write to file opened for READ");
-
- if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
- return;
+ {
+ generate_error (&dtp->common, LIBERROR_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->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
- return;
-
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");
+ {
+ 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, ERROR_OPTION_CONFLICT,
+ generate_error (&dtp->common, LIBERROR_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");
-
+ {
+ generate_error (&dtp->common, LIBERROR_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");
+ {
+ generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
+ "Internal file cannot be accessed by UNFORMATTED "
+ "data transfer");
+ return;
+ }
- /* Check the record number. */
+ /* Check the record or position number. */
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
&& (cf & IOPARM_DT_HAS_REC) == 0)
{
- generate_error (&dtp->common, ERROR_MISSING_OPTION,
+ generate_error (&dtp->common, LIBERROR_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");
+ generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
+ "Record number not allowed for sequential access "
+ "data transfer");
return;
}
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");
+ {
+ generate_error (&dtp->common, LIBERROR_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");
+ {
+ generate_error (&dtp->common, LIBERROR_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");
+ {
+ generate_error (&dtp->common, LIBERROR_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");
+ dtp->u.p.current_unit->previous_nonadvancing_write = 0;
- 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");
+ if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
+ {
+ generate_error (&dtp->common, LIBERROR_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, LIBERROR_MISSING_OPTION,
+ "SIZE specification requires an ADVANCE "
+ "specification of NO");
+ return;
+ }
}
else
{ /* Write constraints. */
if ((cf & IOPARM_END) != 0)
- generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
- "END specification cannot appear in a write statement");
+ {
+ generate_error (&dtp->common, LIBERROR_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");
+ {
+ generate_error (&dtp->common, LIBERROR_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");
+ {
+ generate_error (&dtp->common, LIBERROR_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 ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
- return;
- /* Sanity checks on the record number. */
+ /* To maintain ABI check these only if we have the F2003 flag set. */
+ if(cf & IOPARM_DT_HAS_F2003)
+ {
+ /* Check the decimal mode. */
+ dtp->u.p.decimal_status
+ = !(cf & IOPARM_DT_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
+ find_option (&dtp->common, dtp->u.p.decimal, dtp->u.p.decimal_len,
+ decimal_opt, "Bad DECIMAL parameter in data transfer "
+ "statement");
+
+ if (dtp->u.p.decimal_status == DECIMAL_UNSPECIFIED)
+ dtp->u.p.decimal_status = dtp->u.p.current_unit->flags.decimal;
+
+ /* Check the sign mode. */
+ dtp->u.p.sign_status
+ = !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
+ find_option (&dtp->common, dtp->u.p.sign, dtp->u.p.sign_len, sign_opt,
+ "Bad SIGN parameter in data transfer statement");
+
+ if (dtp->u.p.sign_status == SIGN_UNSPECIFIED)
+ dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign;
+
+ /* Check the blank mode. */
+ dtp->u.p.blank_status
+ = !(cf & IOPARM_DT_HAS_BLANK) ? BLANK_UNSPECIFIED :
+ find_option (&dtp->common, dtp->u.p.blank, dtp->u.p.blank_len,
+ blank_opt,
+ "Bad BLANK parameter in data transfer statement");
+
+ if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
+ dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
+
+ /* Check the delim mode. */
+ dtp->u.p.delim_status
+ = !(cf & IOPARM_DT_HAS_DELIM) ? DELIM_UNSPECIFIED :
+ find_option (&dtp->common, dtp->u.p.delim, dtp->u.p.delim_len,
+ delim_opt,
+ "Bad DELIM parameter in data transfer statement");
+
+ if (dtp->u.p.delim_status == DELIM_UNSPECIFIED)
+ dtp->u.p.delim_status = dtp->u.p.current_unit->flags.delim;
+
+ /* Check the pad mode. */
+ dtp->u.p.pad_status
+ = !(cf & IOPARM_DT_HAS_PAD) ? PAD_UNSPECIFIED :
+ find_option (&dtp->common, dtp->u.p.pad, dtp->u.p.pad_len, pad_opt,
+ "Bad PAD parameter in data transfer statement");
+
+ if (dtp->u.p.pad_status == PAD_UNSPECIFIED)
+ dtp->u.p.pad_status = dtp->u.p.current_unit->flags.pad;
+ }
+ /* Sanity checks on the record number. */
if ((cf & IOPARM_DT_HAS_REC) != 0)
{
if (dtp->rec <= 0)
{
- generate_error (&dtp->common, ERROR_BAD_OPTION,
+ generate_error (&dtp->common, LIBERROR_BAD_OPTION,
"Record number must be positive");
return;
}
if (dtp->rec >= dtp->u.p.current_unit->maxrec)
{
- generate_error (&dtp->common, ERROR_BAD_OPTION,
+ generate_error (&dtp->common, LIBERROR_BAD_OPTION,
"Record number too large");
return;
}
/* Check to see if we might be reading what we wrote before */
- if (dtp->u.p.mode == READING && dtp->u.p.current_unit->mode == WRITING)
- flush(dtp->u.p.current_unit->s);
+ if (dtp->u.p.mode == READING
+ && dtp->u.p.current_unit->mode == WRITING
+ && !is_internal_unit (dtp))
+ {
+ fbuf_flush (dtp->u.p.current_unit, 1);
+ flush(dtp->u.p.current_unit->s);
+ }
/* Check whether the record exists to be read. Only
a partial record needs to exist. */
- if (dtp->u.p.mode == READING && (dtp->rec -1)
+ 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,
+ generate_error (&dtp->common, LIBERROR_BAD_OPTION,
"Non-existing record number");
return;
}
/* Position the file. */
- if (sseek (dtp->u.p.current_unit->s,
- (dtp->rec - 1) * dtp->u.p.current_unit->recl) == FAILURE)
+ if (!is_stream_io (dtp))
{
- generate_error (&dtp->common, ERROR_OS, NULL);
- return;
+ if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
+ * dtp->u.p.current_unit->recl) == FAILURE)
+ {
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
+ return;
+ }
}
+ else
+ {
+ if (dtp->u.p.current_unit->strm_pos != dtp->rec)
+ {
+ fbuf_flush (dtp->u.p.current_unit, 1);
+ flush (dtp->u.p.current_unit->s);
+ if (sseek (dtp->u.p.current_unit->s, dtp->rec - 1) == FAILURE)
+ {
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
+ return;
+ }
+ dtp->u.p.current_unit->strm_pos = dtp->rec;
+ }
+ }
+
}
/* Overwriting an existing sequential file ?
it is always safe to truncate the file on the first write */
if (dtp->u.p.mode == WRITING
&& dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
- && dtp->u.p.current_unit->last_record == 0 && !is_preconnected(dtp->u.p.current_unit->s))
+ && dtp->u.p.current_unit->last_record == 0
+ && !is_preconnected(dtp->u.p.current_unit->s))
struncate(dtp->u.p.current_unit->s);
/* Bugware for badly written mixed C-Fortran I/O. */
dtp->u.p.current_unit->mode = dtp->u.p.mode;
- /* Set the initial value of flags. */
-
- dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
- dtp->u.p.sign_status = SIGN_S;
+ /* Set the maximum position reached from the previous I/O operation. This
+ could be greater than zero from a previous non-advancing write. */
+ dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos;
pre_position (dtp);
+
/* Set up the subroutine that will handle the transfers. */
if (read_flag)
{
- if (dtp->u.p.current_unit->read_bad)
+ if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp))
{
- generate_error (&dtp->common, ERROR_BAD_OPTION,
+ generate_error (&dtp->common, LIBERROR_BAD_OPTION,
"Cannot READ after a nonadvancing WRITE");
return;
}
}
/* Initialize an array_loop_spec given the array descriptor. The function
- returns the index of the last element of the array. */
+ returns the index of the last element of the array, and also returns
+ starting record, where the first I/O goes to (necessary in case of
+ negative strides). */
gfc_offset
-init_loop_spec (gfc_array_char *desc, array_loop_spec *ls)
+init_loop_spec (gfc_array_char *desc, array_loop_spec *ls,
+ gfc_offset *start_record)
{
int rank = GFC_DESCRIPTOR_RANK(desc);
int i;
gfc_offset index;
+ int empty;
+ empty = 0;
index = 1;
+ *start_record = 0;
+
for (i=0; i<rank; i++)
{
- ls[i].idx = 1;
+ 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;
+ empty = empty || (desc->dim[i].ubound < desc->dim[i].lbound);
+
+ if (desc->dim[i].stride > 0)
+ {
+ index += (desc->dim[i].ubound - desc->dim[i].lbound)
+ * desc->dim[i].stride;
+ }
+ else
+ {
+ index -= (desc->dim[i].ubound - desc->dim[i].lbound)
+ * desc->dim[i].stride;
+ *start_record -= (desc->dim[i].ubound - desc->dim[i].lbound)
+ * desc->dim[i].stride;
+ }
}
- return index;
+
+ if (empty)
+ return 0;
+ else
+ return index;
}
/* Determine the index to the next record in an internal unit array by
- by incrementing through the array_loop_spec. TODO: Implement handling
- negative strides. */
+ by incrementing through the array_loop_spec. */
gfc_offset
-next_array_record (st_parameter_dt *dtp, array_loop_spec *ls)
+next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished)
{
int i, carry;
gfc_offset index;
carry = 1;
index = 0;
-
+
for (i = 0; i < dtp->u.p.current_unit->rank; i++)
{
if (carry)
else
carry = 0;
}
- index = index + (ls[i].idx - 1) * ls[i].step;
+ index = index + (ls[i].idx - ls[i].start) * ls[i].step;
}
+
+ *finished = carry;
+
return index;
}
-/* Space to the next record for read mode. If the file is not
- seekable, we read MAX_READ chunks until we get to the right
+
+
+/* Skip to the end of the current record, taking care of an optional
+ record marker of size bytes. If the file is not seekable, we
+ read chunks of size MAX_READ until we get to the right
position. */
-#define MAX_READ 4096
+static void
+skip_record (st_parameter_dt *dtp, size_t bytes)
+{
+ gfc_offset new;
+ size_t rlength;
+ static const size_t MAX_READ = 4096;
+ char p[MAX_READ];
+
+ 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;
+
+ /* Direct access files do not generate END conditions,
+ only I/O errors. */
+ if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
+ }
+ else
+ { /* Seek by reading data. */
+ while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
+ {
+ rlength =
+ (MAX_READ > (size_t) dtp->u.p.current_unit->bytes_left_subrecord) ?
+ MAX_READ : (size_t) dtp->u.p.current_unit->bytes_left_subrecord;
+
+ if (sread (dtp->u.p.current_unit->s, p, &rlength) != 0)
+ {
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
+ return;
+ }
+
+ dtp->u.p.current_unit->bytes_left_subrecord -= rlength;
+ }
+ }
+
+}
+
+
+/* Advance to the next record reading unformatted files, taking
+ care of subrecords. If complete_record is nonzero, we loop
+ until all subrecords are cleared. */
static void
-next_record_r (st_parameter_dt *dtp)
+next_record_r_unf (st_parameter_dt *dtp, int complete_record)
{
- gfc_offset new, record;
- int bytes_left, rlength, length;
- char *p;
+ size_t bytes;
- switch (current_mode (dtp))
+ bytes = compile_options.record_marker == 0 ?
+ sizeof (GFC_INTEGER_4) : compile_options.record_marker;
+
+ while(1)
{
- case UNFORMATTED_SEQUENTIAL:
/* Skip over tail */
- dtp->u.p.current_unit->bytes_left += sizeof (gfc_offset);
-
- /* Fall through... */
- case FORMATTED_DIRECT:
- case UNFORMATTED_DIRECT:
- if (dtp->u.p.current_unit->bytes_left == 0)
- break;
+ skip_record (dtp, bytes);
- 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;
+ if ( ! (complete_record && dtp->u.p.current_unit->continued))
+ return;
- /* Direct access files do not generate END conditions,
- only I/O errors. */
- if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
- generate_error (&dtp->common, ERROR_OS, NULL);
+ us_read (dtp, 1);
+ }
+}
- }
- else
- { /* Seek by reading data. */
- while (dtp->u.p.current_unit->bytes_left > 0)
- {
- rlength = length = (MAX_READ > dtp->u.p.current_unit->bytes_left) ?
- MAX_READ : dtp->u.p.current_unit->bytes_left;
- p = salloc_r (dtp->u.p.current_unit->s, &rlength);
- if (p == NULL)
- {
- generate_error (&dtp->common, ERROR_OS, NULL);
- break;
- }
+static inline gfc_offset
+min_off (gfc_offset a, gfc_offset b)
+{
+ return (a < b ? a : b);
+}
- dtp->u.p.current_unit->bytes_left -= length;
- }
- }
+
+/* Space to the next record for read mode. */
+
+static void
+next_record_r (st_parameter_dt *dtp)
+{
+ gfc_offset record;
+ int bytes_left;
+ size_t length;
+ char p;
+
+ switch (current_mode (dtp))
+ {
+ /* No records in unformatted STREAM I/O. */
+ 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;
/* sf_read has already terminated input because of an '\n' */
{
if (is_array_io (dtp))
{
- record = next_array_record (dtp, dtp->u.p.current_unit->ls);
+ int finished;
+
+ record = next_array_record (dtp, dtp->u.p.current_unit->ls,
+ &finished);
/* Now seek to this record. */
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);
+ generate_error (&dtp->common, LIBERROR_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;
+ bytes_left = min_off (bytes_left,
+ file_length (dtp->u.p.current_unit->s)
+ - file_position (dtp->u.p.current_unit->s));
+ if (sseek (dtp->u.p.current_unit->s,
+ file_position (dtp->u.p.current_unit->s)
+ + bytes_left) == FAILURE)
+ {
+ generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
+ break;
+ }
+ 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)
+ if (sread (dtp->u.p.current_unit->s, &p, &length) != 0)
{
- generate_error (&dtp->common, ERROR_OS, NULL);
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
break;
}
dtp->u.p.current_unit->endfile = AT_ENDFILE;
break;
}
+
+ if (is_stream_io (dtp))
+ dtp->u.p.current_unit->strm_pos++;
}
- while (*p != '\n');
+ while (p != '\n');
break;
}
- if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
- test_endfile (dtp->u.p.current_unit);
+ if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
+ && !dtp->u.p.namelist_mode
+ && dtp->u.p.current_unit->endfile == NO_ENDFILE
+ && (file_length (dtp->u.p.current_unit->s) ==
+ file_position (dtp->u.p.current_unit->s)))
+ dtp->u.p.current_unit->endfile = AT_ENDFILE;
+
}
/* Small utility function to write a record marker, taking care of
- byte swapping. */
+ byte swapping and of choosing the correct size. */
inline static int
write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
{
- size_t len = sizeof (gfc_offset);
- /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
- if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
- return swrite (dtp->u.p.current_unit->s, &buf, &len);
- else {
- gfc_offset p;
- reverse_memcpy (&p, &buf, sizeof (gfc_offset));
- return swrite (dtp->u.p.current_unit->s, &p, &len);
- }
+ 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;
+
+ /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
+ if (dtp->u.p.current_unit->flags.convert == GFC_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;
+ }
+ }
+
}
+/* Position to the next (sub)record in write mode for
+ unformatted sequential files. */
+
+static void
+next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
+{
+ gfc_offset c, m, m_write;
+ size_t record_marker;
+
+ /* Bytes written. */
+ 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);
+
+ /* Write the length tail. If we finish a record containing
+ subrecords, we write out the negative length. */
+
+ 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;
+
+ /* Seek to the head and overwrite the bogus length with the real
+ length. */
+
+ 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;
+
+ /* Seek past the end of the current record. */
+
+ if (sseek (dtp->u.p.current_unit->s, c + record_marker) == FAILURE)
+ goto io_error;
+
+ return;
+
+ io_error:
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
+ return;
+
+}
/* Position to the next record in write mode. */
static void
next_record_w (st_parameter_dt *dtp, int done)
{
- gfc_offset c, m, record, max_pos;
+ gfc_offset m, record, max_pos;
int length;
- char *p;
+ /* Flush and reset the format buffer. */
+ fbuf_flush (dtp->u.p.current_unit, 1);
+
/* Zero counters for X- and T-editing. */
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))
{
+ /* No records in unformatted STREAM I/O. */
+ case UNFORMATTED_STREAM:
+ return;
+
case FORMATTED_DIRECT:
if (dtp->u.p.current_unit->bytes_left == 0)
break;
break;
case UNFORMATTED_DIRECT:
- if (sfree (dtp->u.p.current_unit->s) == FAILURE)
- goto io_error;
+ if (dtp->u.p.current_unit->bytes_left > 0)
+ {
+ length = (int) dtp->u.p.current_unit->bytes_left;
+ if (sset (dtp->u.p.current_unit->s, 0, length) == FAILURE)
+ goto io_error;
+ }
break;
case UNFORMATTED_SEQUENTIAL:
- /* Bytes written. */
- m = dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left;
- c = file_position (dtp->u.p.current_unit->s);
-
- /* Write the length tail. */
-
- if (write_us_marker (dtp, m) != 0)
- goto io_error;
-
- /* Seek to the head and overwrite the bogus length with the real
- length. */
-
- if (sseek (dtp->u.p.current_unit->s, c - m - sizeof (gfc_offset))
- == FAILURE)
- goto io_error;
-
- if (write_us_marker (dtp, m) != 0)
- goto io_error;
-
- /* Seek past the end of the current record. */
-
- if (sseek (dtp->u.p.current_unit->s, c + sizeof (gfc_offset)) == FAILURE)
- goto io_error;
-
+ 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 (dtp->u.p.current_unit->bytes_left == 0)
- break;
-
if (is_internal_unit (dtp))
{
if (is_array_io (dtp))
{
+ int finished;
+
length = (int) dtp->u.p.current_unit->bytes_left;
/* If the farthest position reached is greater than current
if (max_pos > m)
{
length = (int) (max_pos - m);
- p = salloc_w (dtp->u.p.current_unit->s, &length);
+ if (sseek (dtp->u.p.current_unit->s,
+ file_position (dtp->u.p.current_unit->s)
+ + length) == FAILURE)
+ {
+ generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
+ return;
+ }
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);
+ generate_error (&dtp->common, LIBERROR_END, NULL);
return;
}
/* Now that the current record has been padded out,
determine where the next record in the array is. */
- record = next_array_record (dtp, dtp->u.p.current_unit->ls);
-
+ record = next_array_record (dtp, dtp->u.p.current_unit->ls,
+ &finished);
+ if (finished)
+ dtp->u.p.current_unit->endfile = AT_ENDFILE;
+
/* Now seek to this record */
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);
+ generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
return;
}
if (max_pos > m)
{
length = (int) (max_pos - m);
- p = salloc_w (dtp->u.p.current_unit->s, &length);
+ if (sseek (dtp->u.p.current_unit->s,
+ file_position (dtp->u.p.current_unit->s)
+ + length) == FAILURE)
+ {
+ generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
+ return;
+ }
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);
+ generate_error (&dtp->common, LIBERROR_END, NULL);
return;
}
}
}
else
{
- /* If this is the last call to next_record move to the farthest
- position reached in preparation for completing the record.
- (for file unit) */
- 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
#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;
+ if (dtp->u.p.current_unit->strm_pos
+ < file_length (dtp->u.p.current_unit->s))
+ struncate (dtp->u.p.current_unit->s);
+ }
}
break;
io_error:
- generate_error (&dtp->common, ERROR_OS, NULL);
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
break;
}
}
else
next_record_w (dtp, done);
- /* keep position up to date for INQUIRE */
- dtp->u.p.current_unit->flags.position = POSITION_ASIS;
+ if (!is_stream_io (dtp))
+ {
+ /* Keep position up to date for INQUIRE */
+ if (done)
+ update_position (dtp->u.p.current_unit);
- dtp->u.p.current_unit->current_record = 0;
- if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
- {
- fp = file_position (dtp->u.p.current_unit->s);
- /* Calculate next record, rounding up partial records. */
- dtp->u.p.current_unit->last_record = (fp + dtp->u.p.current_unit->recl - 1)
- / dtp->u.p.current_unit->recl;
- }
- else
- dtp->u.p.current_unit->last_record++;
+ dtp->u.p.current_unit->current_record = 0;
+ if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
+ {
+ fp = file_position (dtp->u.p.current_unit->s);
+ /* Calculate next record, rounding up partial records. */
+ dtp->u.p.current_unit->last_record =
+ (fp + dtp->u.p.current_unit->recl - 1) /
+ dtp->u.p.current_unit->recl;
+ }
+ else
+ dtp->u.p.current_unit->last_record++;
+ }
if (!done)
pre_position (dtp);
jmp_buf eof_jump;
GFC_INTEGER_4 cf = dtp->common.flags;
+ if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+ *dtp->size = (GFC_IO_INT) dtp->u.p.size_used;
+
if (dtp->u.p.eor_condition)
{
- generate_error (&dtp->common, ERROR_EOR, NULL);
+ generate_error (&dtp->common, LIBERROR_EOR, NULL);
return;
}
dtp->u.p.eof_jump = &eof_jump;
if (setjmp (eof_jump))
{
- generate_error (&dtp->common, ERROR_END, NULL);
+ generate_error (&dtp->common, LIBERROR_END, NULL);
return;
}
if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
- finish_list_read (dtp);
- else
{
- dtp->u.p.current_unit->current_record = 0;
- if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
+ finish_list_read (dtp);
+ sfree (dtp->u.p.current_unit->s);
+ return;
+ }
+
+ if (dtp->u.p.mode == WRITING)
+ dtp->u.p.current_unit->previous_nonadvancing_write
+ = dtp->u.p.advance_status == ADVANCE_NO;
+
+ if (is_stream_io (dtp))
+ {
+ if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
+ && dtp->u.p.advance_status != ADVANCE_NO)
+ next_record (dtp, 1);
+
+ if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
+ && file_position (dtp->u.p.current_unit->s) >= dtp->rec)
{
- /* Most systems buffer lines, so force the partial record
- to be written out. */
flush (dtp->u.p.current_unit->s);
- dtp->u.p.seen_dollar = 0;
- return;
+ sfree (dtp->u.p.current_unit->s);
}
-
- next_record (dtp, 1);
+ return;
}
- sfree (dtp->u.p.current_unit->s);
+ dtp->u.p.current_unit->current_record = 0;
- if (is_internal_unit (dtp))
+ if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar)
{
- if (is_array_io (dtp) && dtp->u.p.current_unit->ls != NULL)
- free_mem (dtp->u.p.current_unit->ls);
- sclose (dtp->u.p.current_unit->s);
+ dtp->u.p.seen_dollar = 0;
+ fbuf_flush (dtp->u.p.current_unit, 1);
+ sfree (dtp->u.p.current_unit->s);
+ return;
}
-}
+ /* For non-advancing I/O, save the current maximum position for use in the
+ next I/O operation if needed. */
+ if (dtp->u.p.advance_status == ADVANCE_NO)
+ {
+ int bytes_written = (int) (dtp->u.p.current_unit->recl
+ - dtp->u.p.current_unit->bytes_left);
+ dtp->u.p.current_unit->saved_pos =
+ dtp->u.p.max_pos > 0 ? dtp->u.p.max_pos - bytes_written : 0;
+ fbuf_flush (dtp->u.p.current_unit, 0);
+ flush (dtp->u.p.current_unit->s);
+ return;
+ }
+
+ dtp->u.p.current_unit->saved_pos = 0;
+
+ next_record (dtp, 1);
+ sfree (dtp->u.p.current_unit->s);
+}
/* Transfer function for IOLENGTH. It doesn't actually do any
data transfer, it just updates the length counter. */
size_t size, size_t nelems)
{
if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
- *dtp->iolength += (GFC_INTEGER_4) size * nelems;
+ *dtp->iolength += (GFC_IO_INT) size * nelems;
}
void
st_read (st_parameter_dt *dtp)
{
-
library_start (&dtp->common);
data_transfer_init (dtp, 1);
- /* Handle complications dealing with the endfile record. It is
- significant that this is the only place where ERROR_END is
- generated. Reading an end of file elsewhere is either end of
- record or an I/O error. */
+ /* Handle complications dealing with the endfile record. */
if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
switch (dtp->u.p.current_unit->endfile)
case AT_ENDFILE:
if (!is_internal_unit (dtp))
{
- generate_error (&dtp->common, ERROR_END, NULL);
+ generate_error (&dtp->common, LIBERROR_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);
+ generate_error (&dtp->common, LIBERROR_ENDFILE, NULL);
dtp->u.p.current_unit->current_record = 0;
break;
}
void
st_read_done (st_parameter_dt *dtp)
{
- flush(dtp->u.p.current_unit->s);
finalize_transfer (dtp);
free_format_data (dtp);
free_ionml (dtp);
free_mem (dtp->u.p.scratch);
if (dtp->u.p.current_unit != NULL)
unlock_unit (dtp->u.p.current_unit);
+
+ free_internal_unit (dtp);
+
library_end ();
}
/* Deal with endfile conditions associated with sequential files. */
- if (dtp->u.p.current_unit != NULL && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+ if (dtp->u.p.current_unit != NULL
+ && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
switch (dtp->u.p.current_unit->endfile)
{
case AT_ENDFILE: /* Remain at the endfile record. */
break;
case NO_ENDFILE:
- if (dtp->u.p.current_unit->current_record > dtp->u.p.current_unit->last_record)
+ /* Get rid of whatever is after this record. */
+ if (!is_internal_unit (dtp))
{
- /* Get rid of whatever is after this record. */
+ flush (dtp->u.p.current_unit->s);
if (struncate (dtp->u.p.current_unit->s) == FAILURE)
- generate_error (&dtp->common, ERROR_OS, NULL);
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
}
-
dtp->u.p.current_unit->endfile = AT_ENDFILE;
break;
}
free_mem (dtp->u.p.scratch);
if (dtp->u.p.current_unit != NULL)
unlock_unit (dtp->u.p.current_unit);
+
+ free_internal_unit (dtp);
+
library_end ();
}
+
+/* F2003: This is a stub for the runtime portion of the WAIT statement. */
+void
+st_wait (st_parameter_wait *wtp __attribute__((unused)))
+{
+}
+
+
/* Receives the scalar information for namelist objects and stores it
in a linked list of namelist_info types. */
{
namelist_info *t1 = NULL;
namelist_info *nml;
+ size_t var_name_len = strlen (var_name);
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->var_name = (char*) get_mem (var_name_len + 1);
+ memcpy (nml->var_name, var_name, var_name_len);
+ nml->var_name[var_name_len] = '\0';
nml->len = (int) len;
nml->string_length = (index_type) string_length;
/* Store the dimensional information for the namelist object. */
extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
- GFC_INTEGER_4, GFC_INTEGER_4,
- GFC_INTEGER_4);
+ index_type, index_type,
+ index_type);
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)
+ index_type stride, index_type lbound,
+ index_type ubound)
{
namelist_info * nml;
int n;
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;
+ nml->dim[n].stride = stride;
+ nml->dim[n].lbound = lbound;
+ nml->dim[n].ubound = ubound;
}
/* Reverse memcpy - used for byte swapping. */
OSDN Git Service
