[thirdparty/gcc.git] / libgfortran / io / file_pos.c

/* Copyright (C) 2002-2018 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 "async.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;
  bool needs_unlock = false;

  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;
    }

  if (ASYNC_IO && u->au)
    {
      if (async_wait (&(fpp->common), u->au))
	return;
      else
	{
	  needs_unlock = true;
	  LOCK (&u->au->io_lock);
	}
    }

  /* 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);

      if (ASYNC_IO && u->au && needs_unlock)
	UNLOCK (&u->au->io_lock);
    }

  library_end ();
}


extern void st_endfile (st_parameter_filepos *);
export_proto(st_endfile);

void
st_endfile (st_parameter_filepos *fpp)
{
  gfc_unit *u;
  bool needs_unlock = false;

  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 (ASYNC_IO && u->au)
	{
	  if (async_wait (&(fpp->common), u->au))
	    return;
	  else
	    {
	      needs_unlock = true;
	      LOCK (&u->au->io_lock);
	    }
	}

      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:
  if (ASYNC_IO && u->au && needs_unlock)
    UNLOCK (&u->au->io_lock);

  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;
  bool needs_unlock = true;

  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 (ASYNC_IO && u->au)
	    {
	      if (async_wait (&(fpp->common), u->au))
		return;
	      else
		{
		  needs_unlock = true;
		  LOCK (&u->au->io_lock);
		}
	    }

	  /* 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;

      if (ASYNC_IO && u->au && needs_unlock)
	UNLOCK (&u->au->io_lock);

      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;
  bool needs_unlock = false;

  library_start (&fpp->common);

  u = find_unit (fpp->common.unit);
  if (u != NULL)
    {
      if (ASYNC_IO && u->au)
	{
	  if (async_wait (&(fpp->common), u->au))
	    return;
	  else
	    {
	      needs_unlock = true;
	      LOCK (&u->au->io_lock);
	    }
	}

      /* 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");

  if (needs_unlock)
    UNLOCK (&u->au->io_lock);

  library_end ();
}
Commit	Line	Data
8e8f6434	1	/* Copyright (C) 2002-2018 Free Software Foundation, Inc.
a16758bb	2	Contributed by Andy Vaught and Janne Blomqvist
4ee9c684	3
a16758bb	4	This file is part of the GNU Fortran runtime library (libgfortran).
4ee9c684	5
	6	Libgfortran is free software; you can redistribute it and/or modify
	7	it under the terms of the GNU General Public License as published by
6bc9506f	8	the Free Software Foundation; either version 3, or (at your option)
4ee9c684	9	any later version.
	10
	11	Libgfortran is distributed in the hope that it will be useful,
	12	but WITHOUT ANY WARRANTY; without even the implied warranty of
	13	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	GNU General Public License for more details.
	15
6bc9506f	16	Under Section 7 of GPL version 3, you are granted additional
	17	permissions described in the GCC Runtime Library Exception, version
	18	3.1, as published by the Free Software Foundation.
	19
	20	You should have received a copy of the GNU General Public License and
	21	a copy of the GCC Runtime Library Exception along with this program;
	22	see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
	23	<http://www.gnu.org/licenses/>. */
4ee9c684	24
4ee9c684	25	#include "io.h"
f65f6629	26	#include "fbuf.h"
f65f6629	27	#include "unix.h"
629c30bb	28	#include "async.h"
41f2d5e8	29	#include <string.h>
4ee9c684	30
a16758bb	31	/* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE,
	32	ENDFILE, and REWIND as well as the FLUSH statement. */
	33
4ee9c684	34
60c514ba	35	/* formatted_backspace(fpp, u)-- Move the file back one line. The
a16758bb	36	current position is after the newline that terminates the previous
	37	record, and we have to sift backwards to find the newline before
	38	that or the start of the file, whichever comes first. */
