-/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Andy Vaught
Namelist transfer functions contributed by Paul Thomas
Libgfortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
+the Free Software Foundation; either version 3, or (at your option)
any later version.
-In addition to the permissions in the GNU General Public License, the
-Free Software Foundation gives you unlimited permission to link the
-compiled version of this file into combinations with other programs,
-and to distribute those combinations without any restriction coming
-from the use of this file. (The General Public License restrictions
-do apply in other respects; for example, they cover modification of
-the file, and distribution when not linked into a combine
-executable.)
-
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
-You should have received a copy of the GNU General Public License
-along with Libgfortran; see the file COPYING. If not, write to
-the Free Software Foundation, 51 Franklin Street, Fifth Floor,
-Boston, MA 02110-1301, USA. */
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
/* transfer.c -- Top level handling of data transfer statements. */
#include "io.h"
+#include "fbuf.h"
+#include "format.h"
+#include "unix.h"
#include <string.h>
#include <assert.h>
#include <stdlib.h>
+#include <errno.h>
/* Calling conventions: Data transfer statements are unlike other
{NULL, 0}
};
+static const st_option round_opt[] = {
+ {"up", ROUND_UP},
+ {"down", ROUND_DOWN},
+ {"zero", ROUND_ZERO},
+ {"nearest", ROUND_NEAREST},
+ {"compatible", ROUND_COMPATIBLE},
+ {"processor_defined", ROUND_PROCDEFINED},
+ {NULL, 0}
+};
+
static const st_option sign_opt[] = {
{"plus", SIGN_SP},
}
-/* Mid level data transfer statements. These subroutines do reading
- and writing in the style of salloc_r()/salloc_w() within the
- current record. */
+/* Mid level data transfer statements. */
/* When reading sequential formatted records we have a problem. We
don't know how long the line is until we read the trailing newline,
we hit the newline. For small allocations, we use a static buffer.
For larger allocations, we are forced to allocate memory on the
heap. Hopefully this won't happen very often. */
+
+/* Read sequential file - internal unit */
-char *
-read_sf (st_parameter_dt *dtp, int *length, int no_error)
+static char *
+read_sf_internal (st_parameter_dt *dtp, int * length)
{
- char *base, *p, q;
- int n, crlf;
- gfc_offset pos;
- size_t readlen;
+ static char *empty_string[0];
+ char *base;
+ int lorig;
- if (*length > SCRATCH_SIZE)
- dtp->u.p.line_buffer = get_mem (*length);
- p = base = dtp->u.p.line_buffer;
+ /* Zero size array gives internal unit len of 0. Nothing to read. */
+ if (dtp->internal_unit_len == 0
+ && dtp->u.p.current_unit->pad_status == PAD_NO)
+ hit_eof (dtp);
/* If we have seen an eor previously, return a length of 0. The
caller is responsible for correctly padding the input field. */
if (dtp->u.p.sf_seen_eor)
{
*length = 0;
- return base;
+ /* Just return something that isn't a NULL pointer, otherwise the
+ caller thinks an error occured. */
+ return (char*) empty_string;
}
- if (is_internal_unit (dtp))
+ lorig = *length;
+ base = mem_alloc_r (dtp->u.p.current_unit->s, length);
+ if (unlikely (lorig > *length))
{
- readlen = *length;
- if (unlikely (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;
+ hit_eof (dtp);
+ return NULL;
}
- readlen = 1;
- n = 0;
+ dtp->u.p.current_unit->bytes_left -= *length;
- do
+ if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
+ dtp->u.p.size_used += (GFC_IO_INT) *length;
+
+ return base;
+
+}
+
+/* Read sequential file - external unit */
+
+static char *
+read_sf (st_parameter_dt *dtp, int * length)
+{
+ static char *empty_string[0];
+ char *base, *p, q;
+ int n, lorig, seen_comma;
+
+ /* If we have seen an eor previously, return a length of 0. The
+ caller is responsible for correctly padding the input field. */
+ if (dtp->u.p.sf_seen_eor)
{
- if (unlikely (sread (dtp->u.p.current_unit->s, &q, &readlen) != 0))
- {
- generate_error (&dtp->common, LIBERROR_END, NULL);
- return NULL;
- }
+ *length = 0;
+ /* Just return something that isn't a NULL pointer, otherwise the
+ caller thinks an error occured. */
+ return (char*) empty_string;
+ }
- /* If we have a line without a terminating \n, drop through to
- EOR below. */
- if (readlen < 1 && n == 0)
- {
- if (likely (no_error))
- break;
- generate_error (&dtp->common, LIBERROR_END, NULL);
- return NULL;
- }
+ n = seen_comma = 0;
+
+ /* Read data into format buffer and scan through it. */
+ lorig = *length;
+ base = p = fbuf_read (dtp->u.p.current_unit, length);
+ if (base == NULL)
+ return NULL;
+
+ while (n < *length)
+ {
+ q = *p;
- if (readlen < 1 || q == '\n' || q == '\r')
+ if (q == '\n' || q == '\r')
{
- /* Unexpected end of line. */
+ /* Unexpected end of line. Set the position. */
+ fbuf_seek (dtp->u.p.current_unit, n + 1 ,SEEK_CUR);
+ dtp->u.p.sf_seen_eor = 1;
/* If we see an EOR during non-advancing I/O, we need to skip
the rest of the I/O statement. Set the corresponding flag. */
if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
dtp->u.p.eor_condition = 1;
-
- crlf = 0;
+
/* If we encounter a CR, it might be a CRLF. */
if (q == '\r') /* Probably a CRLF */
{
- readlen = 1;
- pos = stream_offset (dtp->u.p.current_unit->s);
- if (unlikely (sread (dtp->u.p.current_unit->s, &q, &readlen)
- != 0))
+ /* See if there is an LF. Use fbuf_read rather then fbuf_getc so
+ the position is not advanced unless it really is an LF. */
+ int readlen = 1;
+ p = fbuf_read (dtp->u.p.current_unit, &readlen);
+ if (*p == '\n' && readlen == 1)
{
- generate_error (&dtp->common, LIBERROR_END, NULL);
- return NULL;
+ dtp->u.p.sf_seen_eor = 2;
+ fbuf_seek (dtp->u.p.current_unit, 1 ,SEEK_CUR);
}
- 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
so we can just continue with a short read. */
if (dtp->u.p.current_unit->pad_status == PAD_NO)
{
- if (likely (no_error))
- break;
generate_error (&dtp->common, LIBERROR_EOR, NULL);
return NULL;
}
*length = n;
- dtp->u.p.sf_seen_eor = (crlf ? 2 : 1);
- break;
+ goto done;
}
/* Short circuit the read if a comma is found during numeric input.
The flag is set to zero during character reads so that commas in
if (q == ',')
if (dtp->u.p.sf_read_comma == 1)
{
+ seen_comma = 1;
notify_std (&dtp->common, GFC_STD_GNU,
"Comma in formatted numeric read.");
*length = n;
break;
}
-
n++;
- *p++ = q;
- dtp->u.p.sf_seen_eor = 0;
+ p++;
+ }
+
+ fbuf_seek (dtp->u.p.current_unit, n + seen_comma, SEEK_CUR);
+
+ /* A short read implies we hit EOF, unless we hit EOR, a comma, or
+ some other stuff. Set the relevant flags. */
+ if (lorig > *length && !dtp->u.p.sf_seen_eor && !seen_comma)
+ {
+ if (n > 0)
+ {
+ if (dtp->u.p.advance_status == ADVANCE_NO)
+ {
+ if (dtp->u.p.current_unit->pad_status == PAD_NO)
+ {
+ hit_eof (dtp);
+ return NULL;
+ }
+ else
+ dtp->u.p.eor_condition = 1;
+ }
+ else
+ dtp->u.p.at_eof = 1;
+ }
+ else if (dtp->u.p.advance_status == ADVANCE_NO
+ || dtp->u.p.current_unit->pad_status == PAD_NO
+ || dtp->u.p.current_unit->bytes_left
+ == dtp->u.p.current_unit->recl)
+ {
+ hit_eof (dtp);
+ return NULL;
+ }
}
- while (n < *length);
done:
- dtp->u.p.current_unit->bytes_left -= *length;
+
+ dtp->u.p.current_unit->bytes_left -= n;
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
- dtp->u.p.size_used += (gfc_offset) *length;
+ dtp->u.p.size_used += (GFC_IO_INT) n;
return base;
}
opened with PAD=YES. The caller must assume tailing spaces for
short reads. */
-try
-read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes)
+void *
+read_block_form (st_parameter_dt *dtp, int * nbytes)
{
char *source;
- size_t nread;
- int nb;
+ int norig;
if (!is_stream_io (dtp))
{
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
else
{
- if (unlikely (dtp->u.p.current_unit->pad_status == PAD_NO))
+ if (unlikely (dtp->u.p.current_unit->pad_status == PAD_NO)
+ && !is_internal_unit (dtp))
{
/* Not enough data left. */
generate_error (&dtp->common, LIBERROR_EOR, NULL);
- return FAILURE;
+ return NULL;
}
}
- if (unlikely (dtp->u.p.current_unit->bytes_left == 0))
+ if (unlikely (dtp->u.p.current_unit->bytes_left == 0
+ && !is_internal_unit(dtp)))
{
- dtp->u.p.current_unit->endfile = AT_ENDFILE;
- generate_error (&dtp->common, LIBERROR_END, NULL);
- return FAILURE;
+ hit_eof (dtp);
+ return NULL;
}
*nbytes = dtp->u.p.current_unit->bytes_left;
(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;
+ if (is_internal_unit (dtp))
+ source = read_sf_internal (dtp, nbytes);
+ else
+ source = read_sf (dtp, nbytes);
+
dtp->u.p.current_unit->strm_pos +=
(gfc_offset) (*nbytes + dtp->u.p.sf_seen_eor);
- if (source == NULL)
- return FAILURE;
- memcpy (buf, source, *nbytes);
- return SUCCESS;
+ return source;
}
+
+ /* If we reach here, we can assume it's direct access. */
+
dtp->u.p.current_unit->bytes_left -= (gfc_offset) *nbytes;
- nread = *nbytes;
- if (unlikely (sread (dtp->u.p.current_unit->s, buf, &nread) != 0))
- {
- generate_error (&dtp->common, LIBERROR_OS, NULL);
- return FAILURE;
- }
+ norig = *nbytes;
+ source = fbuf_read (dtp->u.p.current_unit, nbytes);
+ fbuf_seek (dtp->u.p.current_unit, *nbytes, SEEK_CUR);
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
- dtp->u.p.size_used += (gfc_offset) nread;
+ dtp->u.p.size_used += (GFC_IO_INT) *nbytes;
- if (nread != *nbytes)
- { /* Short read, this shouldn't happen. */
- if (likely (dtp->u.p.current_unit->pad_status == PAD_YES))
- *nbytes = nread;
- else
+ if (norig != *nbytes)
+ {
+ /* Short read, this shouldn't happen. */
+ if (!dtp->u.p.current_unit->pad_status == PAD_YES)
{
generate_error (&dtp->common, LIBERROR_EOR, NULL);
source = NULL;
}
}
- dtp->u.p.current_unit->strm_pos += (gfc_offset) nread;
+ dtp->u.p.current_unit->strm_pos += (gfc_offset) *nbytes;
- return SUCCESS;
+ return source;
}
unformatted files. */
static void
-read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
+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;
+ ssize_t to_read_record;
+ ssize_t have_read_record;
+ ssize_t to_read_subrecord;
+ ssize_t have_read_subrecord;
int short_record;
if (is_stream_io (dtp))
{
- to_read_record = *nbytes;
- have_read_record = to_read_record;
- if (unlikely (sread (dtp->u.p.current_unit->s, buf, &have_read_record)
- != 0))
+ have_read_record = sread (dtp->u.p.current_unit->s, buf,
+ nbytes);
+ if (unlikely (have_read_record < 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return;
dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record;
- if (unlikely (to_read_record != have_read_record))
+ if (unlikely ((ssize_t) nbytes != have_read_record))
{
/* Short read, e.g. if we hit EOF. For stream files,
we have to set the end-of-file condition. */
- generate_error (&dtp->common, LIBERROR_END, NULL);
- return;
+ hit_eof (dtp);
}
return;
}
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{
- if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
+ 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;
+ to_read_record = dtp->u.p.current_unit->bytes_left;
+ nbytes = to_read_record;
}
-
else
{
short_record = 0;
- to_read_record = *nbytes;
+ to_read_record = nbytes;
}
dtp->u.p.current_unit->bytes_left -= to_read_record;
- if (unlikely (sread (dtp->u.p.current_unit->s, buf, &to_read_record)
- != 0))
+ to_read_record = sread (dtp->u.p.current_unit->s, buf, to_read_record);
+ if (unlikely (to_read_record < 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return;
}
- if (to_read_record != *nbytes)
+ if (to_read_record != (ssize_t) nbytes)
{
/* Short read, e.g. if we hit EOF. Apparently, we read
more than was written to the last record. */
- *nbytes = to_read_record;
return;
}
if (unlikely (short_record))
{
generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
- return;
}
return;
}
until the request has been fulfilled or the record has run out
of continuation subrecords. */
- if (unlikely (dtp->u.p.current_unit->endfile == AT_ENDFILE))
- {
- generate_error (&dtp->common, LIBERROR_END, NULL);
- return;
- }
-
/* Check whether we exceed the total record length. */
if (dtp->u.p.current_unit->flags.has_recl
- && (*nbytes > (size_t) dtp->u.p.current_unit->bytes_left))
+ && ((gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left))
{
- to_read_record = (size_t) dtp->u.p.current_unit->bytes_left;
+ to_read_record = dtp->u.p.current_unit->bytes_left;
short_record = 1;
}
else
{
- to_read_record = *nbytes;
+ to_read_record = nbytes;
short_record = 0;
}
have_read_record = 0;
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_subrecord = dtp->u.p.current_unit->bytes_left_subrecord;
to_read_record -= to_read_subrecord;
}
else
dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord;
- have_read_subrecord = to_read_subrecord;
- if (unlikely (sread (dtp->u.p.current_unit->s, buf + have_read_record,
- &have_read_subrecord) != 0))
+ have_read_subrecord = sread (dtp->u.p.current_unit->s,
+ buf + have_read_record, to_read_subrecord);
+ if (unlikely (have_read_subrecord) < 0)
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return;
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 (is_internal_unit (dtp))
{
- dest = salloc_w (dtp->u.p.current_unit->s, &length);
+ dest = mem_alloc_w (dtp->u.p.current_unit->s, &length);
if (dest == NULL)
{
}
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
- dtp->u.p.size_used += (gfc_offset) length;
+ dtp->u.p.size_used += (GFC_IO_INT) length;
dtp->u.p.current_unit->strm_pos += (gfc_offset) length;
write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
{
- size_t have_written, to_write_subrecord;
+ ssize_t have_written;
+ ssize_t to_write_subrecord;
int short_record;
/* Stream I/O. */
if (is_stream_io (dtp))
{
- if (unlikely (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0))
+ have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes);
+ if (unlikely (have_written < 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->strm_pos += (gfc_offset) have_written;
return SUCCESS;
}
if (buf == NULL && nbytes == 0)
return SUCCESS;
- if (unlikely (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0))
+ have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes);
+ if (unlikely (have_written < 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;
+ dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written;
+ dtp->u.p.current_unit->bytes_left -= (gfc_offset) have_written;
return SUCCESS;
}
dtp->u.p.current_unit->bytes_left_subrecord -=
(gfc_offset) to_write_subrecord;
- if (unlikely (swrite (dtp->u.p.current_unit->s, buf + have_written,
- &to_write_subrecord) != 0))
+ to_write_subrecord = swrite (dtp->u.p.current_unit->s,
+ buf + have_written, to_write_subrecord);
+ if (unlikely (to_write_subrecord < 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return FAILURE;
unformatted_read (st_parameter_dt *dtp, bt type,
void *dest, int kind, size_t size, size_t nelems)
{
- size_t i, sz;
-
if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
|| kind == 1)
{
- sz = size * nelems;
if (type == BT_CHARACTER)
- sz *= GFC_SIZE_OF_CHAR_KIND(kind);
- read_block_direct (dtp, dest, &sz);
+ size *= GFC_SIZE_OF_CHAR_KIND(kind);
+ read_block_direct (dtp, dest, size * nelems);
}
else
{
char buffer[16];
char *p;
+ size_t i;
p = dest;
for (i = 0; i < nelems; i++)
{
- read_block_direct (dtp, buffer, &size);
+ read_block_direct (dtp, buffer, size);
reverse_memcpy (p, buffer, size);
p += size;
}
if (actual == expected)
return 0;
+ /* Adjust item_count before emitting error message. */
sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
- type_name (expected), dtp->u.p.item_count, type_name (actual));
+ type_name (expected), dtp->u.p.item_count - 1, type_name (actual));
format_error (dtp, f, buffer);
return 1;
}
-/* This subroutine is the main loop for a formatted data transfer
+/* This function is in the main loop for a formatted data transfer
statement. It would be natural to implement this as a coroutine
with the user program, but C makes that awkward. We loop,
processing format elements. When we actually have to transfer
data instead of just setting flags, we return control to the user
- program which calls a subroutine that supplies the address and type
+ program which calls a function that supplies the address and type
of the next element, then comes back here to process it. */
static void
-formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
- size_t size)
+formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind,
+ size_t size)
{
- char scratch[SCRATCH_SIZE];
int pos, bytes_used;
const fnode *f;
format_token t;
dtp->u.p.sf_read_comma =
dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
- dtp->u.p.line_buffer = scratch;
+ for (;;)
+ {
+ /* If reversion has occurred and there is another real data item,
+ then we have to move to the next record. */
+ if (dtp->u.p.reversion_flag && n > 0)
+ {
+ dtp->u.p.reversion_flag = 0;
+ next_record (dtp, 0);
+ }
+
+ consume_data_flag = 1;
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+ break;
+
+ f = next_format (dtp);
+ if (f == NULL)
+ {
+ /* No data descriptors left. */
+ if (unlikely (n > 0))
+ generate_error (&dtp->common, LIBERROR_FORMAT,
+ "Insufficient data descriptors in format after reversion");
+ return;
+ }
+
+ t = f->format;
+
+ bytes_used = (int)(dtp->u.p.current_unit->recl
+ - dtp->u.p.current_unit->bytes_left);
+
+ if (is_stream_io(dtp))
+ bytes_used = 0;
+
+ switch (t)
+ {
+ case FMT_I:
+ if (n == 0)
+ goto need_read_data;
+ if (require_type (dtp, BT_INTEGER, type, f))
+ return;
+ read_decimal (dtp, f, p, kind);
+ break;
+
+ case FMT_B:
+ if (n == 0)
+ goto need_read_data;
+ if (compile_options.allow_std < GFC_STD_GNU
+ && require_type (dtp, BT_INTEGER, type, f))
+ return;
+ read_radix (dtp, f, p, kind, 2);
+ break;
+
+ case FMT_O:
+ if (n == 0)
+ goto need_read_data;
+ if (compile_options.allow_std < GFC_STD_GNU
+ && require_type (dtp, BT_INTEGER, type, f))
+ return;
+ read_radix (dtp, f, p, kind, 8);
+ break;
+
+ case FMT_Z:
+ if (n == 0)
+ goto need_read_data;
+ if (compile_options.allow_std < GFC_STD_GNU
+ && require_type (dtp, BT_INTEGER, type, f))
+ return;
+ read_radix (dtp, f, p, kind, 16);
+ break;
+
+ case FMT_A:
+ if (n == 0)
+ goto need_read_data;
+
+ /* It is possible to have FMT_A with something not BT_CHARACTER such
+ as when writing out hollerith strings, so check both type
+ and kind before calling wide character routines. */
+ if (type == BT_CHARACTER && kind == 4)
+ read_a_char4 (dtp, f, p, size);
+ else
+ read_a (dtp, f, p, size);
+ break;
+
+ case FMT_L:
+ if (n == 0)
+ goto need_read_data;
+ read_l (dtp, f, p, kind);
+ break;
+
+ case FMT_D:
+ if (n == 0)
+ goto need_read_data;
+ if (require_type (dtp, BT_REAL, type, f))
+ return;
+ read_f (dtp, f, p, kind);
+ break;
+
+ case FMT_E:
+ if (n == 0)
+ goto need_read_data;
+ if (require_type (dtp, BT_REAL, type, f))
+ return;
+ read_f (dtp, f, p, kind);
+ break;
+
+ case FMT_EN:
+ if (n == 0)
+ goto need_read_data;
+ if (require_type (dtp, BT_REAL, type, f))
+ return;
+ read_f (dtp, f, p, kind);
+ break;
+
+ case FMT_ES:
+ if (n == 0)
+ goto need_read_data;
+ if (require_type (dtp, BT_REAL, type, f))
+ return;
+ read_f (dtp, f, p, kind);
+ break;
+
+ case FMT_F:
+ if (n == 0)
+ goto need_read_data;
+ if (require_type (dtp, BT_REAL, type, f))
+ return;
+ read_f (dtp, f, p, kind);
+ break;
+
+ case FMT_G:
+ if (n == 0)
+ goto need_read_data;
+ switch (type)
+ {
+ case BT_INTEGER:
+ read_decimal (dtp, f, p, kind);
+ break;
+ case BT_LOGICAL:
+ read_l (dtp, f, p, kind);
+ break;
+ case BT_CHARACTER:
+ if (kind == 4)
+ read_a_char4 (dtp, f, p, size);
+ else
+ read_a (dtp, f, p, size);
+ break;
+ case BT_REAL:
+ read_f (dtp, f, p, kind);
+ break;
+ default:
+ internal_error (&dtp->common, "formatted_transfer(): Bad type");
+ }
+ break;
+
+ case FMT_STRING:
+ consume_data_flag = 0;
+ format_error (dtp, f, "Constant string in input format");
+ return;
+
+ /* Format codes that don't transfer data. */
+ case FMT_X:
+ case FMT_TR:
+ consume_data_flag = 0;
+ dtp->u.p.skips += f->u.n;
+ pos = bytes_used + dtp->u.p.skips - 1;
+ dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1;
+ read_x (dtp, f->u.n);
+ break;
+
+ case FMT_TL:
+ case FMT_T:
+ consume_data_flag = 0;
+
+ if (f->format == FMT_TL)
+ {
+ /* Handle the special case when no bytes have been used yet.
+ Cannot go below zero. */
+ if (bytes_used == 0)
+ {
+ dtp->u.p.pending_spaces -= f->u.n;
+ dtp->u.p.skips -= f->u.n;
+ dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
+ }
+
+ pos = bytes_used - f->u.n;
+ }
+ else /* FMT_T */
+ pos = f->u.n - 1;
+
+ /* Standard 10.6.1.1: excessive left tabbing is reset to the
+ left tab limit. We do not check if the position has gone
+ beyond the end of record because a subsequent tab could
+ bring us back again. */
+ pos = pos < 0 ? 0 : pos;
+
+ dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
+ dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
+ + pos - dtp->u.p.max_pos;
+ dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
+ ? 0 : dtp->u.p.pending_spaces;
+ if (dtp->u.p.skips == 0)
+ break;
+
+ /* Adjust everything for end-of-record condition */
+ if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
+ {
+ dtp->u.p.current_unit->bytes_left -= dtp->u.p.sf_seen_eor;
+ dtp->u.p.skips -= dtp->u.p.sf_seen_eor;
+ bytes_used = pos;
+ dtp->u.p.sf_seen_eor = 0;
+ }
+ if (dtp->u.p.skips < 0)
+ {
+ if (is_internal_unit (dtp))
+ sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
+ else
+ fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
+ dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
+ dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
+ }
+ else
+ read_x (dtp, dtp->u.p.skips);
+ break;
+
+ case FMT_S:
+ consume_data_flag = 0;
+ dtp->u.p.sign_status = SIGN_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_DC:
+ consume_data_flag = 0;
+ dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA;
+ break;
+
+ case FMT_DP:
+ consume_data_flag = 0;
+ dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
+ break;
+
+ case FMT_RC:
+ consume_data_flag = 0;
+ dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
+ break;
+
+ case FMT_RD:
+ consume_data_flag = 0;
+ dtp->u.p.current_unit->round_status = ROUND_DOWN;
+ break;
+
+ case FMT_RN:
+ consume_data_flag = 0;
+ dtp->u.p.current_unit->round_status = ROUND_NEAREST;
+ break;
+
+ case FMT_RP:
+ consume_data_flag = 0;
+ dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED;
+ break;
+
+ case FMT_RU:
+ consume_data_flag = 0;
+ dtp->u.p.current_unit->round_status = ROUND_UP;
+ break;
+
+ case FMT_RZ:
+ consume_data_flag = 0;
+ dtp->u.p.current_unit->round_status = ROUND_ZERO;
+ break;
+
+ case FMT_P:
+ consume_data_flag = 0;
+ dtp->u.p.scale_factor = f->u.k;
+ break;
+
+ case FMT_DOLLAR:
+ consume_data_flag = 0;
+ dtp->u.p.seen_dollar = 1;
+ break;
+
+ case FMT_SLASH:
+ consume_data_flag = 0;
+ dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
+ next_record (dtp, 0);
+ break;
+
+ case FMT_COLON:
+ /* A colon descriptor causes us to exit this loop (in
+ particular preventing another / descriptor from being
+ processed) unless there is another data item to be
+ transferred. */
+ consume_data_flag = 0;
+ if (n == 0)
+ return;
+ break;
+
+ default:
+ internal_error (&dtp->common, "Bad format node");
+ }
+
+ /* Adjust the item count and data pointer. */
+
+ if ((consume_data_flag > 0) && (n > 0))
+ {
+ n--;
+ p = ((char *) p) + size;
+ }
+
+ dtp->u.p.skips = 0;
+
+ pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
+ dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
+ }
+
+ return;
+
+ /* Come here when we need a data descriptor but don't have one. We
+ push the current format node back onto the input, then return and
+ let the user program call us back with the data. */
+ need_read_data:
+ unget_format (dtp, f);
+}
+
+
+static void
+formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kind,
+ size_t size)
+{
+ int pos, bytes_used;
+ const fnode *f;
+ format_token t;
+ int n;
+ int consume_data_flag;
+
+ /* Change a complex data item into a pair of reals. */
+
+ n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
+ if (type == BT_COMPLEX)
+ {
+ type = BT_REAL;
+ size /= 2;
+ }
+
+ /* If there's an EOR condition, we simulate finalizing the transfer
+ by doing nothing. */
+ if (dtp->u.p.eor_condition)
+ return;
+
+ /* Set this flag so that commas in reads cause the read to complete before
+ the entire field has been read. The next read field will start right after
+ the comma in the stream. (Set to 0 for character reads). */
+ dtp->u.p.sf_read_comma =
+ dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
for (;;)
{
if (dtp->u.p.skips < 0)
{
if (is_internal_unit (dtp))
- move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
+ sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
else
- fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips);
+ fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
}
dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
goto need_data;
if (require_type (dtp, BT_INTEGER, type, f))
return;
-
- if (dtp->u.p.mode == READING)
- read_decimal (dtp, f, p, kind);
- else
- write_i (dtp, f, p, kind);
-
+ write_i (dtp, f, p, kind);
break;
case FMT_B:
if (n == 0)
goto need_data;
-
if (compile_options.allow_std < GFC_STD_GNU
&& require_type (dtp, BT_INTEGER, type, f))
return;
-
- if (dtp->u.p.mode == READING)
- read_radix (dtp, f, p, kind, 2);
- else
- write_b (dtp, f, p, kind);
-
+ write_b (dtp, f, p, kind);
break;
case FMT_O:
if (n == 0)
goto need_data;
-
if (compile_options.allow_std < GFC_STD_GNU
&& require_type (dtp, BT_INTEGER, type, f))
return;
-
- if (dtp->u.p.mode == READING)
- read_radix (dtp, f, p, kind, 8);
- else
- write_o (dtp, f, p, kind);
-
+ write_o (dtp, f, p, kind);
break;
case FMT_Z:
if (n == 0)
goto need_data;
-
if (compile_options.allow_std < GFC_STD_GNU
- && require_type (dtp, BT_INTEGER, type, f))
- return;
-
- if (dtp->u.p.mode == READING)
- read_radix (dtp, f, p, kind, 16);
- else
- write_z (dtp, f, p, kind);
-
+ && require_type (dtp, BT_INTEGER, type, f))
+ return;
+ write_z (dtp, f, p, kind);
break;
case FMT_A:
/* 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)
- {
- if (type == BT_CHARACTER && kind == 4)
- read_a_char4 (dtp, f, p, size);
- else
- read_a (dtp, f, p, size);
- }
+ if (type == BT_CHARACTER && kind == 4)
+ write_a_char4 (dtp, f, p, size);
else
- {
- if (type == BT_CHARACTER && kind == 4)
- write_a_char4 (dtp, f, p, size);
- else
- write_a (dtp, f, p, size);
- }
+ write_a (dtp, f, p, size);
break;
case FMT_L:
if (n == 0)
goto need_data;
-
- if (dtp->u.p.mode == READING)
- read_l (dtp, f, p, kind);
- else
- write_l (dtp, f, p, kind);
-
+ write_l (dtp, f, p, kind);
break;
case FMT_D:
goto need_data;
if (require_type (dtp, BT_REAL, type, f))
return;
-
- if (dtp->u.p.mode == READING)
- read_f (dtp, f, p, kind);
- else
- write_d (dtp, f, p, kind);
-
+ write_d (dtp, f, p, kind);
break;
case FMT_E:
goto need_data;
if (require_type (dtp, BT_REAL, type, f))
return;
-
- if (dtp->u.p.mode == READING)
- read_f (dtp, f, p, kind);
- else
- write_e (dtp, f, p, kind);
+ write_e (dtp, f, p, kind);
break;
case FMT_EN:
goto need_data;
if (require_type (dtp, BT_REAL, type, f))
return;
-
- if (dtp->u.p.mode == READING)
- read_f (dtp, f, p, kind);
- else
- write_en (dtp, f, p, kind);
-
+ write_en (dtp, f, p, kind);
break;
case FMT_ES:
goto need_data;
if (require_type (dtp, BT_REAL, type, f))
return;
-
- if (dtp->u.p.mode == READING)
- read_f (dtp, f, p, kind);
- else
- write_es (dtp, f, p, kind);
-
+ write_es (dtp, f, p, kind);
break;
case FMT_F:
goto need_data;
if (require_type (dtp, BT_REAL, type, f))
return;
-
- if (dtp->u.p.mode == READING)
- read_f (dtp, f, p, kind);
- else
- write_f (dtp, f, p, kind);
-
+ write_f (dtp, f, p, kind);
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, kind);
- break;
- case BT_LOGICAL:
- read_l (dtp, f, p, kind);
- break;
- case BT_CHARACTER:
- if (kind == 4)
- read_a_char4 (dtp, f, p, size);
- else
- read_a (dtp, f, p, size);
- break;
- case BT_REAL:
- read_f (dtp, f, p, kind);
- break;
- default:
- goto bad_type;
- }
- else
- switch (type)
- {
+ switch (type)
+ {
case BT_INTEGER:
write_i (dtp, f, p, kind);
break;
break;
case BT_REAL:
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);
- }
+ write_real_g0 (dtp, p, kind, f->u.real.d);
else
write_d (dtp, f, p, kind);
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;
dtp->u.p.skips += f->u.n;
pos = bytes_used + dtp->u.p.skips - 1;
dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1;
-
/* Writes occur just before the switch on f->format, above, so
that trailing blanks are suppressed, unless we are doing a
non-advancing write in which case we want to output the blanks
now. */
- if (dtp->u.p.mode == WRITING
- && dtp->u.p.advance_status == ADVANCE_NO)
+ if (dtp->u.p.advance_status == ADVANCE_NO)
{
write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
}
-
- if (dtp->u.p.mode == READING)
- read_x (dtp, f->u.n);
-
break;
case FMT_TL:
pos = bytes_used - f->u.n;
}
else /* FMT_T */
- {
- if (dtp->u.p.mode == READING)
- pos = f->u.n - 1;
- else
- pos = f->u.n - dtp->u.p.pending_spaces - 1;
- }
+ pos = f->u.n - dtp->u.p.pending_spaces - 1;
/* Standard 10.6.1.1: excessive left tabbing is reset to the
left tab limit. We do not check if the position has gone
+ 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;
-
- /* Writes occur just before the switch on f->format, above, so that
- trailing blanks are suppressed. */
- if (dtp->u.p.mode == READING)
- {
- /* Adjust everything for end-of-record condition */
- if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
- {
- if (dtp->u.p.sf_seen_eor == 2)
- {
- /* The EOR was a CRLF (two bytes wide). */
- dtp->u.p.current_unit->bytes_left -= 2;
- dtp->u.p.skips -= 2;
- }
- else
- {
- /* The EOR marker was only one byte wide. */
- 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:
dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
break;
+ case FMT_RC:
+ consume_data_flag = 0;
+ dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
+ break;
+
+ case FMT_RD:
+ consume_data_flag = 0;
+ dtp->u.p.current_unit->round_status = ROUND_DOWN;
+ break;
+
+ case FMT_RN:
+ consume_data_flag = 0;
+ dtp->u.p.current_unit->round_status = ROUND_NEAREST;
+ break;
+
+ case FMT_RP:
+ consume_data_flag = 0;
+ dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED;
+ break;
+
+ case FMT_RU:
+ consume_data_flag = 0;
+ dtp->u.p.current_unit->round_status = ROUND_UP;
+ break;
+
+ case FMT_RZ:
+ consume_data_flag = 0;
+ dtp->u.p.current_unit->round_status = ROUND_ZERO;
+ break;
+
case FMT_P:
consume_data_flag = 0;
dtp->u.p.scale_factor = f->u.k;
internal_error (&dtp->common, "Bad format node");
}
- /* Free a buffer that we had to allocate during a sequential
- formatted read of a block that was larger than the static
- buffer. */
-
- if (dtp->u.p.line_buffer != scratch)
- {
- free_mem (dtp->u.p.line_buffer);
- dtp->u.p.line_buffer = scratch;
- }
-
/* Adjust the item count and data pointer. */
if ((consume_data_flag > 0) && (n > 0))
- {
- n--;
- p = ((char *) p) + size;
- }
-
- if (dtp->u.p.mode == READING)
- dtp->u.p.skips = 0;
+ {
+ n--;
+ p = ((char *) p) + size;
+ }
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;
unget_format (dtp, f);
}
+ /* This function is first called from data_init_transfer to initiate the loop
+ over each item in the format, transferring data as required. Subsequent
+ calls to this function occur for each data item foound in the READ/WRITE
+ statement. The item_count is incremented for each call. Since the first
+ call is from data_transfer_init, the item_count is always one greater than
+ the actual count number of the item being transferred. */
+
static void
formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
size_t size, size_t nelems)
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++)
+ if (dtp->u.p.mode == READING)
+ {
+ /* Big loop over all the elements. */
+ for (elem = 0; elem < nelems; elem++)
+ {
+ dtp->u.p.item_count++;
+ formatted_transfer_scalar_read (dtp, type, tmp + stride*elem, kind, size);
+ }
+ }
+ else
{
- dtp->u.p.item_count++;
- formatted_transfer_scalar (dtp, type, tmp + stride*elem, kind, size);
+ /* Big loop over all the elements. */
+ for (elem = 0; elem < nelems; elem++)
+ {
+ dtp->u.p.item_count++;
+ formatted_transfer_scalar_write (dtp, type, tmp + stride*elem, kind, size);
+ }
}
}
-
/* Data transfer entry points. The type of the data entity is
implicit in the subroutine call. This prevents us from having to
share a common enum with the compiler. */
for (n = 0; n < rank; n++)
{
count[n] = 0;
- 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;
+ stride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(desc,n);
+ extent[n] = GFC_DESCRIPTOR_EXTENT(desc,n);
/* If the extent of even one dimension is zero, then the entire
array section contains zero elements, so we return after writing
stride0 = stride[0];
- /* If the innermost dimension has stride 1, we can do the transfer
+ /* If the innermost dimension has a stride of 1, we can do the transfer
in contiguous chunks. */
- if (stride0 == 1)
+ if (stride0 == size)
tsize = extent[0];
else
tsize = 1;
while (data)
{
dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
- data += stride0 * size * tsize;
+ data += stride0 * tsize;
count[0] += tsize;
n = 0;
while (count[n] == extent[n])
{
count[n] = 0;
- data -= stride[n] * extent[n] * size;
+ data -= stride[n] * extent[n];
n++;
if (n == rank)
{
else
{
count[n]++;
- data += stride[n] * size;
+ data += stride[n];
}
}
}
static void
us_read (st_parameter_dt *dtp, int continued)
{
- size_t n, nr;
+ ssize_t n, 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;
-
- if (unlikely (sread (dtp->u.p.current_unit->s, &i, &n) != 0))
+ nr = sread (dtp->u.p.current_unit->s, &i, n);
+ if (unlikely (nr < 0))
{
generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
return;
}
-
- if (n == 0)
+ else if (nr == 0)
{
- dtp->u.p.current_unit->endfile = AT_ENDFILE;
+ hit_eof (dtp);
return; /* end of file */
}
-
- if (unlikely (n != nr))
+ else if (unlikely (n != nr))
{
generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
return;
static void
us_write (st_parameter_dt *dtp, int continued)
{
- size_t nbytes;
+ ssize_t nbytes;
gfc_offset dummy;
dummy = 0;
else
nbytes = compile_options.record_marker ;
- if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0)
+ if (swrite (dtp->u.p.current_unit->s, &dummy, nbytes) != nbytes)
generate_error (&dtp->common, LIBERROR_OS, NULL);
/* For sequential unformatted, if RECL= was not specified in the OPEN
ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
- /* 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));
+ memset (&dtp->u.p, 0, sizeof (dtp->u.p));
dtp->u.p.ionml = ionml;
dtp->u.p.mode = read_flag ? READING : WRITING;
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");
+ "Bad unit number in statement");
return;
}
memset (&u_flags, '\0', sizeof (u_flags));
/* Check the decimal mode. */
dtp->u.p.current_unit->decimal_status
= !(cf & IOPARM_DT_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
- find_option (&dtp->common, dtp->u.p.decimal, dtp->u.p.decimal_len,
+ find_option (&dtp->common, dtp->decimal, dtp->decimal_len,
decimal_opt, "Bad DECIMAL parameter in data transfer "
"statement");
if (dtp->u.p.current_unit->decimal_status == DECIMAL_UNSPECIFIED)
dtp->u.p.current_unit->decimal_status = dtp->u.p.current_unit->flags.decimal;
+ /* Check the round mode. */
+ dtp->u.p.current_unit->round_status
+ = !(cf & IOPARM_DT_HAS_ROUND) ? ROUND_UNSPECIFIED :
+ find_option (&dtp->common, dtp->round, dtp->round_len,
+ round_opt, "Bad ROUND parameter in data transfer "
+ "statement");
+
+ if (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED)
+ dtp->u.p.current_unit->round_status = dtp->u.p.current_unit->flags.round;
+
/* 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,
+ find_option (&dtp->common, dtp->sign, dtp->sign_len, sign_opt,
"Bad SIGN parameter in data transfer statement");
if (dtp->u.p.sign_status == SIGN_UNSPECIFIED)
/* 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,
+ find_option (&dtp->common, dtp->blank, dtp->blank_len,
blank_opt,
"Bad BLANK parameter in data transfer statement");
/* Check the delim mode. */
dtp->u.p.current_unit->delim_status
= !(cf & IOPARM_DT_HAS_DELIM) ? DELIM_UNSPECIFIED :
- find_option (&dtp->common, dtp->u.p.delim, dtp->u.p.delim_len,
+ find_option (&dtp->common, dtp->delim, dtp->delim_len,
delim_opt, "Bad DELIM parameter in data transfer statement");
if (dtp->u.p.current_unit->delim_status == DELIM_UNSPECIFIED)
/* Check the pad mode. */
dtp->u.p.current_unit->pad_status
= !(cf & IOPARM_DT_HAS_PAD) ? PAD_UNSPECIFIED :
- find_option (&dtp->common, dtp->u.p.pad, dtp->u.p.pad_len, pad_opt,
+ find_option (&dtp->common, dtp->pad, dtp->pad_len, pad_opt,
"Bad PAD parameter in data transfer statement");
if (dtp->u.p.current_unit->pad_status == PAD_UNSPECIFIED)
dtp->u.p.current_unit->pad_status = dtp->u.p.current_unit->flags.pad;
+ /* Check to see if we might be reading what we wrote before */
+
+ if (dtp->u.p.mode != dtp->u.p.current_unit->mode
+ && !is_internal_unit (dtp))
+ {
+ int pos = fbuf_reset (dtp->u.p.current_unit);
+ if (pos != 0)
+ sseek (dtp->u.p.current_unit->s, pos, SEEK_CUR);
+ sflush(dtp->u.p.current_unit->s);
+ }
+
+ /* Check the POS= specifier: that it is in range and that it is used with a
+ unit that has been connected for STREAM access. F2003 9.5.1.10. */
+
+ if (((cf & IOPARM_DT_HAS_POS) != 0))
+ {
+ if (is_stream_io (dtp))
+ {
+
+ if (dtp->pos <= 0)
+ {
+ generate_error (&dtp->common, LIBERROR_BAD_OPTION,
+ "POS=specifier must be positive");
+ return;
+ }
+
+ if (dtp->pos >= dtp->u.p.current_unit->maxrec)
+ {
+ generate_error (&dtp->common, LIBERROR_BAD_OPTION,
+ "POS=specifier too large");
+ return;
+ }
+
+ dtp->rec = dtp->pos;
+
+ if (dtp->u.p.mode == READING)
+ {
+ /* Reset the endfile flag; if we hit EOF during reading
+ we'll set the flag and generate an error at that point
+ rather than worrying about it here. */
+ dtp->u.p.current_unit->endfile = NO_ENDFILE;
+ }
+
+ if (dtp->pos != dtp->u.p.current_unit->strm_pos)
+ {
+ fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
+ if (sseek (dtp->u.p.current_unit->s, dtp->pos - 1, SEEK_SET) < 0)
+ {
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
+ return;
+ }
+ dtp->u.p.current_unit->strm_pos = dtp->pos;
+ }
+ }
+ else
+ {
+ generate_error (&dtp->common, LIBERROR_BAD_OPTION,
+ "POS=specifier not allowed, "
+ "Try OPEN with ACCESS='stream'");
+ return;
+ }
+ }
+
+
/* Sanity checks on the record number. */
if ((cf & IOPARM_DT_HAS_REC) != 0)
{
return;
}
- /* Check to see if we might be reading what we wrote before */
+ /* Make sure format buffer is reset. */
+ if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
+ fbuf_reset (dtp->u.p.current_unit);
- 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. */
}
/* Position the file. */
- 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, LIBERROR_OS, NULL);
- return;
- }
- }
- else
+ if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
+ * dtp->u.p.current_unit->recl, SEEK_SET) < 0)
{
- 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;
- }
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
+ return;
}
- }
+ /* TODO: This is required to maintain compatibility between
+ 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
- /* 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))
- struncate(dtp->u.p.current_unit->s);
+ if (is_stream_io (dtp))
+ dtp->u.p.current_unit->strm_pos = dtp->rec;
+
+ /* TODO: Un-comment this code when ABI changes from 4.3.
+ if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
+ {
+ generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
+ "Record number not allowed for stream access "
+ "data transfer");
+ return;
+ } */
+ }
/* Bugware for badly written mixed C-Fortran I/O. */
flush_if_preconnected(dtp->u.p.current_unit->s);
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;
- empty = empty || (desc->dim[i].ubound < desc->dim[i].lbound);
+ ls[i].idx = GFC_DESCRIPTOR_LBOUND(desc,i);
+ ls[i].start = GFC_DESCRIPTOR_LBOUND(desc,i);
+ ls[i].end = GFC_DESCRIPTOR_UBOUND(desc,i);
+ ls[i].step = GFC_DESCRIPTOR_STRIDE(desc,i);
+ empty = empty || (GFC_DESCRIPTOR_UBOUND(desc,i)
+ < GFC_DESCRIPTOR_LBOUND(desc,i));
- if (desc->dim[i].stride > 0)
+ if (GFC_DESCRIPTOR_STRIDE(desc,i) > 0)
{
- index += (desc->dim[i].ubound - desc->dim[i].lbound)
- * desc->dim[i].stride;
+ index += (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
+ * GFC_DESCRIPTOR_STRIDE(desc,i);
}
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;
+ index -= (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
+ * GFC_DESCRIPTOR_STRIDE(desc,i);
+ *start_record -= (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
+ * GFC_DESCRIPTOR_STRIDE(desc,i);
}
}
position. */
static void
-skip_record (st_parameter_dt *dtp, size_t bytes)
+skip_record (st_parameter_dt *dtp, ssize_t bytes)
{
- gfc_offset new;
- size_t rlength;
- static const size_t MAX_READ = 4096;
+ ssize_t rlength, readb;
+ static const ssize_t MAX_READ = 4096;
char p[MAX_READ];
dtp->u.p.current_unit->bytes_left_subrecord += 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_subrecord;
-
/* Direct access files do not generate END conditions,
only I/O errors. */
- if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
+ if (sseek (dtp->u.p.current_unit->s,
+ dtp->u.p.current_unit->bytes_left_subrecord, SEEK_CUR) < 0)
generate_error (&dtp->common, LIBERROR_OS, NULL);
+
+ dtp->u.p.current_unit->bytes_left_subrecord = 0;
}
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;
+ (MAX_READ < dtp->u.p.current_unit->bytes_left_subrecord) ?
+ MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord;
- if (sread (dtp->u.p.current_unit->s, p, &rlength) != 0)
+ readb = sread (dtp->u.p.current_unit->s, p, rlength);
+ if (readb < 0)
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return;
}
- dtp->u.p.current_unit->bytes_left_subrecord -= rlength;
+ dtp->u.p.current_unit->bytes_left_subrecord -= readb;
}
}
/* Space to the next record for read mode. */
static void
-next_record_r (st_parameter_dt *dtp)
+next_record_r (st_parameter_dt *dtp, int done)
{
gfc_offset record;
int bytes_left;
- size_t length;
char p;
+ int cc;
switch (current_mode (dtp))
{
case FORMATTED_DIRECT:
case UNFORMATTED_DIRECT:
- skip_record (dtp, 0);
+ skip_record (dtp, dtp->u.p.current_unit->bytes_left);
break;
case FORMATTED_STREAM:
case FORMATTED_SEQUENTIAL:
- length = 1;
- /* sf_read has already terminated input because of an '\n' */
+ /* read_sf has already terminated input because of an '\n', or
+ we have hit EOF. */
if (dtp->u.p.sf_seen_eor)
{
dtp->u.p.sf_seen_eor = 0;
record = next_array_record (dtp, dtp->u.p.current_unit->ls,
&finished);
+ if (!done && finished)
+ hit_eof (dtp);
/* Now seek to this record. */
record = record * dtp->u.p.current_unit->recl;
- if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
+ if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
break;
bytes_left = (int) dtp->u.p.current_unit->bytes_left;
bytes_left = min_off (bytes_left,
file_length (dtp->u.p.current_unit->s)
- - file_position (dtp->u.p.current_unit->s));
+ - stell (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)
+ bytes_left, SEEK_CUR) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
break;
}
break;
}
- else do
+ else
{
- if (sread (dtp->u.p.current_unit->s, &p, &length) != 0)
+ do
{
- generate_error (&dtp->common, LIBERROR_OS, NULL);
- break;
- }
-
- if (length == 0)
- {
- dtp->u.p.current_unit->endfile = AT_ENDFILE;
- break;
+ errno = 0;
+ cc = fbuf_getc (dtp->u.p.current_unit);
+ if (cc == EOF)
+ {
+ if (errno != 0)
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
+ else
+ {
+ if (is_stream_io (dtp)
+ || dtp->u.p.current_unit->pad_status == PAD_NO
+ || dtp->u.p.current_unit->bytes_left
+ == dtp->u.p.current_unit->recl)
+ hit_eof (dtp);
+ }
+ break;
+ }
+
+ if (is_stream_io (dtp))
+ dtp->u.p.current_unit->strm_pos++;
+
+ p = (char) cc;
}
-
- 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
- && !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 and of choosing the correct size. */
-inline static int
+static int
write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
{
size_t len;
{
case sizeof (GFC_INTEGER_4):
buf4 = buf;
- return swrite (dtp->u.p.current_unit->s, &buf4, &len);
+ 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);
+ return swrite (dtp->u.p.current_unit->s, &buf8, len);
break;
default:
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);
+ 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);
+ return swrite (dtp->u.p.current_unit->s, p, len);
break;
default:
static void
next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
{
- gfc_offset c, m, m_write;
- size_t record_marker;
+ gfc_offset m, m_write, 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. */
else
m_write = m;
- if (unlikely (write_us_marker (dtp, m_write) != 0))
+ if (unlikely (write_us_marker (dtp, m_write) < 0))
goto io_error;
if (compile_options.record_marker == 0)
/* Seek to the head and overwrite the bogus length with the real
length. */
- if (unlikely (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
- == FAILURE))
+ if (unlikely (sseek (dtp->u.p.current_unit->s, - m - 2 * record_marker,
+ SEEK_CUR) < 0))
goto io_error;
if (next_subrecord)
else
m_write = m;
- if (unlikely (write_us_marker (dtp, m_write) != 0))
+ if (unlikely (write_us_marker (dtp, m_write) < 0))
goto io_error;
/* Seek past the end of the current record. */
- if (unlikely (sseek (dtp->u.p.current_unit->s, c + record_marker)
- == FAILURE))
+ if (unlikely (sseek (dtp->u.p.current_unit->s, m + record_marker,
+ SEEK_CUR) < 0))
goto io_error;
return;
}
+
+/* Utility function like memset() but operating on streams. Return
+ value is same as for POSIX write(). */
+
+static ssize_t
+sset (stream * s, int c, ssize_t nbyte)
+{
+ static const int WRITE_CHUNK = 256;
+ char p[WRITE_CHUNK];
+ ssize_t bytes_left, trans;
+
+ if (nbyte < WRITE_CHUNK)
+ memset (p, c, nbyte);
+ else
+ memset (p, c, WRITE_CHUNK);
+
+ bytes_left = nbyte;
+ while (bytes_left > 0)
+ {
+ trans = (bytes_left < WRITE_CHUNK) ? bytes_left : WRITE_CHUNK;
+ trans = swrite (s, p, trans);
+ if (trans <= 0)
+ return trans;
+ bytes_left -= trans;
+ }
+
+ return nbyte - bytes_left;
+}
+
/* Position to the next record in write mode. */
static void
gfc_offset m, record, max_pos;
int length;
- /* 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;
if (dtp->u.p.current_unit->bytes_left == 0)
break;
+ fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
+ fbuf_flush (dtp->u.p.current_unit, WRITING);
if (sset (dtp->u.p.current_unit->s, ' ',
- dtp->u.p.current_unit->bytes_left) == FAILURE)
+ dtp->u.p.current_unit->bytes_left)
+ != dtp->u.p.current_unit->bytes_left)
goto io_error;
break;
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)
+ if (sset (dtp->u.p.current_unit->s, 0, length) != length)
goto io_error;
}
break;
{
length = (int) (max_pos - m);
if (sseek (dtp->u.p.current_unit->s,
- file_position (dtp->u.p.current_unit->s)
- + length) == FAILURE)
+ length, SEEK_CUR) < 0)
{
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)
+ if (sset (dtp->u.p.current_unit->s, ' ', length) != length)
{
generate_error (&dtp->common, LIBERROR_END, NULL);
return;
/* Now seek to this record */
record = record * dtp->u.p.current_unit->recl;
- if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
+ if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
return;
{
length = (int) (max_pos - m);
if (sseek (dtp->u.p.current_unit->s,
- file_position (dtp->u.p.current_unit->s)
- + length) == FAILURE)
+ length, SEEK_CUR) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
return;
length = (int) dtp->u.p.current_unit->bytes_left;
}
- if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
+ if (sset (dtp->u.p.current_unit->s, ' ', length) != length)
{
generate_error (&dtp->common, LIBERROR_END, NULL);
return;
}
else
{
- size_t len;
- const char crlf[] = "\r\n";
-
#ifdef HAVE_CRLF
- len = 2;
+ const int len = 2;
#else
- len = 1;
+ const int len = 1;
#endif
- if (swrite (dtp->u.p.current_unit->s, &crlf[2-len], &len) != 0)
- goto io_error;
-
+ fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
+ char * p = fbuf_alloc (dtp->u.p.current_unit, len);
+ if (!p)
+ goto io_error;
+#ifdef HAVE_CRLF
+ *(p++) = '\r';
+#endif
+ *p = '\n';
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);
+ unit_truncate (dtp->u.p.current_unit,
+ dtp->u.p.current_unit->strm_pos - 1,
+ &dtp->common);
}
}
dtp->u.p.current_unit->read_bad = 0;
if (dtp->u.p.mode == READING)
- next_record_r (dtp);
+ next_record_r (dtp, done);
else
next_record_w (dtp, done);
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);
+ fp = stell (dtp->u.p.current_unit->s);
/* Calculate next record, rounding up partial records. */
dtp->u.p.current_unit->last_record =
(fp + dtp->u.p.current_unit->recl - 1) /
if (!done)
pre_position (dtp);
+
+ fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
}
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;
+ *dtp->size = dtp->u.p.size_used;
if (dtp->u.p.eor_condition)
{
}
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
- return;
+ {
+ if (dtp->u.p.current_unit && current_mode (dtp) == UNFORMATTED_SEQUENTIAL)
+ dtp->u.p.current_unit->current_record = 0;
+ return;
+ }
if ((dtp->u.p.ionml != NULL)
&& (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
{
finish_list_read (dtp);
- sfree (dtp->u.p.current_unit->s);
return;
}
&& 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)
- {
- flush (dtp->u.p.current_unit->s);
- sfree (dtp->u.p.current_unit->s);
- }
return;
}
if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar)
{
+ fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
dtp->u.p.seen_dollar = 0;
- fbuf_flush (dtp->u.p.current_unit, 1);
- sfree (dtp->u.p.current_unit->s);
return;
}
- 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);
+ fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
return;
}
+ else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
+ && dtp->u.p.mode == WRITING && !is_internal_unit (dtp))
+ fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
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
size_t size, size_t nelems)
{
if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
- *dtp->iolength += (GFC_IO_INT) size * nelems;
+ *dtp->iolength += (GFC_IO_INT) (size * nelems);
}
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 ();
}
library_start (&dtp->common);
data_transfer_init (dtp, 1);
-
- /* 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 NO_ENDFILE:
- break;
-
- case AT_ENDFILE:
- if (!is_internal_unit (dtp))
- {
- 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, LIBERROR_ENDFILE, NULL);
- dtp->u.p.current_unit->current_record = 0;
- break;
- }
}
extern void st_read_done (st_parameter_dt *);
st_read_done (st_parameter_dt *dtp)
{
finalize_transfer (dtp);
- free_format_data (dtp);
+ if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
+ free_format_data (dtp->u.p.fmt);
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);
case NO_ENDFILE:
/* Get rid of whatever is after this record. */
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, LIBERROR_OS, NULL);
- }
+ unit_truncate (dtp->u.p.current_unit,
+ stell (dtp->u.p.current_unit->s),
+ &dtp->common);
dtp->u.p.current_unit->endfile = AT_ENDFILE;
break;
}
- free_format_data (dtp);
+ if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
+ free_format_data (dtp->u.p.fmt);
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);
for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
- nml->dim[n].stride = stride;
- nml->dim[n].lbound = lbound;
- nml->dim[n].ubound = ubound;
+ GFC_DIMENSION_SET(nml->dim[n],lbound,ubound,stride);
}
/* Reverse memcpy - used for byte swapping. */
for (i=0; i<n; i++)
*(d++) = *(s--);
}
+
+
+/* Once upon a time, a poor innocent Fortran program was reading a
+ file, when suddenly it hit the end-of-file (EOF). Unfortunately
+ the OS doesn't tell whether we're at the EOF or whether we already
+ went past it. Luckily our hero, libgfortran, keeps track of this.
+ Call this function when you detect an EOF condition. See Section
+ 9.10.2 in F2003. */
+
+void
+hit_eof (st_parameter_dt * dtp)
+{
+ dtp->u.p.current_unit->flags.position = POSITION_APPEND;
+
+ if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+ switch (dtp->u.p.current_unit->endfile)
+ {
+ case NO_ENDFILE:
+ case AT_ENDFILE:
+ generate_error (&dtp->common, LIBERROR_END, NULL);
+ if (!is_internal_unit (dtp))
+ {
+ dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
+ dtp->u.p.current_unit->current_record = 0;
+ }
+ else
+ dtp->u.p.current_unit->endfile = AT_ENDFILE;
+ break;
+
+ case AFTER_ENDFILE:
+ generate_error (&dtp->common, LIBERROR_ENDFILE, NULL);
+ dtp->u.p.current_unit->current_record = 0;
+ break;
+ }
+ else
+ {
+ /* Non-sequential files don't have an ENDFILE record, so we
+ can't be at AFTER_ENDFILE. */
+ dtp->u.p.current_unit->endfile = AT_ENDFILE;
+ generate_error (&dtp->common, LIBERROR_END, NULL);
+ dtp->u.p.current_unit->current_record = 0;
+ }
+}
OSDN Git Service
