transfer.c

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

   statement.  It would be natural to implement this as a coroutine
   with the user program, but C makes that awkward.  We loop,
   processesing format elements.  When we actually have to transfer
   data instead of just setting flags, we return control to the user
   program which calls a subroutine that supplies the address and type
   of the next element, then comes back here to process it.  */

static void
formatted_transfer_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)
	return;	      /* No data descriptors left (already raised).  */

      /* 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:
	  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 */
	    {
	      consume_data_flag = 0;
	      pos = f->u.n - 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;