Skip to content

R
riscv-gcc-1
Commit 7812c78c by Jerry DeLisle
Options

[multiple changes] 

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.

From-SVN: r145571
parent 941c3614
Showing with 2143 additions and 1752 deletions
libgfortran/ChangeLog
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
......
libgfortran/io/fbuf.c
......@@ -33,8 +33,11 @@ Boston, MA 02110-1301, USA. */
#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. */
......@@ -42,14 +45,7 @@ fbuf_init (gfc_unit * u, size_t len)
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;
}
......@@ -61,58 +57,79 @@ fbuf_destroy (gfc_unit * u)
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;
......@@ -123,42 +140,134 @@ fbuf_alloc (gfc_unit * u, size_t len)
}
/* 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;
}
libgfortran/io/file_pos.c
......@@ -46,17 +46,17 @@ formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
{
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
......@@ -81,7 +81,7 @@ formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
/* 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;
......@@ -100,10 +100,10 @@ formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
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)];
......@@ -114,9 +114,10 @@ unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
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. */
......@@ -164,10 +165,7 @@ unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
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);
......@@ -206,15 +204,21 @@ st_backspace (st_parameter_filepos *fpp)
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. */
......@@ -222,11 +226,11 @@ st_backspace (st_parameter_filepos *fpp)
{
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 */
......@@ -243,8 +247,7 @@ st_backspace (st_parameter_filepos *fpp)
u->previous_nonadvancing_write = 0;
flush (u->s);
struncate (u->s);
unit_truncate (u, stell (u->s), &fpp->common);
u->mode = READING;
}
......@@ -253,7 +256,7 @@ st_backspace (st_parameter_filepos *fpp)
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;
......@@ -305,10 +308,10 @@ st_endfile (st_parameter_filepos *fpp)
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);
}
......@@ -347,14 +350,25 @@ st_rewind (st_parameter_filepos *fpp)
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. */
......@@ -366,7 +380,7 @@ st_rewind (st_parameter_filepos *fpp)
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. */
}
......@@ -397,7 +411,11 @@ st_flush (st_parameter_filepos *fpp)
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
......
libgfortran/io/format.c
......@@ -36,6 +36,7 @@ Boston, MA 02110-1301, USA. */
#include "io.h"
#include <ctype.h>
#include <string.h>
#include <stdbool.h>
#define FARRAY_SIZE 64
......@@ -63,7 +64,7 @@ format_data;
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",
......@@ -75,6 +76,129 @@ static const char posint_required[] = "Positive width 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. */
......@@ -90,7 +214,8 @@ next_char (format_data *fmt, int literal)
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);
......@@ -141,10 +266,10 @@ get_fnode (format_data *fmt, fnode **head, fnode **tail, format_token t)
/* 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;
......@@ -156,7 +281,7 @@ free_format_data (st_parameter_dt *dtp)
}
free_mem (fmt);
dtp->u.p.fmt = NULL;
fmt = NULL;
}
......@@ -184,6 +309,14 @@ format_lex (format_data *fmt)
switch (c)
{
case '(':
token = FMT_LPAREN;
break;
case ')':
token = FMT_RPAREN;
break;
case '-':
negative_flag = 1;
/* Fall Through */
......@@ -276,14 +409,6 @@ format_lex (format_data *fmt)
break;
case '(':
token = FMT_LPAREN;
break;
case ')':
token = FMT_RPAREN;
break;
case 'X':
token = FMT_X;
break;
......@@ -455,8 +580,10 @@ parse_format_list (st_parameter_dt *dtp)
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:
......@@ -567,6 +694,7 @@ parse_format_list (st_parameter_dt *dtp)
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:
......@@ -592,6 +720,7 @@ parse_format_list (st_parameter_dt *dtp)
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;
......@@ -689,6 +818,7 @@ parse_format_list (st_parameter_dt *dtp)
fmt->saved_token = t;
fmt->value = 1; /* Default width */
notify_std (&dtp->common, GFC_STD_GNU, posint_required);
save_format = false;
}
}
......@@ -999,6 +1129,33 @@ format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
}
/* 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
......@@ -1006,6 +1163,21 @@ parse_format (st_parameter_dt *dtp)
{
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;
......@@ -1037,35 +1209,12 @@ parse_format (st_parameter_dt *dtp)
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);
}
......
libgfortran/io/intrinsics.c
......@@ -54,13 +54,13 @@ PREFIX(fgetc) (const int * unit, char * c, gfc_charlen_type c_len)
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;
......@@ -119,17 +119,17 @@ int
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;
}
......@@ -196,7 +196,7 @@ flush_i4 (GFC_INTEGER_4 *unit)
us = find_unit (*unit);
if (us != NULL)
{
flush (us->s);
sflush (us->s);
unlock_unit (us);
}
}
......@@ -219,7 +219,7 @@ flush_i8 (GFC_INTEGER_8 *unit)
us = find_unit (*unit);
if (us != NULL)
{
flush (us->s);
sflush (us->s);
unlock_unit (us);
}
}
......@@ -234,22 +234,17 @@ void
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);
}
......@@ -266,7 +261,7 @@ PREFIX(ftell) (int * unit)
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;
}
......@@ -282,7 +277,7 @@ PREFIX(ftell) (int * unit)
*offset = -1; \
else \
{ \
*offset = stream_offset (u->s); \
*offset = stell (u->s); \
unlock_unit (u); \
} \
}
......
libgfortran/io/io.h
......@@ -49,34 +49,59 @@ struct st_parameter_dt;
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. */
......@@ -106,6 +131,18 @@ typedef struct array_loop_spec
}
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
......@@ -127,7 +164,6 @@ array_loop_spec;
typedef struct namelist_type
{
/* Object type, stored as GFC_DTYPE_xxxx. */
bt type;
......@@ -538,10 +574,9 @@ unit_flags;
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;
......@@ -599,6 +634,9 @@ typedef struct gfc_unit
int file_len;
char *file;
/* The format hash table. */
struct format_hash_entry format_hash_table[FORMAT_HASH_SIZE];
/* Formatting buffer. */
struct fbuf *fbuf;
......@@ -683,6 +721,12 @@ internal_proto(open_external);
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);
......@@ -698,12 +742,6 @@ internal_proto(compare_file_filename);
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);
......@@ -734,9 +772,6 @@ internal_proto(inquire_readwrite);
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);
......@@ -752,18 +787,12 @@ internal_proto(flush_if_preconnected);
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);
......@@ -807,6 +836,9 @@ internal_proto(update_position);
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 *);
......@@ -826,9 +858,18 @@ internal_proto(unget_format);
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
......@@ -836,7 +877,7 @@ internal_proto(free_format_data);
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);
......@@ -862,6 +903,9 @@ internal_proto (reverse_memcpy);
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);
......@@ -968,24 +1012,39 @@ extern size_t size_from_complex_kind (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);
......
libgfortran/io/list_read.c
......@@ -33,6 +33,7 @@ Boston, MA 02110-1301, USA. */
#include "io.h"
#include <string.h>
#include <stdlib.h>
#include <ctype.h>
......@@ -79,9 +80,8 @@ push_char (st_parameter_dt *dtp, char c)
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;
......@@ -90,15 +90,15 @@ push_char (st_parameter_dt *dtp, char c)
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;
......@@ -113,8 +113,7 @@ free_saved (st_parameter_dt *dtp)
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;
......@@ -140,9 +139,10 @@ free_line (st_parameter_dt *dtp)
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')
{
......@@ -194,7 +194,7 @@ next_char (st_parameter_dt *dtp)
}
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;
......@@ -204,19 +204,15 @@ next_char (st_parameter_dt *dtp)
/* 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. */
......@@ -240,13 +236,20 @@ next_char (st_parameter_dt *dtp)
}
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');
......@@ -1698,7 +1701,7 @@ list_formatted_read_scalar (st_parameter_dt *dtp, volatile bt type, void *p,
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))
{
......@@ -1726,6 +1729,9 @@ list_formatted_read_scalar (st_parameter_dt *dtp, volatile bt type, void *p,
return;
goto set_value;
}
if (dtp->u.p.input_complete)
goto cleanup;
if (dtp->u.p.input_complete)
goto cleanup;
......@@ -1853,6 +1859,8 @@ finish_list_read (st_parameter_dt *dtp)
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;
......@@ -2261,8 +2269,8 @@ nml_query (st_parameter_dt *dtp, char c)
/* 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);
}
......@@ -2903,7 +2911,7 @@ find_nml_name:
st_printf ("%s\n", nml_err_msg);
if (u != NULL)
{
flush (u->s);
sflush (u->s);
unlock_unit (u);
}
}
......
libgfortran/io/open.c
......@@ -155,7 +155,7 @@ static const st_option async_opt[] =
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;
}
......@@ -271,7 +271,7 @@ edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
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;
......@@ -281,7 +281,7 @@ edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
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)
......@@ -557,7 +557,7 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
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;
}
......@@ -611,7 +611,8 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
{
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);
......@@ -627,7 +628,7 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
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);
......
libgfortran/io/read.c
......@@ -33,6 +33,7 @@ Boston, MA 02110-1301, USA. */
#include <errno.h>
#include <ctype.h>
#include <stdlib.h>
#include <assert.h>
typedef unsigned char uchar;
......@@ -141,38 +142,30 @@ convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
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");
}
......@@ -195,13 +188,13 @@ void
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 == ' ')
......@@ -238,28 +231,26 @@ read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
}
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;
......@@ -274,9 +265,8 @@ read_utf8 (st_parameter_dt *dtp, size_t *nbytes)
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++)
......@@ -309,14 +299,14 @@ read_utf8 (st_parameter_dt *dtp, size_t *nbytes)
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;
......@@ -339,21 +329,19 @@ read_utf8_char1 (st_parameter_dt *dtp, char *p, int len, size_t width)
}
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;
......@@ -363,13 +351,13 @@ read_default_char1 (st_parameter_dt *dtp, char *p, int len, size_t 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;
......@@ -391,19 +379,17 @@ read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, size_t width)
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;
......@@ -425,7 +411,7 @@ void
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 */
......@@ -451,13 +437,11 @@ read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
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;
......@@ -532,18 +516,15 @@ read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
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)
{
......@@ -636,17 +617,14 @@ read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
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)
{
......@@ -783,75 +761,83 @@ read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
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':
......@@ -862,207 +848,173 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
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;
}
......
libgfortran/io/transfer.c
......@@ -37,6 +37,7 @@ Boston, MA 02110-1301, USA. */
#include <string.h>
#include <assert.h>
#include <stdlib.h>
#include <errno.h>
/* Calling conventions: Data transfer statements are unlike other
......@@ -183,60 +184,58 @@ current_mode (st_parameter_dt *dtp)
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. */
......@@ -245,23 +244,14 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error)
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,
......@@ -275,7 +265,6 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error)
}
*length = n;
dtp->u.p.sf_seen_eor = (crlf ? 2 : 1);
break;
}
/* Short circuit the read if a comma is found during numeric input.
......@@ -284,6 +273,7 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error)
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;
......@@ -291,16 +281,31 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error)
}
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;
}
......@@ -316,12 +321,11 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error)
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))
{
......@@ -338,15 +342,14 @@ read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes)
{
/* 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;
......@@ -357,42 +360,36 @@ read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes)
(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;
}
......@@ -402,18 +399,18 @@ read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes)
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;
......@@ -425,7 +422,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
{
/* 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;
......@@ -448,14 +445,14 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
dtp->u.p.current_unit->bytes_left -= to_read_record;
if (unlikely (sread (dtp->u.p.current_unit->s, buf, &to_read_record)
!= 0))
to_read_record = sread (dtp->u.p.current_unit->s, buf, to_read_record);
if (unlikely (to_read_record < 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return;
}
if (to_read_record != *nbytes)
if (to_read_record != (ssize_t) *nbytes)
{
/* Short read, e.g. if we hit EOF. Apparently, we read
more than was written to the last record. */
......@@ -475,18 +472,12 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
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
......@@ -501,7 +492,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
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
......@@ -512,9 +503,9 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
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;
......@@ -603,7 +594,7 @@ write_block (st_parameter_dt *dtp, int length)
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)
{
......@@ -641,20 +632,22 @@ static try
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;
}
......@@ -672,14 +665,15 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
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;
}
......@@ -709,8 +703,9 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
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;
......@@ -920,19 +915,18 @@ require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
}
/* 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;
......@@ -959,7 +953,347 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
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 (;;)
{
......@@ -1010,7 +1344,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
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;
......@@ -1029,57 +1363,34 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
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:
......@@ -1089,31 +1400,16 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
/* 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:
......@@ -1121,12 +1417,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
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:
......@@ -1134,11 +1425,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
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:
......@@ -1146,12 +1433,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
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:
......@@ -1159,12 +1441,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
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:
......@@ -1172,41 +1449,14 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
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;
......@@ -1221,25 +1471,18 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
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;
......@@ -1251,21 +1494,15 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
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:
......@@ -1287,12 +1524,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
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
......@@ -1305,43 +1537,6 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
+ 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:
......@@ -1409,30 +1604,16 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
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;
......@@ -1444,6 +1625,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
unget_format (dtp, f);
}
static void
formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
size_t size, size_t nelems)
......@@ -1454,16 +1636,27 @@ formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
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. */
......@@ -1657,34 +1850,28 @@ transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
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;
......@@ -1750,7 +1937,7 @@ us_read (st_parameter_dt *dtp, int continued)
static void
us_write (st_parameter_dt *dtp, int continued)
{
size_t nbytes;
ssize_t nbytes;
gfc_offset dummy;
dummy = 0;
......@@ -1760,7 +1947,7 @@ us_write (st_parameter_dt *dtp, int continued)
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
......@@ -1962,7 +2149,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
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)
......@@ -2111,65 +2298,71 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
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)
......@@ -2188,15 +2381,10 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
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. */
......@@ -2211,37 +2399,28 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
/* 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);
......@@ -2394,8 +2573,8 @@ next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished)
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];
......@@ -2405,12 +2584,10 @@ skip_record (st_parameter_dt *dtp, size_t bytes)
if (is_seekable (dtp->u.p.current_unit->s))
{
new = file_position (dtp->u.p.current_unit->s)
+ dtp->u.p.current_unit->bytes_left_subrecord;
/* Direct access files do not generate END conditions,
only I/O errors. */
if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
if (sseek (dtp->u.p.current_unit->s,
dtp->u.p.current_unit->bytes_left_subrecord, SEEK_CUR) < 0)
generate_error (&dtp->common, LIBERROR_OS, NULL);
}
else
......@@ -2418,16 +2595,17 @@ skip_record (st_parameter_dt *dtp, size_t bytes)
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;
}
}
......@@ -2475,8 +2653,8 @@ next_record_r (st_parameter_dt *dtp)
{
gfc_offset record;
int bytes_left;
size_t length;
char p;
int cc;
switch (current_mode (dtp))
{
......@@ -2496,11 +2674,12 @@ next_record_r (st_parameter_dt *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;
}
......@@ -2515,7 +2694,7 @@ next_record_r (st_parameter_dt *dtp)
/* Now seek to this record. */
record = record * dtp->u.p.current_unit->recl;
if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
break;
......@@ -2527,10 +2706,9 @@ next_record_r (st_parameter_dt *dtp)
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;
......@@ -2540,42 +2718,37 @@ next_record_r (st_parameter_dt *dtp)
}
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;
......@@ -2595,12 +2768,12 @@ write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
{
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:
......@@ -2615,13 +2788,13 @@ write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
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:
......@@ -2644,7 +2817,7 @@ next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
/* 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. */
......@@ -2654,7 +2827,7 @@ next_record_w_unf (st_parameter_dt *dtp, int 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;
if (compile_options.record_marker == 0)
......@@ -2665,8 +2838,8 @@ next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
/* 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)
......@@ -2674,13 +2847,13 @@ next_record_w_unf (st_parameter_dt *dtp, int 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;
......@@ -2691,6 +2864,35 @@ next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
}
/* 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
......@@ -2699,9 +2901,6 @@ next_record_w (st_parameter_dt *dtp, int done)
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;
......@@ -2716,8 +2915,11 @@ next_record_w (st_parameter_dt *dtp, int done)
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;
......@@ -2726,7 +2928,7 @@ next_record_w (st_parameter_dt *dtp, int done)
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;
......@@ -2757,8 +2959,7 @@ next_record_w (st_parameter_dt *dtp, int done)
{
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;
......@@ -2766,7 +2967,7 @@ next_record_w (st_parameter_dt *dtp, int done)
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;
......@@ -2782,7 +2983,7 @@ next_record_w (st_parameter_dt *dtp, int done)
/* 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;
......@@ -2805,8 +3006,7 @@ next_record_w (st_parameter_dt *dtp, int done)
{
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;
......@@ -2817,7 +3017,7 @@ next_record_w (st_parameter_dt *dtp, int done)
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;
......@@ -2826,23 +3026,27 @@ next_record_w (st_parameter_dt *dtp, int done)
}
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);
}
}
......@@ -2880,7 +3084,7 @@ next_record (st_parameter_dt *dtp, int done)
dtp->u.p.current_unit->current_record = 0;
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{
fp = file_position (dtp->u.p.current_unit->s);
fp = stell (dtp->u.p.current_unit->s);
/* Calculate next record, rounding up partial records. */
dtp->u.p.current_unit->last_record =
(fp + dtp->u.p.current_unit->recl - 1) /
......@@ -2892,6 +3096,8 @@ next_record (st_parameter_dt *dtp, int done)
if (!done)
pre_position (dtp);
fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
}
......@@ -2940,7 +3146,6 @@ finalize_transfer (st_parameter_dt *dtp)
if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
{
finish_list_read (dtp);
sfree (dtp->u.p.current_unit->s);
return;
}
......@@ -2955,10 +3160,9 @@ finalize_transfer (st_parameter_dt *dtp)
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;
}
......@@ -2967,9 +3171,8 @@ finalize_transfer (st_parameter_dt *dtp)
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;
}
......@@ -2981,15 +3184,17 @@ finalize_transfer (st_parameter_dt *dtp)
- 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
......@@ -3046,8 +3251,6 @@ void
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 ();
}
......@@ -3063,29 +3266,6 @@ st_read (st_parameter_dt *dtp)
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 *);
......@@ -3095,10 +3275,9 @@ void
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);
......@@ -3141,19 +3320,16 @@ st_write_done (st_parameter_dt *dtp)
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);
......@@ -3267,3 +3443,46 @@ void reverse_memcpy (void *dest, const void *src, size_t n)
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;
}
}
libgfortran/io/unit.c
......@@ -540,6 +540,8 @@ init_units (void)
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);
}
......@@ -640,7 +642,8 @@ close_unit_1 (gfc_unit *u, int locked)
free_mem (u->file);
u->file = NULL;
u->file_len = 0;
free_format_hash_table (u);
fbuf_destroy (u);
if (!locked)
......@@ -697,15 +700,62 @@ close_units (void)
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. */
......@@ -746,23 +796,25 @@ finish_last_advance_record (gfc_unit *u)
{
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);
}
libgfortran/io/unix.c
......@@ -94,10 +94,6 @@ id_from_fd (const int fd)
#endif
#ifndef SSIZE_MAX
#define SSIZE_MAX SHRT_MAX
#endif
#ifndef PATH_MAX
#define PATH_MAX 1024
#endif
......@@ -129,102 +125,32 @@ id_from_fd (const int fd)
#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 */
......@@ -236,15 +162,12 @@ move_pos_offset (stream* st, int pos_off)
{
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;
......@@ -327,580 +250,330 @@ flush_if_preconnected (stream * s)
}
/* 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
......@@ -912,33 +585,33 @@ fd_open (unix_stream * s)
*********************************************************************/
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)
......@@ -955,25 +628,20 @@ mem_alloc_w_at (int_stream * s, int *len)
/* 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;
}
......@@ -981,84 +649,90 @@ mem_read (int_stream * s, void * buf, size_t * nbytes)
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;
}
/*********************************************************************
......@@ -1071,7 +745,7 @@ mem_sfree (int_stream * s __attribute__ ((unused)))
void
empty_internal_buffer(stream *strm)
{
int_stream * s = (int_stream *) strm;
unix_stream * s = (unix_stream *) strm;
memset(s->buffer, ' ', s->file_length);
}
......@@ -1080,10 +754,10 @@ empty_internal_buffer(stream *strm)
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;
......@@ -1091,14 +765,13 @@ open_internal (char *base, int length, gfc_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;
}
......@@ -1133,7 +806,14 @@ fd_to_stream (int fd, int prot)
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;
}
......@@ -1417,8 +1097,6 @@ output_stream (void)
#endif
s = fd_to_stream (STDOUT_FILENO, PROT_WRITE);
if (options.unbuffered_preconnected)
((unix_stream *) s)->method = SYNC_UNBUFFERED;
return s;
}
......@@ -1436,8 +1114,6 @@ error_stream (void)
#endif
s = fd_to_stream (STDERR_FILENO, PROT_WRITE);
if (options.unbuffered_preconnected)
((unix_stream *) s)->method = SYNC_UNBUFFERED;
return s;
}
......@@ -1668,7 +1344,7 @@ flush_all_units_1 (gfc_unit *u, int min_unit)
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;
......@@ -1698,7 +1374,7 @@ flush_all_units (void)
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);
......@@ -1715,40 +1391,6 @@ flush_all_units (void)
}
/* 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. */
......@@ -1954,16 +1596,15 @@ inquire_readwrite (const char *string, int len)
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;
}
......@@ -1988,12 +1629,6 @@ is_special (stream *s)
}
try
flush (stream *s)
{
return fd_flush( (unix_stream *) s);
}
int
stream_isatty (stream *s)
{
......@@ -2010,12 +1645,6 @@ stream_ttyname (stream *s __attribute__ ((unused)))
#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.
......
libgfortran/io/write.c
......@@ -113,7 +113,7 @@ write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
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. */
......@@ -784,8 +784,7 @@ write_x (st_parameter_dt *dtp, int len, int nspaces)
p = write_block (dtp, len);
if (p == NULL)
return;
if (nspaces > 0)
if (nspaces > 0 && len - nspaces >= 0)
memset (&p[len - nspaces], ' ', nspaces);
}
......@@ -1173,7 +1172,7 @@ namelist_write_newline (st_parameter_dt *dtp)
/* Now seek to this record */
record = record * dtp->u.p.current_unit->recl;
if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
return;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment