mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-31 21:41:33 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
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
This commit is contained in:
Jerry DeLisle 2009-04-05 20:13:56 +00:00
parent 941c3614de
commit 7812c78c34
13 changed files with 2248 additions and 1857 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

201
libgfortran/ChangeLog
View File

@ -1,3 +1,204 @@
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

257
libgfortran/io/fbuf.c
View File

@ -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;
}

88
libgfortran/io/file_pos.c
View File

@ -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

233
libgfortran/io/format.c
View File

@ -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);
}

35
libgfortran/io/intrinsics.c
View File

@ -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); \
} \
}

153
libgfortran/io/io.h
View File

@ -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);

70
libgfortran/io/list_read.c
View File

@ -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);
}
}

13
libgfortran/io/open.c
View File

@ -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);

504
libgfortran/io/read.c
View File

@ -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;
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;
@ -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];
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? */
val_sign = 1;
seen_dp = 0;
wu = f->u.w;
seen_int_digit = 0;
seen_dec_digit = 0;
exponent_sign = 1;
exponent = 0;
w = f->u.w;
p = gfc_alloca (wu);
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,65 +848,160 @@ 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;
++p;
--w;
}
/* 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);
/* At this point the start of an exponent has been found. */
exponent:
p = eat_leading_spaces (&w, (char*) p);
if (*p == '-' || *p == '+')
{
if (*p == '-')
exponent_sign = -1;
++p;
--w;
}
/* 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;
if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
{
while (w > 0 && isdigit (*p))
{
exponent *= 10;
exponent += *p - '0';
++p;
--w;
}
/* Only allow trailing blanks. */
while (w > 0)
{
if (*p != ' ')
goto bad_float;
++p;
--w;
}
}
else /* BZ or BN status is enabled. */
{
while (w > 0)
{
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_sign;
done:
/* Use the precision specified in the format if no decimal point has been
seen. */
if (!seen_dp)
exponent -= f->u.real.d;
/* Output a trailing '0' after decimal point if not yet found. */
if (seen_dp && !seen_dec_digit)
*(out++) = '0';
/* Print out the exponent to finish the reformatted number. Maximum 4
digits for the exponent. */
if (exponent != 0)
{
int dig;
*(out++) = 'e';
if (exponent < 0)
{
*(out++) = '-';
exponent = - exponent;
}
assert (exponent < 10000);
for (dig = 3; dig >= 0; --dig)
{
out[dig] = (char) ('0' + exponent % 10);
exponent /= 10;
}
out += 4;
}
*(out++) = '\0';
/* Do the actual conversion. */
convert_real (dtp, dest, buffer, length);
return;
/* The value read is zero */
zero:
/* The value read is zero. */
zero:
switch (length)
{
case 4:
*((GFC_REAL_4 *) dest) = 0;
*((GFC_REAL_4 *) dest) = 0.0;
break;
case 8:
*((GFC_REAL_8 *) dest) = 0;
*((GFC_REAL_8 *) dest) = 0.0;
break;
#ifdef HAVE_GFC_REAL_10
case 10:
*((GFC_REAL_10 *) dest) = 0;
*((GFC_REAL_10 *) dest) = 0.0;
break;
#endif
#ifdef HAVE_GFC_REAL_16
case 16:
*((GFC_REAL_16 *) dest) = 0;
*((GFC_REAL_16 *) dest) = 0.0;
break;
#endif
@ -929,140 +1010,11 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
}
return;
/* At this point the start of an exponent has been found */
exp1:
while (w > 0 && *p == ' ')
{
w--;
p++;
}
switch (*p)
{
case '-':
exponent_sign = -1;
/* Fall through */
case '+':
p++;
w--;
break;
}
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 */
while (w > 0)
{
if (*p != ' ')
goto bad_float;
p++;
w--;
}
}
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--;
}
}
exponent = exponent * exponent_sign;
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;
}
while (i >= 10)
{
i /= 10;
edigits++;
}
i = ndigits + edigits + 1;
if (val_sign < 0)
i++;
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++;
}
*(p++) = 'e';
sprintf (p, "%d", exponent);
/* Do the actual conversion. */
convert_real (dtp, dest, buffer, length);
if (buffer != scratch)
free_mem (buffer);
bad_float:
generate_error (&dtp->common, LIBERROR_READ_VALUE,
"Bad value during floating point read");
next_record (dtp, 1);
return;
}

1343
libgfortran/io/transfer.c
View File

File diff suppressed because it is too large Load Diff

76
libgfortran/io/unit.c
View File

@ -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);
}

1125
libgfortran/io/unix.c
View File

File diff suppressed because it is too large Load Diff

7
libgfortran/io/write.c
View File

@ -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;