[multiple changes]

2009-04-05  Daniel Kraft  <d@domob.eu>

	PR fortran/38654
	* io/read.c (read_f): Reworked to speed up floating point parsing.
	(convert_real): Use pointer-casting instead of memcpy and temporaries.

2009-04-05  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

        PR libfortran/37754
	* io/io.h (format_hash_entry): New structure for hash table.
	(format_hash_table): The hash table itself.
	(free_format_data): Revise function prototype.
	(free_format_hash_table, init_format_hash,
	free_format_hash): New function prototypes.
	* io/unit.c (close_unit_1): Use free_format_hash_table.
	* io/transfer.c (st_read_done, st_write_done): Free format data if
	internal unit.
	* io/format.c (free_format_hash_table): New function that frees any
	memory allocated previously for cached format data.
	(reset_node): New static helper function to reset the format counters
	for a format node.
	(reset_fnode_counters): New static function recursively calls reset_node
	to traverse the	fnode tree.
	(format_hash): New simple hash function based on XOR, probabalistic,
	tosses collisions.
	(save_parsed_format): New static function to save the parsed format
	data to use again.
	(find_parsed_format): New static function searches the hash table
	looking for a match.
	(free_format_data): Revised to accept pointer to format data rather than
	the dtp pointer so that the function can be used in more places.
	(format_lex): Editorial.
	(parse_format_list): Set flag used to determine of format data hashing
	is to be used.  Internal units are not persistent enough for this.
	(revert): Move to ne location in file.
	(parse_format): Use new functions to look for previously parsed
	format strings and use them rather than re-parse.  If not found, saves
	the parsed format data for later use.
	
2009-04-05  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

        PR libfortran/37754
	* io/transfer.c (formatted_transfer_scalar): Remove this function by
	factoring it into two new functions, one for read and one for write,
	eliminating all the conditionals for read or write mode.
	(formatted transfer_scalar_read): New function.
	(formatted transfer_scalar_write): New function.
	(formatted_transfer): Use new functions.

2009-04-05  Janne Blomqvist  <jb@gcc.gnu.org>

        PR libfortran/25561 libfortran/37754
	* io/io.h (struct stream): Define new stream interface function
	pointers, and inline functions for accessing it.
	(struct fbuf): Use int instead of size_t, remove flushed element.
	(mem_alloc_w): New prototype.
	(mem_alloc_r): New prototype.
	(stream_at_bof): Remove prototype.
	(stream_at_eof): Remove prototype.
	(file_position): Remove prototype.
	(flush): Remove prototype.
	(stream_offset): Remove prototype.
	(unit_truncate): New prototype.
	(read_block_form): Change to return pointer, int* argument.
	(hit_eof): New prototype.
	(fbuf_init): Change prototype.
	(fbuf_reset): Change prototype.
	(fbuf_alloc): Change prototype.
	(fbuf_flush): Change prototype.
	(fbuf_seek): Change prototype.
	(fbuf_read): New prototype.
	(fbuf_getc_refill): New prototype.
	(fbuf_getc): New inline function.
        * io/fbuf.c (fbuf_init): Use int, get rid of flushed.
	(fbuf_debug): New function.
	(fbuf_reset): Flush, and return position offset.
	(fbuf_alloc): Simplify, don't flush, just realloc.
	(fbuf_flush): Make usable for read mode, salvage remaining bytes.
	(fbuf_seek): New whence argument.
	(fbuf_read): New function.
	(fbuf_getc_refill): New function.
	* io/file_pos.c (formatted_backspace): Use new stream interface.
	(unformatted_backspace): Likewise.
	(st_backspace): Make sure format buffer is reset, use new stream
	interface, use unit_truncate.
	(st_endfile): Likewise.
	(st_rewind): Likewise.
	* io/intrinsics.c: Use new stream interface.
	* io/list_read.c (push_char): Don't use u.p.scratch, use realloc
	to resize.
	(free_saved): Don't check u.p.scratch.
	(next_char): Use new stream interface, use fbuf_getc() for external files.
	(finish_list_read): flush format buffer.
	(nml_query): Update to use modified interface:s
	* io/open.c (test_endfile): Use new stream interface.
	(edit_modes): Likewise.
	(new_unit): Likewise, set bytes_left to 1 for stream files.
	* io/read.c (read_l): Use new read_block_form interface.
	(read_utf8): Likewise.
	(read_utf8_char1): Likewise.
	(read_default_char1): Likewise.
	(read_utf8_char4): Likewise.
	(read_default_char4): Likewise.
	(read_a): Likewise.
	(read_a_char4): Likewise.
	(read_decimal): Likewise.
	(read_radix): Likewise.
	(read_f): Likewise.
	* io/transfer.c (read_sf): Use fbuf_read and mem_alloc_r, remove
	usage of u.p.line_buffer.
	(read_block_form): Update interface to return pointer, use
	fbuf_read for direct access.
	(read_block_direct): Update to new stream interface.
	(write_block): Use mem_alloc_w for internal I/O.
	(write_buf): Update to new stream interface.
	(formatted_transfer_scalar): Don't use u.p.line_buffer, use
	fbuf_seek for external files.
	(us_read): Update to new stream interface.
	(us_write): Likewise.
	(data_transfer_init): Always check if we switch modes and flush.
	(skip_record): Use new stream interface, fix comparison.
	(next_record_r): Check for and reset u.p.at_eof, use new stream
	interface, use fbuf_getc for spacing.
	(write_us_marker): Update to new stream interface, don't inline.
	(next_record_w_unf): Likewise.
	(sset): New function.
	(next_record_w): Use new stream interface, use fbuf for printing
	newline.
	(next_record): Use new stream interface.
	(finalize_transfer): Remove sfree call, use new stream interface.
	(st_iolength_done): Don't use u.p.scratch.
	(st_read): Don't check for end of file.
	(st_read_done): Don't use u.p.scratch, use unit_truncate.
	(hit_eof): New function.
	* io/unit.c (init_units): Always init fbuf for formatted units.
	(update_position): Use new stream interface.
	(unit_truncate): New function.
	(finish_last_advance_record): Use fbuf to print newline.
	* io/unix.c: Remove unused SSIZE_MAX macro.
	(BUFFER_SIZE): Make static const variable rather than macro.
	(struct unix_stream): Remove dirty_offset, len, method,
	small_buffer. Order elements by decreasing size.
	(struct int_stream): Remove.
	(move_pos_offset): Remove usage of dirty_offset.
	(reset_stream): Remove.
	(do_read): Rename to raw_read, update to match new stream
	interface.
	(do_write): Rename to raw_write, update to new stream interface.
	(raw_seek): New function.
	(raw_tell): New function.
	(raw_truncate): New function.
	(raw_close): New function.
	(raw_flush): New function.
	(raw_init): New function.
	(fd_alloc): Remove.
	(fd_alloc_r_at): Remove.
	(fd_alloc_w_at): Remove.
	(fd_sfree): Remove.
	(fd_seek): Remove.
	(fd_truncate): Remove.
	(fd_sset): Remove.
	(fd_read): Remove.
	(fd_write): Remove.
	(fd_close): Remove.
	(fd_open): Remove.
	(fd_flush): Rename to buf_flush, update to new stream interface
	and unix_stream.
	(buf_read): New function.
	(buf_write): New function.
	(buf_seek): New function.
	(buf_tell): New function.
	(buf_truncate): New function.
	(buf_close): New function.
	(buf_init): New function.
	(mem_alloc_r_at): Rename to mem_alloc_r, change prototype.
	(mem_alloc_w_at): Rename to mem_alloc_w, change prototype.
	(mem_read): Change to match new stream interface.
	(mem_write): Likewise.
	(mem_seek): Likewise.
	(mem_tell): Likewise.
	(mem_truncate): Likewise.
	(mem_close): Likewise.
	(mem_flush): New function.
	(mem_sfree): Remove.
	(empty_internal_buffer): Cast to correct type.
	(open_internal): Use correct type, init function pointers.
	(fd_to_stream): Test whether to open file as buffered or raw.
	(output_stream): Remove mode set.
	(error_stream): Likewise.
	(flush_all_units_1): Use new stream interface.
	(flush_all_units): Likewise.
	(stream_at_bof): Remove.
	(stream_at_eof): Remove.
	(file_position): Remove.
	(file_length): Update logic to use stream interface.
	(flush): Remove.
	(stream_offset): Remove.
	* io/write.c (write_utf8_char4): Use int instead of size_t.
	(write_x): Extra safety check.
	(namelist_write_newline): Use new stream interface.

From-SVN: r145571

libgfortran/ChangeLog

