gcc/libgfortran/io/transfer.c

/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
   Contributed by Andy Vaught

This file is part of the GNU Fortran 95 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 2, 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.

You should have received a copy of the GNU General Public License
along with Libgfortran; see the file COPYING.  If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.  */


/* transfer.c -- Top level handling of data transfer statements. */

#include "config.h"
#include <string.h>
#include "libgfortran.h"
#include "io.h"


/* Calling conventions:  Data transfer statements are unlike other
 * library calls in that they extend over several calls.

 * The first call is always a call to st_read() or st_write().  These
 * subroutines return no status unless a namelist read or write is
 * being done, in which case there is the usual status.  No further
 * calls are necessary in this case.
 *
 * For other sorts of data transfer, there are zero or more data
 * transfer statement that depend on the format of the data transfer
 * statement.
 *
 *    transfer_integer
 *    transfer_logical
 *    transfer_character
 *    transfer_real
 *    transfer_complex
 *
 *  These subroutines do not return status.
 *
 *  The last call is a call to st_[read|write]_done().  While
 *  something can easily go wrong with the initial st_read() or
 *  st_write(), an error inhibits any data from actually being
 *  transferred.
 */

gfc_unit *current_unit;
static int sf_seen_eor = 0;

char scratch[SCRATCH_SIZE];
static char *line_buffer = NULL;

static unit_advance advance_status;

static st_option advance_opt[] = {
  {"yes", ADVANCE_YES},
  {"no", ADVANCE_NO},
  {NULL}
};


static void (*transfer) (bt, void *, int);


typedef enum
{ FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
  FORMATTED_DIRECT, UNFORMATTED_DIRECT
}
file_mode;


static file_mode
current_mode (void)
{
  file_mode m;

  if (current_unit->flags.access == ACCESS_DIRECT)
    {
      m = current_unit->flags.form == FORM_FORMATTED ?
	FORMATTED_DIRECT : UNFORMATTED_DIRECT;
    }
  else
    {
      m = current_unit->flags.form == FORM_FORMATTED ?
	FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
    }

  return m;
}


/* Mid level data transfer statements.  These subroutines do reading
 * and writing in the style of salloc_r()/salloc_w() within the
 * current record. */

/* read_sf()-- When reading sequential formatted records we have a
 * problem.  We don't know how long the line is until we read the
 * trailing newline, and we don't want to read too much.  If we read
 * too much, we might have to do a physical seek backwards depending
 * on how much data is present, and devices like terminals aren't
 * seekable and would cause an I/O error.
 *
 * Given this, the solution is to read a byte at a time, stopping if
 * we hit the newline.  For small locations, we use a static buffer.
 * For larger allocations, we are forced to allocate memory on the
 * heap.  Hopefully this won't happen very often. */

static char *
read_sf (int *length)
{
  static char data[SCRATCH_SIZE];
  char *base, *p, *q;
  int n, unity;

  if (*length > SCRATCH_SIZE)
    p = base = line_buffer = get_mem (*length);
  else
    p = base = data;

  memset(base,'\0',*length);

  current_unit->bytes_left = options.default_recl;
  unity = 1;
  n = 0;

  do
    {
      if (is_internal_unit())
        {
       /* unity may be modified inside salloc_r if is_internal_unit() is true */
          unity = 1;
        }

      q = salloc_r (current_unit->s, &unity);
      if (q == NULL)
	break;

      if (*q == '\n')
	{
          if (current_unit->unit_number == options.stdin_unit)
            { 
              if (n <= 0)
                continue;
            }          
			/* Unexpected end of line */
	  if (current_unit->flags.pad == PAD_NO)
	    {
	      generate_error (ERROR_EOR, NULL);
	      return NULL;
	    }

	  current_unit->bytes_left = 0;
	  *length = n;
          sf_seen_eor = 1;
	  break;
	}

      n++;
      *p++ = *q;
      sf_seen_eor = 0;
    }
  while (n < *length);

  return base;
}


/* read_block()-- Function for reading the next couple of bytes from
 * the current file, advancing the current position.  We return a
 * pointer to a buffer containing the bytes.  We return NULL on end of
 * record or end of file.
 *
 * If the read is short, then it is because the current record does not
 * have enough data to satisfy the read request and the file was
 * opened with PAD=YES.  The caller must assume tailing spaces for
 * short reads.  */

