-/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
- Free Software Foundation, Inc.
+/* Copyright (C) 2002-2018 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).
+This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
#include "format.h"
#include "unix.h"
#include <string.h>
-#include <assert.h>
-#include <stdlib.h>
#include <errno.h>
For other sorts of data transfer, there are zero or more data
transfer statement that depend on the format of the data transfer
- statement.
+ statement. For READ (and for backwards compatibily: for WRITE), one has
transfer_integer
transfer_logical
transfer_character_wide
transfer_real
transfer_complex
+ transfer_real128
+ transfer_complex128
- These subroutines do not return status.
+ and for WRITE
+
+ transfer_integer_write
+ transfer_logical_write
+ transfer_character_write
+ transfer_character_wide_write
+ transfer_real_write
+ transfer_complex_write
+ transfer_real128_write
+ transfer_complex128_write
+
+ These subroutines do not return status. The *128 functions
+ are in the file transfer128.c.
The last call is a call to st_[read|write]_done(). While
something can easily go wrong with the initial st_read() or
extern void transfer_integer (st_parameter_dt *, void *, int);
export_proto(transfer_integer);
+extern void transfer_integer_write (st_parameter_dt *, void *, int);
+export_proto(transfer_integer_write);
+
extern void transfer_real (st_parameter_dt *, void *, int);
export_proto(transfer_real);
+extern void transfer_real_write (st_parameter_dt *, void *, int);
+export_proto(transfer_real_write);
+
extern void transfer_logical (st_parameter_dt *, void *, int);
export_proto(transfer_logical);
-extern void transfer_character (st_parameter_dt *, void *, int);
+extern void transfer_logical_write (st_parameter_dt *, void *, int);
+export_proto(transfer_logical_write);
+
+extern void transfer_character (st_parameter_dt *, void *, gfc_charlen_type);
export_proto(transfer_character);
-extern void transfer_character_wide (st_parameter_dt *, void *, int, int);
+extern void transfer_character_write (st_parameter_dt *, void *, gfc_charlen_type);
+export_proto(transfer_character_write);
+
+extern void transfer_character_wide (st_parameter_dt *, void *, gfc_charlen_type, int);
export_proto(transfer_character_wide);
+extern void transfer_character_wide_write (st_parameter_dt *,
+ void *, gfc_charlen_type, int);
+export_proto(transfer_character_wide_write);
+
extern void transfer_complex (st_parameter_dt *, void *, int);
export_proto(transfer_complex);
+extern void transfer_complex_write (st_parameter_dt *, void *, int);
+export_proto(transfer_complex_write);
+
extern void transfer_array (st_parameter_dt *, gfc_array_char *, int,
gfc_charlen_type);
export_proto(transfer_array);
+extern void transfer_array_write (st_parameter_dt *, gfc_array_char *, int,
+ gfc_charlen_type);
+export_proto(transfer_array_write);
+
+/* User defined derived type input/output. */
+extern void
+transfer_derived (st_parameter_dt *dtp, void *dtio_source, void *dtio_proc);
+export_proto(transfer_derived);
+
+extern void
+transfer_derived_write (st_parameter_dt *dtp, void *dtio_source, void *dtio_proc);
+export_proto(transfer_derived_write);
+
static void us_read (st_parameter_dt *, int);
static void us_write (st_parameter_dt *, int);
static void next_record_r_unf (st_parameter_dt *, int);
/* 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,
- and we don't want to read too much. If we read too much, we might
- have to do a physical seek backwards depending on how much data is
- present, and devices like terminals aren't seekable and would cause
- an I/O error.
-
- Given this, the solution is to read a byte at a time, stopping if
- we hit the newline. For small allocations, we use a static buffer.
- For larger allocations, we are forced to allocate memory on the
- heap. Hopefully this won't happen very often. */
-
/* Read sequential file - internal unit */
static char *
-read_sf_internal (st_parameter_dt *dtp, int * length)
+read_sf_internal (st_parameter_dt *dtp, size_t *length)
{
static char *empty_string[0];
- char *base;
- int lorig;
+ char *base = NULL;
+ size_t lorig;
/* Zero size array gives internal unit len of 0. Nothing to read. */
if (dtp->internal_unit_len == 0
{
*length = 0;
/* Just return something that isn't a NULL pointer, otherwise the
- caller thinks an error occured. */
+ caller thinks an error occurred. */
return (char*) empty_string;
}
+ /* There are some cases with mixed DTIO where we have read a character
+ and saved it in the last character buffer, so we need to backup. */
+ if (unlikely (dtp->u.p.current_unit->child_dtio > 0 &&
+ dtp->u.p.current_unit->last_char != EOF - 1))
+ {
+ dtp->u.p.current_unit->last_char = EOF - 1;
+ sseek (dtp->u.p.current_unit->s, -1, SEEK_CUR);
+ }
+
lorig = *length;
- base = mem_alloc_r (dtp->u.p.current_unit->s, length);
+ if (is_char4_unit(dtp))
+ {
+ gfc_char4_t *p = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s,
+ length);
+ base = fbuf_alloc (dtp->u.p.current_unit, lorig);
+ for (size_t i = 0; i < *length; i++, p++)
+ base[i] = *p > 255 ? '?' : (unsigned char) *p;
+ }
+ else
+ base = mem_alloc_r (dtp->u.p.current_unit->s, length);
+
if (unlikely (lorig > *length))
{
hit_eof (dtp);
dtp->u.p.current_unit->bytes_left -= *length;
- if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
- dtp->u.p.size_used += (GFC_IO_INT) *length;
+ if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
+ dtp->u.p.current_unit->has_size)
+ dtp->u.p.current_unit->size_used += (GFC_IO_INT) *length;
return base;
}
+/* When reading sequential formatted records we have a problem. We
+ don't know how long the line is until we read the trailing newline,
+ and we don't want to read too much. If we read too much, we might
+ have to do a physical seek backwards depending on how much data is
+ present, and devices like terminals aren't seekable and would cause
+ an I/O error.
+
+ Given this, the solution is to read a byte at a time, stopping if
+ we hit the newline. For small allocations, we use a static buffer.
+ For larger allocations, we are forced to allocate memory on the
+ heap. Hopefully this won't happen very often. */
+
/* Read sequential file - external unit */
static char *
-read_sf (st_parameter_dt *dtp, int * length)
+read_sf (st_parameter_dt *dtp, size_t *length)
{
static char *empty_string[0];
- char *base, *p, q;
- int n, lorig, seen_comma;
+ size_t lorig, n;
+ int q, q2;
+ int seen_comma;
/* If we have seen an eor previously, return a length of 0. The
caller is responsible for correctly padding the input field. */
{
*length = 0;
/* Just return something that isn't a NULL pointer, otherwise the
- caller thinks an error occured. */
+ caller thinks an error occurred. */
return (char*) empty_string;
}
+ /* There are some cases with mixed DTIO where we have read a character
+ and saved it in the last character buffer, so we need to backup. */
+ if (unlikely (dtp->u.p.current_unit->child_dtio > 0 &&
+ dtp->u.p.current_unit->last_char != EOF - 1))
+ {
+ dtp->u.p.current_unit->last_char = EOF - 1;
+ fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR);
+ }
+
n = seen_comma = 0;
/* Read data into format buffer and scan through it. */
lorig = *length;
- base = p = fbuf_read (dtp->u.p.current_unit, length);
- if (base == NULL)
- return NULL;
while (n < *length)
{
- q = *p;
-
- if (q == '\n' || q == '\r')
+ q = fbuf_getc (dtp->u.p.current_unit);
+ if (q == EOF)
+ break;
+ else if (dtp->u.p.current_unit->flags.cc != CC_NONE
+ && (q == '\n' || q == '\r'))
{
/* Unexpected end of line. Set the position. */
- 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;
-
+
/* If we encounter a CR, it might be a CRLF. */
if (q == '\r') /* Probably a CRLF */
{
- /* 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)
- {
- dtp->u.p.sf_seen_eor = 2;
- fbuf_seek (dtp->u.p.current_unit, 1 ,SEEK_CUR);
- }
+ /* See if there is an LF. */
+ q2 = fbuf_getc (dtp->u.p.current_unit);
+ if (q2 == '\n')
+ dtp->u.p.sf_seen_eor = 2;
+ else if (q2 != EOF) /* Oops, seek back. */
+ fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR);
}
/* Without padding, terminate the I/O statement without assigning
/* 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 == ',')
+ else if (q == ',')
if (dtp->u.p.sf_read_comma == 1)
{
seen_comma = 1;
notify_std (&dtp->common, GFC_STD_GNU,
"Comma in formatted numeric read.");
- *length = n;
break;
}
n++;
- p++;
- }
+ }
- fbuf_seek (dtp->u.p.current_unit, n + seen_comma, SEEK_CUR);
+ *length = n;
/* A short read implies we hit EOF, unless we hit EOR, a comma, or
some other stuff. Set the relevant flags. */
dtp->u.p.current_unit->bytes_left -= n;
- if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
- dtp->u.p.size_used += (GFC_IO_INT) n;
+ if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
+ dtp->u.p.current_unit->has_size)
+ dtp->u.p.current_unit->size_used += (GFC_IO_INT) n;
- return base;
+ /* We can't call fbuf_getptr before the loop doing fbuf_getc, because
+ fbuf_getc might reallocate the buffer. So return current pointer
+ minus all the advances, which is n plus up to two characters
+ of newline or comma. */
+ return fbuf_getptr (dtp->u.p.current_unit)
+ - n - dtp->u.p.sf_seen_eor - seen_comma;
}
/* Function for reading the next couple of bytes from the current
- file, advancing the current position. We return FAILURE on end of record or
+ file, advancing the current position. We return NULL on end of record or
end of file. This function is only for formatted I/O, unformatted uses
read_block_direct.
short reads. */
void *
-read_block_form (st_parameter_dt *dtp, int * nbytes)
+read_block_form (st_parameter_dt *dtp, size_t *nbytes)
{
char *source;
- int norig;
+ size_t norig;
if (!is_stream_io (dtp))
{
/* 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->recl == default_recl)
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
else
{
}
}
- if (unlikely (dtp->u.p.current_unit->bytes_left == 0
- && !is_internal_unit(dtp)))
+ if (is_internal_unit(dtp))
{
- hit_eof (dtp);
- return NULL;
+ if (*nbytes > 0 && dtp->u.p.current_unit->bytes_left == 0)
+ {
+ if (dtp->u.p.advance_status == ADVANCE_NO)
+ {
+ generate_error (&dtp->common, LIBERROR_EOR, NULL);
+ return NULL;
+ }
+ }
+ }
+ else
+ {
+ if (unlikely (dtp->u.p.current_unit->bytes_left == 0))
+ {
+ hit_eof (dtp);
+ return NULL;
+ }
}
*nbytes = dtp->u.p.current_unit->bytes_left;
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_IO_INT) *nbytes;
+ if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
+ dtp->u.p.current_unit->has_size)
+ dtp->u.p.current_unit->size_used += (GFC_IO_INT) *nbytes;
if (norig != *nbytes)
- {
+ {
/* Short read, this shouldn't happen. */
- if (!dtp->u.p.current_unit->pad_status == PAD_YES)
+ if (dtp->u.p.current_unit->pad_status == PAD_NO)
{
generate_error (&dtp->common, LIBERROR_EOR, NULL);
source = NULL;
}
+/* Read a block from a character(kind=4) internal unit, to be transferred into
+ a character(kind=4) variable. Note: Portions of this code borrowed from
+ read_sf_internal. */
+void *
+read_block_form4 (st_parameter_dt *dtp, size_t *nbytes)
+{
+ static gfc_char4_t *empty_string[0];
+ gfc_char4_t *source;
+ size_t lorig;
+
+ if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
+ *nbytes = dtp->u.p.current_unit->bytes_left;
+
+ /* Zero size array gives internal unit len of 0. Nothing to read. */
+ if (dtp->internal_unit_len == 0
+ && dtp->u.p.current_unit->pad_status == PAD_NO)
+ hit_eof (dtp);
+
+ /* If we have seen an eor previously, return a length of 0. The
+ caller is responsible for correctly padding the input field. */
+ if (dtp->u.p.sf_seen_eor)
+ {
+ *nbytes = 0;
+ /* Just return something that isn't a NULL pointer, otherwise the
+ caller thinks an error occurred. */
+ return empty_string;
+ }
+
+ lorig = *nbytes;
+ source = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s, nbytes);
+
+ if (unlikely (lorig > *nbytes))
+ {
+ hit_eof (dtp);
+ return NULL;
+ }
+
+ dtp->u.p.current_unit->bytes_left -= *nbytes;
+
+ if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
+ dtp->u.p.current_unit->has_size)
+ dtp->u.p.current_unit->size_used += (GFC_IO_INT) *nbytes;
+
+ return source;
+}
+
+
/* Reads a block directly into application data space. This is for
unformatted files. */
if (is_stream_io (dtp))
{
- have_read_record = sread (dtp->u.p.current_unit->s, buf,
+ have_read_record = sread (dtp->u.p.current_unit->s, buf,
nbytes);
if (unlikely (have_read_record < 0))
{
return;
}
- dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record;
+ dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record;
if (unlikely ((ssize_t) nbytes != have_read_record))
{
return;
}
- if (to_read_record != (ssize_t) 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. */
dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord;
- have_read_subrecord = sread (dtp->u.p.current_unit->s,
+ have_read_subrecord = sread (dtp->u.p.current_unit->s,
buf + have_read_record, to_read_subrecord);
- if (unlikely (have_read_subrecord) < 0)
+ if (unlikely (have_read_subrecord < 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return;
have_read_record += have_read_subrecord;
if (unlikely (to_read_subrecord != have_read_subrecord))
-
{
/* Short read, e.g. if we hit EOF. This means the record
structure has been corrupted, or the trailing record
fill in. Returns NULL on error. */
void *
-write_block (st_parameter_dt *dtp, int length)
+write_block (st_parameter_dt *dtp, size_t length)
{
char *dest;
== 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->recl == default_recl))
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
else
{
if (is_internal_unit (dtp))
{
- dest = mem_alloc_w (dtp->u.p.current_unit->s, &length);
+ if (is_char4_unit(dtp)) /* char4 internel unit. */
+ {
+ gfc_char4_t *dest4;
+ dest4 = mem_alloc_w4 (dtp->u.p.current_unit->s, &length);
+ if (dest4 == NULL)
+ {
+ generate_error (&dtp->common, LIBERROR_END, NULL);
+ return NULL;
+ }
+ return dest4;
+ }
+ else
+ dest = mem_alloc_w (dtp->u.p.current_unit->s, &length);
- if (dest == NULL)
- {
- generate_error (&dtp->common, LIBERROR_END, NULL);
- return NULL;
- }
+ if (dest == NULL)
+ {
+ generate_error (&dtp->common, LIBERROR_END, NULL);
+ return NULL;
+ }
- if (unlikely (dtp->u.p.current_unit->endfile == AT_ENDFILE))
- generate_error (&dtp->common, LIBERROR_END, NULL);
+ if (unlikely (dtp->u.p.current_unit->endfile == AT_ENDFILE))
+ generate_error (&dtp->common, LIBERROR_END, NULL);
}
else
{
dest = fbuf_alloc (dtp->u.p.current_unit, length);
if (dest == NULL)
- {
- generate_error (&dtp->common, LIBERROR_OS, NULL);
- return NULL;
- }
+ {
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
+ return NULL;
+ }
}
-
- if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
- dtp->u.p.size_used += (GFC_IO_INT) length;
+
+ if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
+ dtp->u.p.current_unit->has_size)
+ dtp->u.p.current_unit->size_used += (GFC_IO_INT) length;
dtp->u.p.current_unit->strm_pos += (gfc_offset) length;
called for unformatted files. There are three cases to consider:
Stream I/O, unformatted direct, unformatted sequential. */
-static try
+static bool
write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
{
if (unlikely (have_written < 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
- return FAILURE;
+ return false;
}
- dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written;
+ dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written;
- return SUCCESS;
+ return true;
}
/* Unformatted direct access. */
if (unlikely (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes))
{
generate_error (&dtp->common, LIBERROR_DIRECT_EOR, NULL);
- return FAILURE;
+ return false;
}
if (buf == NULL && nbytes == 0)
- return SUCCESS;
+ return true;
- have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes);
+ 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;
+ return false;
}
dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written;
dtp->u.p.current_unit->bytes_left -= (gfc_offset) have_written;
- return SUCCESS;
+ return true;
}
/* Unformatted sequential. */
dtp->u.p.current_unit->bytes_left_subrecord -=
(gfc_offset) to_write_subrecord;
- to_write_subrecord = swrite (dtp->u.p.current_unit->s,
+ 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;
+ return false;
}
- dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord;
+ dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord;
nbytes -= to_write_subrecord;
have_written += to_write_subrecord;
if (unlikely (short_record))
{
generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
- return FAILURE;
+ return false;
+ }
+ return true;
+}
+
+
+/* Reverse memcpy - used for byte swapping. */
+
+static void
+reverse_memcpy (void *dest, const void *src, size_t n)
+{
+ char *d, *s;
+ size_t i;
+
+ d = (char *) dest;
+ s = (char *) src + n - 1;
+
+ /* Write with ascending order - this is likely faster
+ on modern architectures because of write combining. */
+ for (i=0; i<n; i++)
+ *(d++) = *(s--);
+}
+
+
+/* Utility function for byteswapping an array, using the bswap
+ builtins if possible. dest and src can overlap completely, or then
+ they must point to separate objects; partial overlaps are not
+ allowed. */
+
+static void
+bswap_array (void *dest, const void *src, size_t size, size_t nelems)
+{
+ const char *ps;
+ char *pd;
+
+ switch (size)
+ {
+ case 1:
+ break;
+ case 2:
+ for (size_t i = 0; i < nelems; i++)
+ ((uint16_t*)dest)[i] = __builtin_bswap16 (((uint16_t*)src)[i]);
+ break;
+ case 4:
+ for (size_t i = 0; i < nelems; i++)
+ ((uint32_t*)dest)[i] = __builtin_bswap32 (((uint32_t*)src)[i]);
+ break;
+ case 8:
+ for (size_t i = 0; i < nelems; i++)
+ ((uint64_t*)dest)[i] = __builtin_bswap64 (((uint64_t*)src)[i]);
+ break;
+ case 12:
+ ps = src;
+ pd = dest;
+ for (size_t i = 0; i < nelems; i++)
+ {
+ uint32_t tmp;
+ memcpy (&tmp, ps, 4);
+ *(uint32_t*)pd = __builtin_bswap32 (*(uint32_t*)(ps + 8));
+ *(uint32_t*)(pd + 4) = __builtin_bswap32 (*(uint32_t*)(ps + 4));
+ *(uint32_t*)(pd + 8) = __builtin_bswap32 (tmp);
+ ps += size;
+ pd += size;
+ }
+ break;
+ case 16:
+ ps = src;
+ pd = dest;
+ for (size_t i = 0; i < nelems; i++)
+ {
+ uint64_t tmp;
+ memcpy (&tmp, ps, 8);
+ *(uint64_t*)pd = __builtin_bswap64 (*(uint64_t*)(ps + 8));
+ *(uint64_t*)(pd + 8) = __builtin_bswap64 (tmp);
+ ps += size;
+ pd += size;
+ }
+ break;
+ default:
+ pd = dest;
+ if (dest != src)
+ {
+ ps = src;
+ for (size_t i = 0; i < nelems; i++)
+ {
+ reverse_memcpy (pd, ps, size);
+ ps += size;
+ pd += size;
+ }
+ }
+ else
+ {
+ /* In-place byte swap. */
+ for (size_t i = 0; i < nelems; i++)
+ {
+ char tmp, *low = pd, *high = pd + size - 1;
+ for (size_t j = 0; j < size/2; j++)
+ {
+ tmp = *low;
+ *low = *high;
+ *high = tmp;
+ low++;
+ high--;
+ }
+ pd += size;
+ }
+ }
}
- return SUCCESS;
}
unformatted_read (st_parameter_dt *dtp, bt type,
void *dest, int kind, size_t size, size_t nelems)
{
- if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
- || kind == 1)
+ if (type == BT_CLASS)
{
- if (type == BT_CHARACTER)
- size *= GFC_SIZE_OF_CHAR_KIND(kind);
- read_block_direct (dtp, dest, size * nelems);
+ int unit = dtp->u.p.current_unit->unit_number;
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsg, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+
+ /* Call the user defined unformatted READ procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+ dtp->u.p.ufdtio_ptr (dest, &unit, child_iostat, child_iomsg,
+ child_iomsg_len);
+ dtp->u.p.current_unit->child_dtio--;
+ return;
}
- else
- {
- char buffer[16];
- char *p;
- size_t i;
- p = dest;
+ if (type == BT_CHARACTER)
+ size *= GFC_SIZE_OF_CHAR_KIND(kind);
+ read_block_direct (dtp, dest, size * nelems);
+ if (unlikely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_SWAP)
+ && kind != 1)
+ {
/* Handle wide chracters. */
- if (type == BT_CHARACTER && kind != 1)
- {
- nelems *= size;
- size = kind;
- }
+ if (type == BT_CHARACTER)
+ {
+ nelems *= size;
+ size = kind;
+ }
/* Break up complex into its constituent reals. */
- if (type == BT_COMPLEX)
- {
- nelems *= 2;
- size /= 2;
- }
-
- /* By now, all complex variables have been split into their
- constituent reals. */
-
- for (i = 0; i < nelems; i++)
- {
- read_block_direct (dtp, buffer, size);
- reverse_memcpy (p, buffer, size);
- p += size;
- }
+ else if (type == BT_COMPLEX)
+ {
+ nelems *= 2;
+ size /= 2;
+ }
+ bswap_array (dest, dest, size, nelems);
}
}
/* Master function for unformatted writes. NOTE: For kind=10 the size is 16
bytes on 64 bit machines. The unused bytes are not initialized and never
used, which can show an error with memory checking analyzers like
- valgrind. */
+ valgrind. We us BT_CLASS to denote a User Defined I/O call. */
static void
unformatted_write (st_parameter_dt *dtp, bt type,
void *source, int kind, size_t size, size_t nelems)
{
- if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
+ if (type == BT_CLASS)
+ {
+ int unit = dtp->u.p.current_unit->unit_number;
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsg, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+
+ /* Call the user defined unformatted WRITE procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+ dtp->u.p.ufdtio_ptr (source, &unit, child_iostat, child_iomsg,
+ child_iomsg_len);
+ dtp->u.p.current_unit->child_dtio--;
+ return;
+ }
+
+ if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
|| kind == 1)
{
size_t stride = type == BT_CHARACTER ?
}
else
{
- char buffer[16];
+#define BSWAP_BUFSZ 512
+ char buffer[BSWAP_BUFSZ];
char *p;
- size_t i;
+ size_t nrem;
p = source;
nelems *= size;
size = kind;
}
-
+
/* Break up complex into its constituent reals. */
if (type == BT_COMPLEX)
{
nelems *= 2;
size /= 2;
- }
+ }
/* By now, all complex variables have been split into their
constituent reals. */
- for (i = 0; i < nelems; i++)
+ nrem = nelems;
+ do
{
- reverse_memcpy(buffer, p, size);
- p += size;
- write_buf (dtp, buffer, size);
+ size_t nc;
+ if (size * nrem > BSWAP_BUFSZ)
+ nc = BSWAP_BUFSZ / size;
+ else
+ nc = nrem;
+
+ bswap_array (buffer, p, size, nc);
+ write_buf (dtp, buffer, size * nc);
+ p += size * nc;
+ nrem -= nc;
}
+ while (nrem > 0);
}
}
case BT_COMPLEX:
p = "COMPLEX";
break;
+ case BT_CLASS:
+ p = "CLASS or DERIVED";
+ break;
default:
internal_error (NULL, "type_name(): Bad type");
}
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];
static int
require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
{
- char buffer[100];
+#define BUFLEN 100
+ char buffer[BUFLEN];
if (actual == expected)
return 0;
/* Adjust item_count before emitting error message. */
- sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
+ snprintf (buffer, BUFLEN,
+ "Expected %s for item %d in formatted transfer, got %s",
type_name (expected), dtp->u.p.item_count - 1, type_name (actual));
format_error (dtp, f, buffer);
}
+/* Check that the dtio procedure required for formatted IO is present. */
+
+static int
+check_dtio_proc (st_parameter_dt *dtp, const fnode *f)
+{
+ char buffer[BUFLEN];
+
+ if (dtp->u.p.fdtio_ptr != NULL)
+ return 0;
+
+ snprintf (buffer, BUFLEN,
+ "Missing DTIO procedure or intrinsic type passed for item %d "
+ "in formatted transfer",
+ dtp->u.p.item_count - 1);
+
+ format_error (dtp, f, buffer);
+ return 1;
+}
+
+
+static int
+require_numeric_type (st_parameter_dt *dtp, bt actual, const fnode *f)
+{
+#define BUFLEN 100
+ char buffer[BUFLEN];
+
+ if (actual == BT_INTEGER || actual == BT_REAL || actual == BT_COMPLEX)
+ return 0;
+
+ /* Adjust item_count before emitting error message. */
+ snprintf (buffer, BUFLEN,
+ "Expected numeric type for item %d in formatted transfer, got %s",
+ dtp->u.p.item_count - 1, type_name (actual));
+
+ format_error (dtp, f, buffer);
+ return 1;
+}
+
+static char *
+get_dt_format (char *p, gfc_charlen_type *length)
+{
+ char delim = p[-1]; /* The delimiter is always the first character back. */
+ char c, *q, *res;
+ gfc_charlen_type len = *length; /* This length already correct, less 'DT'. */
+
+ res = q = xmalloc (len + 2);
+
+ /* Set the beginning of the string to 'DT', length adjusted below. */
+ *q++ = 'D';
+ *q++ = 'T';
+
+ /* The string may contain doubled quotes so scan and skip as needed. */
+ for (; len > 0; len--)
+ {
+ c = *q++ = *p++;
+ if (c == delim)
+ p++; /* Skip the doubled delimiter. */
+ }
+
+ /* Adjust the string length by two now that we are done. */
+ *length += 2;
+
+ return res;
+}
+
+
/* This function is in the main loop for a formatted data transfer
statement. It would be natural to implement this as a coroutine
with the user program, but C makes that awkward. We loop,
case FMT_B:
if (n == 0)
goto need_read_data;
- if (compile_options.allow_std < GFC_STD_GNU
+ if (!(compile_options.allow_std & GFC_STD_GNU)
+ && require_numeric_type (dtp, type, f))
+ return;
+ if (!(compile_options.allow_std & GFC_STD_F2008)
&& require_type (dtp, BT_INTEGER, type, f))
return;
read_radix (dtp, f, p, kind, 2);
case FMT_O:
if (n == 0)
- goto need_read_data;
- if (compile_options.allow_std < GFC_STD_GNU
+ goto need_read_data;
+ if (!(compile_options.allow_std & GFC_STD_GNU)
+ && require_numeric_type (dtp, type, f))
+ return;
+ if (!(compile_options.allow_std & GFC_STD_F2008)
&& require_type (dtp, BT_INTEGER, type, f))
return;
read_radix (dtp, f, p, kind, 8);
case FMT_Z:
if (n == 0)
goto need_read_data;
- if (compile_options.allow_std < GFC_STD_GNU
+ if (!(compile_options.allow_std & GFC_STD_GNU)
+ && require_numeric_type (dtp, type, f))
+ return;
+ if (!(compile_options.allow_std & GFC_STD_F2008)
&& require_type (dtp, BT_INTEGER, type, f))
return;
read_radix (dtp, f, p, kind, 16);
read_f (dtp, f, p, kind);
break;
+ case FMT_DT:
+ if (n == 0)
+ goto need_read_data;
+
+ if (check_dtio_proc (dtp, f))
+ return;
+ if (require_type (dtp, BT_CLASS, type, f))
+ return;
+ int unit = dtp->u.p.current_unit->unit_number;
+ char dt[] = "DT";
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+ char *iotype;
+ gfc_charlen_type iotype_len = f->u.udf.string_len;
+
+ /* Build the iotype string. */
+ if (iotype_len == 0)
+ {
+ iotype_len = 2;
+ iotype = dt;
+ }
+ else
+ iotype = get_dt_format (f->u.udf.string, &iotype_len);
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsg, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+
+ /* Call the user defined formatted READ procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+ dtp->u.p.current_unit->last_char = EOF - 1;
+ dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist,
+ child_iostat, child_iomsg,
+ iotype_len, child_iomsg_len);
+ dtp->u.p.current_unit->child_dtio--;
+
+ if (f->u.udf.string_len != 0)
+ free (iotype);
+ /* Note: vlist is freed in free_format_data. */
+ break;
+
case FMT_E:
if (n == 0)
goto need_read_data;
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.pending_spaces == 0)
+ dtp->u.p.sf_seen_eor = 0;
}
if (dtp->u.p.skips < 0)
{
- if (is_internal_unit (dtp))
+ 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);
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;
formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kind,
size_t size)
{
- int pos, bytes_used;
+ gfc_offset pos, bytes_used;
const fnode *f;
format_token t;
int n;
/* Now discharge T, TR and X movements to the right. This is delayed
until a data producing format to suppress trailing spaces. */
-
+
t = f->format;
if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
&& ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
|| t == FMT_Z || t == FMT_F || t == FMT_E
|| t == FMT_EN || t == FMT_ES || t == FMT_G
- || t == FMT_L || t == FMT_A || t == FMT_D))
+ || t == FMT_L || t == FMT_A || t == FMT_D
+ || t == FMT_DT))
|| t == FMT_STRING))
{
if (dtp->u.p.skips > 0)
{
- int tmp;
+ gfc_offset tmp;
write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
- tmp = (int)(dtp->u.p.current_unit->recl
- - dtp->u.p.current_unit->bytes_left);
- dtp->u.p.max_pos =
+ tmp = dtp->u.p.current_unit->recl
+ - dtp->u.p.current_unit->bytes_left;
+ dtp->u.p.max_pos =
dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
+ dtp->u.p.skips = 0;
}
if (dtp->u.p.skips < 0)
{
- if (is_internal_unit (dtp))
+ 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.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 = dtp->u.p.current_unit->recl
+ - dtp->u.p.current_unit->bytes_left;
if (is_stream_io(dtp))
bytes_used = 0;
case FMT_B:
if (n == 0)
goto need_data;
- if (compile_options.allow_std < GFC_STD_GNU
+ if (!(compile_options.allow_std & GFC_STD_GNU)
+ && require_numeric_type (dtp, type, f))
+ return;
+ if (!(compile_options.allow_std & GFC_STD_F2008)
&& require_type (dtp, BT_INTEGER, type, f))
return;
write_b (dtp, f, p, kind);
case FMT_O:
if (n == 0)
- goto need_data;
- if (compile_options.allow_std < GFC_STD_GNU
+ goto need_data;
+ if (!(compile_options.allow_std & GFC_STD_GNU)
+ && require_numeric_type (dtp, type, f))
+ return;
+ if (!(compile_options.allow_std & GFC_STD_F2008)
&& require_type (dtp, BT_INTEGER, type, f))
return;
write_o (dtp, f, p, kind);
case FMT_Z:
if (n == 0)
goto need_data;
- if (compile_options.allow_std < GFC_STD_GNU
+ if (!(compile_options.allow_std & GFC_STD_GNU)
+ && require_numeric_type (dtp, type, f))
+ return;
+ if (!(compile_options.allow_std & GFC_STD_F2008)
&& require_type (dtp, BT_INTEGER, type, f))
return;
write_z (dtp, f, p, kind);
write_d (dtp, f, p, kind);
break;
+ case FMT_DT:
+ if (n == 0)
+ goto need_data;
+ int unit = dtp->u.p.current_unit->unit_number;
+ char dt[] = "DT";
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+ char *iotype;
+ gfc_charlen_type iotype_len = f->u.udf.string_len;
+
+ /* Build the iotype string. */
+ if (iotype_len == 0)
+ {
+ iotype_len = 2;
+ iotype = dt;
+ }
+ else
+ iotype = get_dt_format (f->u.udf.string, &iotype_len);
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsg, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+
+ if (check_dtio_proc (dtp, f))
+ return;
+
+ /* Call the user defined formatted WRITE procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+
+ dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist,
+ child_iostat, child_iomsg,
+ iotype_len, child_iomsg_len);
+ dtp->u.p.current_unit->child_dtio--;
+
+ if (f->u.udf.string_len != 0)
+ free (iotype);
+ /* Note: vlist is freed in free_format_data. */
+ break;
+
case FMT_E:
if (n == 0)
goto need_data;
write_i (dtp, f, p, kind);
break;
case BT_LOGICAL:
- write_l (dtp, f, p, kind);
+ write_l (dtp, f, p, kind);
break;
case BT_CHARACTER:
if (kind == 4)
p = ((char *) p) + size;
}
- pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
+ pos = dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left;
dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
}
dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
}
+void
+transfer_integer_write (st_parameter_dt *dtp, void *p, int kind)
+{
+ transfer_integer (dtp, p, kind);
+}
void
transfer_real (st_parameter_dt *dtp, void *p, int kind)
dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
}
+void
+transfer_real_write (st_parameter_dt *dtp, void *p, int kind)
+{
+ transfer_real (dtp, p, kind);
+}
void
transfer_logical (st_parameter_dt *dtp, void *p, int kind)
dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
}
+void
+transfer_logical_write (st_parameter_dt *dtp, void *p, int kind)
+{
+ transfer_logical (dtp, p, kind);
+}
void
-transfer_character (st_parameter_dt *dtp, void *p, int len)
+transfer_character (st_parameter_dt *dtp, void *p, gfc_charlen_type len)
{
static char *empty_string[0];
}
void
-transfer_character_wide (st_parameter_dt *dtp, void *p, int len, int kind)
+transfer_character_write (st_parameter_dt *dtp, void *p, gfc_charlen_type len)
+{
+ transfer_character (dtp, p, len);
+}
+
+void
+transfer_character_wide (st_parameter_dt *dtp, void *p, gfc_charlen_type len, int kind)
{
static char *empty_string[0];
dtp->u.p.transfer (dtp, BT_CHARACTER, p, kind, len, 1);
}
+void
+transfer_character_wide_write (st_parameter_dt *dtp, void *p, gfc_charlen_type len, int kind)
+{
+ transfer_character_wide (dtp, p, len, kind);
+}
void
transfer_complex (st_parameter_dt *dtp, void *p, int kind)
dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
}
+void
+transfer_complex_write (st_parameter_dt *dtp, void *p, int kind)
+{
+ transfer_complex (dtp, p, kind);
+}
void
transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type stride[GFC_MAX_DIMENSIONS];
- index_type stride0, rank, size, type, n;
+ index_type stride0, rank, size, n;
size_t tsize;
char *data;
bt iotype;
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
- type = GFC_DESCRIPTOR_TYPE (desc);
- size = GFC_DESCRIPTOR_SIZE (desc);
-
- /* FIXME: What a kludge: Array descriptors and the IO library use
- different enums for types. */
- switch (type)
- {
- case GFC_DTYPE_UNKNOWN:
- iotype = BT_NULL; /* Is this correct? */
- break;
- case GFC_DTYPE_INTEGER:
- iotype = BT_INTEGER;
- break;
- case GFC_DTYPE_LOGICAL:
- iotype = BT_LOGICAL;
- break;
- case GFC_DTYPE_REAL:
- iotype = BT_REAL;
- break;
- case GFC_DTYPE_COMPLEX:
- iotype = BT_COMPLEX;
- break;
- case GFC_DTYPE_CHARACTER:
- iotype = BT_CHARACTER;
- size = charlen;
- break;
- case GFC_DTYPE_DERIVED:
- internal_error (&dtp->common,
- "Derived type I/O should have been handled via the frontend.");
- break;
- default:
- internal_error (&dtp->common, "transfer_array(): Bad type");
- }
+ iotype = (bt) GFC_DESCRIPTOR_TYPE (desc);
+ size = iotype == BT_CHARACTER ? (index_type) charlen : GFC_DESCRIPTOR_SIZE (desc);
rank = GFC_DESCRIPTOR_RANK (desc);
for (n = 0; n < rank; n++)
}
}
+void
+transfer_array_write (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
+ gfc_charlen_type charlen)
+{
+ transfer_array (dtp, desc, kind, charlen);
+}
+
+
+/* User defined input/output iomsg. */
+
+#define IOMSG_LEN 256
+
+void
+transfer_derived (st_parameter_dt *parent, void *dtio_source, void *dtio_proc)
+{
+ if (parent->u.p.current_unit)
+ {
+ if (parent->u.p.current_unit->flags.form == FORM_UNFORMATTED)
+ parent->u.p.ufdtio_ptr = (unformatted_dtio) dtio_proc;
+ else
+ parent->u.p.fdtio_ptr = (formatted_dtio) dtio_proc;
+ }
+ parent->u.p.transfer (parent, BT_CLASS, dtio_source, 0, 0, 1);
+}
+
/* Preposition a sequential unformatted file while reading. */
}
}
else
+ {
+ uint32_t u32;
+ uint64_t u64;
switch (nr)
{
case sizeof(GFC_INTEGER_4):
- reverse_memcpy (&i4, &i, sizeof (i4));
+ memcpy (&u32, &i, sizeof (u32));
+ u32 = __builtin_bswap32 (u32);
+ memcpy (&i4, &u32, sizeof (i4));
i = i4;
break;
case sizeof(GFC_INTEGER_8):
- reverse_memcpy (&i8, &i, sizeof (i8));
+ memcpy (&u64, &i, sizeof (u64));
+ u64 = __builtin_bswap64 (u64);
+ memcpy (&i8, &u64, sizeof (i8));
i = i8;
break;
runtime_error ("Illegal value for record marker");
break;
}
+ }
if (i >= 0)
{
was specified, we continue from where we last left off. I.e.
there is nothing to do here. */
break;
-
+
case UNFORMATTED_SEQUENTIAL:
if (dtp->u.p.mode == READING)
us_read (dtp, 0);
dtp->u.p.ionml = ionml;
dtp->u.p.mode = read_flag ? READING : WRITING;
+ dtp->u.p.namelist_mode = 0;
+ dtp->u.p.cc.len = 0;
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
- if ((cf & IOPARM_DT_HAS_SIZE) != 0)
- dtp->u.p.size_used = 0; /* Initialize the count. */
-
dtp->u.p.current_unit = get_unit (dtp, 1);
- if (dtp->u.p.current_unit->s == NULL)
- { /* Open the unit with some default flags. */
- st_parameter_open opp;
- unit_convert conv;
- if (dtp->common.unit < 0)
- {
- close_unit (dtp->u.p.current_unit);
- dtp->u.p.current_unit = NULL;
- generate_error (&dtp->common, LIBERROR_BAD_OPTION,
- "Bad unit number in 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)
- {
+ if (dtp->u.p.current_unit == NULL)
+ {
+ /* This means we tried to access an external unit < 0 without
+ having opened it first with NEWUNIT=. */
+ generate_error (&dtp->common, LIBERROR_BAD_OPTION,
+ "Unit number is negative and unit was not already "
+ "opened with OPEN(NEWUNIT=...)");
+ return;
+ }
+ else if (dtp->u.p.current_unit->s == NULL)
+ { /* Open the unit with some default flags. */
+ st_parameter_open opp;
+ unit_convert conv;
+
+ memset (&u_flags, '\0', sizeof (u_flags));
+ u_flags.access = ACCESS_SEQUENTIAL;
+ u_flags.action = ACTION_READWRITE;
+
+ /* Is it unformatted? */
+ if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
+ | IOPARM_DT_IONML_SET)))
+ u_flags.form = FORM_UNFORMATTED;
+ else
+ u_flags.form = FORM_UNSPECIFIED;
+
+ u_flags.delim = DELIM_UNSPECIFIED;
+ u_flags.blank = BLANK_UNSPECIFIED;
+ u_flags.pad = PAD_UNSPECIFIED;
+ u_flags.decimal = DECIMAL_UNSPECIFIED;
+ u_flags.encoding = ENCODING_UNSPECIFIED;
+ u_flags.async = ASYNC_UNSPECIFIED;
+ u_flags.round = ROUND_UNSPECIFIED;
+ u_flags.sign = SIGN_UNSPECIFIED;
+ u_flags.share = SHARE_UNSPECIFIED;
+ u_flags.cc = CC_UNSPECIFIED;
+ u_flags.readonly = 0;
+
+ u_flags.status = STATUS_UNKNOWN;
+
+ conv = get_unformatted_convert (dtp->common.unit);
+
+ if (conv == GFC_CONVERT_NONE)
+ conv = compile_options.convert;
+
+ switch (conv)
+ {
case GFC_CONVERT_NATIVE:
case GFC_CONVERT_SWAP:
break;
-
+
case GFC_CONVERT_BIG:
- conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
+ conv = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
break;
-
+
case GFC_CONVERT_LITTLE:
- conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
+ conv = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
break;
-
+
default:
internal_error (&opp.common, "Illegal value for CONVERT");
break;
- }
+ }
+
+ u_flags.convert = conv;
- u_flags.convert = conv;
+ opp.common = dtp->common;
+ opp.common.flags &= IOPARM_COMMON_MASK;
+ dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags);
+ dtp->common.flags &= ~IOPARM_COMMON_MASK;
+ dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
+ if (dtp->u.p.current_unit == NULL)
+ return;
+ }
- opp.common = dtp->common;
- opp.common.flags &= IOPARM_COMMON_MASK;
- dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags);
- dtp->common.flags &= ~IOPARM_COMMON_MASK;
- dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
- if (dtp->u.p.current_unit == NULL)
- return;
- }
+ if (dtp->u.p.current_unit->child_dtio == 0)
+ {
+ if ((cf & IOPARM_DT_HAS_SIZE) != 0)
+ {
+ dtp->u.p.current_unit->has_size = true;
+ /* Initialize the count. */
+ dtp->u.p.current_unit->size_used = 0;
+ }
+ else
+ dtp->u.p.current_unit->has_size = false;
+ }
+ else if (dtp->u.p.current_unit->internal_unit_kind > 0)
+ dtp->u.p.unit_is_internal = 1;
/* Check the action. */
if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
{
if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
- generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
- "A format cannot be specified with a namelist");
+ {
+ generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
+ "A format cannot be specified with a namelist");
+ return;
+ }
}
else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
{
generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"Missing format for FORMATTED data transfer");
+ return;
}
if (is_internal_unit (dtp)
return;
}
- if (dtp->u.p.current_unit->endfile == AFTER_ENDFILE)
+ if (compile_options.warn_std &&
+ dtp->u.p.current_unit->endfile == AFTER_ENDFILE)
{
generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
"Sequential READ or WRITE not allowed after "
"EOF marker, possibly use REWIND or BACKSPACE");
return;
}
-
}
+
/* Process the ADVANCE option. */
dtp->u.p.advance_status
}
}
+ /* Child IO is non-advancing and any ADVANCE= specifier is ignored.
+ F2008 9.6.2.4 */
+ if (dtp->u.p.current_unit->child_dtio > 0)
+ dtp->u.p.advance_status = ADVANCE_NO;
+
if (read_flag)
{
dtp->u.p.current_unit->previous_nonadvancing_write = 0;
return;
}
- if ((cf & IOPARM_DT_HAS_SIZE) != 0
+ if ((cf & IOPARM_DT_HAS_SIZE) != 0
&& dtp->u.p.advance_status != ADVANCE_NO)
{
generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
= !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
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)
dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign;
find_option (&dtp->common, dtp->blank, dtp->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;
= !(cf & IOPARM_DT_HAS_DELIM) ? DELIM_UNSPECIFIED :
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)
- dtp->u.p.current_unit->delim_status = dtp->u.p.current_unit->flags.delim;
+ {
+ if (ionml && dtp->u.p.current_unit->flags.delim == DELIM_UNSPECIFIED)
+ dtp->u.p.current_unit->delim_status = DELIM_QUOTE;
+ else
+ dtp->u.p.current_unit->delim_status = dtp->u.p.current_unit->flags.delim;
+ }
/* Check the pad mode. */
dtp->u.p.current_unit->pad_status
= !(cf & IOPARM_DT_HAS_PAD) ? PAD_UNSPECIFIED :
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 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
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);
return;
}
}
-
+
/* Sanity checks on the record number. */
if ((cf & IOPARM_DT_HAS_REC) != 0)
a partial record needs to exist. */
if (dtp->u.p.mode == READING && (dtp->rec - 1)
- * dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s))
+ * dtp->u.p.current_unit->recl >= ssize (dtp->u.p.current_unit->s))
{
generate_error (&dtp->common, LIBERROR_BAD_OPTION,
"Non-existing record number");
/* Position the file. */
if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
- * dtp->u.p.current_unit->recl, SEEK_SET) < 0)
- {
- 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 */
-
- if (is_stream_io (dtp))
- dtp->u.p.current_unit->strm_pos = dtp->rec;
+ * dtp->u.p.current_unit->recl, SEEK_SET) < 0)
+ {
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
+ return;
+ }
- /* 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);
+ if (!is_internal_unit (dtp))
+ flush_if_preconnected(dtp->u.p.current_unit->s);
dtp->u.p.current_unit->mode = dtp->u.p.mode;
dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos;
pre_position (dtp);
-
+
/* Set up the subroutine that will handle the transfers. */
else
{
if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
- dtp->u.p.transfer = list_formatted_read;
+ {
+ if (dtp->u.p.current_unit->child_dtio == 0)
+ dtp->u.p.current_unit->last_char = EOF - 1;
+ dtp->u.p.transfer = list_formatted_read;
+ }
else
dtp->u.p.transfer = formatted_transfer;
}
dtp->u.p.current_unit->read_bad = 1;
}
- /* Start the data transfer if we are doing a formatted transfer. */
- if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
- && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0)
- && dtp->u.p.ionml == NULL)
- formatted_transfer (dtp, 0, NULL, 0, 0, 1);
+ if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
+ {
+#ifdef HAVE_USELOCALE
+ dtp->u.p.old_locale = uselocale (c_locale);
+#else
+ __gthread_mutex_lock (&old_locale_lock);
+ if (!old_locale_ctr++)
+ {
+ old_locale = setlocale (LC_NUMERIC, NULL);
+ setlocale (LC_NUMERIC, "C");
+ }
+ __gthread_mutex_unlock (&old_locale_lock);
+#endif
+ /* Start the data transfer if we are doing a formatted transfer. */
+ if ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0
+ && dtp->u.p.ionml == NULL)
+ formatted_transfer (dtp, 0, NULL, 0, 0, 1);
+ }
}
+
/* Initialize an array_loop_spec given the array descriptor. The function
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,
gfc_offset *start_record)
{
int rank = GFC_DESCRIPTOR_RANK(desc);
int i;
- gfc_offset index;
+ gfc_offset index;
int empty;
empty = 0;
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)
+ empty = empty || (GFC_DESCRIPTOR_UBOUND(desc,i)
< GFC_DESCRIPTOR_LBOUND(desc,i));
if (GFC_DESCRIPTOR_STRIDE(desc,i) > 0)
/* Determine the index to the next record in an internal unit array by
by incrementing through the array_loop_spec. */
-
+
gfc_offset
next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished)
{
int i, carry;
gfc_offset index;
-
+
carry = 1;
index = 0;
position. */
static void
-skip_record (st_parameter_dt *dtp, ssize_t bytes)
+skip_record (st_parameter_dt *dtp, gfc_offset bytes)
{
ssize_t rlength, readb;
- static const ssize_t MAX_READ = 4096;
+#define 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))
+ /* Direct access files do not generate END conditions,
+ only I/O errors. */
+ if (sseek (dtp->u.p.current_unit->s,
+ dtp->u.p.current_unit->bytes_left_subrecord, SEEK_CUR) < 0)
{
- /* Direct access files do not generate END conditions,
- only I/O errors. */
- 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. */
+ /* Seeking failed, fall back to seeking by reading data. */
while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
{
- rlength =
+ rlength =
(MAX_READ < dtp->u.p.current_unit->bytes_left_subrecord) ?
MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord;
dtp->u.p.current_unit->bytes_left_subrecord -= readb;
}
+ return;
}
-
+ dtp->u.p.current_unit->bytes_left_subrecord = 0;
}
}
-static inline gfc_offset
+static gfc_offset
min_off (gfc_offset a, gfc_offset b)
{
return (a < b ? a : b);
next_record_r (st_parameter_dt *dtp, int done)
{
gfc_offset record;
- int bytes_left;
char p;
int cc;
/* 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;
}
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
}
- else
+ else
{
- bytes_left = (int) dtp->u.p.current_unit->bytes_left;
- bytes_left = min_off (bytes_left,
- file_length (dtp->u.p.current_unit->s)
+ gfc_offset bytes_left = dtp->u.p.current_unit->bytes_left;
+ bytes_left = min_off (bytes_left,
+ ssize (dtp->u.p.current_unit->s)
- stell (dtp->u.p.current_unit->s));
- if (sseek (dtp->u.p.current_unit->s,
+ if (sseek (dtp->u.p.current_unit->s,
bytes_left, SEEK_CUR) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
}
dtp->u.p.current_unit->bytes_left
= dtp->u.p.current_unit->recl;
- }
+ }
break;
}
- else
+ else if (dtp->u.p.current_unit->flags.cc != CC_NONE)
{
do
{
errno = 0;
cc = fbuf_getc (dtp->u.p.current_unit);
- if (cc == EOF)
+ if (cc == EOF)
{
if (errno != 0)
generate_error (&dtp->common, LIBERROR_OS, NULL);
}
break;
}
-
+
if (is_stream_io (dtp))
dtp->u.p.current_unit->strm_pos++;
-
+
p = (char) cc;
}
while (p != '\n');
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
{
+ uint32_t u32;
+ uint64_t u64;
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);
+ memcpy (&u32, &buf4, sizeof (u32));
+ u32 = __builtin_bswap32 (u32);
+ return swrite (dtp->u.p.current_unit->s, &u32, 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);
+ memcpy (&u64, &buf8, sizeof (u64));
+ u64 = __builtin_bswap64 (u64);
+ return swrite (dtp->u.p.current_unit->s, &u64, len);
break;
default:
m = dtp->u.p.current_unit->recl_subrecord
- dtp->u.p.current_unit->bytes_left_subrecord;
- /* 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 (unlikely (write_us_marker (dtp, m_write) < 0))
- goto io_error;
-
if (compile_options.record_marker == 0)
record_marker = sizeof (GFC_INTEGER_4);
else
/* Seek to the head and overwrite the bogus length with the real
length. */
- if (unlikely (sseek (dtp->u.p.current_unit->s, - m - 2 * record_marker,
+ if (unlikely (sseek (dtp->u.p.current_unit->s, - m - record_marker,
SEEK_CUR) < 0))
goto io_error;
/* Seek past the end of the current record. */
- if (unlikely (sseek (dtp->u.p.current_unit->s, m + record_marker,
- SEEK_CUR) < 0))
+ if (unlikely (sseek (dtp->u.p.current_unit->s, m, SEEK_CUR) < 0))
+ goto io_error;
+
+ /* 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 (unlikely (write_us_marker (dtp, m_write) < 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 gfc_offset
+sset (stream *s, int c, gfc_offset nbyte)
{
- static const int WRITE_CHUNK = 256;
+#define WRITE_CHUNK 256
char p[WRITE_CHUNK];
- ssize_t bytes_left, trans;
+ gfc_offset bytes_left;
+ ssize_t trans;
if (nbyte < WRITE_CHUNK)
memset (p, c, nbyte);
return trans;
bytes_left -= trans;
}
-
+
return nbyte - bytes_left;
}
+
+/* Finish up a record according to the legacy carriagecontrol type, based
+ on the first character in the record. */
+
+static void
+next_record_cc (st_parameter_dt *dtp)
+{
+ /* Only valid with CARRIAGECONTROL=FORTRAN. */
+ if (dtp->u.p.current_unit->flags.cc != CC_FORTRAN)
+ return;
+
+ fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
+ if (dtp->u.p.cc.len > 0)
+ {
+ char *p = fbuf_alloc (dtp->u.p.current_unit, dtp->u.p.cc.len);
+ if (!p)
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
+
+ /* Output CR for the first character with default CC setting. */
+ *(p++) = dtp->u.p.cc.u.end;
+ if (dtp->u.p.cc.len > 1)
+ *p = dtp->u.p.cc.u.end;
+ }
+}
+
/* Position to the next record in write mode. */
static void
next_record_w (st_parameter_dt *dtp, int done)
{
- gfc_offset m, record, max_pos;
- int length;
+ gfc_offset max_pos_off;
/* Zero counters for X- and T-editing. */
- max_pos = dtp->u.p.max_pos;
+ max_pos_off = dtp->u.p.max_pos;
dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
switch (current_mode (dtp))
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)
+ if (sset (dtp->u.p.current_unit->s, ' ',
+ dtp->u.p.current_unit->bytes_left)
!= dtp->u.p.current_unit->bytes_left)
goto io_error;
case UNFORMATTED_DIRECT:
if (dtp->u.p.current_unit->bytes_left > 0)
{
- length = (int) dtp->u.p.current_unit->bytes_left;
+ gfc_offset length = dtp->u.p.current_unit->bytes_left;
if (sset (dtp->u.p.current_unit->s, 0, length) != length)
goto io_error;
}
if (is_internal_unit (dtp))
{
+ char *p;
+ /* Internal unit, so must fit in memory. */
+ size_t length, m, record;
+ size_t max_pos = max_pos_off;
if (is_array_io (dtp))
{
int finished;
- length = (int) dtp->u.p.current_unit->bytes_left;
-
+ length = dtp->u.p.current_unit->bytes_left;
+
/* If the farthest position reached is greater than current
position, adjust the position and set length to pad out
whats left. Otherwise just pad whats left.
- dtp->u.p.current_unit->bytes_left;
if (max_pos > m)
{
- length = (int) (max_pos - m);
- if (sseek (dtp->u.p.current_unit->s,
+ length = (max_pos - m);
+ if (sseek (dtp->u.p.current_unit->s,
length, SEEK_CUR) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
return;
}
- length = (int) (dtp->u.p.current_unit->recl - max_pos);
+ length = ((size_t) dtp->u.p.current_unit->recl - max_pos);
}
- if (sset (dtp->u.p.current_unit->s, ' ', length) != length)
- {
- generate_error (&dtp->common, LIBERROR_END, NULL);
- return;
+ p = write_block (dtp, length);
+ if (p == NULL)
+ return;
+
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ memset4 (p4, ' ', length);
}
+ else
+ memset (p, ' ', length);
/* Now that the current record has been padded out,
determine where the next record in the array is. */
&finished);
if (finished)
dtp->u.p.current_unit->endfile = AT_ENDFILE;
-
+
/* Now seek to this record */
- record = record * dtp->u.p.current_unit->recl;
+ record = record * ((size_t) dtp->u.p.current_unit->recl);
if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
{
- dtp->u.p.current_unit->bytes_left;
if (max_pos > m)
{
- length = (int) (max_pos - m);
- if (sseek (dtp->u.p.current_unit->s,
+ length = max_pos - m;
+ if (sseek (dtp->u.p.current_unit->s,
length, SEEK_CUR) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
return;
}
- length = (int) (dtp->u.p.current_unit->recl - max_pos);
+ length = (size_t) dtp->u.p.current_unit->recl
+ - max_pos;
}
else
- length = (int) dtp->u.p.current_unit->bytes_left;
+ length = dtp->u.p.current_unit->bytes_left;
}
-
- if (sset (dtp->u.p.current_unit->s, ' ', length) != length)
+ if (length > 0)
{
- generate_error (&dtp->common, LIBERROR_END, NULL);
- return;
+ p = write_block (dtp, length);
+ if (p == NULL)
+ return;
+
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ memset4 (p4, (gfc_char4_t) ' ', length);
+ }
+ else
+ memset (p, ' ', length);
}
}
}
+ /* Handle legacy CARRIAGECONTROL line endings. */
+ else if (dtp->u.p.current_unit->flags.cc == CC_FORTRAN)
+ next_record_cc (dtp);
else
{
+ /* Skip newlines for CC=CC_NONE. */
+ const int len = (dtp->u.p.current_unit->flags.cc == CC_NONE)
+ ? 0
#ifdef HAVE_CRLF
- const int len = 2;
+ : 2;
#else
- const int len = 1;
+ : 1;
#endif
- 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;
+ fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
+ if (dtp->u.p.current_unit->flags.cc != CC_NONE)
+ {
+ char *p = fbuf_alloc (dtp->u.p.current_unit, len);
+ if (!p)
+ goto io_error;
#ifdef HAVE_CRLF
- *(p++) = '\r';
+ *(p++) = '\r';
#endif
- *p = '\n';
+ *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))
+ < ssize (dtp->u.p.current_unit->s))
unit_truncate (dtp->u.p.current_unit,
dtp->u.p.current_unit->strm_pos - 1,
&dtp->common);
else
next_record_w (dtp, done);
+ fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
+
if (!is_stream_io (dtp))
{
- /* Keep position up to date for INQUIRE */
+ /* Since we have changed the position, set it to unspecified so
+ that INQUIRE(POSITION=) knows it needs to look into it. */
if (done)
- update_position (dtp->u.p.current_unit);
+ dtp->u.p.current_unit->flags.position = POSITION_UNSPECIFIED;
dtp->u.p.current_unit->current_record = 0;
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
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) /
- dtp->u.p.current_unit->recl;
+ (fp + dtp->u.p.current_unit->recl) /
+ dtp->u.p.current_unit->recl - 1;
}
else
dtp->u.p.current_unit->last_record++;
if (!done)
pre_position (dtp);
- fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
+ smarkeor (dtp->u.p.current_unit->s);
}
static void
finalize_transfer (st_parameter_dt *dtp)
{
- jmp_buf eof_jump;
GFC_INTEGER_4 cf = dtp->common.flags;
+ if ((dtp->u.p.ionml != NULL)
+ && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
+ {
+ dtp->u.p.namelist_mode = 1;
+ if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
+ namelist_read (dtp);
+ else
+ namelist_write (dtp);
+ }
+
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
- *dtp->size = dtp->u.p.size_used;
+ *dtp->size = dtp->u.p.current_unit->size_used;
if (dtp->u.p.eor_condition)
{
generate_error (&dtp->common, LIBERROR_EOR, NULL);
- return;
+ goto done;
}
- if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+ if (dtp->u.p.current_unit && (dtp->u.p.current_unit->child_dtio > 0))
{
- if (dtp->u.p.current_unit && current_mode (dtp) == UNFORMATTED_SEQUENTIAL)
- dtp->u.p.current_unit->current_record = 0;
+ if (cf & IOPARM_DT_HAS_FORMAT)
+ {
+ free (dtp->u.p.fmt);
+ free (dtp->format);
+ }
return;
}
- if ((dtp->u.p.ionml != NULL)
- && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
{
- if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
- namelist_read (dtp);
- else
- namelist_write (dtp);
+ if (dtp->u.p.current_unit && current_mode (dtp) == UNFORMATTED_SEQUENTIAL)
+ dtp->u.p.current_unit->current_record = 0;
+ goto done;
}
dtp->u.p.transfer = NULL;
if (dtp->u.p.current_unit == NULL)
- return;
-
- dtp->u.p.eof_jump = &eof_jump;
- if (setjmp (eof_jump))
- {
- generate_error (&dtp->common, LIBERROR_END, NULL);
- return;
- }
+ goto done;
if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
{
finish_list_read (dtp);
- return;
+ goto done;
}
if (dtp->u.p.mode == WRITING)
&& dtp->u.p.advance_status != ADVANCE_NO)
next_record (dtp, 1);
- return;
+ goto done;
}
dtp->u.p.current_unit->current_record = 0;
{
fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
dtp->u.p.seen_dollar = 0;
- return;
+ goto done;
}
/* 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)
{
+ if (dtp->u.p.skips > 0)
+ {
+ int tmp;
+ write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
+ 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;
+ dtp->u.p.skips = 0;
+ }
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, dtp->u.p.mode);
- return;
+ goto done;
}
- else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
+ 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);
+ fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
dtp->u.p.current_unit->saved_pos = 0;
-
+ dtp->u.p.current_unit->last_char = EOF - 1;
next_record (dtp, 1);
+
+ done:
+
+ if (dtp->u.p.unit_is_internal)
+ {
+ fbuf_destroy (dtp->u.p.current_unit);
+ if (dtp->u.p.current_unit
+ && (dtp->u.p.current_unit->child_dtio == 0)
+ && dtp->u.p.current_unit->s)
+ {
+ sclose (dtp->u.p.current_unit->s);
+ dtp->u.p.current_unit->s = NULL;
+ }
+ }
+
+#ifdef HAVE_USELOCALE
+ if (dtp->u.p.old_locale != (locale_t) 0)
+ {
+ uselocale (dtp->u.p.old_locale);
+ dtp->u.p.old_locale = (locale_t) 0;
+ }
+#else
+ __gthread_mutex_lock (&old_locale_lock);
+ if (!--old_locale_ctr)
+ {
+ setlocale (LC_NUMERIC, old_locale);
+ old_locale = NULL;
+ }
+ __gthread_mutex_unlock (&old_locale_lock);
+#endif
}
/* Transfer function for IOLENGTH. It doesn't actually do any
data transfer, it just updates the length counter. */
static void
-iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
+iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
void *dest __attribute__ ((unused)),
- int kind __attribute__((unused)),
+ int kind __attribute__((unused)),
size_t size, size_t nelems)
{
if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
st_read_done (st_parameter_dt *dtp)
{
finalize_transfer (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.current_unit != NULL)
- unlock_unit (dtp->u.p.current_unit);
- free_internal_unit (dtp);
-
+ /* If this is a parent READ statement we do not need to retain the
+ internal unit structure for child use. */
+ if (dtp->u.p.current_unit != NULL
+ && dtp->u.p.current_unit->child_dtio == 0)
+ {
+ if (dtp->u.p.unit_is_internal)
+ {
+ if ((dtp->common.flags & IOPARM_DT_HAS_UDTIO) == 0)
+ {
+ free (dtp->u.p.current_unit->filename);
+ dtp->u.p.current_unit->filename = NULL;
+ if (dtp->u.p.current_unit->ls)
+ free (dtp->u.p.current_unit->ls);
+ dtp->u.p.current_unit->ls = NULL;
+ }
+ newunit_free (dtp->common.unit);
+ }
+ if (dtp->u.p.unit_is_internal || dtp->u.p.format_not_saved)
+ {
+ free_format_data (dtp->u.p.fmt);
+ free_format (dtp);
+ }
+ unlock_unit (dtp->u.p.current_unit);
+ }
+
library_end ();
}
{
finalize_transfer (dtp);
- /* Deal with endfile conditions associated with sequential files. */
-
- 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;
+ if (dtp->u.p.current_unit != NULL
+ && dtp->u.p.current_unit->child_dtio == 0)
+ {
+ /* Deal with endfile conditions associated with sequential files. */
+ if (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 AFTER_ENDFILE:
- dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now. */
- break;
+ case AFTER_ENDFILE:
+ dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now. */
+ break;
- case NO_ENDFILE:
- /* Get rid of whatever is after this record. */
- if (!is_internal_unit (dtp))
- 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;
- }
+ case NO_ENDFILE:
+ /* Get rid of whatever is after this record. */
+ if (!is_internal_unit (dtp))
+ 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;
+ }
- 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.current_unit != NULL)
- unlock_unit (dtp->u.p.current_unit);
-
- free_internal_unit (dtp);
+ free_ionml (dtp);
+ /* If this is a parent WRITE statement we do not need to retain the
+ internal unit structure for child use. */
+ if (dtp->u.p.unit_is_internal)
+ {
+ if ((dtp->common.flags & IOPARM_DT_HAS_UDTIO) == 0)
+ {
+ free (dtp->u.p.current_unit->filename);
+ dtp->u.p.current_unit->filename = NULL;
+ if (dtp->u.p.current_unit->ls)
+ free (dtp->u.p.current_unit->ls);
+ dtp->u.p.current_unit->ls = NULL;
+ }
+ newunit_free (dtp->common.unit);
+ }
+ if (dtp->u.p.unit_is_internal || dtp->u.p.format_not_saved)
+ {
+ free_format_data (dtp->u.p.fmt);
+ free_format (dtp);
+ }
+ unlock_unit (dtp->u.p.current_unit);
+ }
library_end ();
}
/* Receives the scalar information for namelist objects and stores it
in a linked list of namelist_info types. */
-extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
- GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
-export_proto(st_set_nml_var);
-
-
-void
-st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
- GFC_INTEGER_4 len, gfc_charlen_type string_length,
- GFC_INTEGER_4 dtype)
+static void
+set_nml_var (st_parameter_dt *dtp, void *var_addr, char *var_name,
+ GFC_INTEGER_4 len, gfc_charlen_type string_length,
+ GFC_INTEGER_4 dtype, void *dtio_sub, void *vtable)
{
namelist_info *t1 = NULL;
namelist_info *nml;
size_t var_name_len = strlen (var_name);
- nml = (namelist_info*) get_mem (sizeof (namelist_info));
+ nml = (namelist_info*) xmalloc (sizeof (namelist_info));
nml->mem_pos = var_addr;
+ nml->dtio_sub = dtio_sub;
+ nml->vtable = vtable;
- nml->var_name = (char*) get_mem (var_name_len + 1);
+ nml->var_name = (char*) xmalloc (var_name_len + 1);
memcpy (nml->var_name, var_name, var_name_len);
nml->var_name[var_name_len] = '\0';
if (nml->var_rank > 0)
{
nml->dim = (descriptor_dimension*)
- get_mem (nml->var_rank * sizeof (descriptor_dimension));
+ xmallocarray (nml->var_rank, sizeof (descriptor_dimension));
nml->ls = (array_loop_spec*)
- get_mem (nml->var_rank * sizeof (array_loop_spec));
+ xmallocarray (nml->var_rank, sizeof (array_loop_spec));
}
else
{
}
}
+extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
+ GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
+export_proto(st_set_nml_var);
+
+void
+st_set_nml_var (st_parameter_dt *dtp, void *var_addr, char *var_name,
+ GFC_INTEGER_4 len, gfc_charlen_type string_length,
+ GFC_INTEGER_4 dtype)
+{
+ set_nml_var (dtp, var_addr, var_name, len, string_length,
+ dtype, NULL, NULL);
+}
+
+
+/* Essentially the same as previous but carrying the dtio procedure
+ and the vtable as additional arguments. */
+extern void st_set_nml_dtio_var (st_parameter_dt *dtp, void *, char *,
+ GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4,
+ void *, void *);
+export_proto(st_set_nml_dtio_var);
+
+
+void
+st_set_nml_dtio_var (st_parameter_dt *dtp, void *var_addr, char *var_name,
+ GFC_INTEGER_4 len, gfc_charlen_type string_length,
+ GFC_INTEGER_4 dtype, void *dtio_sub, void *vtable)
+{
+ set_nml_var (dtp, var_addr, var_name, len, string_length,
+ dtype, dtio_sub, vtable);
+}
+
/* Store the dimensional information for the namelist object. */
extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
index_type, index_type,
index_type stride, index_type lbound,
index_type ubound)
{
- namelist_info * nml;
+ namelist_info *nml;
int n;
n = (int)n_dim;
GFC_DIMENSION_SET(nml->dim[n],lbound,ubound,stride);
}
-/* Reverse memcpy - used for byte swapping. */
-
-void reverse_memcpy (void *dest, const void *src, size_t n)
-{
- char *d, *s;
- size_t i;
-
- d = (char *) dest;
- s = (char *) src + n - 1;
-
- /* Write with ascending order - this is likely faster
- on modern architectures because of write combining. */
- for (i=0; i<n; i++)
- *(d++) = *(s--);
-}
-
/* Once upon a time, a poor innocent Fortran program was reading a
file, when suddenly it hit the end-of-file (EOF). Unfortunately
9.10.2 in F2003. */
void
-hit_eof (st_parameter_dt * dtp)
+hit_eof (st_parameter_dt *dtp)
{
dtp->u.p.current_unit->flags.position = POSITION_APPEND;
case NO_ENDFILE:
case AT_ENDFILE:
generate_error (&dtp->common, LIBERROR_END, NULL);
- if (!is_internal_unit (dtp))
+ if (!is_internal_unit (dtp) && !dtp->u.p.namelist_mode)
{
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;
projects / gcc.git / blobdiff