4ee9c684	39
2cb567cf	40	#define READ_CHUNK 4096
4ee9c684	41
4ee9c684	42	static void
60c514ba	43	formatted_backspace (st_parameter_filepos fpp, gfc_unit u)
4ee9c684	44	{
b093181d	45	gfc_offset base;
d875179d	46	char p[READ_CHUNK];
65f15010	47	ssize_t n;
4ee9c684	48
65f15010	49	base = stell (u->s) - 1;
4ee9c684	50
	51	do
	52	{
	53	n = (base < READ_CHUNK) ? base : READ_CHUNK;
	54	base -= n;
65f15010	55	if (sseek (u->s, base, SEEK_SET) < 0)
d875179d	56	goto io_error;
65f15010	57	if (sread (u->s, p, n) != n)
4ee9c684	58	goto io_error;
4ee9c684	59
a16758bb	60	/* We have moved backwards from the current position, it should
	61	not be possible to get a short read. Because it is not
	62	clear what to do about such thing, we ignore the possibility. */
4ee9c684	63
4ee9c684	64	/* There is no memrchr() in the C library, so we have to do it
a16758bb	65	ourselves. */
4ee9c684	66
d875179d	67	while (n > 0)
4ee9c684	68	{
d875179d	69	n--;
4ee9c684	70	if (p[n] == '\n')
	71	{
	72	base += n + 1;
	73	goto done;
	74	}
4ee9c684	75	}
	76
	77	}
	78	while (base != 0);
	79
a16758bb	80	/* base is the new pointer. Seek to it exactly. */
7145fd06	81	done:
65f15010	82	if (sseek (u->s, base, SEEK_SET) < 0)
4ee9c684	83	goto io_error;
60c514ba	84	u->last_record--;
60c514ba	85	u->endfile = NO_ENDFILE;
2b09e331	86	u->last_char = EOF - 1;
4ee9c684	87	return;
4ee9c684	88
7145fd06	89	io_error:
18f0b7df	90	generate_error (&fpp->common, LIBERROR_OS, NULL);
4ee9c684	91	}
	92
	93
60c514ba	94	/* unformatted_backspace(fpp) -- Move the file backwards for an unformatted
a16758bb	95	sequential file. We are guaranteed to be between records on entry and
bbaaa7b1	96	we have to shift to the previous record. Loop over subrecords. */
4ee9c684	97
4ee9c684	98	static void
60c514ba	99	unformatted_backspace (st_parameter_filepos fpp, gfc_unit u)
4ee9c684	100	{
65f15010	101	gfc_offset m, slen;
f23886ab	102	GFC_INTEGER_4 m4;
f23886ab	103	GFC_INTEGER_8 m8;
65f15010	104	ssize_t length;
bbaaa7b1	105	int continued;
d875179d	106	char p[sizeof (GFC_INTEGER_8)];
4ee9c684	107
f23886ab	108	if (compile_options.record_marker == 0)
bbaaa7b1	109	length = sizeof (GFC_INTEGER_4);
f23886ab	110	else
	111	length = compile_options.record_marker;
	112
bbaaa7b1	113	do
bbaaa7b1	114	{
65f15010	115	slen = - (gfc_offset) length;
65f15010	116	if (sseek (u->s, slen, SEEK_CUR) < 0)
d875179d	117	goto io_error;
65f15010	118	if (sread (u->s, p, length) != length)
d875179d	119	goto io_error;
4ee9c684	120
18f0b7df	121	/* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
861d8137	122	if (likely (u->flags.convert == GFC_CONVERT_NATIVE))
f23886ab	123	{
bbaaa7b1	124	switch (length)
	125	{
	126	case sizeof(GFC_INTEGER_4):
	127	memcpy (&m4, p, sizeof (m4));
	128	m = m4;
	129	break;
	130
	131	case sizeof(GFC_INTEGER_8):
	132	memcpy (&m8, p, sizeof (m8));
	133	m = m8;
	134	break;
	135
	136	default:
	137	runtime_error ("Illegal value for record marker");
	138	break;
	139	}
f23886ab	140	}
bbaaa7b1	141	else
f23886ab	142	{
a01f9ef3	143	uint32_t u32;
a01f9ef3	144	uint64_t u64;
bbaaa7b1	145	switch (length)
	146	{
	147	case sizeof(GFC_INTEGER_4):
a01f9ef3	148	memcpy (&u32, p, sizeof (u32));
	149	u32 = __builtin_bswap32 (u32);
	150	memcpy (&m4, &u32, sizeof (m4));
bbaaa7b1	151	m = m4;
	152	break;
	153
	154	case sizeof(GFC_INTEGER_8):
a01f9ef3	155	memcpy (&u64, p, sizeof (u64));
	156	u64 = __builtin_bswap64 (u64);
	157	memcpy (&m8, &u64, sizeof (m8));
bbaaa7b1	158	m = m8;
	159	break;
	160
	161	default:
	162	runtime_error ("Illegal value for record marker");
	163	break;
	164	}
	165
f23886ab	166	}
f23886ab	167
bbaaa7b1	168	continued = m < 0;
	169	if (continued)
	170	m = -m;
9e94d29f	171
65f15010	172	if (sseek (u->s, -m -2 * length, SEEK_CUR) < 0)
bbaaa7b1	173	goto io_error;
bbaaa7b1	174	} while (continued);
4ee9c684	175
60c514ba	176	u->last_record--;
4ee9c684	177	return;
4ee9c684	178
7145fd06	179	io_error:
18f0b7df	180	generate_error (&fpp->common, LIBERROR_OS, NULL);
4ee9c684	181	}
	182
	183
60c514ba	184	extern void st_backspace (st_parameter_filepos *);
7b6cb5bd	185	export_proto(st_backspace);
7b6cb5bd	186
4ee9c684	187	void
60c514ba	188	st_backspace (st_parameter_filepos *fpp)
4ee9c684	189	{
f02dd226	190	gfc_unit *u;
629c30bb	191	bool needs_unlock = false;
4ee9c684	192
60c514ba	193	library_start (&fpp->common);
4ee9c684	194
60c514ba	195	u = find_unit (fpp->common.unit);
4ee9c684	196	if (u == NULL)
4ee9c684	197	{
18f0b7df	198	generate_error (&fpp->common, LIBERROR_BAD_UNIT, NULL);
4ee9c684	199	goto done;
	200	}
	201
442c1e06	202	/* Direct access is prohibited, and so is unformatted stream access. */
4ee9c684	203
442c1e06	204
	205	if (u->flags.access == ACCESS_DIRECT)
	206	{
	207	generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
	208	"Cannot BACKSPACE a file opened for DIRECT access");
	209	goto done;
	210	}
	211
65f15010	212	if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED)
	213	{
	214	generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
	215	"Cannot BACKSPACE an unformatted stream file");
	216	goto done;
	217	}
	218
