[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/read.c

@@ -33,6 +33,7 @@ Boston, MA 02110-1301, USA.  */
 #include <errno.h>
 #include <ctype.h>
 #include <stdlib.h>
+#include <assert.h>
 
 typedef unsigned char uchar;
 
@@ -141,38 +142,30 @@ convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
   switch (length)
     {
     case 4:
-      {
-	GFC_REAL_4 tmp =
+      *((GFC_REAL_4*) dest) =
 #if defined(HAVE_STRTOF)
-	  strtof (buffer, NULL);
+	strtof (buffer, NULL);
 #else
-	  (GFC_REAL_4) strtod (buffer, NULL);
+	(GFC_REAL_4) strtod (buffer, NULL);
 #endif
-	memcpy (dest, (void *) &tmp, length);
-      }
       break;
+
     case 8:
-      {
-	GFC_REAL_8 tmp = strtod (buffer, NULL);
-	memcpy (dest, (void *) &tmp, length);
-      }
+      *((GFC_REAL_8*) dest) = strtod (buffer, NULL);
       break;
+
 #if defined(HAVE_GFC_REAL_10) && defined (HAVE_STRTOLD)
     case 10:
-      {
-	GFC_REAL_10 tmp = strtold (buffer, NULL);
-	memcpy (dest, (void *) &tmp, length);
-      }
+      *((GFC_REAL_10*) dest) = strtold (buffer, NULL);
       break;
 #endif
+
 #if defined(HAVE_GFC_REAL_16) && defined (HAVE_STRTOLD)
     case 16:
-      {
-	GFC_REAL_16 tmp = strtold (buffer, NULL);
-	memcpy (dest, (void *) &tmp, length);
-      }
+      *((GFC_REAL_16*) dest) = strtold (buffer, NULL);
       break;
 #endif
+
     default:
       internal_error (&dtp->common, "Unsupported real kind during IO");
     }
@@ -195,13 +188,13 @@ void
 read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 {
   char *p;
-  size_t w;
+  int w;
 
   w = f->u.w;
 
-  p = gfc_alloca (w);
+  p = read_block_form (dtp, &w);
 
-  if (read_block_form (dtp, p, &w) == FAILURE)
+  if (p == NULL)
     return;
 
   while (*p == ' ')
@@ -238,28 +231,26 @@ read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 }
 
 
-static inline gfc_char4_t
-read_utf8 (st_parameter_dt *dtp, size_t *nbytes) 
+static gfc_char4_t
+read_utf8 (st_parameter_dt *dtp, int *nbytes) 
 {
   static const uchar masks[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 };
   static const uchar patns[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
-  static uchar buffer[6];
-  size_t i, nb, nread;
+  int i, nb, nread;
   gfc_char4_t c;
-  int status;
   char *s;
 
   *nbytes = 1;
-  s = (char *) &buffer[0];
-  status = read_block_form (dtp, s, nbytes);
-  if (status == FAILURE)
+
+  s = read_block_form (dtp, nbytes);
+  if (s == NULL)
     return 0;
 
   /* If this is a short read, just return.  */
   if (*nbytes == 0)
     return 0;
 
-  c = buffer[0];
+  c = (uchar) s[0];
   if (c < 0x80)
     return c;
 
@@ -274,9 +265,8 @@ read_utf8 (st_parameter_dt *dtp, size_t *nbytes)
   c = (c & masks[nb-1]);
   nread = nb - 1;
 
-  s = (char *) &buffer[1];
-  status = read_block_form (dtp, s, &nread);
-  if (status == FAILURE)
+  s = read_block_form (dtp, &nread);
+  if (s == NULL)
     return 0;
   /* Decode the bytes read.  */
   for (i = 1; i < nb; i++)
@@ -309,14 +299,14 @@ read_utf8 (st_parameter_dt *dtp, size_t *nbytes)
 
 
 static void
-read_utf8_char1 (st_parameter_dt *dtp, char *p, int len, size_t width)
+read_utf8_char1 (st_parameter_dt *dtp, char *p, int len, int width)
 {
   gfc_char4_t c;
   char *dest;
-  size_t nbytes;
+  int nbytes;
   int i, j;
 
-  len = ((int) width < len) ? len : (int) width;
+  len = (width < len) ? len : width;
 
   dest = (char *) p;
 
@@ -339,21 +329,19 @@ read_utf8_char1 (st_parameter_dt *dtp, char *p, int len, size_t width)
 }
 
 static void
-read_default_char1 (st_parameter_dt *dtp, char *p, int len, size_t width)
+read_default_char1 (st_parameter_dt *dtp, char *p, int len, int width)
 {
   char *s;
-  int m, n, status;
+  int m, n;
 
-  s = gfc_alloca (width);
-
-  status = read_block_form (dtp, s, &width);
+  s = read_block_form (dtp, &width);
   
-  if (status == FAILURE)
+  if (s == NULL)
     return;
-  if (width > (size_t) len)
+  if (width > len)
      s += (width - len);
 
-  m = ((int) width > len) ? len : (int) width;
+  m = (width > len) ? len : width;
   memcpy (p, s, m);
 
   n = len - width;
@@ -363,13 +351,13 @@ read_default_char1 (st_parameter_dt *dtp, char *p, int len, size_t width)
 
 
 static void
-read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, size_t width)
+read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, int width)
 {
   gfc_char4_t *dest;
-  size_t nbytes;
+  int nbytes;
   int i, j;
 
-  len = ((int) width < len) ? len : (int) width;
+  len = (width < len) ? len : width;
 
   dest = (gfc_char4_t *) p;
 
@@ -391,19 +379,17 @@ read_utf8_char4 (st_parameter_dt *dtp, void *p, int len, size_t width)
 
 
 static void
-read_default_char4 (st_parameter_dt *dtp, char *p, int len, size_t width)
+read_default_char4 (st_parameter_dt *dtp, char *p, int len, int width)
 {
   char *s;
   gfc_char4_t *dest;
-  int m, n, status;
-
-  s = gfc_alloca (width);
+  int m, n;
 
-  status = read_block_form (dtp, s, &width);
+  s = read_block_form (dtp, &width);
   
-  if (status == FAILURE)
+  if (s == NULL)
     return;
-  if (width > (size_t) len)
+  if (width > len)
      s += (width - len);
 
   m = ((int) width > len) ? len : (int) width;
@@ -425,7 +411,7 @@ void
 read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
 {
   int wi;
-  size_t w;
+  int w;
 
   wi = f->u.w;
   if (wi == -1) /* '(A)' edit descriptor  */
@@ -451,13 +437,11 @@ read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
 void
 read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, int length)
 {
-  int wi;
-  size_t w;
+  int w;
 
-  wi = f->u.w;
-  if (wi == -1) /* '(A)' edit descriptor  */
-    wi = length;
-  w = wi;
+  w = f->u.w;
+  if (w == -1) /* '(A)' edit descriptor  */
+    w = length;
 
   /* Read in w characters, treating comma as not a separator.  */
   dtp->u.p.sf_read_comma = 0;
@@ -532,18 +516,15 @@ read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
   GFC_UINTEGER_LARGEST value, maxv, maxv_10;
   GFC_INTEGER_LARGEST v;
   int w, negative; 
-  size_t wu;
   char c, *p;
 
-  wu = f->u.w;
+  w = f->u.w;
 
-  p = gfc_alloca (wu);
+  p = read_block_form (dtp, &w);
 
-  if (read_block_form (dtp, p, &wu) == FAILURE)
+  if (p == NULL)
     return;
 
-  w = wu;
-
   p = eat_leading_spaces (&w, p);
   if (w == 0)
     {
@@ -636,17 +617,14 @@ read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
   GFC_INTEGER_LARGEST v;
   int w, negative;
   char c, *p;
-  size_t wu;
 
-  wu = f->u.w;
+  w = f->u.w;
 
-  p = gfc_alloca (wu);
+  p = read_block_form (dtp, &w);
 
-  if (read_block_form (dtp, p, &wu) == FAILURE)
+  if (p == NULL)
     return;
 
-  w = wu;
-
   p = eat_leading_spaces (&w, p);
   if (w == 0)
     {
@@ -783,75 +761,83 @@ read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
 void
 read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 {
-  size_t wu;
   int w, seen_dp, exponent;
-  int exponent_sign, val_sign;
-  int ndigits;
-  int edigits;
-  int i;
-  char *p, *buffer;
-  char *digits;
-  char scratch[SCRATCH_SIZE];
-
-  val_sign = 1;
-  seen_dp = 0;
-  wu = f->u.w;
+  int exponent_sign;
+  const char *p;
+  char *buffer;
+  char *out;
+  int seen_int_digit; /* Seen a digit before the decimal point?  */
+  int seen_dec_digit; /* Seen a digit after the decimal point?  */
 
-  p = gfc_alloca (wu);
+  seen_dp = 0;
+  seen_int_digit = 0;
+  seen_dec_digit = 0;
+  exponent_sign = 1;
+  exponent = 0;
+  w = f->u.w;
 
-  if (read_block_form (dtp, p, &wu) == FAILURE)
+  /* Read in the next block.  */
+  p = read_block_form (dtp, &w);
+  if (p == NULL)
     return;
-
-  w = wu;
-
-  p = eat_leading_spaces (&w, p);
+  p = eat_leading_spaces (&w, (char*) p);
   if (w == 0)
     goto zero;
 
-  /* Optional sign */
+  /* In this buffer we're going to re-format the number cleanly to be parsed
+     by convert_real in the end; this assures we're using strtod from the
+     C library for parsing and thus probably get the best accuracy possible.
+     This process may add a '+0.0' in front of the number as well as change the
+     exponent because of an implicit decimal point or the like.  Thus allocating
+     strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
+     original buffer had should be enough.  */
+  buffer = gfc_alloca (w + 11);
+  out = buffer;
 
+  /* Optional sign */
   if (*p == '-' || *p == '+')
     {
       if (*p == '-')
-        val_sign = -1;
-      p++;
-      w--;
+	*(out++) = '-';
+      ++p;
+      --w;
     }
 
-  exponent_sign = 1;
-  p = eat_leading_spaces (&w, p);
+  p = eat_leading_spaces (&w, (char*) p);
   if (w == 0)
     goto zero;
 
-  /* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D')
-     is required at this point */
-
-  if (!isdigit (*p) && *p != '.' && *p != ',' && *p != 'd' && *p != 'D'
-      && *p != 'e' && *p != 'E')
-    goto bad_float;
-
-  /* Remember the position of the first digit.  */
-  digits = p;
-  ndigits = 0;
-
-  /* Scan through the string to find the exponent.  */
+  /* Process the mantissa string.  */
   while (w > 0)
     {
       switch (*p)
 	{
 	case ',':
-	  if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA
-               && *p == ',')
-	    *p = '.';
-	  else
+	  if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA)
 	    goto bad_float;
-	  /* Fall through */
+	  /* Fall through.  */
 	case '.':
 	  if (seen_dp)
 	    goto bad_float;
+	  if (!seen_int_digit)
+	    *(out++) = '0';
+	  *(out++) = '.';
 	  seen_dp = 1;
-	  /* Fall through */
+	  break;
 
+	case ' ':
+	  if (dtp->u.p.blank_status == BLANK_ZERO)
+	    {
+	      *(out++) = '0';
+	      goto found_digit;
+	    }
+	  else if (dtp->u.p.blank_status == BLANK_NULL)
+	    break;
+	  else
+	    /* TODO: Should we check instead that there are only trailing
+	       blanks here, as is done below for exponents?  */
+	    goto done;
+	  /* Fall through.  */
 	case '0':
 	case '1':
 	case '2':
@@ -862,207 +848,173 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 	case '7':
 	case '8':
 	case '9':
-	case ' ':
-	  ndigits++;
-	  p++;
-	  w--;
+	  *(out++) = *p;
+found_digit:
+	  if (!seen_dp)
+	    seen_int_digit = 1;
+	  else
+	    seen_dec_digit = 1;
 	  break;
 
 	case '-':
-	  exponent_sign = -1;
-	  /* Fall through */
-
 	case '+':
-	  p++;
-	  w--;
-	  goto exp2;
+	  goto exponent;
 
-	case 'd':
 	case 'e':
-	case 'D':
 	case 'E':
-	  p++;
-	  w--;
-	  goto exp1;
+	case 'd':
+	case 'D':
+	  ++p;
+	  --w;
+	  goto exponent;
 
 	default:
 	  goto bad_float;
 	}
-    }
 
-  /* No exponent has been seen, so we use the current scale factor */
-  exponent = -dtp->u.p.scale_factor;
-  goto done;
-
- bad_float:
-  generate_error (&dtp->common, LIBERROR_READ_VALUE,
-		  "Bad value during floating point read");
-  next_record (dtp, 1);
-  return;
-
-  /* The value read is zero */
- zero:
-  switch (length)
-    {
-      case 4:
-	*((GFC_REAL_4 *) dest) = 0;
-	break;
-
-      case 8:
-	*((GFC_REAL_8 *) dest) = 0;
-	break;
-
-#ifdef HAVE_GFC_REAL_10
-      case 10:
-	*((GFC_REAL_10 *) dest) = 0;
-	break;
-#endif
-
-#ifdef HAVE_GFC_REAL_16
-      case 16:
-	*((GFC_REAL_16 *) dest) = 0;
-	break;
-#endif
-
-      default:
-	internal_error (&dtp->common, "Unsupported real kind during IO");
+      ++p;
+      --w;
     }
-  return;
+  
+  /* No exponent has been seen, so we use the current scale factor.  */
+  exponent = - dtp->u.p.scale_factor;
+  goto done;
 
-  /* At this point the start of an exponent has been found */
- exp1:
-  while (w > 0 && *p == ' ')
+  /* At this point the start of an exponent has been found.  */
+exponent:
+  p = eat_leading_spaces (&w, (char*) p);
+  if (*p == '-' || *p == '+')
     {
-      w--;
-      p++;
+      if (*p == '-')
+	exponent_sign = -1;
+      ++p;
+      --w;
     }
 
-  switch (*p)
-    {
-    case '-':
-      exponent_sign = -1;
-      /* Fall through */
-
-    case '+':
-      p++;
-      w--;
-      break;
-    }
+  /* At this point a digit string is required.  We calculate the value
+     of the exponent in order to take account of the scale factor and
+     the d parameter before explict conversion takes place.  */
 
   if (w == 0)
     goto bad_float;
 
-  /* At this point a digit string is required.  We calculate the value
-     of the exponent in order to take account of the scale factor and
-     the d parameter before explict conversion takes place. */
- exp2:
-  /* Normal processing of exponent */
-  exponent = 0;
   if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
     {
       while (w > 0 && isdigit (*p))
-        {
-          exponent = 10 * exponent + *p - '0';
-          p++;
-          w--;
-        }
-        
-      /* Only allow trailing blanks */
-
+	{
+	  exponent *= 10;
+	  exponent += *p - '0';
+	  ++p;
+	  --w;
+	}
+	
+      /* Only allow trailing blanks.  */
       while (w > 0)
-        {
-          if (*p != ' ')
+	{
+	  if (*p != ' ')
 	    goto bad_float;
-          p++;
-          w--;
-        }
+	  ++p;
+	  --w;
+	}
     }    
-  else  /* BZ or BN status is enabled */
+  else  /* BZ or BN status is enabled.  */
     {
       while (w > 0)
-        {
-          if (*p == ' ')
-            {
-	      if (dtp->u.p.blank_status == BLANK_ZERO) *p = '0';
-	      if (dtp->u.p.blank_status == BLANK_NULL)
-                {
-                  p++;
-                  w--;
-                  continue;
-                }
-            }
-          else if (!isdigit (*p))
-            goto bad_float;
-
-          exponent = 10 * exponent + *p - '0';
-          p++;
-          w--;
-        }
+	{
+	  if (*p == ' ')
+	    {
+	      if (dtp->u.p.blank_status == BLANK_ZERO)
+		exponent *= 10;
+	      else
+		assert (dtp->u.p.blank_status == BLANK_NULL);
+	    }
+	  else if (!isdigit (*p))
+	    goto bad_float;
+	  else
+	    {
+	      exponent *= 10;
+	      exponent += *p - '0';
+	    }
+
+	  ++p;
+	  --w;
+	}
     }
 
-  exponent = exponent * exponent_sign;
+  exponent *= exponent_sign;
 
- done:
+done:
   /* Use the precision specified in the format if no decimal point has been
      seen.  */
   if (!seen_dp)
     exponent -= f->u.real.d;
 
-  if (exponent > 0)
-    {
-      edigits = 2;
-      i = exponent;
-    }
-  else
-    {
-      edigits = 3;
-      i = -exponent;
-    }
+  /* Output a trailing '0' after decimal point if not yet found.  */
+  if (seen_dp && !seen_dec_digit)
+    *(out++) = '0';
 
-  while (i >= 10)
+  /* Print out the exponent to finish the reformatted number.  Maximum 4
+     digits for the exponent.  */
+  if (exponent != 0)
     {
-      i /= 10;
-      edigits++;
-    }
+      int dig;
 
-  i = ndigits + edigits + 1;
-  if (val_sign < 0)
-    i++;
+      *(out++) = 'e';
+      if (exponent < 0)
+	{
+	  *(out++) = '-';
+	  exponent = - exponent;
+	}
 
-  if (i < SCRATCH_SIZE) 
-    buffer = scratch;
-  else
-    buffer = get_mem (i);
-
-  /* Reformat the string into a temporary buffer.  As we're using atof it's
-     easiest to just leave the decimal point in place.  */
-  p = buffer;
-  if (val_sign < 0)
-    *(p++) = '-';
-  for (; ndigits > 0; ndigits--)
-    {
-      if (*digits == ' ')
-        {
-	  if (dtp->u.p.blank_status == BLANK_ZERO) *digits = '0';
-	  if (dtp->u.p.blank_status == BLANK_NULL)
-            {
-              digits++;
-              continue;
-            } 
-        }
-      *p = *digits;
-      p++;
-      digits++;
+      assert (exponent < 10000);
+      for (dig = 3; dig >= 0; --dig)
+	{
+	  out[dig] = (char) ('0' + exponent % 10);
+	  exponent /= 10;
+	}
+      out += 4;
     }
-  *(p++) = 'e';
-  sprintf (p, "%d", exponent);
+  *(out++) = '\0';
 
   /* Do the actual conversion.  */
   convert_real (dtp, dest, buffer, length);
 
-  if (buffer != scratch)
-     free_mem (buffer);
+  return;
 
+  /* The value read is zero.  */
+zero:
+  switch (length)
+    {
+      case 4:
+	*((GFC_REAL_4 *) dest) = 0.0;
+	break;
+
+      case 8:
+	*((GFC_REAL_8 *) dest) = 0.0;
+	break;
+
+#ifdef HAVE_GFC_REAL_10
+      case 10:
+	*((GFC_REAL_10 *) dest) = 0.0;
+	break;
+#endif
+
+#ifdef HAVE_GFC_REAL_16
+      case 16:
+	*((GFC_REAL_16 *) dest) = 0.0;
+	break;
+#endif
+
+      default:
+	internal_error (&dtp->common, "Unsupported real kind during IO");
+    }
+  return;
+
+bad_float:
+  generate_error (&dtp->common, LIBERROR_READ_VALUE,
+		  "Bad value during floating point read");
+  next_record (dtp, 1);
+  return;
 }
 
 

libgfortran/io/transfer.c

@@ -37,6 +37,7 @@ Boston, MA 02110-1301, USA.  */
 #include <string.h>
 #include <assert.h>
 #include <stdlib.h>
+#include <errno.h>
 
 
 /* Calling conventions:  Data transfer statements are unlike other
@@ -183,60 +184,58 @@ current_mode (st_parameter_dt *dtp)
    heap.  Hopefully this won't happen very often.  */
 
 char *
-read_sf (st_parameter_dt *dtp, int *length, int no_error)
+read_sf (st_parameter_dt *dtp, int * length, int no_error)
 {
+  static char *empty_string[0];
   char *base, *p, q;
-  int n, crlf;
-  gfc_offset pos;
-  size_t readlen;
+  int n, lorig, memread, seen_comma;
 
-  if (*length > SCRATCH_SIZE)
-    dtp->u.p.line_buffer = get_mem (*length);
-  p = base = dtp->u.p.line_buffer;
+  /* If we hit EOF previously with the no_error flag set (i.e. X, T,
+     TR edit descriptors), and we now try to read again, this time
+     without setting no_error.  */
+  if (!no_error && dtp->u.p.at_eof)
+    {
+      *length = 0;
+      hit_eof (dtp);
+      return NULL;
+    }
 
   /* If we have seen an eor previously, return a length of 0.  The
      caller is responsible for correctly padding the input field.  */
   if (dtp->u.p.sf_seen_eor)
     {
       *length = 0;
-      return base;
+      /* Just return something that isn't a NULL pointer, otherwise the
+         caller thinks an error occured.  */
+      return (char*) empty_string;
     }
 
   if (is_internal_unit (dtp))
     {
-      readlen = *length;
-      if (unlikely (sread (dtp->u.p.current_unit->s, p, &readlen) != 0
-		    || readlen < (size_t) *length))
+      memread = *length;
+      base = mem_alloc_r (dtp->u.p.current_unit->s, length);
+      if (unlikely (memread > *length))
 	{
-	  generate_error (&dtp->common, LIBERROR_END, NULL);
+          hit_eof (dtp);
 	  return NULL;
 	}
-	
+      n = *length;
       goto done;
     }
 
-  readlen = 1;
-  n = 0;
+  n = seen_comma = 0;
 
-  do
-    {
-      if (unlikely (sread (dtp->u.p.current_unit->s, &q, &readlen) != 0))
-        {
-	  generate_error (&dtp->common, LIBERROR_END, NULL);
-	  return NULL;
-	}
+  /* Read data into format buffer and scan through it.  */
+  lorig = *length;
+  base = p = fbuf_read (dtp->u.p.current_unit, length);
+  if (base == NULL)
+    return NULL;
 
-      /* If we have a line without a terminating \n, drop through to
-	 EOR below.  */
-      if (readlen < 1 && n == 0)
-	{
-	  if (likely (no_error))
-	    break;
-	  generate_error (&dtp->common, LIBERROR_END, NULL);
-	  return NULL;
-	}
+  while (n < *length)
+    {
+      q = *p;
 
-      if (readlen < 1 || q == '\n' || q == '\r')
+      if (q == '\n' || q == '\r')
 	{
 	  /* Unexpected end of line.  */
 
@@ -245,23 +244,14 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error)
 	  if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
 	    dtp->u.p.eor_condition = 1;
 
-	  crlf = 0;
 	  /* If we encounter a CR, it might be a CRLF.  */
 	  if (q == '\r') /* Probably a CRLF */
 	    {
-	      readlen = 1;
-	      pos = stream_offset (dtp->u.p.current_unit->s);
-	      if (unlikely (sread (dtp->u.p.current_unit->s, &q, &readlen)
-			    != 0))
-	        {
-		  generate_error (&dtp->common, LIBERROR_END, NULL);
-		  return NULL;
-		}
-	      if (q != '\n' && readlen == 1) /* Not a CRLF after all.  */
-		sseek (dtp->u.p.current_unit->s, pos);
-	      else
-		crlf = 1;
+	      if (n < *length && *(p + 1) == '\n')
+		dtp->u.p.sf_seen_eor = 2;
 	    }
+          else
+            dtp->u.p.sf_seen_eor = 1;
 
 	  /* Without padding, terminate the I/O statement without assigning
 	     the value.  With padding, the value still needs to be assigned,
@@ -275,7 +265,6 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error)
 	    }
 
 	  *length = n;
-	  dtp->u.p.sf_seen_eor = (crlf ? 2 : 1);
 	  break;
 	}
       /*  Short circuit the read if a comma is found during numeric input.
@@ -284,6 +273,7 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error)
       if (q == ',')
 	if (dtp->u.p.sf_read_comma == 1)
 	  {
+            seen_comma = 1;
 	    notify_std (&dtp->common, GFC_STD_GNU,
 			"Comma in formatted numeric read.");
 	    *length = n;
@@ -291,16 +281,31 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error)
 	  }
 
       n++;
-      *p++ = q;
-      dtp->u.p.sf_seen_eor = 0;
+      p++;
+    } 
+
+  fbuf_seek (dtp->u.p.current_unit, n + dtp->u.p.sf_seen_eor + seen_comma, 
+             SEEK_CUR);
+
+  /* A short read implies we hit EOF, unless we hit EOR, a comma, or
+     some other stuff. Set the relevant flags.  */
+  if (lorig > *length && !dtp->u.p.sf_seen_eor && !seen_comma)
+    {
+      if (no_error)
+        dtp->u.p.at_eof = 1;
+      else
+        {
+          hit_eof (dtp);
+          return NULL;
+        }
     }
-  while (n < *length);
 
  done:
-  dtp->u.p.current_unit->bytes_left -= *length;
+
+  dtp->u.p.current_unit->bytes_left -= n;
 
   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
-    dtp->u.p.size_used += (GFC_IO_INT) *length;
+    dtp->u.p.size_used += (GFC_IO_INT) n;
 
   return base;
 }
@@ -316,12 +321,11 @@ read_sf (st_parameter_dt *dtp, int *length, int no_error)
    opened with PAD=YES.  The caller must assume tailing spaces for
    short reads.  */
 
-try
-read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes)
+void *
+read_block_form (st_parameter_dt *dtp, int * nbytes)
 {
   char *source;
-  size_t nread;
-  int nb;
+  int norig;
 
   if (!is_stream_io (dtp))
     {
@@ -338,15 +342,14 @@ read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes)
 		{
 		  /* Not enough data left.  */
 		  generate_error (&dtp->common, LIBERROR_EOR, NULL);
-		  return FAILURE;
+		  return NULL;
 		}
 	    }
 
 	  if (unlikely (dtp->u.p.current_unit->bytes_left == 0))
 	    {
-	      dtp->u.p.current_unit->endfile = AT_ENDFILE;
-	      generate_error (&dtp->common, LIBERROR_END, NULL);
-	      return FAILURE;
+              hit_eof (dtp);
+	      return NULL;
 	    }
 
 	  *nbytes = dtp->u.p.current_unit->bytes_left;
@@ -357,42 +360,36 @@ read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes)
       (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL ||
        dtp->u.p.current_unit->flags.access == ACCESS_STREAM))
     {
-      nb = *nbytes;
-      source = read_sf (dtp, &nb, 0);
-      *nbytes = nb;
+      source = read_sf (dtp, nbytes, 0);
       dtp->u.p.current_unit->strm_pos +=
 	(gfc_offset) (*nbytes + dtp->u.p.sf_seen_eor);
-      if (source == NULL)
-	return FAILURE;
-      memcpy (buf, source, *nbytes);
-      return SUCCESS;
+      return source;
     }
+
+  /* If we reach here, we can assume it's direct access.  */
+
   dtp->u.p.current_unit->bytes_left -= (gfc_offset) *nbytes;
 
-  nread = *nbytes;
-  if (unlikely (sread (dtp->u.p.current_unit->s, buf, &nread) != 0))
-    {
-      generate_error (&dtp->common, LIBERROR_OS, NULL);
-      return FAILURE;
-    }
+  norig = *nbytes;
+  source = fbuf_read (dtp->u.p.current_unit, nbytes);
+  fbuf_seek (dtp->u.p.current_unit, *nbytes, SEEK_CUR);
 
   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
-    dtp->u.p.size_used += (GFC_IO_INT) nread;
+    dtp->u.p.size_used += (GFC_IO_INT) *nbytes;
 
-  if (nread != *nbytes)
-    {				/* Short read, this shouldn't happen.  */
-      if (likely (dtp->u.p.current_unit->pad_status == PAD_YES))
-	*nbytes = nread;
-      else
+  if (norig != *nbytes)
+    {				
+      /* Short read, this shouldn't happen.  */
+      if (!dtp->u.p.current_unit->pad_status == PAD_YES)
 	{
 	  generate_error (&dtp->common, LIBERROR_EOR, NULL);
 	  source = NULL;
 	}
     }
 
-  dtp->u.p.current_unit->strm_pos += (gfc_offset) nread;
+  dtp->u.p.current_unit->strm_pos += (gfc_offset) *nbytes;
 
-  return SUCCESS;
+  return source;
 }
 
 
@@ -402,18 +399,18 @@ read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes)
 static void
 read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
 {
-  size_t to_read_record;
-  size_t have_read_record;
-  size_t to_read_subrecord;
-  size_t have_read_subrecord;
+  ssize_t to_read_record;
+  ssize_t have_read_record;
+  ssize_t to_read_subrecord;
+  ssize_t have_read_subrecord;
   int short_record;
 
   if (is_stream_io (dtp))
     {
       to_read_record = *nbytes;
-      have_read_record = to_read_record;
-      if (unlikely (sread (dtp->u.p.current_unit->s, buf, &have_read_record)
-		    != 0))
+      have_read_record = sread (dtp->u.p.current_unit->s, buf, 
+				to_read_record);
+      if (unlikely (have_read_record < 0))
 	{
 	  generate_error (&dtp->common, LIBERROR_OS, NULL);
 	  return;
@@ -425,7 +422,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
 	{
 	  /* Short read,  e.g. if we hit EOF.  For stream files,
 	   we have to set the end-of-file condition.  */
-	  generate_error (&dtp->common, LIBERROR_END, NULL);
+          hit_eof (dtp);
 	  return;
 	}
       return;
@@ -448,14 +445,14 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
 
       dtp->u.p.current_unit->bytes_left -= to_read_record;
 
-      if (unlikely (sread (dtp->u.p.current_unit->s, buf, &to_read_record)
-		    != 0))
+      to_read_record = sread (dtp->u.p.current_unit->s, buf, to_read_record);
+      if (unlikely (to_read_record < 0))
 	{
 	  generate_error (&dtp->common, LIBERROR_OS, NULL);
 	  return;
 	}
 
-      if (to_read_record != *nbytes)  
+      if (to_read_record != (ssize_t) *nbytes)  
 	{
 	  /* Short read, e.g. if we hit EOF.  Apparently, we read
 	   more than was written to the last record.  */
@@ -475,18 +472,12 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
      until the request has been fulfilled or the record has run out
      of continuation subrecords.  */
 
-  if (unlikely (dtp->u.p.current_unit->endfile == AT_ENDFILE))
-    {
-      generate_error (&dtp->common, LIBERROR_END, NULL);
-      return;
-    }
-
   /* Check whether we exceed the total record length.  */
 
   if (dtp->u.p.current_unit->flags.has_recl
       && (*nbytes > (size_t) dtp->u.p.current_unit->bytes_left))
     {
-      to_read_record = (size_t) dtp->u.p.current_unit->bytes_left;
+      to_read_record = (ssize_t) dtp->u.p.current_unit->bytes_left;
       short_record = 1;
     }
   else
@@ -501,7 +492,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
       if (dtp->u.p.current_unit->bytes_left_subrecord
 	  < (gfc_offset) to_read_record)
 	{
-	  to_read_subrecord = (size_t) dtp->u.p.current_unit->bytes_left_subrecord;
+	  to_read_subrecord = (ssize_t) dtp->u.p.current_unit->bytes_left_subrecord;
 	  to_read_record -= to_read_subrecord;
 	}
       else
@@ -512,9 +503,9 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
 
       dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord;
 
-      have_read_subrecord = to_read_subrecord;
-      if (unlikely (sread (dtp->u.p.current_unit->s, buf + have_read_record,
-			   &have_read_subrecord) != 0))
+      have_read_subrecord = sread (dtp->u.p.current_unit->s, 
+				   buf + have_read_record, to_read_subrecord);
+      if (unlikely (have_read_subrecord) < 0)
 	{
 	  generate_error (&dtp->common, LIBERROR_OS, NULL);
 	  return;
@@ -603,7 +594,7 @@ write_block (st_parameter_dt *dtp, int length)
 
   if (is_internal_unit (dtp))
     {
-    dest = salloc_w (dtp->u.p.current_unit->s, &length);
+    dest = mem_alloc_w (dtp->u.p.current_unit->s, &length);
 
     if (dest == NULL)
       {
@@ -641,20 +632,22 @@ static try
 write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
 {
 
-  size_t have_written, to_write_subrecord;
+  ssize_t have_written;
+  ssize_t to_write_subrecord;
   int short_record;
 
   /* Stream I/O.  */
 
   if (is_stream_io (dtp))
     {
-      if (unlikely (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0))
+      have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes);
+      if (unlikely (have_written < 0))
 	{
 	  generate_error (&dtp->common, LIBERROR_OS, NULL);
 	  return FAILURE;
 	}
 
-      dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes; 
+      dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written; 
 
       return SUCCESS;
     }
@@ -672,14 +665,15 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
       if (buf == NULL && nbytes == 0)
 	return SUCCESS;
 
-      if (unlikely (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0))
+      have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes); 
+      if (unlikely (have_written < 0))
 	{
 	  generate_error (&dtp->common, LIBERROR_OS, NULL);
 	  return FAILURE;
 	}
 
-      dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
-      dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
+      dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written;
+      dtp->u.p.current_unit->bytes_left -= (gfc_offset) have_written;
 
       return SUCCESS;
     }
@@ -709,8 +703,9 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
       dtp->u.p.current_unit->bytes_left_subrecord -=
 	(gfc_offset) to_write_subrecord;
 
-      if (unlikely (swrite (dtp->u.p.current_unit->s, buf + have_written,
-			    &to_write_subrecord) != 0))
+      to_write_subrecord = swrite (dtp->u.p.current_unit->s, 
+				   buf + have_written, to_write_subrecord);
+      if (unlikely (to_write_subrecord < 0))
 	{
 	  generate_error (&dtp->common, LIBERROR_OS, NULL);
 	  return FAILURE;
@@ -920,19 +915,18 @@ require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
 }
 
 
-/* This subroutine is the main loop for a formatted data transfer
+/* This function is in the main loop for a formatted data transfer
    statement.  It would be natural to implement this as a coroutine
    with the user program, but C makes that awkward.  We loop,
    processing format elements.  When we actually have to transfer
    data instead of just setting flags, we return control to the user
-   program which calls a subroutine that supplies the address and type
+   program which calls a function that supplies the address and type
    of the next element, then comes back here to process it.  */
 
 static void
-formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
-			   size_t size)
+formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind,
+				size_t size)
 {
-  char scratch[SCRATCH_SIZE];
   int pos, bytes_used;
   const fnode *f;
   format_token t;
@@ -959,7 +953,347 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
   dtp->u.p.sf_read_comma =
     dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
 
-  dtp->u.p.line_buffer = scratch;
+  for (;;)
+    {
+      /* If reversion has occurred and there is another real data item,
+	 then we have to move to the next record.  */
+      if (dtp->u.p.reversion_flag && n > 0)
+	{
+	  dtp->u.p.reversion_flag = 0;
+	  next_record (dtp, 0);
+	}
+
+      consume_data_flag = 1;
+      if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+	break;
+
+      f = next_format (dtp);
+      if (f == NULL)
+	{
+	  /* No data descriptors left.  */
+	  if (unlikely (n > 0))
+	    generate_error (&dtp->common, LIBERROR_FORMAT,
+		"Insufficient data descriptors in format after reversion");
+	  return;
+	}
+
+      t = f->format;
+
+      bytes_used = (int)(dtp->u.p.current_unit->recl
+		   - dtp->u.p.current_unit->bytes_left);
+
+      if (is_stream_io(dtp))
+	bytes_used = 0;
+
+      switch (t)
+	{
+	case FMT_I:
+	  if (n == 0)
+	    goto need_read_data;
+	  if (require_type (dtp, BT_INTEGER, type, f))
+	    return;
+	  read_decimal (dtp, f, p, kind);
+	  break;
+
+	case FMT_B:
+	  if (n == 0)
+	    goto need_read_data;
+	  if (compile_options.allow_std < GFC_STD_GNU
+              && require_type (dtp, BT_INTEGER, type, f))
+	    return;
+	  read_radix (dtp, f, p, kind, 2);
+	  break;
+
+	case FMT_O:
+	  if (n == 0)
+	    goto need_read_data; 
+	  if (compile_options.allow_std < GFC_STD_GNU
+              && require_type (dtp, BT_INTEGER, type, f))
+	    return;
+	  read_radix (dtp, f, p, kind, 8);
+	  break;
+
+	case FMT_Z:
+	  if (n == 0)
+	    goto need_read_data;
+	  if (compile_options.allow_std < GFC_STD_GNU
+              && require_type (dtp, BT_INTEGER, type, f))
+	    return;
+	  read_radix (dtp, f, p, kind, 16);
+	  break;
+
+	case FMT_A:
+	  if (n == 0)
+	    goto need_read_data;
+
+	  /* It is possible to have FMT_A with something not BT_CHARACTER such
+	     as when writing out hollerith strings, so check both type
+	     and kind before calling wide character routines.  */
+	  if (type == BT_CHARACTER && kind == 4)
+	    read_a_char4 (dtp, f, p, size);
+	  else
+	    read_a (dtp, f, p, size);
+	  break;
+
+	case FMT_L:
+	  if (n == 0)
+	    goto need_read_data;
+	  read_l (dtp, f, p, kind);
+	  break;
+
+	case FMT_D:
+	  if (n == 0)
+	    goto need_read_data;
+	  if (require_type (dtp, BT_REAL, type, f))
+	    return;
+	  read_f (dtp, f, p, kind);
+	  break;
+
+	case FMT_E:
+	  if (n == 0)
+	    goto need_read_data;
+	  if (require_type (dtp, BT_REAL, type, f))
+	    return;
+	  read_f (dtp, f, p, kind);
+	  break;
+
+	case FMT_EN:
+	  if (n == 0)
+	    goto need_read_data;
+	  if (require_type (dtp, BT_REAL, type, f))
+	    return;
+	  read_f (dtp, f, p, kind);
+	  break;
+
+	case FMT_ES:
+	  if (n == 0)
+	    goto need_read_data;
+	  if (require_type (dtp, BT_REAL, type, f))
+	    return;
+	  read_f (dtp, f, p, kind);
+	  break;
+
+	case FMT_F:
+	  if (n == 0)
+	    goto need_read_data;
+	  if (require_type (dtp, BT_REAL, type, f))
+	    return;
+	  read_f (dtp, f, p, kind);
+	  break;
+
+	case FMT_G:
+	  if (n == 0)
+	    goto need_read_data;
+	  switch (type)
+	    {
+	      case BT_INTEGER:
+		read_decimal (dtp, f, p, kind);
+		break;
+	      case BT_LOGICAL:
+		read_l (dtp, f, p, kind);
+		break;
+	      case BT_CHARACTER:
+		if (kind == 4)
+		  read_a_char4 (dtp, f, p, size);
+		else
+		  read_a (dtp, f, p, size);
+		break;
+	      case BT_REAL:
+		read_f (dtp, f, p, kind);
+		break;
+	      default:
+		internal_error (&dtp->common, "formatted_transfer(): Bad type");
+	    }
+	  break;
+
+	case FMT_STRING:
+	  consume_data_flag = 0;
+	  format_error (dtp, f, "Constant string in input format");
+	  return;
+
+	/* Format codes that don't transfer data.  */
+	case FMT_X:
+	case FMT_TR:
+	  consume_data_flag = 0;
+	  dtp->u.p.skips += f->u.n;
+	  pos = bytes_used + dtp->u.p.skips - 1;
+	  dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1;
+	  read_x (dtp, f->u.n);
+	  break;
+
+	case FMT_TL:
+	case FMT_T:
+	  consume_data_flag = 0;
+
+	  if (f->format == FMT_TL)
+	    {
+	      /* Handle the special case when no bytes have been used yet.
+	         Cannot go below zero. */
+	      if (bytes_used == 0)
+		{
+		  dtp->u.p.pending_spaces -= f->u.n;
+		  dtp->u.p.skips -= f->u.n;
+		  dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
+		}
+
+	      pos = bytes_used - f->u.n;
+	    }
+	  else /* FMT_T */
+	    pos = f->u.n - 1;
+
+	  /* Standard 10.6.1.1: excessive left tabbing is reset to the
+	     left tab limit.  We do not check if the position has gone
+	     beyond the end of record because a subsequent tab could
+	     bring us back again.  */
+	  pos = pos < 0 ? 0 : pos;
+
+	  dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
+	  dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
+				    + pos - dtp->u.p.max_pos;
+	  dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
+				    ? 0 : dtp->u.p.pending_spaces;
+	  if (dtp->u.p.skips == 0)
+	    break;
+
+	  /* Adjust everything for end-of-record condition */
+	  if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
+	    {
+              dtp->u.p.current_unit->bytes_left -= dtp->u.p.sf_seen_eor;
+              dtp->u.p.skips -= dtp->u.p.sf_seen_eor;
+	      bytes_used = pos;
+	      dtp->u.p.sf_seen_eor = 0;
+	    }
+	  if (dtp->u.p.skips < 0)
+	    {
+              if (is_internal_unit (dtp))  
+                move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
+              else
+                fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
+	      dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
+	      dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
+	    }
+	  else
+	    read_x (dtp, dtp->u.p.skips);
+	  break;
+
+	case FMT_S:
+	  consume_data_flag = 0;
+	  dtp->u.p.sign_status = SIGN_S;
+	  break;
+
+	case FMT_SS:
+	  consume_data_flag = 0;
+	  dtp->u.p.sign_status = SIGN_SS;
+	  break;
+
+	case FMT_SP:
+	  consume_data_flag = 0;
+	  dtp->u.p.sign_status = SIGN_SP;
+	  break;
+
+	case FMT_BN:
+	  consume_data_flag = 0 ;
+	  dtp->u.p.blank_status = BLANK_NULL;
+	  break;
+
+	case FMT_BZ:
+	  consume_data_flag = 0;
+	  dtp->u.p.blank_status = BLANK_ZERO;
+	  break;
+
+	case FMT_DC:
+	  consume_data_flag = 0;
+	  dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA;
+	  break;
+
+	case FMT_DP:
+	  consume_data_flag = 0;
+	  dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
+	  break;
+
+	case FMT_P:
+	  consume_data_flag = 0;
+	  dtp->u.p.scale_factor = f->u.k;
+	  break;
+
+	case FMT_DOLLAR:
+	  consume_data_flag = 0;
+	  dtp->u.p.seen_dollar = 1;
+	  break;
+
+	case FMT_SLASH:
+	  consume_data_flag = 0;
+	  dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
+	  next_record (dtp, 0);
+	  break;
+
+	case FMT_COLON:
+	  /* A colon descriptor causes us to exit this loop (in
+	     particular preventing another / descriptor from being
+	     processed) unless there is another data item to be
+	     transferred.  */
+	  consume_data_flag = 0;
+	  if (n == 0)
+	    return;
+	  break;
+
+	default:
+	  internal_error (&dtp->common, "Bad format node");
+	}
+
+      /* Adjust the item count and data pointer.  */
+
+      if ((consume_data_flag > 0) && (n > 0))
+	{
+	  n--;
+	  p = ((char *) p) + size;
+	}
+
+      dtp->u.p.skips = 0;
+
+      pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
+      dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
+    }
+
+  return;
+
+  /* Come here when we need a data descriptor but don't have one.  We
+     push the current format node back onto the input, then return and
+     let the user program call us back with the data.  */
+ need_read_data:
+  unget_format (dtp, f);
+}
+
+
+static void
+formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kind,
+				 size_t size)
+{
+  int pos, bytes_used;
+  const fnode *f;
+  format_token t;
+  int n;
+  int consume_data_flag;
+
+  /* Change a complex data item into a pair of reals.  */
+
+  n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
+  if (type == BT_COMPLEX)
+    {
+      type = BT_REAL;
+      size /= 2;
+    }
+
+  /* If there's an EOR condition, we simulate finalizing the transfer
+     by doing nothing.  */
+  if (dtp->u.p.eor_condition)
+    return;
+
+  /* Set this flag so that commas in reads cause the read to complete before
+     the entire field has been read.  The next read field will start right after
+     the comma in the stream.  (Set to 0 for character reads).  */
+  dtp->u.p.sf_read_comma =
+    dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
 
   for (;;)
     {
@@ -1010,7 +1344,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
               if (is_internal_unit (dtp))  
 	        move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
               else
-                fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips);
+                fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
 	      dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
 	    }
 	  dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
@@ -1029,57 +1363,34 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
 	    goto need_data;
 	  if (require_type (dtp, BT_INTEGER, type, f))
 	    return;
-
-	  if (dtp->u.p.mode == READING)
-	    read_decimal (dtp, f, p, kind);
-	  else
-	    write_i (dtp, f, p, kind);
-
+	  write_i (dtp, f, p, kind);
 	  break;
 
 	case FMT_B:
 	  if (n == 0)
 	    goto need_data;
-
 	  if (compile_options.allow_std < GFC_STD_GNU
               && require_type (dtp, BT_INTEGER, type, f))
 	    return;
-
-	  if (dtp->u.p.mode == READING)
-	    read_radix (dtp, f, p, kind, 2);
-	  else
-	    write_b (dtp, f, p, kind);
-
+	  write_b (dtp, f, p, kind);
 	  break;
 
 	case FMT_O:
 	  if (n == 0)
 	    goto need_data; 
-
 	  if (compile_options.allow_std < GFC_STD_GNU
               && require_type (dtp, BT_INTEGER, type, f))
 	    return;
-
-	  if (dtp->u.p.mode == READING)
-	    read_radix (dtp, f, p, kind, 8);
-	  else
-	    write_o (dtp, f, p, kind);
-
+	  write_o (dtp, f, p, kind);
 	  break;
 
 	case FMT_Z:
 	  if (n == 0)
 	    goto need_data;
-
 	  if (compile_options.allow_std < GFC_STD_GNU
               && require_type (dtp, BT_INTEGER, type, f))
 	    return;
-
-	  if (dtp->u.p.mode == READING)
-	    read_radix (dtp, f, p, kind, 16);
-	  else
-	    write_z (dtp, f, p, kind);
-
+	  write_z (dtp, f, p, kind);
 	  break;
 
 	case FMT_A:
@@ -1089,31 +1400,16 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
 	  /* It is possible to have FMT_A with something not BT_CHARACTER such
 	     as when writing out hollerith strings, so check both type
 	     and kind before calling wide character routines.  */
-	  if (dtp->u.p.mode == READING)
-	    {
-	      if (type == BT_CHARACTER && kind == 4)
-		read_a_char4 (dtp, f, p, size);
-	      else
-		read_a (dtp, f, p, size);
-	    }
+	  if (type == BT_CHARACTER && kind == 4)
+	    write_a_char4 (dtp, f, p, size);
 	  else
-	    {
-	      if (type == BT_CHARACTER && kind == 4)
-		write_a_char4 (dtp, f, p, size);
-	      else
-		write_a (dtp, f, p, size);
-	    }
+	    write_a (dtp, f, p, size);
 	  break;
 
 	case FMT_L:
 	  if (n == 0)
 	    goto need_data;
-
-	  if (dtp->u.p.mode == READING)
-	    read_l (dtp, f, p, kind);
-	  else
-	    write_l (dtp, f, p, kind);
-
+	  write_l (dtp, f, p, kind);
 	  break;
 
 	case FMT_D:
@@ -1121,12 +1417,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
 	    goto need_data;
 	  if (require_type (dtp, BT_REAL, type, f))
 	    return;
-
-	  if (dtp->u.p.mode == READING)
-	    read_f (dtp, f, p, kind);
-	  else
-	    write_d (dtp, f, p, kind);
-
+	  write_d (dtp, f, p, kind);
 	  break;
 
 	case FMT_E:
@@ -1134,11 +1425,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
 	    goto need_data;
 	  if (require_type (dtp, BT_REAL, type, f))
 	    return;
-
-	  if (dtp->u.p.mode == READING)
-	    read_f (dtp, f, p, kind);
-	  else
-	    write_e (dtp, f, p, kind);
+	  write_e (dtp, f, p, kind);
 	  break;
 
 	case FMT_EN:
@@ -1146,12 +1433,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
 	    goto need_data;
 	  if (require_type (dtp, BT_REAL, type, f))
 	    return;
-
-	  if (dtp->u.p.mode == READING)
-	    read_f (dtp, f, p, kind);
-	  else
-	    write_en (dtp, f, p, kind);
-
+	  write_en (dtp, f, p, kind);
 	  break;
 
 	case FMT_ES:
@@ -1159,12 +1441,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
 	    goto need_data;
 	  if (require_type (dtp, BT_REAL, type, f))
 	    return;
-
-	  if (dtp->u.p.mode == READING)
-	    read_f (dtp, f, p, kind);
-	  else
-	    write_es (dtp, f, p, kind);
-
+	  write_es (dtp, f, p, kind);
 	  break;
 
 	case FMT_F:
@@ -1172,41 +1449,14 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
 	    goto need_data;
 	  if (require_type (dtp, BT_REAL, type, f))
 	    return;
-
-	  if (dtp->u.p.mode == READING)
-	    read_f (dtp, f, p, kind);
-	  else
-	    write_f (dtp, f, p, kind);
-
+	  write_f (dtp, f, p, kind);
 	  break;
 
 	case FMT_G:
 	  if (n == 0)
 	    goto need_data;
-	  if (dtp->u.p.mode == READING)
-	    switch (type)
-	      {
-	      case BT_INTEGER:
-		read_decimal (dtp, f, p, kind);
-		break;
-	      case BT_LOGICAL:
-		read_l (dtp, f, p, kind);
-		break;
-	      case BT_CHARACTER:
-		if (kind == 4)
-		  read_a_char4 (dtp, f, p, size);
-		else
-		  read_a (dtp, f, p, size);
-		break;
-	      case BT_REAL:
-		read_f (dtp, f, p, kind);
-		break;
-	      default:
-		goto bad_type;
-	      }
-	  else
-	    switch (type)
-	      {
+	  switch (type)
+	    {
 	      case BT_INTEGER:
 		write_i (dtp, f, p, kind);
 		break;
@@ -1221,25 +1471,18 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
 		break;
 	      case BT_REAL:
 		if (f->u.real.w == 0)
-		  write_real_g0 (dtp, p, kind, f->u.real.d);
+                  write_real_g0 (dtp, p, kind, f->u.real.d);
 		else
 		  write_d (dtp, f, p, kind);
 		break;
 	      default:
-	      bad_type:
 		internal_error (&dtp->common,
 				"formatted_transfer(): Bad type");
-	      }
-
+	    }
 	  break;
 
 	case FMT_STRING:
 	  consume_data_flag = 0;
-	  if (dtp->u.p.mode == READING)
-	    {
-	      format_error (dtp, f, "Constant string in input format");
-	      return;
-	    }
 	  write_constant_string (dtp, f);
 	  break;
 
@@ -1251,21 +1494,15 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
 	  dtp->u.p.skips += f->u.n;
 	  pos = bytes_used + dtp->u.p.skips - 1;
 	  dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1;
-
 	  /* Writes occur just before the switch on f->format, above, so
 	     that trailing blanks are suppressed, unless we are doing a
 	     non-advancing write in which case we want to output the blanks
 	     now.  */
-	  if (dtp->u.p.mode == WRITING
-	      && dtp->u.p.advance_status == ADVANCE_NO)
+	  if (dtp->u.p.advance_status == ADVANCE_NO)
 	    {
 	      write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
 	      dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
 	    }
-
-	  if (dtp->u.p.mode == READING)
-	    read_x (dtp, f->u.n);
-
 	  break;
 
 	case FMT_TL:
@@ -1287,12 +1524,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
 	      pos = bytes_used - f->u.n;
 	    }
 	  else /* FMT_T */
-	    {
-	      if (dtp->u.p.mode == READING)
-		pos = f->u.n - 1;
-	      else
-		pos = f->u.n - dtp->u.p.pending_spaces - 1;
-	    }
+	    pos = f->u.n - dtp->u.p.pending_spaces - 1;
 
 	  /* Standard 10.6.1.1: excessive left tabbing is reset to the
 	     left tab limit.  We do not check if the position has gone
@@ -1305,43 +1537,6 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
 				    + pos - dtp->u.p.max_pos;
 	  dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
 				    ? 0 : dtp->u.p.pending_spaces;
-
-	  if (dtp->u.p.skips == 0)
-	    break;
-
-	  /* Writes occur just before the switch on f->format, above, so that
-	     trailing blanks are suppressed.  */
-	  if (dtp->u.p.mode == READING)
-	    {
-	      /* Adjust everything for end-of-record condition */
-	      if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
-		{
-		  if (dtp->u.p.sf_seen_eor == 2)
-		    {
-		      /* The EOR was a CRLF (two bytes wide).  */
-		      dtp->u.p.current_unit->bytes_left -= 2;
-		      dtp->u.p.skips -= 2;
-		    }
-		  else
-		    {
-		      /* The EOR marker was only one byte wide.  */
-		      dtp->u.p.current_unit->bytes_left--;
-		      dtp->u.p.skips--;
-		    }
-		  bytes_used = pos;
-		  dtp->u.p.sf_seen_eor = 0;
-		}
-	      if (dtp->u.p.skips < 0)
-		{
-		  move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
-		  dtp->u.p.current_unit->bytes_left
-		    -= (gfc_offset) dtp->u.p.skips;
-		  dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
-		}
-	      else
-		read_x (dtp, dtp->u.p.skips);
-	    }
-
 	  break;
 
 	case FMT_S:
@@ -1409,30 +1604,16 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
 	  internal_error (&dtp->common, "Bad format node");
 	}
 
-      /* Free a buffer that we had to allocate during a sequential
-	 formatted read of a block that was larger than the static
-	 buffer.  */
-
-      if (dtp->u.p.line_buffer != scratch)
-	{
-	  free_mem (dtp->u.p.line_buffer);
-	  dtp->u.p.line_buffer = scratch;
-	}
-
       /* Adjust the item count and data pointer.  */
 
       if ((consume_data_flag > 0) && (n > 0))
-      {
-	n--;
-	p = ((char *) p) + size;
-      }
-
-      if (dtp->u.p.mode == READING)
-	dtp->u.p.skips = 0;
+	{
+	  n--;
+	  p = ((char *) p) + size;
+	}
 
       pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
       dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
-
     }
 
   return;
@@ -1444,6 +1625,7 @@ formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
   unget_format (dtp, f);
 }
 
+
 static void
 formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
 		    size_t size, size_t nelems)