+2009-04-05  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/38654
+	* io/read.c (read_f): Reworked to speed up floating point parsing.
+	(convert_real): Use pointer-casting instead of memcpy and temporaries.
+
+2009-04-05  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+        PR libfortran/37754
+	* io/io.h (format_hash_entry): New structure for hash table.
+	(format_hash_table): The hash table itself.
+	(free_format_data): Revise function prototype.
+	(free_format_hash_table, init_format_hash,
+	free_format_hash): New function prototypes.
+	* io/unit.c (close_unit_1): Use free_format_hash_table.
+	* io/transfer.c (st_read_done, st_write_done): Free format data if
+	internal unit.
+	* io/format.c (free_format_hash_table): New function that frees any
+	memory allocated previously for cached format data.
+	(reset_node): New static helper function to reset the format counters
+	for a format node.
+	(reset_fnode_counters): New static function recursively calls reset_node
+	to traverse the	fnode tree.
+	(format_hash): New simple hash function based on XOR, probabalistic,
+	tosses collisions.
+	(save_parsed_format): New static function to save the parsed format
+	data to use again.
+	(find_parsed_format): New static function searches the hash table
+	looking for a match.
+	(free_format_data): Revised to accept pointer to format data rather than
+	the dtp pointer so that the function can be used in more places.
+	(format_lex): Editorial.
+	(parse_format_list): Set flag used to determine of format data hashing
+	is to be used.  Internal units are not persistent enough for this.
+	(revert): Move to ne location in file.
+	(parse_format): Use new functions to look for previously parsed
+	format strings and use them rather than re-parse.  If not found, saves
+	the parsed format data for later use.
+	
+2009-04-05  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+        PR libfortran/37754
+	* io/transfer.c (formatted_transfer_scalar): Remove this function by
+	factoring it into two new functions, one for read and one for write,
+	eliminating all the conditionals for read or write mode.
+	(formatted transfer_scalar_read): New function.
+	(formatted transfer_scalar_write): New function.
+	(formatted_transfer): Use new functions.
+
+2009-04-05  Janne Blomqvist  <jb@gcc.gnu.org>
+
+        PR libfortran/25561 libfortran/37754
+	* io/io.h (struct stream): Define new stream interface function
+	pointers, and inline functions for accessing it.
+	(struct fbuf): Use int instead of size_t, remove flushed element.
+	(mem_alloc_w): New prototype.
+	(mem_alloc_r): New prototype.
+	(stream_at_bof): Remove prototype.
+	(stream_at_eof): Remove prototype.
+	(file_position): Remove prototype.
+	(flush): Remove prototype.
+	(stream_offset): Remove prototype.
+	(unit_truncate): New prototype.
+	(read_block_form): Change to return pointer, int* argument.
+	(hit_eof): New prototype.
+	(fbuf_init): Change prototype.
+	(fbuf_reset): Change prototype.
+	(fbuf_alloc): Change prototype.
+	(fbuf_flush): Change prototype.
+	(fbuf_seek): Change prototype.
+	(fbuf_read): New prototype.
+	(fbuf_getc_refill): New prototype.
+	(fbuf_getc): New inline function.
+        * io/fbuf.c (fbuf_init): Use int, get rid of flushed.
+	(fbuf_debug): New function.
+	(fbuf_reset): Flush, and return position offset.
+	(fbuf_alloc): Simplify, don't flush, just realloc.
+	(fbuf_flush): Make usable for read mode, salvage remaining bytes.
+	(fbuf_seek): New whence argument.
+	(fbuf_read): New function.
+	(fbuf_getc_refill): New function.
+	* io/file_pos.c (formatted_backspace): Use new stream interface.
+	(unformatted_backspace): Likewise.
+	(st_backspace): Make sure format buffer is reset, use new stream
+	interface, use unit_truncate.
+	(st_endfile): Likewise.
+	(st_rewind): Likewise.
+	* io/intrinsics.c: Use new stream interface.
+	* io/list_read.c (push_char): Don't use u.p.scratch, use realloc
+	to resize.
+	(free_saved): Don't check u.p.scratch.
+	(next_char): Use new stream interface, use fbuf_getc() for external files.
+	(finish_list_read): flush format buffer.
+	(nml_query): Update to use modified interface:s
+	* io/open.c (test_endfile): Use new stream interface.
+	(edit_modes): Likewise.
+	(new_unit): Likewise, set bytes_left to 1 for stream files.
+	* io/read.c (read_l): Use new read_block_form interface.
+	(read_utf8): Likewise.
+	(read_utf8_char1): Likewise.
+	(read_default_char1): Likewise.
+	(read_utf8_char4): Likewise.
+	(read_default_char4): Likewise.
+	(read_a): Likewise.
+	(read_a_char4): Likewise.
+	(read_decimal): Likewise.
+	(read_radix): Likewise.
+	(read_f): Likewise.
+	* io/transfer.c (read_sf): Use fbuf_read and mem_alloc_r, remove
+	usage of u.p.line_buffer.
+	(read_block_form): Update interface to return pointer, use
+	fbuf_read for direct access.
+	(read_block_direct): Update to new stream interface.
+	(write_block): Use mem_alloc_w for internal I/O.
+	(write_buf): Update to new stream interface.
+	(formatted_transfer_scalar): Don't use u.p.line_buffer, use
+	fbuf_seek for external files.
+	(us_read): Update to new stream interface.
+	(us_write): Likewise.
+	(data_transfer_init): Always check if we switch modes and flush.
+	(skip_record): Use new stream interface, fix comparison.
+	(next_record_r): Check for and reset u.p.at_eof, use new stream
+	interface, use fbuf_getc for spacing.
+	(write_us_marker): Update to new stream interface, don't inline.
+	(next_record_w_unf): Likewise.
+	(sset): New function.
+	(next_record_w): Use new stream interface, use fbuf for printing
+	newline.
+	(next_record): Use new stream interface.
+	(finalize_transfer): Remove sfree call, use new stream interface.
+	(st_iolength_done): Don't use u.p.scratch.
+	(st_read): Don't check for end of file.
+	(st_read_done): Don't use u.p.scratch, use unit_truncate.
+	(hit_eof): New function.
+	* io/unit.c (init_units): Always init fbuf for formatted units.
+	(update_position): Use new stream interface.
+	(unit_truncate): New function.
+	(finish_last_advance_record): Use fbuf to print newline.
+	* io/unix.c: Remove unused SSIZE_MAX macro.
+	(BUFFER_SIZE): Make static const variable rather than macro.
+	(struct unix_stream): Remove dirty_offset, len, method,
+	small_buffer. Order elements by decreasing size.
+	(struct int_stream): Remove.
+	(move_pos_offset): Remove usage of dirty_offset.
+	(reset_stream): Remove.
+	(do_read): Rename to raw_read, update to match new stream
+	interface.
+	(do_write): Rename to raw_write, update to new stream interface.
+	(raw_seek): New function.
+	(raw_tell): New function.
+	(raw_truncate): New function.
+	(raw_close): New function.
+	(raw_flush): New function.
+	(raw_init): New function.
+	(fd_alloc): Remove.
+	(fd_alloc_r_at): Remove.
+	(fd_alloc_w_at): Remove.
+	(fd_sfree): Remove.
+	(fd_seek): Remove.
+	(fd_truncate): Remove.
+	(fd_sset): Remove.
+	(fd_read): Remove.
+	(fd_write): Remove.
+	(fd_close): Remove.
+	(fd_open): Remove.
+	(fd_flush): Rename to buf_flush, update to new stream interface
+	and unix_stream.
+	(buf_read): New function.
+	(buf_write): New function.
+	(buf_seek): New function.
+	(buf_tell): New function.
+	(buf_truncate): New function.
+	(buf_close): New function.
+	(buf_init): New function.
+	(mem_alloc_r_at): Rename to mem_alloc_r, change prototype.
+	(mem_alloc_w_at): Rename to mem_alloc_w, change prototype.
+	(mem_read): Change to match new stream interface.
+	(mem_write): Likewise.
+	(mem_seek): Likewise.
+	(mem_tell): Likewise.
+	(mem_truncate): Likewise.
+	(mem_close): Likewise.
+	(mem_flush): New function.
+	(mem_sfree): Remove.
+	(empty_internal_buffer): Cast to correct type.
+	(open_internal): Use correct type, init function pointers.
+	(fd_to_stream): Test whether to open file as buffered or raw.
+	(output_stream): Remove mode set.
+	(error_stream): Likewise.
+	(flush_all_units_1): Use new stream interface.
+	(flush_all_units): Likewise.
+	(stream_at_bof): Remove.
+	(stream_at_eof): Remove.
+	(file_position): Remove.
+	(file_length): Update logic to use stream interface.
+	(flush): Remove.
+	(stream_offset): Remove.
+	* io/write.c (write_utf8_char4): Use int instead of size_t.
+	(write_x): Extra safety check.
+	(namelist_write_newline): Use new stream interface.
+
 2009-03-29  John David Anglin  <dave.anglin@nrc-cnrc.gc.ca>
 
 	PR fortran/33595

libgfortran/io/fbuf.c

@@ -33,8 +33,11 @@ Boston, MA 02110-1301, USA.  */
 #include <stdlib.h>
 
 