629c30bb	219	if (ASYNC_IO && u->au)
	220	{
	221	if (async_wait (&(fpp->common), u->au))
	222	return;
	223	else
	224	{
	225	needs_unlock = true;
	226	LOCK (&u->au->io_lock);
	227	}
	228	}
	229
65f15010	230	/* Make sure format buffer is flushed and reset. */
	231	if (u->flags.form == FORM_FORMATTED)
	232	{
	233	int pos = fbuf_reset (u);
	234	if (pos != 0)
	235	sseek (u->s, pos, SEEK_CUR);
	236	}
4ee9c684	237
d875179d	238
a16758bb	239	/* Check for special cases involving the ENDFILE record first. */
4ee9c684	240
4ee9c684	241	if (u->endfile == AFTER_ENDFILE)
813a04a4	242	{
813a04a4	243	u->endfile = AT_ENDFILE;
f4bfed80	244	u->flags.position = POSITION_APPEND;
65f15010	245	sflush (u->s);
813a04a4	246	}
4ee9c684	247	else
4ee9c684	248	{
65f15010	249	if (stell (u->s) == 0)
f4bfed80	250	{
	251	u->flags.position = POSITION_REWIND;
	252	goto done; /* Common special case */
	253	}
4ee9c684	254
ca865049	255	if (u->mode == WRITING)
a16758bb	256	{
442c1e06	257	/* If there are previously written bytes from a write with
	258	ADVANCE="no", add a record marker before performing the
	259	BACKSPACE. */
	260
	261	if (u->previous_nonadvancing_write)
	262	finish_last_advance_record (u);
	263
	264	u->previous_nonadvancing_write = 0;
	265
65f15010	266	unit_truncate (u, stell (u->s), &fpp->common);
a16758bb	267	u->mode = READING;
a16758bb	268	}
ca865049	269
74b0c8a0	270	if (u->flags.form == FORM_FORMATTED)
60c514ba	271	formatted_backspace (fpp, u);
4ee9c684	272	else
60c514ba	273	unformatted_backspace (fpp, u);
ca865049	274
65f15010	275	u->flags.position = POSITION_UNSPECIFIED;
ca865049	276	u->endfile = NO_ENDFILE;
ca865049	277	u->current_record = 0;
4e63a695	278	u->bytes_left = 0;
4ee9c684	279	}
4ee9c684	280
7145fd06	281	done:
60c514ba	282	if (u != NULL)
629c30bb	283	{
	284	unlock_unit (u);
	285
	286	if (ASYNC_IO && u->au && needs_unlock)
	287	UNLOCK (&u->au->io_lock);
	288	}
60c514ba	289
4ee9c684	290	library_end ();
4ee9c684	291	}
a16758bb	292
a16758bb	293
60c514ba	294	extern void st_endfile (st_parameter_filepos *);
a16758bb	295	export_proto(st_endfile);
	296
	297	void
