This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: Ping! Re: [patch, libgfortran] PR37754 [4.4 Regression] READ I/O Performance regression from 4.3 to 4.4/4.5
Jack Howarth wrote:
On Mon, May 25, 2009 at 10:23:15PM +0300, Janne Blomqvist wrote:
Jerry DeLisle wrote:
Jerry DeLisle wrote:
The attached patch is a backport of the I/O performance patches and
associated fixes from trunk.
Regression tested on x86-64.
OK for 4.4. This will close out the PR.
I am staged and ready to pull the trigger on this. Need an approval. :)
Ok.
I'm not completely comfortable with this, it's a pretty large set of
changes. However, they seem to have worked surprisingly well on trunk.
Or perhaps people are using trunk less now that the released versions
are good enough for most purposes..
--
Janne Blomqvist
Has anyone actually tried to bootstrap gcc 4.4 with the proposed patch?
I had a rather cryptic error from make when trying to build it against
Saturday's gcc 4.4 branch on x86_64-apple-darwin9. Without the proposed
patch, gcc 4.4 branch built fine.
Jack
Please accept my apology. I missed some hunks related to xtoa and itoa
functions that were moved or renamed to gfc_xtoa and gfc_itoa.
The attached patch corrects all this and is what I will commit. I regression
tested and NIST tested again just to be sure.
Jerry
Index: runtime/backtrace.c
===================================================================
--- runtime/backtrace.c (revision 147820)
+++ runtime/backtrace.c (working copy)
@@ -147,7 +147,7 @@ show_backtrace (void)
/* Write the list of addresses in hexadecimal format. */
for (i = 0; i < depth; i++)
- addr[i] = xtoa ((GFC_UINTEGER_LARGEST) (intptr_t) trace[i], addr_buf[i],
+ addr[i] = gfc_xtoa ((GFC_UINTEGER_LARGEST) (intptr_t) trace[i], addr_buf[i],
sizeof (addr_buf[i]));
/* Don't output an error message if something goes wrong, we'll simply
Index: runtime/error.c
===================================================================
--- runtime/error.c (revision 147820)
+++ runtime/error.c (working copy)
@@ -112,47 +112,10 @@ sys_exit (int code)
* Other error returns are reserved for the STOP statement with a numeric code.
*/
-/* gfc_itoa()-- Integer to decimal conversion. */
+/* gfc_xtoa()-- Integer to hexadecimal conversion. */
const char *
-gfc_itoa (GFC_INTEGER_LARGEST n, char *buffer, size_t len)
-{
- int negative;
- char *p;
- GFC_UINTEGER_LARGEST t;
-
- assert (len >= GFC_ITOA_BUF_SIZE);
-
- if (n == 0)
- return "0";
-
- negative = 0;
- t = n;
- if (n < 0)
- {
- negative = 1;
- t = -n; /*must use unsigned to protect from overflow*/
- }
-
- p = buffer + GFC_ITOA_BUF_SIZE - 1;
- *p = '\0';
-
- while (t != 0)
- {
- *--p = '0' + (t % 10);
- t /= 10;
- }
-
- if (negative)
- *--p = '-';
- return p;
-}
-
-
-/* xtoa()-- Integer to hexadecimal conversion. */
-
-const char *
-xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
+gfc_xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
{
int digit;
char *p;
Index: ChangeLog
===================================================================
--- ChangeLog (revision 147820)
+++ ChangeLog (working copy)
@@ -1,3 +1,325 @@
+2009-05-23 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ Backport from mainline:
+ PR libfortran/37754
+ * io/write_float.def: Simplify format calculation.
+
+2009-05-23 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+ Backport from mainline:
+ PR fortran/22423
+ * io/transfer.c (read_block_direct): Avoid warning.
+
+2009-05-23 Janne Blomqvist <jb@gcc.gnu.org>
+
+ Backport from mainline:
+ PR libfortran/39667
+ * io/file_pos.c (st_rewind): Don't truncate or flush.
+ * io/intrinsics.c (fgetc): Flush if switching mode.
+ (fputc): Likewise.
+
+2009-05-23 Janne Blomqvist <jb@gcc.gnu.org>
+
+ Backport from mainline:
+ PR libfortran/39782
+ * io/transfer.c (data_transfer_init): Don't flush before seek.
+
+2009-05-23 Janne Blomqvist <jb@gcc.gnu.org>
+
+ Backport from mainline:
+ * io/io.h (is_preconnected): Remove prototype.
+ * io/unix.c (is_preconnected): Remove function.
+
+2009-05-23 Janne Blomqvist <jb@gcc.gnu.org>
+
+ Backport from mainline:
+ PR libfortran/38668
+ * io/transfer.c (finalize_transfer): Don't flush for advance='no'.
+
+2009-05-23 Danny Smith <dannysmith@clear.net.nz>
+
+ Backport from mainline:
+ * io/write.c (itoa) : Rename back to gfc_itoa.
+ (write_i): Adjust call to write_decimal.
+ (write_integer): Use gfc_itoa.
+
+2009-05-23 Janne Blomqvist <jb@gcc.gnu.org>
+
+ Backport from mainline:
+ * io/io.h (move_pos_offset): Remove prototype.
+ * io/transfer.c (formatted_transfer_scalar_read): Use sseek
+ instead of move_pos_offset.
+ * io/unix.c (move_pos_offset): Remove.
+
+2009-05-23 Janne Blomqvist <jb@gcc.gnu.org>
+
+ Backport from mainline:
+ PR libfortran/39665 libfortran/39702 libfortran/39709
+ * io/io.h (st_parameter_dt): Revert aligned attribute from u.p.value.
+ * io/list_read.c (read_complex): Read directly into user pointer.
+ (read_real): Likewise.
+ (list_formatted_read_scalar): Update read_complex and read_real calls.
+ (nml_read_obj): Read directly into user pointer.
+
+2009-05-23 Janne Blomqvist <jb@gcc.gnu.org>
+
+ Backport from mainline:
+ PR libfortran/39665
+ * io/io.h (st_parameter_dt): Add aligned attribute to u.p.value.
+ * io/read.c (convert_real): Add note about alignment requirements.
+
+2009-05-23 Janne Blomqvist <jb@gcc.gnu.org>
+
+ Backport from mainline:
+ * io/open.c (already_open): Test for POSIX close return value.
+ * io/unit.c (close_unit_1): Likewise.
+ * io/unix.c (raw_close): Return 0 for success for preconnected units.
+
+2009-05-23 Janne Blomqvist <jb@gcc.gnu.org>
+
+ Backport from mainline:
+ * runtime/error.c (gfc_itoa): Move to io/write.c
+ (xtoa): Rename to gfc_xtoa.
+ * runtime/backtrace.c (show_backtrace): Call gfc_xtoa.
+ * libgfortran.h (gfc_itoa): Remove prototype.
+ (xtoa): Rename prototype to gfc_xtoa.
+ * io/list_read.c (nml_read_obj): Use size_t for string length.
+ * io/transfer.c (read_block_direct): Change nbytes arg from
+ pointer to value.
+ (unformatted_read): Minor cleanup, call read_block_directly properly.
+ (skip_record): Use ssize_t.
+ (next_record_w_unf): Avoid stell() call by calling sseek with SEEK_CUR.
+ (iolength_transfer): Make sure to multiply before cast.
+ * io/intrinsics.c (fgetc): Remove unnecessary variable.
+ * io/format.c (format_hash): Use gfc_charlen_type.
+ * io/write.c (itoa): Move from runtime/error.c:gfc_itoa, rename,
+ make static.
+ (write_i): Call with pointer to itoa.
+ (write_z): Call with pointer to gfc_xtoa.
+ (write_integer): Pointer to itoa.
+ (nml_write_obj): Type cleanup, don't call strlen in loop.
+
+2009-05-23 H.J. Lu <hongjiu.lu@intel.com>
+
+ Backport from mainline:
+ PR libgfortran/39664
+ * io/unix.c (raw_close): Don't close STDOUT_FILENO,
+ STDERR_FILENO nor STDIN_FILENO.
+
+2009-05-23 David Edelsohn <edelsohn@gnu.org>
+
+ Backport from mainline:
+ * io/io.h (struct stream): Rename truncate to trunc.
+ (struncate): Same.
+ * io/unix.c (raw_init): Rename truncate to trunc.
+ (buf_init): Same.
+ (open_internal): Same.
+
+2009-05-23 Daniel Kraft <d@domob.eu>
+
+ Backport from mainline:
+ 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-05-23 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ Backport from mainline:
+ 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-05-23 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ Backport from mainline:
+ 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-05-23 Janne Blomqvist <jb@gcc.gnu.org>
+
+ Backport from mainline:
+ 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-05-16 Janne Blomqvist <jb@gcc.gnu.org>
PR libfortran/39782
Index: libgfortran.h
===================================================================
--- libgfortran.h (revision 147820)
+++ libgfortran.h (working copy)
@@ -631,11 +631,8 @@ internal_proto(show_backtrace);
extern void sys_exit (int) __attribute__ ((noreturn));
internal_proto(sys_exit);
-extern const char *gfc_itoa (GFC_INTEGER_LARGEST, char *, size_t);
-internal_proto(gfc_itoa);
-
-extern const char *xtoa (GFC_UINTEGER_LARGEST, char *, size_t);
-internal_proto(xtoa);
+extern const char *gfc_xtoa (GFC_UINTEGER_LARGEST, char *, size_t);
+internal_proto(gfc_xtoa);
extern void os_error (const char *) __attribute__ ((noreturn));
iexport_proto(os_error);
Index: io/file_pos.c
===================================================================
--- io/file_pos.c (revision 147820)
+++ io/file_pos.c (working copy)
@@ -41,17 +41,17 @@ formatted_backspace (st_parameter_filepo
{
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
@@ -76,7 +76,7 @@ formatted_backspace (st_parameter_filepo
/* 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;
@@ -95,10 +95,10 @@ formatted_backspace (st_parameter_filepo
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)];
@@ -109,9 +109,10 @@ unformatted_backspace (st_parameter_file
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. */
@@ -159,10 +160,7 @@ unformatted_backspace (st_parameter_file
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);
@@ -201,15 +199,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. */
@@ -217,11 +221,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 */
@@ -238,8 +242,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;
}
@@ -248,7 +251,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;
@@ -300,10 +303,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);
}
@@ -338,18 +341,11 @@ st_rewind (st_parameter_filepos *fpp)
u->previous_nonadvancing_write = 0;
- /* Flush the buffers. If we have been writing to the file, the last
- 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);
+ fbuf_reset (u);
- 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. */
@@ -361,7 +357,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. */
}
@@ -392,7 +388,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
Index: io/open.c
===================================================================
--- io/open.c (revision 147820)
+++ io/open.c (working copy)
@@ -150,7 +150,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;
}
@@ -266,7 +266,7 @@ edit_modes (st_parameter_open *opp, gfc_
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;
@@ -276,7 +276,7 @@ edit_modes (st_parameter_open *opp, gfc_
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)
@@ -552,7 +552,7 @@ new_unit (st_parameter_open *opp, gfc_un
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;
}
@@ -606,7 +606,8 @@ new_unit (st_parameter_open *opp, gfc_un
{
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);
@@ -622,7 +623,7 @@ new_unit (st_parameter_open *opp, gfc_un
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);
@@ -676,7 +677,7 @@ already_open (st_parameter_open *opp, gf
}
#endif
- if (sclose (u->s) == FAILURE)
+ if (sclose (u->s) == -1)
{
unlock_unit (u);
generate_error (&opp->common, LIBERROR_OS,
Index: io/list_read.c
===================================================================
--- io/list_read.c (revision 147820)
+++ io/list_read.c (working copy)
@@ -28,6 +28,7 @@ see the files COPYING3 and COPYING.RUNTI
#include "io.h"
#include <string.h>
+#include <stdlib.h>
#include <ctype.h>
@@ -74,9 +75,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;
@@ -85,15 +85,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;
@@ -108,8 +108,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;
@@ -135,9 +134,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')
{
@@ -189,7 +189,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;
@@ -199,19 +199,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. */
@@ -235,13 +231,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');
@@ -1216,7 +1219,7 @@ parse_real (st_parameter_dt *dtp, void *
what it is right away. */
static void
-read_complex (st_parameter_dt *dtp, int kind, size_t size)
+read_complex (st_parameter_dt *dtp, void * dest, int kind, size_t size)
{
char message[100];
char c;
@@ -1240,7 +1243,7 @@ read_complex (st_parameter_dt *dtp, int
}
eat_spaces (dtp);
- if (parse_real (dtp, dtp->u.p.value, kind))
+ if (parse_real (dtp, dest, kind))
return;
eol_1:
@@ -1263,7 +1266,7 @@ eol_2:
else
unget_char (dtp, c);
- if (parse_real (dtp, dtp->u.p.value + size / 2, kind))
+ if (parse_real (dtp, dest + size / 2, kind))
return;
eat_spaces (dtp);
@@ -1297,7 +1300,7 @@ eol_2:
/* Parse a real number with a possible repeat count. */
static void
-read_real (st_parameter_dt *dtp, int length)
+read_real (st_parameter_dt *dtp, void * dest, int length)
{
char c, message[100];
int seen_dp;
@@ -1510,7 +1513,7 @@ read_real (st_parameter_dt *dtp, int len
unget_char (dtp, c);
eat_separator (dtp);
push_char (dtp, '\0');
- if (convert_real (dtp, dtp->u.p.value, dtp->u.p.saved_string, length))
+ if (convert_real (dtp, dest, dtp->u.p.saved_string, length))
return;
free_saved (dtp);
@@ -1693,7 +1696,7 @@ list_formatted_read_scalar (st_parameter
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))
{
@@ -1721,6 +1724,9 @@ list_formatted_read_scalar (st_parameter
return;
goto set_value;
}
+
+ if (dtp->u.p.input_complete)
+ goto cleanup;
if (dtp->u.p.input_complete)
goto cleanup;
@@ -1751,10 +1757,16 @@ list_formatted_read_scalar (st_parameter
read_character (dtp, kind);
break;
case BT_REAL:
- read_real (dtp, kind);
+ read_real (dtp, p, kind);
+ /* Copy value back to temporary if needed. */
+ if (dtp->u.p.repeat_count > 0)
+ memcpy (dtp->u.p.value, p, kind);
break;
case BT_COMPLEX:
- read_complex (dtp, kind, size);
+ read_complex (dtp, p, kind, size);
+ /* Copy value back to temporary if needed. */
+ if (dtp->u.p.repeat_count > 0)
+ memcpy (dtp->u.p.value, p, size);
break;
default:
internal_error (&dtp->common, "Bad type for list read");
@@ -1770,8 +1782,12 @@ list_formatted_read_scalar (st_parameter
switch (dtp->u.p.saved_type)
{
case BT_COMPLEX:
- case BT_INTEGER:
case BT_REAL:
+ if (dtp->u.p.repeat_count > 0)
+ memcpy (p, dtp->u.p.value, size);
+ break;
+
+ case BT_INTEGER:
case BT_LOGICAL:
memcpy (p, dtp->u.p.value, size);
break;
@@ -1848,6 +1864,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;
@@ -2256,8 +2274,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);
}
@@ -2292,7 +2310,7 @@ nml_read_obj (st_parameter_dt *dtp, name
int dim;
index_type dlen;
index_type m;
- index_type obj_name_len;
+ size_t obj_name_len;
void * pdata;
/* This object not touched in name parsing. */
@@ -2371,12 +2389,17 @@ nml_read_obj (st_parameter_dt *dtp, name
break;
case GFC_DTYPE_REAL:
- read_real (dtp, len);
- break;
+ /* Need to copy data back from the real location to the temp in order
+ to handle nml reads into arrays. */
+ read_real (dtp, pdata, len);
+ memcpy (dtp->u.p.value, pdata, dlen);
+ break;
case GFC_DTYPE_COMPLEX:
- read_complex (dtp, len, dlen);
- break;
+ /* Same as for REAL, copy back to temp. */
+ read_complex (dtp, pdata, len, dlen);
+ memcpy (dtp->u.p.value, pdata, dlen);
+ break;
case GFC_DTYPE_DERIVED:
obj_name_len = strlen (nl->var_name) + 1;
@@ -2898,7 +2921,7 @@ find_nml_name:
st_printf ("%s\n", nml_err_msg);
if (u != NULL)
{
- flush (u->s);
+ sflush (u->s);
unlock_unit (u);
}
}
Index: io/read.c
===================================================================
--- io/read.c (revision 147820)
+++ io/read.c (working copy)
@@ -28,6 +28,7 @@ see the files COPYING3 and COPYING.RUNTI
#include <errno.h>
#include <ctype.h>
#include <stdlib.h>
+#include <assert.h>
typedef unsigned char uchar;
@@ -125,8 +126,10 @@ max_value (int length, int signed_flag)
/* convert_real()-- Convert a character representation of a floating
* point number to the machine number. Returns nonzero if there is a
- * range problem during conversion. TODO: handle not-a-numbers and
- * infinities. */
+ * range problem during conversion. Note: many architectures
+ * (e.g. IA-64, HP-PA) require that the storage pointed to by the dest
+ * argument is properly aligned for the type in question. TODO:
+ * handle not-a-numbers and infinities. */
int
convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
@@ -136,38 +139,30 @@ convert_real (st_parameter_dt *dtp, void
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");
}
@@ -190,13 +185,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 == ' ')
@@ -233,28 +228,26 @@ read_l (st_parameter_dt *dtp, const fnod
}
-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;
@@ -269,9 +262,8 @@ read_utf8 (st_parameter_dt *dtp, size_t
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++)
@@ -304,14 +296,14 @@ read_utf8 (st_parameter_dt *dtp, size_t
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;
@@ -334,21 +326,19 @@ read_utf8_char1 (st_parameter_dt *dtp, c
}
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;
@@ -358,13 +348,13 @@ read_default_char1 (st_parameter_dt *dtp
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;
@@ -386,19 +376,17 @@ read_utf8_char4 (st_parameter_dt *dtp, v
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;
@@ -420,7 +408,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 */
@@ -446,13 +434,11 @@ read_a (st_parameter_dt *dtp, const fnod
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;
@@ -527,18 +513,15 @@ read_decimal (st_parameter_dt *dtp, cons
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)
{
@@ -631,17 +614,14 @@ read_radix (st_parameter_dt *dtp, const
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)
{
@@ -778,75 +758,83 @@ read_radix (st_parameter_dt *dtp, const
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;
-
- p = gfc_alloca (wu);
+ 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':
@@ -857,207 +845,173 @@ read_f (st_parameter_dt *dtp, const fnod
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)
+ /* 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)
{
- edigits = 2;
- i = exponent;
- }
- else
- {
- edigits = 3;
- i = -exponent;
- }
+ int dig;
- while (i >= 10)
- {
- i /= 10;
- edigits++;
+ *(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';
- i = ndigits + edigits + 1;
- if (val_sign < 0)
- i++;
+ /* Do the actual conversion. */
+ convert_real (dtp, dest, buffer, length);
- if (i < SCRATCH_SIZE)
- buffer = scratch;
- else
- buffer = get_mem (i);
+ return;
- /* 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--)
+ /* The value read is zero. */
+zero:
+ switch (length)
{
- 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);
+ case 4:
+ *((GFC_REAL_4 *) dest) = 0.0;
+ break;
- /* Do the actual conversion. */
- convert_real (dtp, dest, buffer, length);
+ case 8:
+ *((GFC_REAL_8 *) dest) = 0.0;
+ break;
- if (buffer != scratch)
- free_mem (buffer);
+#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;
}
Index: io/io.h
===================================================================
--- io/io.h (revision 147820)
+++ io/io.h (working copy)
@@ -46,34 +46,60 @@ 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 *);
+ /* Avoid keyword truncate due to AIX namespace collision. */
+ int (*trunc) (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);
+}
+
+static inline ssize_t
+swrite (stream * s, const void * buf, ssize_t nbyte)
+{
+ return s->write (s, buf, nbyte);
+}
-/* Macros for doing file I/O given a stream. */
+static inline off_t
+sseek (stream * s, off_t offset, int whence)
+{
+ return s->seek (s, offset, whence);
+}
+
+static inline off_t
+stell (stream * s)
+{
+ return s->tell (s);
+}
-#define sfree(s) ((s)->sfree)(s)
-#define sclose(s) ((s)->close)(s)
+static inline int
+struncate (stream * s, off_t length)
+{
+ return s->trunc (s, length);
+}
-#define salloc_w(s, len) ((s)->alloc_w_at)(s, len)
+static inline int
+sflush (stream * s)
+{
+ return s->flush (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
+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. */
@@ -103,6 +129,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
@@ -124,7 +162,6 @@ array_loop_spec;
typedef struct namelist_type
{
-
/* Object type, stored as GFC_DTYPE_xxxx. */
bt type;
@@ -461,9 +498,9 @@ typedef struct st_parameter_dt
/* A flag used to identify when a non-standard expanded namelist read
has occurred. */
int expanded_read;
- /* Storage area for values except for strings. Must be large
- enough to hold a complex value (two reals) of the largest
- kind. */
+ /* Storage area for values except for strings. Must be
+ large enough to hold a complex value (two reals) of the
+ largest kind. */
char value[32];
GFC_IO_INT size_used;
} p;
@@ -535,10 +572,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;
@@ -596,6 +632,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;
@@ -668,9 +707,6 @@ fnode;
/* unix.c */
-extern int move_pos_offset (stream *, int);
-internal_proto(move_pos_offset);
-
extern int compare_files (stream *, stream *);
internal_proto(compare_files);
@@ -680,6 +716,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);
@@ -695,12 +737,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);
@@ -731,36 +767,24 @@ 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);
extern int is_special (stream *);
internal_proto(is_special);
-extern int is_preconnected (stream *);
-internal_proto(is_preconnected);
-
extern void flush_if_preconnected (stream *);
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);
@@ -804,6 +828,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 *);
@@ -823,9 +850,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
@@ -833,7 +869,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);
@@ -859,6 +895,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);
@@ -965,24 +1004,39 @@ extern size_t size_from_complex_kind (in
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);
Index: io/unit.c
===================================================================
--- io/unit.c (revision 147820)
+++ io/unit.c (working copy)
@@ -535,6 +535,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);
}
@@ -619,7 +621,7 @@ close_unit_1 (gfc_unit *u, int locked)
if (u->previous_nonadvancing_write)
finish_last_advance_record (u);
- rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
+ rc = (u->s == NULL) ? 0 : sclose (u->s) == -1;
u->closed = 1;
if (!locked)
@@ -635,7 +637,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)
@@ -692,15 +695,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. */
@@ -741,23 +791,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);
}
Index: io/fbuf.c
===================================================================
--- io/fbuf.c (revision 147820)
+++ io/fbuf.c (working copy)
@@ -28,8 +28,11 @@ see the files COPYING3 and COPYING.RUNTI
#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. */
@@ -37,14 +40,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;
}
@@ -56,58 +52,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;
@@ -118,42 +135,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;
}
Index: io/unix.c
===================================================================
--- io/unix.c (revision 147820)
+++ io/unix.c (working copy)
@@ -89,10 +89,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
@@ -124,128 +120,30 @@ 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 */
- 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;
- 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. */
+ char *buffer; /* Pointer to the buffer. */
+ int fd; /* The POSIX file descriptor. */
- 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 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;
-}
-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 */
-
-int
-move_pos_offset (stream* st, int pos_off)
-{
- unix_stream * str = (unix_stream*)st;
- if (pos_off < 0)
- {
- str->logical_offset += pos_off;
-
- if (str->dirty_offset + 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;
- }
- }
-
- return pos_off;
- }
- return 0;
}
+unix_stream;
/* fix_fd()-- Given a file descriptor, make sure it is not one of the
@@ -292,17 +190,6 @@ fix_fd (int fd)
return fd;
}
-int
-is_preconnected (stream * s)
-{
- int fd;
-
- fd = ((unix_stream *) s)->fd;
- if (fd == STDIN_FILENO || fd == STDOUT_FILENO || fd == STDERR_FILENO)
- return 1;
- else
- return 0;
-}
/* If the stream corresponds to a preconnected unit, we flush the
corresponding C stream. This is bugware for mixed C-Fortran codes
@@ -322,580 +209,335 @@ 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;
}
-
-/* get_oserror()-- Get the most recent operating system error. For
- * unix, this is errno. */
-
-const char *
-get_oserror (void)
+static off_t
+raw_seek (unix_stream * s, off_t offset, int whence)
{
- return strerror (errno);
+ return lseek (s->fd, offset, whence);
}
-
-/*********************************************************************
- File descriptor stream functions
-*********************************************************************/
-
-
-/* fd_flush()-- Write bytes that need to be written */
-
-static try
-fd_flush (unix_stream * s)
+static off_t
+raw_tell (unix_stream * s)
{
- size_t writelen;
-
- if (s->ndirty == 0)
- return SUCCESS;
-
- if (s->file_length != -1 && s->physical_offset != s->dirty_offset &&
- lseek (s->fd, s->dirty_offset, SEEK_SET) < 0)
- return FAILURE;
-
- writelen = s->ndirty;
- if (do_write (s, s->buffer + (s->dirty_offset - s->buffer_offset),
- &writelen) != 0)
- return FAILURE;
-
- s->physical_offset = s->dirty_offset + writelen;
-
- /* 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->ndirty -= writelen;
- if (s->ndirty != 0)
- return FAILURE;
-
- return SUCCESS;
+ return lseek (s->fd, 0, SEEK_CUR);
}
-
-/* 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 int
+raw_truncate (unix_stream * s, off_t length)
{
- char *new_buffer;
- int n, read_len;
-
- if (*len <= BUFFER_SIZE)
- {
- new_buffer = s->small_buffer;
- read_len = BUFFER_SIZE;
- }
- 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);
+#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
+}
- s->active = n;
- }
+static int
+raw_close (unix_stream * s)
+{
+ int retval;
+
+ if (s->fd != STDOUT_FILENO
+ && s->fd != STDERR_FILENO
+ && s->fd != STDIN_FILENO)
+ retval = close (s->fd);
else
- { /* new buffer starts off empty */
- s->active = 0;
- }
-
- s->buffer_offset = where;
-
- /* free the old buffer if necessary */
+ retval = 0;
+ free_mem (s);
+ return retval;
+}
- if (s->buffer != NULL && s->buffer != s->small_buffer)
- free_mem (s->buffer);
+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.trunc = (void *) raw_truncate;
+ s->st.close = (void *) raw_close;
+ s->st.flush = (void *) raw_flush;
- s->buffer = new_buffer;
- s->len = read_len;
+ s->buffer = NULL;
+ return 0;
}
-/* 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. */
+/*********************************************************************
+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 char *
-fd_alloc_r_at (unix_stream * s, int *len)
+static int
+buf_flush (unix_stream * s)
{
- gfc_offset m;
- gfc_offset where = s->logical_offset;
+ int writelen;
- if (s->buffer != NULL && s->buffer_offset <= where &&
- where + *len <= s->buffer_offset + s->active)
- {
-
- /* Return a position within the current buffer */
+ /* Flushing in read mode means discarding read bytes. */
+ s->active = 0;
- s->logical_offset = where + *len;
- return s->buffer + where - s->buffer_offset;
- }
+ if (s->ndirty == 0)
+ return 0;
+
+ if (s->file_length != -1 && s->physical_offset != s->buffer_offset
+ && lseek (s->fd, s->buffer_offset, SEEK_SET) < 0)
+ return -1;
- fd_alloc (s, where, len);
+ writelen = raw_write (s, s->buffer, s->ndirty);
- m = where + s->active;
+ s->physical_offset = s->buffer_offset + writelen;
- if (s->physical_offset != m && lseek (s->fd, m, SEEK_SET) < 0)
- return NULL;
+ /* 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;
- /* do_read() hangs on read from terminals for *BSD-systems. Only
- use read() in that case. */
+ s->ndirty -= writelen;
+ if (s->ndirty != 0)
+ return -1;
- if (s->special_file)
- {
- ssize_t n;
+ return 0;
+}
- n = read (s->fd, s->buffer + s->active, s->len - s->active);
- if (n < 0)
- return NULL;
+static ssize_t
+buf_read (unix_stream * s, void * buf, ssize_t nbyte)
+{
+ if (s->active == 0)
+ s->buffer_offset = s->logical_offset;
- s->physical_offset = m + n;
- s->active += n;
- }
+ /* 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
{
- 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;
+ /* 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;
}
-
- if (s->active < *len)
- *len = s->active; /* Bytes actually available */
-
- s->logical_offset = where + *len;
-
- return s->buffer;
+ s->logical_offset += nbyte;
+ return nbyte;
}
-
-/* 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)
+static ssize_t
+buf_write (unix_stream * s, const void * buf, ssize_t nbyte)
{
- 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 (s->ndirty == 0)
+ s->buffer_offset = s->logical_offset;
- 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;
+ /* 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)
+ {
+ 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
- {
- 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;
-}
-
-
-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;
+ s->file_length = s->logical_offset;
+ return nbyte;
}
-
-static try
-fd_seek (unix_stream * s, gfc_offset offset)
+static off_t
+buf_seek (unix_stream * s, off_t offset, int whence)
{
-
- 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)
+ switch (whence)
{
- s->physical_offset = s->logical_offset = offset;
- s->active = 0;
- return SUCCESS;
+ case SEEK_SET:
+ break;
+ case SEEK_CUR:
+ offset += s->logical_offset;
+ break;
+ case SEEK_END:
+ offset += s->file_length;
+ break;
+ default:
+ return -1;
}
-
- 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)
-{
- /* 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)
+ if (offset < 0)
{
- if (errno == ESPIPE)
- return SUCCESS;
- else
- return FAILURE;
- }
-
- /* 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
- ))
- {
- /* 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;
+ int r;
- 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;
- }
-
- 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.read = (void *) buf_read;
+ s->st.write = (void *) buf_write;
+ s->st.seek = (void *) buf_seek;
+ s->st.tell = (void *) buf_tell;
+ s->st.trunc = (void *) buf_truncate;
+ s->st.close = (void *) buf_close;
+ s->st.flush = (void *) buf_flush;
- 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->buffer = NULL;
+ s->buffer = get_mem (BUFFER_SIZE);
+ return 0;
}
-
-
/*********************************************************************
memory stream functions - These are used for internal files
@@ -907,33 +549,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)
@@ -950,25 +592,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;
}
@@ -976,84 +613,90 @@ mem_read (int_stream * s, void * buf, si
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;
+}
/*********************************************************************
@@ -1066,7 +709,7 @@ mem_sfree (int_stream * s __attribute__
void
empty_internal_buffer(stream *strm)
{
- int_stream * s = (int_stream *) strm;
+ unix_stream * s = (unix_stream *) strm;
memset(s->buffer, ' ', s->file_length);
}
@@ -1075,10 +718,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;
@@ -1086,14 +729,13 @@ open_internal (char *base, int length, g
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.tell = (void *) mem_tell;
s->st.trunc = (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;
}
@@ -1128,7 +770,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;
}
@@ -1412,8 +1061,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;
}
@@ -1431,8 +1078,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;
}
@@ -1663,7 +1308,7 @@ flush_all_units_1 (gfc_unit *u, int min_
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;
@@ -1693,7 +1338,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);
@@ -1710,40 +1355,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. */
@@ -1949,16 +1560,15 @@ inquire_readwrite (const char *string, i
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;
}
@@ -1983,12 +1593,6 @@ is_special (stream *s)
}
-try
-flush (stream *s)
-{
- return fd_flush( (unix_stream *) s);
-}
-
int
stream_isatty (stream *s)
{
@@ -2005,12 +1609,6 @@ stream_ttyname (stream *s __attribute__
#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.
Index: io/transfer.c
===================================================================
--- io/transfer.c (revision 147820)
+++ io/transfer.c (working copy)
@@ -32,6 +32,7 @@ see the files COPYING3 and COPYING.RUNTI
#include <string.h>
#include <assert.h>
#include <stdlib.h>
+#include <errno.h>
/* Calling conventions: Data transfer statements are unlike other
@@ -178,60 +179,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;
-
- if (*length > SCRATCH_SIZE)
- dtp->u.p.line_buffer = get_mem (*length);
- p = base = dtp->u.p.line_buffer;
+ int n, lorig, memread, seen_comma;
+
+ /* 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. */
@@ -240,23 +239,14 @@ read_sf (st_parameter_dt *dtp, int *leng
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,
@@ -270,7 +260,6 @@ read_sf (st_parameter_dt *dtp, int *leng
}
*length = n;
- dtp->u.p.sf_seen_eor = (crlf ? 2 : 1);
break;
}
/* Short circuit the read if a comma is found during numeric input.
@@ -279,6 +268,7 @@ read_sf (st_parameter_dt *dtp, int *leng
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;
@@ -286,16 +276,31 @@ read_sf (st_parameter_dt *dtp, int *leng
}
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;
}
@@ -311,12 +316,11 @@ read_sf (st_parameter_dt *dtp, int *leng
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))
{
@@ -333,15 +337,14 @@ read_block_form (st_parameter_dt *dtp, v
{
/* 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;
@@ -352,42 +355,36 @@ read_block_form (st_parameter_dt *dtp, v
(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;
}
@@ -395,20 +392,19 @@ read_block_form (st_parameter_dt *dtp, v
unformatted files. */
static void
-read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
+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,
+ nbytes);
+ if (unlikely (have_read_record < 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return;
@@ -416,52 +412,48 @@ read_block_direct (st_parameter_dt *dtp,
dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record;
- if (unlikely (to_read_record != have_read_record))
+ if (unlikely ((ssize_t) nbytes != have_read_record))
{
/* 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);
- return;
+ hit_eof (dtp);
}
return;
}
if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
{
- if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
+ if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)
{
short_record = 1;
- to_read_record = (size_t) dtp->u.p.current_unit->bytes_left;
- *nbytes = to_read_record;
+ to_read_record = dtp->u.p.current_unit->bytes_left;
+ nbytes = to_read_record;
}
-
else
{
short_record = 0;
- to_read_record = *nbytes;
+ to_read_record = 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. */
- *nbytes = to_read_record;
return;
}
if (unlikely (short_record))
{
generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
- return;
}
return;
}
@@ -470,23 +462,17 @@ read_block_direct (st_parameter_dt *dtp,
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))
+ && ((gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left))
{
- to_read_record = (size_t) dtp->u.p.current_unit->bytes_left;
+ to_read_record = dtp->u.p.current_unit->bytes_left;
short_record = 1;
}
else
{
- to_read_record = *nbytes;
+ to_read_record = nbytes;
short_record = 0;
}
have_read_record = 0;
@@ -496,7 +482,7 @@ read_block_direct (st_parameter_dt *dtp,
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 = dtp->u.p.current_unit->bytes_left_subrecord;
to_read_record -= to_read_subrecord;
}
else
@@ -507,9 +493,9 @@ read_block_direct (st_parameter_dt *dtp,
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;
@@ -524,7 +510,6 @@ read_block_direct (st_parameter_dt *dtp,
structure has been corrupted, or the trailing record
marker would still be present. */
- *nbytes = have_read_record;
generate_error (&dtp->common, LIBERROR_CORRUPT_FILE, NULL);
return;
}
@@ -598,7 +583,7 @@ write_block (st_parameter_dt *dtp, int l
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)
{
@@ -636,20 +621,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;
}
@@ -667,14 +654,15 @@ write_buf (st_parameter_dt *dtp, void *b
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;
}
@@ -704,8 +692,9 @@ write_buf (st_parameter_dt *dtp, void *b
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;
@@ -737,20 +726,18 @@ static void
unformatted_read (st_parameter_dt *dtp, bt type,
void *dest, int kind, size_t size, size_t nelems)
{
- size_t i, sz;
-
if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
|| kind == 1)
{
- sz = size * nelems;
if (type == BT_CHARACTER)
- sz *= GFC_SIZE_OF_CHAR_KIND(kind);
- read_block_direct (dtp, dest, &sz);
+ size *= GFC_SIZE_OF_CHAR_KIND(kind);
+ read_block_direct (dtp, dest, size * nelems);
}
else
{
char buffer[16];
char *p;
+ size_t i;
p = dest;
@@ -773,7 +760,7 @@ unformatted_read (st_parameter_dt *dtp,
for (i = 0; i < nelems; i++)
{
- read_block_direct (dtp, buffer, &size);
+ read_block_direct (dtp, buffer, size);
reverse_memcpy (p, buffer, size);
p += size;
}
@@ -915,19 +902,18 @@ require_type (st_parameter_dt *dtp, bt e
}
-/* 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;
@@ -954,7 +940,347 @@ formatted_transfer_scalar (st_parameter_
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))
+ sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
+ else
+ fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
+ dtp->u.p.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 (;;)
{
@@ -1003,9 +1329,9 @@ formatted_transfer_scalar (st_parameter_
if (dtp->u.p.skips < 0)
{
if (is_internal_unit (dtp))
- move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
+ sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
else
- fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips);
+ 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;
@@ -1024,57 +1350,34 @@ formatted_transfer_scalar (st_parameter_
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:
@@ -1084,31 +1387,16 @@ formatted_transfer_scalar (st_parameter_
/* 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:
@@ -1116,12 +1404,7 @@ formatted_transfer_scalar (st_parameter_
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:
@@ -1129,11 +1412,7 @@ formatted_transfer_scalar (st_parameter_
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:
@@ -1141,12 +1420,7 @@ formatted_transfer_scalar (st_parameter_
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:
@@ -1154,12 +1428,7 @@ formatted_transfer_scalar (st_parameter_
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:
@@ -1167,41 +1436,14 @@ formatted_transfer_scalar (st_parameter_
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;
@@ -1216,25 +1458,18 @@ formatted_transfer_scalar (st_parameter_
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;
@@ -1246,21 +1481,15 @@ formatted_transfer_scalar (st_parameter_
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:
@@ -1282,12 +1511,7 @@ formatted_transfer_scalar (st_parameter_
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
@@ -1300,43 +1524,6 @@ formatted_transfer_scalar (st_parameter_
+ 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:
@@ -1404,30 +1591,16 @@ formatted_transfer_scalar (st_parameter_
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;
@@ -1439,6 +1612,7 @@ formatted_transfer_scalar (st_parameter_
unget_format (dtp, f);
}
+
static void
formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
size_t size, size_t nelems)
@@ -1449,16 +1623,27 @@ formatted_transfer (st_parameter_dt *dtp
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. */
@@ -1652,34 +1837,28 @@ transfer_array (st_parameter_dt *dtp, gf
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;
@@ -1745,7 +1924,7 @@ us_read (st_parameter_dt *dtp, int conti
static void
us_write (st_parameter_dt *dtp, int continued)
{
- size_t nbytes;
+ ssize_t nbytes;
gfc_offset dummy;
dummy = 0;
@@ -1755,7 +1934,7 @@ us_write (st_parameter_dt *dtp, int cont
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
@@ -1957,7 +2136,7 @@ data_transfer_init (st_parameter_dt *dtp
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)
@@ -2106,65 +2285,70 @@ data_transfer_init (st_parameter_dt *dtp
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);
+ 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)
@@ -2183,15 +2367,10 @@ data_transfer_init (st_parameter_dt *dtp
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. */
@@ -2206,37 +2385,28 @@ data_transfer_init (st_parameter_dt *dtp
/* 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);
@@ -2387,11 +2557,10 @@ next_array_record (st_parameter_dt *dtp,
position. */
static void
-skip_record (st_parameter_dt *dtp, size_t bytes)
+skip_record (st_parameter_dt *dtp, ssize_t bytes)
{
- gfc_offset new;
- size_t rlength;
- static const size_t MAX_READ = 4096;
+ ssize_t rlength, readb;
+ static const ssize_t MAX_READ = 4096;
char p[MAX_READ];
dtp->u.p.current_unit->bytes_left_subrecord += bytes;
@@ -2400,12 +2569,10 @@ skip_record (st_parameter_dt *dtp, size_
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
@@ -2413,16 +2580,17 @@ skip_record (st_parameter_dt *dtp, size_
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 < dtp->u.p.current_unit->bytes_left_subrecord) ?
+ MAX_READ : 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;
}
}
@@ -2470,8 +2638,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))
{
@@ -2491,11 +2659,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;
}
@@ -2510,7 +2679,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;
@@ -2522,10 +2691,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;
@@ -2535,42 +2703,37 @@ next_record_r (st_parameter_dt *dtp)
}
break;
}
- else do
+ else
{
- if (sread (dtp->u.p.current_unit->s, &p, &length) != 0)
- {
- generate_error (&dtp->common, LIBERROR_OS, NULL);
- break;
- }
-
- if (length == 0)
+ do
{
- 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;
@@ -2590,12 +2753,12 @@ write_us_marker (st_parameter_dt *dtp, c
{
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:
@@ -2610,13 +2773,13 @@ write_us_marker (st_parameter_dt *dtp, c
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:
@@ -2633,13 +2796,11 @@ write_us_marker (st_parameter_dt *dtp, c
static void
next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
{
- gfc_offset c, m, m_write;
- size_t record_marker;
+ gfc_offset m, m_write, record_marker;
/* 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);
/* Write the length tail. If we finish a record containing
subrecords, we write out the negative length. */
@@ -2649,7 +2810,7 @@ next_record_w_unf (st_parameter_dt *dtp,
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)
@@ -2660,8 +2821,8 @@ next_record_w_unf (st_parameter_dt *dtp,
/* 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, - m - 2 * record_marker,
+ SEEK_CUR) < 0))
goto io_error;
if (next_subrecord)
@@ -2669,13 +2830,13 @@ next_record_w_unf (st_parameter_dt *dtp,
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, m + record_marker,
+ SEEK_CUR) < 0))
goto io_error;
return;
@@ -2686,6 +2847,35 @@ next_record_w_unf (st_parameter_dt *dtp,
}
+
+/* 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
@@ -2694,9 +2884,6 @@ next_record_w (st_parameter_dt *dtp, int
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;
@@ -2711,8 +2898,11 @@ next_record_w (st_parameter_dt *dtp, int
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;
@@ -2721,7 +2911,7 @@ next_record_w (st_parameter_dt *dtp, int
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;
@@ -2752,8 +2942,7 @@ next_record_w (st_parameter_dt *dtp, int
{
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;
@@ -2761,7 +2950,7 @@ next_record_w (st_parameter_dt *dtp, int
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;
@@ -2777,7 +2966,7 @@ next_record_w (st_parameter_dt *dtp, int
/* 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;
@@ -2800,8 +2989,7 @@ next_record_w (st_parameter_dt *dtp, int
{
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;
@@ -2812,7 +3000,7 @@ next_record_w (st_parameter_dt *dtp, int
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;
@@ -2821,23 +3009,27 @@ next_record_w (st_parameter_dt *dtp, int
}
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);
}
}
@@ -2875,7 +3067,7 @@ next_record (st_parameter_dt *dtp, int d
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) /
@@ -2887,6 +3079,8 @@ next_record (st_parameter_dt *dtp, int d
if (!done)
pre_position (dtp);
+
+ fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
}
@@ -2935,7 +3129,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;
}
@@ -2948,6 +3141,7 @@ finalize_transfer (st_parameter_dt *dtp)
if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
&& dtp->u.p.advance_status != ADVANCE_NO)
next_record (dtp, 1);
+
return;
}
@@ -2955,9 +3149,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;
}
@@ -2969,15 +3162,16 @@ 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);
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
@@ -2990,7 +3184,7 @@ iolength_transfer (st_parameter_dt *dtp,
size_t size, size_t nelems)
{
if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
- *dtp->iolength += (GFC_IO_INT) size * nelems;
+ *dtp->iolength += (GFC_IO_INT) (size * nelems);
}
@@ -3034,8 +3228,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 ();
}
@@ -3051,29 +3243,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 *);
@@ -3083,10 +3252,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);
@@ -3129,19 +3297,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);
@@ -3255,3 +3420,46 @@ void reverse_memcpy (void *dest, const v
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;
+ }
+}
Index: io/intrinsics.c
===================================================================
--- io/intrinsics.c (revision 147820)
+++ io/intrinsics.c (working copy)
@@ -41,21 +41,26 @@ int
PREFIX(fgetc) (const int * unit, char * c, gfc_charlen_type c_len)
{
int ret;
- size_t s;
gfc_unit * u = find_unit (*unit);
if (u == NULL)
return -1;
- s = 1;
+ fbuf_reset (u);
+ if (u->mode == WRITING)
+ {
+ sflush (u->s);
+ u->mode = READING;
+ }
+
memset (c, ' ', c_len);
- ret = sread (u->s, c, &s);
+ ret = sread (u->s, c, 1);
unlock_unit (u);
- if (ret != 0)
+ if (ret < 0)
return ret;
- if (s != 1)
+ if (ret != 1)
return -1;
else
return 0;
@@ -114,17 +119,24 @@ 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);
+ fbuf_reset (u);
+ if (u->mode == READING)
+ {
+ sflush (u->s);
+ u->mode = WRITING;
+ }
+
+ s = swrite (u->s, c, 1);
unlock_unit (u);
- return ret;
+ if (s < 0)
+ return -1;
+ return 0;
}
@@ -191,7 +203,7 @@ flush_i4 (GFC_INTEGER_4 *unit)
us = find_unit (*unit);
if (us != NULL)
{
- flush (us->s);
+ sflush (us->s);
unlock_unit (us);
}
}
@@ -214,7 +226,7 @@ flush_i8 (GFC_INTEGER_8 *unit)
us = find_unit (*unit);
if (us != NULL)
{
- flush (us->s);
+ sflush (us->s);
unlock_unit (us);
}
}
@@ -229,22 +241,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);
}
@@ -261,7 +268,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;
}
@@ -277,7 +284,7 @@ PREFIX(ftell) (int * unit)
*offset = -1; \
else \
{ \
- *offset = stream_offset (u->s); \
+ *offset = stell (u->s); \
unlock_unit (u); \
} \
}
Index: io/format.c
===================================================================
--- io/format.c (revision 147820)
+++ io/format.c (working copy)
@@ -31,6 +31,7 @@ see the files COPYING3 and COPYING.RUNTI
#include "io.h"
#include <ctype.h>
#include <string.h>
+#include <stdbool.h>
#define FARRAY_SIZE 64
@@ -58,7 +59,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",
@@ -70,6 +71,129 @@ static const char posint_required[] = "P
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;
+ gfc_charlen_type key_len;
+ uint32_t hash = 0;
+ gfc_charlen_type 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. */
@@ -85,7 +209,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);
@@ -136,10 +261,10 @@ get_fnode (format_data *fmt, fnode **hea
/* 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;
@@ -151,7 +276,7 @@ free_format_data (st_parameter_dt *dtp)
}
free_mem (fmt);
- dtp->u.p.fmt = NULL;
+ fmt = NULL;
}
@@ -179,6 +304,14 @@ format_lex (format_data *fmt)
switch (c)
{
+ case '(':
+ token = FMT_LPAREN;
+ break;
+
+ case ')':
+ token = FMT_RPAREN;
+ break;
+
case '-':
negative_flag = 1;
/* Fall Through */
@@ -271,14 +404,6 @@ format_lex (format_data *fmt)
break;
- case '(':
- token = FMT_LPAREN;
- break;
-
- case ')':
- token = FMT_RPAREN;
- break;
-
case 'X':
token = FMT_X;
break;
@@ -450,8 +575,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:
@@ -562,6 +689,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:
@@ -587,6 +715,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;
@@ -684,6 +813,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;
}
}
@@ -994,6 +1124,33 @@ format_error (st_parameter_dt *dtp, cons
}
+/* 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
@@ -1001,6 +1158,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;
@@ -1032,35 +1204,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);
}
Index: io/write.c
===================================================================
--- io/write.c (revision 147820)
+++ io/write.c (working copy)
@@ -108,7 +108,7 @@ write_utf8_char4 (st_parameter_dt *dtp,
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. */
@@ -597,7 +597,7 @@ write_decimal (st_parameter_dt *dtp, con
n = -n;
nsign = sign == S_NONE ? 0 : 1;
- /* conv calls gfc_itoa which sets the negative sign needed
+ /* conv calls itoa which sets the negative sign needed
by write_integer. The sign '+' or '-' is set below based on sign
calculated above, so we just point past the sign in the string
before proceeding to avoid double signs in corner cases.
@@ -707,6 +707,48 @@ btoa (GFC_UINTEGER_LARGEST n, char *buff
}
+/* gfc_itoa()-- Integer to decimal conversion.
+ The itoa function is a widespread non-standard extension to standard
+ C, often declared in <stdlib.h>. Even though the itoa defined here
+ is a static function we take care not to conflict with any prior
+ non-static declaration. Hence the 'gfc_' prefix, which is normally
+ reserved for functions with external linkage. */
+
+static const char *
+gfc_itoa (GFC_INTEGER_LARGEST n, char *buffer, size_t len)
+{
+ int negative;
+ char *p;
+ GFC_UINTEGER_LARGEST t;
+
+ assert (len >= GFC_ITOA_BUF_SIZE);
+
+ if (n == 0)
+ return "0";
+
+ negative = 0;
+ t = n;
+ if (n < 0)
+ {
+ negative = 1;
+ t = -n; /*must use unsigned to protect from overflow*/
+ }
+
+ p = buffer + GFC_ITOA_BUF_SIZE - 1;
+ *p = '\0';
+
+ while (t != 0)
+ {
+ *--p = '0' + (t % 10);
+ t /= 10;
+ }
+
+ if (negative)
+ *--p = '-';
+ return p;
+}
+
+
void
write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
@@ -730,7 +772,7 @@ write_o (st_parameter_dt *dtp, const fno
void
write_z (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
- write_int (dtp, f, p, len, xtoa);
+ write_int (dtp, f, p, len, gfc_xtoa);
}
@@ -779,8 +821,7 @@ write_x (st_parameter_dt *dtp, int len,
p = write_block (dtp, len);
if (p == NULL)
return;
-
- if (nspaces > 0)
+ if (nspaces > 0 && len - nspaces >= 0)
memset (&p[len - nspaces], ' ', nspaces);
}
@@ -1168,7 +1209,7 @@ namelist_write_newline (st_parameter_dt
/* 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;
@@ -1189,13 +1230,13 @@ nml_write_obj (st_parameter_dt *dtp, nam
int rep_ctr;
int num;
int nml_carry;
- index_type len;
+ int len;
index_type obj_size;
index_type nelem;
- index_type dim_i;
- index_type clen;
+ size_t dim_i;
+ size_t clen;
index_type elem_ctr;
- index_type obj_name_len;
+ size_t obj_name_len;
void * p ;
char cup;
char * obj_name;
@@ -1225,14 +1266,16 @@ nml_write_obj (st_parameter_dt *dtp, nam
len = 0;
if (base)
{
- len =strlen (base->var_name);
- for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++)
+ len = strlen (base->var_name);
+ base_name_len = strlen (base_name);
+ for (dim_i = 0; dim_i < base_name_len; dim_i++)
{
cup = toupper (base_name[dim_i]);
write_character (dtp, &cup, 1, 1);
}
}
- for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++)
+ clen = strlen (obj->var_name);
+ for (dim_i = len; dim_i < clen; dim_i++)
{
cup = toupper (obj->var_name[dim_i]);
write_character (dtp, &cup, 1, 1);
@@ -1271,7 +1314,7 @@ nml_write_obj (st_parameter_dt *dtp, nam
/* Set the index vector and count the number of elements. */
nelem = 1;
- for (dim_i=0; dim_i < obj->var_rank; dim_i++)
+ for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
{
obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound);
@@ -1374,7 +1417,7 @@ nml_write_obj (st_parameter_dt *dtp, nam
/* Append the qualifier. */
tot_len = base_name_len + clen;
- for (dim_i = 0; dim_i < obj->var_rank; dim_i++)
+ for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
{
if (!dim_i)
{
@@ -1383,7 +1426,7 @@ nml_write_obj (st_parameter_dt *dtp, nam
}
sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx);
tot_len += strlen (ext_name + tot_len);
- ext_name[tot_len] = (dim_i == obj->var_rank - 1) ? ')' : ',';
+ ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';
tot_len++;
}
@@ -1437,11 +1480,11 @@ nml_write_obj (st_parameter_dt *dtp, nam
obj_loop:
nml_carry = 1;
- for (dim_i = 0; nml_carry && (dim_i < obj->var_rank); dim_i++)
+ for (dim_i = 0; nml_carry && (dim_i < (size_t) obj->var_rank); dim_i++)
{
obj->ls[dim_i].idx += nml_carry ;
nml_carry = 0;
- if (obj->ls[dim_i].idx > (ssize_t)obj->dim[dim_i].ubound)
+ if (obj->ls[dim_i].idx > (index_type) obj->dim[dim_i].ubound)
{
obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
nml_carry = 1;
Index: io/write_float.def
===================================================================
--- io/write_float.def (revision 147820)
+++ io/write_float.def (working copy)
@@ -603,7 +603,7 @@ output_float_FMT_G_ ## x (st_parameter_d
int d = f->u.real.d;\
int w = f->u.real.w;\
fnode *newf;\
- GFC_REAL_ ## x exp_d;\
+ GFC_REAL_ ## x rexp_d;\
int low, high, mid;\
int ubound, lbound;\
char *p;\
@@ -612,8 +612,8 @@ output_float_FMT_G_ ## x (st_parameter_d
save_scale_factor = dtp->u.p.scale_factor;\
newf = (fnode *) get_mem (sizeof (fnode));\
\
- exp_d = calculate_exp_ ## x (d);\
- if ((m > 0.0 && m < 0.1 - 0.05 / exp_d) || (m >= exp_d - 0.5 ) ||\
+ rexp_d = calculate_exp_ ## x (-d);\
+ if ((m > 0.0 && m < 0.1 - 0.05 * rexp_d) || (rexp_d * (m + 0.5) >= 1.0) ||\
((m == 0.0) && !(compile_options.allow_std & GFC_STD_F2003)))\
{ \
newf->format = FMT_E;\
@@ -635,8 +635,7 @@ output_float_FMT_G_ ## x (st_parameter_d
GFC_REAL_ ## x temp;\
mid = (low + high) / 2;\
\
- temp = (calculate_exp_ ## x (mid) - \
- 5 * calculate_exp_ ## x (mid - d - 1)) / 10;\
+ temp = (calculate_exp_ ## x (mid - 1) * (1 - 0.5 * rexp_d));\
\
if (m < temp)\
{ \