@@ -1454,16 +1636,27 @@ formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
   tmp = (char *) p;
   size_t stride = type == BT_CHARACTER ?
 		  size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
-  /* Big loop over all the elements.  */
-  for (elem = 0; elem < nelems; elem++)
+  if (dtp->u.p.mode == READING)
+    {
+      /* Big loop over all the elements.  */
+      for (elem = 0; elem < nelems; elem++)
+	{
+	  dtp->u.p.item_count++;
+	  formatted_transfer_scalar_read (dtp, type, tmp + stride*elem, kind, size);
+	}
+    }
+  else
     {
-      dtp->u.p.item_count++;
-      formatted_transfer_scalar (dtp, type, tmp + stride*elem, kind, size);
+      /* Big loop over all the elements.  */
+      for (elem = 0; elem < nelems; elem++)
+	{
+	  dtp->u.p.item_count++;
+	  formatted_transfer_scalar_write (dtp, type, tmp + stride*elem, kind, size);
+	}
     }
 }
 
 
-
 /* Data transfer entry points.  The type of the data entity is
    implicit in the subroutine call.  This prevents us from having to
    share a common enum with the compiler.  */
@@ -1657,34 +1850,28 @@ transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
 static void
 us_read (st_parameter_dt *dtp, int continued)
 {
-  size_t n, nr;
+  ssize_t n, nr;
   GFC_INTEGER_4 i4;
   GFC_INTEGER_8 i8;
   gfc_offset i;
 
-  if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
-    return;
-
   if (compile_options.record_marker == 0)
     n = sizeof (GFC_INTEGER_4);
   else
     n = compile_options.record_marker;
 
-  nr = n;
-
-  if (unlikely (sread (dtp->u.p.current_unit->s, &i, &n) != 0))
+  nr = sread (dtp->u.p.current_unit->s, &i, n);
+  if (unlikely (nr < 0))
     {
       generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
       return;
     }
-
-  if (n == 0)
+  else if (nr == 0)
     {
-      dtp->u.p.current_unit->endfile = AT_ENDFILE;
+      hit_eof (dtp);
       return;  /* end of file */
     }
-
-  if (unlikely (n != nr))
+  else if (unlikely (n != nr))
     {
       generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
       return;
@@ -1750,7 +1937,7 @@ us_read (st_parameter_dt *dtp, int continued)
 static void
 us_write (st_parameter_dt *dtp, int continued)
 {
-  size_t nbytes;
+  ssize_t nbytes;
   gfc_offset dummy;
 
   dummy = 0;
@@ -1760,7 +1947,7 @@ us_write (st_parameter_dt *dtp, int continued)
   else
     nbytes = compile_options.record_marker ;
 
-  if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0)
+  if (swrite (dtp->u.p.current_unit->s, &dummy, nbytes) != nbytes)
     generate_error (&dtp->common, LIBERROR_OS, NULL);
 
   /* For sequential unformatted, if RECL= was not specified in the OPEN
@@ -1962,7 +2149,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
       return;
     }
 
-  /* Check the record number.  */
+  /* Check the record or position number.  */
 
   if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
       && (cf & IOPARM_DT_HAS_REC) == 0)
@@ -2111,65 +2298,71 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
   
   if (dtp->u.p.current_unit->pad_status == PAD_UNSPECIFIED)
 	dtp->u.p.current_unit->pad_status = dtp->u.p.current_unit->flags.pad;
-  
+
+  /* Check to see if we might be reading what we wrote before  */
+
+  if (dtp->u.p.mode != dtp->u.p.current_unit->mode
+      && !is_internal_unit (dtp))
+    {
+      int pos = fbuf_reset (dtp->u.p.current_unit);
+      if (pos != 0)
+        sseek (dtp->u.p.current_unit->s, pos, SEEK_CUR);
+      sflush(dtp->u.p.current_unit->s);
+    }
+
   /* Check the POS= specifier: that it is in range and that it is used with a
      unit that has been connected for STREAM access. F2003 9.5.1.10.  */
   
   if (((cf & IOPARM_DT_HAS_POS) != 0))
     {
       if (is_stream_io (dtp))
-	{
-
-	  if (dtp->pos <= 0)
-	    {
-	      generate_error (&dtp->common, LIBERROR_BAD_OPTION,
-			      "POS=specifier must be positive");
-	      return;
-	    }
-
-	  if (dtp->pos >= dtp->u.p.current_unit->maxrec)
-	    {
-	      generate_error (&dtp->common, LIBERROR_BAD_OPTION,
-			      "POS=specifier too large");
-	      return;
-	    }
-
-	  dtp->rec = dtp->pos;
-
-	  if (dtp->u.p.mode == READING)
-	    {
-	      /* Required for compatibility between 4.3 and 4.4 runtime. Check
-	      to see if we might be reading what we wrote before  */
-	      if (dtp->u.p.current_unit->mode == WRITING)
-		{
-		  fbuf_flush (dtp->u.p.current_unit, 1);      
-		  flush(dtp->u.p.current_unit->s);
-		}
-
-	      if (dtp->pos < file_length (dtp->u.p.current_unit->s))
-		dtp->u.p.current_unit->endfile = NO_ENDFILE;
-	    }
-
-	  if (dtp->pos != dtp->u.p.current_unit->strm_pos)
-	    {
-	      fbuf_flush (dtp->u.p.current_unit, 1);
-	      flush (dtp->u.p.current_unit->s);
-	      if (sseek (dtp->u.p.current_unit->s, dtp->pos - 1) == FAILURE)
-		{
-		  generate_error (&dtp->common, LIBERROR_OS, NULL);
-		  return;
-		}
-	      dtp->u.p.current_unit->strm_pos = dtp->pos;
-	    }
-	}
+        {
+          
+          if (dtp->pos <= 0)
+            {
+              generate_error (&dtp->common, LIBERROR_BAD_OPTION,
+                              "POS=specifier must be positive");
+              return;
+            }
+          
+          if (dtp->pos >= dtp->u.p.current_unit->maxrec)
+            {
+              generate_error (&dtp->common, LIBERROR_BAD_OPTION,
+                              "POS=specifier too large");
+              return;
+            }
+          
+          dtp->rec = dtp->pos;
+          
+          if (dtp->u.p.mode == READING)
+            {
+              /* Reset the endfile flag; if we hit EOF during reading
+                 we'll set the flag and generate an error at that point
+                 rather than worrying about it here.  */
+              dtp->u.p.current_unit->endfile = NO_ENDFILE;
+            }
+         
+          if (dtp->pos != dtp->u.p.current_unit->strm_pos)
+            {
+              fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
+              sflush (dtp->u.p.current_unit->s);
+              if (sseek (dtp->u.p.current_unit->s, dtp->pos - 1, SEEK_SET) < 0)
+                {
+                  generate_error (&dtp->common, LIBERROR_OS, NULL);
+                  return;
+                }
+              dtp->u.p.current_unit->strm_pos = dtp->pos;
+            }
+        }
       else
-	{
-	  generate_error (&dtp->common, LIBERROR_BAD_OPTION,
-			  "POS=specifier not allowed, "
-			  "Try OPEN with ACCESS='stream'");
-	  return;
-	}
+        {
+          generate_error (&dtp->common, LIBERROR_BAD_OPTION,
+                          "POS=specifier not allowed, "
+                          "Try OPEN with ACCESS='stream'");
+          return;
+        }
     }
+  
 
   /* Sanity checks on the record number.  */
   if ((cf & IOPARM_DT_HAS_REC) != 0)
@@ -2188,15 +2381,10 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
 	  return;
 	}
 
