--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/libgfortran/io/file_pos.c	Fri Oct 27 22:46:09 2017 +0900
@@ -0,0 +1,473 @@
+/* Copyright (C) 2002-2017 Free Software Foundation, Inc.
+   Contributed by Andy Vaught and Janne Blomqvist
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+#include "io.h"
+#include "fbuf.h"
+#include "unix.h"
+#include <string.h>
+
+/* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE,
+   ENDFILE, and REWIND as well as the FLUSH statement.  */
+
+
+/* formatted_backspace(fpp, u)-- Move the file back one line.  The
+   current position is after the newline that terminates the previous
+   record, and we have to sift backwards to find the newline before
+   that or the start of the file, whichever comes first.  */
+
+#define READ_CHUNK 4096
+
+static void
+formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
+{
+  gfc_offset base;
+  char p[READ_CHUNK];
+  ssize_t n;
+
+  base = stell (u->s) - 1;
+
+  do
+    {
+      n = (base < READ_CHUNK) ? base : READ_CHUNK;
+      base -= n;
+      if (sseek (u->s, base, SEEK_SET) < 0)
+        goto io_error;
+      if (sread (u->s, p, n) != n)
+	goto io_error;
+
+      /* We have moved backwards from the current position, it should
+         not be possible to get a short read.  Because it is not
+         clear what to do about such thing, we ignore the possibility.  */
+
+      /* There is no memrchr() in the C library, so we have to do it
+         ourselves.  */
+
+      while (n > 0)
+	{
+          n--;
+	  if (p[n] == '\n')
+	    {
+	      base += n + 1;
+	      goto done;
+	    }
+	}
+
+    }
+  while (base != 0);
+
+  /* base is the new pointer.  Seek to it exactly.  */
+ done:
+  if (sseek (u->s, base, SEEK_SET) < 0)
+    goto io_error;
+  u->last_record--;
+  u->endfile = NO_ENDFILE;
+  u->last_char = EOF - 1;
+  return;
+
+ io_error:
+  generate_error (&fpp->common, LIBERROR_OS, NULL);
+}
+
+
+/* unformatted_backspace(fpp) -- Move the file backwards for an unformatted
+   sequential file.  We are guaranteed to be between records on entry and 
+   we have to shift to the previous record.  Loop over subrecords.  */
+
+static void
+unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
+{
+  gfc_offset m, slen;
+  GFC_INTEGER_4 m4;
+  GFC_INTEGER_8 m8;
+  ssize_t length;
+  int continued;
+  char p[sizeof (GFC_INTEGER_8)];
+
+  if (compile_options.record_marker == 0)
+    length = sizeof (GFC_INTEGER_4);
+  else
+    length = compile_options.record_marker;
+
+  do
+    {
+      slen = - (gfc_offset) length;
+      if (sseek (u->s, slen, SEEK_CUR) < 0)
+        goto io_error;
+      if (sread (u->s, p, length) != length)
+        goto io_error;
+
+      /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here.  */
+      if (likely (u->flags.convert == GFC_CONVERT_NATIVE))
+	{
+	  switch (length)
+	    {
+	    case sizeof(GFC_INTEGER_4):
+	      memcpy (&m4, p, sizeof (m4));
+	      m = m4;
+	      break;
+
+	    case sizeof(GFC_INTEGER_8):
+	      memcpy (&m8, p, sizeof (m8));
+	      m = m8;
+	      break;
+
+	    default:
+	      runtime_error ("Illegal value for record marker");
+	      break;
+	    }
+	}
+      else
+	{
+	  uint32_t u32;
+	  uint64_t u64;
+	  switch (length)
+	    {
+	    case sizeof(GFC_INTEGER_4):
+	      memcpy (&u32, p, sizeof (u32));
+	      u32 = __builtin_bswap32 (u32);
+	      memcpy (&m4, &u32, sizeof (m4));
+	      m = m4;
+	      break;
+
+	    case sizeof(GFC_INTEGER_8):
+	      memcpy (&u64, p, sizeof (u64));
+	      u64 = __builtin_bswap64 (u64);
+	      memcpy (&m8, &u64, sizeof (m8));
+	      m = m8;
+	      break;
+
+	    default:
+	      runtime_error ("Illegal value for record marker");
+	      break;
+	    }
+
+	}
+
+      continued = m < 0;
+      if (continued)
+	m = -m;
+
+      if (sseek (u->s, -m -2 * length, SEEK_CUR) < 0)
+	goto io_error;
+    } while (continued);
+
+  u->last_record--;
+  return;
+
+ io_error:
+  generate_error (&fpp->common, LIBERROR_OS, NULL);
+}
+
+
+extern void st_backspace (st_parameter_filepos *);
+export_proto(st_backspace);
+
+void
+st_backspace (st_parameter_filepos *fpp)
+{
+  gfc_unit *u;
+
+  library_start (&fpp->common);
+
+  u = find_unit (fpp->common.unit);
+  if (u == NULL)
+    {
+      generate_error (&fpp->common, LIBERROR_BAD_UNIT, NULL);
+      goto done;
+    }
+
+  /* Direct access is prohibited, and so is unformatted stream access.  */
+
+
+  if (u->flags.access == ACCESS_DIRECT)
+    {
+      generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
+		      "Cannot BACKSPACE a file opened for DIRECT access");
+      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);
+    }
+
+  
+  /* Check for special cases involving the ENDFILE record first.  */
+
+  if (u->endfile == AFTER_ENDFILE)
+    {
+      u->endfile = AT_ENDFILE;
+      u->flags.position = POSITION_APPEND;
+      sflush (u->s);
+    }
+  else
+    {
+      if (stell (u->s) == 0)
+	{
+	  u->flags.position = POSITION_REWIND;
+	  goto done;		/* Common special case */
+	}
+
+      if (u->mode == WRITING)
+	{
+	  /* If there are previously written bytes from a write with
+	     ADVANCE="no", add a record marker before performing the
+	     BACKSPACE.  */
+
+	  if (u->previous_nonadvancing_write)
+	    finish_last_advance_record (u);
+
+	  u->previous_nonadvancing_write = 0;
+
+	  unit_truncate (u, stell (u->s), &fpp->common);
+	  u->mode = READING;
+        }
+
+      if (u->flags.form == FORM_FORMATTED)
+	formatted_backspace (fpp, u);
+      else
+	unformatted_backspace (fpp, u);
+
+      u->flags.position = POSITION_UNSPECIFIED;
+      u->endfile = NO_ENDFILE;
+      u->current_record = 0;
+      u->bytes_left = 0;
+    }
+
+ done:
+  if (u != NULL)
+    unlock_unit (u);
+
+  library_end ();
+}
+
+
+extern void st_endfile (st_parameter_filepos *);
+export_proto(st_endfile);
+
+void
+st_endfile (st_parameter_filepos *fpp)
+{
+  gfc_unit *u;
+
+  library_start (&fpp->common);
+
+  u = find_unit (fpp->common.unit);
+  if (u != NULL)
+    {
+      if (u->flags.access == ACCESS_DIRECT)
+	{
+	  generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
+			  "Cannot perform ENDFILE on a file opened "
+			  "for DIRECT access");
+	  goto done;
+	}
+
+      if (u->flags.access == ACCESS_SEQUENTIAL
+      	  && u->endfile == AFTER_ENDFILE)
+	{
+	  generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
+			  "Cannot perform ENDFILE on a file already "
+			  "positioned after the EOF marker");
+	  goto done;
+	}
+
+      /* If there are previously written bytes from a write with ADVANCE="no",
+	 add a record marker before performing the ENDFILE.  */
+
+      if (u->previous_nonadvancing_write)
+	finish_last_advance_record (u);
+
+      u->previous_nonadvancing_write = 0;
+
+      if (u->current_record)
+	{
+	  st_parameter_dt dtp;
+	  dtp.common = fpp->common;
+	  memset (&dtp.u.p, 0, sizeof (dtp.u.p));
+	  dtp.u.p.current_unit = u;
+	  next_record (&dtp, 1);
+	}
+
+      unit_truncate (u, stell (u->s), &fpp->common);
+      u->endfile = AFTER_ENDFILE;
+      u->last_char = EOF - 1;
+      if (0 == stell (u->s))
+        u->flags.position = POSITION_REWIND;
+    }
+  else
+    {
+      if (fpp->common.unit < 0)
+	{
+	  generate_error (&fpp->common, LIBERROR_BAD_OPTION,
+			  "Bad unit number in statement");
+	  return;
+	}
+
+      u = find_or_create_unit (fpp->common.unit);
+      if (u->s == NULL)
+	{
+	  /* Open the unit with some default flags.  */
+	  st_parameter_open opp;
+	  unit_flags u_flags;
+
+	  memset (&u_flags, '\0', sizeof (u_flags));
+	  u_flags.access = ACCESS_SEQUENTIAL;
+	  u_flags.action = ACTION_READWRITE;
+
+	  /* Is it unformatted?  */
+	  if (!(fpp->common.flags & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
+				     | IOPARM_DT_IONML_SET)))
+	    u_flags.form = FORM_UNFORMATTED;
+	  else
+	    u_flags.form = FORM_UNSPECIFIED;
+
+	  u_flags.delim = DELIM_UNSPECIFIED;
+	  u_flags.blank = BLANK_UNSPECIFIED;
+	  u_flags.pad = PAD_UNSPECIFIED;
+	  u_flags.decimal = DECIMAL_UNSPECIFIED;
+	  u_flags.encoding = ENCODING_UNSPECIFIED;
+	  u_flags.async = ASYNC_UNSPECIFIED;
+	  u_flags.round = ROUND_UNSPECIFIED;
+	  u_flags.sign = SIGN_UNSPECIFIED;
+	  u_flags.status = STATUS_UNKNOWN;
+	  u_flags.convert = GFC_CONVERT_NATIVE;
+	  u_flags.share = SHARE_UNSPECIFIED;
+	  u_flags.cc = CC_UNSPECIFIED;
+
+	  opp.common = fpp->common;
+	  opp.common.flags &= IOPARM_COMMON_MASK;
+	  u = new_unit (&opp, u, &u_flags);
+	  if (u == NULL)
+	    return;
+	  u->endfile = AFTER_ENDFILE;
+	  u->last_char = EOF - 1;
+	}
+    }
+
+  done:
+    unlock_unit (u);
+
+  library_end ();
+}
+
+
+extern void st_rewind (st_parameter_filepos *);
+export_proto(st_rewind);
+
+void
+st_rewind (st_parameter_filepos *fpp)
+{
+  gfc_unit *u;
+
+  library_start (&fpp->common);
+
+  u = find_unit (fpp->common.unit);
+  if (u != NULL)
+    {
+      if (u->flags.access == ACCESS_DIRECT)
+	generate_error (&fpp->common, LIBERROR_BAD_OPTION,
+			"Cannot REWIND a file opened for DIRECT access");
+      else
+	{
+	  /* If there are previously written bytes from a write with ADVANCE="no",
+	     add a record marker before performing the ENDFILE.  */
+
+	  if (u->previous_nonadvancing_write)
+	    finish_last_advance_record (u);
+
+	  u->previous_nonadvancing_write = 0;
+
+	  fbuf_reset (u);
+
+	  u->last_record = 0;
+
+	  if (sseek (u->s, 0, SEEK_SET) < 0)
+	    {
+	      generate_error (&fpp->common, LIBERROR_OS, NULL);
+	      library_end ();
+	      return;
+	    }
+
+	  /* Set this for compatibilty with g77 for /dev/null.  */
+	  if (ssize (u->s) == 0)
+	    u->endfile = AT_ENDFILE;
+	  else
+	    {
+	      /* We are rewinding so we are not at the end.  */
+	      u->endfile = NO_ENDFILE;
+	    }
+	  
+	  u->current_record = 0;
+	  u->strm_pos = 1;
+	  u->read_bad = 0;
+	  u->last_char = EOF - 1;
+	}
+      /* Update position for INQUIRE.  */
+      u->flags.position = POSITION_REWIND;
+      unlock_unit (u);
+    }
+
+  library_end ();
+}
+
+
+extern void st_flush (st_parameter_filepos *);
+export_proto(st_flush);
+
+void
+st_flush (st_parameter_filepos *fpp)
+{
+  gfc_unit *u;
+
+  library_start (&fpp->common);
+
+  u = find_unit (fpp->common.unit);
+  if (u != NULL)
+    {
+      /* Make sure format buffer is flushed.  */
+      if (u->flags.form == FORM_FORMATTED)
+        fbuf_flush (u, u->mode);
+
+      sflush (u->s);
+      u->last_char = EOF - 1;
+      unlock_unit (u);
+    }
+  else
+    /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */ 
+    generate_error (&fpp->common, LIBERROR_BAD_OPTION,
+			"Specified UNIT in FLUSH is not connected");
+
+  library_end ();
+}