text: /* Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
     Contributed by Andy Vaught
     Namelist transfer functions contributed by Paul Thomas
  
  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.
  
  In addition to the permissions in the GNU General Public License, the
  Free Software Foundation gives you unlimited permission to link the
  compiled version of this file into combinations with other programs,
  and to distribute those combinations without any restriction coming
  from the use of this file.  (The General Public License restrictions
  do apply in other respects; for example, they cover modification of
  the file, and distribution when not linked into a combine
  executable.)
  
  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, 51 Franklin Street, Fifth Floor,
  Boston, MA 02110-1301, USA.  */
  
  
  /* transfer.c -- Top level handling of data transfer statements.  */
  
  #include "config.h"
  #include <string.h>
  #include <assert.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.  */
  
  extern void transfer_integer (st_parameter_dt *, void *, int);
  export_proto(transfer_integer);
  
  extern void transfer_real (st_parameter_dt *, void *, int);
  export_proto(transfer_real);
  
  extern void transfer_logical (st_parameter_dt *, void *, int);
  export_proto(transfer_logical);
  
  extern void transfer_character (st_parameter_dt *, void *, int);
  export_proto(transfer_character);
  
  extern void transfer_complex (st_parameter_dt *, void *, int);
  export_proto(transfer_complex);
  
  extern void transfer_array (st_parameter_dt *, gfc_array_char *, int,
  			    gfc_charlen_type);
  export_proto(transfer_array);
  
  static void us_read (st_parameter_dt *, int);
  static void us_write (st_parameter_dt *, int);
  static void next_record_r_unf (st_parameter_dt *, int);
  static void next_record_w_unf (st_parameter_dt *, int);
  
  static const st_option advance_opt[] = {
    {"yes", ADVANCE_YES},
    {"no", ADVANCE_NO},
    {NULL, 0}
  };
  
  
  typedef enum
  { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
    FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
  }
  file_mode;
  
  
  static file_mode
  current_mode (st_parameter_dt *dtp)
  {
    file_mode m;
  
    m = FORM_UNSPECIFIED;
  
    if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
      {
        m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
  	FORMATTED_DIRECT : UNFORMATTED_DIRECT;
      }
    else if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
      {
        m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
  	FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
      }
    else if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
      {
        m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
  	FORMATTED_STREAM : UNFORMATTED_STREAM;
      }
  
    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.  */
  
  /* 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 allocations, we use a static buffer.
     For larger allocations, we are forced to allocate memory on the
     heap.  Hopefully this won't happen very often.  */
  
  char *
  read_sf (st_parameter_dt *dtp, int *length, int no_error)
  {
    char *base, *p, *q;
    int n, readlen, crlf;
    gfc_offset pos;
  
    if (*length > SCRATCH_SIZE)
      dtp->u.p.line_buffer = get_mem (*length);
    p = base = dtp->u.p.line_buffer;
  
    /* 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;
      }
  
    readlen = 1;
    n = 0;
  
    do
      {
        if (is_internal_unit (dtp))
  	{
  	  /* readlen may be modified inside salloc_r if
  	     is_internal_unit (dtp) is true.  */
  	  readlen = 1;
  	}
  
        q = salloc_r (dtp->u.p.current_unit->s, &readlen);
        if (q == NULL)
  	break;
  
        /* If we have a line without a terminating \n, drop through to
  	 EOR below.  */
        if (readlen < 1 && n == 0)
  	{
  	  if (no_error)
  	    break;
  	  generate_error (&dtp->common, ERROR_END, NULL);
  	  return NULL;
  	}
  
        if (readlen < 1 || *q == '\n' || *q == '\r')
  	{
  	  /* Unexpected end of line.  */
  
  	  /* If we see an EOR during non-advancing I/O, we need to skip
  	     the rest of the I/O statement.  Set the corresponding flag.  */
  	  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);
  	      q = salloc_r (dtp->u.p.current_unit->s, &readlen);
  	      if (*q != '\n' && readlen == 1) /* Not a CRLF after all.  */
  		sseek (dtp->u.p.current_unit->s, pos);
  	      else
  		crlf = 1;
  	    }
  
  	  /* Without padding, terminate the I/O statement without assigning
  	     the value.  With padding, the value still needs to be assigned,
  	     so we can just continue with a short read.  */
  	  if (dtp->u.p.current_unit->flags.pad == PAD_NO)
  	    {
  	      if (no_error)
  		break;
  	      generate_error (&dtp->common, ERROR_EOR, NULL);
  	      return NULL;
  	    }
  
  	  *length = n;
  	  dtp->u.p.sf_seen_eor = (crlf ? 2 : 1);
  	  break;
  	}
        /*  Short circuit the read if a comma is found during numeric input.
  	  The flag is set to zero during character reads so that commas in
  	  strings are not ignored  */
        if (*q == ',')
  	if (dtp->u.p.sf_read_comma == 1)
  	  {
  	    notify_std (&dtp->common, GFC_STD_GNU,
  			"Comma in formatted numeric read.");
  	    *length = n;
  	    break;
  	  }
  
        n++;
        *p++ = *q;
        dtp->u.p.sf_seen_eor = 0;
      }
    while (n < *length);
    dtp->u.p.current_unit->bytes_left -= *length;
  
    if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
      dtp->u.p.size_used += (gfc_offset) *length;
  
    return base;
  }
  
  
  /* 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 (st_parameter_dt *dtp, int *length)
  {
    char *source;
    int nread;
  
    if (is_stream_io (dtp))
      {
        if (sseek (dtp->u.p.current_unit->s,
  		 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
  	{
  	  generate_error (&dtp->common, ERROR_END, NULL);
  	  return NULL;
  	}
      }
    else
      {
        if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *length)
  	{
  	  /* For preconnected units with default record length, set bytes left
  	   to unit record length and proceed, otherwise error.  */
  	  if (dtp->u.p.current_unit->unit_number == options.stdin_unit
  	      && dtp->u.p.current_unit->recl == DEFAULT_RECL)
            dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
  	  else
  	    {
  	      if (dtp->u.p.current_unit->flags.pad == PAD_NO)
  		{
  		  /* Not enough data left.  */
  		  generate_error (&dtp->common, ERROR_EOR, NULL);
  		  return NULL;
  		}
  	    }
  
  	  if (dtp->u.p.current_unit->bytes_left == 0)
  	    {
  	      dtp->u.p.current_unit->endfile = AT_ENDFILE;
  	      generate_error (&dtp->common, ERROR_END, NULL);
  	      return NULL;
  	    }
  
  	  *length = dtp->u.p.current_unit->bytes_left;
  	}
      }
  
    if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
        (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL ||
         dtp->u.p.current_unit->flags.access == ACCESS_STREAM))
      {
        source = read_sf (dtp, length, 0);
        dtp->u.p.current_unit->strm_pos +=
  	(gfc_offset) (*length + dtp->u.p.sf_seen_eor);
        return source;
      }
    dtp->u.p.current_unit->bytes_left -= (gfc_offset) *length;
  
    nread = *length;
    source = salloc_r (dtp->u.p.current_unit->s, &nread);
  
    if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
      dtp->u.p.size_used += (gfc_offset) nread;
  
    if (nread != *length)
      {				/* Short read, this shouldn't happen.  */
        if (dtp->u.p.current_unit->flags.pad == PAD_YES)
  	*length = nread;
        else
  	{
  	  generate_error (&dtp->common, ERROR_EOR, NULL);
  	  source = NULL;
  	}
      }
  
    dtp->u.p.current_unit->strm_pos += (gfc_offset) nread;
  
    return source;
  }
  
  
  /* Reads a block directly into application data space.  This is for
     unformatted files.  */
  
  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;
    int short_record;
  
    if (is_stream_io (dtp))
      {
        if (sseek (dtp->u.p.current_unit->s,
  		 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
  	{
  	  generate_error (&dtp->common, ERROR_END, NULL);
  	  return;
  	}
  
        to_read_record = *nbytes;
        have_read_record = to_read_record;
        if (sread (dtp->u.p.current_unit->s, buf, &have_read_record) != 0)
  	{
  	  generate_error (&dtp->common, ERROR_OS, NULL);
  	  return;
  	}
  
        dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record; 
  
        if (to_read_record != have_read_record)
  	{
  	  /* Short read,  e.g. if we hit EOF.  For stream files,
  	   we have to set the end-of-file condition.  */
  	  generate_error (&dtp->common, ERROR_END, NULL);
  	  return;
  	}
        return;
      }
  
    if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
      {
        if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
  	{
  	  short_record = 1;
  	  to_read_record = (size_t) dtp->u.p.current_unit->bytes_left;
  	  *nbytes = to_read_record;
  	}
  
        else
  	{
  	  short_record = 0;
  	  to_read_record = *nbytes;
  	}
  
        dtp->u.p.current_unit->bytes_left -= to_read_record;
  
        if (sread (dtp->u.p.current_unit->s, buf, &to_read_record) != 0)
  	{
  	  generate_error (&dtp->common, ERROR_OS, NULL);
  	  return;
  	}
  
        if (to_read_record != *nbytes)  
  	{
  	  /* Short read, e.g. if we hit EOF.  Apparently, we read
  	   more than was written to the last record.  */
  	  *nbytes = to_read_record;
  	  return;
  	}
  
        if (short_record)
  	{
  	  generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
  	  return;
  	}
        return;
      }
  
    /* Unformatted sequential.  We loop over the subrecords, reading
       until the request has been fulfilled or the record has run out
       of continuation subrecords.  */
  
    if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
      {
        generate_error (&dtp->common, ERROR_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;
        short_record = 1;
      }
    else
      {
        to_read_record = *nbytes;
        short_record = 0;
      }
    have_read_record = 0;
  
    while(1)
      {
        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_record -= to_read_subrecord;
  	}
        else
  	{
  	  to_read_subrecord = to_read_record;
  	  to_read_record = 0;
  	}
  
        dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord;
  
        have_read_subrecord = to_read_subrecord;
        if (sread (dtp->u.p.current_unit->s, buf + have_read_record,
  		 &have_read_subrecord) != 0)
  	{
  	  generate_error (&dtp->common, ERROR_OS, NULL);
  	  return;
  	}
  
        have_read_record += have_read_subrecord;
  
        if (to_read_subrecord != have_read_subrecord)  
  			
  	{
  	  /* Short read, e.g. if we hit EOF.  This means the record
  	     structure has been corrupted, or the trailing record
  	     marker would still be present.  */
  
  	  *nbytes = have_read_record;
  	  generate_error (&dtp->common, ERROR_CORRUPT_FILE, NULL);
  	  return;
  	}
  
        if (to_read_record > 0)
  	{
  	  if (dtp->u.p.current_unit->continued)
  	    {
  	      next_record_r_unf (dtp, 0);
  	      us_read (dtp, 1);
  	    }
  	  else
  	    {
  	      /* Let's make sure the file position is correctly pre-positioned
  		 for the next read statement.  */
  
  	      dtp->u.p.current_unit->current_record = 0;
  	      next_record_r_unf (dtp, 0);
  	      generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
  	      return;
  	    }
  	}
        else
  	{
  	  /* Normal exit, the read request has been fulfilled.  */
  	  break;
  	}
      }
  
    dtp->u.p.current_unit->bytes_left -= have_read_record;
    if (short_record)
      {
        generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
        return;
      }
    return;
  }
  
  
  /* 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 (st_parameter_dt *dtp, int length)
  {
    char *dest;
  
    if (is_stream_io (dtp))
      {
        if (sseek (dtp->u.p.current_unit->s,
  		 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
  	{
  	  generate_error (&dtp->common, ERROR_OS, NULL);
  	  return NULL;
  	}
      }
    else
      {
        if (dtp->u.p.current_unit->bytes_left < (gfc_offset) length)
  	{
  	  /* For preconnected units with default record length, set bytes left
  	     to unit record length and proceed, otherwise error.  */
  	  if ((dtp->u.p.current_unit->unit_number == options.stdout_unit
  		|| dtp->u.p.current_unit->unit_number == options.stderr_unit)
  		&& dtp->u.p.current_unit->recl == DEFAULT_RECL)
  	    dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
  	  else
  	    {
  	      generate_error (&dtp->common, ERROR_EOR, NULL);
  	      return NULL;
  	    }
  	}
  
        dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
      }
  
    dest = salloc_w (dtp->u.p.current_unit->s, &length);
  
    if (dest == NULL)
      {
        generate_error (&dtp->common, ERROR_END, NULL);
        return NULL;
      }
  
    if (is_internal_unit (dtp) && dtp->u.p.current_unit->endfile == AT_ENDFILE)
      generate_error (&dtp->common, ERROR_END, NULL);
  
    if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
      dtp->u.p.size_used += (gfc_offset) length;
  
    dtp->u.p.current_unit->strm_pos += (gfc_offset) length;
  
    return dest;
  }
  
  
  /* High level interface to swrite(), taking care of errors.  This is only
     called for unformatted files.  There are three cases to consider:
     Stream I/O, unformatted direct, unformatted sequential.  */
  
  static try
  write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
  {
  
    size_t have_written, to_write_subrecord;
    int short_record;
  
  
    /* Stream I/O.  */
  
    if (is_stream_io (dtp))
      {
        if (sseek (dtp->u.p.current_unit->s,
  		 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
  	{
  	  generate_error (&dtp->common, ERROR_OS, NULL);
  	  return FAILURE;
  	}
  
        if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
  	{
  	  generate_error (&dtp->common, ERROR_OS, NULL);
  	  return FAILURE;
  	}
  
        dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes; 
  
        return SUCCESS;
      }
  
    /* Unformatted direct access.  */
  
    if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
      {
        if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)
  	{
  	  generate_error (&dtp->common, ERROR_DIRECT_EOR, NULL);
  	  return FAILURE;
  	}
  
        if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
  	{
  	  generate_error (&dtp->common, ERROR_OS, NULL);
  	  return FAILURE;
  	}
  
        dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
        dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
  
        return SUCCESS;
  
      }
  
    /* Unformatted sequential.  */
  
    have_written = 0;
  
    if (dtp->u.p.current_unit->flags.has_recl
        && (gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left)
      {
        nbytes = dtp->u.p.current_unit->bytes_left;
        short_record = 1;
      }
    else
      {
        short_record = 0;
      }
  
    while (1)
      {
  
        to_write_subrecord =
  	(size_t) dtp->u.p.current_unit->bytes_left_subrecord < nbytes ?
  	(size_t) dtp->u.p.current_unit->bytes_left_subrecord : nbytes;
  
        dtp->u.p.current_unit->bytes_left_subrecord -=
  	(gfc_offset) to_write_subrecord;
  
        if (swrite (dtp->u.p.current_unit->s, buf + have_written,
  		  &to_write_subrecord) != 0)
  	{
  	  generate_error (&dtp->common, ERROR_OS, NULL);
  	  return FAILURE;
  	}
  
        dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord; 
        nbytes -= to_write_subrecord;
        have_written += to_write_subrecord;
  
        if (nbytes == 0)
  	break;
  
        next_record_w_unf (dtp, 1);
        us_write (dtp, 1);
      }
    dtp->u.p.current_unit->bytes_left -= have_written;
    if (short_record)
      {
        generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
        return FAILURE;
      }
    return SUCCESS;
  }
  
  
  /* Master function for unformatted reads.  */
  
  static void
  unformatted_read (st_parameter_dt *dtp, bt type,
  		  void *dest, int kind,
  		  size_t size, size_t nelems)
  {
    size_t i, sz;
  
    /* Currently, character implies size=1.  */
    if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE
        || size == 1 || type == BT_CHARACTER)
      {
        sz = size * nelems;
        read_block_direct (dtp, dest, &sz);
      }
    else
      {
        char buffer[16];
        char *p;
        
        /* Break up complex into its constituent reals.  */
        if (type == BT_COMPLEX)
  	{
  	  nelems *= 2;
  	  size /= 2;
  	}
        p = dest;
        
        /* By now, all complex variables have been split into their
  	 constituent reals.  For types with padding, we only need to
  	 read kind bytes.  We don't care about the contents
  	 of the padding.  If we hit a short record, then sz is
  	 adjusted accordingly, making later reads no-ops.  */
        
        if (type == BT_REAL || type == BT_COMPLEX)
  	sz = size_from_real_kind (kind);
        else
  	sz = kind;
  
        for (i=0; i<nelems; i++)
  	{
   	  read_block_direct (dtp, buffer, &sz);
   	  reverse_memcpy (p, buffer, sz);
   	  p += size;
   	}
      }
  }
  
  
  /* Master function for unformatted writes.  */
  
  static void
  unformatted_write (st_parameter_dt *dtp, bt type,
  		   void *source, int kind,
  		   size_t size, size_t nelems)
  {
    if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE ||
        size == 1 || type == BT_CHARACTER)
      {
        size *= nelems;
  
        write_buf (dtp, source, size);
      }
    else
      {
        char buffer[16];
        char *p;
        size_t i, sz;
    
        /* Break up complex into its constituent reals.  */
        if (type == BT_COMPLEX)
  	{
  	  nelems *= 2;
  	  size /= 2;
  	}      
  
        p = source;
  
        /* By now, all complex variables have been split into their
  	 constituent reals.  For types with padding, we only need to
  	 read kind bytes.  We don't care about the contents
  	 of the padding.  */
  
        if (type == BT_REAL || type == BT_COMPLEX)
  	sz = size_from_real_kind (kind);
        else
  	sz = kind;
  
        for (i=0; i<nelems; i++)
  	{
  	  reverse_memcpy(buffer, p, size);
   	  p+= size;
  	  write_buf (dtp, buffer, sz);
  	}
      }
  }
  
  
  /* 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 (NULL, "type_name(): Bad type");
      }
  
    return p;
  }
  
  
  /* 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 (st_parameter_dt *dtp, const fnode *f)
  {
    char c, delimiter, *p, *q;
    int length;
  
    length = f->u.string.length;
    if (length == 0)
      return;
  
    p = write_block (dtp, 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' && c != 'h')
  	q++;			/* Skip the doubled delimiter.  */
      }
  }
  
  
  /* 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 (st_parameter_dt *dtp, bt expected, bt actual, const 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), dtp->u.p.item_count, type_name (actual));
  
    format_error (dtp, f, buffer);
    return 1;
  }
  
  
  /* 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,
     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
     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 len,
  			   size_t size)
  {
    char scratch[SCRATCH_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 = 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 (n > 0)
  	    generate_error (&dtp->common, ERROR_FORMAT,
  		"Insufficient data descriptors in format after reversion");
  	  return;
  	}
  
        /* Now discharge T, TR and X movements to the right.  This is delayed
  	 until a data producing format to suppress trailing spaces.  */
  	 
        t = f->format;
        if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
  	&& ((n>0 && (  t == FMT_I  || t == FMT_B  || t == FMT_O
  		    || t == FMT_Z  || t == FMT_F  || t == FMT_E
  		    || t == FMT_EN || t == FMT_ES || t == FMT_G
  		    || t == FMT_L  || t == FMT_A  || t == FMT_D))
  	    || t == FMT_STRING))
  	{
  	  if (dtp->u.p.skips > 0)
  	    {
  	      write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
  	      dtp->u.p.max_pos = (int)(dtp->u.p.current_unit->recl
  				       - dtp->u.p.current_unit->bytes_left);
  	    }
  	  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;
  	}
  
        bytes_used = (int)(dtp->u.p.current_unit->recl
  			 - dtp->u.p.current_unit->bytes_left);
  
        switch (t)
  	{
  	case FMT_I:
  	  if (n == 0)
  	    goto need_data;
  	  if (require_type (dtp, BT_INTEGER, type, f))
  	    return;
  
  	  if (dtp->u.p.mode == READING)
  	    read_decimal (dtp, f, p, len);
  	  else
  	    write_i (dtp, f, p, len);
  
  	  break;
  
  	case FMT_B:
  	  if (n == 0)
  	    goto need_data;
  	  if (require_type (dtp, BT_INTEGER, type, f))
  	    return;
  
  	  if (dtp->u.p.mode == READING)
  	    read_radix (dtp, f, p, len, 2);
  	  else
  	    write_b (dtp, f, p, len);
  
  	  break;
  
  	case FMT_O:
  	  if (n == 0)
  	    goto need_data;
  
  	  if (dtp->u.p.mode == READING)
  	    read_radix (dtp, f, p, len, 8);
  	  else
  	    write_o (dtp, f, p, len);
  
  	  break;
  
  	case FMT_Z:
  	  if (n == 0)
  	    goto need_data;
  
  	  if (dtp->u.p.mode == READING)
  	    read_radix (dtp, f, p, len, 16);
  	  else
  	    write_z (dtp, f, p, len);
  
  	  break;
  
  	case FMT_A:
  	  if (n == 0)
  	    goto need_data;
  
  	  if (dtp->u.p.mode == READING)
  	    read_a (dtp, f, p, len);
  	  else
  	    write_a (dtp, f, p, len);
  
  	  break;
  
  	case FMT_L:
  	  if (n == 0)
  	    goto need_data;
  
  	  if (dtp->u.p.mode == READING)
  	    read_l (dtp, f, p, len);
  	  else
  	    write_l (dtp, f, p, len);
  
  	  break;
  
  	case FMT_D:
  	  if (n == 0)
  	    goto need_data;
  	  if (require_type (dtp, BT_REAL, type, f))
  	    return;
  
  	  if (dtp->u.p.mode == READING)
  	    read_f (dtp, f, p, len);
  	  else
  	    write_d (dtp, f, p, len);
  
  	  break;
  
  	case FMT_E:
  	  if (n == 0)
  	    goto need_data;
  	  if (require_type (dtp, BT_REAL, type, f))
  	    return;
  
  	  if (dtp->u.p.mode == READING)
  	    read_f (dtp, f, p, len);
  	  else
  	    write_e (dtp, f, p, len);
  	  break;
  
  	case FMT_EN:
  	  if (n == 0)
  	    goto need_data;
  	  if (require_type (dtp, BT_REAL, type, f))
  	    return;
  
  	  if (dtp->u.p.mode == READING)
  	    read_f (dtp, f, p, len);
  	  else
  	    write_en (dtp, f, p, len);
  
  	  break;
  
  	case FMT_ES:
  	  if (n == 0)
  	    goto need_data;
  	  if (require_type (dtp, BT_REAL, type, f))
  	    return;
  
  	  if (dtp->u.p.mode == READING)
  	    read_f (dtp, f, p, len);
  	  else
  	    write_es (dtp, f, p, len);
  
  	  break;
  
  	case FMT_F:
  	  if (n == 0)
  	    goto need_data;
  	  if (require_type (dtp, BT_REAL, type, f))
  	    return;
  
  	  if (dtp->u.p.mode == READING)
  	    read_f (dtp, f, p, len);
  	  else
  	    write_f (dtp, f, p, len);
  
  	  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, len);
  		break;
  	      case BT_LOGICAL:
  		read_l (dtp, f, p, len);
  		break;
  	      case BT_CHARACTER:
  		read_a (dtp, f, p, len);
  		break;
  	      case BT_REAL:
  		read_f (dtp, f, p, len);
  		break;
  	      default:
  		goto bad_type;
  	      }
  	  else
  	    switch (type)
  	      {
  	      case BT_INTEGER:
  		write_i (dtp, f, p, len);
  		break;
  	      case BT_LOGICAL:
  		write_l (dtp, f, p, len);
  		break;
  	      case BT_CHARACTER:
  		write_a (dtp, f, p, len);
  		break;
  	      case BT_REAL:
  		write_d (dtp, f, p, len);
  		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;
  
  	/* Format codes that don't transfer data.  */
  	case FMT_X:
  	case FMT_TR:
  	  consume_data_flag = 0;
  
  	  pos = bytes_used + f->u.n + dtp->u.p.skips;
  	  dtp->u.p.skips = f->u.n + dtp->u.p.skips;
  	  dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos;
  
  	  /* 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)
  	    {
  	      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:
  	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.pending_spaces = dtp->u.p.pending_spaces < 0 ? 0
  					    : dtp->u.p.pending_spaces;
  		  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 */
  	    {
  	      if (dtp->u.p.mode == READING)
  		pos = f->u.n - 1;
  	      else
  		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
  	     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;
  
  	  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:
  	  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_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");
  	}
  
        /* 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;
  
        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_data:
    unget_format (dtp, f);
  }
  
  static void
  formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
  		    size_t size, size_t nelems)
  {
    size_t elem;
    char *tmp;
  
    tmp = (char *) p;
  
    /* Big loop over all the elements.  */
    for (elem = 0; elem < nelems; elem++)
      {
        dtp->u.p.item_count++;
        formatted_transfer_scalar (dtp, type, tmp + size*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.  */
  
  void
  transfer_integer (st_parameter_dt *dtp, void *p, int kind)
  {
    if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
      return;
    dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
  }
  
  
  void
  transfer_real (st_parameter_dt *dtp, void *p, int kind)
  {
    size_t size;
    if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
      return;
    size = size_from_real_kind (kind);
    dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
  }
  
  
  void
  transfer_logical (st_parameter_dt *dtp, void *p, int kind)
  {
    if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
      return;
    dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
  }
  
  
  void
  transfer_character (st_parameter_dt *dtp, void *p, int len)
  {
    if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
      return;
    /* Currently we support only 1 byte chars, and the library is a bit
       confused of character kind vs. length, so we kludge it by setting
       kind = length.  */
    dtp->u.p.transfer (dtp, BT_CHARACTER, p, len, len, 1);
  }
  
  
  void
  transfer_complex (st_parameter_dt *dtp, void *p, int kind)
  {
    size_t size;
    if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
      return;
    size = size_from_complex_kind (kind);
    dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
  }
  
  
  void
  transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
  		gfc_charlen_type charlen)
  {
    index_type count[GFC_MAX_DIMENSIONS];
    index_type extent[GFC_MAX_DIMENSIONS];
    index_type stride[GFC_MAX_DIMENSIONS];
    index_type stride0, rank, size, type, n;
    size_t tsize;
    char *data;
    bt iotype;
  
    if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
      return;
  
    type = GFC_DESCRIPTOR_TYPE (desc);
    size = GFC_DESCRIPTOR_SIZE (desc);
  
    /* FIXME: What a kludge: Array descriptors and the IO library use
       different enums for types.  */
    switch (type)
      {
      case GFC_DTYPE_UNKNOWN:
        iotype = BT_NULL;  /* Is this correct?  */
        break;
      case GFC_DTYPE_INTEGER:
        iotype = BT_INTEGER;
        break;
      case GFC_DTYPE_LOGICAL:
        iotype = BT_LOGICAL;
        break;
      case GFC_DTYPE_REAL:
        iotype = BT_REAL;
        break;
      case GFC_DTYPE_COMPLEX:
        iotype = BT_COMPLEX;
        break;
      case GFC_DTYPE_CHARACTER:
        iotype = BT_CHARACTER;
        /* FIXME: Currently dtype contains the charlen, which is
  	 clobbered if charlen > 2**24. That's why we use a separate
  	 argument for the charlen. However, if we want to support
  	 non-8-bit charsets we need to fix dtype to contain
  	 sizeof(chartype) and fix the code below.  */
        size = charlen;
        kind = charlen;
        break;
      case GFC_DTYPE_DERIVED:
        internal_error (&dtp->common,
  		"Derived type I/O should have been handled via the frontend.");
        break;
      default:
        internal_error (&dtp->common, "transfer_array(): Bad type");
      }
  
    rank = GFC_DESCRIPTOR_RANK (desc);
    for (n = 0; n < rank; n++)
      {
        count[n] = 0;
        stride[n] = desc->dim[n].stride;
        extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound;
  
        /* If the extent of even one dimension is zero, then the entire
  	 array section contains zero elements, so we return.  */
        if (extent[n] <= 0)
  	return;
      }
  
    stride0 = stride[0];
  
    /* If the innermost dimension has stride 1, we can do the transfer
       in contiguous chunks.  */
    if (stride0 == 1)
      tsize = extent[0];
    else
      tsize = 1;
  
    data = GFC_DESCRIPTOR_DATA (desc);
  
    while (data)
      {
        dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
        data += stride0 * size * tsize;
        count[0] += tsize;
        n = 0;
        while (count[n] == extent[n])
  	{
  	  count[n] = 0;
  	  data -= stride[n] * extent[n] * size;
  	  n++;
  	  if (n == rank)
  	    {
  	      data = NULL;
  	      break;
  	    }
  	  else
  	    {
  	      count[n]++;
  	      data += stride[n] * size;
  	    }
  	}
      }
  }
  
  
  /* Preposition a sequential unformatted file while reading.  */
  
  static void
  us_read (st_parameter_dt *dtp, int continued)
  {
    char *p;
    int n;
    int 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;
  
    p = salloc_r (dtp->u.p.current_unit->s, &n);
  
    if (n == 0)
      {
        dtp->u.p.current_unit->endfile = AT_ENDFILE;
        return;  /* end of file */
      }
  
    if (p == NULL || n != nr)
      {
        generate_error (&dtp->common, ERROR_BAD_US, NULL);
        return;
      }
  
    /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here.  */
    if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
      {
        switch (nr)
  	{
  	case sizeof(GFC_INTEGER_4):
  	  memcpy (&i4, p, sizeof (i4));
  	  i = i4;
  	  break;
  
  	case sizeof(GFC_INTEGER_8):
  	  memcpy (&i8, p, sizeof (i8));
  	  i = i8;
  	  break;
  
  	default:
  	  runtime_error ("Illegal value for record marker");
  	  break;
  	}
      }
    else
        switch (nr)
  	{
  	case sizeof(GFC_INTEGER_4):
  	  reverse_memcpy (&i4, p, sizeof (i4));
  	  i = i4;
  	  break;
  
  	case sizeof(GFC_INTEGER_8):
  	  reverse_memcpy (&i8, p, sizeof (i8));
  	  i = i8;
  	  break;
  
  	default:
  	  runtime_error ("Illegal value for record marker");
  	  break;
  	}
  
    if (i >= 0)
      {
        dtp->u.p.current_unit->bytes_left_subrecord = i;
        dtp->u.p.current_unit->continued = 0;
      }
    else
      {
        dtp->u.p.current_unit->bytes_left_subrecord = -i;
        dtp->u.p.current_unit->continued = 1;
      }
  
    if (! continued)
      dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
  }
  
  
  /* Preposition a sequential unformatted file while writing.  This
     amount to writing a bogus length that will be filled in later.  */
  
  static void
  us_write (st_parameter_dt *dtp, int continued)
  {
    size_t nbytes;
    gfc_offset dummy;
  
    dummy = 0;
  
    if (compile_options.record_marker == 0)
      nbytes = sizeof (GFC_INTEGER_4);
    else
      nbytes = compile_options.record_marker ;
  
    if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0)
      generate_error (&dtp->common, ERROR_OS, NULL);
  
    /* For sequential unformatted, if RECL= was not specified in the OPEN
       we write until we have more bytes than can fit in the subrecord
       markers, then we write a new subrecord.  */
    
    dtp->u.p.current_unit->bytes_left_subrecord =
      dtp->u.p.current_unit->recl_subrecord;
    dtp->u.p.current_unit->continued = continued;
  }
  
  
  /* 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 (st_parameter_dt *dtp)
  {
    if (dtp->u.p.current_unit->current_record)
      return;			/* Already positioned.  */
  
    switch (current_mode (dtp))
      {
      case FORMATTED_STREAM:
      case UNFORMATTED_STREAM:
        /* There are no records with stream I/O.  Set the default position
  	 to the beginning of the file if no position was specified.  */
        if ((dtp->common.flags & IOPARM_DT_HAS_REC) == 0)
          dtp->u.p.current_unit->strm_pos = 1;
        break;
      
      case UNFORMATTED_SEQUENTIAL:
        if (dtp->u.p.mode == READING)
  	us_read (dtp, 0);
        else
  	us_write (dtp, 0);
  
        break;
  
      case FORMATTED_SEQUENTIAL:
      case FORMATTED_DIRECT:
      case UNFORMATTED_DIRECT:
        dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
        break;
      }
  
    dtp->u.p.current_unit->current_record = 1;
  }
  
  
  /* Initialize things for a data transfer.  This code is common for
     both reading and writing.  */
  
  static void
  data_transfer_init (st_parameter_dt *dtp, int read_flag)
  {
    unit_flags u_flags;  /* Used for creating a unit if needed.  */
    GFC_INTEGER_4 cf = dtp->common.flags;
    namelist_info *ionml;
  
    ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
    memset (&dtp->u.p, 0, sizeof (dtp->u.p));
    dtp->u.p.ionml = ionml;
    dtp->u.p.mode = read_flag ? READING : WRITING;
  
    if ((cf & IOPARM_DT_HAS_SIZE) != 0)
      dtp->u.p.size_used = 0;  /* Initialize the count.  */
  
    dtp->u.p.current_unit = get_unit (dtp, 1);
    if (dtp->u.p.current_unit->s == NULL)
    {  /* Open the unit with some default flags.  */
       st_parameter_open opp;
       unit_convert conv;
  
       if (dtp->common.unit < 0)
       {
         close_unit (dtp->u.p.current_unit);
         dtp->u.p.current_unit = NULL;
         generate_error (&dtp->common, ERROR_BAD_OPTION,
  		       "Bad unit number in OPEN statement");
         return;
       }
       memset (&u_flags, '\0', sizeof (u_flags));
       u_flags.access = ACCESS_SEQUENTIAL;
       u_flags.action = ACTION_READWRITE;
  
       /* Is it unformatted?  */
       if (!(cf & (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.status = STATUS_UNKNOWN;
  
       conv = get_unformatted_convert (dtp->common.unit);
  
       if (conv == CONVERT_NONE)
         conv = compile_options.convert;
  
       /* We use l8_to_l4_offset, which is 0 on little-endian machines
  	and 1 on big-endian machines.  */
       switch (conv)
         {
         case CONVERT_NATIVE:
         case CONVERT_SWAP:
  	 break;
  	 
         case CONVERT_BIG:
  	 conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP;
  	 break;
        
         case CONVERT_LITTLE:
  	 conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE;
  	 break;
  	 
         default:
  	 internal_error (&opp.common, "Illegal value for CONVERT");
  	 break;
         }
  
       u_flags.convert = conv;
  
       opp.common = dtp->common;
       opp.common.flags &= IOPARM_COMMON_MASK;
       dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags);
       dtp->common.flags &= ~IOPARM_COMMON_MASK;
       dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
       if (dtp->u.p.current_unit == NULL)
         return;
    }
  
    /* Check the action.  */
  
    if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
      {
        generate_error (&dtp->common, ERROR_BAD_ACTION,
  		      "Cannot read from file opened for WRITE");
        return;
      }
  
    if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ)
      {
        generate_error (&dtp->common, ERROR_BAD_ACTION,
  		      "Cannot write to file opened for READ");
        return;
      }
  
    dtp->u.p.first_item = 1;
  
    /* Check the format.  */
  
    if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
      parse_format (dtp);
  
    if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
        && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
  	 != 0)
      {
        generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
  		      "Format present for UNFORMATTED data transfer");
        return;
      }
  
    if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
       {
  	if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
  	   generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
  		    "A format cannot be specified with a namelist");
       }
    else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
  	   !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
      {
        generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
  		      "Missing format for FORMATTED data transfer");
      }
  
    if (is_internal_unit (dtp)
        && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
      {
        generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
  		      "Internal file cannot be accessed by UNFORMATTED "
  		      "data transfer");
        return;
      }
  
    /* Check the record or position number.  */
  
    if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
        && (cf & IOPARM_DT_HAS_REC) == 0)
      {
        generate_error (&dtp->common, ERROR_MISSING_OPTION,
  		      "Direct access data transfer requires record number");
        return;
      }
  
    if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
        && (cf & IOPARM_DT_HAS_REC) != 0)
      {
        generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
  		      "Record number not allowed for sequential access data transfer");
        return;
      }
  
    /* Process the ADVANCE option.  */
  
    dtp->u.p.advance_status
      = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED :
        find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt,
  		   "Bad ADVANCE parameter in data transfer statement");
  
    if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED)
      {
        if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
  	{
  	  generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
  			  "ADVANCE specification conflicts with sequential access");
  	  return;
  	}
  
        if (is_internal_unit (dtp))
  	{
  	  generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
  			  "ADVANCE specification conflicts with internal file");
  	  return;
  	}
  
        if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
  	  != IOPARM_DT_HAS_FORMAT)
  	{
  	  generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
  			  "ADVANCE specification requires an explicit format");
  	  return;
  	}
      }
  
    if (read_flag)
      {
        if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
  	{
  	  generate_error (&dtp->common, ERROR_MISSING_OPTION,
  			  "EOR specification requires an ADVANCE specification "
  			  "of NO");
  	  return;
  	}
  
        if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
  	{
  	  generate_error (&dtp->common, ERROR_MISSING_OPTION,
  			  "SIZE specification requires an ADVANCE specification of NO");
  	  return;
  	}
      }
    else
      {				/* Write constraints.  */
        if ((cf & IOPARM_END) != 0)
  	{
  	  generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
  			  "END specification cannot appear in a write statement");
  	  return;
  	}
  
        if ((cf & IOPARM_EOR) != 0)
  	{
  	  generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
  			  "EOR specification cannot appear in a write statement");
  	  return;
  	}
  
        if ((cf & IOPARM_DT_HAS_SIZE) != 0)
  	{
  	  generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
  			  "SIZE specification cannot appear in a write statement");
  	  return;
  	}
      }
  
    if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
      dtp->u.p.advance_status = ADVANCE_YES;
  
    /* Sanity checks on the record number.  */
    if ((cf & IOPARM_DT_HAS_REC) != 0)
      {
        if (dtp->rec <= 0)
  	{
  	  generate_error (&dtp->common, ERROR_BAD_OPTION,
  			  "Record number must be positive");
  	  return;
  	}
  
        if (dtp->rec >= dtp->u.p.current_unit->maxrec)
  	{
  	  generate_error (&dtp->common, ERROR_BAD_OPTION,
  			  "Record number too large");
  	  return;
  	}
  
        /* Check to see if we might be reading what we wrote before  */
  
        if (dtp->u.p.mode == READING
  	  && dtp->u.p.current_unit->mode == WRITING
  	  && !is_internal_unit (dtp))
  	 flush(dtp->u.p.current_unit->s);
  
        /* Check whether the record exists to be read.  Only
  	 a partial record needs to exist.  */
  
        if (dtp->u.p.mode == READING && (dtp->rec -1)
  	  * dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s))
  	{
  	  generate_error (&dtp->common, ERROR_BAD_OPTION,
  			  "Non-existing record number");
  	  return;
  	}
  
        /* Position the file.  */
        if (!is_stream_io (dtp))
  	{
  	  if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
  		     * dtp->u.p.current_unit->recl) == FAILURE)
  	    {
  	      generate_error (&dtp->common, ERROR_OS, NULL);
  	      return;
  	    }
  	}
        else
  	dtp->u.p.current_unit->strm_pos = dtp->rec;
  
      }
  
    /* 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);
  
    dtp->u.p.current_unit->mode = dtp->u.p.mode;
  
    /* Set the initial value of flags.  */
  
    dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
    dtp->u.p.sign_status = SIGN_S;
  
    pre_position (dtp);
  
    /* Set up the subroutine that will handle the transfers.  */
  
    if (read_flag)
      {
        if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
  	dtp->u.p.transfer = unformatted_read;
        else
  	{
  	  if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
  	    dtp->u.p.transfer = list_formatted_read;
  	  else
  	    dtp->u.p.transfer = formatted_transfer;
  	}
      }
    else
      {
        if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
  	dtp->u.p.transfer = unformatted_write;
        else
  	{
  	  if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
  	    dtp->u.p.transfer = list_formatted_write;
  	  else
  	    dtp->u.p.transfer = formatted_transfer;
  	}
      }
  
    /* Make sure that we don't do a read after a nonadvancing write.  */
  
    if (read_flag)
      {
        if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp))
  	{
  	  generate_error (&dtp->common, ERROR_BAD_OPTION,
  			  "Cannot READ after a nonadvancing WRITE");
  	  return;
  	}
      }
    else
      {
        if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar)
  	dtp->u.p.current_unit->read_bad = 1;
      }
  
    /* Start the data transfer if we are doing a formatted transfer.  */
    if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
        && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0)
        && dtp->u.p.ionml == NULL)
      formatted_transfer (dtp, 0, NULL, 0, 0, 1);
  }
  
  /* Initialize an array_loop_spec given the array descriptor.  The function
     returns the index of the last element of the array.  */
     
  gfc_offset
  init_loop_spec (gfc_array_char *desc, array_loop_spec *ls)
  {
    int rank = GFC_DESCRIPTOR_RANK(desc);
    int i;
    gfc_offset index; 
  
    index = 1;
    for (i=0; i<rank; i++)
      {
        ls[i].idx = desc->dim[i].lbound;
        ls[i].start = desc->dim[i].lbound;
        ls[i].end = desc->dim[i].ubound;
        ls[i].step = desc->dim[i].stride;
        
        index += (desc->dim[i].ubound - desc->dim[i].lbound)
                        * desc->dim[i].stride;
      }
    return index;
  }
  
  /* Determine the index to the next record in an internal unit array by
     by incrementing through the array_loop_spec.  TODO:  Implement handling
     negative strides. */
     
  gfc_offset
  next_array_record (st_parameter_dt *dtp, array_loop_spec *ls)
  {
    int i, carry;
    gfc_offset index;
    
    carry = 1;
    index = 0;
    
    for (i = 0; i < dtp->u.p.current_unit->rank; i++)
      {
        if (carry)
          {
            ls[i].idx++;
            if (ls[i].idx > ls[i].end)
              {
                ls[i].idx = ls[i].start;
                carry = 1;
              }
            else
              carry = 0;
          }
        index = index + (ls[i].idx - ls[i].start) * ls[i].step;
      }
  
    return index;
  }
  
  
  
  /* Skip to the end of the current record, taking care of an optional
     record marker of size bytes.  If the file is not seekable, we
     read chunks of size MAX_READ until we get to the right
     position.  */
  
  #define MAX_READ 4096
  
  static void
  skip_record (st_parameter_dt *dtp, size_t bytes)
  {
    gfc_offset new;
    int rlength, length;
    char *p;
  
    dtp->u.p.current_unit->bytes_left_subrecord += bytes;
    if (dtp->u.p.current_unit->bytes_left_subrecord == 0)
      return;
  
    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)
  	generate_error (&dtp->common, ERROR_OS, NULL);
      }
    else
      {			/* Seek by reading data.  */
        while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
  	{
  	  rlength = length =
  	    (MAX_READ > dtp->u.p.current_unit->bytes_left_subrecord) ?
  	    MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord;
  
  	  p = salloc_r (dtp->u.p.current_unit->s, &rlength);
  	  if (p == NULL)
  	    {
  	      generate_error (&dtp->common, ERROR_OS, NULL);
  	      return;
  	    }
  
  	  dtp->u.p.current_unit->bytes_left_subrecord -= length;
  	}
      }
  
  }
  
  #undef MAX_READ
  
  /* Advance to the next record reading unformatted files, taking
     care of subrecords.  If complete_record is nonzero, we loop
     until all subrecords are cleared.  */
  
  static void
  next_record_r_unf (st_parameter_dt *dtp, int complete_record)
  {
    size_t bytes;
  
    bytes =  compile_options.record_marker == 0 ?
      sizeof (GFC_INTEGER_4) : compile_options.record_marker;
  
    while(1)
      {
  
        /* Skip over tail */
  
        skip_record (dtp, bytes);
  
        if ( ! (complete_record && dtp->u.p.current_unit->continued))
  	return;
  
        us_read (dtp, 1);
      }
  }
  
  /* Space to the next record for read mode.  */
  
  static void
  next_record_r (st_parameter_dt *dtp)
  {
    gfc_offset record;
    int length, bytes_left;
    char *p;
  
    switch (current_mode (dtp))
      {
      /* No records in unformatted STREAM I/O.  */
      case UNFORMATTED_STREAM:
        return;
      
      case UNFORMATTED_SEQUENTIAL:
        next_record_r_unf (dtp, 1);
        dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
        break;
  
      case FORMATTED_DIRECT:
      case UNFORMATTED_DIRECT:
        skip_record (dtp, 0);
        break;
  
      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)
  	{
  	  dtp->u.p.sf_seen_eor = 0;
  	  break;
  	}
  
        if (is_internal_unit (dtp))
  	{
  	  if (is_array_io (dtp))
  	    {
  	      record = next_array_record (dtp, dtp->u.p.current_unit->ls);
  
  	      /* Now seek to this record.  */
  	      record = record * dtp->u.p.current_unit->recl;
  	      if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
  		{
  		  generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
  		  break;
  		}
  	      dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
  	    }
  	  else  
  	    {
  	      bytes_left = (int) dtp->u.p.current_unit->bytes_left;
  	      p = salloc_r (dtp->u.p.current_unit->s, &bytes_left);
  	      if (p != NULL)
  		dtp->u.p.current_unit->bytes_left
  		  = dtp->u.p.current_unit->recl;
  	    } 
  	  break;
  	}
        else do
  	{
  	  p = salloc_r (dtp->u.p.current_unit->s, &length);
  
  	  if (p == NULL)
  	    {
  	      generate_error (&dtp->common, ERROR_OS, NULL);
  	      break;
  	    }
  
  	  if (length == 0)
  	    {
  	      dtp->u.p.current_unit->endfile = AT_ENDFILE;
  	      break;
  	    }
  
  	  if (is_stream_io (dtp))
  	    dtp->u.p.current_unit->strm_pos++;
  	}
        while (*p != '\n');
  
        break;
      }
  
    if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
      test_endfile (dtp->u.p.current_unit);
  }
  
  
  /* Small utility function to write a record marker, taking care of
     byte swapping and of choosing the correct size.  */
  
  inline static int
  write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
  {
    size_t len;
    GFC_INTEGER_4 buf4;
    GFC_INTEGER_8 buf8;
    char p[sizeof (GFC_INTEGER_8)];
  
    if (compile_options.record_marker == 0)
      len = sizeof (GFC_INTEGER_4);
    else
      len = compile_options.record_marker;
  
    /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here.  */
    if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
      {
        switch (len)
  	{
  	case sizeof (GFC_INTEGER_4):
  	  buf4 = buf;
  	  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);
  	  break;
  
  	default:
  	  runtime_error ("Illegal value for record marker");
  	  break;
  	}
      }
    else
      {
        switch (len)
  	{
  	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);
  	  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);
  	  break;
  
  	default:
  	  runtime_error ("Illegal value for record marker");
  	  break;
  	}
      }
  
  }
  
  /* Position to the next (sub)record in write mode for
     unformatted sequential files.  */
  
  static void
  next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
  {
    gfc_offset c, m, m_write;
    size_t record_marker;
  
    /* 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);
  
    /* Write the length tail.  If we finish a record containing
       subrecords, we write out the negative length.  */
  
    if (dtp->u.p.current_unit->continued)
      m_write = -m;
    else
      m_write = m;
  
    if (write_us_marker (dtp, m_write) != 0)
      goto io_error;
  
    if (compile_options.record_marker == 0)
      record_marker = sizeof (GFC_INTEGER_4);
    else
      record_marker = compile_options.record_marker;
  
    /* Seek to the head and overwrite the bogus length with the real
       length.  */
  
    if (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
        == FAILURE)
      goto io_error;
  
    if (next_subrecord)
      m_write = -m;
    else
      m_write = m;
  
    if (write_us_marker (dtp, m_write) != 0)
      goto io_error;
  
    /* Seek past the end of the current record.  */
  
    if (sseek (dtp->u.p.current_unit->s, c + record_marker) == FAILURE)
      goto io_error;
  
    return;
  
   io_error:
    generate_error (&dtp->common, ERROR_OS, NULL);
    return;
  
  }
  
  /* Position to the next record in write mode.  */
  
  static void
  next_record_w (st_parameter_dt *dtp, int done)
  {
    gfc_offset m, record, max_pos;
    int length;
    char *p;
  
    /* 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;
  
    switch (current_mode (dtp))
      {
      /* No records in unformatted STREAM I/O.  */
      case UNFORMATTED_STREAM:
        return;
  
      case FORMATTED_DIRECT:
        if (dtp->u.p.current_unit->bytes_left == 0)
  	break;
  
        if (sset (dtp->u.p.current_unit->s, ' ', 
  		dtp->u.p.current_unit->bytes_left) == FAILURE)
  	goto io_error;
  
        break;
  
      case UNFORMATTED_DIRECT:
        if (sfree (dtp->u.p.current_unit->s) == FAILURE)
  	goto io_error;
        break;
  
      case UNFORMATTED_SEQUENTIAL:
        next_record_w_unf (dtp, 0);
        dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
        break;
  
      case FORMATTED_STREAM:
      case FORMATTED_SEQUENTIAL:
  
        if (is_internal_unit (dtp))
  	{
  	  if (is_array_io (dtp))
  	    {
  	      length = (int) dtp->u.p.current_unit->bytes_left;
  	      
  	      /* If the farthest position reached is greater than current
  	      position, adjust the position and set length to pad out
  	      whats left.  Otherwise just pad whats left.
  	      (for character array unit) */
  	      m = dtp->u.p.current_unit->recl
  			- dtp->u.p.current_unit->bytes_left;
  	      if (max_pos > m)
  		{
  		  length = (int) (max_pos - m);
  		  p = salloc_w (dtp->u.p.current_unit->s, &length);
  		  length = (int) (dtp->u.p.current_unit->recl - max_pos);
  		}
  
  	      if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
  		{
  		  generate_error (&dtp->common, ERROR_END, NULL);
  		  return;
  		}
  
  	      /* Now that the current record has been padded out,
  		 determine where the next record in the array is. */
  	      record = next_array_record (dtp, dtp->u.p.current_unit->ls);
  	      if (record == 0)
  		dtp->u.p.current_unit->endfile = AT_ENDFILE;
  	      
  	      /* Now seek to this record */
  	      record = record * dtp->u.p.current_unit->recl;
  
  	      if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
  		{
  		  generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
  		  return;
  		}
  
  	      dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
  	    }
  	  else
  	    {
  	      length = 1;
  
  	      /* If this is the last call to next_record move to the farthest
  		 position reached and set length to pad out the remainder
  		 of the record. (for character scaler unit) */
  	      if (done)
  		{
  		  m = dtp->u.p.current_unit->recl
  			- dtp->u.p.current_unit->bytes_left;
  		  if (max_pos > m)
  		    {
  		      length = (int) (max_pos - m);
  		      p = salloc_w (dtp->u.p.current_unit->s, &length);
  		      length = (int) (dtp->u.p.current_unit->recl - max_pos);
  		    }
  		  else
  		    length = (int) dtp->u.p.current_unit->bytes_left;
  		}
  
  	      if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
  		{
  		  generate_error (&dtp->common, ERROR_END, NULL);
  		  return;
  		}
  	    }
  	}
        else
  	{
  
  	  /* If this is the last call to next_record move to the farthest
  	  position reached in preparation for completing the record.
  	  (for file unit) */
  	  if (done)
  	    {
  	      m = dtp->u.p.current_unit->recl -
  			dtp->u.p.current_unit->bytes_left;
  	      if (max_pos > m)
  		{
  		  length = (int) (max_pos - m);
  		  p = salloc_w (dtp->u.p.current_unit->s, &length);
  		}
   	    }
  	  size_t len;
  	  const char crlf[] = "\r\n";
  #ifdef HAVE_CRLF
  	  len = 2;
  #else
  	  len = 1;
  #endif
  	  if (swrite (dtp->u.p.current_unit->s, &crlf[2-len], &len) != 0)
  	    goto io_error;
  	  
  	  if (is_stream_io (dtp))
  	    dtp->u.p.current_unit->strm_pos += len;
  	}
  
        break;
  
      io_error:
        generate_error (&dtp->common, ERROR_OS, NULL);
        break;
      }
  }
  
  /* 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 (st_parameter_dt *dtp, int done)
  {
    gfc_offset fp; /* File position.  */
  
    dtp->u.p.current_unit->read_bad = 0;
  
    if (dtp->u.p.mode == READING)
      next_record_r (dtp);
    else
      next_record_w (dtp, done);
  
    if (!is_stream_io (dtp))
      {
        /* keep position up to date for INQUIRE */
        dtp->u.p.current_unit->flags.position = POSITION_ASIS;
        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);
  	  /* Calculate next record, rounding up partial records.  */
  	  dtp->u.p.current_unit->last_record =
  	    (fp + dtp->u.p.current_unit->recl - 1) /
  	      dtp->u.p.current_unit->recl;
  	}
        else
  	dtp->u.p.current_unit->last_record++;
      }
  
    if (!done)
      pre_position (dtp);
  }
  
  
  /* Finalize the current data transfer.  For a nonadvancing transfer,
     this means advancing to the next record.  For internal units close the
     stream associated with the unit.  */
  
  static void
  finalize_transfer (st_parameter_dt *dtp)
  {
    jmp_buf eof_jump;
    GFC_INTEGER_4 cf = dtp->common.flags;
  
    if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
      *dtp->size = (GFC_INTEGER_4) dtp->u.p.size_used;
  
    if (dtp->u.p.eor_condition)
      {
        generate_error (&dtp->common, ERROR_EOR, NULL);
        return;
      }
  
    if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
      return;
  
    if ((dtp->u.p.ionml != NULL)
        && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
      {
         if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
  	 namelist_read (dtp);
         else
  	 namelist_write (dtp);
      }
  
    dtp->u.p.transfer = NULL;
    if (dtp->u.p.current_unit == NULL)
      return;
  
    dtp->u.p.eof_jump = &eof_jump;
    if (setjmp (eof_jump))
      {
        generate_error (&dtp->common, ERROR_END, NULL);
        return;
      }
  
    if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
      {
        finish_list_read (dtp);
        sfree (dtp->u.p.current_unit->s);
        return;
      }
  
    if (is_stream_io (dtp))
      {
        if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
  	next_record (dtp, 1);
        flush (dtp->u.p.current_unit->s);
        sfree (dtp->u.p.current_unit->s);
        return;
      }
  
    dtp->u.p.current_unit->current_record = 0;
  
    if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar)
      {
        dtp->u.p.seen_dollar = 0;
        sfree (dtp->u.p.current_unit->s);
        return;
      }
  
    if (dtp->u.p.advance_status == ADVANCE_NO)
      {
        flush (dtp->u.p.current_unit->s);
        return;
      }
  
    next_record (dtp, 1);
    sfree (dtp->u.p.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 (st_parameter_dt *dtp, bt type __attribute__((unused)), 
  		   void *dest __attribute__ ((unused)),
  		   int kind __attribute__((unused)), 
  		   size_t size, size_t nelems)
  {
    if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
      *dtp->iolength += (GFC_INTEGER_4) size * nelems;
  }
  
  
  /* 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 (st_parameter_dt *dtp)
  {
    if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
      *dtp->iolength = 0;
  
    memset (&dtp->u.p, 0, sizeof (dtp->u.p));
  
    /* Set up the subroutine that will handle the transfers.  */
  
    dtp->u.p.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.  */
  
  extern void st_iolength (st_parameter_dt *);
  export_proto(st_iolength);
  
  void
  st_iolength (st_parameter_dt *dtp)
  {
    library_start (&dtp->common);
    iolength_transfer_init (dtp);
  }
  
  extern void st_iolength_done (st_parameter_dt *);
  export_proto(st_iolength_done);
  
  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 ();
  }
  
  
  /* The READ statement.  */
  
  extern void st_read (st_parameter_dt *);
  export_proto(st_read);
  
  void
  st_read (st_parameter_dt *dtp)
  {
    library_start (&dtp->common);
  
    data_transfer_init (dtp, 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 (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, ERROR_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, ERROR_ENDFILE, NULL);
  	dtp->u.p.current_unit->current_record = 0;
  	break;
        }
  }
  
  extern void st_read_done (st_parameter_dt *);
  export_proto(st_read_done);
  
  void
  st_read_done (st_parameter_dt *dtp)
  {
    finalize_transfer (dtp);
    free_format_data (dtp);
    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);
  
    free_internal_unit (dtp);
    
    library_end ();
  }
  
  extern void st_write (st_parameter_dt *);
  export_proto(st_write);
  
  void
  st_write (st_parameter_dt *dtp)
  {
    library_start (&dtp->common);
    data_transfer_init (dtp, 0);
  }
  
  extern void st_write_done (st_parameter_dt *);
  export_proto(st_write_done);
  
  void
  st_write_done (st_parameter_dt *dtp)
  {
    finalize_transfer (dtp);
  
    /* Deal with endfile conditions associated with sequential files.  */
  
    if (dtp->u.p.current_unit != NULL 
        && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
      switch (dtp->u.p.current_unit->endfile)
        {
        case AT_ENDFILE:		/* Remain at the endfile record.  */
  	break;
  
        case AFTER_ENDFILE:
  	dtp->u.p.current_unit->endfile = AT_ENDFILE;	/* Just at it now.  */
  	break;
  
        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, ERROR_OS, NULL);
  	  }
  	dtp->u.p.current_unit->endfile = AT_ENDFILE;
  	break;
        }
  
    free_format_data (dtp);
    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);
    
    free_internal_unit (dtp);
  
    library_end ();
  }
  
  /* Receives the scalar information for namelist objects and stores it
     in a linked list of namelist_info types.  */
  
  extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
  			    GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
  export_proto(st_set_nml_var);
  
  
  void
  st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
  		GFC_INTEGER_4 len, gfc_charlen_type string_length,
  		GFC_INTEGER_4 dtype)
  {
    namelist_info *t1 = NULL;
    namelist_info *nml;
  
    nml = (namelist_info*) get_mem (sizeof (namelist_info));
  
    nml->mem_pos = var_addr;
  
    nml->var_name = (char*) get_mem (strlen (var_name) + 1);
    strcpy (nml->var_name, var_name);
  
    nml->len = (int) len;
    nml->string_length = (index_type) string_length;
  
    nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
    nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
    nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
  
    if (nml->var_rank > 0)
      {
        nml->dim = (descriptor_dimension*)
  		   get_mem (nml->var_rank * sizeof (descriptor_dimension));
        nml->ls = (array_loop_spec*)
  		  get_mem (nml->var_rank * sizeof (array_loop_spec));
      }
    else
      {
        nml->dim = NULL;
        nml->ls = NULL;
      }
  
    nml->next = NULL;
  
    if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
      {
        dtp->common.flags |= IOPARM_DT_IONML_SET;
        dtp->u.p.ionml = nml;
      }
    else
      {
        for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
        t1->next = nml;
      }
  }
  
  /* Store the dimensional information for the namelist object.  */
  extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
  				GFC_INTEGER_4, GFC_INTEGER_4,
  				GFC_INTEGER_4);
  export_proto(st_set_nml_var_dim);
  
  void
  st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
  		    GFC_INTEGER_4 stride, GFC_INTEGER_4 lbound,
  		    GFC_INTEGER_4 ubound)
  {
    namelist_info * nml;
    int n;
  
    n = (int)n_dim;
  
    for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
  
    nml->dim[n].stride = (ssize_t)stride;
    nml->dim[n].lbound = (ssize_t)lbound;
    nml->dim[n].ubound = (ssize_t)ubound;
  }
  
  /* Reverse memcpy - used for byte swapping.  */
  
  void reverse_memcpy (void *dest, const void *src, size_t n)
  {
    char *d, *s;
    size_t i;
  
    d = (char *) dest;
    s = (char *) src + n - 1;
  
    /* Write with ascending order - this is likely faster
       on modern architectures because of write combining.  */
    for (i=0; i<n; i++)
        *(d++) = *(s--);
  }
  