-      /* Check to see if we might be reading what we wrote before  */
+      /* Make sure format buffer is reset.  */
+      if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
+        fbuf_reset (dtp->u.p.current_unit);
 
-      if (dtp->u.p.mode == READING
-	  && dtp->u.p.current_unit->mode == WRITING
-	  && !is_internal_unit (dtp))
-	{
-	  fbuf_flush (dtp->u.p.current_unit, 1);      
-	  flush(dtp->u.p.current_unit->s);
-	}
 
       /* Check whether the record exists to be read.  Only
 	 a partial record needs to exist.  */
@@ -2211,37 +2399,28 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
 
       /* Position the file.  */
       if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
-		 * dtp->u.p.current_unit->recl) == FAILURE)
-	{
-	  generate_error (&dtp->common, LIBERROR_OS, NULL);
-	  return;
-	}
+                 * dtp->u.p.current_unit->recl, SEEK_SET) < 0)
+        {
+          generate_error (&dtp->common, LIBERROR_OS, NULL);
+          return;
+        }
 
       /* TODO: This is required to maintain compatibility between
-	 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
+         4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
 
       if (is_stream_io (dtp))
-	dtp->u.p.current_unit->strm_pos = dtp->rec;
-      
+        dtp->u.p.current_unit->strm_pos = dtp->rec;
+
       /* TODO: Un-comment this code when ABI changes from 4.3.
       if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
-	{
-	  generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
-		      "Record number not allowed for stream access "
-		      "data transfer");
-	  return;
-	}  */
-
+       {
+         generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
+                     "Record number not allowed for stream access "
+                     "data transfer");
+         return;
+       }  */
     }
 