+//#define FBUF_DEBUG
+
+
 void
-fbuf_init (gfc_unit * u, size_t len)
+fbuf_init (gfc_unit * u, int len)
 {
   if (len == 0)
     len = 512;			/* Default size.  */
@@ -42,14 +45,7 @@ fbuf_init (gfc_unit * u, size_t len)
   u->fbuf = get_mem (sizeof (fbuf));
   u->fbuf->buf = get_mem (len);
   u->fbuf->len = len;
-  u->fbuf->act = u->fbuf->flushed = u->fbuf->pos = 0;
-}
-
-
-void
-fbuf_reset (gfc_unit * u)
-{
-  u->fbuf->act = u->fbuf->flushed = u->fbuf->pos = 0;
+  u->fbuf->act = u->fbuf->pos = 0;
 }
 
 
@@ -61,58 +57,79 @@ fbuf_destroy (gfc_unit * u)
   if (u->fbuf->buf)
     free_mem (u->fbuf->buf);
   free_mem (u->fbuf);
+  u->fbuf = NULL;
+}
+
+
+static void
+#ifdef FBUF_DEBUG
+fbuf_debug (gfc_unit * u, const char * format, ...)
+{
+  va_list args;
+  va_start(args, format);
+  vfprintf(stderr, format, args);
+  va_end(args);
+  fprintf (stderr, "fbuf_debug pos: %d, act: %d, buf: ''", 
+           u->fbuf->pos, u->fbuf->act);
+  for (int ii = 0; ii < u->fbuf->act; ii++)
+    {
+      putc (u->fbuf->buf[ii], stderr);
+    }
+  fprintf (stderr, "''\n");
+}
+#else
+fbuf_debug (gfc_unit * u __attribute__ ((unused)),
+            const char * format __attribute__ ((unused)),
+            ...) {}
+#endif
+
+  
+
+/* You should probably call this before doing a physical seek on the
+   underlying device.  Returns how much the physical position was
+   modified.  */
+
+int
+fbuf_reset (gfc_unit * u)
+{
+  int seekval = 0;
+
+  if (!u->fbuf)
+    return 0;
+
+  fbuf_debug (u, "fbuf_reset: ");
+  fbuf_flush (u, u->mode);
+  /* If we read past the current position, seek the underlying device
+     back.  */
+  if (u->mode == READING && u->fbuf->act > u->fbuf->pos)
+    {
+      seekval = - (u->fbuf->act - u->fbuf->pos);
+      fbuf_debug (u, "fbuf_reset seekval %d, ", seekval);
+    }
+  u->fbuf->act = u->fbuf->pos = 0;
+  return seekval;
 }
 
 
 /* Return a pointer to the current position in the buffer, and increase
    the pointer by len. Makes sure that the buffer is big enough, 
-   reallocating if necessary. If the buffer is not big enough, there are
-   three cases to consider:
-   1. If we haven't flushed anything, realloc
-   2. If we have flushed enough that by discarding the flushed bytes
-      the request fits into the buffer, do that.
-   3. Else allocate a new buffer, memcpy unflushed active bytes from old
-      buffer. */
+   reallocating if necessary.  */
 
 char *
-fbuf_alloc (gfc_unit * u, size_t len)
+fbuf_alloc (gfc_unit * u, int len)
 {
-  size_t newlen;
+  int newlen;
   char *dest;
+  fbuf_debug (u, "fbuf_alloc len %d, ", len);
   if (u->fbuf->pos + len > u->fbuf->len)
     {
-      if (u->fbuf->flushed == 0)
-	{
-	  /* Round up to nearest multiple of the current buffer length.  */
-	  newlen = ((u->fbuf->pos + len) / u->fbuf->len + 1) * u->fbuf->len;
-	  dest = realloc (u->fbuf->buf, newlen);
-	  if (dest == NULL)
-	    return NULL;
-	  u->fbuf->buf = dest;
-	  u->fbuf->len = newlen;
-	}
-      else if (u->fbuf->act - u->fbuf->flushed + len < u->fbuf->len)
-	{
-	  memmove (u->fbuf->buf, u->fbuf->buf + u->fbuf->flushed,
-		   u->fbuf->act - u->fbuf->flushed);
-	  u->fbuf->act -= u->fbuf->flushed;
-	  u->fbuf->pos -= u->fbuf->flushed;
-	  u->fbuf->flushed = 0;
-	}
-      else
-	{
-	  /* Most general case, flushed != 0, request doesn't fit.  */
-	  newlen = ((u->fbuf->pos - u->fbuf->flushed + len)
-		    / u->fbuf->len + 1) * u->fbuf->len;
-	  dest = get_mem (newlen);
-	  memcpy (dest, u->fbuf->buf + u->fbuf->flushed,
-		  u->fbuf->act - u->fbuf->flushed);
-	  u->fbuf->act -= u->fbuf->flushed;
-	  u->fbuf->pos -= u->fbuf->flushed;
-	  u->fbuf->flushed = 0;
-	  u->fbuf->buf = dest;
-	  u->fbuf->len = newlen;
-	}
+      /* Round up to nearest multiple of the current buffer length.  */
+      newlen = ((u->fbuf->pos + len) / u->fbuf->len + 1) * u->fbuf->len;
+      dest = realloc (u->fbuf->buf, newlen);
+      if (dest == NULL)
+	return NULL;
+      u->fbuf->buf = dest;
+      u->fbuf->len = newlen;
     }
 
   dest = u->fbuf->buf + u->fbuf->pos;
@@ -123,42 +140,134 @@ fbuf_alloc (gfc_unit * u, size_t len)
 }
 
 
-
+/* mode argument is WRITING for write mode and READING for read
+   mode. Return value is 0 for success, -1 on failure.  */
 
 int
-fbuf_flush (gfc_unit * u, int record_done)
+fbuf_flush (gfc_unit * u, unit_mode mode)
 {
-  int status;
-  size_t nbytes;
+  int nwritten;
 
   if (!u->fbuf)
     return 0;
-  if (u->fbuf->act - u->fbuf->flushed != 0)
+
+  fbuf_debug (u, "fbuf_flush with mode %d: ", mode);
+
+  if (mode == WRITING)
     {
-      if (record_done)
-        nbytes = u->fbuf->act - u->fbuf->flushed;
-      else	
-        nbytes = u->fbuf->pos - u->fbuf->flushed;	
-      status = swrite (u->s, u->fbuf->buf + u->fbuf->flushed, &nbytes);
-      u->fbuf->flushed += nbytes;
+      if (u->fbuf->pos > 0)
+	{
+	  nwritten = swrite (u->s, u->fbuf->buf, u->fbuf->pos);
+	  if (nwritten < 0)
+	    return -1;
+	}
     }
-  else
-    status = 0;
-  if (record_done)
-    fbuf_reset (u);
-  return status;
+  /* Salvage remaining bytes for both reading and writing. This
+     happens with the combination of advance='no' and T edit
+     descriptors leaving the final position somewhere not at the end
+     of the record. For reading, this also happens if we sread() past
+     the record boundary.  */ 
+  if (u->fbuf->act > u->fbuf->pos && u->fbuf->pos > 0)
+    memmove (u->fbuf->buf, u->fbuf->buf + u->fbuf->pos, 
+             u->fbuf->act - u->fbuf->pos);
+
+  u->fbuf->act -= u->fbuf->pos;
+  u->fbuf->pos = 0;
+
+  return 0;
 }
 
 
 int