60c514ba	298	st_endfile (st_parameter_filepos *fpp)
a16758bb	299	{
a16758bb	300	gfc_unit *u;
629c30bb	301	bool needs_unlock = false;
a16758bb	302
60c514ba	303	library_start (&fpp->common);
a16758bb	304
60c514ba	305	u = find_unit (fpp->common.unit);
a16758bb	306	if (u != NULL)
a16758bb	307	{
442c1e06	308	if (u->flags.access == ACCESS_DIRECT)
	309	{
	310	generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
7fb4c5ad	311	"Cannot perform ENDFILE on a file opened "
	312	"for DIRECT access");
	313	goto done;
	314	}
	315
629c30bb	316	if (ASYNC_IO && u->au)
	317	{
	318	if (async_wait (&(fpp->common), u->au))
	319	return;
	320	else
	321	{
	322	needs_unlock = true;
	323	LOCK (&u->au->io_lock);
	324	}
	325	}
	326
7fb4c5ad	327	if (u->flags.access == ACCESS_SEQUENTIAL
	328	&& u->endfile == AFTER_ENDFILE)
	329	{
	330	generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
	331	"Cannot perform ENDFILE on a file already "
	332	"positioned after the EOF marker");
442c1e06	333	goto done;
	334	}
	335
	336	/* If there are previously written bytes from a write with ADVANCE="no",
	337	add a record marker before performing the ENDFILE. */
	338
	339	if (u->previous_nonadvancing_write)
	340	finish_last_advance_record (u);
	341
	342	u->previous_nonadvancing_write = 0;
	343
a16758bb	344	if (u->current_record)
60c514ba	345	{
	346	st_parameter_dt dtp;
	347	dtp.common = fpp->common;
b5d015e3	348	memset (&dtp.u.p, 0, sizeof (dtp.u.p));
60c514ba	349	dtp.u.p.current_unit = u;
	350	next_record (&dtp, 1);
	351	}
a16758bb	352
65f15010	353	unit_truncate (u, stell (u->s), &fpp->common);
a16758bb	354	u->endfile = AFTER_ENDFILE;
2b09e331	355	u->last_char = EOF - 1;
65f15010	356	if (0 == stell (u->s))
65f15010	357	u->flags.position = POSITION_REWIND;
a16758bb	358	}
7fb4c5ad	359	else
	360	{
	361	if (fpp->common.unit < 0)
	362	{
	363	generate_error (&fpp->common, LIBERROR_BAD_OPTION,
	364	"Bad unit number in statement");
	365	return;
	366	}
	367
	368	u = find_or_create_unit (fpp->common.unit);
	369	if (u->s == NULL)
	370	{
	371	/* Open the unit with some default flags. */
	372	st_parameter_open opp;
	373	unit_flags u_flags;
	374
	375	memset (&u_flags, '\0', sizeof (u_flags));
	376	u_flags.access = ACCESS_SEQUENTIAL;
	377	u_flags.action = ACTION_READWRITE;
26ba582e	378
	379	/* Is it unformatted? */
	380	if (!(fpp->common.flags & (IOPARM_DT_HAS_FORMAT \| IOPARM_DT_LIST_FORMAT
	381	\| IOPARM_DT_IONML_SET)))
	382	u_flags.form = FORM_UNFORMATTED;
	383	else
	384	u_flags.form = FORM_UNSPECIFIED;
	385
7fb4c5ad	386	u_flags.delim = DELIM_UNSPECIFIED;
	387	u_flags.blank = BLANK_UNSPECIFIED;
	388	u_flags.pad = PAD_UNSPECIFIED;
	389	u_flags.decimal = DECIMAL_UNSPECIFIED;
	390	u_flags.encoding = ENCODING_UNSPECIFIED;
	391	u_flags.async = ASYNC_UNSPECIFIED;
	392	u_flags.round = ROUND_UNSPECIFIED;
	393	u_flags.sign = SIGN_UNSPECIFIED;
	394	u_flags.status = STATUS_UNKNOWN;
	395	u_flags.convert = GFC_CONVERT_NATIVE;
b3db57e8	396	u_flags.share = SHARE_UNSPECIFIED;
b3db57e8	397	u_flags.cc = CC_UNSPECIFIED;
7fb4c5ad	398
	399	opp.common = fpp->common;
	400	opp.common.flags &= IOPARM_COMMON_MASK;
	401	u = new_unit (&opp, u, &u_flags);
	402	if (u == NULL)
	403	return;
	404	u->endfile = AFTER_ENDFILE;
2b09e331	405	u->last_char = EOF - 1;
7fb4c5ad	406	}
	407	}
	408