-  /* Overwriting an existing sequential file ?
-     it is always safe to truncate the file on the first write */
-  if (dtp->u.p.mode == WRITING
-      && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
-      && dtp->u.p.current_unit->last_record == 0 
-      && !is_preconnected(dtp->u.p.current_unit->s))
-	struncate(dtp->u.p.current_unit->s);
-
   /* Bugware for badly written mixed C-Fortran I/O.  */
   flush_if_preconnected(dtp->u.p.current_unit->s);
 
@@ -2394,8 +2573,8 @@ next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished)
 static void
 skip_record (st_parameter_dt *dtp, size_t bytes)
 {
-  gfc_offset new;
   size_t rlength;
+  ssize_t readb;
   static const size_t MAX_READ = 4096;
   char p[MAX_READ];
 
@@ -2405,12 +2584,10 @@ skip_record (st_parameter_dt *dtp, size_t bytes)
 
   if (is_seekable (dtp->u.p.current_unit->s))
     {
-      new = file_position (dtp->u.p.current_unit->s)
-	+ dtp->u.p.current_unit->bytes_left_subrecord;
-
       /* Direct access files do not generate END conditions,
 	 only I/O errors.  */
-      if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
+      if (sseek (dtp->u.p.current_unit->s, 
+		 dtp->u.p.current_unit->bytes_left_subrecord, SEEK_CUR) < 0)
 	generate_error (&dtp->common, LIBERROR_OS, NULL);
     }
   else
@@ -2418,16 +2595,17 @@ skip_record (st_parameter_dt *dtp, size_t bytes)
       while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
 	{
 	  rlength = 
-	    (MAX_READ > (size_t) dtp->u.p.current_unit->bytes_left_subrecord) ?
+	    (MAX_READ < (size_t) dtp->u.p.current_unit->bytes_left_subrecord) ?
 	    MAX_READ : (size_t) dtp->u.p.current_unit->bytes_left_subrecord;
 
-	  if (sread (dtp->u.p.current_unit->s, p, &rlength) != 0)
+	  readb = sread (dtp->u.p.current_unit->s, p, rlength);
+	  if (readb < 0)
 	    {
 	      generate_error (&dtp->common, LIBERROR_OS, NULL);
 	      return;
 	    }
 
-	  dtp->u.p.current_unit->bytes_left_subrecord -= rlength;
+	  dtp->u.p.current_unit->bytes_left_subrecord -= readb;
 	}
     }
 
