+2009-04-05 Daniel Kraft <d@domob.eu>
+
+ PR fortran/38654
+ * io/read.c (read_f): Reworked to speed up floating point parsing.
+ (convert_real): Use pointer-casting instead of memcpy and temporaries.
+
+2009-04-05 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ PR libfortran/37754
+ * io/io.h (format_hash_entry): New structure for hash table.
+ (format_hash_table): The hash table itself.
+ (free_format_data): Revise function prototype.
+ (free_format_hash_table, init_format_hash,
+ free_format_hash): New function prototypes.
+ * io/unit.c (close_unit_1): Use free_format_hash_table.
+ * io/transfer.c (st_read_done, st_write_done): Free format data if
+ internal unit.
+ * io/format.c (free_format_hash_table): New function that frees any
+ memory allocated previously for cached format data.
+ (reset_node): New static helper function to reset the format counters
+ for a format node.
+ (reset_fnode_counters): New static function recursively calls reset_node
+ to traverse the fnode tree.
+ (format_hash): New simple hash function based on XOR, probabalistic,
+ tosses collisions.
+ (save_parsed_format): New static function to save the parsed format
+ data to use again.
+ (find_parsed_format): New static function searches the hash table
+ looking for a match.
+ (free_format_data): Revised to accept pointer to format data rather than
+ the dtp pointer so that the function can be used in more places.
+ (format_lex): Editorial.
+ (parse_format_list): Set flag used to determine of format data hashing
+ is to be used. Internal units are not persistent enough for this.
+ (revert): Move to ne location in file.
+ (parse_format): Use new functions to look for previously parsed
+ format strings and use them rather than re-parse. If not found, saves
+ the parsed format data for later use.
+
+2009-04-05 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ PR libfortran/37754
+ * io/transfer.c (formatted_transfer_scalar): Remove this function by
+ factoring it into two new functions, one for read and one for write,
+ eliminating all the conditionals for read or write mode.
+ (formatted transfer_scalar_read): New function.
+ (formatted transfer_scalar_write): New function.
+ (formatted_transfer): Use new functions.
+
+2009-04-05 Janne Blomqvist <jb@gcc.gnu.org>
+
+ PR libfortran/25561 libfortran/37754
+ * io/io.h (struct stream): Define new stream interface function
+ pointers, and inline functions for accessing it.
+ (struct fbuf): Use int instead of size_t, remove flushed element.
+ (mem_alloc_w): New prototype.
+ (mem_alloc_r): New prototype.
+ (stream_at_bof): Remove prototype.
+ (stream_at_eof): Remove prototype.
+ (file_position): Remove prototype.
+ (flush): Remove prototype.
+ (stream_offset): Remove prototype.
+ (unit_truncate): New prototype.
+ (read_block_form): Change to return pointer, int* argument.
+ (hit_eof): New prototype.
+ (fbuf_init): Change prototype.
+ (fbuf_reset): Change prototype.
+ (fbuf_alloc): Change prototype.
+ (fbuf_flush): Change prototype.
+ (fbuf_seek): Change prototype.
+ (fbuf_read): New prototype.
+ (fbuf_getc_refill): New prototype.
+ (fbuf_getc): New inline function.
+ * io/fbuf.c (fbuf_init): Use int, get rid of flushed.
+ (fbuf_debug): New function.
+ (fbuf_reset): Flush, and return position offset.
+ (fbuf_alloc): Simplify, don't flush, just realloc.
+ (fbuf_flush): Make usable for read mode, salvage remaining bytes.
+ (fbuf_seek): New whence argument.
+ (fbuf_read): New function.
+ (fbuf_getc_refill): New function.
+ * io/file_pos.c (formatted_backspace): Use new stream interface.
+ (unformatted_backspace): Likewise.
+ (st_backspace): Make sure format buffer is reset, use new stream
+ interface, use unit_truncate.
+ (st_endfile): Likewise.
+ (st_rewind): Likewise.
+ * io/intrinsics.c: Use new stream interface.
+ * io/list_read.c (push_char): Don't use u.p.scratch, use realloc
+ to resize.
+ (free_saved): Don't check u.p.scratch.
+ (next_char): Use new stream interface, use fbuf_getc() for external files.
+ (finish_list_read): flush format buffer.
+ (nml_query): Update to use modified interface:s
+ * io/open.c (test_endfile): Use new stream interface.
+ (edit_modes): Likewise.
+ (new_unit): Likewise, set bytes_left to 1 for stream files.
+ * io/read.c (read_l): Use new read_block_form interface.
+ (read_utf8): Likewise.
+ (read_utf8_char1): Likewise.
+ (read_default_char1): Likewise.
+ (read_utf8_char4): Likewise.
+ (read_default_char4): Likewise.
+ (read_a): Likewise.
+ (read_a_char4): Likewise.
+ (read_decimal): Likewise.
+ (read_radix): Likewise.
+ (read_f): Likewise.
+ * io/transfer.c (read_sf): Use fbuf_read and mem_alloc_r, remove
+ usage of u.p.line_buffer.
+ (read_block_form): Update interface to return pointer, use
+ fbuf_read for direct access.
+ (read_block_direct): Update to new stream interface.
+ (write_block): Use mem_alloc_w for internal I/O.
+ (write_buf): Update to new stream interface.
+ (formatted_transfer_scalar): Don't use u.p.line_buffer, use
+ fbuf_seek for external files.
+ (us_read): Update to new stream interface.
+ (us_write): Likewise.
+ (data_transfer_init): Always check if we switch modes and flush.
+ (skip_record): Use new stream interface, fix comparison.
+ (next_record_r): Check for and reset u.p.at_eof, use new stream
+ interface, use fbuf_getc for spacing.
+ (write_us_marker): Update to new stream interface, don't inline.
+ (next_record_w_unf): Likewise.
+ (sset): New function.
+ (next_record_w): Use new stream interface, use fbuf for printing
+ newline.
+ (next_record): Use new stream interface.
+ (finalize_transfer): Remove sfree call, use new stream interface.
+ (st_iolength_done): Don't use u.p.scratch.
+ (st_read): Don't check for end of file.
+ (st_read_done): Don't use u.p.scratch, use unit_truncate.
+ (hit_eof): New function.
+ * io/unit.c (init_units): Always init fbuf for formatted units.
+ (update_position): Use new stream interface.
+ (unit_truncate): New function.
+ (finish_last_advance_record): Use fbuf to print newline.
+ * io/unix.c: Remove unused SSIZE_MAX macro.
+ (BUFFER_SIZE): Make static const variable rather than macro.
+ (struct unix_stream): Remove dirty_offset, len, method,
+ small_buffer. Order elements by decreasing size.
+ (struct int_stream): Remove.
+ (move_pos_offset): Remove usage of dirty_offset.
+ (reset_stream): Remove.
+ (do_read): Rename to raw_read, update to match new stream
+ interface.
+ (do_write): Rename to raw_write, update to new stream interface.
+ (raw_seek): New function.
+ (raw_tell): New function.
+ (raw_truncate): New function.
+ (raw_close): New function.
+ (raw_flush): New function.
+ (raw_init): New function.
+ (fd_alloc): Remove.
+ (fd_alloc_r_at): Remove.
+ (fd_alloc_w_at): Remove.
+ (fd_sfree): Remove.
+ (fd_seek): Remove.
+ (fd_truncate): Remove.
+ (fd_sset): Remove.
+ (fd_read): Remove.
+ (fd_write): Remove.
+ (fd_close): Remove.
+ (fd_open): Remove.
+ (fd_flush): Rename to buf_flush, update to new stream interface
+ and unix_stream.
+ (buf_read): New function.
+ (buf_write): New function.
+ (buf_seek): New function.
+ (buf_tell): New function.
+ (buf_truncate): New function.
+ (buf_close): New function.
+ (buf_init): New function.
+ (mem_alloc_r_at): Rename to mem_alloc_r, change prototype.
+ (mem_alloc_w_at): Rename to mem_alloc_w, change prototype.
+ (mem_read): Change to match new stream interface.
+ (mem_write): Likewise.
+ (mem_seek): Likewise.
+ (mem_tell): Likewise.
+ (mem_truncate): Likewise.
+ (mem_close): Likewise.
+ (mem_flush): New function.
+ (mem_sfree): Remove.
+ (empty_internal_buffer): Cast to correct type.
+ (open_internal): Use correct type, init function pointers.
+ (fd_to_stream): Test whether to open file as buffered or raw.
+ (output_stream): Remove mode set.
+ (error_stream): Likewise.
+ (flush_all_units_1): Use new stream interface.
+ (flush_all_units): Likewise.
+ (stream_at_bof): Remove.
+ (stream_at_eof): Remove.
+ (file_position): Remove.
+ (file_length): Update logic to use stream interface.
+ (flush): Remove.
+ (stream_offset): Remove.
+ * io/write.c (write_utf8_char4): Use int instead of size_t.
+ (write_x): Extra safety check.
+ (namelist_write_newline): Use new stream interface.
+
2009-03-29 John David Anglin <dave.anglin@nrc-cnrc.gc.ca>
PR fortran/33595
#include <stdlib.h>
+//#define FBUF_DEBUG
+
+
void
-fbuf_init (gfc_unit * u, size_t len)
+fbuf_init (gfc_unit * u, int len)
{
if (len == 0)
len = 512; /* Default size. */
u->fbuf = get_mem (sizeof (fbuf));
u->fbuf->buf = get_mem (len);
u->fbuf->len = len;
- u->fbuf->act = u->fbuf->flushed = u->fbuf->pos = 0;
-}
-
-
-void
-fbuf_reset (gfc_unit * u)
-{
- u->fbuf->act = u->fbuf->flushed = u->fbuf->pos = 0;
+ u->fbuf->act = u->fbuf->pos = 0;
}
if (u->fbuf->buf)
free_mem (u->fbuf->buf);
free_mem (u->fbuf);
+ u->fbuf = NULL;
+}
+
+
+static void
+#ifdef FBUF_DEBUG
+fbuf_debug (gfc_unit * u, const char * format, ...)
+{
+ va_list args;
+ va_start(args, format);
+ vfprintf(stderr, format, args);
+ va_end(args);
+ fprintf (stderr, "fbuf_debug pos: %d, act: %d, buf: ''",
+ u->fbuf->pos, u->fbuf->act);
+ for (int ii = 0; ii < u->fbuf->act; ii++)
+ {
+ putc (u->fbuf->buf[ii], stderr);
+ }
+ fprintf (stderr, "''\n");
+}
+#else
+fbuf_debug (gfc_unit * u __attribute__ ((unused)),
+ const char * format __attribute__ ((unused)),
+ ...) {}
+#endif
+
+
+
+/* You should probably call this before doing a physical seek on the
+ underlying device. Returns how much the physical position was
+ modified. */
+
+int
+fbuf_reset (gfc_unit * u)
+{
+ int seekval = 0;
+
+ if (!u->fbuf)
+ return 0;
+
+ fbuf_debug (u, "fbuf_reset: ");
+ fbuf_flush (u, u->mode);
+ /* If we read past the current position, seek the underlying device
+ back. */
+ if (u->mode == READING && u->fbuf->act > u->fbuf->pos)
+ {
+ seekval = - (u->fbuf->act - u->fbuf->pos);
+ fbuf_debug (u, "fbuf_reset seekval %d, ", seekval);
+ }
+ u->fbuf->act = u->fbuf->pos = 0;
+ return seekval;
}
/* Return a pointer to the current position in the buffer, and increase
the pointer by len. Makes sure that the buffer is big enough,
- reallocating if necessary. If the buffer is not big enough, there are
- three cases to consider:
- 1. If we haven't flushed anything, realloc
- 2. If we have flushed enough that by discarding the flushed bytes
- the request fits into the buffer, do that.
- 3. Else allocate a new buffer, memcpy unflushed active bytes from old
- buffer. */
+ reallocating if necessary. */
char *
-fbuf_alloc (gfc_unit * u, size_t len)
+fbuf_alloc (gfc_unit * u, int len)
{
- size_t newlen;
+ int newlen;
char *dest;
+ fbuf_debug (u, "fbuf_alloc len %d, ", len);
if (u->fbuf->pos + len > u->fbuf->len)
{
- if (u->fbuf->flushed == 0)
- {
- /* Round up to nearest multiple of the current buffer length. */
- newlen = ((u->fbuf->pos + len) / u->fbuf->len + 1) * u->fbuf->len;
- dest = realloc (u->fbuf->buf, newlen);
- if (dest == NULL)
- return NULL;
- u->fbuf->buf = dest;
- u->fbuf->len = newlen;
- }
- else if (u->fbuf->act - u->fbuf->flushed + len < u->fbuf->len)
- {
- memmove (u->fbuf->buf, u->fbuf->buf + u->fbuf->flushed,
- u->fbuf->act - u->fbuf->flushed);
- u->fbuf->act -= u->fbuf->flushed;
- u->fbuf->pos -= u->fbuf->flushed;
- u->fbuf->flushed = 0;
- }
- else
- {
- /* Most general case, flushed != 0, request doesn't fit. */
- newlen = ((u->fbuf->pos - u->fbuf->flushed + len)
- / u->fbuf->len + 1) * u->fbuf->len;
- dest = get_mem (newlen);
- memcpy (dest, u->fbuf->buf + u->fbuf->flushed,
- u->fbuf->act - u->fbuf->flushed);
- u->fbuf->act -= u->fbuf->flushed;
- u->fbuf->pos -= u->fbuf->flushed;
- u->fbuf->flushed = 0;
- u->fbuf->buf = dest;
- u->fbuf->len = newlen;
- }
+ /* Round up to nearest multiple of the current buffer length. */
+ newlen = ((u->fbuf->pos + len) / u->fbuf->len + 1) * u->fbuf->len;
+ dest = realloc (u->fbuf->buf, newlen);
+ if (dest == NULL)
+ return NULL;
+ u->fbuf->buf = dest;
+ u->fbuf->len = newlen;
}
dest = u->fbuf->buf + u->fbuf->pos;
}
-
+/* mode argument is WRITING for write mode and READING for read
+ mode. Return value is 0 for success, -1 on failure. */
int
-fbuf_flush (gfc_unit * u, int record_done)
+fbuf_flush (gfc_unit * u, unit_mode mode)
{
- int status;
- size_t nbytes;
+ int nwritten;
if (!u->fbuf)
return 0;
- if (u->fbuf->act - u->fbuf->flushed != 0)
+
+ fbuf_debug (u, "fbuf_flush with mode %d: ", mode);
+
+ if (mode == WRITING)
{
- if (record_done)
- nbytes = u->fbuf->act - u->fbuf->flushed;
- else
- nbytes = u->fbuf->pos - u->fbuf->flushed;
- status = swrite (u->s, u->fbuf->buf + u->fbuf->flushed, &nbytes);
- u->fbuf->flushed += nbytes;
+ if (u->fbuf->pos > 0)
+ {
+ nwritten = swrite (u->s, u->fbuf->buf, u->fbuf->pos);
+ if (nwritten < 0)
+ return -1;
+ }
}
- else
- status = 0;
- if (record_done)
- fbuf_reset (u);
- return status;
+ /* Salvage remaining bytes for both reading and writing. This
+ happens with the combination of advance='no' and T edit
+ descriptors leaving the final position somewhere not at the end
+ of the record. For reading, this also happens if we sread() past
+ the record boundary. */
+ if (u->fbuf->act > u->fbuf->pos && u->fbuf->pos > 0)
+ memmove (u->fbuf->buf, u->fbuf->buf + u->fbuf->pos,
+ u->fbuf->act - u->fbuf->pos);
+
+ u->fbuf->act -= u->fbuf->pos;
+ u->fbuf->pos = 0;
+
+ return 0;
}
int
-fbuf_seek (gfc_unit * u, gfc_offset off)
+fbuf_seek (gfc_unit * u, int off, int whence)
{
- gfc_offset pos = u->fbuf->pos + off;
- /* Moving to the left past the flushed marked would imply moving past
- the left tab limit, which is never allowed. So return error if
- that is attempted. */
- if (pos < (gfc_offset) u->fbuf->flushed)
+ if (!u->fbuf)
return -1;
- u->fbuf->pos = pos;
- return 0;
+
+ switch (whence)
+ {
+ case SEEK_SET:
+ break;
+ case SEEK_CUR:
+ off += u->fbuf->pos;
+ break;
+ case SEEK_END:
+ off += u->fbuf->act;
+ break;
+ default:
+ return -1;
+ }
+
+ fbuf_debug (u, "fbuf_seek, off %d ", off);
+ /* The start of the buffer is always equal to the left tab
+ limit. Moving to the left past the buffer is illegal in C and
+ would also imply moving past the left tab limit, which is never
+ allowed in Fortran. Similarly, seeking past the end of the buffer
+ is not possible, in that case the user must make sure to allocate
+ space with fbuf_alloc(). So return error if that is
+ attempted. */
+ if (off < 0 || off > u->fbuf->act)
+ return -1;
+ u->fbuf->pos = off;
+ return off;
+}
+
+
+/* Fill the buffer with bytes for reading. Returns a pointer to start
+ reading from. If we hit EOF, returns a short read count. If any
+ other error occurs, return NULL. After reading, the caller is
+ expected to call fbuf_seek to update the position with the number
+ of bytes actually processed. */
+
+char *
+fbuf_read (gfc_unit * u, int * len)
+{
+ char *ptr;
+ int oldact, oldpos;
+ int readlen = 0;
+
+ fbuf_debug (u, "fbuf_read, len %d: ", *len);
+ oldact = u->fbuf->act;
+ oldpos = u->fbuf->pos;
+ ptr = fbuf_alloc (u, *len);
+ u->fbuf->pos = oldpos;
+ if (oldpos + *len > oldact)
+ {
+ fbuf_debug (u, "reading %d bytes starting at %d ",
+ oldpos + *len - oldact, oldact);
+ readlen = sread (u->s, u->fbuf->buf + oldact, oldpos + *len - oldact);
+ if (readlen < 0)
+ return NULL;
+ *len = oldact - oldpos + readlen;
+ }
+ u->fbuf->act = oldact + readlen;
+ fbuf_debug (u, "fbuf_read done: ");
+ return ptr;
+}
+
+
+/* When the fbuf_getc() inline function runs out of buffer space, it
+ calls this function to fill the buffer with bytes for
+ reading. Never call this function directly. */
+
+int
+fbuf_getc_refill (gfc_unit * u)
+{
+ int nread;
+ char *p;
+
+ fbuf_debug (u, "fbuf_getc_refill ");
+
+ /* Read 80 bytes (average line length?). This is a compromise
+ between not needing to call the read() syscall all the time and
+ not having to memmove unnecessary stuff when switching to the
+ next record. */
+ nread = 80;
+
+ p = fbuf_read (u, &nread);
+
+ if (p && nread > 0)
+ return (unsigned char) u->fbuf->buf[u->fbuf->pos++];
+ else
+ return EOF;
}
{
gfc_offset base;
char p[READ_CHUNK];
- size_t n;
+ ssize_t n;
- base = file_position (u->s) - 1;
+ base = stell (u->s) - 1;
do
{
n = (base < READ_CHUNK) ? base : READ_CHUNK;
base -= n;
- if (sseek (u->s, base) == FAILURE)
+ if (sseek (u->s, base, SEEK_SET) < 0)
goto io_error;
- if (sread (u->s, p, &n) != 0)
+ if (sread (u->s, p, n) != n)
goto io_error;
/* We have moved backwards from the current position, it should
/* base is the new pointer. Seek to it exactly. */
done:
- if (sseek (u->s, base) == FAILURE)
+ if (sseek (u->s, base, SEEK_SET) < 0)
goto io_error;
u->last_record--;
u->endfile = NO_ENDFILE;
static void
unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
{
- gfc_offset m, new;
+ gfc_offset m, slen;
GFC_INTEGER_4 m4;
GFC_INTEGER_8 m8;
- size_t length;
+ ssize_t length;
int continued;
char p[sizeof (GFC_INTEGER_8)];
do
{
- if (sseek (u->s, file_position (u->s) - length) == FAILURE)
+ slen = - (gfc_offset) length;
+ if (sseek (u->s, slen, SEEK_CUR) < 0)
goto io_error;
- if (sread (u->s, p, &length) != 0)
+ if (sread (u->s, p, length) != length)
goto io_error;
/* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
if (continued)
m = -m;
- if ((new = file_position (u->s) - m - 2*length) < 0)
- new = 0;
-
- if (sseek (u->s, new) == FAILURE)
+ if (sseek (u->s, -m -2 * length, SEEK_CUR) < 0)
goto io_error;
} while (continued);
goto done;
}
- if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED)
- {
- generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
- "Cannot BACKSPACE an unformatted stream file");
- goto done;
- }
+ if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED)
+ {
+ generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
+ "Cannot BACKSPACE an unformatted stream file");
+ goto done;
+ }
+
+ /* Make sure format buffer is flushed and reset. */
+ if (u->flags.form == FORM_FORMATTED)
+ {
+ int pos = fbuf_reset (u);
+ if (pos != 0)
+ sseek (u->s, pos, SEEK_CUR);
+ }
- /* Make sure format buffer is flushed. */
- fbuf_flush (u, 1);
/* Check for special cases involving the ENDFILE record first. */
{
u->endfile = AT_ENDFILE;
u->flags.position = POSITION_APPEND;
- flush (u->s);
+ sflush (u->s);
}
else
{
- if (file_position (u->s) == 0)
+ if (stell (u->s) == 0)
{
u->flags.position = POSITION_REWIND;
goto done; /* Common special case */
u->previous_nonadvancing_write = 0;
- flush (u->s);
- struncate (u->s);
+ unit_truncate (u, stell (u->s), &fpp->common);
u->mode = READING;
}
else
unformatted_backspace (fpp, u);
- update_position (u);
+ u->flags.position = POSITION_UNSPECIFIED;
u->endfile = NO_ENDFILE;
u->current_record = 0;
u->bytes_left = 0;
next_record (&dtp, 1);
}
- flush (u->s);
- struncate (u->s);
+ unit_truncate (u, stell (u->s), &fpp->common);
u->endfile = AFTER_ENDFILE;
- update_position (u);
+ if (0 == stell (u->s))
+ u->flags.position = POSITION_REWIND;
done:
unlock_unit (u);
}
written record is the last record in the file, so truncate the
file now. Reset to read mode so two consecutive rewind
statements do not delete the file contents. */
- flush (u->s);
- if (u->mode == WRITING && u->flags.access != ACCESS_STREAM)
- struncate (u->s);
+ if (u->mode == WRITING)
+ {
+ /* unit_truncate takes care of flushing. */
+ unit_truncate (u, stell (u->s), &fpp->common);
+ /* .. but we still need to reset since we're going to seek. */
+ fbuf_reset (u);
+ }
+ else
+ {
+ /* Make sure buffers are reset. */
+ if (u->flags.form == FORM_FORMATTED)
+ fbuf_reset (u);
+ sflush (u->s);
+ }
u->mode = READING;
u->last_record = 0;
- if (file_position (u->s) != 0 && sseek (u->s, 0) == FAILURE)
+ if (sseek (u->s, 0, SEEK_SET) < 0)
generate_error (&fpp->common, LIBERROR_OS, NULL);
/* Handle special files like /dev/null differently. */
else
{
/* Set this for compatibilty with g77 for /dev/null. */
- if (file_length (u->s) == 0 && file_position (u->s) == 0)
+ if (file_length (u->s) == 0 && stell (u->s) == 0)
u->endfile = AT_ENDFILE;
/* Future refinements on special files can go here. */
}
u = find_unit (fpp->common.unit);
if (u != NULL)
{
- flush (u->s);
+ /* Make sure format buffer is flushed. */
+ if (u->flags.form == FORM_FORMATTED)
+ fbuf_flush (u, u->mode);
+
+ sflush (u->s);
unlock_unit (u);
}
else
#include "io.h"
#include <ctype.h>
#include <string.h>
+#include <stdbool.h>
#define FARRAY_SIZE 64
static const fnode colon_node = { FMT_COLON, 0, NULL, NULL, {{ 0, 0, 0 }}, 0,
NULL };
-/* Error messages */
+/* Error messages. */
static const char posint_required[] = "Positive width required in format",
period_required[] = "Period required in format",
reversion_error[] = "Exhausted data descriptors in format",
zero_width[] = "Zero width in format descriptor";
+/* The following routines support caching format data from parsed format strings
+ into a hash table. This avoids repeatedly parsing duplicate format strings
+ or format strings in I/O statements that are repeated in loops. */
+
+
+/* Traverse the table and free all data. */
+
+void
+free_format_hash_table (gfc_unit *u)
+{
+ size_t i;
+
+ /* free_format_data handles any NULL pointers. */
+ for (i = 0; i < FORMAT_HASH_SIZE; i++)
+ {
+ if (u->format_hash_table[i].hashed_fmt != NULL)
+ free_format_data (u->format_hash_table[i].hashed_fmt);
+ u->format_hash_table[i].hashed_fmt = NULL;
+ }
+}
+
+/* Traverse the format_data structure and reset the fnode counters. */
+
+static void
+reset_node (fnode *fn)
+{
+ fnode *f;
+
+ fn->count = 0;
+ fn->current = NULL;
+
+ if (fn->format != FMT_LPAREN)
+ return;
+
+ for (f = fn->u.child; f; f = f->next)
+ {
+ if (f->format == FMT_RPAREN)
+ break;
+ reset_node (f);
+ }
+}
+
+static void
+reset_fnode_counters (st_parameter_dt *dtp)
+{
+ fnode *f;
+ format_data *fmt;
+
+ fmt = dtp->u.p.fmt;
+
+ /* Clear this pointer at the head so things start at the right place. */
+ fmt->array.array[0].current = NULL;
+
+ for (f = fmt->last->array[0].u.child; f; f = f->next)
+ reset_node (f);
+}
+
+
+/* A simple hashing function to generate an index into the hash table. */
+
+static inline
+uint32_t format_hash (st_parameter_dt *dtp)
+{
+ char *key;
+ size_t key_len;
+ uint32_t hash = 0;
+ size_t i;
+
+ /* Hash the format string. Super simple, but what the heck! */
+ key = dtp->format;
+ key_len = dtp->format_len;
+ for (i = 0; i < key_len; i++)
+ hash ^= key[i];
+ hash &= (FORMAT_HASH_SIZE - 1);
+ return hash;
+}
+
+
+static void
+save_parsed_format (st_parameter_dt *dtp)
+{
+ uint32_t hash;
+ gfc_unit *u;
+
+ hash = format_hash (dtp);
+ u = dtp->u.p.current_unit;
+
+ /* Index into the hash table. We are simply replacing whatever is there
+ relying on probability. */
+ if (u->format_hash_table[hash].hashed_fmt != NULL)
+ free_format_data (u->format_hash_table[hash].hashed_fmt);
+ u->format_hash_table[hash].hashed_fmt = NULL;
+
+ u->format_hash_table[hash].key = dtp->format;
+ u->format_hash_table[hash].key_len = dtp->format_len;
+ u->format_hash_table[hash].hashed_fmt = dtp->u.p.fmt;
+}
+
+
+static format_data *
+find_parsed_format (st_parameter_dt *dtp)
+{
+ uint32_t hash;
+ gfc_unit *u;
+
+ hash = format_hash (dtp);
+ u = dtp->u.p.current_unit;
+
+ if (u->format_hash_table[hash].key != NULL)
+ {
+ /* See if it matches. */
+ if (u->format_hash_table[hash].key_len == dtp->format_len)
+ {
+ /* So far so good. */
+ if (strncmp (u->format_hash_table[hash].key,
+ dtp->format, dtp->format_len) == 0)
+ return u->format_hash_table[hash].hashed_fmt;
+ }
+ }
+ return NULL;
+}
+
+
/* next_char()-- Return the next character in the format string.
* Returns -1 when the string is done. If the literal flag is set,
* spaces are significant, otherwise they are not. */
return -1;
fmt->format_string_len--;
- fmt->error_element = c = toupper (*fmt->format_string++);
+ c = toupper (*fmt->format_string++);
+ fmt->error_element = c;
}
while ((c == ' ' || c == '\t') && !literal);
/* free_format_data()-- Free all allocated format data. */
void
-free_format_data (st_parameter_dt *dtp)
+free_format_data (format_data *fmt)
{
fnode_array *fa, *fa_next;
- format_data *fmt = dtp->u.p.fmt;
+
if (fmt == NULL)
return;
}
free_mem (fmt);
- dtp->u.p.fmt = NULL;
+ fmt = NULL;
}
switch (c)
{
+ case '(':
+ token = FMT_LPAREN;
+ break;
+
+ case ')':
+ token = FMT_RPAREN;
+ break;
+
case '-':
negative_flag = 1;
/* Fall Through */
break;
- case '(':
- token = FMT_LPAREN;
- break;
-
- case ')':
- token = FMT_RPAREN;
- break;
-
case 'X':
token = FMT_X;
break;
format_token t, u, t2;
int repeat;
format_data *fmt = dtp->u.p.fmt;
+ bool save_format;
head = tail = NULL;
+ save_format = !is_internal_unit (dtp);
/* Get the next format item */
format_item:
case FMT_DP:
notify_std (&dtp->common, GFC_STD_F2003, "Fortran 2003: DC or DP "
"descriptor not allowed");
+ save_format = true;
/* Fall through. */
case FMT_S:
case FMT_SS:
get_fnode (fmt, &head, &tail, FMT_DOLLAR);
tail->repeat = 1;
notify_std (&dtp->common, GFC_STD_GNU, "Extension: $ descriptor");
+ save_format = false;
goto between_desc;
fmt->saved_token = t;
fmt->value = 1; /* Default width */
notify_std (&dtp->common, GFC_STD_GNU, posint_required);
+ save_format = false;
}
}
}
+/* revert()-- Do reversion of the format. Control reverts to the left
+ * parenthesis that matches the rightmost right parenthesis. From our
+ * tree structure, we are looking for the rightmost parenthesis node
+ * at the second level, the first level always being a single
+ * parenthesis node. If this node doesn't exit, we use the top
+ * level. */
+
+static void
+revert (st_parameter_dt *dtp)
+{
+ fnode *f, *r;
+ format_data *fmt = dtp->u.p.fmt;
+
+ dtp->u.p.reversion_flag = 1;
+
+ r = NULL;
+
+ for (f = fmt->array.array[0].u.child; f; f = f->next)
+ if (f->format == FMT_LPAREN)
+ r = f;
+
+ /* If r is NULL because no node was found, the whole tree will be used */
+
+ fmt->array.array[0].current = r;
+ fmt->array.array[0].count = 0;
+}
+
/* parse_format()-- Parse a format string. */
void
{
format_data *fmt;
+ /* Lookup format string to see if it has already been parsed. */
+
+ dtp->u.p.fmt = find_parsed_format (dtp);
+
+ if (dtp->u.p.fmt != NULL)
+ {
+ dtp->u.p.fmt->reversion_ok = 0;
+ dtp->u.p.fmt->saved_token = FMT_NONE;
+ dtp->u.p.fmt->saved_format = NULL;
+ reset_fnode_counters (dtp);
+ return;
+ }
+
+ /* Not found so proceed as follows. */
+
dtp->u.p.fmt = fmt = get_mem (sizeof (format_data));
fmt->format_string = dtp->format;
fmt->format_string_len = dtp->format_len;
fmt->error = "Missing initial left parenthesis in format";
if (fmt->error)
- format_error (dtp, NULL, fmt->error);
-}
-
-
-/* revert()-- Do reversion of the format. Control reverts to the left
- * parenthesis that matches the rightmost right parenthesis. From our
- * tree structure, we are looking for the rightmost parenthesis node
- * at the second level, the first level always being a single
- * parenthesis node. If this node doesn't exit, we use the top
- * level. */
-
-static void
-revert (st_parameter_dt *dtp)
-{
- fnode *f, *r;
- format_data *fmt = dtp->u.p.fmt;
-
- dtp->u.p.reversion_flag = 1;
-
- r = NULL;
-
- for (f = fmt->array.array[0].u.child; f; f = f->next)
- if (f->format == FMT_LPAREN)
- r = f;
-
- /* If r is NULL because no node was found, the whole tree will be used */
-
- fmt->array.array[0].current = r;
- fmt->array.array[0].count = 0;
+ {
+ format_error (dtp, NULL, fmt->error);
+ free_format_hash_table (dtp->u.p.current_unit);
+ return;
+ }
+ save_parsed_format (dtp);
}
s = 1;
memset (c, ' ', c_len);
- ret = sread (u->s, c, &s);
+ ret = sread (u->s, c, s);
unlock_unit (u);
- if (ret != 0)
+ if (ret < 0)
return ret;
- if (s != 1)
+ if (ret != 1)
return -1;
else
return 0;
PREFIX(fputc) (const int * unit, char * c,
gfc_charlen_type c_len __attribute__((unused)))
{
- size_t s;
- int ret;
+ ssize_t s;
gfc_unit * u = find_unit (*unit);
if (u == NULL)
return -1;
- s = 1;
- ret = swrite (u->s, c, &s);
+ s = swrite (u->s, c, 1);
unlock_unit (u);
- return ret;
+ if (s < 0)
+ return -1;
+ return 0;
}
us = find_unit (*unit);
if (us != NULL)
{
- flush (us->s);
+ sflush (us->s);
unlock_unit (us);
}
}
us = find_unit (*unit);
if (us != NULL)
{
- flush (us->s);
+ sflush (us->s);
unlock_unit (us);
}
}
fseek_sub (int * unit, GFC_IO_INT * offset, int * whence, int * status)
{
gfc_unit * u = find_unit (*unit);
- try result = FAILURE;
+ ssize_t result = -1;
if (u != NULL && is_seekable(u->s))
{
- if (*whence == 0)
- result = sseek(u->s, *offset); /* SEEK_SET */
- else if (*whence == 1)
- result = sseek(u->s, file_position(u->s) + *offset); /* SEEK_CUR */
- else if (*whence == 2)
- result = sseek(u->s, file_length(u->s) + *offset); /* SEEK_END */
+ result = sseek(u->s, *offset, *whence);
unlock_unit (u);
}
if (status)
- *status = (result == FAILURE ? -1 : 0);
+ *status = (result < 0 ? -1 : 0);
}
size_t ret;
if (u == NULL)
return ((size_t) -1);
- ret = (size_t) stream_offset (u->s);
+ ret = (size_t) stell (u->s);
unlock_unit (u);
return ret;
}
*offset = -1; \
else \
{ \
- *offset = stream_offset (u->s); \
+ *offset = stell (u->s); \
unlock_unit (u); \
} \
}
typedef struct stream
{
- char *(*alloc_w_at) (struct stream *, int *);
- try (*sfree) (struct stream *);
- try (*close) (struct stream *);
- try (*seek) (struct stream *, gfc_offset);
- try (*trunc) (struct stream *);
- int (*read) (struct stream *, void *, size_t *);
- int (*write) (struct stream *, const void *, size_t *);
- try (*set) (struct stream *, int, size_t);
+ ssize_t (*read) (struct stream *, void *, ssize_t);
+ ssize_t (*write) (struct stream *, const void *, ssize_t);
+ off_t (*seek) (struct stream *, off_t, int);
+ off_t (*tell) (struct stream *);
+ int (*truncate) (struct stream *, off_t);
+ int (*flush) (struct stream *);
+ int (*close) (struct stream *);
}
stream;
-typedef enum
-{ SYNC_BUFFERED, SYNC_UNBUFFERED, ASYNC }
-io_mode;
+/* Inline functions for doing file I/O given a stream. */
+static inline ssize_t
+sread (stream * s, void * buf, ssize_t nbyte)
+{
+ return s->read (s, buf, nbyte);
+}
-/* Macros for doing file I/O given a stream. */
+static inline ssize_t
+swrite (stream * s, const void * buf, ssize_t nbyte)
+{
+ return s->write (s, buf, nbyte);
+}
-#define sfree(s) ((s)->sfree)(s)
-#define sclose(s) ((s)->close)(s)
+static inline off_t
+sseek (stream * s, off_t offset, int whence)
+{
+ return s->seek (s, offset, whence);
+}
-#define salloc_w(s, len) ((s)->alloc_w_at)(s, len)
+static inline off_t
+stell (stream * s)
+{
+ return s->tell (s);
+}
-#define sseek(s, pos) ((s)->seek)(s, pos)
-#define struncate(s) ((s)->trunc)(s)
-#define sread(s, buf, nbytes) ((s)->read)(s, buf, nbytes)
-#define swrite(s, buf, nbytes) ((s)->write)(s, buf, nbytes)
+static inline int
+struncate (stream * s, off_t length)
+{
+ return s->truncate (s, length);
+}
+
+static inline int
+sflush (stream * s)
+{
+ return s->flush (s);
+}
+
+static inline int
+sclose (stream * s)
+{
+ return s->close (s);
+}
-#define sset(s, c, n) ((s)->set)(s, c, n)
/* Macros for testing what kinds of I/O we are doing. */
}
array_loop_spec;
+/* A stucture to build a hash table for format data. */
+
+#define FORMAT_HASH_SIZE 16
+
+typedef struct format_hash_entry
+{
+ char *key;
+ gfc_charlen_type key_len;
+ struct format_data *hashed_fmt;
+}
+format_hash_entry;
+
/* Representation of a namelist object in libgfortran
Namelist Records
typedef struct namelist_type
{
-
/* Object type, stored as GFC_DTYPE_xxxx. */
bt type;
typedef struct fbuf
{
char *buf; /* Start of buffer. */
- size_t len; /* Length of buffer. */
- size_t act; /* Active bytes in buffer. */
- size_t flushed; /* Flushed bytes from beginning of buffer. */
- size_t pos; /* Current position in buffer. */
+ int len; /* Length of buffer. */
+ int act; /* Active bytes in buffer. */
+ int pos; /* Current position in buffer. */
}
fbuf;
int file_len;
char *file;
+
+ /* The format hash table. */
+ struct format_hash_entry format_hash_table[FORMAT_HASH_SIZE];
/* Formatting buffer. */
struct fbuf *fbuf;
extern stream *open_internal (char *, int, gfc_offset);
internal_proto(open_internal);
+extern char * mem_alloc_w (stream *, int *);
+internal_proto(mem_alloc_w);
+
+extern char * mem_alloc_r (stream *, int *);
+internal_proto(mem_alloc_w);
+
extern stream *input_stream (void);
internal_proto(input_stream);
extern gfc_unit *find_file (const char *file, gfc_charlen_type file_len);
internal_proto(find_file);
-extern int stream_at_bof (stream *);
-internal_proto(stream_at_bof);
-
-extern int stream_at_eof (stream *);
-internal_proto(stream_at_eof);
-
extern int delete_file (gfc_unit *);
internal_proto(delete_file);
extern gfc_offset file_length (stream *);
internal_proto(file_length);
-extern gfc_offset file_position (stream *);
-internal_proto(file_position);
-
extern int is_seekable (stream *);
internal_proto(is_seekable);
extern void empty_internal_buffer(stream *);
internal_proto(empty_internal_buffer);
-extern try flush (stream *);
-internal_proto(flush);
-
extern int stream_isatty (stream *);
internal_proto(stream_isatty);
extern char * stream_ttyname (stream *);
internal_proto(stream_ttyname);
-extern gfc_offset stream_offset (stream *s);
-internal_proto(stream_offset);
-
extern int unpack_filename (char *, const char *, int);
internal_proto(unpack_filename);
extern void finish_last_advance_record (gfc_unit *u);
internal_proto (finish_last_advance_record);
+extern int unit_truncate (gfc_unit *, gfc_offset, st_parameter_common *);
+internal_proto (unit_truncate);
+
/* open.c */
extern gfc_unit *new_unit (st_parameter_open *, gfc_unit *, unit_flags *);
extern void format_error (st_parameter_dt *, const fnode *, const char *);
internal_proto(format_error);
-extern void free_format_data (st_parameter_dt *);
+extern void free_format_data (struct format_data *);
internal_proto(free_format_data);
+extern void free_format_hash_table (gfc_unit *);
+internal_proto(free_format_hash_table);
+
+extern void init_format_hash (st_parameter_dt *);
+internal_proto(init_format_hash);
+
+extern void free_format_hash (st_parameter_dt *);
+internal_proto(free_format_hash);
+
/* transfer.c */
#define SCRATCH_SIZE 300
extern const char *type_name (bt);
internal_proto(type_name);
-extern try read_block_form (st_parameter_dt *, void *, size_t *);
+extern void * read_block_form (st_parameter_dt *, int *);
internal_proto(read_block_form);
extern char *read_sf (st_parameter_dt *, int *, int);
extern void st_wait (st_parameter_wait *);
export_proto(st_wait);
+extern void hit_eof (st_parameter_dt *);
+internal_proto(hit_eof);
+
/* read.c */
extern void set_integer (void *, GFC_INTEGER_LARGEST, int);
internal_proto(size_from_complex_kind);
/* fbuf.c */
-extern void fbuf_init (gfc_unit *, size_t);
+extern void fbuf_init (gfc_unit *, int);
internal_proto(fbuf_init);
extern void fbuf_destroy (gfc_unit *);
internal_proto(fbuf_destroy);
-extern void fbuf_reset (gfc_unit *);
+extern int fbuf_reset (gfc_unit *);
internal_proto(fbuf_reset);
-extern char * fbuf_alloc (gfc_unit *, size_t);
+extern char * fbuf_alloc (gfc_unit *, int);
internal_proto(fbuf_alloc);
-extern int fbuf_flush (gfc_unit *, int);
+extern int fbuf_flush (gfc_unit *, unit_mode);
internal_proto(fbuf_flush);
-extern int fbuf_seek (gfc_unit *, gfc_offset);
+extern int fbuf_seek (gfc_unit *, int, int);
internal_proto(fbuf_seek);
+extern char * fbuf_read (gfc_unit *, int *);
+internal_proto(fbuf_read);
+
+/* Never call this function, only use fbuf_getc(). */
+extern int fbuf_getc_refill (gfc_unit *);
+internal_proto(fbuf_getc_refill);
+
+static inline int
+fbuf_getc (gfc_unit * u)
+{
+ if (u->fbuf->pos < u->fbuf->act)
+ return (unsigned char) u->fbuf->buf[u->fbuf->pos++];
+ return fbuf_getc_refill (u);
+}
+
/* lock.c */
extern void free_ionml (st_parameter_dt *);
internal_proto(free_ionml);
#include "io.h"
#include <string.h>
+#include <stdlib.h>
#include <ctype.h>
if (dtp->u.p.saved_string == NULL)
{
- if (dtp->u.p.scratch == NULL)
- dtp->u.p.scratch = get_mem (SCRATCH_SIZE);
- dtp->u.p.saved_string = dtp->u.p.scratch;
+ dtp->u.p.saved_string = get_mem (SCRATCH_SIZE);
+ // memset below should be commented out.
memset (dtp->u.p.saved_string, 0, SCRATCH_SIZE);
dtp->u.p.saved_length = SCRATCH_SIZE;
dtp->u.p.saved_used = 0;
if (dtp->u.p.saved_used >= dtp->u.p.saved_length)
{
dtp->u.p.saved_length = 2 * dtp->u.p.saved_length;
- new = get_mem (2 * dtp->u.p.saved_length);
-
- memset (new, 0, 2 * dtp->u.p.saved_length);
-
- memcpy (new, dtp->u.p.saved_string, dtp->u.p.saved_used);
- if (dtp->u.p.saved_string != dtp->u.p.scratch)
- free_mem (dtp->u.p.saved_string);
-
+ new = realloc (dtp->u.p.saved_string, dtp->u.p.saved_length);
+ if (new == NULL)
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
dtp->u.p.saved_string = new;
+
+ // Also this should not be necessary.
+ memset (new + dtp->u.p.saved_used, 0,
+ dtp->u.p.saved_length - dtp->u.p.saved_used);
+
}
dtp->u.p.saved_string[dtp->u.p.saved_used++] = c;
if (dtp->u.p.saved_string == NULL)
return;
- if (dtp->u.p.saved_string != dtp->u.p.scratch)
- free_mem (dtp->u.p.saved_string);
+ free_mem (dtp->u.p.saved_string);
dtp->u.p.saved_string = NULL;
dtp->u.p.saved_used = 0;
static char
next_char (st_parameter_dt *dtp)
{
- size_t length;
+ ssize_t length;
gfc_offset record;
char c;
+ int cc;
if (dtp->u.p.last_char != '\0')
{
}
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)
longjmp (*dtp->u.p.eof_jump, 1);
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
/* Get the next character and handle end-of-record conditions. */
- length = 1;
-
- if (sread (dtp->u.p.current_unit->s, &c, &length) != 0)
- {
- generate_error (&dtp->common, LIBERROR_OS, NULL);
- return '\0';
- }
-
- if (is_stream_io (dtp) && length == 1)
- dtp->u.p.current_unit->strm_pos++;
-
if (is_internal_unit (dtp))
{
+ length = sread (dtp->u.p.current_unit->s, &c, 1);
+ if (length < 0)
+ {
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
+ return '\0';
+ }
+
if (is_array_io (dtp))
{
/* Check whether we hit EOF. */
}
else
{
- if (length == 0)
+ cc = fbuf_getc (dtp->u.p.current_unit);
+
+ if (cc == EOF)
{
if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
longjmp (*dtp->u.p.eof_jump, 1);
dtp->u.p.current_unit->endfile = AT_ENDFILE;
c = '\n';
}
+ else
+ c = (char) cc;
+ if (is_stream_io (dtp) && cc != EOF)
+ dtp->u.p.current_unit->strm_pos++;
+
}
done:
dtp->u.p.at_eol = (c == '\n' || c == '\r');
dtp->u.p.input_complete = 0;
dtp->u.p.repeat_count = 1;
dtp->u.p.at_eol = 0;
-
+
c = eat_spaces (dtp);
if (is_separator (c))
{
return;
goto set_value;
}
+
+ if (dtp->u.p.input_complete)
+ goto cleanup;
if (dtp->u.p.input_complete)
goto cleanup;
free_saved (dtp);
+ fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
+
if (dtp->u.p.at_eol)
{
dtp->u.p.at_eol = 0;
/* Flush the stream to force immediate output. */
- fbuf_flush (dtp->u.p.current_unit, 1);
- flush (dtp->u.p.current_unit->s);
+ fbuf_flush (dtp->u.p.current_unit, WRITING);
+ sflush (dtp->u.p.current_unit->s);
unlock_unit (dtp->u.p.current_unit);
}
st_printf ("%s\n", nml_err_msg);
if (u != NULL)
{
- flush (u->s);
+ sflush (u->s);
unlock_unit (u);
}
}
static void
test_endfile (gfc_unit * u)
{
- if (u->endfile == NO_ENDFILE && file_length (u->s) == file_position (u->s))
+ if (u->endfile == NO_ENDFILE && file_length (u->s) == stell (u->s))
u->endfile = AT_ENDFILE;
}
break;
case POSITION_REWIND:
- if (sseek (u->s, 0) == FAILURE)
+ if (sseek (u->s, 0, SEEK_SET) != 0)
goto seek_error;
u->current_record = 0;
break;
case POSITION_APPEND:
- if (sseek (u->s, file_length (u->s)) == FAILURE)
+ if (sseek (u->s, 0, SEEK_END) < 0)
goto seek_error;
if (flags->access != ACCESS_STREAM)
if (flags->position == POSITION_APPEND)
{
- if (sseek (u->s, file_length (u->s)) == FAILURE)
+ if (sseek (u->s, 0, SEEK_END) < 0)
generate_error (&opp->common, LIBERROR_OS, NULL);
u->endfile = AT_ENDFILE;
}
{
u->maxrec = max_offset;
u->recl = 1;
- u->strm_pos = file_position (u->s) + 1;
+ u->bytes_left = 1;
+ u->strm_pos = stell (u->s) + 1;
}
memmove (u->file, opp->file, opp->file_len);
if (flags->status == STATUS_SCRATCH && opp->file != NULL)
free_mem (opp->file);
- if (flags->form == FORM_FORMATTED && (flags->action != ACTION_READ))
+ if (flags->form == FORM_FORMATTED)
{
if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
fbuf_init (u, u->recl);
#include <errno.h>
#include <ctype.h>
#include <stdlib.h>
+#include <assert.h>
typedef unsigned char uchar;
switch (length)
{
case 4:
- {
- GFC_REAL_4 tmp =
+ *((GFC_REAL_4*) dest) =
#if defined(HAVE_STRTOF)
- strtof (buffer, NULL);
+ strtof (buffer, NULL);
#else
- (GFC_REAL_4) strtod (buffer, NULL);
+ (GFC_REAL_4) strtod (buffer, NULL);
#endif
- memcpy (dest, (void *) &tmp, length);
- }
break;
+
case 8:
- {
- GFC_REAL_8 tmp = strtod (buffer, NULL);
- memcpy (dest, (void *) &tmp, length);
- }
+ *((GFC_REAL_8*) dest) = strtod (buffer, NULL);
break;
+
#if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
case 10:
- {
- GFC_REAL_10 tmp = strtold (buffer, NULL);
- memcpy (dest, (void *) &tmp, length);
- }
+ *((GFC_REAL_10*) dest) = strtold (buffer, NULL);
break;
#endif
+
#if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD)
case 16:
- {
- GFC_REAL_16 tmp = strtold (buffer, NULL);
- memcpy (dest, (void *) &tmp, length);
- }
+ *((GFC_REAL_16*) dest) = strtold (buffer, NULL);
break;
#endif
+
default:
internal_error (&dtp->common, "Unsupported real kind during IO");
}
read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
{
char *p;
- size_t w;
+ int w;
w = f->u.w;
- p = gfc_alloca (w);
+ p = read_block_form (dtp, &w);
- if (read_block_form (dtp, p, &w) == FAILURE)
+ if (p == NULL)
return;
while (*p == ' ')
}
-static inline gfc_char4_t
-read_utf8 (st_parameter_dt *dtp, size_t *nbytes)
+static gfc_char4_t
+read_utf8 (st_parameter_dt *dtp, int *nbytes)
{
static const uchar masks[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
static const uchar patns[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
- static uchar buffer[6];
- size_t i, nb, nread;
+ int i, nb, nread;
gfc_char4_t c;
- int status;
char *s;
*nbytes = 1;
- s = (char *) &buffer[0];
- status = read_block_form (dtp, s, nbytes);
- if (status == FAILURE)
+
+ s = read_block_form (dtp, nbytes);
+ if (s == NULL)
return 0;
/* If this is a short read, just return. */
if (*nbytes == 0)
return 0;
- c = buffer[0];
+ c = (uchar) s[0];
if (c < 0x80)
return c;
c = (c & masks[nb-1]);
nread = nb - 1;
- s = (char *) &buffer[1];
- status = read_block_form (dtp, s, &nread);
- if (status == FAILURE)
+ s = read_block_form (dtp, &nread);
+ if (s == NULL)
return 0;
/* Decode the bytes read. */
for (i = 1; i < nb; i++)
static void
-read_utf8_char1 (st_parameter_dt *dtp, char *p, int len, size_t width)
+read_utf8_char1 (st_parameter_dt *dtp, char *p, int len, int width)
{
gfc_char4_t c;
char *dest;
- size_t nbytes;
+ int nbytes;
int i, j;
- len = ((int) width < len) ? len : (int) width;
+ len = (width < len) ? len : width;
dest = (char *) p;
}
static void
-read_default_char1 (st_parameter_dt *dtp, char *p, int len, size_t width)
+read_default_char1 (st_parameter_dt *dtp, char *p, int len, int width)
{
char *s;
- int m, n, status;
+ int m, n;
- s = gfc_alloca (width);
-
- status = read_block_form (dtp, s, &width);
+ s = read_block_form (dtp, &width);
- if (status == FAILURE)
+ if (s == NULL)
return;
- if (width > (size_t) len)
+ if (width > len)
s += (width - len);
- m = ((int) width > len) ? len : (int) width;
+ m = (width > len) ? len : width;
memcpy (p, s, m);
n = len - width;
static void
-read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, size_t width)
+read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, int width)
{
gfc_char4_t *dest;
- size_t nbytes;
+ int nbytes;
int i, j;
- len = ((int) width < len) ? len : (int) width;
+ len = (width < len) ? len : width;
dest = (gfc_char4_t *) p;
static void
-read_default_char4 (st_parameter_dt *dtp, char *p, int len, size_t width)
+read_default_char4 (st_parameter_dt *dtp, char *p, int len, int width)
{
char *s;
gfc_char4_t *dest;
- int m, n, status;
-
- s = gfc_alloca (width);
+ int m, n;
- status = read_block_form (dtp, s, &width);
+ s = read_block_form (dtp, &width);
- if (status == FAILURE)
+ if (s == NULL)
return;
- if (width > (size_t) len)
+ if (width > len)
s += (width - len);
m = ((int) width > len) ? len : (int) width;
read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
{
int wi;
- size_t w;
+ int w;
wi = f->u.w;
if (wi == -1) /* '(A)' edit descriptor */
void
read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, int length)
{
- int wi;
- size_t w;
+ int w;
- wi = f->u.w;
- if (wi == -1) /* '(A)' edit descriptor */
- wi = length;
- w = wi;
+ w = f->u.w;
+ if (w == -1) /* '(A)' edit descriptor */
+ w = length;
/* Read in w characters, treating comma as not a separator. */
dtp->u.p.sf_read_comma = 0;
GFC_UINTEGER_LARGEST value, maxv, maxv_10;
GFC_INTEGER_LARGEST v;
int w, negative;
- size_t wu;
char c, *p;
- wu = f->u.w;
+ w = f->u.w;
- p = gfc_alloca (wu);
+ p = read_block_form (dtp, &w);
- if (read_block_form (dtp, p, &wu) == FAILURE)
+ if (p == NULL)
return;
- w = wu;
-
p = eat_leading_spaces (&w, p);
if (w == 0)
{
GFC_INTEGER_LARGEST v;
int w, negative;
char c, *p;
- size_t wu;
- wu = f->u.w;
+ w = f->u.w;
- p = gfc_alloca (wu);
+ p = read_block_form (dtp, &w);
- if (read_block_form (dtp, p, &wu) == FAILURE)
+ if (p == NULL)
return;
- w = wu;
-
p = eat_leading_spaces (&w, p);
if (w == 0)
{
void
read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
{
- size_t wu;
int w, seen_dp, exponent;
- int exponent_sign, val_sign;
- int ndigits;
- int edigits;
- int i;
- char *p, *buffer;
- char *digits;
- char scratch[SCRATCH_SIZE];
-
- val_sign = 1;
- seen_dp = 0;
- wu = f->u.w;
+ int exponent_sign;
+ const char *p;
+ char *buffer;
+ char *out;
+ int seen_int_digit; /* Seen a digit before the decimal point? */
+ int seen_dec_digit; /* Seen a digit after the decimal point? */
- p = gfc_alloca (wu);
+ seen_dp = 0;
+ seen_int_digit = 0;
+ seen_dec_digit = 0;
+ exponent_sign = 1;
+ exponent = 0;
+ w = f->u.w;
- if (read_block_form (dtp, p, &wu) == FAILURE)
+ /* Read in the next block. */
+ p = read_block_form (dtp, &w);
+ if (p == NULL)
return;
-
- w = wu;
-
- p = eat_leading_spaces (&w, p);
+ p = eat_leading_spaces (&w, (char*) p);
if (w == 0)
goto zero;
- /* Optional sign */
+ /* In this buffer we're going to re-format the number cleanly to be parsed
+ by convert_real in the end; this assures we're using strtod from the
+ C library for parsing and thus probably get the best accuracy possible.
+ This process may add a '+0.0' in front of the number as well as change the
+ exponent because of an implicit decimal point or the like. Thus allocating
+ strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
+ original buffer had should be enough. */
+ buffer = gfc_alloca (w + 11);
+ out = buffer;
+ /* Optional sign */
if (*p == '-' || *p == '+')
{
if (*p == '-')
- val_sign = -1;
- p++;
- w--;
+ *(out++) = '-';
+ ++p;
+ --w;
}
- exponent_sign = 1;
- p = eat_leading_spaces (&w, p);
+ p = eat_leading_spaces (&w, (char*) p);
if (w == 0)
goto zero;
- /* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D')
- is required at this point */
-
- if (!isdigit (*p) && *p != '.' && *p != ',' && *p != 'd' && *p != 'D'
- && *p != 'e' && *p != 'E')
- goto bad_float;
-
- /* Remember the position of the first digit. */
- digits = p;
- ndigits = 0;
-
- /* Scan through the string to find the exponent. */
+ /* Process the mantissa string. */
while (w > 0)
{
switch (*p)
{
case ',':
- if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA
- && *p == ',')
- *p = '.';
- else
+ if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA)
goto bad_float;
- /* Fall through */
+ /* Fall through. */
case '.':
if (seen_dp)
goto bad_float;
+ if (!seen_int_digit)
+ *(out++) = '0';
+ *(out++) = '.';
seen_dp = 1;
- /* Fall through */
+ break;
+ case ' ':
+ if (dtp->u.p.blank_status == BLANK_ZERO)
+ {
+ *(out++) = '0';
+ goto found_digit;
+ }
+ else if (dtp->u.p.blank_status == BLANK_NULL)
+ break;
+ else
+ /* TODO: Should we check instead that there are only trailing
+ blanks here, as is done below for exponents? */
+ goto done;
+ /* Fall through. */
case '0':
case '1':
case '2':
case '7':
case '8':
case '9':
- case ' ':
- ndigits++;
- p++;
- w--;
+ *(out++) = *p;
+found_digit:
+ if (!seen_dp)
+ seen_int_digit = 1;
+ else
+ seen_dec_digit = 1;
break;
case '-':
- exponent_sign = -1;
- /* Fall through */
-
case '+':
- p++;
- w--;
- goto exp2;
+ goto exponent;
- case 'd':
case 'e':
- case 'D':
case 'E':
- p++;
- w--;
- goto exp1;
+ case 'd':
+ case 'D':
+ ++p;
+ --w;
+ goto exponent;
default:
goto bad_float;
}
- }
- /* No exponent has been seen, so we use the current scale factor */
- exponent = -dtp->u.p.scale_factor;
- goto done;
-
- bad_float:
- generate_error (&dtp->common, LIBERROR_READ_VALUE,
- "Bad value during floating point read");
- next_record (dtp, 1);
- return;
-
- /* The value read is zero */
- zero:
- switch (length)
- {
- case 4:
- *((GFC_REAL_4 *) dest) = 0;
- break;
-
- case 8:
- *((GFC_REAL_8 *) dest) = 0;
- break;
-
-#ifdef HAVE_GFC_REAL_10
- case 10:
- *((GFC_REAL_10 *) dest) = 0;
- break;
-#endif
-
-#ifdef HAVE_GFC_REAL_16
- case 16:
- *((GFC_REAL_16 *) dest) = 0;
- break;
-#endif
-
- default:
- internal_error (&dtp->common, "Unsupported real kind during IO");
+ ++p;
+ --w;
}
- return;
+
+ /* No exponent has been seen, so we use the current scale factor. */
+ exponent = - dtp->u.p.scale_factor;
+ goto done;
- /* At this point the start of an exponent has been found */
- exp1:
- while (w > 0 && *p == ' ')
+ /* At this point the start of an exponent has been found. */
+exponent:
+ p = eat_leading_spaces (&w, (char*) p);
+ if (*p == '-' || *p == '+')
{
- w--;
- p++;
+ if (*p == '-')
+ exponent_sign = -1;
+ ++p;
+ --w;
}
- switch (*p)
- {
- case '-':
- exponent_sign = -1;
- /* Fall through */
-
- case '+':
- p++;
- w--;
- break;
- }
+ /* At this point a digit string is required. We calculate the value
+ of the exponent in order to take account of the scale factor and
+ the d parameter before explict conversion takes place. */
if (w == 0)
goto bad_float;
- /* At this point a digit string is required. We calculate the value
- of the exponent in order to take account of the scale factor and
- the d parameter before explict conversion takes place. */
- exp2:
- /* Normal processing of exponent */
- exponent = 0;
if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
{
while (w > 0 && isdigit (*p))
- {
- exponent = 10 * exponent + *p - '0';
- p++;
- w--;
- }
-
- /* Only allow trailing blanks */
-
+ {
+ exponent *= 10;
+ exponent += *p - '0';
+ ++p;
+ --w;
+ }
+
+ /* Only allow trailing blanks. */
while (w > 0)
- {
- if (*p != ' ')
+ {
+ if (*p != ' ')
goto bad_float;
- p++;
- w--;
- }
+ ++p;
+ --w;
+ }
}
- else /* BZ or BN status is enabled */
+ else /* BZ or BN status is enabled. */
{
while (w > 0)
- {
- if (*p == ' ')
- {
- if (dtp->u.p.blank_status == BLANK_ZERO) *p = '0';
- if (dtp->u.p.blank_status == BLANK_NULL)
- {
- p++;
- w--;
- continue;
- }
- }
- else if (!isdigit (*p))
- goto bad_float;
-
- exponent = 10 * exponent + *p - '0';
- p++;
- w--;
- }
+ {
+ if (*p == ' ')
+ {
+ if (dtp->u.p.blank_status == BLANK_ZERO)
+ exponent *= 10;
+ else
+ assert (dtp->u.p.blank_status == BLANK_NULL);
+ }
+ else if (!isdigit (*p))
+ goto bad_float;
+ else
+ {
+ exponent *= 10;
+ exponent += *p - '0';
+ }
+
+ ++p;
+ --w;
+ }
}
- exponent = exponent * exponent_sign;
+ exponent *= exponent_sign;
- done:
+done:
/* Use the precision specified in the format if no decimal point has been
seen. */
if (!seen_dp)
exponent -= f->u.real.d;
- if (exponent > 0)
- {
- edigits = 2;
- i = exponent;
- }
- else
- {
- edigits = 3;
- i = -exponent;
- }
+ /* Output a trailing '0' after decimal point if not yet found. */
+ if (seen_dp && !seen_dec_digit)
+ *(out++) = '0';
- while (i >= 10)
+ /* Print out the exponent to finish the reformatted number. Maximum 4
+ digits for the exponent. */
+ if (exponent != 0)
{
- i /= 10;
- edigits++;
- }
+ int dig;
- i = ndigits + edigits + 1;
- if (val_sign < 0)
- i++;
+ *(out++) = 'e';
+ if (exponent < 0)
+ {
+ *(out++) = '-';
+ exponent = - exponent;
+ }
- if (i < SCRATCH_SIZE)
- buffer = scratch;
- else
- buffer = get_mem (i);
-
- /* Reformat the string into a temporary buffer. As we're using atof it's
- easiest to just leave the decimal point in place. */
- p = buffer;
- if (val_sign < 0)
- *(p++) = '-';
- for (; ndigits > 0; ndigits--)
- {
- if (*digits == ' ')
- {
- if (dtp->u.p.blank_status == BLANK_ZERO) *digits = '0';
- if (dtp->u.p.blank_status == BLANK_NULL)
- {
- digits++;
- continue;
- }
- }
- *p = *digits;
- p++;
- digits++;
+ assert (exponent < 10000);
+ for (dig = 3; dig >= 0; --dig)
+ {
+ out[dig] = (char) ('0' + exponent % 10);
+ exponent /= 10;
+ }
+ out += 4;
}
- *(p++) = 'e';
- sprintf (p, "%d", exponent);
+ *(out++) = '\0';
/* Do the actual conversion. */
convert_real (dtp, dest, buffer, length);
- if (buffer != scratch)
- free_mem (buffer);
+ return;
+ /* The value read is zero. */
+zero:
+ switch (length)
+ {
+ case 4:
+ *((GFC_REAL_4 *) dest) = 0.0;
+ break;
+
+ case 8:
+ *((GFC_REAL_8 *) dest) = 0.0;
+ break;
+
+#ifdef HAVE_GFC_REAL_10
+ case 10:
+ *((GFC_REAL_10 *) dest) = 0.0;
+ break;
+#endif
+
+#ifdef HAVE_GFC_REAL_16
+ case 16:
+ *((GFC_REAL_16 *) dest) = 0.0;
+ break;
+#endif
+
+ default:
+ internal_error (&dtp->common, "Unsupported real kind during IO");
+ }
+ return;
+
+bad_float:
+ generate_error (&dtp->common, LIBERROR_READ_VALUE,
+ "Bad value during floating point read");
+ next_record (dtp, 1);
+ return;
}
#include <string.h>
#include <assert.h>
#include <stdlib.h>
+#include <errno.h>
/* Calling conventions: Data transfer statements are unlike other
heap. Hopefully this won't happen very often. */
char *
-read_sf (st_parameter_dt *dtp, int *length, int no_error)
+read_sf (st_parameter_dt *dtp, int * length, int no_error)
{
+ static char *empty_string[0];
char *base, *p, q;
- int n, crlf;
- gfc_offset pos;
- size_t readlen;
+ int n, lorig, memread, seen_comma;
- if (*length > SCRATCH_SIZE)
- dtp->u.p.line_buffer = get_mem (*length);
- p = base = dtp->u.p.line_buffer;
+ /* If we hit EOF previously with the no_error flag set (i.e. X, T,
+ TR edit descriptors), and we now try to read again, this time
+ without setting no_error. */
+ if (!no_error && dtp->u.p.at_eof)
+ {
+ *length = 0;
+ hit_eof (dtp);
+ return NULL;
+ }
/* 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))
{
- readlen = *length;
- if (unlikely (sread (dtp->u.p.current_unit->s, p, &readlen) != 0
- || readlen < (size_t) *length))
+ memread = *length;
+ base = mem_alloc_r (dtp->u.p.current_unit->s, length);
+ if (unlikely (memread > *length))
{
- generate_error (&dtp->common, LIBERROR_END, NULL);
+ hit_eof (dtp);
return NULL;
}
-
+ n = *length;
goto done;
}
- readlen = 1;
- n = 0;
+ n = seen_comma = 0;
- do
- {
- if (unlikely (sread (dtp->u.p.current_unit->s, &q, &readlen) != 0))
- {
- generate_error (&dtp->common, LIBERROR_END, NULL);
- return NULL;
- }
+ /* 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;
- /* 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;
- }
+ while (n < *length)
+ {
+ q = *p;
- if (readlen < 1 || q == '\n' || q == '\r')
+ if (q == '\n' || q == '\r')
{
/* Unexpected end of line. */
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))
- {
- generate_error (&dtp->common, LIBERROR_END, NULL);
- return NULL;
- }
- if (q != '\n' && readlen == 1) /* Not a CRLF after all. */
- sseek (dtp->u.p.current_unit->s, pos);
- else
- crlf = 1;
+ if (n < *length && *(p + 1) == '\n')
+ dtp->u.p.sf_seen_eor = 2;
}
+ else
+ dtp->u.p.sf_seen_eor = 1;
/* Without padding, terminate the I/O statement without assigning
the value. With padding, the value still needs to be assigned,
}
*length = n;
- dtp->u.p.sf_seen_eor = (crlf ? 2 : 1);
break;
}
/* Short circuit the read if a comma is found during numeric input.
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;
}
n++;
- *p++ = q;
- dtp->u.p.sf_seen_eor = 0;
+ p++;
+ }
+
+ fbuf_seek (dtp->u.p.current_unit, n + dtp->u.p.sf_seen_eor + 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 (no_error)
+ dtp->u.p.at_eof = 1;
+ else
+ {
+ 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_IO_INT) *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))
{
{
/* 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))
{
- 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;
+ source = read_sf (dtp, nbytes, 0);
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_IO_INT) 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;
}
static void
read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
{
- size_t to_read_record;
- size_t have_read_record;
- size_t to_read_subrecord;
- size_t have_read_subrecord;
+ 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,
+ to_read_record);
+ if (unlikely (have_read_record < 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return;
{
/* 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);
+ hit_eof (dtp);
return;
}
return;
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. */
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))
{
- to_read_record = (size_t) dtp->u.p.current_unit->bytes_left;
+ to_read_record = (ssize_t) dtp->u.p.current_unit->bytes_left;
short_record = 1;
}
else
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 = (ssize_t) 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;
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)
{
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;
}
-/* 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))
+ move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
+ else
+ fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, 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_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 (is_internal_unit (dtp))
move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
else
- fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips);
+ 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);
-
+ 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)
- 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:
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);
}
+
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. */
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
return;
}
- /* Check the record number. */
+ /* Check the record or position number. */
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
&& (cf & IOPARM_DT_HAS_REC) == 0)
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)
- {
- /* Required for compatibility between 4.3 and 4.4 runtime. Check
- to see if we might be reading what we wrote before */
- if (dtp->u.p.current_unit->mode == WRITING)
- {
- fbuf_flush (dtp->u.p.current_unit, 1);
- flush(dtp->u.p.current_unit->s);
- }
-
- if (dtp->pos < file_length (dtp->u.p.current_unit->s))
- 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, 1);
- flush (dtp->u.p.current_unit->s);
- if (sseek (dtp->u.p.current_unit->s, dtp->pos - 1) == FAILURE)
- {
- generate_error (&dtp->common, LIBERROR_OS, NULL);
- return;
- }
- dtp->u.p.current_unit->strm_pos = dtp->pos;
- }
- }
+ {
+
+ 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);
+ sflush (dtp->u.p.current_unit->s);
+ 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;
- }
+ {
+ 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 (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;
- }
+ * 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 */
+ 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->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;
- } */
-
+ {
+ generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
+ "Record number not allowed for stream access "
+ "data transfer");
+ return;
+ } */
}
- /* 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);
-
/* Bugware for badly written mixed C-Fortran I/O. */
flush_if_preconnected(dtp->u.p.current_unit->s);
static void
skip_record (st_parameter_dt *dtp, size_t bytes)
{
- gfc_offset new;
size_t rlength;
+ ssize_t readb;
static const size_t MAX_READ = 4096;
char p[MAX_READ];
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);
}
else
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 : (size_t) 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;
}
}
{
gfc_offset record;
int bytes_left;
- size_t length;
char p;
+ int cc;
switch (current_mode (dtp))
{
case FORMATTED_STREAM:
case FORMATTED_SEQUENTIAL:
- length = 1;
- /* sf_read has already terminated input because of an '\n' */
- if (dtp->u.p.sf_seen_eor)
+ /* 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.at_eof)
{
dtp->u.p.sf_seen_eor = 0;
+ dtp->u.p.at_eof = 0;
break;
}
/* 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
+ 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:
/* 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);
+ c = stell (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, c - m - record_marker,
+ SEEK_SET) < 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, c + record_marker,
+ SEEK_SET) < 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->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);
}
if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
{
finish_list_read (dtp);
- sfree (dtp->u.p.current_unit->s);
return;
}
next_record (dtp, 1);
if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
- && file_position (dtp->u.p.current_unit->s) >= dtp->rec)
+ && stell (dtp->u.p.current_unit->s) >= dtp->rec)
{
- flush (dtp->u.p.current_unit->s);
- sfree (dtp->u.p.current_unit->s);
+ sflush (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);
+ sflush (dtp->u.p.current_unit->s);
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
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))
+ 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))
+ 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 (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;
+ }
+}
u->file_len = strlen (stdin_name);
u->file = get_mem (u->file_len);
memmove (u->file, stdin_name, u->file_len);
+
+ fbuf_init (u, 0);
__gthread_mutex_unlock (&u->lock);
}
free_mem (u->file);
u->file = NULL;
u->file_len = 0;
-
+
+ free_format_hash_table (u);
fbuf_destroy (u);
if (!locked)
void
update_position (gfc_unit *u)
{
- if (file_position (u->s) == 0)
+ if (stell (u->s) == 0)
u->flags.position = POSITION_REWIND;
- else if (file_length (u->s) == file_position (u->s))
+ else if (file_length (u->s) == stell (u->s))
u->flags.position = POSITION_APPEND;
else
u->flags.position = POSITION_ASIS;
}
+/* High level interface to truncate a file safely, i.e. flush format
+ buffers, check that it's a regular file, and generate error if that
+ occurs. Just like POSIX ftruncate, returns 0 on success, -1 on
+ failure. */
+
+int
+unit_truncate (gfc_unit * u, gfc_offset pos, st_parameter_common * common)
+{
+ int ret;
+
+ /* Make sure format buffer is flushed. */
+ if (u->flags.form == FORM_FORMATTED)
+ {
+ if (u->mode == READING)
+ pos += fbuf_reset (u);
+ else
+ fbuf_flush (u, u->mode);
+ }
+
+ /* Don't try to truncate a special file, just pretend that it
+ succeeds. */
+ if (is_special (u->s) || !is_seekable (u->s))
+ {
+ sflush (u->s);
+ return 0;
+ }
+
+ /* struncate() should flush the stream buffer if necessary, so don't
+ bother calling sflush() here. */
+ ret = struncate (u->s, pos);
+
+ if (ret != 0)
+ {
+ generate_error (common, LIBERROR_OS, NULL);
+ u->endfile = NO_ENDFILE;
+ u->flags.position = POSITION_ASIS;
+ }
+ else
+ {
+ u->endfile = AT_ENDFILE;
+ u->flags.position = POSITION_APPEND;
+ }
+
+ return ret;
+}
+
+
/* filename_from_unit()-- If the unit_number exists, return a pointer to the
name of the associated file, otherwise return the empty string. The caller
must free memory allocated for the filename string. */
{
if (u->saved_pos > 0)
- fbuf_seek (u, u->saved_pos);
-
- fbuf_flush (u, 1);
+ fbuf_seek (u, u->saved_pos, SEEK_CUR);
if (!(u->unit_number == options.stdout_unit
|| u->unit_number == options.stderr_unit))
{
- 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 (u->s, &crlf[2-len], &len) != 0)
+ char *p = fbuf_alloc (u, len);
+ if (!p)
os_error ("Completing record after ADVANCE_NO failed");
+#ifdef HAVE_CRLF
+ *(p++) = '\r';
+#endif
+ *p = '\n';
}
+
+ fbuf_flush (u, u->mode);
}
#endif
-#ifndef SSIZE_MAX
-#define SSIZE_MAX SHRT_MAX
-#endif
-
#ifndef PATH_MAX
#define PATH_MAX 1024
#endif
#endif
-/* Unix stream I/O module */
+/* Unix and internal stream I/O module */
-#define BUFFER_SIZE 8192
+static const int BUFFER_SIZE = 8192;
typedef struct
{
stream st;
- int fd;
gfc_offset buffer_offset; /* File offset of the start of the buffer */
gfc_offset physical_offset; /* Current physical file offset */
gfc_offset logical_offset; /* Current logical file offset */
- gfc_offset dirty_offset; /* Start of modified bytes in buffer */
gfc_offset file_length; /* Length of the file, -1 if not seekable. */
- int len; /* Physical length of the current buffer */
+ char *buffer; /* Pointer to the buffer. */
+ int fd; /* The POSIX file descriptor. */
+
int active; /* Length of valid bytes in the buffer */
int prot;
- int ndirty; /* Dirty bytes starting at dirty_offset */
+ int ndirty; /* Dirty bytes starting at buffer_offset */
int special_file; /* =1 if the fd refers to a special file */
-
- io_mode method; /* Method of stream I/O being used */
-
- char *buffer;
- char small_buffer[BUFFER_SIZE];
}
unix_stream;
-/* Stream structure for internal files. Fields must be kept in sync
- with unix_stream above, except for the buffer. For internal files
- we point the buffer pointer directly at the destination memory. */
-
-typedef struct
-{
- stream st;
-
- int fd;
- gfc_offset buffer_offset; /* File offset of the start of the buffer */
- gfc_offset physical_offset; /* Current physical file offset */
- gfc_offset logical_offset; /* Current logical file offset */
- gfc_offset dirty_offset; /* Start of modified bytes in buffer */
- gfc_offset file_length; /* Length of the file, -1 if not seekable. */
-
- int len; /* Physical length of the current buffer */
- int active; /* Length of valid bytes in the buffer */
-
- int prot;
- int ndirty; /* Dirty bytes starting at dirty_offset */
-
- int special_file; /* =1 if the fd refers to a special file */
-
- io_mode method; /* Method of stream I/O being used */
-
- char *buffer;
-}
-int_stream;
-
-/* This implementation of stream I/O is based on the paper:
- *
- * "Exploiting the advantages of mapped files for stream I/O",
- * O. Krieger, M. Stumm and R. Umrau, "Proceedings of the 1992 Winter
- * USENIX conference", p. 27-42.
- *
- * It differs in a number of ways from the version described in the
- * paper. First of all, threads are not an issue during I/O and we
- * also don't have to worry about having multiple regions, since
- * fortran's I/O model only allows you to be one place at a time.
- *
- * On the other hand, we have to be able to writing at the end of a
- * stream, read from the start of a stream or read and write blocks of
- * bytes from an arbitrary position. After opening a file, a pointer
- * to a stream structure is returned, which is used to handle file
- * accesses until the file is closed.
- *
- * salloc_at_r(stream, len, where)-- Given a stream pointer, return a
- * pointer to a block of memory that mirror the file at position
- * 'where' that is 'len' bytes long. The len integer is updated to
- * reflect how many bytes were actually read. The only reason for a
- * short read is end of file. The file pointer is updated. The
- * pointer is valid until the next call to salloc_*.
- *
- * salloc_at_w(stream, len, where)-- Given the stream pointer, returns
- * a pointer to a block of memory that is updated to reflect the state
- * of the file. The length of the buffer is always equal to that
- * requested. The buffer must be completely set by the caller. When
- * data has been written, the sfree() function must be called to
- * indicate that the caller is done writing data to the buffer. This
- * may or may not cause a physical write.
- *
- * Short forms of these are salloc_r() and salloc_w() which drop the
- * 'where' parameter and use the current file pointer. */
-
-
/*move_pos_offset()-- Move the record pointer right or left
*relative to current position */
{
str->logical_offset += pos_off;
- if (str->dirty_offset + str->ndirty > str->logical_offset)
+ if (str->ndirty > str->logical_offset)
{
if (str->ndirty + pos_off > 0)
str->ndirty += pos_off;
else
- {
- str->dirty_offset += pos_off + pos_off;
- str->ndirty = 0;
- }
+ str->ndirty = 0;
}
return pos_off;
}
-/* Reset a stream after reading/writing. Assumes that the buffers have
- been flushed. */
+/* get_oserror()-- Get the most recent operating system error. For
+ * unix, this is errno. */
-inline static void
-reset_stream (unix_stream * s, size_t bytes_rw)
+const char *
+get_oserror (void)
{
- s->physical_offset += bytes_rw;
- s->logical_offset = s->physical_offset;
- if (s->file_length != -1 && s->physical_offset > s->file_length)
- s->file_length = s->physical_offset;
+ return strerror (errno);
}
-/* Read bytes into a buffer, allowing for short reads. If the nbytes
- * argument is less on return than on entry, it is because we've hit
- * the end of file. */
+/********************************************************************
+Raw I/O functions (read, write, seek, tell, truncate, close).
+
+These functions wrap the basic POSIX I/O syscalls. Any deviation in
+semantics is a bug, except the following: write restarts in case
+of being interrupted by a signal, and as the first argument the
+functions take the unix_stream struct rather than an integer file
+descriptor. Also, for POSIX read() and write() a nbyte argument larger
+than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
+than size_t as for POSIX read/write.
+*********************************************************************/
static int
-do_read (unix_stream * s, void * buf, size_t * nbytes)
+raw_flush (unix_stream * s __attribute__ ((unused)))
{
- ssize_t trans;
- size_t bytes_left;
- char *buf_st;
- int status;
-
- status = 0;
- bytes_left = *nbytes;
- buf_st = (char *) buf;
-
- /* We must read in a loop since some systems don't restart system
- calls in case of a signal. */
- while (bytes_left > 0)
- {
- /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
- so we must read in chunks smaller than SSIZE_MAX. */
- trans = (bytes_left < SSIZE_MAX) ? bytes_left : SSIZE_MAX;
- trans = read (s->fd, buf_st, trans);
- if (trans < 0)
- {
- if (errno == EINTR)
- continue;
- else
- {
- status = errno;
- break;
- }
- }
- else if (trans == 0) /* We hit EOF. */
- break;
- buf_st += trans;
- bytes_left -= trans;
- }
-
- *nbytes -= bytes_left;
- return status;
+ return 0;
}
+static ssize_t
+raw_read (unix_stream * s, void * buf, ssize_t nbyte)
+{
+ /* For read we can't do I/O in a loop like raw_write does, because
+ that will break applications that wait for interactive I/O. */
+ return read (s->fd, buf, nbyte);
+}
-/* Write a buffer to a stream, allowing for short writes. */
-
-static int
-do_write (unix_stream * s, const void * buf, size_t * nbytes)
+static ssize_t
+raw_write (unix_stream * s, const void * buf, ssize_t nbyte)
{
- ssize_t trans;
- size_t bytes_left;
+ ssize_t trans, bytes_left;
char *buf_st;
- int status;
- status = 0;
- bytes_left = *nbytes;
+ bytes_left = nbyte;
buf_st = (char *) buf;
/* We must write in a loop since some systems don't restart system
calls in case of a signal. */
while (bytes_left > 0)
{
- /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
- so we must write in chunks smaller than SSIZE_MAX. */
- trans = (bytes_left < SSIZE_MAX) ? bytes_left : SSIZE_MAX;
- trans = write (s->fd, buf_st, trans);
+ trans = write (s->fd, buf_st, bytes_left);
if (trans < 0)
{
if (errno == EINTR)
continue;
else
- {
- status = errno;
- break;
- }
+ return trans;
}
buf_st += trans;
bytes_left -= trans;
}
- *nbytes -= bytes_left;
- return status;
+ return nbyte - bytes_left;
}
+static off_t
+raw_seek (unix_stream * s, off_t offset, int whence)
+{
+ return lseek (s->fd, offset, whence);
+}
-/* get_oserror()-- Get the most recent operating system error. For
- * unix, this is errno. */
+static off_t
+raw_tell (unix_stream * s)
+{
+ return lseek (s->fd, 0, SEEK_CUR);
+}
-const char *
-get_oserror (void)
+static int
+raw_truncate (unix_stream * s, off_t length)
{
- return strerror (errno);
+#ifdef HAVE_FTRUNCATE
+ return ftruncate (s->fd, length);
+#elif defined HAVE_CHSIZE
+ return chsize (s->fd, length);
+#else
+ runtime_error ("required ftruncate or chsize support not present");
+ return -1;
+#endif
}
+static int
+raw_close (unix_stream * s)
+{
+ int retval;
+
+ retval = close (s->fd);
+ free_mem (s);
+ return retval;
+}
-/*********************************************************************
- File descriptor stream functions
-*********************************************************************/
+static int
+raw_init (unix_stream * s)
+{
+ s->st.read = (void *) raw_read;
+ s->st.write = (void *) raw_write;
+ s->st.seek = (void *) raw_seek;
+ s->st.tell = (void *) raw_tell;
+ s->st.truncate = (void *) raw_truncate;
+ s->st.close = (void *) raw_close;
+ s->st.flush = (void *) raw_flush;
+ s->buffer = NULL;
+ return 0;
+}
-/* fd_flush()-- Write bytes that need to be written */
-static try
-fd_flush (unix_stream * s)
+/*********************************************************************
+Buffered I/O functions. These functions have the same semantics as the
+raw I/O functions above, except that they are buffered in order to
+improve performance. The buffer must be flushed when switching from
+reading to writing and vice versa.
+*********************************************************************/
+
+static int
+buf_flush (unix_stream * s)
{
- size_t writelen;
+ int writelen;
+
+ /* Flushing in read mode means discarding read bytes. */
+ s->active = 0;
if (s->ndirty == 0)
- return SUCCESS;
+ return 0;
- if (s->file_length != -1 && s->physical_offset != s->dirty_offset &&
- lseek (s->fd, s->dirty_offset, SEEK_SET) < 0)
- return FAILURE;
+ if (s->file_length != -1 && s->physical_offset != s->buffer_offset
+ && lseek (s->fd, s->buffer_offset, SEEK_SET) < 0)
+ return -1;
- writelen = s->ndirty;
- if (do_write (s, s->buffer + (s->dirty_offset - s->buffer_offset),
- &writelen) != 0)
- return FAILURE;
+ writelen = raw_write (s, s->buffer, s->ndirty);
- s->physical_offset = s->dirty_offset + writelen;
+ s->physical_offset = s->buffer_offset + writelen;
- /* don't increment file_length if the file is non-seekable */
+ /* Don't increment file_length if the file is non-seekable. */
if (s->file_length != -1 && s->physical_offset > s->file_length)
- s->file_length = s->physical_offset;
+ s->file_length = s->physical_offset;
s->ndirty -= writelen;
if (s->ndirty != 0)
- return FAILURE;
+ return -1;
- return SUCCESS;
+ return 0;
}
-
-/* fd_alloc()-- Arrange a buffer such that the salloc() request can be
- * satisfied. This subroutine gets the buffer ready for whatever is
- * to come next. */
-
-static void
-fd_alloc (unix_stream * s, gfc_offset where,
- int *len __attribute__ ((unused)))
+static ssize_t
+buf_read (unix_stream * s, void * buf, ssize_t nbyte)
{
- char *new_buffer;
- int n, read_len;
+ if (s->active == 0)
+ s->buffer_offset = s->logical_offset;
- if (*len <= BUFFER_SIZE)
- {
- new_buffer = s->small_buffer;
- read_len = BUFFER_SIZE;
- }
+ /* Is the data we want in the buffer? */
+ if (s->logical_offset + nbyte <= s->buffer_offset + s->active
+ && s->buffer_offset <= s->logical_offset)
+ memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset), nbyte);
else
{
- new_buffer = get_mem (*len);
- read_len = *len;
- }
-
- /* Salvage bytes currently within the buffer. This is important for
- * devices that cannot seek. */
-
- if (s->buffer != NULL && s->buffer_offset <= where &&
- where <= s->buffer_offset + s->active)
- {
-
- n = s->active - (where - s->buffer_offset);
- memmove (new_buffer, s->buffer + (where - s->buffer_offset), n);
-
- s->active = n;
- }
- else
- { /* new buffer starts off empty */
- s->active = 0;
+ /* First copy the active bytes if applicable, then read the rest
+ either directly or filling the buffer. */
+ char *p;
+ int nread = 0;
+ ssize_t to_read, did_read;
+ gfc_offset new_logical;
+
+ p = (char *) buf;
+ if (s->logical_offset >= s->buffer_offset
+ && s->buffer_offset + s->active >= s->logical_offset)
+ {
+ nread = s->active - (s->logical_offset - s->buffer_offset);
+ memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset),
+ nread);
+ p += nread;
+ }
+ /* At this point we consider all bytes in the buffer discarded. */
+ to_read = nbyte - nread;
+ new_logical = s->logical_offset + nread;
+ if (s->file_length != -1 && s->physical_offset != new_logical
+ && lseek (s->fd, new_logical, SEEK_SET) < 0)
+ return -1;
+ s->buffer_offset = s->physical_offset = new_logical;
+ if (to_read <= BUFFER_SIZE/2)
+ {
+ did_read = raw_read (s, s->buffer, BUFFER_SIZE);
+ s->physical_offset += did_read;
+ s->active = did_read;
+ did_read = (did_read > to_read) ? to_read : did_read;
+ memcpy (p, s->buffer, did_read);
+ }
+ else
+ {
+ did_read = raw_read (s, p, to_read);
+ s->physical_offset += did_read;
+ s->active = 0;
+ }
+ nbyte = did_read + nread;
}
-
- s->buffer_offset = where;
-
- /* free the old buffer if necessary */
-
- if (s->buffer != NULL && s->buffer != s->small_buffer)
- free_mem (s->buffer);
-
- s->buffer = new_buffer;
- s->len = read_len;
+ s->logical_offset += nbyte;
+ return nbyte;
}
-
-/* fd_alloc_r_at()-- Allocate a stream buffer for reading. Either
- * we've already buffered the data or we need to load it. Returns
- * NULL on I/O error. */
-
-static char *
-fd_alloc_r_at (unix_stream * s, int *len)
+static ssize_t
+buf_write (unix_stream * s, const void * buf, ssize_t nbyte)
{
- gfc_offset m;
- gfc_offset where = s->logical_offset;
-
- if (s->buffer != NULL && s->buffer_offset <= where &&
- where + *len <= s->buffer_offset + s->active)
- {
-
- /* Return a position within the current buffer */
-
- s->logical_offset = where + *len;
- return s->buffer + where - s->buffer_offset;
- }
-
- fd_alloc (s, where, len);
-
- m = where + s->active;
-
- if (s->physical_offset != m && lseek (s->fd, m, SEEK_SET) < 0)
- return NULL;
-
- /* do_read() hangs on read from terminals for *BSD-systems. Only
- use read() in that case. */
-
- if (s->special_file)
+ if (s->ndirty == 0)
+ s->buffer_offset = s->logical_offset;
+
+ /* Does the data fit into the buffer? As a special case, if the
+ buffer is empty and the request is bigger than BUFFER_SIZE/2,
+ write directly. This avoids the case where the buffer would have
+ to be flushed at every write. */
+ if (!(s->ndirty == 0 && nbyte > BUFFER_SIZE/2)
+ && s->logical_offset + nbyte <= s->buffer_offset + BUFFER_SIZE
+ && s->buffer_offset <= s->logical_offset
+ && s->buffer_offset + s->ndirty >= s->logical_offset)
{
- ssize_t n;
-
- n = read (s->fd, s->buffer + s->active, s->len - s->active);
- if (n < 0)
- return NULL;
-
- s->physical_offset = m + n;
- s->active += n;
+ memcpy (s->buffer + (s->logical_offset - s->buffer_offset), buf, nbyte);
+ int nd = (s->logical_offset - s->buffer_offset) + nbyte;
+ if (nd > s->ndirty)
+ s->ndirty = nd;
}
else
{
- size_t n;
-
- n = s->len - s->active;
- if (do_read (s, s->buffer + s->active, &n) != 0)
- return NULL;
-
- s->physical_offset = m + n;
- s->active += n;
- }
-
- if (s->active < *len)
- *len = s->active; /* Bytes actually available */
-
- s->logical_offset = where + *len;
-
- return s->buffer;
-}
-
-
-/* fd_alloc_w_at()-- Allocate a stream buffer for writing. Either
- * we've already buffered the data or we need to load it. */
-
-static char *
-fd_alloc_w_at (unix_stream * s, int *len)
-{
- gfc_offset n;
- gfc_offset where = s->logical_offset;
-
- if (s->buffer == NULL || s->buffer_offset > where ||
- where + *len > s->buffer_offset + s->len)
- {
-
- if (fd_flush (s) == FAILURE)
- return NULL;
- fd_alloc (s, where, len);
- }
-
- /* Return a position within the current buffer */
- if (s->ndirty == 0
- || where > s->dirty_offset + s->ndirty
- || s->dirty_offset > where + *len)
- { /* Discontiguous blocks, start with a clean buffer. */
- /* Flush the buffer. */
- if (s->ndirty != 0)
- fd_flush (s);
- s->dirty_offset = where;
- s->ndirty = *len;
- }
- else
- {
- gfc_offset start; /* Merge with the existing data. */
- if (where < s->dirty_offset)
- start = where;
- else
- start = s->dirty_offset;
- if (where + *len > s->dirty_offset + s->ndirty)
- s->ndirty = where + *len - start;
- else
- s->ndirty = s->dirty_offset + s->ndirty - start;
- s->dirty_offset = start;
+ /* Flush, and either fill the buffer with the new data, or if
+ the request is bigger than the buffer size, write directly
+ bypassing the buffer. */
+ buf_flush (s);
+ if (nbyte <= BUFFER_SIZE/2)
+ {
+ memcpy (s->buffer, buf, nbyte);
+ s->buffer_offset = s->logical_offset;
+ s->ndirty += nbyte;
+ }
+ else
+ {
+ if (s->file_length != -1 && s->physical_offset != s->logical_offset
+ && lseek (s->fd, s->logical_offset, SEEK_SET) < 0)
+ return -1;
+ nbyte = raw_write (s, buf, nbyte);
+ s->physical_offset += nbyte;
+ }
}
-
- s->logical_offset = where + *len;
-
+ s->logical_offset += nbyte;
/* Don't increment file_length if the file is non-seekable. */
-
if (s->file_length != -1 && s->logical_offset > s->file_length)
- s->file_length = s->logical_offset;
-
- n = s->logical_offset - s->buffer_offset;
- if (n > s->active)
- s->active = n;
-
- return s->buffer + where - s->buffer_offset;
+ s->file_length = s->logical_offset;
+ return nbyte;
}
-
-static try
-fd_sfree (unix_stream * s)
-{
- if (s->ndirty != 0 &&
- (s->buffer != s->small_buffer || options.all_unbuffered ||
- s->method == SYNC_UNBUFFERED))
- return fd_flush (s);
-
- return SUCCESS;
-}
-
-
-static try
-fd_seek (unix_stream * s, gfc_offset offset)
-{
-
- if (s->file_length == -1)
- return SUCCESS;
-
- if (s->physical_offset == offset) /* Are we lucky and avoid syscall? */
- {
- s->logical_offset = offset;
- return SUCCESS;
- }
-
- if (lseek (s->fd, offset, SEEK_SET) >= 0)
- {
- s->physical_offset = s->logical_offset = offset;
- s->active = 0;
- return SUCCESS;
- }
-
- return FAILURE;
-}
-
-
-/* truncate_file()-- Given a unit, truncate the file at the current
- * position. Sets the physical location to the new end of the file.
- * Returns nonzero on error. */
-
-static try
-fd_truncate (unix_stream * s)
+static off_t
+buf_seek (unix_stream * s, off_t offset, int whence)
{
- /* Non-seekable files, like terminals and fifo's fail the lseek so just
- return success, there is nothing to truncate. If its not a pipe there
- is a real problem. */
- if (lseek (s->fd, s->logical_offset, SEEK_SET) == -1)
+ switch (whence)
{
- if (errno == ESPIPE)
- return SUCCESS;
- else
- return FAILURE;
+ case SEEK_SET:
+ break;
+ case SEEK_CUR:
+ offset += s->logical_offset;
+ break;
+ case SEEK_END:
+ offset += s->file_length;
+ break;
+ default:
+ return -1;
}
-
- /* Using ftruncate on a seekable special file (like /dev/null)
- is undefined, so we treat it as if the ftruncate succeeded. */
- if (!s->special_file
- && (
-#ifdef HAVE_FTRUNCATE
- ftruncate (s->fd, s->logical_offset) != 0
-#elif defined HAVE_CHSIZE
- chsize (s->fd, s->logical_offset) != 0
-#else
- /* If we have neither, always fail and exit, noisily. */
- runtime_error ("required ftruncate or chsize support not present"), 1
-#endif
- ))
+ if (offset < 0)
{
- /* The truncation failed and we need to handle this gracefully.
- The file length remains the same, but the file-descriptor
- offset needs adjustment per the successful lseek above.
- (Similarly, the contents of the buffer isn't valid anymore.)
- A ftruncate call does not affect the physical (file-descriptor)
- offset, according to the ftruncate manual, so neither should a
- failed call. */
- s->physical_offset = s->logical_offset;
- s->active = 0;
- return FAILURE;
+ errno = EINVAL;
+ return -1;
}
-
- s->physical_offset = s->file_length = s->logical_offset;
- s->active = 0;
- return SUCCESS;
+ s->logical_offset = offset;
+ return offset;
}
-
-/* Similar to memset(), but operating on a stream instead of a string.
- Takes care of not using too much memory. */
-
-static try
-fd_sset (unix_stream * s, int c, size_t n)
+static off_t
+buf_tell (unix_stream * s)
{
- size_t bytes_left;
- int trans;
- void *p;
-
- bytes_left = n;
-
- while (bytes_left > 0)
- {
- /* memset() in chunks of BUFFER_SIZE. */
- trans = (bytes_left < BUFFER_SIZE) ? bytes_left : BUFFER_SIZE;
-
- p = fd_alloc_w_at (s, &trans);
- if (p)
- memset (p, c, trans);
- else
- return FAILURE;
-
- bytes_left -= trans;
- }
-
- return SUCCESS;
+ return s->logical_offset;
}
-
-/* Stream read function. Avoids using a buffer for big reads. The
- interface is like POSIX read(), but the nbytes argument is a
- pointer; on return it contains the number of bytes written. The
- function return value is the status indicator (0 for success). */
-
static int
-fd_read (unix_stream * s, void * buf, size_t * nbytes)
+buf_truncate (unix_stream * s, off_t length)
{
- void *p;
- int tmp, status;
-
- if (*nbytes < BUFFER_SIZE && s->method == SYNC_BUFFERED)
- {
- tmp = *nbytes;
- p = fd_alloc_r_at (s, &tmp);
- if (p)
- {
- *nbytes = tmp;
- memcpy (buf, p, *nbytes);
- return 0;
- }
- else
- {
- *nbytes = 0;
- return errno;
- }
- }
-
- /* If the request is bigger than BUFFER_SIZE we flush the buffers
- and read directly. */
- if (fd_flush (s) == FAILURE)
- {
- *nbytes = 0;
- return errno;
- }
-
- if (is_seekable ((stream *) s) && fd_seek (s, s->logical_offset) == FAILURE)
- {
- *nbytes = 0;
- return errno;
- }
+ int r;
- status = do_read (s, buf, nbytes);
- reset_stream (s, *nbytes);
- return status;
+ if (buf_flush (s) != 0)
+ return -1;
+ r = raw_truncate (s, length);
+ if (r == 0)
+ s->file_length = length;
+ return r;
}
-
-/* Stream write function. Avoids using a buffer for big writes. The
- interface is like POSIX write(), but the nbytes argument is a
- pointer; on return it contains the number of bytes written. The
- function return value is the status indicator (0 for success). */
-
static int
-fd_write (unix_stream * s, const void * buf, size_t * nbytes)
-{
- void *p;
- int tmp, status;
-
- if (*nbytes < BUFFER_SIZE && s->method == SYNC_BUFFERED)
- {
- tmp = *nbytes;
- p = fd_alloc_w_at (s, &tmp);
- if (p)
- {
- *nbytes = tmp;
- memcpy (p, buf, *nbytes);
- return 0;
- }
- else
- {
- *nbytes = 0;
- return errno;
- }
- }
-
- /* If the request is bigger than BUFFER_SIZE we flush the buffers
- and write directly. */
- if (fd_flush (s) == FAILURE)
- {
- *nbytes = 0;
- return errno;
- }
-
- if (is_seekable ((stream *) s) && fd_seek (s, s->logical_offset) == FAILURE)
- {
- *nbytes = 0;
- return errno;
- }
-
- status = do_write (s, buf, nbytes);
- reset_stream (s, *nbytes);
- return status;
-}
-
-
-static try
-fd_close (unix_stream * s)
+buf_close (unix_stream * s)
{
- if (fd_flush (s) == FAILURE)
- return FAILURE;
-
- if (s->buffer != NULL && s->buffer != s->small_buffer)
- free_mem (s->buffer);
-
- if (s->fd != STDOUT_FILENO && s->fd != STDERR_FILENO && s->fd != STDIN_FILENO)
- {
- if (close (s->fd) < 0)
- return FAILURE;
- }
-
- free_mem (s);
-
- return SUCCESS;
+ if (buf_flush (s) != 0)
+ return -1;
+ free_mem (s->buffer);
+ return raw_close (s);
}
-
-static void
-fd_open (unix_stream * s)
+static int
+buf_init (unix_stream * s)
{
- if (isatty (s->fd))
- s->method = SYNC_UNBUFFERED;
- else
- s->method = SYNC_BUFFERED;
-
- s->st.alloc_w_at = (void *) fd_alloc_w_at;
- s->st.sfree = (void *) fd_sfree;
- s->st.close = (void *) fd_close;
- s->st.seek = (void *) fd_seek;
- s->st.trunc = (void *) fd_truncate;
- s->st.read = (void *) fd_read;
- s->st.write = (void *) fd_write;
- s->st.set = (void *) fd_sset;
+ s->st.read = (void *) buf_read;
+ s->st.write = (void *) buf_write;
+ s->st.seek = (void *) buf_seek;
+ s->st.tell = (void *) buf_tell;
+ s->st.truncate = (void *) buf_truncate;
+ s->st.close = (void *) buf_close;
+ s->st.flush = (void *) buf_flush;
- s->buffer = NULL;
+ s->buffer = get_mem (BUFFER_SIZE);
+ return 0;
}
-
-
/*********************************************************************
memory stream functions - These are used for internal files
*********************************************************************/
-static char *
-mem_alloc_r_at (int_stream * s, int *len)
+char *
+mem_alloc_r (stream * strm, int * len)
{
+ unix_stream * s = (unix_stream *) strm;
gfc_offset n;
gfc_offset where = s->logical_offset;
if (where < s->buffer_offset || where > s->buffer_offset + s->active)
return NULL;
- s->logical_offset = where + *len;
-
n = s->buffer_offset + s->active - where;
if (*len > n)
*len = n;
+ s->logical_offset = where + *len;
+
return s->buffer + (where - s->buffer_offset);
}
-static char *
-mem_alloc_w_at (int_stream * s, int *len)
+char *
+mem_alloc_w (stream * strm, int * len)
{
+ unix_stream * s = (unix_stream *) strm;
gfc_offset m;
gfc_offset where = s->logical_offset;
- assert (*len >= 0); /* Negative values not allowed. */
-
m = where + *len;
if (where < s->buffer_offset)
/* Stream read function for internal units. */
-static int
-mem_read (int_stream * s, void * buf, size_t * nbytes)
+static ssize_t
+mem_read (stream * s, void * buf, ssize_t nbytes)
{
void *p;
- int tmp;
+ int nb = nbytes;
- tmp = *nbytes;
- p = mem_alloc_r_at (s, &tmp);
+ p = mem_alloc_r (s, &nb);
if (p)
{
- *nbytes = tmp;
- memcpy (buf, p, *nbytes);
- return 0;
+ memcpy (buf, p, nb);
+ return (ssize_t) nb;
}
else
- {
- *nbytes = 0;
- return 0;
- }
+ return 0;
}
at the moment, as all internal IO is formatted and the formatted IO
routines use mem_alloc_w_at. */
-static int
-mem_write (int_stream * s, const void * buf, size_t * nbytes)
+static ssize_t
+mem_write (stream * s, const void * buf, ssize_t nbytes)
{
void *p;
- int tmp;
+ int nb = nbytes;
- tmp = *nbytes;
- p = mem_alloc_w_at (s, &tmp);
+ p = mem_alloc_w (s, &nb);
if (p)
{
- *nbytes = tmp;
- memcpy (p, buf, *nbytes);
- return 0;
+ memcpy (p, buf, nb);
+ return (ssize_t) nb;
}
else
- {
- *nbytes = 0;
- return 0;
- }
+ return 0;
}
-static int
-mem_seek (int_stream * s, gfc_offset offset)
+static off_t
+mem_seek (stream * strm, off_t offset, int whence)
{
+ unix_stream * s = (unix_stream *) strm;
+ switch (whence)
+ {
+ case SEEK_SET:
+ break;
+ case SEEK_CUR:
+ offset += s->logical_offset;
+ break;
+ case SEEK_END:
+ offset += s->file_length;
+ break;
+ default:
+ return -1;
+ }
+
+ /* Note that for internal array I/O it's actually possible to have a
+ negative offset, so don't check for that. */
if (offset > s->file_length)
{
- errno = ESPIPE;
- return FAILURE;
+ errno = EINVAL;
+ return -1;
}
s->logical_offset = offset;
- return SUCCESS;
+
+ /* Returning < 0 is the error indicator for sseek(), so return 0 if
+ offset is negative. Thus if the return value is 0, the caller
+ has to use stell() to get the real value of logical_offset. */
+ if (offset >= 0)
+ return offset;
+ return 0;
}
-static try
-mem_set (int_stream * s, int c, size_t n)
+static off_t
+mem_tell (stream * s)
{
- void *p;
- int len;
-
- len = n;
-
- p = mem_alloc_w_at (s, &len);
- if (p)
- {
- memset (p, c, len);
- return SUCCESS;
- }
- else
- return FAILURE;
+ return ((unix_stream *)s)->logical_offset;
}
static int
-mem_truncate (int_stream * s __attribute__ ((unused)))
+mem_truncate (unix_stream * s __attribute__ ((unused)),
+ off_t length __attribute__ ((unused)))
{
- return SUCCESS;
+ return 0;
}
-static try
-mem_close (int_stream * s)
+static int
+mem_flush (unix_stream * s __attribute__ ((unused)))
{
- if (s != NULL)
- free_mem (s);
-
- return SUCCESS;
+ return 0;
}
-static try
-mem_sfree (int_stream * s __attribute__ ((unused)))
+static int
+mem_close (unix_stream * s)
{
- return SUCCESS;
-}
+ if (s != NULL)
+ free_mem (s);
+ return 0;
+}
/*********************************************************************
void
empty_internal_buffer(stream *strm)
{
- int_stream * s = (int_stream *) strm;
+ unix_stream * s = (unix_stream *) strm;
memset(s->buffer, ' ', s->file_length);
}
stream *
open_internal (char *base, int length, gfc_offset offset)
{
- int_stream *s;
+ unix_stream *s;
- s = get_mem (sizeof (int_stream));
- memset (s, '\0', sizeof (int_stream));
+ s = get_mem (sizeof (unix_stream));
+ memset (s, '\0', sizeof (unix_stream));
s->buffer = base;
s->buffer_offset = offset;
s->logical_offset = 0;
s->active = s->file_length = length;
- s->st.alloc_w_at = (void *) mem_alloc_w_at;
- s->st.sfree = (void *) mem_sfree;
s->st.close = (void *) mem_close;
s->st.seek = (void *) mem_seek;
- s->st.trunc = (void *) mem_truncate;
+ s->st.tell = (void *) mem_tell;
+ s->st.truncate = (void *) mem_truncate;
s->st.read = (void *) mem_read;
s->st.write = (void *) mem_write;
- s->st.set = (void *) mem_set;
+ s->st.flush = (void *) mem_flush;
return (stream *) s;
}
s->special_file = !S_ISREG (statbuf.st_mode);
- fd_open (s);
+ if (isatty (s->fd) || options.all_unbuffered
+ ||(options.unbuffered_preconnected &&
+ (s->fd == STDIN_FILENO
+ || s->fd == STDOUT_FILENO
+ || s->fd == STDERR_FILENO)))
+ raw_init (s);
+ else
+ buf_init (s);
return (stream *) s;
}
#endif
s = fd_to_stream (STDOUT_FILENO, PROT_WRITE);
- if (options.unbuffered_preconnected)
- ((unix_stream *) s)->method = SYNC_UNBUFFERED;
return s;
}
#endif
s = fd_to_stream (STDERR_FILENO, PROT_WRITE);
- if (options.unbuffered_preconnected)
- ((unix_stream *) s)->method = SYNC_UNBUFFERED;
return s;
}
if (__gthread_mutex_trylock (&u->lock))
return u;
if (u->s)
- flush (u->s);
+ sflush (u->s);
__gthread_mutex_unlock (&u->lock);
}
u = u->right;
if (u->closed == 0)
{
- flush (u->s);
+ sflush (u->s);
__gthread_mutex_lock (&unit_lock);
__gthread_mutex_unlock (&u->lock);
(void) predec_waiting_locked (u);
}
-/* stream_at_bof()-- Returns nonzero if the stream is at the beginning
- * of the file. */
-
-int
-stream_at_bof (stream * s)
-{
- unix_stream *us;
-
- if (!is_seekable (s))
- return 0;
-
- us = (unix_stream *) s;
-
- return us->logical_offset == 0;
-}
-
-
-/* stream_at_eof()-- Returns nonzero if the stream is at the end
- * of the file. */
-
-int
-stream_at_eof (stream * s)
-{
- unix_stream *us;
-
- if (!is_seekable (s))
- return 0;
-
- us = (unix_stream *) s;
-
- return us->logical_offset == us->dirty_offset;
-}
-
-
/* delete_file()-- Given a unit structure, delete the file associated
* with the unit. Returns nonzero if something went wrong. */
gfc_offset
file_length (stream * s)
{
- return ((unix_stream *) s)->file_length;
-}
-
-
-/* file_position()-- Return the current position of the file */
-
-gfc_offset
-file_position (stream *s)
-{
- return ((unix_stream *) s)->logical_offset;
+ off_t curr, end;
+ if (!is_seekable (s))
+ return -1;
+ curr = stell (s);
+ if (curr == -1)
+ return curr;
+ end = sseek (s, 0, SEEK_END);
+ sseek (s, curr, SEEK_SET);
+ return end;
}
}
-try
-flush (stream *s)
-{
- return fd_flush( (unix_stream *) s);
-}
-
int
stream_isatty (stream *s)
{
#endif
}
-gfc_offset
-stream_offset (stream *s)
-{
- return (((unix_stream *) s)->logical_offset);
-}
-
/* How files are stored: This is an operating-system specific issue,
and therefore belongs here. There are three cases to consider.
gfc_char4_t c;
static const uchar masks[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
static const uchar limits[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
- size_t nbytes;
+ int nbytes;
uchar buf[6], d, *q;
/* Take care of preceding blanks. */
p = write_block (dtp, len);
if (p == NULL)
return;
-
- if (nspaces > 0)
+ if (nspaces > 0 && len - nspaces >= 0)
memset (&p[len - nspaces], ' ', nspaces);
}
/* 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;
OSDN Git Service