void *
read_block (int *length)
{
  char *source;
  int nread;

  if (current_unit->flags.form == FORM_FORMATTED &&
      current_unit->flags.access == ACCESS_SEQUENTIAL)
    return read_sf (length);	/* Special case */

  if (current_unit->bytes_left < *length)
    {
      if (current_unit->flags.pad == PAD_NO)
	{
	  generate_error (ERROR_EOR, NULL);	/* Not enough data left */
	  return NULL;
	}

      *length = current_unit->bytes_left;
    }

  current_unit->bytes_left -= *length;

  nread = *length;
  source = salloc_r (current_unit->s, &nread);

  if (ioparm.size != NULL)
    *ioparm.size += nread;

  if (nread != *length)
    {				/* Short read, this shouldn't happen */
      if (current_unit->flags.pad == PAD_YES)
	*length = nread;
      else
	{
	  generate_error (ERROR_EOR, NULL);
	  source = NULL;
	}
    }

  return source;
}


/* write_block()-- Function for writing a block of bytes to the
 * current file at the current position, advancing the file pointer.
 * We are given a length and return a pointer to a buffer that the
 * caller must (completely) fill in.  Returns NULL on error. */

void *
write_block (int length)
{
  char *dest;

  if (!is_internal_unit() && current_unit->bytes_left < length)
    {
      generate_error (ERROR_EOR, NULL);
      return NULL;
    }

  current_unit->bytes_left -= length;
  dest = salloc_w (current_unit->s, &length);

  if (ioparm.size != NULL)
    *ioparm.size += length;

  return dest;
}


/* unformatted_read()-- Master function for unformatted reads.  */

static void
unformatted_read (bt type, void *dest, int length)
{
  void *source;
  int w;
  w = length;
  source = read_block (&w);

  if (source != NULL)
    {
      memcpy (dest, source, w);
      if (length != w)
	memset (((char *) dest) + w, ' ', length - w);
    }
}

static void
unformatted_write (bt type, void *source, int length)
{
  void *dest;
   dest = write_block (length);
   if (dest != NULL)
     memcpy (dest, source, length);
}


/* type_name()-- Return a pointer to the name of a type. */

const char *
type_name (bt type)
{
  const char *p;

  switch (type)
    {
    case BT_INTEGER:
      p = "INTEGER";
      break;
    case BT_LOGICAL:
      p = "LOGICAL";
      break;
    case BT_CHARACTER:
      p = "CHARACTER";
      break;
    case BT_REAL:
      p = "REAL";
      break;
    case BT_COMPLEX:
      p = "COMPLEX";
      break;
    default:
      internal_error ("type_name(): Bad type");
    }

  return p;
}


/* write_constant_string()-- write a constant string to the output.
 * This is complicated because the string can have doubled delimiters
 * in it.  The length in the format node is the true length. */

static void
write_constant_string (fnode * f)
{
  char c, delimiter, *p, *q;
  int length;

  length = f->u.string.length;
  if (length == 0)
    return;

  p = write_block (length);
  if (p == NULL)
    return;

  q = f->u.string.p;
  delimiter = q[-1];

  for (; length > 0; length--)
    {
      c = *p++ = *q++;
      if (c == delimiter && c != 'H')
	q++;			/* Skip the doubled delimiter */
    }
}


/* require_type()-- Given actual and expected types in a formatted
 * data transfer, make sure they agree.  If not, an error message is
 * generated.  Returns nonzero if something went wrong.  */

static int
require_type (bt expected, bt actual, fnode * f)
{
  char buffer[100];

  if (actual == expected)
    return 0;

  st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
	      type_name (expected), g.item_count, type_name (actual));

  format_error (f, buffer);
  return 1;
}


/* formatted_transfer()-- This subroutine is 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, processesing 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 of the next element, then comes back
 * here to process it.  */