@@ -2475,8 +2653,8 @@ next_record_r (st_parameter_dt *dtp)
 {
   gfc_offset record;
   int bytes_left;
-  size_t length;
   char p;
+  int cc;
 
   switch (current_mode (dtp))
     {
@@ -2496,11 +2674,12 @@ next_record_r (st_parameter_dt *dtp)
 
     case FORMATTED_STREAM:
     case FORMATTED_SEQUENTIAL:
-      length = 1;
-      /* sf_read has already terminated input because of an '\n'  */
-      if (dtp->u.p.sf_seen_eor)
+      /* read_sf has already terminated input because of an '\n', or
+         we have hit EOF.  */
+      if (dtp->u.p.sf_seen_eor || dtp->u.p.at_eof)
 	{
 	  dtp->u.p.sf_seen_eor = 0;
+          dtp->u.p.at_eof = 0;
 	  break;
 	}
 
@@ -2515,7 +2694,7 @@ next_record_r (st_parameter_dt *dtp)
 
 	      /* Now seek to this record.  */
 	      record = record * dtp->u.p.current_unit->recl;
-	      if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
+	      if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
 		{
 		  generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
 		  break;
@@ -2527,10 +2706,9 @@ next_record_r (st_parameter_dt *dtp)
 	      bytes_left = (int) dtp->u.p.current_unit->bytes_left;
 	      bytes_left = min_off (bytes_left, 
 		      file_length (dtp->u.p.current_unit->s)
-		      - file_position (dtp->u.p.current_unit->s));
+		      - stell (dtp->u.p.current_unit->s));
 	      if (sseek (dtp->u.p.current_unit->s, 
-			  file_position (dtp->u.p.current_unit->s) 
-			  + bytes_left) == FAILURE)
+			 bytes_left, SEEK_CUR) < 0)
 	        {
 		  generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
 		  break;
@@ -2540,42 +2718,37 @@ next_record_r (st_parameter_dt *dtp)
 	    } 
 	  break;
 	}
-      else do
+      else 
 	{
-	  if (sread (dtp->u.p.current_unit->s, &p, &length) != 0) 
+	  do
 	    {
-	      generate_error (&dtp->common, LIBERROR_OS, NULL);
-	      break;
-	    }
-
-	  if (length == 0)
-	    {
-	      dtp->u.p.current_unit->endfile = AT_ENDFILE;
-	      break;
+              errno = 0;
+              cc = fbuf_getc (dtp->u.p.current_unit);
+	      if (cc == EOF) 
+		{
+                  if (errno != 0)
+                    generate_error (&dtp->common, LIBERROR_OS, NULL);
+                  else
+                    hit_eof (dtp);
+		  break;
+                }
+	      
+	      if (is_stream_io (dtp))
+		dtp->u.p.current_unit->strm_pos++;
+              
+              p = (char) cc;
 	    }
-
-	  if (is_stream_io (dtp))
-	    dtp->u.p.current_unit->strm_pos++;
+	  while (p != '\n');
 	}
-      while (p != '\n');
-
       break;
     }
-
-  if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
-      && !dtp->u.p.namelist_mode
-      && dtp->u.p.current_unit->endfile == NO_ENDFILE
-      && (file_length (dtp->u.p.current_unit->s) ==
-	 file_position (dtp->u.p.current_unit->s)))
-    dtp->u.p.current_unit->endfile = AT_ENDFILE;
-
 }
 
 
 /* Small utility function to write a record marker, taking care of
    byte swapping and of choosing the correct size.  */
 
-inline static int
+static int
 write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
 {
   size_t len;
@@ -2595,12 +2768,12 @@ write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
 	{
 	case sizeof (GFC_INTEGER_4):
 	  buf4 = buf;
-	  return swrite (dtp->u.p.current_unit->s, &buf4, &len);
+	  return swrite (dtp->u.p.current_unit->s, &buf4, len);
 	  break;
 
 	case sizeof (GFC_INTEGER_8):
 	  buf8 = buf;
-	  return swrite (dtp->u.p.current_unit->s, &buf8, &len);
+	  return swrite (dtp->u.p.current_unit->s, &buf8, len);
 	  break;
 
 	default:
@@ -2615,13 +2788,13 @@ write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
 	case sizeof (GFC_INTEGER_4):
 	  buf4 = buf;
 	  reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4));
-	  return swrite (dtp->u.p.current_unit->s, p, &len);
+	  return swrite (dtp->u.p.current_unit->s, p, len);
 	  break;
 
 	case sizeof (GFC_INTEGER_8):
 	  buf8 = buf;
 	  reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_8));
-	  return swrite (dtp->u.p.current_unit->s, p, &len);
+	  return swrite (dtp->u.p.current_unit->s, p, len);
 	  break;
 
 	default:
@@ -2644,7 +2817,7 @@ next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
   /* Bytes written.  */
   m = dtp->u.p.current_unit->recl_subrecord
     - dtp->u.p.current_unit->bytes_left_subrecord;
-  c = file_position (dtp->u.p.current_unit->s);
+  c = stell (dtp->u.p.current_unit->s);
 
   /* Write the length tail.  If we finish a record containing
      subrecords, we write out the negative length.  */
@@ -2654,7 +2827,7 @@ next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
   else
     m_write = m;
 
-  if (unlikely (write_us_marker (dtp, m_write) != 0))
+  if (unlikely (write_us_marker (dtp, m_write) < 0))
     goto io_error;
 
   if (compile_options.record_marker == 0)
@@ -2665,8 +2838,8 @@ next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
   /* Seek to the head and overwrite the bogus length with the real
      length.  */
 
-  if (unlikely (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
-		== FAILURE))
+  if (unlikely (sseek (dtp->u.p.current_unit->s, c - m - record_marker, 
+		       SEEK_SET) < 0))
     goto io_error;
 
   if (next_subrecord)
@@ -2674,13 +2847,13 @@ next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
   else
     m_write = m;
 
-  if (unlikely (write_us_marker (dtp, m_write) != 0))
+  if (unlikely (write_us_marker (dtp, m_write) < 0))
     goto io_error;
 
   /* Seek past the end of the current record.  */
 
-  if (unlikely (sseek (dtp->u.p.current_unit->s, c + record_marker)
-		== FAILURE))
+  if (unlikely (sseek (dtp->u.p.current_unit->s, c + record_marker, 
+		       SEEK_SET) < 0))
     goto io_error;
 
   return;
@@ -2691,6 +2864,35 @@ next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
 
 }
 
+
+/* Utility function like memset() but operating on streams. Return
+   value is same as for POSIX write().  */
+
+static ssize_t
+sset (stream * s, int c, ssize_t nbyte)
+{
+  static const int WRITE_CHUNK = 256;
+  char p[WRITE_CHUNK];
+  ssize_t bytes_left, trans;
+
+  if (nbyte < WRITE_CHUNK)
+    memset (p, c, nbyte);
+  else
+    memset (p, c, WRITE_CHUNK);
+
+  bytes_left = nbyte;
+  while (bytes_left > 0)
+    {
+      trans = (bytes_left < WRITE_CHUNK) ? bytes_left : WRITE_CHUNK;
+      trans = swrite (s, p, trans);
+      if (trans < 0)
+	return trans;
+      bytes_left -= trans;
+    }
+	       
+  return nbyte - bytes_left;
+}
+
 /* Position to the next record in write mode.  */
 
 static void
@@ -2699,9 +2901,6 @@ next_record_w (st_parameter_dt *dtp, int done)
   gfc_offset m, record, max_pos;
   int length;
 
-  /* Flush and reset the format buffer.  */
-  fbuf_flush (dtp->u.p.current_unit, 1);
-  
   /* Zero counters for X- and T-editing.  */
   max_pos = dtp->u.p.max_pos;
   dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
@@ -2716,8 +2915,11 @@ next_record_w (st_parameter_dt *dtp, int done)
       if (dtp->u.p.current_unit->bytes_left == 0)
 	break;
 
+      fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
+      fbuf_flush (dtp->u.p.current_unit, WRITING);
       if (sset (dtp->u.p.current_unit->s, ' ', 
-		dtp->u.p.current_unit->bytes_left) == FAILURE)
+		dtp->u.p.current_unit->bytes_left) 
+	  != dtp->u.p.current_unit->bytes_left)
 	goto io_error;
 
       break;
@@ -2726,7 +2928,7 @@ next_record_w (st_parameter_dt *dtp, int done)
       if (dtp->u.p.current_unit->bytes_left > 0)
 	{
 	  length = (int) dtp->u.p.current_unit->bytes_left;
-	  if (sset (dtp->u.p.current_unit->s, 0, length) == FAILURE)
+	  if (sset (dtp->u.p.current_unit->s, 0, length) != length)
 	    goto io_error;
 	}
       break;
@@ -2757,8 +2959,7 @@ next_record_w (st_parameter_dt *dtp, int done)
 		{
 		  length = (int) (max_pos - m);
 		  if (sseek (dtp->u.p.current_unit->s, 
-			      file_position (dtp->u.p.current_unit->s) 
-			      + length) == FAILURE)
+			     length, SEEK_CUR) < 0)
 		    {
 		      generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
 		      return;
@@ -2766,7 +2967,7 @@ next_record_w (st_parameter_dt *dtp, int done)
 		  length = (int) (dtp->u.p.current_unit->recl - max_pos);
 		}
 
-	      if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
+	      if (sset (dtp->u.p.current_unit->s, ' ', length) != length)
 		{
 		  generate_error (&dtp->common, LIBERROR_END, NULL);
 		  return;
@@ -2782,7 +2983,7 @@ next_record_w (st_parameter_dt *dtp, int done)
 	      /* Now seek to this record */
 	      record = record * dtp->u.p.current_unit->recl;
 
-	      if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
+	      if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
 		{
 		  generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
 		  return;
@@ -2805,8 +3006,7 @@ next_record_w (st_parameter_dt *dtp, int done)
 		    {
 		      length = (int) (max_pos - m);
 		      if (sseek (dtp->u.p.current_unit->s, 
-				  file_position (dtp->u.p.current_unit->s)
-				  + length) == FAILURE)
+				 length, SEEK_CUR) < 0)
 		        {
 			  generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
 			  return;
@@ -2817,7 +3017,7 @@ next_record_w (st_parameter_dt *dtp, int done)
 		    length = (int) dtp->u.p.current_unit->bytes_left;
 		}
 
-	      if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
+	      if (sset (dtp->u.p.current_unit->s, ' ', length) != length)
 		{
 		  generate_error (&dtp->common, LIBERROR_END, NULL);
 		  return;
@@ -2826,23 +3026,27 @@ next_record_w (st_parameter_dt *dtp, int done)
 	}
       else
 	{
-	  size_t len;
-	  const char crlf[] = "\r\n";
-
 #ifdef HAVE_CRLF
-	  len = 2;
+	  const int len = 2;
 #else
-	  len = 1;
+	  const int len = 1;
 #endif
-	  if (swrite (dtp->u.p.current_unit->s, &crlf[2-len], &len) != 0)
-	    goto io_error;
-	  
+          fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
+          char * p = fbuf_alloc (dtp->u.p.current_unit, len);
+          if (!p)
+            goto io_error;
+#ifdef HAVE_CRLF
+          *(p++) = '\r';
+#endif
+          *p = '\n';
 	  if (is_stream_io (dtp))
 	    {
 	      dtp->u.p.current_unit->strm_pos += len;
 	      if (dtp->u.p.current_unit->strm_pos
 		  < file_length (dtp->u.p.current_unit->s))
-		struncate (dtp->u.p.current_unit->s);
+		unit_truncate (dtp->u.p.current_unit,
+                               dtp->u.p.current_unit->strm_pos - 1,
+                               &dtp->common);
 	    }
 	}
 
@@ -2880,7 +3084,7 @@ next_record (st_parameter_dt *dtp, int done)
       dtp->u.p.current_unit->current_record = 0;
       if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
 	{
-	  fp = file_position (dtp->u.p.current_unit->s);
+	  fp = stell (dtp->u.p.current_unit->s);
 	  /* Calculate next record, rounding up partial records.  */
 	  dtp->u.p.current_unit->last_record =
 	    (fp + dtp->u.p.current_unit->recl - 1) /
@@ -2892,6 +3096,8 @@ next_record (st_parameter_dt *dtp, int done)
 
   if (!done)
     pre_position (dtp);
+
+  fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
 }
 
 
@@ -2940,7 +3146,6 @@ finalize_transfer (st_parameter_dt *dtp)
   if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
     {
       finish_list_read (dtp);
-      sfree (dtp->u.p.current_unit->s);
       return;
     }
 
@@ -2955,10 +3160,9 @@ finalize_transfer (st_parameter_dt *dtp)
 	next_record (dtp, 1);
 
       if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
-	  && file_position (dtp->u.p.current_unit->s) >= dtp->rec)
+	  && stell (dtp->u.p.current_unit->s) >= dtp->rec)
 	{
-	  flush (dtp->u.p.current_unit->s);
-	  sfree (dtp->u.p.current_unit->s);
+	  sflush (dtp->u.p.current_unit->s);
 	}
       return;
     }