-fbuf_seek (gfc_unit * u, gfc_offset off)
+fbuf_seek (gfc_unit * u, int off, int whence)
 {
-  gfc_offset pos = u->fbuf->pos + off;
-  /* Moving to the left past the flushed marked would imply moving past
-     the left tab limit, which is never allowed. So return error if
-     that is attempted.  */
-  if (pos < (gfc_offset) u->fbuf->flushed)
+  if (!u->fbuf)
     return -1;
-  u->fbuf->pos = pos;
-  return 0;
+
+  switch (whence)
+    {
+    case SEEK_SET:
+      break;
+    case SEEK_CUR:
+      off += u->fbuf->pos;
+      break;
+    case SEEK_END:
+      off += u->fbuf->act;
+      break;
+    default:
+      return -1;
+    }
+
+  fbuf_debug (u, "fbuf_seek, off %d ", off);
+  /* The start of the buffer is always equal to the left tab
+     limit. Moving to the left past the buffer is illegal in C and
+     would also imply moving past the left tab limit, which is never
+     allowed in Fortran. Similarly, seeking past the end of the buffer
+     is not possible, in that case the user must make sure to allocate
+     space with fbuf_alloc().  So return error if that is
+     attempted.  */
+  if (off < 0 || off > u->fbuf->act)
+    return -1;
+  u->fbuf->pos = off;
+  return off;
+}
+
+
+/* Fill the buffer with bytes for reading.  Returns a pointer to start
+   reading from. If we hit EOF, returns a short read count. If any
+   other error occurs, return NULL.  After reading, the caller is
+   expected to call fbuf_seek to update the position with the number
+   of bytes actually processed. */
+
+char *
+fbuf_read (gfc_unit * u, int * len)
+{
+  char *ptr;
+  int oldact, oldpos;
+  int readlen = 0;
+
+  fbuf_debug (u, "fbuf_read, len %d: ", *len);
+  oldact = u->fbuf->act;
+  oldpos = u->fbuf->pos;
+  ptr = fbuf_alloc (u, *len);
+  u->fbuf->pos = oldpos;
+  if (oldpos + *len > oldact)
+    {
+      fbuf_debug (u, "reading %d bytes starting at %d ", 
+                  oldpos + *len - oldact, oldact);
+      readlen = sread (u->s, u->fbuf->buf + oldact, oldpos + *len - oldact);
+      if (readlen < 0)
+	return NULL;
+      *len = oldact - oldpos + readlen;
+    }
+  u->fbuf->act = oldact + readlen;
+  fbuf_debug (u, "fbuf_read done: ");
+  return ptr;
+}
+
+
+/* When the fbuf_getc() inline function runs out of buffer space, it
+   calls this function to fill the buffer with bytes for
+   reading. Never call this function directly.  */
+
+int
+fbuf_getc_refill (gfc_unit * u)
+{
+  int nread;
+  char *p;
+
+  fbuf_debug (u, "fbuf_getc_refill ");
+
+  /* Read 80 bytes (average line length?).  This is a compromise
+     between not needing to call the read() syscall all the time and
+     not having to memmove unnecessary stuff when switching to the
+     next record.  */
+  nread = 80;
+
+  p = fbuf_read (u, &nread);
+
+  if (p && nread > 0)
+    return (unsigned char) u->fbuf->buf[u->fbuf->pos++];
+  else
+    return EOF;
 }

libgfortran/io/file_pos.c

@@ -46,17 +46,17 @@ formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
 {
   gfc_offset base;
   char p[READ_CHUNK];
-  size_t n;
+  ssize_t n;
 
-  base = file_position (u->s) - 1;
+  base = stell (u->s) - 1;
 
   do
     {
       n = (base < READ_CHUNK) ? base : READ_CHUNK;
       base -= n;
-      if (sseek (u->s, base) == FAILURE)
+      if (sseek (u->s, base, SEEK_SET) < 0)
         goto io_error;
-      if (sread (u->s, p, &n) != 0)
+      if (sread (u->s, p, n) != n)
 	goto io_error;
 
       /* We have moved backwards from the current position, it should
@@ -81,7 +81,7 @@ formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
 
   /* base is the new pointer.  Seek to it exactly.  */
  done:
-  if (sseek (u->s, base) == FAILURE)
+  if (sseek (u->s, base, SEEK_SET) < 0)
     goto io_error;
   u->last_record--;
   u->endfile = NO_ENDFILE;
@@ -100,10 +100,10 @@ formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
 static void
 unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
 {
-  gfc_offset m, new;
+  gfc_offset m, slen;
   GFC_INTEGER_4 m4;
   GFC_INTEGER_8 m8;
-  size_t length;
+  ssize_t length;
   int continued;
   char p[sizeof (GFC_INTEGER_8)];
 
@@ -114,9 +114,10 @@ unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
 
   do
     {
-      if (sseek (u->s, file_position (u->s) - length) == FAILURE)
+      slen = - (gfc_offset) length;
+      if (sseek (u->s, slen, SEEK_CUR) < 0)
         goto io_error;
-      if (sread (u->s, p, &length) != 0)
+      if (sread (u->s, p, length) != length)
         goto io_error;
 
       /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here.  */
@@ -164,10 +165,7 @@ unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
       if (continued)
 	m = -m;
 
-      if ((new = file_position (u->s) - m - 2*length) < 0)
-	new = 0;
-
-      if (sseek (u->s, new) == FAILURE)
+      if (sseek (u->s, -m -2 * length, SEEK_CUR) < 0)
 	goto io_error;
     } while (continued);
 
@@ -206,15 +204,21 @@ st_backspace (st_parameter_filepos *fpp)
       goto done;
     }
 
-    if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED)
-      {
-	generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
-			"Cannot BACKSPACE an unformatted stream file");
-	goto done;
-      }
+  if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED)
+    {
+      generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
+                      "Cannot BACKSPACE an unformatted stream file");
+      goto done;
+    }
+
+  /* Make sure format buffer is flushed and reset.  */
+  if (u->flags.form == FORM_FORMATTED)
+    {
+      int pos = fbuf_reset (u);
+      if (pos != 0)
+        sseek (u->s, pos, SEEK_CUR);
+    }
 
-  /* Make sure format buffer is flushed.  */
-  fbuf_flush (u, 1);
   
   /* Check for special cases involving the ENDFILE record first.  */
 
@@ -222,11 +226,11 @@ st_backspace (st_parameter_filepos *fpp)
     {
       u->endfile = AT_ENDFILE;
       u->flags.position = POSITION_APPEND;
-      flush (u->s);
+      sflush (u->s);
     }
   else
     {
-      if (file_position (u->s) == 0)
+      if (stell (u->s) == 0)
 	{
 	  u->flags.position = POSITION_REWIND;
 	  goto done;		/* Common special case */
@@ -243,8 +247,7 @@ st_backspace (st_parameter_filepos *fpp)
 
 	  u->previous_nonadvancing_write = 0;
 
-	  flush (u->s);
-	  struncate (u->s);
+	  unit_truncate (u, stell (u->s), &fpp->common);
 	  u->mode = READING;
         }
 
@@ -253,7 +256,7 @@ st_backspace (st_parameter_filepos *fpp)
       else
 	unformatted_backspace (fpp, u);
 
-      update_position (u);
+      u->flags.position = POSITION_UNSPECIFIED;
       u->endfile = NO_ENDFILE;
       u->current_record = 0;
       u->bytes_left = 0;
@@ -305,10 +308,10 @@ st_endfile (st_parameter_filepos *fpp)
 	  next_record (&dtp, 1);
 	}
 
-      flush (u->s);
-      struncate (u->s);
+      unit_truncate (u, stell (u->s), &fpp->common);
       u->endfile = AFTER_ENDFILE;
-      update_position (u);
+      if (0 == stell (u->s))
+        u->flags.position = POSITION_REWIND;
     done:
       unlock_unit (u);
     }
@@ -347,14 +350,25 @@ st_rewind (st_parameter_filepos *fpp)
 	       written record is the last record in the file, so truncate the
 	       file now.  Reset to read mode so two consecutive rewind
 	       statements do not delete the file contents.  */
-	  flush (u->s);
-	  if (u->mode == WRITING && u->flags.access != ACCESS_STREAM)
-	    struncate (u->s);
+	  if (u->mode == WRITING)
+	    {
+	      /* unit_truncate takes care of flushing.  */
+	      unit_truncate (u, stell (u->s), &fpp->common);
+	      /* .. but we still need to reset since we're going to seek.  */
+	      fbuf_reset (u);
+	    }
+          else
+            {
+              /* Make sure buffers are reset.  */
+              if (u->flags.form == FORM_FORMATTED)
+                fbuf_reset (u);
+              sflush (u->s);
+            }              
 
 	  u->mode = READING;
 	  u->last_record = 0;
 
-	  if (file_position (u->s) != 0 && sseek (u->s, 0) == FAILURE)
+	  if (sseek (u->s, 0, SEEK_SET) < 0)
 	    generate_error (&fpp->common, LIBERROR_OS, NULL);
 
 	  /* Handle special files like /dev/null differently.  */
@@ -366,7 +380,7 @@ st_rewind (st_parameter_filepos *fpp)
 	  else
 	    {
 	      /* Set this for compatibilty with g77 for /dev/null.  */
-	      if (file_length (u->s) == 0  && file_position (u->s) == 0)
+	      if (file_length (u->s) == 0  && stell (u->s) == 0)
 		u->endfile = AT_ENDFILE;
 	      /* Future refinements on special files can go here.  */
 	    }
@@ -397,7 +411,11 @@ st_flush (st_parameter_filepos *fpp)
   u = find_unit (fpp->common.unit);
   if (u != NULL)
     {
-      flush (u->s);
+      /* Make sure format buffer is flushed.  */
+      if (u->flags.form == FORM_FORMATTED)
+        fbuf_flush (u, u->mode);
+
+      sflush (u->s);
       unlock_unit (u);
     }
   else

libgfortran/io/format.c

@@ -36,6 +36,7 @@ Boston, MA 02110-1301, USA.  */
 #include "io.h"
 #include <ctype.h>
 #include <string.h>
+#include <stdbool.h>
 
 #define FARRAY_SIZE 64
 
@@ -63,7 +64,7 @@ format_data;
 static const fnode colon_node = { FMT_COLON, 0, NULL, NULL, {{ 0, 0, 0 }}, 0,
 				  NULL };
 
