-/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
- Free Software Foundation, Inc.
+/* Copyright (C) 2002-2014 Free Software Foundation, Inc.
Contributed by Andy Vaught
Namelist transfer functions contributed by Paul Thomas
F2003 I/O support contributed by Jerry DeLisle
{
*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;
}
{
*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;
}
/* 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.
{
*nbytes = 0;
/* Just return something that isn't a NULL pointer, otherwise the
- caller thinks an error occured. */
+ caller thinks an error occurred. */
return empty_string;
}
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;
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;
- 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);
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. */
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;
if (unlikely (short_record))
{
generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
- return FAILURE;
+ return false;
}
- return SUCCESS;
+ return true;
}
-/* Master function for unformatted reads. */
+/* Reverse memcpy - used for byte swapping. */
static void
-unformatted_read (st_parameter_dt *dtp, bt type,
- void *dest, int kind, size_t size, size_t nelems)
+reverse_memcpy (void *dest, const void *src, size_t n)
{
- if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
- || kind == 1)
+ 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)
{
- if (type == BT_CHARACTER)
- size *= GFC_SIZE_OF_CHAR_KIND(kind);
- read_block_direct (dtp, dest, size * nelems);
+ 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;
+ }
+ }
}
- else
- {
- char buffer[16];
- char *p;
- size_t i;
+}
- p = dest;
+/* Master function for unformatted reads. */
+
+static void
+unformatted_read (st_parameter_dt *dtp, bt type,
+ void *dest, int kind, size_t size, size_t nelems)
+{
+ if (type == BT_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);
}
}
}
else
{
- char buffer[16];
+#define BSWAP_BUFSZ 512
+ char buffer[BSWAP_BUFSZ];
char *p;
- size_t i;
+ size_t nrem;
p = source;
/* 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);
}
}
}
+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;
+}
+
+
/* 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,
if (n == 0)
goto need_read_data;
if (!(compile_options.allow_std & GFC_STD_GNU)
+ && require_numeric_type (dtp, type, f))
+ return;
+ if (!(compile_options.allow_std & GFC_STD_F2008)
&& require_type (dtp, BT_INTEGER, type, f))
return;
read_radix (dtp, f, p, kind, 2);
if (n == 0)
goto need_read_data;
if (!(compile_options.allow_std & GFC_STD_GNU)
+ && require_numeric_type (dtp, type, f))
+ return;
+ if (!(compile_options.allow_std & GFC_STD_F2008)
&& require_type (dtp, BT_INTEGER, type, f))
return;
read_radix (dtp, f, p, kind, 8);
if (n == 0)
goto need_read_data;
if (!(compile_options.allow_std & GFC_STD_GNU)
+ && require_numeric_type (dtp, type, f))
+ return;
+ if (!(compile_options.allow_std & GFC_STD_F2008)
&& require_type (dtp, BT_INTEGER, type, f))
return;
read_radix (dtp, f, p, kind, 16);
if (n == 0)
goto need_data;
if (!(compile_options.allow_std & GFC_STD_GNU)
+ && require_numeric_type (dtp, type, f))
+ return;
+ if (!(compile_options.allow_std & GFC_STD_F2008)
&& require_type (dtp, BT_INTEGER, type, f))
return;
write_b (dtp, f, p, kind);
if (n == 0)
goto need_data;
if (!(compile_options.allow_std & GFC_STD_GNU)
+ && require_numeric_type (dtp, type, f))
+ return;
+ if (!(compile_options.allow_std & GFC_STD_F2008)
&& require_type (dtp, BT_INTEGER, type, f))
return;
write_o (dtp, f, p, kind);
if (n == 0)
goto need_data;
if (!(compile_options.allow_std & GFC_STD_GNU)
+ && require_numeric_type (dtp, type, f))
+ return;
+ if (!(compile_options.allow_std & GFC_STD_F2008)
&& require_type (dtp, BT_INTEGER, type, f))
return;
write_z (dtp, f, p, kind);
}
}
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)
{
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)
= !(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 =
+ compile_options.allow_std & GFC_STD_GNU ? DELIM_QUOTE : DELIM_NONE;
+ 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;
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");
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 =
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);
{
bytes_left = (int) dtp->u.p.current_unit->bytes_left;
bytes_left = min_off (bytes_left,
- file_length (dtp->u.p.current_unit->s)
+ ssize (dtp->u.p.current_unit->s)
- stell (dtp->u.p.current_unit->s));
if (sseek (dtp->u.p.current_unit->s,
bytes_left, SEEK_CUR) < 0)
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;
return nbyte - bytes_left;
}
-static inline void
-memset4 (gfc_char4_t *p, gfc_char4_t c, int k)
-{
- int j;
- for (j = 0; j < k; j++)
- *p++ = c;
-}
/* Position to the next record in write mode. */
{
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);
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)
pre_position (dtp);
fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
+ smarkeor (dtp->u.p.current_unit->s);
}
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->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
{
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
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;
projects / gcc.git / blobdiff