@@ -2967,9 +3171,8 @@ finalize_transfer (st_parameter_dt *dtp)
 
   if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar)
     {
+      fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
       dtp->u.p.seen_dollar = 0;
-      fbuf_flush (dtp->u.p.current_unit, 1);
-      sfree (dtp->u.p.current_unit->s);
       return;
     }
 
@@ -2981,15 +3184,17 @@ finalize_transfer (st_parameter_dt *dtp)
 	- dtp->u.p.current_unit->bytes_left);
       dtp->u.p.current_unit->saved_pos =
 	dtp->u.p.max_pos > 0 ? dtp->u.p.max_pos - bytes_written : 0;
-      fbuf_flush (dtp->u.p.current_unit, 0);
-      flush (dtp->u.p.current_unit->s);
+      fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
+      sflush (dtp->u.p.current_unit->s);
       return;
     }
+  else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED 
+           && dtp->u.p.mode == WRITING && !is_internal_unit (dtp))
+      fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);    
 
   dtp->u.p.current_unit->saved_pos = 0;
 
   next_record (dtp, 1);
-  sfree (dtp->u.p.current_unit->s);
 }
 
 /* Transfer function for IOLENGTH. It doesn't actually do any
@@ -3046,8 +3251,6 @@ void
 st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
 {
   free_ionml (dtp);
-  if (dtp->u.p.scratch != NULL)
-    free_mem (dtp->u.p.scratch);
   library_end ();
 }
 
@@ -3063,29 +3266,6 @@ st_read (st_parameter_dt *dtp)
   library_start (&dtp->common);
 
   data_transfer_init (dtp, 1);
-
-  /* Handle complications dealing with the endfile record.  */
-
-  if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
-    switch (dtp->u.p.current_unit->endfile)
-      {
-      case NO_ENDFILE:
-	break;
-
-      case AT_ENDFILE:
-	if (!is_internal_unit (dtp))
-	  {
-	    generate_error (&dtp->common, LIBERROR_END, NULL);
-	    dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
-	    dtp->u.p.current_unit->current_record = 0;
-	  }
-	break;
-
-      case AFTER_ENDFILE:
-	generate_error (&dtp->common, LIBERROR_ENDFILE, NULL);
-	dtp->u.p.current_unit->current_record = 0;
-	break;
-      }
 }
 
 extern void st_read_done (st_parameter_dt *);
@@ -3095,10 +3275,9 @@ void
 st_read_done (st_parameter_dt *dtp)
 {
   finalize_transfer (dtp);
-  free_format_data (dtp);
+  if (is_internal_unit (dtp))
+    free_format_data (dtp->u.p.fmt);
   free_ionml (dtp);
-  if (dtp->u.p.scratch != NULL)
-    free_mem (dtp->u.p.scratch);
   if (dtp->u.p.current_unit != NULL)
     unlock_unit (dtp->u.p.current_unit);
 
@@ -3141,19 +3320,16 @@ st_write_done (st_parameter_dt *dtp)
       case NO_ENDFILE:
 	/* Get rid of whatever is after this record.  */
         if (!is_internal_unit (dtp))
-	  {
-	    flush (dtp->u.p.current_unit->s);
-	    if (struncate (dtp->u.p.current_unit->s) == FAILURE)
-	      generate_error (&dtp->common, LIBERROR_OS, NULL);
-	  }
+          unit_truncate (dtp->u.p.current_unit, 
+                         stell (dtp->u.p.current_unit->s),
+                         &dtp->common);
 	dtp->u.p.current_unit->endfile = AT_ENDFILE;
 	break;
       }
 
-  free_format_data (dtp);
+  if (is_internal_unit (dtp))
+    free_format_data (dtp->u.p.fmt);
   free_ionml (dtp);
-  if (dtp->u.p.scratch != NULL)
-    free_mem (dtp->u.p.scratch);
   if (dtp->u.p.current_unit != NULL)
     unlock_unit (dtp->u.p.current_unit);
   
@@ -3267,3 +3443,46 @@ void reverse_memcpy (void *dest, const void *src, size_t n)
   for (i=0; i<n; i++)
       *(d++) = *(s--);
 }
+
+
+/* Once upon a time, a poor innocent Fortran program was reading a
+   file, when suddenly it hit the end-of-file (EOF).  Unfortunately
+   the OS doesn't tell whether we're at the EOF or whether we already
+   went past it.  Luckily our hero, libgfortran, keeps track of this.
+   Call this function when you detect an EOF condition.  See Section
+   9.10.2 in F2003.  */
+
+void
+hit_eof (st_parameter_dt * dtp)
+{
+  dtp->u.p.current_unit->flags.position = POSITION_APPEND;
+
+  if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+    switch (dtp->u.p.current_unit->endfile)
+      {
+      case NO_ENDFILE:
+      case AT_ENDFILE:
+        generate_error (&dtp->common, LIBERROR_END, NULL);
+	if (!is_internal_unit (dtp))
+	  {
+	    dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
+	    dtp->u.p.current_unit->current_record = 0;
+	  }
+        else
+          dtp->u.p.current_unit->endfile = AT_ENDFILE;
+	break;
+        
+      case AFTER_ENDFILE:
+	generate_error (&dtp->common, LIBERROR_ENDFILE, NULL);
+	dtp->u.p.current_unit->current_record = 0;
+	break;
+      }
+  else
+    {
+      /* Non-sequential files don't have an ENDFILE record, so we
+         can't be at AFTER_ENDFILE.  */
+      dtp->u.p.current_unit->endfile = AT_ENDFILE;
+      generate_error (&dtp->common, LIBERROR_END, NULL);
+      dtp->u.p.current_unit->current_record = 0;
+    }
+}

libgfortran/io/unit.c

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

libgfortran/io/unix.c

@@ -94,10 +94,6 @@ id_from_fd (const int fd)
 
 #endif
 
-#ifndef SSIZE_MAX
-#define SSIZE_MAX SHRT_MAX
-#endif
-
 #ifndef PATH_MAX
 #define PATH_MAX 1024
 #endif
@@ -129,102 +125,32 @@ id_from_fd (const int fd)
 #endif
 
 
-/* Unix stream I/O module */
+/* Unix and internal stream I/O module */
 
-#define BUFFER_SIZE 8192
+static const int BUFFER_SIZE = 8192;
 
 typedef struct
 {
   stream st;
 
-  int fd;
   gfc_offset buffer_offset;	/* File offset of the start of the buffer */
   gfc_offset physical_offset;	/* Current physical file offset */
   gfc_offset logical_offset;	/* Current logical file offset */
-  gfc_offset dirty_offset;	/* Start of modified bytes in buffer */
   gfc_offset file_length;	/* Length of the file, -1 if not seekable. */
 
-  int len;			/* Physical length of the current buffer */
+  char *buffer;                 /* Pointer to the buffer.  */
+  int fd;                       /* The POSIX file descriptor.  */
+
   int active;			/* Length of valid bytes in the buffer */
 
   int prot;
-  int ndirty;			/* Dirty bytes starting at dirty_offset */
+  int ndirty;			/* Dirty bytes starting at buffer_offset */
 
   int special_file;		/* =1 if the fd refers to a special file */
-
-  io_mode method;		/* Method of stream I/O being used */
-
-  char *buffer;
-  char small_buffer[BUFFER_SIZE];
 }
 unix_stream;
 
 
-/* Stream structure for internal files. Fields must be kept in sync
-   with unix_stream above, except for the buffer. For internal files
-   we point the buffer pointer directly at the destination memory.  */
-
-typedef struct
-{
-  stream st;
-
-  int fd;
-  gfc_offset buffer_offset;	/* File offset of the start of the buffer */
-  gfc_offset physical_offset;	/* Current physical file offset */
-  gfc_offset logical_offset;	/* Current logical file offset */
-  gfc_offset dirty_offset;	/* Start of modified bytes in buffer */
-  gfc_offset file_length;	/* Length of the file, -1 if not seekable. */
-
-  int len;			/* Physical length of the current buffer */
-  int active;			/* Length of valid bytes in the buffer */
-
-  int prot;
-  int ndirty;			/* Dirty bytes starting at dirty_offset */
-
-  int special_file;		/* =1 if the fd refers to a special file */
-
-  io_mode method;		/* Method of stream I/O being used */
-
-  char *buffer;
-}
-int_stream;
-
-/* This implementation of stream I/O is based on the paper:
- *
- *  "Exploiting the advantages of mapped files for stream I/O",
- *  O. Krieger, M. Stumm and R. Umrau, "Proceedings of the 1992 Winter
- *  USENIX conference", p. 27-42.
- *
- * It differs in a number of ways from the version described in the
- * paper.  First of all, threads are not an issue during I/O and we
- * also don't have to worry about having multiple regions, since
- * fortran's I/O model only allows you to be one place at a time.
- *
- * On the other hand, we have to be able to writing at the end of a
- * stream, read from the start of a stream or read and write blocks of
- * bytes from an arbitrary position.  After opening a file, a pointer
- * to a stream structure is returned, which is used to handle file
- * accesses until the file is closed.
- *
- * salloc_at_r(stream, len, where)-- Given a stream pointer, return a
- * pointer to a block of memory that mirror the file at position
- * 'where' that is 'len' bytes long.  The len integer is updated to
- * reflect how many bytes were actually read.  The only reason for a
- * short read is end of file.  The file pointer is updated.  The
- * pointer is valid until the next call to salloc_*.
- *
- * salloc_at_w(stream, len, where)-- Given the stream pointer, returns
- * a pointer to a block of memory that is updated to reflect the state
- * of the file.  The length of the buffer is always equal to that
- * requested.  The buffer must be completely set by the caller.  When
- * data has been written, the sfree() function must be called to
- * indicate that the caller is done writing data to the buffer.  This
- * may or may not cause a physical write.
- *
- * Short forms of these are salloc_r() and salloc_w() which drop the
- * 'where' parameter and use the current file pointer. */
-
-
 /*move_pos_offset()--  Move the record pointer right or left
  *relative to current position */
 
@@ -236,15 +162,12 @@ move_pos_offset (stream* st, int pos_off)
     {
       str->logical_offset += pos_off;
 
-      if (str->dirty_offset + str->ndirty > str->logical_offset)
+      if (str->ndirty > str->logical_offset)
 	{
 	  if (str->ndirty + pos_off > 0)
 	    str->ndirty += pos_off;
 	  else
-	    {
-	      str->dirty_offset +=  pos_off + pos_off;
-	      str->ndirty = 0;
-	    }
+            str->ndirty = 0;
 	}
 
     return pos_off;
@@ -327,580 +250,330 @@ flush_if_preconnected (stream * s)
 }
 
 
-/* Reset a stream after reading/writing. Assumes that the buffers have
-   been flushed.  */
+/* get_oserror()-- Get the most recent operating system error.  For
+ * unix, this is errno. */
 
-inline static void
-reset_stream (unix_stream * s, size_t bytes_rw)
+const char *
+get_oserror (void)
 {
-  s->physical_offset += bytes_rw;
-  s->logical_offset = s->physical_offset;
-  if (s->file_length != -1 && s->physical_offset > s->file_length)
-    s->file_length = s->physical_offset;
+  return strerror (errno);
 }
 
 
-/* Read bytes into a buffer, allowing for short reads.  If the nbytes
- * argument is less on return than on entry, it is because we've hit
- * the end of file. */
+/********************************************************************
+Raw I/O functions (read, write, seek, tell, truncate, close).
+
+These functions wrap the basic POSIX I/O syscalls. Any deviation in
+semantics is a bug, except the following: write restarts in case
+of being interrupted by a signal, and as the first argument the
+functions take the unix_stream struct rather than an integer file
+descriptor. Also, for POSIX read() and write() a nbyte argument larger
+than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
+than size_t as for POSIX read/write.
+*********************************************************************/
 
 static int
-do_read (unix_stream * s, void * buf, size_t * nbytes)
+raw_flush (unix_stream * s  __attribute__ ((unused)))
 {
-  ssize_t trans;
-  size_t bytes_left;
-  char *buf_st;
-  int status;
-
-  status = 0;
-  bytes_left = *nbytes;
-  buf_st = (char *) buf;
-
-  /* We must read in a loop since some systems don't restart system
-     calls in case of a signal.  */
-  while (bytes_left > 0)
-    {
-      /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
-	 so we must read in chunks smaller than SSIZE_MAX.  */
-      trans = (bytes_left < SSIZE_MAX) ? bytes_left : SSIZE_MAX;
-      trans = read (s->fd, buf_st, trans);
-      if (trans < 0)
-	{
-	  if (errno == EINTR)
-	    continue;
-	  else
-	    {
-	      status = errno;
-	      break;
-	    }
-	}
-      else if (trans == 0) /* We hit EOF.  */
-	break;
-      buf_st += trans;
-      bytes_left -= trans;
-    }
-
-  *nbytes -= bytes_left;
-  return status;
+  return 0;
 }
 
+static ssize_t
+raw_read (unix_stream * s, void * buf, ssize_t nbyte)
+{
+  /* For read we can't do I/O in a loop like raw_write does, because
+     that will break applications that wait for interactive I/O.  */
+  return read (s->fd, buf, nbyte);
+}
 
-/* Write a buffer to a stream, allowing for short writes.  */
-
-static int
-do_write (unix_stream * s, const void * buf, size_t * nbytes)
+static ssize_t
+raw_write (unix_stream * s, const void * buf, ssize_t nbyte)
 {
-  ssize_t trans;
-  size_t bytes_left;
+  ssize_t trans, bytes_left;
   char *buf_st;
-  int status;
 
-  status = 0;
-  bytes_left = *nbytes;
+  bytes_left = nbyte;
   buf_st = (char *) buf;
 
   /* We must write in a loop since some systems don't restart system
      calls in case of a signal.  */
   while (bytes_left > 0)
     {
-      /* Requests between SSIZE_MAX and SIZE_MAX are undefined by SUSv3,
-	 so we must write in chunks smaller than SSIZE_MAX.  */
-      trans = (bytes_left < SSIZE_MAX) ? bytes_left : SSIZE_MAX;
-      trans = write (s->fd, buf_st, trans);
+      trans = write (s->fd, buf_st, bytes_left);
       if (trans < 0)
 	{
 	  if (errno == EINTR)
 	    continue;
 	  else
-	    {
-	      status = errno;
-	      break;
-	    }
+	    return trans;
 	}
       buf_st += trans;
       bytes_left -= trans;
     }
 
-  *nbytes -= bytes_left;
-  return status;
+  return nbyte - bytes_left;
 }
 
