Backport PRs 22423, 25561, 37754, 38654, 38668, 39664, 39665, 39667, 39782
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. From-SVN: r147887
This commit is contained in:
parent
6ab070dd0b
commit
e4995489fb
|
@ -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
|
||||
|
|
|
@ -28,8 +28,11 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#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;
|
||||
}
|
||||
|
|
|
@ -41,17 +41,17 @@ formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
|
|||
{
|
||||
gfc_offset base;
|
||||
char p[READ_CHUNK];
|
||||
size_t n;
|
||||
ssize_t n;
|
||||
|
||||
base = file_position (u->s) - 1;
|
||||
base = stell (u->s) - 1;
|
||||
|
||||
do
|
||||
{
|
||||
n = (base < READ_CHUNK) ? base : READ_CHUNK;
|
||||
base -= n;
|
||||
if (sseek (u->s, base) == FAILURE)
|
||||
if (sseek (u->s, base, SEEK_SET) < 0)
|
||||
goto io_error;
|
||||
if (sread (u->s, p, &n) != 0)
|
||||
if (sread (u->s, p, n) != n)
|
||||
goto io_error;
|
||||
|
||||
/* We have moved backwards from the current position, it should
|
||||
|
@ -76,7 +76,7 @@ formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
|
|||
|
||||
/* base is the new pointer. Seek to it exactly. */
|
||||
done:
|
||||
if (sseek (u->s, base) == FAILURE)
|
||||
if (sseek (u->s, base, SEEK_SET) < 0)
|
||||
goto io_error;
|
||||
u->last_record--;
|
||||
u->endfile = NO_ENDFILE;
|
||||
|
@ -95,10 +95,10 @@ formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
|
|||
static void
|
||||
unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
|
||||
{
|
||||
gfc_offset m, new;
|
||||
gfc_offset m, slen;
|
||||
GFC_INTEGER_4 m4;
|
||||
GFC_INTEGER_8 m8;
|
||||
size_t length;
|
||||
ssize_t length;
|
||||
int continued;
|
||||
char p[sizeof (GFC_INTEGER_8)];
|
||||
|
||||
|
@ -109,9 +109,10 @@ unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
|
|||
|
||||
do
|
||||
{
|
||||
if (sseek (u->s, file_position (u->s) - length) == FAILURE)
|
||||
slen = - (gfc_offset) length;
|
||||
if (sseek (u->s, slen, SEEK_CUR) < 0)
|
||||
goto io_error;
|
||||
if (sread (u->s, p, &length) != 0)
|
||||
if (sread (u->s, p, length) != length)
|
||||
goto io_error;
|
||||
|
||||
/* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
|
||||
|
@ -159,10 +160,7 @@ unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
|
|||
if (continued)
|
||||
m = -m;
|
||||
|
||||
if ((new = file_position (u->s) - m - 2*length) < 0)
|
||||
new = 0;
|
||||
|
||||
if (sseek (u->s, new) == FAILURE)
|
||||
if (sseek (u->s, -m -2 * length, SEEK_CUR) < 0)
|
||||
goto io_error;
|
||||
} while (continued);
|
||||
|
||||
|
@ -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
|
||||
|
|
|
@ -31,6 +31,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#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[] = "Positive width required in format",
|
|||
reversion_error[] = "Exhausted data descriptors in format",
|
||||
zero_width[] = "Zero width in format descriptor";
|
||||
|
||||
/* The following routines support caching format data from parsed format strings
|
||||
into a hash table. This avoids repeatedly parsing duplicate format strings
|
||||
or format strings in I/O statements that are repeated in loops. */
|
||||
|
||||
|
||||
/* Traverse the table and free all data. */
|
||||
|
||||
void
|
||||
free_format_hash_table (gfc_unit *u)
|
||||
{
|
||||
size_t i;
|
||||
|
||||
/* free_format_data handles any NULL pointers. */
|
||||
for (i = 0; i < FORMAT_HASH_SIZE; i++)
|
||||
{
|
||||
if (u->format_hash_table[i].hashed_fmt != NULL)
|
||||
free_format_data (u->format_hash_table[i].hashed_fmt);
|
||||
u->format_hash_table[i].hashed_fmt = NULL;
|
||||
}
|
||||
}
|
||||
|
||||
/* Traverse the format_data structure and reset the fnode counters. */
|
||||
|
||||
static void
|
||||
reset_node (fnode *fn)
|
||||
{
|
||||
fnode *f;
|
||||
|
||||
fn->count = 0;
|
||||
fn->current = NULL;
|
||||
|
||||
if (fn->format != FMT_LPAREN)
|
||||
return;
|
||||
|
||||
for (f = fn->u.child; f; f = f->next)
|
||||
{
|
||||
if (f->format == FMT_RPAREN)
|
||||
break;
|
||||
reset_node (f);
|
||||
}
|
||||
}
|
||||
|
||||
static void
|
||||
reset_fnode_counters (st_parameter_dt *dtp)
|
||||
{
|
||||
fnode *f;
|
||||
format_data *fmt;
|
||||
|
||||
fmt = dtp->u.p.fmt;
|
||||
|
||||
/* Clear this pointer at the head so things start at the right place. */
|
||||
fmt->array.array[0].current = NULL;
|
||||
|
||||
for (f = fmt->last->array[0].u.child; f; f = f->next)
|
||||
reset_node (f);
|
||||
}
|
||||
|
||||
|
||||
/* A simple hashing function to generate an index into the hash table. */
|
||||
|
||||
static inline
|
||||
uint32_t format_hash (st_parameter_dt *dtp)
|
||||
{
|
||||
char *key;
|
||||
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 **head, fnode **tail, format_token t)
|
|||
/* free_format_data()-- Free all allocated format data. */
|
||||
|
||||
void
|
||||
free_format_data (st_parameter_dt *dtp)
|
||||
free_format_data (format_data *fmt)
|
||||
{
|
||||
fnode_array *fa, *fa_next;
|
||||
format_data *fmt = dtp->u.p.fmt;
|
||||
|
||||
|
||||
if (fmt == NULL)
|
||||
return;
|
||||
|
@ -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, const fnode *f, const char *message)
|
|||
}
|
||||
|
||||
|
||||
/* revert()-- Do reversion of the format. Control reverts to the left
|
||||
* parenthesis that matches the rightmost right parenthesis. From our
|
||||
* tree structure, we are looking for the rightmost parenthesis node
|
||||
* at the second level, the first level always being a single
|
||||
* parenthesis node. If this node doesn't exit, we use the top
|
||||
* level. */
|
||||
|
||||
static void
|
||||
revert (st_parameter_dt *dtp)
|
||||
{
|
||||
fnode *f, *r;
|
||||
format_data *fmt = dtp->u.p.fmt;
|
||||
|
||||
dtp->u.p.reversion_flag = 1;
|
||||
|
||||
r = NULL;
|
||||
|
||||
for (f = fmt->array.array[0].u.child; f; f = f->next)
|
||||
if (f->format == FMT_LPAREN)
|
||||
r = f;
|
||||
|
||||
/* If r is NULL because no node was found, the whole tree will be used */
|
||||
|
||||
fmt->array.array[0].current = r;
|
||||
fmt->array.array[0].count = 0;
|
||||
}
|
||||
|
||||
/* parse_format()-- Parse a format string. */
|
||||
|
||||
void
|
||||
|
@ -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);
|
||||
}
|
||||
|
||||
|
||||
|
|
|
@ -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); \
|
||||
} \
|
||||
}
|
||||
|
|
|
@ -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);
|
||||
}
|
||||
|
||||
/* Macros for doing file I/O given a stream. */
|
||||
static inline ssize_t
|
||||
swrite (stream * s, const void * buf, ssize_t nbyte)
|
||||
{
|
||||
return s->write (s, buf, nbyte);
|
||||
}
|
||||
|
||||
#define sfree(s) ((s)->sfree)(s)
|
||||
#define sclose(s) ((s)->close)(s)
|
||||
static inline off_t
|
||||
sseek (stream * s, off_t offset, int whence)
|
||||
{
|
||||
return s->seek (s, offset, whence);
|
||||
}
|
||||
|
||||
#define salloc_w(s, len) ((s)->alloc_w_at)(s, len)
|
||||
static inline off_t
|
||||
stell (stream * s)
|
||||
{
|
||||
return s->tell (s);
|
||||
}
|
||||
|
||||
#define sseek(s, pos) ((s)->seek)(s, pos)
|
||||
#define struncate(s) ((s)->trunc)(s)
|
||||
#define sread(s, buf, nbytes) ((s)->read)(s, buf, nbytes)
|
||||
#define swrite(s, buf, nbytes) ((s)->write)(s, buf, nbytes)
|
||||
static inline int
|
||||
struncate (stream * s, off_t length)
|
||||
{
|
||||
return s->trunc (s, length);
|
||||
}
|
||||
|
||||
static inline int
|
||||
sflush (stream * s)
|
||||
{
|
||||
return s->flush (s);
|
||||
}
|
||||
|
||||
static inline int
|
||||
sclose (stream * s)
|
||||
{
|
||||
return s->close (s);
|
||||
}
|
||||
|
||||
#define sset(s, c, n) ((s)->set)(s, c, n)
|
||||
|
||||
/* Macros for testing what kinds of I/O we are doing. */
|
||||
|
||||
|
@ -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 (int);
|
|||
internal_proto(size_from_complex_kind);
|
||||
|
||||
/* fbuf.c */
|
||||
extern void fbuf_init (gfc_unit *, size_t);
|
||||
extern void fbuf_init (gfc_unit *, int);
|
||||
internal_proto(fbuf_init);
|
||||
|
||||
extern void fbuf_destroy (gfc_unit *);
|
||||
internal_proto(fbuf_destroy);
|
||||
|
||||
extern void fbuf_reset (gfc_unit *);
|
||||
extern int fbuf_reset (gfc_unit *);
|
||||
internal_proto(fbuf_reset);
|
||||
|
||||
extern char * fbuf_alloc (gfc_unit *, size_t);
|
||||
extern char * fbuf_alloc (gfc_unit *, int);
|
||||
internal_proto(fbuf_alloc);
|
||||
|
||||
extern int fbuf_flush (gfc_unit *, int);
|
||||
extern int fbuf_flush (gfc_unit *, unit_mode);
|
||||
internal_proto(fbuf_flush);
|
||||
|
||||
extern int fbuf_seek (gfc_unit *, gfc_offset);
|
||||
extern int fbuf_seek (gfc_unit *, int, int);
|
||||
internal_proto(fbuf_seek);
|
||||
|
||||
extern char * fbuf_read (gfc_unit *, int *);
|
||||
internal_proto(fbuf_read);
|
||||
|
||||
/* Never call this function, only use fbuf_getc(). */
|
||||
extern int fbuf_getc_refill (gfc_unit *);
|
||||
internal_proto(fbuf_getc_refill);
|
||||
|
||||
static inline int
|
||||
fbuf_getc (gfc_unit * u)
|
||||
{
|
||||
if (u->fbuf->pos < u->fbuf->act)
|
||||
return (unsigned char) u->fbuf->buf[u->fbuf->pos++];
|
||||
return fbuf_getc_refill (u);
|
||||
}
|
||||
|
||||
/* lock.c */
|
||||
extern void free_ionml (st_parameter_dt *);
|
||||
internal_proto(free_ionml);
|
||||
|
|
|
@ -28,6 +28,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
|
||||
#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 *buffer, int length)
|
|||
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 kind, size_t size)
|
|||
}
|
||||
|
||||
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 length)
|
|||
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_dt *dtp, volatile bt type, void *p,
|
|||
dtp->u.p.input_complete = 0;
|
||||
dtp->u.p.repeat_count = 1;
|
||||
dtp->u.p.at_eol = 0;
|
||||
|
||||
|
||||
c = eat_spaces (dtp);
|
||||
if (is_separator (c))
|
||||
{
|
||||
|
@ -1721,6 +1724,9 @@ list_formatted_read_scalar (st_parameter_dt *dtp, volatile bt type, void *p,
|
|||
return;
|
||||
goto set_value;
|
||||
}
|
||||
|
||||
if (dtp->u.p.input_complete)
|
||||
goto cleanup;
|
||||
|
||||
if (dtp->u.p.input_complete)
|
||||
goto cleanup;
|
||||
|
@ -1751,10 +1757,16 @@ list_formatted_read_scalar (st_parameter_dt *dtp, volatile bt type, void *p,
|
|||
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_dt *dtp, volatile bt type, void *p,
|
|||
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, namelist_info * nl, index_type offset,
|
|||
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, namelist_info * nl, index_type offset,
|
|||
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);
|
||||
}
|
||||
}
|
||||
|
|
|
@ -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_unit * u, unit_flags * flags)
|
|||
break;
|
||||
|
||||
case POSITION_REWIND:
|
||||
if (sseek (u->s, 0) == FAILURE)
|
||||
if (sseek (u->s, 0, SEEK_SET) != 0)
|
||||
goto seek_error;
|
||||
|
||||
u->current_record = 0;
|
||||
|
@ -276,7 +276,7 @@ edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
|
|||
break;
|
||||
|
||||
case POSITION_APPEND:
|
||||
if (sseek (u->s, file_length (u->s)) == FAILURE)
|
||||
if (sseek (u->s, 0, SEEK_END) < 0)
|
||||
goto seek_error;
|
||||
|
||||
if (flags->access != ACCESS_STREAM)
|
||||
|
@ -552,7 +552,7 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
|
|||
|
||||
if (flags->position == POSITION_APPEND)
|
||||
{
|
||||
if (sseek (u->s, file_length (u->s)) == FAILURE)
|
||||
if (sseek (u->s, 0, SEEK_END) < 0)
|
||||
generate_error (&opp->common, LIBERROR_OS, NULL);
|
||||
u->endfile = AT_ENDFILE;
|
||||
}
|
||||
|
@ -606,7 +606,8 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
|
|||
{
|
||||
u->maxrec = max_offset;
|
||||
u->recl = 1;
|
||||
u->strm_pos = file_position (u->s) + 1;
|
||||
u->bytes_left = 1;
|
||||
u->strm_pos = stell (u->s) + 1;
|
||||
}
|
||||
|
||||
memmove (u->file, opp->file, opp->file_len);
|
||||
|
@ -622,7 +623,7 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
|
|||
if (flags->status == STATUS_SCRATCH && opp->file != NULL)
|
||||
free_mem (opp->file);
|
||||
|
||||
if (flags->form == FORM_FORMATTED && (flags->action != ACTION_READ))
|
||||
if (flags->form == FORM_FORMATTED)
|
||||
{
|
||||
if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
|
||||
fbuf_init (u, u->recl);
|
||||
|
@ -676,7 +677,7 @@ already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
|
|||
}
|
||||
#endif
|
||||
|
||||
if (sclose (u->s) == FAILURE)
|
||||
if (sclose (u->s) == -1)
|
||||
{
|
||||
unlock_unit (u);
|
||||
generate_error (&opp->common, LIBERROR_OS,
|
||||
|
|
|
@ -28,6 +28,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|||
#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 *dest, const char *buffer, int length)
|
|||
switch (length)
|
||||
{
|
||||
case 4:
|
||||
{
|
||||
GFC_REAL_4 tmp =
|
||||
*((GFC_REAL_4*) dest) =
|
||||
#if defined(HAVE_STRTOF)
|
||||
strtof (buffer, NULL);
|
||||
strtof (buffer, NULL);
|
||||
#else
|
||||
(GFC_REAL_4) strtod (buffer, NULL);
|
||||
(GFC_REAL_4) strtod (buffer, NULL);
|
||||
#endif
|
||||
memcpy (dest, (void *) &tmp, length);
|
||||
}
|
||||
break;
|
||||
|
||||
case 8:
|
||||
{
|
||||
GFC_REAL_8 tmp = strtod (buffer, NULL);
|
||||
memcpy (dest, (void *) &tmp, length);
|
||||
}
|
||||
*((GFC_REAL_8*) dest) = strtod (buffer, NULL);
|
||||
break;
|
||||
|
||||
#if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
|
||||
case 10:
|
||||
{
|
||||
GFC_REAL_10 tmp = strtold (buffer, NULL);
|
||||
memcpy (dest, (void *) &tmp, length);
|
||||
}
|
||||
*((GFC_REAL_10*) dest) = strtold (buffer, NULL);
|
||||
break;
|
||||
#endif
|
||||
|
||||
#if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD)
|
||||
case 16:
|
||||
{
|
||||
GFC_REAL_16 tmp = strtold (buffer, NULL);
|
||||
memcpy (dest, (void *) &tmp, length);
|
||||
}
|
||||
*((GFC_REAL_16*) dest) = strtold (buffer, NULL);
|
||||
break;
|
||||
#endif
|
||||
|
||||
default:
|
||||
internal_error (&dtp->common, "Unsupported real kind during IO");
|
||||
}
|
||||
|
@ -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 fnode *f, char *dest, int length)
|
|||
}
|
||||
|
||||
|
||||
static inline gfc_char4_t
|
||||
read_utf8 (st_parameter_dt *dtp, size_t *nbytes)
|
||||
static gfc_char4_t
|
||||
read_utf8 (st_parameter_dt *dtp, int *nbytes)
|
||||
{
|
||||
static const uchar masks[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
|
||||
static const uchar patns[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
|
||||
static uchar buffer[6];
|
||||
size_t i, nb, nread;
|
||||
int i, nb, nread;
|
||||
gfc_char4_t c;
|
||||
int status;
|
||||
char *s;
|
||||
|
||||
*nbytes = 1;
|
||||
s = (char *) &buffer[0];
|
||||
status = read_block_form (dtp, s, nbytes);
|
||||
if (status == FAILURE)
|
||||
|
||||
s = read_block_form (dtp, nbytes);
|
||||
if (s == NULL)
|
||||
return 0;
|
||||
|
||||
/* If this is a short read, just return. */
|
||||
if (*nbytes == 0)
|
||||
return 0;
|
||||
|
||||
c = buffer[0];
|
||||
c = (uchar) s[0];
|
||||
if (c < 0x80)
|
||||
return c;
|
||||
|
||||
|
@ -269,9 +262,8 @@ read_utf8 (st_parameter_dt *dtp, size_t *nbytes)
|
|||
c = (c & masks[nb-1]);
|
||||
nread = nb - 1;
|
||||
|
||||
s = (char *) &buffer[1];
|
||||
status = read_block_form (dtp, s, &nread);
|
||||
if (status == FAILURE)
|
||||
s = read_block_form (dtp, &nread);
|
||||
if (s == NULL)
|
||||
return 0;
|
||||
/* Decode the bytes read. */
|
||||
for (i = 1; i < nb; i++)
|
||||
|
@ -304,14 +296,14 @@ read_utf8 (st_parameter_dt *dtp, size_t *nbytes)
|
|||
|
||||
|
||||
static void
|
||||
read_utf8_char1 (st_parameter_dt *dtp, char *p, int len, size_t width)
|
||||
read_utf8_char1 (st_parameter_dt *dtp, char *p, int len, int width)
|
||||
{
|
||||
gfc_char4_t c;
|
||||
char *dest;
|
||||
size_t nbytes;
|
||||
int nbytes;
|
||||
int i, j;
|
||||
|
||||
len = ((int) width < len) ? len : (int) width;
|
||||
len = (width < len) ? len : width;
|
||||
|
||||
dest = (char *) p;
|
||||
|
||||
|
@ -334,21 +326,19 @@ read_utf8_char1 (st_parameter_dt *dtp, char *p, int len, size_t width)
|
|||
}
|
||||
|
||||
static void
|
||||
read_default_char1 (st_parameter_dt *dtp, char *p, int len, size_t width)
|
||||
read_default_char1 (st_parameter_dt *dtp, char *p, int len, int width)
|
||||
{
|
||||
char *s;
|
||||
int m, n, status;
|
||||
int m, n;
|
||||
|
||||
s = gfc_alloca (width);
|
||||
|
||||
status = read_block_form (dtp, s, &width);
|
||||
s = read_block_form (dtp, &width);
|
||||
|
||||
if (status == FAILURE)
|
||||
if (s == NULL)
|
||||
return;
|
||||
if (width > (size_t) len)
|
||||
if (width > len)
|
||||
s += (width - len);
|
||||
|
||||
m = ((int) width > len) ? len : (int) width;
|
||||
m = (width > len) ? len : width;
|
||||
memcpy (p, s, m);
|
||||
|
||||
n = len - width;
|
||||
|
@ -358,13 +348,13 @@ read_default_char1 (st_parameter_dt *dtp, char *p, int len, size_t width)
|
|||
|
||||
|
||||
static void
|
||||
read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, size_t width)
|
||||
read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, int width)
|
||||
{
|
||||
gfc_char4_t *dest;
|
||||
size_t nbytes;
|
||||
int nbytes;
|
||||
int i, j;
|
||||
|
||||
len = ((int) width < len) ? len : (int) width;
|
||||
len = (width < len) ? len : width;
|
||||
|
||||
dest = (gfc_char4_t *) p;
|
||||
|
||||
|
@ -386,19 +376,17 @@ read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, size_t width)
|
|||
|
||||
|
||||
static void
|
||||
read_default_char4 (st_parameter_dt *dtp, char *p, int len, size_t width)
|
||||
read_default_char4 (st_parameter_dt *dtp, char *p, int len, int width)
|
||||
{
|
||||
char *s;
|
||||
gfc_char4_t *dest;
|
||||
int m, n, status;
|
||||
int m, n;
|
||||
|
||||
s = gfc_alloca (width);
|
||||
|
||||
status = read_block_form (dtp, s, &width);
|
||||
s = read_block_form (dtp, &width);
|
||||
|
||||
if (status == FAILURE)
|
||||
if (s == NULL)
|
||||
return;
|
||||
if (width > (size_t) len)
|
||||
if (width > len)
|
||||
s += (width - len);
|
||||
|
||||
m = ((int) width > len) ? len : (int) width;
|
||||
|
@ -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 fnode *f, char *p, int length)
|
|||
void
|
||||
read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, int length)
|
||||
{
|
||||
int wi;
|
||||
size_t w;
|
||||
int w;
|
||||
|
||||
wi = f->u.w;
|
||||
if (wi == -1) /* '(A)' edit descriptor */
|
||||
wi = length;
|
||||
w = wi;
|
||||
w = f->u.w;
|
||||
if (w == -1) /* '(A)' edit descriptor */
|
||||
w = length;
|
||||
|
||||
/* Read in w characters, treating comma as not a separator. */
|
||||
dtp->u.p.sf_read_comma = 0;
|
||||
|
@ -527,18 +513,15 @@ read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
|
|||
GFC_UINTEGER_LARGEST value, maxv, maxv_10;
|
||||
GFC_INTEGER_LARGEST v;
|
||||
int w, negative;
|
||||
size_t wu;
|
||||
char c, *p;
|
||||
|
||||
wu = f->u.w;
|
||||
w = f->u.w;
|
||||
|
||||
p = gfc_alloca (wu);
|
||||
p = read_block_form (dtp, &w);
|
||||
|
||||
if (read_block_form (dtp, p, &wu) == FAILURE)
|
||||
if (p == NULL)
|
||||
return;
|
||||
|
||||
w = wu;
|
||||
|
||||
p = eat_leading_spaces (&w, p);
|
||||
if (w == 0)
|
||||
{
|
||||
|
@ -631,17 +614,14 @@ read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
|
|||
GFC_INTEGER_LARGEST v;
|
||||
int w, negative;
|
||||
char c, *p;
|
||||
size_t wu;
|
||||
|
||||
wu = f->u.w;
|
||||
w = f->u.w;
|
||||
|
||||
p = gfc_alloca (wu);
|
||||
p = read_block_form (dtp, &w);
|
||||
|
||||
if (read_block_form (dtp, p, &wu) == FAILURE)
|
||||
if (p == NULL)
|
||||
return;
|
||||
|
||||
w = wu;
|
||||
|
||||
p = eat_leading_spaces (&w, p);
|
||||
if (w == 0)
|
||||
{
|
||||
|
@ -778,75 +758,83 @@ read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
|
|||
void
|
||||
read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
|
||||
{
|
||||
size_t wu;
|
||||
int w, seen_dp, exponent;
|
||||
int exponent_sign, val_sign;
|
||||
int ndigits;
|
||||
int edigits;
|
||||
int i;
|
||||
char *p, *buffer;
|
||||
char *digits;
|
||||
char scratch[SCRATCH_SIZE];
|
||||
int exponent_sign;
|
||||
const char *p;
|
||||
char *buffer;
|
||||
char *out;
|
||||
int seen_int_digit; /* Seen a digit before the decimal point? */
|
||||
int seen_dec_digit; /* Seen a digit after the decimal point? */
|
||||
|
||||
val_sign = 1;
|
||||
seen_dp = 0;
|
||||
wu = f->u.w;
|
||||
seen_int_digit = 0;
|
||||
seen_dec_digit = 0;
|
||||
exponent_sign = 1;
|
||||
exponent = 0;
|
||||
w = f->u.w;
|
||||
|
||||
p = gfc_alloca (wu);
|
||||
|
||||
if (read_block_form (dtp, p, &wu) == FAILURE)
|
||||
/* Read in the next block. */
|
||||
p = read_block_form (dtp, &w);
|
||||
if (p == NULL)
|
||||
return;
|
||||
|
||||
w = wu;
|
||||
|
||||
p = eat_leading_spaces (&w, p);
|
||||
p = eat_leading_spaces (&w, (char*) p);
|
||||
if (w == 0)
|
||||
goto zero;
|
||||
|
||||
/* Optional sign */
|
||||
/* In this buffer we're going to re-format the number cleanly to be parsed
|
||||
by convert_real in the end; this assures we're using strtod from the
|
||||
C library for parsing and thus probably get the best accuracy possible.
|
||||
This process may add a '+0.0' in front of the number as well as change the
|
||||
exponent because of an implicit decimal point or the like. Thus allocating
|
||||
strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
|
||||
original buffer had should be enough. */
|
||||
buffer = gfc_alloca (w + 11);
|
||||
out = buffer;
|
||||
|
||||
/* Optional sign */
|
||||
if (*p == '-' || *p == '+')
|
||||
{
|
||||
if (*p == '-')
|
||||
val_sign = -1;
|
||||
p++;
|
||||
w--;
|
||||
*(out++) = '-';
|
||||
++p;
|
||||
--w;
|
||||
}
|
||||
|
||||
exponent_sign = 1;
|
||||
p = eat_leading_spaces (&w, p);
|
||||
p = eat_leading_spaces (&w, (char*) p);
|
||||
if (w == 0)
|
||||
goto zero;
|
||||
|
||||
/* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D')
|
||||
is required at this point */
|
||||
|
||||
if (!isdigit (*p) && *p != '.' && *p != ',' && *p != 'd' && *p != 'D'
|
||||
&& *p != 'e' && *p != 'E')
|
||||
goto bad_float;
|
||||
|
||||
/* Remember the position of the first digit. */
|
||||
digits = p;
|
||||
ndigits = 0;
|
||||
|
||||
/* Scan through the string to find the exponent. */
|
||||
/* Process the mantissa string. */
|
||||
while (w > 0)
|
||||
{
|
||||
switch (*p)
|
||||
{
|
||||
case ',':
|
||||
if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA
|
||||
&& *p == ',')
|
||||
*p = '.';
|
||||
else
|
||||
if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA)
|
||||
goto bad_float;
|
||||
/* Fall through */
|
||||
/* Fall through. */
|
||||
case '.':
|
||||
if (seen_dp)
|
||||
goto bad_float;
|
||||
if (!seen_int_digit)
|
||||
*(out++) = '0';
|
||||
*(out++) = '.';
|
||||
seen_dp = 1;
|
||||
/* Fall through */
|
||||
break;
|
||||
|
||||
case ' ':
|
||||
if (dtp->u.p.blank_status == BLANK_ZERO)
|
||||
{
|
||||
*(out++) = '0';
|
||||
goto found_digit;
|
||||
}
|
||||
else if (dtp->u.p.blank_status == BLANK_NULL)
|
||||
break;
|
||||
else
|
||||
/* TODO: Should we check instead that there are only trailing
|
||||
blanks here, as is done below for exponents? */
|
||||
goto done;
|
||||
/* Fall through. */
|
||||
case '0':
|
||||
case '1':
|
||||
case '2':
|
||||
|
@ -857,65 +845,160 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
|
|||
case '7':
|
||||
case '8':
|
||||
case '9':
|
||||
case ' ':
|
||||
ndigits++;
|
||||
p++;
|
||||
w--;
|
||||
*(out++) = *p;
|
||||
found_digit:
|
||||
if (!seen_dp)
|
||||
seen_int_digit = 1;
|
||||
else
|
||||
seen_dec_digit = 1;
|
||||
break;
|
||||
|
||||
case '-':
|
||||
exponent_sign = -1;
|
||||
/* Fall through */
|
||||
|
||||
case '+':
|
||||
p++;
|
||||
w--;
|
||||
goto exp2;
|
||||
goto exponent;
|
||||
|
||||
case 'd':
|
||||
case 'e':
|
||||
case 'D':
|
||||
case 'E':
|
||||
p++;
|
||||
w--;
|
||||
goto exp1;
|
||||
case 'd':
|
||||
case 'D':
|
||||
++p;
|
||||
--w;
|
||||
goto exponent;
|
||||
|
||||
default:
|
||||
goto bad_float;
|
||||
}
|
||||
}
|
||||
|
||||
/* No exponent has been seen, so we use the current scale factor */
|
||||
exponent = -dtp->u.p.scale_factor;
|
||||
++p;
|
||||
--w;
|
||||
}
|
||||
|
||||
/* No exponent has been seen, so we use the current scale factor. */
|
||||
exponent = - dtp->u.p.scale_factor;
|
||||
goto done;
|
||||
|
||||
bad_float:
|
||||
generate_error (&dtp->common, LIBERROR_READ_VALUE,
|
||||
"Bad value during floating point read");
|
||||
next_record (dtp, 1);
|
||||
/* At this point the start of an exponent has been found. */
|
||||
exponent:
|
||||
p = eat_leading_spaces (&w, (char*) p);
|
||||
if (*p == '-' || *p == '+')
|
||||
{
|
||||
if (*p == '-')
|
||||
exponent_sign = -1;
|
||||
++p;
|
||||
--w;
|
||||
}
|
||||
|
||||
/* At this point a digit string is required. We calculate the value
|
||||
of the exponent in order to take account of the scale factor and
|
||||
the d parameter before explict conversion takes place. */
|
||||
|
||||
if (w == 0)
|
||||
goto bad_float;
|
||||
|
||||
if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
|
||||
{
|
||||
while (w > 0 && isdigit (*p))
|
||||
{
|
||||
exponent *= 10;
|
||||
exponent += *p - '0';
|
||||
++p;
|
||||
--w;
|
||||
}
|
||||
|
||||
/* Only allow trailing blanks. */
|
||||
while (w > 0)
|
||||
{
|
||||
if (*p != ' ')
|
||||
goto bad_float;
|
||||
++p;
|
||||
--w;
|
||||
}
|
||||
}
|
||||
else /* BZ or BN status is enabled. */
|
||||
{
|
||||
while (w > 0)
|
||||
{
|
||||
if (*p == ' ')
|
||||
{
|
||||
if (dtp->u.p.blank_status == BLANK_ZERO)
|
||||
exponent *= 10;
|
||||
else
|
||||
assert (dtp->u.p.blank_status == BLANK_NULL);
|
||||
}
|
||||
else if (!isdigit (*p))
|
||||
goto bad_float;
|
||||
else
|
||||
{
|
||||
exponent *= 10;
|
||||
exponent += *p - '0';
|
||||
}
|
||||
|
||||
++p;
|
||||
--w;
|
||||
}
|
||||
}
|
||||
|
||||
exponent *= exponent_sign;
|
||||
|
||||
done:
|
||||
/* Use the precision specified in the format if no decimal point has been
|
||||
seen. */
|
||||
if (!seen_dp)
|
||||
exponent -= f->u.real.d;
|
||||
|
||||
/* Output a trailing '0' after decimal point if not yet found. */
|
||||
if (seen_dp && !seen_dec_digit)
|
||||
*(out++) = '0';
|
||||
|
||||
/* Print out the exponent to finish the reformatted number. Maximum 4
|
||||
digits for the exponent. */
|
||||
if (exponent != 0)
|
||||
{
|
||||
int dig;
|
||||
|
||||
*(out++) = 'e';
|
||||
if (exponent < 0)
|
||||
{
|
||||
*(out++) = '-';
|
||||
exponent = - exponent;
|
||||
}
|
||||
|
||||
assert (exponent < 10000);
|
||||
for (dig = 3; dig >= 0; --dig)
|
||||
{
|
||||
out[dig] = (char) ('0' + exponent % 10);
|
||||
exponent /= 10;
|
||||
}
|
||||
out += 4;
|
||||
}
|
||||
*(out++) = '\0';
|
||||
|
||||
/* Do the actual conversion. */
|
||||
convert_real (dtp, dest, buffer, length);
|
||||
|
||||
return;
|
||||
|
||||
/* The value read is zero */
|
||||
zero:
|
||||
/* The value read is zero. */
|
||||
zero:
|
||||
switch (length)
|
||||
{
|
||||
case 4:
|
||||
*((GFC_REAL_4 *) dest) = 0;
|
||||
*((GFC_REAL_4 *) dest) = 0.0;
|
||||
break;
|
||||
|
||||
case 8:
|
||||
*((GFC_REAL_8 *) dest) = 0;
|
||||
*((GFC_REAL_8 *) dest) = 0.0;
|
||||
break;
|
||||
|
||||
#ifdef HAVE_GFC_REAL_10
|
||||
case 10:
|
||||
*((GFC_REAL_10 *) dest) = 0;
|
||||
*((GFC_REAL_10 *) dest) = 0.0;
|
||||
break;
|
||||
#endif
|
||||
|
||||
#ifdef HAVE_GFC_REAL_16
|
||||
case 16:
|
||||
*((GFC_REAL_16 *) dest) = 0;
|
||||
*((GFC_REAL_16 *) dest) = 0.0;
|
||||
break;
|
||||
#endif
|
||||
|
||||
|
@ -924,140 +1007,11 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
|
|||
}
|
||||
return;
|
||||
|
||||
/* At this point the start of an exponent has been found */
|
||||
exp1:
|
||||
while (w > 0 && *p == ' ')
|
||||
{
|
||||
w--;
|
||||
p++;
|
||||
}
|
||||
|
||||
switch (*p)
|
||||
{
|
||||
case '-':
|
||||
exponent_sign = -1;
|
||||
/* Fall through */
|
||||
|
||||
case '+':
|
||||
p++;
|
||||
w--;
|
||||
break;
|
||||
}
|
||||
|
||||
if (w == 0)
|
||||
goto bad_float;
|
||||
|
||||
/* At this point a digit string is required. We calculate the value
|
||||
of the exponent in order to take account of the scale factor and
|
||||
the d parameter before explict conversion takes place. */
|
||||
exp2:
|
||||
/* Normal processing of exponent */
|
||||
exponent = 0;
|
||||
if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
|
||||
{
|
||||
while (w > 0 && isdigit (*p))
|
||||
{
|
||||
exponent = 10 * exponent + *p - '0';
|
||||
p++;
|
||||
w--;
|
||||
}
|
||||
|
||||
/* Only allow trailing blanks */
|
||||
|
||||
while (w > 0)
|
||||
{
|
||||
if (*p != ' ')
|
||||
goto bad_float;
|
||||
p++;
|
||||
w--;
|
||||
}
|
||||
}
|
||||
else /* BZ or BN status is enabled */
|
||||
{
|
||||
while (w > 0)
|
||||
{
|
||||
if (*p == ' ')
|
||||
{
|
||||
if (dtp->u.p.blank_status == BLANK_ZERO) *p = '0';
|
||||
if (dtp->u.p.blank_status == BLANK_NULL)
|
||||
{
|
||||
p++;
|
||||
w--;
|
||||
continue;
|
||||
}
|
||||
}
|
||||
else if (!isdigit (*p))
|
||||
goto bad_float;
|
||||
|
||||
exponent = 10 * exponent + *p - '0';
|
||||
p++;
|
||||
w--;
|
||||
}
|
||||
}
|
||||
|
||||
exponent = exponent * exponent_sign;
|
||||
|
||||
done:
|
||||
/* Use the precision specified in the format if no decimal point has been
|
||||
seen. */
|
||||
if (!seen_dp)
|
||||
exponent -= f->u.real.d;
|
||||
|
||||
if (exponent > 0)
|
||||
{
|
||||
edigits = 2;
|
||||
i = exponent;
|
||||
}
|
||||
else
|
||||
{
|
||||
edigits = 3;
|
||||
i = -exponent;
|
||||
}
|
||||
|
||||
while (i >= 10)
|
||||
{
|
||||
i /= 10;
|
||||
edigits++;
|
||||
}
|
||||
|
||||
i = ndigits + edigits + 1;
|
||||
if (val_sign < 0)
|
||||
i++;
|
||||
|
||||
if (i < SCRATCH_SIZE)
|
||||
buffer = scratch;
|
||||
else
|
||||
buffer = get_mem (i);
|
||||
|
||||
/* Reformat the string into a temporary buffer. As we're using atof it's
|
||||
easiest to just leave the decimal point in place. */
|
||||
p = buffer;
|
||||
if (val_sign < 0)
|
||||
*(p++) = '-';
|
||||
for (; ndigits > 0; ndigits--)
|
||||
{
|
||||
if (*digits == ' ')
|
||||
{
|
||||
if (dtp->u.p.blank_status == BLANK_ZERO) *digits = '0';
|
||||
if (dtp->u.p.blank_status == BLANK_NULL)
|
||||
{
|
||||
digits++;
|
||||
continue;
|
||||
}
|
||||
}
|
||||
*p = *digits;
|
||||
p++;
|
||||
digits++;
|
||||
}
|
||||
*(p++) = 'e';
|
||||
sprintf (p, "%d", exponent);
|
||||
|
||||
/* Do the actual conversion. */
|
||||
convert_real (dtp, dest, buffer, length);
|
||||
|
||||
if (buffer != scratch)
|
||||
free_mem (buffer);
|
||||
|
||||
bad_float:
|
||||
generate_error (&dtp->common, LIBERROR_READ_VALUE,
|
||||
"Bad value during floating point read");
|
||||
next_record (dtp, 1);
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -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);
|
||||
}
|
||||
|
||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -108,7 +108,7 @@ write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
|
|||
gfc_char4_t c;
|
||||
static const uchar masks[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
|
||||
static const uchar limits[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
|
||||
size_t nbytes;
|
||||
int nbytes;
|
||||
uchar buf[6], d, *q;
|
||||
|
||||
/* Take care of preceding blanks. */
|
||||
|
@ -597,7 +597,7 @@ write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
|
|||
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 *buffer, size_t len)
|
|||
}
|
||||
|
||||
|
||||
/* 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 fnode *f, const char *p, int len)
|
|||
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, int nspaces)
|
|||
p = write_block (dtp, len);
|
||||
if (p == NULL)
|
||||
return;
|
||||
|
||||
if (nspaces > 0)
|
||||
if (nspaces > 0 && len - nspaces >= 0)
|
||||
memset (&p[len - nspaces], ' ', nspaces);
|
||||
}
|
||||
|
||||
|
@ -1168,7 +1209,7 @@ namelist_write_newline (st_parameter_dt *dtp)
|
|||
/* Now seek to this record */
|
||||
record = record * dtp->u.p.current_unit->recl;
|
||||
|
||||
if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
|
||||
if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
|
||||
{
|
||||
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
|
||||
return;
|
||||
|
@ -1189,13 +1230,13 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
|
|||
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, namelist_info * obj, index_type offset,
|
|||
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, namelist_info * obj, index_type offset,
|
|||
/* 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, namelist_info * obj, index_type offset,
|
|||
/* 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, namelist_info * obj, index_type offset,
|
|||
}
|
||||
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, namelist_info * obj, index_type offset,
|
|||
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;
|
||||
|
|
|
@ -603,7 +603,7 @@ output_float_FMT_G_ ## x (st_parameter_dt *dtp, const fnode *f, \
|
|||
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_dt *dtp, const fnode *f, \
|
|||
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_dt *dtp, const fnode *f, \
|
|||
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)\
|
||||
{ \
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
|
|
Loading…
Reference in New Issue