-/* Error messages */
+/* Error messages. */
 
 static const char posint_required[] = "Positive width required in format",
   period_required[] = "Period required in format",
@@ -75,6 +76,129 @@ static const char posint_required[] = "Positive width required in format",
   reversion_error[] = "Exhausted data descriptors in format",
   zero_width[] = "Zero width in format descriptor";
 
+/* The following routines support caching format data from parsed format strings
+   into a hash table.  This avoids repeatedly parsing duplicate format strings
+   or format strings in I/O statements that are repeated in loops.  */
+
+
+/* Traverse the table and free all data.  */
+
+void
+free_format_hash_table (gfc_unit *u)
+{
+  size_t i;
+
+  /* free_format_data handles any NULL pointers.  */
+  for (i = 0; i < FORMAT_HASH_SIZE; i++)
+    {
+      if (u->format_hash_table[i].hashed_fmt != NULL)
+	free_format_data (u->format_hash_table[i].hashed_fmt);
+      u->format_hash_table[i].hashed_fmt = NULL;
+    }
+}
+
+/* Traverse the format_data structure and reset the fnode counters.  */
+
+static void
+reset_node (fnode *fn)
+{
+  fnode *f;
+
+  fn->count = 0;
+  fn->current = NULL;
+  
+  if (fn->format != FMT_LPAREN)
+    return;
+
+  for (f = fn->u.child; f; f = f->next)
+    {
+      if (f->format == FMT_RPAREN)
+	break;
+      reset_node (f);
+    }
+}
+
+static void
+reset_fnode_counters (st_parameter_dt *dtp)
+{
+  fnode *f;
+  format_data *fmt;
+
+  fmt = dtp->u.p.fmt;
+
+  /* Clear this pointer at the head so things start at the right place.  */
+  fmt->array.array[0].current = NULL;
+
+  for (f = fmt->last->array[0].u.child; f; f = f->next)
+    reset_node (f);
+}
+
+
+/* A simple hashing function to generate an index into the hash table.  */
+
+static inline
+uint32_t format_hash (st_parameter_dt *dtp)
+{
+  char *key;
+  size_t key_len;
+  uint32_t hash = 0;
+  size_t i;
+
+  /* Hash the format string. Super simple, but what the heck!  */
+  key = dtp->format;
+  key_len = dtp->format_len;
+  for (i = 0; i < key_len; i++)
+    hash ^= key[i];
+  hash &= (FORMAT_HASH_SIZE - 1);
+  return hash;
+}
+
+
+static void
+save_parsed_format (st_parameter_dt *dtp)
+{
+  uint32_t hash;
+  gfc_unit *u;
+
+  hash = format_hash (dtp);
+  u = dtp->u.p.current_unit;
+
+  /* Index into the hash table.  We are simply replacing whatever is there
+     relying on probability.  */
+  if (u->format_hash_table[hash].hashed_fmt != NULL)
+    free_format_data (u->format_hash_table[hash].hashed_fmt);
+  u->format_hash_table[hash].hashed_fmt = NULL;
+
+  u->format_hash_table[hash].key = dtp->format;
+  u->format_hash_table[hash].key_len = dtp->format_len;
+  u->format_hash_table[hash].hashed_fmt = dtp->u.p.fmt;
+}
+
+
+static format_data *
+find_parsed_format (st_parameter_dt *dtp)
+{
+  uint32_t hash;
+  gfc_unit *u;
+
+  hash = format_hash (dtp);
+  u = dtp->u.p.current_unit;
+
+  if (u->format_hash_table[hash].key != NULL)
+    {
+      /* See if it matches.  */
+      if (u->format_hash_table[hash].key_len == dtp->format_len)
+	{
+	  /* So far so good.  */
+	  if (strncmp (u->format_hash_table[hash].key,
+	      dtp->format, dtp->format_len) == 0)
+	    return u->format_hash_table[hash].hashed_fmt;
+	}
+    }
+  return NULL;
+}
+
+
 /* next_char()-- Return the next character in the format string.
  * Returns -1 when the string is done.  If the literal flag is set,
  * spaces are significant, otherwise they are not. */
@@ -90,7 +214,8 @@ next_char (format_data *fmt, int literal)
 	return -1;
 
       fmt->format_string_len--;
-      fmt->error_element = c = toupper (*fmt->format_string++);
+      c = toupper (*fmt->format_string++);
+      fmt->error_element = c;
     }
   while ((c == ' ' || c == '\t') && !literal);
 
@@ -141,10 +266,10 @@ get_fnode (format_data *fmt, fnode **head, fnode **tail, format_token t)
 /* free_format_data()-- Free all allocated format data.  */
 
 void
-free_format_data (st_parameter_dt *dtp)
+free_format_data (format_data *fmt)
 {
   fnode_array *fa, *fa_next;
-  format_data *fmt = dtp->u.p.fmt;
+
 
   if (fmt == NULL)
     return;
@@ -156,7 +281,7 @@ free_format_data (st_parameter_dt *dtp)
     }
 
   free_mem (fmt);
-  dtp->u.p.fmt = NULL;
+  fmt = NULL;
 }
 
 
@@ -184,6 +309,14 @@ format_lex (format_data *fmt)
 
   switch (c)
     {
+    case '(':
+      token = FMT_LPAREN;
+      break;
+
+    case ')':
+      token = FMT_RPAREN;
+      break;
+
     case '-':
       negative_flag = 1;
       /* Fall Through */
@@ -276,14 +409,6 @@ format_lex (format_data *fmt)
 
       break;
 
-    case '(':
-      token = FMT_LPAREN;
-      break;
-
-    case ')':
-      token = FMT_RPAREN;
-      break;
-
     case 'X':
       token = FMT_X;
       break;
@@ -455,8 +580,10 @@ parse_format_list (st_parameter_dt *dtp)
   format_token t, u, t2;
   int repeat;
   format_data *fmt = dtp->u.p.fmt;
+  bool save_format;
 
   head = tail = NULL;
+  save_format = !is_internal_unit (dtp);
 
   /* Get the next format item */
  format_item:
@@ -567,6 +694,7 @@ parse_format_list (st_parameter_dt *dtp)
     case FMT_DP:
       notify_std (&dtp->common, GFC_STD_F2003, "Fortran 2003: DC or DP "
 		  "descriptor not allowed");
+      save_format = true;
     /* Fall through.  */
     case FMT_S:
     case FMT_SS:
@@ -592,6 +720,7 @@ parse_format_list (st_parameter_dt *dtp)
       get_fnode (fmt, &head, &tail, FMT_DOLLAR);
       tail->repeat = 1;
       notify_std (&dtp->common, GFC_STD_GNU, "Extension: $ descriptor");
+      save_format = false;
       goto between_desc;
 
 
@@ -689,6 +818,7 @@ parse_format_list (st_parameter_dt *dtp)
 	      fmt->saved_token = t;
 	      fmt->value = 1;	/* Default width */
 	      notify_std (&dtp->common, GFC_STD_GNU, posint_required);
+	      save_format = false;
 	    }
 	}
 
@@ -999,6 +1129,33 @@ format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
 }
 
 
+/* revert()-- Do reversion of the format.  Control reverts to the left
+ * parenthesis that matches the rightmost right parenthesis.  From our
+ * tree structure, we are looking for the rightmost parenthesis node
+ * at the second level, the first level always being a single
+ * parenthesis node.  If this node doesn't exit, we use the top
+ * level. */
+
+static void
+revert (st_parameter_dt *dtp)
+{
+  fnode *f, *r;
+  format_data *fmt = dtp->u.p.fmt;
+
+  dtp->u.p.reversion_flag = 1;
+
+  r = NULL;
+
+  for (f = fmt->array.array[0].u.child; f; f = f->next)
+    if (f->format == FMT_LPAREN)
+      r = f;
+
+  /* If r is NULL because no node was found, the whole tree will be used */
+
+  fmt->array.array[0].current = r;
+  fmt->array.array[0].count = 0;
+}
+
 /* parse_format()-- Parse a format string.  */
 
 void
