transfer.c

gcc-fortran,linux使用fortran的编译软件。很好用的。

/* 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 const st_option advance_opt[] = {
  {"yes", ADVANCE_YES},
  {"no", ADVANCE_NO},
  {NULL, 0}
};


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


static file_mode
current_mode (st_parameter_dt *dtp)
{
  file_mode m;

  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
    {
      m = dtp->u.p.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.  */

/* 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 (st_parameter_dt *dtp, int *length)
{
  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)
	{
	  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)
	    {
	      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 (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->size += *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 (dtp->u.p.current_unit->bytes_left < *length)
    {
      if (dtp->u.p.current_unit->flags.pad == PAD_NO)
	{
	  generate_error (&dtp->common, ERROR_EOR, NULL);
	  /* Not enough data left.  */
	  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)
    return read_sf (dtp, length);	/* Special case.  */

  dtp->u.p.current_unit->bytes_left -= *length;

  nread = *length;
  source = salloc_r (dtp->u.p.current_unit->s, &nread);

  if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
    *dtp->size += 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;
	}
    }

  return source;
}


/* Reads a block directly into application data space.  */

static void
read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
{
  int *length;
  void *data;
  size_t nread;

  if (dtp->u.p.current_unit->bytes_left < *nbytes)
    {
      if (dtp->u.p.current_unit->flags.pad == PAD_NO)
	{
	  /* Not enough data left.  */
	  generate_error (&dtp->common, ERROR_EOR, NULL);
	  return;
	}

      *nbytes = 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)
    {
      length = (int *) nbytes;
      data = read_sf (dtp, length);	/* Special case.  */
      memcpy (buf, data, (size_t) *length);
      return;
    }

  dtp->u.p.current_unit->bytes_left -= *nbytes;

  nread = *nbytes;
  if (sread (dtp->u.p.current_unit->s, buf, &nread) != 0)
    {
      generate_error (&dtp->common, ERROR_OS, NULL);
      return;
    }

  if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
    *dtp->size += (GFC_INTEGER_4) nread;

  if (nread != *nbytes)
    {				/* Short read, e.g. if we hit EOF.  */
      if (dtp->u.p.current_unit->flags.pad == PAD_YES)
	{
	  memset (((char *) buf) + nread, ' ', *nbytes - nread);
	  *nbytes = nread;
	}
      else
	generate_error (&dtp->common, ERROR_EOR, NULL);
    }
}


/* 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 (dtp->u.p.current_unit->bytes_left < length)
    {
      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 ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
    *dtp->size += length;

  return dest;
}


/* High level interface to swrite(), taking care of errors.  */

static try
write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
{
  if (dtp->u.p.current_unit->bytes_left < nbytes)
    {
      generate_error (&dtp->common, ERROR_EOR, NULL);
      return FAILURE;
    }

  dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;

  if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
    {
      generate_error (&dtp->common, ERROR_OS, NULL);
      return FAILURE;
    }

  if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
    {
      *dtp->size += (GFC_INTEGER_4) nbytes;
      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)
{
  /* Currently, character implies size=1.  */
  if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE
      || size == 1 || type == BT_CHARACTER)
    {
      size *= nelems;
      read_block_direct (dtp, dest, &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 = 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.  */
      
      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.  */

      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