629c30bb	409	done:
	410	if (ASYNC_IO && u->au && needs_unlock)
	411	UNLOCK (&u->au->io_lock);
	412
	413	unlock_unit (u);
a16758bb	414
	415	library_end ();
	416	}
	417
	418
60c514ba	419	extern void st_rewind (st_parameter_filepos *);
a16758bb	420	export_proto(st_rewind);
	421
	422	void
60c514ba	423	st_rewind (st_parameter_filepos *fpp)
a16758bb	424	{
a16758bb	425	gfc_unit *u;
629c30bb	426	bool needs_unlock = true;
a16758bb	427
60c514ba	428	library_start (&fpp->common);
a16758bb	429
60c514ba	430	u = find_unit (fpp->common.unit);
a16758bb	431	if (u != NULL)
a16758bb	432	{
4d8ee55b	433	if (u->flags.access == ACCESS_DIRECT)
18f0b7df	434	generate_error (&fpp->common, LIBERROR_BAD_OPTION,
a16758bb	435	"Cannot REWIND a file opened for DIRECT access");
	436	else
	437	{
629c30bb	438	if (ASYNC_IO && u->au)
	439	{
	440	if (async_wait (&(fpp->common), u->au))
	441	return;
	442	else
	443	{
	444	needs_unlock = true;
	445	LOCK (&u->au->io_lock);
	446	}
	447	}
	448
442c1e06	449	/* If there are previously written bytes from a write with ADVANCE="no",
	450	add a record marker before performing the ENDFILE. */
	451
	452	if (u->previous_nonadvancing_write)
	453	finish_last_advance_record (u);
	454
	455	u->previous_nonadvancing_write = 0;
	456
7ee4f67a	457	fbuf_reset (u);
1c201879	458
a16758bb	459	u->last_record = 0;
6e34b5c4	460
65f15010	461	if (sseek (u->s, 0, SEEK_SET) < 0)
83fb22d2	462	{
	463	generate_error (&fpp->common, LIBERROR_OS, NULL);
	464	library_end ();
	465	return;
	466	}
a16758bb	467
cc65b133	468	/* Set this for compatibilty with g77 for /dev/null. */
41178014	469	if (ssize (u->s) == 0)
cc65b133	470	u->endfile = AT_ENDFILE;
cc65b133	471	else
6e34b5c4	472	{
	473	/* We are rewinding so we are not at the end. */
	474	u->endfile = NO_ENDFILE;
	475	}
cc65b133	476
a16758bb	477	u->current_record = 0;
3c43c91f	478	u->strm_pos = 1;
8f0b0abf	479	u->read_bad = 0;
2b09e331	480	u->last_char = EOF - 1;
a16758bb	481	}
	482	/* Update position for INQUIRE. */
	483	u->flags.position = POSITION_REWIND;
629c30bb	484
	485	if (ASYNC_IO && u->au && needs_unlock)
	486	UNLOCK (&u->au->io_lock);
	487
60c514ba	488	unlock_unit (u);
a16758bb	489	}
	490
	491	library_end ();
	492	}
	493
	494
60c514ba	495	extern void st_flush (st_parameter_filepos *);
a16758bb	496	export_proto(st_flush);
	497
	498	void
60c514ba	499	st_flush (st_parameter_filepos *fpp)
a16758bb	500	{
a16758bb	501	gfc_unit *u;
629c30bb	502	bool needs_unlock = false;
a16758bb	503
60c514ba	504	library_start (&fpp->common);
a16758bb	505
60c514ba	506	u = find_unit (fpp->common.unit);
a16758bb	507	if (u != NULL)
a16758bb	508	{
629c30bb	509	if (ASYNC_IO && u->au)
	510	{
	511	if (async_wait (&(fpp->common), u->au))
	512	return;
	513	else
	514	{
	515	needs_unlock = true;
	516	LOCK (&u->au->io_lock);
	517	}
	518	}
	519
65f15010	520	/* Make sure format buffer is flushed. */
	521	if (u->flags.form == FORM_FORMATTED)
	522	fbuf_flush (u, u->mode);
	523
	524	sflush (u->s);
2b09e331	525	u->last_char = EOF - 1;
60c514ba	526	unlock_unit (u);
a16758bb	527	}
9bc7d5e2	528	else
9bc7d5e2	529	/* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */
18f0b7df	530	generate_error (&fpp->common, LIBERROR_BAD_OPTION,
9bc7d5e2	531	"Specified UNIT in FLUSH is not connected");
a16758bb	532
629c30bb	533	if (needs_unlock)
	534	UNLOCK (&u->au->io_lock);
	535
a16758bb	536	library_end ();
a16758bb	537	}