@@ -1006,6 +1163,21 @@ parse_format (st_parameter_dt *dtp)
 {
   format_data *fmt;
 
+  /* Lookup format string to see if it has already been parsed.  */
+
+  dtp->u.p.fmt = find_parsed_format (dtp);
+
+  if (dtp->u.p.fmt != NULL)
+    {
+      dtp->u.p.fmt->reversion_ok = 0;
+      dtp->u.p.fmt->saved_token = FMT_NONE;
+      dtp->u.p.fmt->saved_format = NULL;
+      reset_fnode_counters (dtp);
+      return;
+    }
+
+  /* Not found so proceed as follows.  */
+
   dtp->u.p.fmt = fmt = get_mem (sizeof (format_data));
   fmt->format_string = dtp->format;
   fmt->format_string_len = dtp->format_len;
@@ -1037,35 +1209,12 @@ parse_format (st_parameter_dt *dtp)
     fmt->error = "Missing initial left parenthesis in format";
 
   if (fmt->error)
-    format_error (dtp, NULL, fmt->error);
-}
-
-
-/* revert()-- Do reversion of the format.  Control reverts to the left
- * parenthesis that matches the rightmost right parenthesis.  From our
- * tree structure, we are looking for the rightmost parenthesis node
- * at the second level, the first level always being a single
- * parenthesis node.  If this node doesn't exit, we use the top
- * level. */
-
-static void
-revert (st_parameter_dt *dtp)
-{
-  fnode *f, *r;
-  format_data *fmt = dtp->u.p.fmt;
-
-  dtp->u.p.reversion_flag = 1;
-
-  r = NULL;
-
-  for (f = fmt->array.array[0].u.child; f; f = f->next)
-    if (f->format == FMT_LPAREN)
-      r = f;
-
-  /* If r is NULL because no node was found, the whole tree will be used */
-
-  fmt->array.array[0].current = r;
-  fmt->array.array[0].count = 0;
+    {
+      format_error (dtp, NULL, fmt->error);
+      free_format_hash_table (dtp->u.p.current_unit);
+      return;
+    }
+  save_parsed_format (dtp);
 }
 
 

libgfortran/io/intrinsics.c

@@ -54,13 +54,13 @@ PREFIX(fgetc) (const int * unit, char * c, gfc_charlen_type c_len)
 
   s = 1;
   memset (c, ' ', c_len);
-  ret = sread (u->s, c, &s);
+  ret = sread (u->s, c, s);
   unlock_unit (u);
 
-  if (ret != 0)
+  if (ret < 0)
     return ret;
 
-  if (s != 1)
+  if (ret != 1)
     return -1;
   else
     return 0;
@@ -119,17 +119,17 @@ int
 PREFIX(fputc) (const int * unit, char * c,
 	       gfc_charlen_type c_len __attribute__((unused)))
 {
-  size_t s;
-  int ret;
+  ssize_t s;
   gfc_unit * u = find_unit (*unit);
 
   if (u == NULL)
     return -1;
 
-  s = 1;
-  ret = swrite (u->s, c, &s);
+  s = swrite (u->s, c, 1);
   unlock_unit (u);
-  return ret;
+  if (s < 0)
+    return -1;
+  return 0;
 }
 
 
@@ -196,7 +196,7 @@ flush_i4 (GFC_INTEGER_4 *unit)
       us = find_unit (*unit);
       if (us != NULL)
 	{
-	  flush (us->s);
+	  sflush (us->s);
 	  unlock_unit (us);
 	}
     }
@@ -219,7 +219,7 @@ flush_i8 (GFC_INTEGER_8 *unit)
       us = find_unit (*unit);
       if (us != NULL)
 	{
-	  flush (us->s);
+	  sflush (us->s);
 	  unlock_unit (us);
 	}
     }
@@ -234,22 +234,17 @@ void
 fseek_sub (int * unit, GFC_IO_INT * offset, int * whence, int * status)
 {
   gfc_unit * u = find_unit (*unit);
-  try result = FAILURE;
+  ssize_t result = -1;
 
   if (u != NULL && is_seekable(u->s))
     {
-      if (*whence == 0)
-        result = sseek(u->s, *offset);                       /* SEEK_SET */
-      else if (*whence == 1)
-        result = sseek(u->s, file_position(u->s) + *offset); /* SEEK_CUR */
-      else if (*whence == 2)
-        result = sseek(u->s, file_length(u->s) + *offset);   /* SEEK_END */
+      result = sseek(u->s, *offset, *whence);
 
       unlock_unit (u);
     }
 
   if (status)
-    *status = (result == FAILURE ? -1 : 0);
+    *status = (result < 0 ? -1 : 0);
 }
 
 
@@ -266,7 +261,7 @@ PREFIX(ftell) (int * unit)
   size_t ret;
   if (u == NULL)
     return ((size_t) -1);
-  ret = (size_t) stream_offset (u->s);
+  ret = (size_t) stell (u->s);
   unlock_unit (u);
   return ret;
 }
@@ -282,7 +277,7 @@ PREFIX(ftell) (int * unit)
       *offset = -1; \
     else \
       { \
-	*offset = stream_offset (u->s); \
+	*offset = stell (u->s); \
 	unlock_unit (u); \
       } \
   }

libgfortran/io/io.h

@@ -49,34 +49,59 @@ struct st_parameter_dt;
 
 typedef struct stream
 {
-  char *(*alloc_w_at) (struct stream *, int *);
-  try (*sfree) (struct stream *);
-  try (*close) (struct stream *);
-  try (*seek) (struct stream *, gfc_offset);
-  try (*trunc) (struct stream *);
-  int (*read) (struct stream *, void *, size_t *);
-  int (*write) (struct stream *, const void *, size_t *);
-  try (*set) (struct stream *, int, size_t);
+  ssize_t (*read) (struct stream *, void *, ssize_t);
+  ssize_t (*write) (struct stream *, const void *, ssize_t);
+  off_t (*seek) (struct stream *, off_t, int);
+  off_t (*tell) (struct stream *);
+  int (*truncate) (struct stream *, off_t);
+  int (*flush) (struct stream *);
+  int (*close) (struct stream *);
 }
 stream;
 
-typedef enum
-{ SYNC_BUFFERED, SYNC_UNBUFFERED, ASYNC }
-io_mode;
+/* Inline functions for doing file I/O given a stream.  */
+static inline ssize_t
+sread (stream * s, void * buf, ssize_t nbyte)
+{
+  return s->read (s, buf, nbyte);
+}
 
-/* Macros for doing file I/O given a stream.  */
+static inline ssize_t
+swrite (stream * s, const void * buf, ssize_t nbyte)
+{
+  return s->write (s, buf, nbyte);
+}
 
-#define sfree(s) ((s)->sfree)(s)
-#define sclose(s) ((s)->close)(s)
+static inline off_t
+sseek (stream * s, off_t offset, int whence)
+{
+  return s->seek (s, offset, whence);
+}
 
-#define salloc_w(s, len) ((s)->alloc_w_at)(s, len)
+static inline off_t
+stell (stream * s)
+{
+  return s->tell (s);
+}
 
-#define sseek(s, pos) ((s)->seek)(s, pos)
-#define struncate(s) ((s)->trunc)(s)
-#define sread(s, buf, nbytes) ((s)->read)(s, buf, nbytes)
-#define swrite(s, buf, nbytes) ((s)->write)(s, buf, nbytes)
+static inline int
+struncate (stream * s, off_t length)
+{
+  return s->truncate (s, length);
+}
+
+static inline int
+sflush (stream * s)
+{
+  return s->flush (s);
+}
+
+static inline int
+sclose (stream * s)
+{
+  return s->close (s);
+}
 
-#define sset(s, c, n) ((s)->set)(s, c, n)
 
 /* Macros for testing what kinds of I/O we are doing.  */
 
@@ -106,6 +131,18 @@ typedef struct array_loop_spec
 }
 array_loop_spec;
 
+/* A stucture to build a hash table for format data.  */
+
+#define FORMAT_HASH_SIZE 16 
+
+typedef struct format_hash_entry
+{
+  char *key;
+  gfc_charlen_type key_len;
+  struct format_data *hashed_fmt;
+}
+format_hash_entry;
+
 /* Representation of a namelist object in libgfortran
 
    Namelist Records
@@ -127,7 +164,6 @@ array_loop_spec;
 
 typedef struct namelist_type
 {
-
   /* Object type, stored as GFC_DTYPE_xxxx.  */
   bt type;
 
@@ -538,10 +574,9 @@ unit_flags;
 typedef struct fbuf
 {
   char *buf;			/* Start of buffer.  */
-  size_t len;			/* Length of buffer.  */
-  size_t act;			/* Active bytes in buffer.  */
-  size_t flushed;		/* Flushed bytes from beginning of buffer.  */
-  size_t pos;			/* Current position in buffer.  */
+  int len;			/* Length of buffer.  */
+  int act;			/* Active bytes in buffer.  */
+  int pos;			/* Current position in buffer.  */
 }
 fbuf;
 
@@ -599,6 +634,9 @@ typedef struct gfc_unit
 
   int file_len;
   char *file;
+
+  /* The format hash table.  */
+  struct format_hash_entry format_hash_table[FORMAT_HASH_SIZE];
   
   /* Formatting buffer.  */
   struct fbuf *fbuf;
@@ -683,6 +721,12 @@ internal_proto(open_external);
 extern stream *open_internal (char *, int, gfc_offset);
 internal_proto(open_internal);
 
+extern char * mem_alloc_w (stream *, int *);
+internal_proto(mem_alloc_w);
+
+extern char * mem_alloc_r (stream *, int *);
+internal_proto(mem_alloc_w);
+
 extern stream *input_stream (void);
 internal_proto(input_stream);
 