static void
formatted_transfer (bt type, void *p, int len)
{
  int pos ,m ;
  fnode *f;
  int i, 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;

  /* If reversion has occurred and there is another real data item,
   * then we have to move to the next record */

  if (g.reversion_flag && n > 0)
    {
      g.reversion_flag = 0;
      next_record (0);
    }
  for (;;)
    {
      consume_data_flag = 1 ;
      if (ioparm.library_return != LIBRARY_OK)
	break;

      f = next_format ();
      if (f == NULL)
	return;			/* No data descriptors left (already raised) */

      switch (f->format)
	{
	case FMT_I:
	  if (n == 0)
	    goto need_data;
	  if (require_type (BT_INTEGER, type, f))
	    return;

	  if (g.mode == READING)
	    read_decimal (f, p, len);
	  else
	    write_i (f, p, len);

	  break;

	case FMT_B:
	  if (n == 0)
	    goto need_data;
	  if (require_type (BT_INTEGER, type, f))
	    return;

	  if (g.mode == READING)
	    read_radix (f, p, len, 2);
	  else
	    write_b (f, p, len);

	  break;

	case FMT_O:
	  if (n == 0)
	    goto need_data;

	  if (g.mode == READING)
	    read_radix (f, p, len, 8);
	  else
	    write_o (f, p, len);

	  break;

	case FMT_Z:
	  if (n == 0)
	    goto need_data;

	  if (g.mode == READING)
	    read_radix (f, p, len, 16);
	  else
	    write_z (f, p, len);

	  break;

	case FMT_A:
	  if (n == 0)
	    goto need_data;
	  if (require_type (BT_CHARACTER, type, f))
	    return;

	  if (g.mode == READING)
	    read_a (f, p, len);
	  else
	    write_a (f, p, len);

	  break;

	case FMT_L:
	  if (n == 0)
	    goto need_data;

	  if (g.mode == READING)
	    read_l (f, p, len);
	  else
	    write_l (f, p, len);

	  break;

	case FMT_D:
	  if (n == 0)
	    goto need_data;
	  if (require_type (BT_REAL, type, f))
	    return;

	  if (g.mode == READING)
	    read_f (f, p, len);
	  else
	    write_d (f, p, len);

	  break;

	case FMT_E:
	  if (n == 0)
	    goto need_data;
	  if (require_type (BT_REAL, type, f))
	    return;

	  if (g.mode == READING)
	    read_f (f, p, len);
	  else
	    write_e (f, p, len);
	  break;

	case FMT_EN:
	  if (n == 0)
	    goto need_data;
	  if (require_type (BT_REAL, type, f))
	    return;

	  if (g.mode == READING)
	    read_f (f, p, len);
	  else
	    write_en (f, p, len);

	  break;

	case FMT_ES:
	  if (n == 0)
	    goto need_data;
	  if (require_type (BT_REAL, type, f))
	    return;

	  if (g.mode == READING)
	    read_f (f, p, len);
	  else
	    write_es (f, p, len);

	  break;

	case FMT_F:
	  if (n == 0)
	    goto need_data;
	  if (require_type (BT_REAL, type, f))
	    return;

	  if (g.mode == READING)
	    read_f (f, p, len);
	  else
	    write_f (f, p, len);

	  break;

	case FMT_G:
	  if (n == 0)
	    goto need_data;
	  if (g.mode == READING)
	    switch (type)
	      {
	      case BT_INTEGER:
		read_decimal (f, p, len);
		break;
	      case BT_LOGICAL:
		read_l (f, p, len);
		break;
	      case BT_CHARACTER:
		read_a (f, p, len);
		break;
	      case BT_REAL:
		read_f (f, p, len);
		break;
	      default:
		goto bad_type;
	      }
	  else
	    switch (type)
	      {
	      case BT_INTEGER:
		write_i (f, p, len);
		break;
	      case BT_LOGICAL:
		write_l (f, p, len);
		break;
	      case BT_CHARACTER:
		write_a (f, p, len);
		break;
	      case BT_REAL:
		write_d (f, p, len);
		break;
	      default:
	      bad_type:
		internal_error ("formatted_transfer(): Bad type");
	      }

	  break;

	case FMT_STRING:
          consume_data_flag = 0 ;
	  if (g.mode == READING)
	    {
	      format_error (f, "Constant string in input format");
	      return;
	    }
	  write_constant_string (f);
	  break;

	  /* Format codes that don't transfer data */
	case FMT_X:
	case FMT_TR:
          consume_data_flag = 0 ;
	  if (g.mode == READING)
	    read_x (f);
	  else
	    write_x (f);

	  break;

        case FMT_TL:
        case FMT_T:
           if (f->format==FMT_TL)
             {
                pos = f->u.n ;
                pos= current_unit->recl - current_unit->bytes_left - pos;
             }
           else // FMT==T
             {
                consume_data_flag = 0 ;
                pos = f->u.n - 1; 
             }

           if (pos < 0 || pos >= current_unit->recl )
           {
             generate_error (ERROR_EOR, "T Or TL edit position error");
             break ;
            }
            m = pos - (current_unit->recl - current_unit->bytes_left);

            if (m == 0)
               break;

            if (m > 0)
             {
               f->u.n = m;
               if (g.mode == READING)
                 read_x (f);
               else
                 write_x (f);
             }
            if (m < 0)
             {
               move_pos_offset (current_unit->s,m);
             }

	  break;

	case FMT_S:
          consume_data_flag = 0 ;
	  g.sign_status = SIGN_S;
	  break;

	case FMT_SS:
          consume_data_flag = 0 ;
	  g.sign_status = SIGN_SS;
	  break;

	case FMT_SP:
          consume_data_flag = 0 ;
	  g.sign_status = SIGN_SP;
	  break;

	case FMT_BN:
          consume_data_flag = 0 ;
	  g.blank_status = BLANK_NULL;
	  break;

	case FMT_BZ:
          consume_data_flag = 0 ;
	  g.blank_status = BLANK_ZERO;
	  break;

	case FMT_P:
          consume_data_flag = 0 ;
	  g.scale_factor = f->u.k;
	  break;

	case FMT_DOLLAR:
          consume_data_flag = 0 ;
	  g.seen_dollar = 1;
	  break;

	case FMT_SLASH:
          consume_data_flag = 0 ;
	  for (i = 0; i < f->repeat; i++)
	    next_record (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 ("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 (line_buffer != NULL)
	{
	  free_mem (line_buffer);
	  line_buffer = NULL;
	}

      /* Adjust the item count and data pointer */

      if ((consume_data_flag > 0) && (n > 0))
      {
	n--;
        p = ((char *) p) + len;
      }
    }

  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_data:
  unget_format (f);
}



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

void
transfer_integer (void *p, int kind)
{

  g.item_count++;
  if (ioparm.library_return != LIBRARY_OK)
    return;
  transfer (BT_INTEGER, p, kind);
}


void
transfer_real (void *p, int kind)
{

  g.item_count++;
  if (ioparm.library_return != LIBRARY_OK)
    return;
  transfer (BT_REAL, p, kind);
}


void
transfer_logical (void *p, int kind)
{

  g.item_count++;
  if (ioparm.library_return != LIBRARY_OK)
    return;
  transfer (BT_LOGICAL, p, kind);
}


void
transfer_character (void *p, int len)
{

  g.item_count++;
  if (ioparm.library_return != LIBRARY_OK)
    return;
  transfer (BT_CHARACTER, p, len);
}


void
transfer_complex (void *p, int kind)
{

  g.item_count++;
  if (ioparm.library_return != LIBRARY_OK)
    return;
  transfer (BT_COMPLEX, p, kind);
}


/* us_read()-- Preposition a sequential unformatted file while reading. */

static void
us_read (void)
{
  gfc_offset *p;
  int n;

  n = sizeof (gfc_offset);
  p = (gfc_offset *) salloc_r (current_unit->s, &n);

  if (p == NULL || n != sizeof (gfc_offset))
    {
      generate_error (ERROR_BAD_US, NULL);
      return;
    }

  current_unit->bytes_left = *p;
}


/* us_write()-- Preposition a sequential unformatted file while
 * writing.  This amount to writing a bogus length that will be filled
 * in later.  */

static void
us_write (void)
{
  gfc_offset *p;
  int length;

  length = sizeof (gfc_offset);
  p = (gfc_offset *) salloc_w (current_unit->s, &length);

  if (p == NULL)
    {
      generate_error (ERROR_OS, NULL);
      return;
    }

  *p = 0;			/* Bogus value for now */
  if (sfree (current_unit->s) == FAILURE)
    generate_error (ERROR_OS, NULL);

  /* for sequential unformatted, we write until we have more bytes than
      can fit in the record markers. if disk space runs out first it will
      error on the write */
  current_unit->recl = g.max_offset;

  current_unit->bytes_left = current_unit->recl;
}


/* pre_position()-- position to the next record prior to transfer.  We
 * are assumed to be before the next record.  We also calculate the
 * bytes in the next record. */

static void
pre_position (void)
{

  if (current_unit->current_record)
    return;			/* Already positioned */

  switch (current_mode ())
    {
    case UNFORMATTED_SEQUENTIAL:
      if (g.mode == READING)
	us_read ();
      else
	us_write ();

      break;

    case FORMATTED_SEQUENTIAL:
    case FORMATTED_DIRECT:
    case UNFORMATTED_DIRECT:
      current_unit->bytes_left = current_unit->recl;
      break;
    }

  current_unit->current_record = 1;
}


/* data_transfer_init()-- Initialize things for a data transfer.  This
 * code is common for both reading and writing. */

static void
data_transfer_init (int read_flag)
{
  unit_flags u_flags;  /* used for creating a unit if needed */

  g.mode = read_flag ? READING : WRITING;

  if (ioparm.size != NULL)
    *ioparm.size = 0;		/* Initialize the count */

  current_unit = get_unit (read_flag);
  if (current_unit == NULL)
  {  /* open the unit with some default flags */
     memset (&u_flags, '\0', sizeof (u_flags));
     u_flags.access = ACCESS_SEQUENTIAL;
     u_flags.action = ACTION_READWRITE;
     /* is it unformatted ?*/
     if (ioparm.format == NULL && !ioparm.list_format)
       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.status = STATUS_UNKNOWN;
     new_unit(&u_flags);
     current_unit = get_unit (read_flag);
  }

  if (current_unit == NULL)
    return;

  if (is_internal_unit())
    {
      current_unit->recl = file_length(current_unit->s);
      if (g.mode==WRITING)
        empty_internal_buffer (current_unit->s);
    }

  /* Check the action */

  if (read_flag && current_unit->flags.action == ACTION_WRITE)
    generate_error (ERROR_BAD_ACTION,
		    "Cannot read from file opened for WRITE");

  if (!read_flag && current_unit->flags.action == ACTION_READ)
    generate_error (ERROR_BAD_ACTION, "Cannot write to file opened for READ");

  if (ioparm.library_return != LIBRARY_OK)
    return;

  /* Check the format */

  if (ioparm.format)
    parse_format ();

  if (ioparm.library_return != LIBRARY_OK)
    return;

  if (current_unit->flags.form == FORM_UNFORMATTED
      && (ioparm.format != NULL || ioparm.list_format))
    generate_error (ERROR_OPTION_CONFLICT,
		    "Format present for UNFORMATTED data transfer");

  if (ioparm.namelist_name != NULL && ionml != NULL)
     {
        if(ioparm.format != NULL)
           generate_error (ERROR_OPTION_CONFLICT,
                    "A format cannot be specified with a namelist");
     }
  else if (current_unit->flags.form == FORM_FORMATTED &&
           ioparm.format == NULL && !ioparm.list_format)
    generate_error (ERROR_OPTION_CONFLICT,
                    "Missing format for FORMATTED data transfer");


  if (is_internal_unit () && current_unit->flags.form == FORM_UNFORMATTED)
    generate_error (ERROR_OPTION_CONFLICT,
		    "Internal file cannot be accessed by UNFORMATTED data transfer");

  /* Check the record number */

  if (current_unit->flags.access == ACCESS_DIRECT && ioparm.rec == 0)
    {
      generate_error (ERROR_MISSING_OPTION,
		      "Direct access data transfer requires record number");
      return;
    }

  if (current_unit->flags.access == ACCESS_SEQUENTIAL && ioparm.rec != 0)
    {
      generate_error (ERROR_OPTION_CONFLICT,
		      "Record number not allowed for sequential access data transfer");
      return;
    }

  /* Process the ADVANCE option */

  advance_status = (ioparm.advance == NULL) ? ADVANCE_UNSPECIFIED :
    find_option (ioparm.advance, ioparm.advance_len, advance_opt,
		 "Bad ADVANCE parameter in data transfer statement");

  if (advance_status != ADVANCE_UNSPECIFIED)
    {
      if (current_unit->flags.access == ACCESS_DIRECT)
	generate_error (ERROR_OPTION_CONFLICT,
			"ADVANCE specification conflicts with sequential access");

      if (is_internal_unit ())
	generate_error (ERROR_OPTION_CONFLICT,
			"ADVANCE specification conflicts with internal file");

      if (ioparm.format == NULL || ioparm.list_format)
	generate_error (ERROR_OPTION_CONFLICT,
			"ADVANCE specification requires an explicit format");
    }

  if (read_flag)
    {
      if (ioparm.eor != 0 && advance_status == ADVANCE_NO)
	generate_error (ERROR_MISSING_OPTION,
			"EOR specification requires an ADVANCE specification of NO");

      if (ioparm.size != NULL && advance_status != ADVANCE_NO)
	generate_error (ERROR_MISSING_OPTION,
			"SIZE specification requires an ADVANCE specification of NO");

    }
  else
    {				/* Write constraints */

      if (ioparm.end != 0)
	generate_error (ERROR_OPTION_CONFLICT,
			"END specification cannot appear in a write statement");

      if (ioparm.eor != 0)
	generate_error (ERROR_OPTION_CONFLICT,
			"EOR specification cannot appear in a write statement");

      if (ioparm.size != 0)
	generate_error (ERROR_OPTION_CONFLICT,
			"SIZE specification cannot appear in a write statement");
    }

  if (advance_status == ADVANCE_UNSPECIFIED)
    advance_status = ADVANCE_YES;
  if (ioparm.library_return != LIBRARY_OK)
    return;

  /* Sanity checks on the record number */

  if (ioparm.rec)
    {
      if (ioparm.rec <= 0)
	{
	  generate_error (ERROR_BAD_OPTION, "Record number must be positive");
	  return;
	}

      if (ioparm.rec >= current_unit->maxrec)
	{
	  generate_error (ERROR_BAD_OPTION, "Record number too large");
	  return;
	}

      /* Position the file */

      if (sseek (current_unit->s,
               (ioparm.rec - 1) * current_unit->recl) == FAILURE)
	generate_error (ERROR_OS, NULL);
    }

  /* Set the initial value of flags */

  g.blank_status = current_unit->flags.blank;
  g.sign_status = SIGN_S;
  g.scale_factor = 0;
  g.seen_dollar = 0;
  g.first_item = 1;
  g.item_count = 0;

  pre_position ();

  /* Set up the subroutine that will handle the transfers */

  if (read_flag)
    {
      if (current_unit->flags.form == FORM_UNFORMATTED)
	transfer = unformatted_read;
      else
	{
	  if (ioparm.list_format)
            {
               transfer = list_formatted_read;
               init_at_eol();
            }
	  else
	    transfer = formatted_transfer;
	}
    }
  else
    {
      if (current_unit->flags.form == FORM_UNFORMATTED)
	transfer = unformatted_write;
      else
	{
	  if (ioparm.list_format)
	    transfer = list_formatted_write;
	  else
	    transfer = formatted_transfer;
	}
    }

  /* Make sure that we don't do a read after a nonadvancing write */

  if (read_flag)
    {
      if (current_unit->read_bad)
	{
	  generate_error (ERROR_BAD_OPTION,
			  "Cannot READ after a nonadvancing WRITE");
	  return;
	}
    }
  else
    {
      if (advance_status == ADVANCE_YES)
	current_unit->read_bad = 1;
    }

  /* Start the data transfer if we are doing a formatted transfer */
  if (current_unit->flags.form == FORM_FORMATTED && !ioparm.list_format
      && ioparm.namelist_name == NULL && ionml == NULL)

     formatted_transfer (0, NULL, 0);

}


/* next_record_r()-- Space to the next record for read mode.  If the
 * file is not seekable, we read MAX_READ chunks until we get to the
 * right position. */

#define MAX_READ 4096

static void
next_record_r (int done)
{
  int rlength, length;
  gfc_offset new;
  char *p;

  switch (current_mode ())
    {
    case UNFORMATTED_SEQUENTIAL:
      current_unit->bytes_left += sizeof (gfc_offset);	/* Skip over tail */

      /* Fall through */

    case FORMATTED_DIRECT:
    case UNFORMATTED_DIRECT:
      if (current_unit->bytes_left == 0)
	break;

      if (is_seekable (current_unit->s))
	{
	  new = file_position (current_unit->s) + current_unit->bytes_left;

	  /* Direct access files do not generate END conditions, only I/O errors */

	  if (sseek (current_unit->s, new) == FAILURE)
	    generate_error (ERROR_OS, NULL);

	}
      else
	{			/* Seek by reading data */
	  while (current_unit->bytes_left > 0)
	    {
	      rlength = length = (MAX_READ > current_unit->bytes_left) ?
		MAX_READ : current_unit->bytes_left;

	      p = salloc_r (current_unit->s, &rlength);
	      if (p == NULL)
		{
		  generate_error (ERROR_OS, NULL);
		  break;
		}

	      current_unit->bytes_left -= length;
	    }
	}

      break;

    case FORMATTED_SEQUENTIAL:
      length = 1;
      if (sf_seen_eor && done)
         break;

      do
        {
          p = salloc_r (current_unit->s, &length);

          /*In case of internal file, there may not be any '\n'.*/
          if (is_internal_unit() && p == NULL)
            {
               break;
            }

          if (p == NULL)
            {
              generate_error (ERROR_OS, NULL);
              break;
            }

          if (length == 0)
            {
              current_unit->endfile = AT_ENDFILE;
              break;
            }
        }
      while (*p != '\n');

      break;
    }

  if (current_unit->flags.access == ACCESS_SEQUENTIAL)
    test_endfile (current_unit);
}


/* next_record_w()-- Position to the next record in write mode */

static void
next_record_w (int done)
{
  gfc_offset c, m;
  int length;
  char *p;

  switch (current_mode ())
    {
    case FORMATTED_DIRECT:
    case UNFORMATTED_DIRECT:
      if (current_unit->bytes_left == 0)
	break;

      length = current_unit->bytes_left;

      p = salloc_w (current_unit->s, &length);
      if (p == NULL)
	goto io_error;

      memset (p, ' ', current_unit->bytes_left);
      if (sfree (current_unit->s) == FAILURE)
	goto io_error;

      break;

    case UNFORMATTED_SEQUENTIAL:
      m = current_unit->recl - current_unit->bytes_left; /* Bytes written */
      c = file_position (current_unit->s);

      length = sizeof (gfc_offset);

      /* Write the length tail */

      p = salloc_w (current_unit->s, &length);
      if (p == NULL)
	goto io_error;

      *((gfc_offset *) p) = m;
      if (sfree (current_unit->s) == FAILURE)
	goto io_error;

      /* Seek to the head and overwrite the bogus length with the real length */

      p = salloc_w_at (current_unit->s, &length, c - m - length);
      if (p == NULL)
	generate_error (ERROR_OS, NULL);

      *((gfc_offset *) p) = m;
      if (sfree (current_unit->s) == FAILURE)
	goto io_error;

      /* Seek past the end of the current record */

      if (sseek (current_unit->s, c + sizeof (gfc_offset)) == FAILURE)
	goto io_error;

      break;

    case FORMATTED_SEQUENTIAL:
      length = 1;
      p = salloc_w (current_unit->s, &length);

      if (!is_internal_unit())
        {
          if (p)
            *p = '\n'; /* no CR for internal writes */
          else
            goto io_error;
        }

      if (sfree (current_unit->s) == FAILURE)
 	goto io_error;

      break;

    io_error:
      generate_error (ERROR_OS, NULL);
      break;
    }
}


/* next_record()-- Position to the next record, which means moving to
 * the end of the current record.  This can happen under several
 * different conditions.  If the done flag is not set, we get ready to
 * process the next record.  */

void
next_record (int done)
{

  current_unit->read_bad = 0;

  if (g.mode == READING)
    next_record_r (done);
  else
    next_record_w (done);

  current_unit->current_record = 0;
  if (current_unit->flags.access == ACCESS_DIRECT)
    current_unit->last_record = file_position (current_unit->s) 
                               / current_unit->recl;
  else
    current_unit->last_record++;

  if (!done)
    pre_position ();
}


/* Finalize the current data transfer.  For a nonadvancing transfer,
 * this means advancing to the next record. */

static void
finalize_transfer (void)
{

  if (setjmp (g.eof_jump))
    {
       generate_error (ERROR_END, NULL);
       return;
    }

  if ((ionml != NULL) && (ioparm.namelist_name != NULL))
    {
       if (ioparm.namelist_read_mode)
         namelist_read();
       else
         namelist_write();
    }

  transfer = NULL;
  if (current_unit == NULL)
    return;

  if (ioparm.list_format && g.mode == READING)
    finish_list_read ();
  else
    {
      free_fnodes ();

      if (advance_status == ADVANCE_NO)
	{
	  /* Most systems buffer lines, so force the partial record
	     to be written out.  */
	  flush (current_unit->s);
	  return;
	}

      next_record (1);
      current_unit->current_record = 0;
    }

  sfree (current_unit->s);
}


/* Transfer function for IOLENGTH. It doesn't actually do any
   data transfer, it just updates the length counter.  */

static void
iolength_transfer (bt type, void *dest, int len)
{
  if (ioparm.iolength != NULL)
    *ioparm.iolength += len;
}


/* Initialize the IOLENGTH data transfer. This function is in essence
   a very much simplified version of data_transfer_init(), because it
   doesn't have to deal with units at all.  */

static void
iolength_transfer_init (void)
{

  if (ioparm.iolength != NULL)
    *ioparm.iolength = 0;

  g.item_count = 0;

  /* Set up the subroutine that will handle the transfers.  */

  transfer = iolength_transfer;

}


/* Library entry point for the IOLENGTH form of the INQUIRE
   statement. The IOLENGTH form requires no I/O to be performed, but
   it must still be a runtime library call so that we can determine
   the iolength for dynamic arrays and such.  */

void
st_iolength (void)
{
  library_start ();

  iolength_transfer_init ();
}

void
st_iolength_done (void)
{
  library_end ();
}


/* The READ statement */

void
st_read (void)
{

  library_start ();

  data_transfer_init (1);

  /* Handle complications dealing with the endfile record.  It is
   * significant that this is the only place where ERROR_END is
   * generated.  Reading an end of file elsewhere is either end of
   * record or an I/O error. */

  if (current_unit->flags.access == ACCESS_SEQUENTIAL)
    switch (current_unit->endfile)
      {
      case NO_ENDFILE:
	break;

      case AT_ENDFILE:
        if (!is_internal_unit())
          {
            generate_error (ERROR_END, NULL);
            current_unit->endfile = AFTER_ENDFILE;
          }
	break;

      case AFTER_ENDFILE:
	generate_error (ERROR_ENDFILE, NULL);
	break;
      }
}


void
st_read_done (void)
{
  finalize_transfer ();

  library_end ();
}


void
st_write (void)
{

  library_start ();
  data_transfer_init (0);
}


void
st_write_done (void)
{

  finalize_transfer ();

  /* Deal with endfile conditions associated with sequential files */

  if (current_unit != NULL && current_unit->flags.access == ACCESS_SEQUENTIAL)
    switch (current_unit->endfile)
      {
      case AT_ENDFILE:		/* Remain at the endfile record */
	break;

      case AFTER_ENDFILE:
	current_unit->endfile = AT_ENDFILE;	/* Just at it now */
	break;

      case NO_ENDFILE:		/* Get rid of whatever is after this record */
	if (struncate (current_unit->s) == FAILURE)
	  generate_error (ERROR_OS, NULL);

	current_unit->endfile = AT_ENDFILE;
	break;
      }

  library_end ();
}


static void
st_set_nml_var (void * var_addr, char * var_name, int var_name_len,
                int kind, bt type)
{
  namelist_info *t1 = NULL, *t2 = NULL;
  namelist_info *nml = (namelist_info *) get_mem (sizeof(
                                                    namelist_info ));
  nml->mem_pos = var_addr;
  nml->var_name = (char*) get_mem (var_name_len+1);
  strncpy (nml->var_name,var_name,var_name_len);
  nml->var_name[var_name_len] = 0;
  nml->len = kind;
  nml->type = type;

  nml->next = NULL;

  if (ionml == NULL)
     ionml = nml;
  else
    {
      t1 = ionml;
      while (t1 != NULL)
       {
         t2 = t1;
         t1 = t1->next;
       }
       t2->next = nml;
    }
}

void
st_set_nml_var_int (void * var_addr, char * var_name, int var_name_len,
                int kind)
{
   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_INTEGER);
}

void
st_set_nml_var_float (void * var_addr, char * var_name, int var_name_len,
                int kind)
{
   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_REAL);
}

void
st_set_nml_var_char (void * var_addr, char * var_name, int var_name_len,
                int kind)
{
   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_CHARACTER);
}

void
st_set_nml_var_complex (void * var_addr, char * var_name, int var_name_len,
                int kind)
{
   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_COMPLEX);
}

void
st_set_nml_var_log (void * var_addr, char * var_name, int var_name_len,
                int kind)
{
   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_LOGICAL);
}