+static off_t
+raw_seek (unix_stream * s, off_t offset, int whence)
+{
+  return lseek (s->fd, offset, whence);
+}
 
-/* get_oserror()-- Get the most recent operating system error.  For
- * unix, this is errno. */
+static off_t
+raw_tell (unix_stream * s)
+{
+  return lseek (s->fd, 0, SEEK_CUR);
+}
 
-const char *
-get_oserror (void)
+static int
+raw_truncate (unix_stream * s, off_t length)
 {
-  return strerror (errno);
+#ifdef HAVE_FTRUNCATE
+  return ftruncate (s->fd, length);
+#elif defined HAVE_CHSIZE
+  return chsize (s->fd, length);
+#else
+  runtime_error ("required ftruncate or chsize support not present");
+  return -1;
+#endif
 }
 
+static int
+raw_close (unix_stream * s)
+{
+  int retval;
+  
+  retval = close (s->fd);
+  free_mem (s);
+  return retval;
+}
 
-/*********************************************************************
-    File descriptor stream functions
-*********************************************************************/
+static int
+raw_init (unix_stream * s)
+{
+  s->st.read = (void *) raw_read;
+  s->st.write = (void *) raw_write;
+  s->st.seek = (void *) raw_seek;
+  s->st.tell = (void *) raw_tell;
+  s->st.truncate = (void *) raw_truncate;
+  s->st.close = (void *) raw_close;
+  s->st.flush = (void *) raw_flush;
 
+  s->buffer = NULL;
+  return 0;
+}
 
-/* fd_flush()-- Write bytes that need to be written */
 
-static try
-fd_flush (unix_stream * s)
+/*********************************************************************
+Buffered I/O functions. These functions have the same semantics as the
+raw I/O functions above, except that they are buffered in order to
+improve performance. The buffer must be flushed when switching from
+reading to writing and vice versa.
+*********************************************************************/
+
+static int
+buf_flush (unix_stream * s)
 {
-  size_t writelen;
+  int writelen;
+
+  /* Flushing in read mode means discarding read bytes.  */
+  s->active = 0;
 
   if (s->ndirty == 0)
-    return SUCCESS;
+    return 0;
   
-  if (s->file_length != -1 && s->physical_offset != s->dirty_offset &&
-      lseek (s->fd, s->dirty_offset, SEEK_SET) < 0)
-    return FAILURE;
+  if (s->file_length != -1 && s->physical_offset != s->buffer_offset
+      && lseek (s->fd, s->buffer_offset, SEEK_SET) < 0)
+    return -1;
 
-  writelen = s->ndirty;
-  if (do_write (s, s->buffer + (s->dirty_offset - s->buffer_offset),
-		&writelen) != 0)
-    return FAILURE;
+  writelen = raw_write (s, s->buffer, s->ndirty);
 
-  s->physical_offset = s->dirty_offset + writelen;
+  s->physical_offset = s->buffer_offset + writelen;
 
-  /* don't increment file_length if the file is non-seekable */
+  /* Don't increment file_length if the file is non-seekable.  */
   if (s->file_length != -1 && s->physical_offset > s->file_length)
-      s->file_length = s->physical_offset; 
+      s->file_length = s->physical_offset;
 
   s->ndirty -= writelen;
   if (s->ndirty != 0)
-    return FAILURE;
+    return -1;
 
-  return SUCCESS;
+  return 0;
 }
 
-
-/* fd_alloc()-- Arrange a buffer such that the salloc() request can be
- * satisfied.  This subroutine gets the buffer ready for whatever is
- * to come next. */
-
-static void
-fd_alloc (unix_stream * s, gfc_offset where,
-	  int *len __attribute__ ((unused)))
+static ssize_t
+buf_read (unix_stream * s, void * buf, ssize_t nbyte)
 {
-  char *new_buffer;
-  int n, read_len;
+  if (s->active == 0)
+    s->buffer_offset = s->logical_offset;
 
-  if (*len <= BUFFER_SIZE)
-    {
-      new_buffer = s->small_buffer;
-      read_len = BUFFER_SIZE;
-    }
+  /* Is the data we want in the buffer?  */
+  if (s->logical_offset + nbyte <= s->buffer_offset + s->active
+      && s->buffer_offset <= s->logical_offset)
+    memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset), nbyte);
   else
     {
-      new_buffer = get_mem (*len);
-      read_len = *len;
-    }
-
-  /* Salvage bytes currently within the buffer.  This is important for
-   * devices that cannot seek. */
-
-  if (s->buffer != NULL && s->buffer_offset <= where &&
-      where <= s->buffer_offset + s->active)
-    {
-
-      n = s->active - (where - s->buffer_offset);
-      memmove (new_buffer, s->buffer + (where - s->buffer_offset), n);
-
-      s->active = n;
-    }
-  else
-    {				/* new buffer starts off empty */
-      s->active = 0;
+      /* First copy the active bytes if applicable, then read the rest
+         either directly or filling the buffer.  */
+      char *p;
+      int nread = 0;
+      ssize_t to_read, did_read;
+      gfc_offset new_logical;
+      
+      p = (char *) buf;
+      if (s->logical_offset >= s->buffer_offset 
+          && s->buffer_offset + s->active >= s->logical_offset)
+        {
+          nread = s->active - (s->logical_offset - s->buffer_offset);
+          memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset), 
+                  nread);
+          p += nread;
+        }
+      /* At this point we consider all bytes in the buffer discarded.  */
+      to_read = nbyte - nread;
+      new_logical = s->logical_offset + nread;
+      if (s->file_length != -1 && s->physical_offset != new_logical
+          && lseek (s->fd, new_logical, SEEK_SET) < 0)
+        return -1;
+      s->buffer_offset = s->physical_offset = new_logical;
+      if (to_read <= BUFFER_SIZE/2)
+        {
+          did_read = raw_read (s, s->buffer, BUFFER_SIZE);
+          s->physical_offset += did_read;
+          s->active = did_read;
+          did_read = (did_read > to_read) ? to_read : did_read;
+          memcpy (p, s->buffer, did_read);
+        }
+      else
+        {
+          did_read = raw_read (s, p, to_read);
+          s->physical_offset += did_read;
+          s->active = 0;
+        }
+      nbyte = did_read + nread;
     }
-
-  s->buffer_offset = where;
-
-  /* free the old buffer if necessary */
-
-  if (s->buffer != NULL && s->buffer != s->small_buffer)
-    free_mem (s->buffer);
-
-  s->buffer = new_buffer;
-  s->len = read_len;
+  s->logical_offset += nbyte;
+  return nbyte;
 }
 
-
-/* fd_alloc_r_at()-- Allocate a stream buffer for reading.  Either
- * we've already buffered the data or we need to load it.  Returns
- * NULL on I/O error. */
-
-static char *
-fd_alloc_r_at (unix_stream * s, int *len)
+static ssize_t
+buf_write (unix_stream * s, const void * buf, ssize_t nbyte)
 {
-  gfc_offset m;
-  gfc_offset where = s->logical_offset;
-
-  if (s->buffer != NULL && s->buffer_offset <= where &&
-      where + *len <= s->buffer_offset + s->active)
-    {
-
-      /* Return a position within the current buffer */
-
-      s->logical_offset = where + *len;
-      return s->buffer + where - s->buffer_offset;
-    }
-
-  fd_alloc (s, where, len);
-
-  m = where + s->active;
-
-  if (s->physical_offset != m && lseek (s->fd, m, SEEK_SET) < 0)
-    return NULL;
-
-  /* do_read() hangs on read from terminals for *BSD-systems.  Only
-     use read() in that case.  */
-
-  if (s->special_file)
+  if (s->ndirty == 0)
+    s->buffer_offset = s->logical_offset;
+
+  /* Does the data fit into the buffer?  As a special case, if the
+     buffer is empty and the request is bigger than BUFFER_SIZE/2,
+     write directly. This avoids the case where the buffer would have
+     to be flushed at every write.  */
+  if (!(s->ndirty == 0 && nbyte > BUFFER_SIZE/2)
+      && s->logical_offset + nbyte <= s->buffer_offset + BUFFER_SIZE
+      && s->buffer_offset <= s->logical_offset
+      && s->buffer_offset + s->ndirty >= s->logical_offset)
     {
-      ssize_t n;
-
-      n = read (s->fd, s->buffer + s->active, s->len - s->active);
-      if (n < 0)
-	return NULL;
-
-      s->physical_offset = m + n;
-      s->active += n;
+      memcpy (s->buffer + (s->logical_offset - s->buffer_offset), buf, nbyte);
+      int nd = (s->logical_offset - s->buffer_offset) + nbyte;
+      if (nd > s->ndirty)
+        s->ndirty = nd;
     }
   else
     {
-      size_t n;
-
-      n = s->len - s->active;
-      if (do_read (s, s->buffer + s->active, &n) != 0)
-	return NULL;
-
-      s->physical_offset = m + n;
-      s->active += n;
-    }
-
-  if (s->active < *len)
-    *len = s->active;		/* Bytes actually available */
-
-  s->logical_offset = where + *len;
-
-  return s->buffer;
-}
-
-
-/* fd_alloc_w_at()-- Allocate a stream buffer for writing.  Either
- * we've already buffered the data or we need to load it. */
-
-static char *
-fd_alloc_w_at (unix_stream * s, int *len)
-{
-  gfc_offset n;
-  gfc_offset where = s->logical_offset;
-
-  if (s->buffer == NULL || s->buffer_offset > where ||
-      where + *len > s->buffer_offset + s->len)
-    {
-
-      if (fd_flush (s) == FAILURE)
-	return NULL;
-      fd_alloc (s, where, len);
-    }
-
-  /* Return a position within the current buffer */
-  if (s->ndirty == 0 
-      || where > s->dirty_offset + s->ndirty    
-      || s->dirty_offset > where + *len)
-    {  /* Discontiguous blocks, start with a clean buffer.  */  
-	/* Flush the buffer.  */  
-      if (s->ndirty != 0)    
-	fd_flush (s);  
-      s->dirty_offset = where;  
-      s->ndirty = *len;
-    }
-  else
-    {  
-      gfc_offset start;  /* Merge with the existing data.  */  
-      if (where < s->dirty_offset)    
-	start = where;  
-      else    
-	start = s->dirty_offset;  
-      if (where + *len > s->dirty_offset + s->ndirty)    
-	s->ndirty = where + *len - start;  
-      else    
-	s->ndirty = s->dirty_offset + s->ndirty - start;  
-      s->dirty_offset = start;
+      /* Flush, and either fill the buffer with the new data, or if
+         the request is bigger than the buffer size, write directly
+         bypassing the buffer.  */
+      buf_flush (s);
+      if (nbyte <= BUFFER_SIZE/2)
+        {
+          memcpy (s->buffer, buf, nbyte);
+          s->buffer_offset = s->logical_offset;
+          s->ndirty += nbyte;
+        }
+      else
+        {
+          if (s->file_length != -1 && s->physical_offset != s->logical_offset
+              && lseek (s->fd, s->logical_offset, SEEK_SET) < 0)
+            return -1;
+          nbyte = raw_write (s, buf, nbyte);
+          s->physical_offset += nbyte;
+        }
     }
-
-  s->logical_offset = where + *len;
-
+  s->logical_offset += nbyte;
   /* Don't increment file_length if the file is non-seekable.  */
-
   if (s->file_length != -1 && s->logical_offset > s->file_length)
-     s->file_length = s->logical_offset;
-
-  n = s->logical_offset - s->buffer_offset;
-  if (n > s->active)
-    s->active = n;
-
-  return s->buffer + where - s->buffer_offset;
+    s->file_length = s->logical_offset;
+  return nbyte;
 }
 
-
-static try
-fd_sfree (unix_stream * s)
-{
-  if (s->ndirty != 0 &&
-      (s->buffer != s->small_buffer || options.all_unbuffered ||
-       s->method == SYNC_UNBUFFERED))
-    return fd_flush (s);
-
-  return SUCCESS;
-}
-
-
-static try
-fd_seek (unix_stream * s, gfc_offset offset)
-{
-
-  if (s->file_length == -1)
-    return SUCCESS;
-
-  if (s->physical_offset == offset) /* Are we lucky and avoid syscall?  */
-    {
-      s->logical_offset = offset;
-      return SUCCESS;
-    }
-
-  if (lseek (s->fd, offset, SEEK_SET) >= 0)
-    {
-      s->physical_offset = s->logical_offset = offset;
-      s->active = 0;
-      return SUCCESS;
-    }
-
-  return FAILURE;
-}
-
-
-/* truncate_file()-- Given a unit, truncate the file at the current
- * position.  Sets the physical location to the new end of the file.
- * Returns nonzero on error. */
-
-static try
-fd_truncate (unix_stream * s)
+static off_t
+buf_seek (unix_stream * s, off_t offset, int whence)
 {
-  /* Non-seekable files, like terminals and fifo's fail the lseek so just
-     return success, there is nothing to truncate.  If its not a pipe there
-     is a real problem.  */
-  if (lseek (s->fd, s->logical_offset, SEEK_SET) == -1)
+  switch (whence)
     {
-      if (errno == ESPIPE)
-	return SUCCESS;
-      else
-	return FAILURE;
+    case SEEK_SET:
+      break;
+    case SEEK_CUR:
+      offset += s->logical_offset;
+      break;
+    case SEEK_END:
+      offset += s->file_length;
+      break;
+    default:
+      return -1;
     }
-
-  /* Using ftruncate on a seekable special file (like /dev/null)
-     is undefined, so we treat it as if the ftruncate succeeded.  */
-  if (!s->special_file
-      && (
-#ifdef HAVE_FTRUNCATE
-	  ftruncate (s->fd, s->logical_offset) != 0
-#elif defined HAVE_CHSIZE
-	  chsize (s->fd, s->logical_offset) != 0
-#else
-	  /* If we have neither, always fail and exit, noisily.  */
-	  runtime_error ("required ftruncate or chsize support not present"), 1
-#endif
-	  ))
+  if (offset < 0)
     {
-      /* The truncation failed and we need to handle this gracefully.
-	 The file length remains the same, but the file-descriptor
-	 offset needs adjustment per the successful lseek above.
-	 (Similarly, the contents of the buffer isn't valid anymore.)
-	 A ftruncate call does not affect the physical (file-descriptor)
-	 offset, according to the ftruncate manual, so neither should a
-	 failed call.  */
-      s->physical_offset = s->logical_offset;
-      s->active = 0;
-      return FAILURE;
+      errno = EINVAL;
+      return -1;
     }
-
-  s->physical_offset = s->file_length = s->logical_offset;
-  s->active = 0;
-  return SUCCESS;
+  s->logical_offset = offset;
+  return offset;
 }
 
-
-/* Similar to memset(), but operating on a stream instead of a string.
-   Takes care of not using too much memory.  */
-
-static try
-fd_sset (unix_stream * s, int c, size_t n)
+static off_t
+buf_tell (unix_stream * s)
 {
-  size_t bytes_left;
-  int trans;
-  void *p;
-
-  bytes_left = n;
-
-  while (bytes_left > 0)
-    {
-      /* memset() in chunks of BUFFER_SIZE.  */
-      trans = (bytes_left < BUFFER_SIZE) ? bytes_left : BUFFER_SIZE;
-
-      p = fd_alloc_w_at (s, &trans);
-      if (p)
-	  memset (p, c, trans);
-      else
-	return FAILURE;
-
-      bytes_left -= trans;
-    }
-
-  return SUCCESS;
+  return s->logical_offset;
 }
 