@@ -698,12 +742,6 @@ internal_proto(compare_file_filename);
 extern gfc_unit *find_file (const char *file, gfc_charlen_type file_len);
 internal_proto(find_file);
 
-extern int stream_at_bof (stream *);
-internal_proto(stream_at_bof);
-
-extern int stream_at_eof (stream *);
-internal_proto(stream_at_eof);
-
 extern int delete_file (gfc_unit *);
 internal_proto(delete_file);
 
@@ -734,9 +772,6 @@ internal_proto(inquire_readwrite);
 extern gfc_offset file_length (stream *);
 internal_proto(file_length);
 
-extern gfc_offset file_position (stream *);
-internal_proto(file_position);
-
 extern int is_seekable (stream *);
 internal_proto(is_seekable);
 
@@ -752,18 +787,12 @@ internal_proto(flush_if_preconnected);
 extern void empty_internal_buffer(stream *);
 internal_proto(empty_internal_buffer);
 
-extern try flush (stream *);
-internal_proto(flush);
-
 extern int stream_isatty (stream *);
 internal_proto(stream_isatty);
 
 extern char * stream_ttyname (stream *);
 internal_proto(stream_ttyname);
 
-extern gfc_offset stream_offset (stream *s);
-internal_proto(stream_offset);
-
 extern int unpack_filename (char *, const char *, int);
 internal_proto(unpack_filename);
 
@@ -807,6 +836,9 @@ internal_proto(update_position);
 extern void finish_last_advance_record (gfc_unit *u);
 internal_proto (finish_last_advance_record);
 
+extern int unit_truncate (gfc_unit *, gfc_offset, st_parameter_common *);
+internal_proto (unit_truncate);
+
 /* open.c */
 
 extern gfc_unit *new_unit (st_parameter_open *, gfc_unit *, unit_flags *);
@@ -826,9 +858,18 @@ internal_proto(unget_format);
 extern void format_error (st_parameter_dt *, const fnode *, const char *);
 internal_proto(format_error);
 
-extern void free_format_data (st_parameter_dt *);
+extern void free_format_data (struct format_data *);
 internal_proto(free_format_data);
 
+extern void free_format_hash_table (gfc_unit *);
+internal_proto(free_format_hash_table);
+
+extern void init_format_hash (st_parameter_dt *);
+internal_proto(init_format_hash);
+
+extern void free_format_hash (st_parameter_dt *);
+internal_proto(free_format_hash);
+
 /* transfer.c */
 
 #define SCRATCH_SIZE 300
@@ -836,7 +877,7 @@ internal_proto(free_format_data);
 extern const char *type_name (bt);
 internal_proto(type_name);
 
-extern try read_block_form (st_parameter_dt *, void *, size_t *);
+extern void * read_block_form (st_parameter_dt *, int *);
 internal_proto(read_block_form);
 
 extern char *read_sf (st_parameter_dt *, int *, int);
@@ -862,6 +903,9 @@ internal_proto (reverse_memcpy);
 extern void st_wait (st_parameter_wait *);
 export_proto(st_wait);
 
+extern void hit_eof (st_parameter_dt *);
+internal_proto(hit_eof);
+
 /* read.c */
 
 extern void set_integer (void *, GFC_INTEGER_LARGEST, int);
@@ -968,24 +1012,39 @@ extern size_t size_from_complex_kind (int);
 internal_proto(size_from_complex_kind);
 
 /* fbuf.c */
-extern void fbuf_init (gfc_unit *, size_t);
+extern void fbuf_init (gfc_unit *, int);
 internal_proto(fbuf_init);
 
 extern void fbuf_destroy (gfc_unit *);
 internal_proto(fbuf_destroy);
 
-extern void fbuf_reset (gfc_unit *);
+extern int fbuf_reset (gfc_unit *);
 internal_proto(fbuf_reset);
 
-extern char * fbuf_alloc (gfc_unit *, size_t);
+extern char * fbuf_alloc (gfc_unit *, int);
 internal_proto(fbuf_alloc);
 
-extern int fbuf_flush (gfc_unit *, int);
+extern int fbuf_flush (gfc_unit *, unit_mode);
 internal_proto(fbuf_flush);
 
-extern int fbuf_seek (gfc_unit *, gfc_offset);
+extern int fbuf_seek (gfc_unit *, int, int);
 internal_proto(fbuf_seek);
 
+extern char * fbuf_read (gfc_unit *, int *);
+internal_proto(fbuf_read);
+
+/* Never call this function, only use fbuf_getc().  */
+extern int fbuf_getc_refill (gfc_unit *);
+internal_proto(fbuf_getc_refill);
+
+static inline int
+fbuf_getc (gfc_unit * u)
+{
+  if (u->fbuf->pos < u->fbuf->act)
+    return (unsigned char) u->fbuf->buf[u->fbuf->pos++];
+  return fbuf_getc_refill (u);
+}
+
 /* lock.c */
 extern void free_ionml (st_parameter_dt *);
 internal_proto(free_ionml);

libgfortran/io/list_read.c

@@ -33,6 +33,7 @@ Boston, MA 02110-1301, USA.  */
 
 #include "io.h"
 #include <string.h>
+#include <stdlib.h>
 #include <ctype.h>
 
 