-
-/* Stream read function. Avoids using a buffer for big reads. The
-   interface is like POSIX read(), but the nbytes argument is a
-   pointer; on return it contains the number of bytes written. The
-   function return value is the status indicator (0 for success).  */
-
 static int
-fd_read (unix_stream * s, void * buf, size_t * nbytes)
+buf_truncate (unix_stream * s, off_t length)
 {
-  void *p;
-  int tmp, status;
-
-  if (*nbytes < BUFFER_SIZE && s->method == SYNC_BUFFERED)
-    {
-      tmp = *nbytes;
-      p = fd_alloc_r_at (s, &tmp);
-      if (p)
-	{
-	  *nbytes = tmp;
-	  memcpy (buf, p, *nbytes);
-	  return 0;
-	}
-      else
-	{
-	  *nbytes = 0;
-	  return errno;
-	}
-    }
-
-  /* If the request is bigger than BUFFER_SIZE we flush the buffers
-     and read directly.  */
-  if (fd_flush (s) == FAILURE)
-    {
-      *nbytes = 0;
-      return errno;
-    }
-
-  if (is_seekable ((stream *) s) && fd_seek (s, s->logical_offset) == FAILURE)
-    {
-      *nbytes = 0;
-      return errno;
-    }
+  int r;
 
-  status = do_read (s, buf, nbytes);
-  reset_stream (s, *nbytes);
-  return status;
+  if (buf_flush (s) != 0)
+    return -1;
+  r = raw_truncate (s, length);
+  if (r == 0)
+    s->file_length = length;
+  return r;
 }
 
-
-/* Stream write function. Avoids using a buffer for big writes. The
-   interface is like POSIX write(), but the nbytes argument is a
-   pointer; on return it contains the number of bytes written. The
-   function return value is the status indicator (0 for success).  */
-
 static int
-fd_write (unix_stream * s, const void * buf, size_t * nbytes)
-{
-  void *p;
-  int tmp, status;
-
-  if (*nbytes < BUFFER_SIZE && s->method == SYNC_BUFFERED)
-    {
-      tmp = *nbytes;
-      p = fd_alloc_w_at (s, &tmp);
-      if (p)
-	{
-	  *nbytes = tmp;
-	  memcpy (p, buf, *nbytes);
-	  return 0;
-	}
-      else
-	{
-	  *nbytes = 0;
-	  return errno;
-	}
-    }
-
-  /* If the request is bigger than BUFFER_SIZE we flush the buffers
-     and write directly.  */
-  if (fd_flush (s) == FAILURE)
-    {
-      *nbytes = 0;
-      return errno;
-    }
-
-  if (is_seekable ((stream *) s) && fd_seek (s, s->logical_offset) == FAILURE)
-    {
-      *nbytes = 0;
-      return errno;
-    }
-
-  status =  do_write (s, buf, nbytes);
-  reset_stream (s, *nbytes);
-  return status;
-}
-
-
-static try
-fd_close (unix_stream * s)
+buf_close (unix_stream * s)
 {
-  if (fd_flush (s) == FAILURE)
-    return FAILURE;
-
-  if (s->buffer != NULL && s->buffer != s->small_buffer)
-    free_mem (s->buffer);
-
-  if (s->fd != STDOUT_FILENO && s->fd != STDERR_FILENO && s->fd != STDIN_FILENO)
-    {
-      if (close (s->fd) < 0)
-	return FAILURE;
-    }
-
-  free_mem (s);
-
-  return SUCCESS;
+  if (buf_flush (s) != 0)
+    return -1;
+  free_mem (s->buffer);
+  return raw_close (s);
 }
 
-
-static void
-fd_open (unix_stream * s)
+static int
+buf_init (unix_stream * s)
 {
-  if (isatty (s->fd))
-    s->method = SYNC_UNBUFFERED;
-  else
-    s->method = SYNC_BUFFERED;
-
-  s->st.alloc_w_at = (void *) fd_alloc_w_at;
-  s->st.sfree = (void *) fd_sfree;
-  s->st.close = (void *) fd_close;
-  s->st.seek = (void *) fd_seek;
-  s->st.trunc = (void *) fd_truncate;
-  s->st.read = (void *) fd_read;
-  s->st.write = (void *) fd_write;
-  s->st.set = (void *) fd_sset;
+  s->st.read = (void *) buf_read;
+  s->st.write = (void *) buf_write;
+  s->st.seek = (void *) buf_seek;
+  s->st.tell = (void *) buf_tell;
+  s->st.truncate = (void *) buf_truncate;
+  s->st.close = (void *) buf_close;
+  s->st.flush = (void *) buf_flush;
 
-  s->buffer = NULL;
+  s->buffer = get_mem (BUFFER_SIZE);
+  return 0;
 }
 
 
-
-
 /*********************************************************************
   memory stream functions - These are used for internal files
 
@@ -912,33 +585,33 @@ fd_open (unix_stream * s)
 *********************************************************************/
 
 
-static char *
-mem_alloc_r_at (int_stream * s, int *len)
+char *
+mem_alloc_r (stream * strm, int * len)
 {
+  unix_stream * s = (unix_stream *) strm;
   gfc_offset n;
   gfc_offset where = s->logical_offset;
 
   if (where < s->buffer_offset || where > s->buffer_offset + s->active)
     return NULL;
 
-  s->logical_offset = where + *len;
-
   n = s->buffer_offset + s->active - where;
   if (*len > n)
     *len = n;
 
+  s->logical_offset = where + *len;
+
   return s->buffer + (where - s->buffer_offset);
 }
 
 
-static char *
-mem_alloc_w_at (int_stream * s, int *len)
+char *
+mem_alloc_w (stream * strm, int * len)
 {
+  unix_stream * s = (unix_stream *) strm;
   gfc_offset m;
   gfc_offset where = s->logical_offset;
 
-  assert (*len >= 0);  /* Negative values not allowed. */
-  
   m = where + *len;
 
   if (where < s->buffer_offset)
@@ -955,25 +628,20 @@ mem_alloc_w_at (int_stream * s, int *len)
 
 /* Stream read function for internal units.  */
 
-static int
-mem_read (int_stream * s, void * buf, size_t * nbytes)
+static ssize_t
+mem_read (stream * s, void * buf, ssize_t nbytes)
 {
   void *p;
-  int tmp;
+  int nb = nbytes;
 
-  tmp = *nbytes;
-  p = mem_alloc_r_at (s, &tmp);
+  p = mem_alloc_r (s, &nb);
   if (p)
     {
-      *nbytes = tmp;
-      memcpy (buf, p, *nbytes);
-      return 0;
+      memcpy (buf, p, nb);
+      return (ssize_t) nb;
     }
   else
-    {
-      *nbytes = 0;
-      return 0;
-    }
+    return 0;
 }
 
 
@@ -981,84 +649,90 @@ mem_read (int_stream * s, void * buf, size_t * nbytes)
    at the moment, as all internal IO is formatted and the formatted IO
    routines use mem_alloc_w_at.  */
 
-static int
-mem_write (int_stream * s, const void * buf, size_t * nbytes)
+static ssize_t
+mem_write (stream * s, const void * buf, ssize_t nbytes)
 {
   void *p;
-  int tmp;
+  int nb = nbytes;
 
-  tmp = *nbytes;
-  p = mem_alloc_w_at (s, &tmp);
+  p = mem_alloc_w (s, &nb);
   if (p)
     {
-      *nbytes = tmp;
-      memcpy (p, buf, *nbytes);
-      return 0;
+      memcpy (p, buf, nb);
+      return (ssize_t) nb;
     }
   else
-    {
-      *nbytes = 0;
-      return 0;
-    }
+    return 0;
 }
 
 
-static int
-mem_seek (int_stream * s, gfc_offset offset)
+static off_t
+mem_seek (stream * strm, off_t offset, int whence)
 {
+  unix_stream * s = (unix_stream *) strm;
+  switch (whence)
+    {
+    case SEEK_SET:
+      break;
+    case SEEK_CUR:
+      offset += s->logical_offset;
+      break;
+    case SEEK_END:
+      offset += s->file_length;
+      break;
+    default:
+      return -1;
+    }
+
+  /* Note that for internal array I/O it's actually possible to have a
+     negative offset, so don't check for that.  */
   if (offset > s->file_length)
     {
-      errno = ESPIPE;
-      return FAILURE;
+      errno = EINVAL;
+      return -1;
     }
 
   s->logical_offset = offset;
-  return SUCCESS;
+
+  /* Returning < 0 is the error indicator for sseek(), so return 0 if
+     offset is negative.  Thus if the return value is 0, the caller
+     has to use stell() to get the real value of logical_offset.  */
+  if (offset >= 0)
+    return offset;
+  return 0;
 }
 
 
-static try
-mem_set (int_stream * s, int c, size_t n)
+static off_t
+mem_tell (stream * s)
 {
-  void *p;
-  int len;
-
-  len = n;
-  
-  p = mem_alloc_w_at (s, &len);
-  if (p)
-    {
-      memset (p, c, len);
-      return SUCCESS;
-    }
-  else
-    return FAILURE;
+  return ((unix_stream *)s)->logical_offset;
 }
 
 
 static int
-mem_truncate (int_stream * s __attribute__ ((unused)))
+mem_truncate (unix_stream * s __attribute__ ((unused)), 
+	      off_t length __attribute__ ((unused)))
 {
-  return SUCCESS;
+  return 0;
 }
 
 
-static try
-mem_close (int_stream * s)
+static int
+mem_flush (unix_stream * s __attribute__ ((unused)))
 {
-  if (s != NULL)
-    free_mem (s);
-
-  return SUCCESS;
+  return 0;
 }
 
 
-static try
-mem_sfree (int_stream * s __attribute__ ((unused)))
+static int
+mem_close (unix_stream * s)
 {
-  return SUCCESS;
-}
+  if (s != NULL)
+    free_mem (s);
 
+  return 0;
+}
 
 
 /*********************************************************************
@@ -1071,7 +745,7 @@ mem_sfree (int_stream * s __attribute__ ((unused)))
 void
 empty_internal_buffer(stream *strm)
 {
-  int_stream * s = (int_stream *) strm;
+  unix_stream * s = (unix_stream *) strm;
   memset(s->buffer, ' ', s->file_length);
 }
 
@@ -1080,10 +754,10 @@ empty_internal_buffer(stream *strm)
 stream *
 open_internal (char *base, int length, gfc_offset offset)
 {
-  int_stream *s;
+  unix_stream *s;
 
-  s = get_mem (sizeof (int_stream));
-  memset (s, '\0', sizeof (int_stream));
+  s = get_mem (sizeof (unix_stream));
+  memset (s, '\0', sizeof (unix_stream));
 
   s->buffer = base;
   s->buffer_offset = offset;
@@ -1091,14 +765,13 @@ open_internal (char *base, int length, gfc_offset offset)
   s->logical_offset = 0;
   s->active = s->file_length = length;
 
-  s->st.alloc_w_at = (void *) mem_alloc_w_at;
-  s->st.sfree = (void *) mem_sfree;
   s->st.close = (void *) mem_close;
   s->st.seek = (void *) mem_seek;
-  s->st.trunc = (void *) mem_truncate;
+  s->st.tell = (void *) mem_tell;
+  s->st.truncate = (void *) mem_truncate;
   s->st.read = (void *) mem_read;
   s->st.write = (void *) mem_write;
-  s->st.set = (void *) mem_set;
+  s->st.flush = (void *) mem_flush;
 
   return (stream *) s;
 }
@@ -1133,7 +806,14 @@ fd_to_stream (int fd, int prot)
 
   s->special_file = !S_ISREG (statbuf.st_mode);
 
-  fd_open (s);
+  if (isatty (s->fd) || options.all_unbuffered
+      ||(options.unbuffered_preconnected && 
+         (s->fd == STDIN_FILENO 
+          || s->fd == STDOUT_FILENO 
+          || s->fd == STDERR_FILENO)))
+    raw_init (s);
+  else
+    buf_init (s);
 
   return (stream *) s;
 }
@@ -1417,8 +1097,6 @@ output_stream (void)
 #endif
 
   s = fd_to_stream (STDOUT_FILENO, PROT_WRITE);
-  if (options.unbuffered_preconnected)
-    ((unix_stream *) s)->method = SYNC_UNBUFFERED;
   return s;
 }
 
@@ -1436,8 +1114,6 @@ error_stream (void)
 #endif
 
   s = fd_to_stream (STDERR_FILENO, PROT_WRITE);
-  if (options.unbuffered_preconnected)
-    ((unix_stream *) s)->method = SYNC_UNBUFFERED;
   return s;
 }
 
@@ -1668,7 +1344,7 @@ flush_all_units_1 (gfc_unit *u, int min_unit)
 	  if (__gthread_mutex_trylock (&u->lock))
 	    return u;
 	  if (u->s)
-	    flush (u->s);
+	    sflush (u->s);
 	  __gthread_mutex_unlock (&u->lock);
 	}
       u = u->right;
@@ -1698,7 +1374,7 @@ flush_all_units (void)
 
       if (u->closed == 0)
 	{
-	  flush (u->s);
+	  sflush (u->s);
 	  __gthread_mutex_lock (&unit_lock);
 	  __gthread_mutex_unlock (&u->lock);
 	  (void) predec_waiting_locked (u);
@@ -1715,40 +1391,6 @@ flush_all_units (void)
 }
 
 
-/* stream_at_bof()-- Returns nonzero if the stream is at the beginning
- * of the file. */
-
-int
-stream_at_bof (stream * s)
-{
-  unix_stream *us;
-
-  if (!is_seekable (s))
-    return 0;
-
-  us = (unix_stream *) s;
-
-  return us->logical_offset == 0;
-}
-
-
-/* stream_at_eof()-- Returns nonzero if the stream is at the end
- * of the file. */
-
-int
-stream_at_eof (stream * s)
-{
-  unix_stream *us;
-
-  if (!is_seekable (s))
-    return 0;
-
-  us = (unix_stream *) s;
-
-  return us->logical_offset == us->dirty_offset;
-}
-
-
 /* delete_file()-- Given a unit structure, delete the file associated
  * with the unit.  Returns nonzero if something went wrong. */
 
@@ -1954,16 +1596,15 @@ inquire_readwrite (const char *string, int len)
 gfc_offset
 file_length (stream * s)
 {
-  return ((unix_stream *) s)->file_length;
-}
-
-
-/* file_position()-- Return the current position of the file */
-
-gfc_offset
-file_position (stream *s)
-{
-  return ((unix_stream *) s)->logical_offset;
+  off_t curr, end;
+  if (!is_seekable (s))
+    return -1;
+  curr = stell (s);
+  if (curr == -1)
+    return curr;
+  end = sseek (s, 0, SEEK_END);
+  sseek (s, curr, SEEK_SET);
+  return end;
 }
 
 
@@ -1988,12 +1629,6 @@ is_special (stream *s)
 }
 
 
-try
-flush (stream *s)
-{
-  return fd_flush( (unix_stream *) s);
-}
-
 int
 stream_isatty (stream *s)
 {
@@ -2010,12 +1645,6 @@ stream_ttyname (stream *s __attribute__ ((unused)))
 #endif
 }
 
-gfc_offset
-stream_offset (stream *s)
-{
-  return (((unix_stream *) s)->logical_offset);
-}
-
 
 /* How files are stored:  This is an operating-system specific issue,
    and therefore belongs here.  There are three cases to consider.

libgfortran/io/write.c

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