@@ -79,9 +80,8 @@ push_char (st_parameter_dt *dtp, char c)
 
   if (dtp->u.p.saved_string == NULL)
     {
-      if (dtp->u.p.scratch == NULL)
-	dtp->u.p.scratch = get_mem (SCRATCH_SIZE);
-      dtp->u.p.saved_string = dtp->u.p.scratch;
+      dtp->u.p.saved_string = get_mem (SCRATCH_SIZE);
+      // memset below should be commented out.
       memset (dtp->u.p.saved_string, 0, SCRATCH_SIZE);
       dtp->u.p.saved_length = SCRATCH_SIZE;
       dtp->u.p.saved_used = 0;
@@ -90,15 +90,15 @@ push_char (st_parameter_dt *dtp, char c)
   if (dtp->u.p.saved_used >= dtp->u.p.saved_length)
     {
       dtp->u.p.saved_length = 2 * dtp->u.p.saved_length;
-      new = get_mem (2 * dtp->u.p.saved_length);
-
-      memset (new, 0, 2 * dtp->u.p.saved_length);
-
-      memcpy (new, dtp->u.p.saved_string, dtp->u.p.saved_used);
-      if (dtp->u.p.saved_string != dtp->u.p.scratch)
-	free_mem (dtp->u.p.saved_string);
-
+      new = realloc (dtp->u.p.saved_string, dtp->u.p.saved_length);
+      if (new == NULL)
+	generate_error (&dtp->common, LIBERROR_OS, NULL);
       dtp->u.p.saved_string = new;
+      
+      // Also this should not be necessary.
+      memset (new + dtp->u.p.saved_used, 0, 
+	      dtp->u.p.saved_length - dtp->u.p.saved_used);
+
     }
 
   dtp->u.p.saved_string[dtp->u.p.saved_used++] = c;
@@ -113,8 +113,7 @@ free_saved (st_parameter_dt *dtp)
   if (dtp->u.p.saved_string == NULL)
     return;
 
-  if (dtp->u.p.saved_string != dtp->u.p.scratch)
-    free_mem (dtp->u.p.saved_string);
+  free_mem (dtp->u.p.saved_string);
 
   dtp->u.p.saved_string = NULL;
   dtp->u.p.saved_used = 0;
@@ -140,9 +139,10 @@ free_line (st_parameter_dt *dtp)
 static char
 next_char (st_parameter_dt *dtp)
 {
-  size_t length;
+  ssize_t length;
   gfc_offset record;
   char c;
+  int cc;
 
   if (dtp->u.p.last_char != '\0')
     {
@@ -194,7 +194,7 @@ next_char (st_parameter_dt *dtp)
 	    }
 
 	  record *= dtp->u.p.current_unit->recl;
-	  if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
+	  if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
 	    longjmp (*dtp->u.p.eof_jump, 1);
 
 	  dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
@@ -204,19 +204,15 @@ next_char (st_parameter_dt *dtp)
 
   /* Get the next character and handle end-of-record conditions.  */
 
-  length = 1;
-
-  if (sread (dtp->u.p.current_unit->s, &c, &length) != 0)
-    {
-	generate_error (&dtp->common, LIBERROR_OS, NULL);
-	return '\0';
-    }
-  
-  if (is_stream_io (dtp) && length == 1)
-    dtp->u.p.current_unit->strm_pos++;
-
   if (is_internal_unit (dtp))
     {
+      length = sread (dtp->u.p.current_unit->s, &c, 1);
+      if (length < 0)
+	{
+	  generate_error (&dtp->common, LIBERROR_OS, NULL);
+	  return '\0';
+	}
+  
       if (is_array_io (dtp))
 	{
 	  /* Check whether we hit EOF.  */ 
@@ -240,13 +236,20 @@ next_char (st_parameter_dt *dtp)
     }
   else
     {
-      if (length == 0)
+      cc = fbuf_getc (dtp->u.p.current_unit);
+
+      if (cc == EOF)
 	{
 	  if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
 	    longjmp (*dtp->u.p.eof_jump, 1);
 	  dtp->u.p.current_unit->endfile = AT_ENDFILE;
 	  c = '\n';
 	}
+      else
+	c = (char) cc;
+      if (is_stream_io (dtp) && cc != EOF)
+	dtp->u.p.current_unit->strm_pos++;
+
     }
 done:
   dtp->u.p.at_eol = (c == '\n' || c == '\r');
@@ -1698,7 +1701,7 @@ list_formatted_read_scalar (st_parameter_dt *dtp, volatile bt type, void *p,
       dtp->u.p.input_complete = 0;
       dtp->u.p.repeat_count = 1;
       dtp->u.p.at_eol = 0;
-
+      
       c = eat_spaces (dtp);
       if (is_separator (c))
 	{
@@ -1726,6 +1729,9 @@ list_formatted_read_scalar (st_parameter_dt *dtp, volatile bt type, void *p,
 	    return;
 	  goto set_value;
 	}
+	
+      if (dtp->u.p.input_complete)
+	goto cleanup;
 
       if (dtp->u.p.input_complete)
 	goto cleanup;
@@ -1853,6 +1859,8 @@ finish_list_read (st_parameter_dt *dtp)
 
   free_saved (dtp);
 
+  fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
+
   if (dtp->u.p.at_eol)
     {
       dtp->u.p.at_eol = 0;
@@ -2261,8 +2269,8 @@ nml_query (st_parameter_dt *dtp, char c)
 
       /* Flush the stream to force immediate output.  */
 
-      fbuf_flush (dtp->u.p.current_unit, 1);
-      flush (dtp->u.p.current_unit->s);
+      fbuf_flush (dtp->u.p.current_unit, WRITING);
+      sflush (dtp->u.p.current_unit->s);
       unlock_unit (dtp->u.p.current_unit);
     }
 
@@ -2903,7 +2911,7 @@ find_nml_name:
 	  st_printf ("%s\n", nml_err_msg);
 	  if (u != NULL)
 	    {
-	      flush (u->s);
+	      sflush (u->s);
 	      unlock_unit (u);
 	    }
         }

libgfortran/io/open.c

@@ -155,7 +155,7 @@ static const st_option async_opt[] =
 static void
 test_endfile (gfc_unit * u)
 {
-  if (u->endfile == NO_ENDFILE && file_length (u->s) == file_position (u->s))
+  if (u->endfile == NO_ENDFILE && file_length (u->s) == stell (u->s))
     u->endfile = AT_ENDFILE;
 }
 
@@ -271,7 +271,7 @@ edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
       break;
 
     case POSITION_REWIND:
-      if (sseek (u->s, 0) == FAILURE)
+      if (sseek (u->s, 0, SEEK_SET) != 0)
 	goto seek_error;
 
       u->current_record = 0;
@@ -281,7 +281,7 @@ edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
       break;
 
     case POSITION_APPEND:
-      if (sseek (u->s, file_length (u->s)) == FAILURE)
+      if (sseek (u->s, 0, SEEK_END) < 0)
 	goto seek_error;
 
       if (flags->access != ACCESS_STREAM)
@@ -557,7 +557,7 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
 
   if (flags->position == POSITION_APPEND)
     {
-      if (sseek (u->s, file_length (u->s)) == FAILURE)
+      if (sseek (u->s, 0, SEEK_END) < 0)
 	generate_error (&opp->common, LIBERROR_OS, NULL);
       u->endfile = AT_ENDFILE;
     }
@@ -611,7 +611,8 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
     {
       u->maxrec = max_offset;
       u->recl = 1;
-      u->strm_pos = file_position (u->s) + 1;
+      u->bytes_left = 1;
+      u->strm_pos = stell (u->s) + 1;
     }
 
   memmove (u->file, opp->file, opp->file_len);
@@ -627,7 +628,7 @@ new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
   if (flags->status == STATUS_SCRATCH && opp->file != NULL)
     free_mem (opp->file);
     
-  if (flags->form == FORM_FORMATTED && (flags->action != ACTION_READ))
+  if (flags->form == FORM_FORMATTED)
     {
       if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
         fbuf_init (u, u->recl);

libgfortran/io/unit.c

@@ -540,6 +540,8 @@ init_units (void)
       u->file_len = strlen (stdin_name);
       u->file = get_mem (u->file_len);
       memmove (u->file, stdin_name, u->file_len);
+
+      fbuf_init (u, 0);
     
       __gthread_mutex_unlock (&u->lock);
     }
@@ -640,7 +642,8 @@ close_unit_1 (gfc_unit *u, int locked)
     free_mem (u->file);
   u->file = NULL;
   u->file_len = 0;
-  
+
+  free_format_hash_table (u);  
   fbuf_destroy (u);
 
   if (!locked)
@@ -697,15 +700,62 @@ close_units (void)
 void
 update_position (gfc_unit *u)
 {
-  if (file_position (u->s) == 0)
+  if (stell (u->s) == 0)
     u->flags.position = POSITION_REWIND;
-  else if (file_length (u->s) == file_position (u->s))
+  else if (file_length (u->s) == stell (u->s))
     u->flags.position = POSITION_APPEND;
   else
     u->flags.position = POSITION_ASIS;
 }
 
 
+/* High level interface to truncate a file safely, i.e. flush format
+   buffers, check that it's a regular file, and generate error if that
+   occurs.  Just like POSIX ftruncate, returns 0 on success, -1 on
+   failure.  */
+
+int
+unit_truncate (gfc_unit * u, gfc_offset pos, st_parameter_common * common)
+{
+  int ret;
+
+  /* Make sure format buffer is flushed.  */
+  if (u->flags.form == FORM_FORMATTED)
+    {
+      if (u->mode == READING)
+	pos += fbuf_reset (u);
+      else
+	fbuf_flush (u, u->mode);
+    }
+  
+  /* Don't try to truncate a special file, just pretend that it
+     succeeds.  */
+  if (is_special (u->s) || !is_seekable (u->s))
+    {
+      sflush (u->s);
+      return 0;
+    }
+
+  /* struncate() should flush the stream buffer if necessary, so don't
+     bother calling sflush() here.  */
+  ret = struncate (u->s, pos);
+
+  if (ret != 0)
+    {
+      generate_error (common, LIBERROR_OS, NULL);
+      u->endfile = NO_ENDFILE;
+      u->flags.position = POSITION_ASIS;
+    }
+  else
+    {
+      u->endfile = AT_ENDFILE;
+      u->flags.position = POSITION_APPEND;
+    }
+
+  return ret;
+}
+
+
 /* filename_from_unit()-- If the unit_number exists, return a pointer to the
    name of the associated file, otherwise return the empty string.  The caller
    must free memory allocated for the filename string.  */
@@ -746,23 +796,25 @@ finish_last_advance_record (gfc_unit *u)
 {
   
   if (u->saved_pos > 0)
-    fbuf_seek (u, u->saved_pos);
-    
-  fbuf_flush (u, 1);
+    fbuf_seek (u, u->saved_pos, SEEK_CUR);
 
   if (!(u->unit_number == options.stdout_unit
 	|| u->unit_number == options.stderr_unit))
     {
-      size_t len;
-
-      const char crlf[] = "\r\n";
 #ifdef HAVE_CRLF
-      len = 2;
+      const int len = 2;
 #else
-      len = 1;
+      const int len = 1;
 #endif
-      if (swrite (u->s, &crlf[2-len], &len) != 0)
+      char *p = fbuf_alloc (u, len);
+      if (!p)
 	os_error ("Completing record after ADVANCE_NO failed");
+#ifdef HAVE_CRLF
+      *(p++) = '\r';
+#endif
+      *p = '\n';
     }
+
+  fbuf_flush (u, u->mode);
 }
 

libgfortran/io/write.c

@@ -113,7 +113,7 @@ write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
   gfc_char4_t c;
   static const uchar masks[6] =  { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
   static const uchar limits[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
-  size_t nbytes;
+  int nbytes;
   uchar buf[6], d, *q; 
 
   /* Take care of preceding blanks.  */
@@ -784,8 +784,7 @@ write_x (st_parameter_dt *dtp, int len, int nspaces)
   p = write_block (dtp, len);
   if (p == NULL)
     return;
-
-  if (nspaces > 0)
+  if (nspaces > 0 && len - nspaces >= 0)
     memset (&p[len - nspaces], ' ', nspaces);
 }
 
@@ -1173,7 +1172,7 @@ namelist_write_newline (st_parameter_dt *dtp)
 	  /* Now seek to this record */
 	  record = record * dtp->u.p.current_unit->recl;
 
-	  if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
+	  if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
 	    {
 	      generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
 	      return;