transfer.c

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

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

  if (desc->dim[0].stride == 0)
    desc->dim[0].stride = 1;

  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)
{
  char *p;
  int n;
  gfc_offset i;

  if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
    return;

  n = sizeof (gfc_offset);
  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 != sizeof (gfc_offset))
    {
      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)
    memcpy (&i, p, sizeof (gfc_offset));
  else
    reverse_memcpy (&i, p, sizeof (gfc_offset));
    
  dtp->u.p.current_unit->bytes_left = i;
}


/* 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)
{
  size_t nbytes;
  gfc_offset dummy;

  dummy = 0;
  nbytes = sizeof (gfc_offset);

  if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0)
    generate_error (&dtp->common, ERROR_OS, NULL);

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

  dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
}


/* 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 UNFORMATTED_SEQUENTIAL:
      if (dtp->u.p.mode == READING)
	us_read (dtp);
      else
	us_write (dtp);

      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->size = 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;
     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;
     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");

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

  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
    return;

  dtp->u.p.first_item = 1;

  /* Check the format.  */

  if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
    parse_format (dtp);

  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
    return;

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

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

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

      if (is_internal_unit (dtp))
	generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
			"ADVANCE specification conflicts with internal file");

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

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

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

    }
  else
    {				/* Write constraints.  */
      if ((cf & IOPARM_END) != 0)
	generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
			"END specification cannot appear in a write statement");

      if ((cf & IOPARM_EOR) != 0)
	generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
			"EOR specification cannot appear in a write statement");

      if ((cf & IOPARM_DT_HAS_SIZE) != 0)
	generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
			"SIZE specification cannot appear in a write statement");
    }

  if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
    dtp->u.p.advance_status = ADVANCE_YES;
  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
    return;

  /* 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)
	 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 (sseek (dtp->u.p.current_unit->s,
	       (dtp->rec - 1) * dtp->u.p.current_unit->recl) == FAILURE)
	{
	  generate_error (&dtp->common, ERROR_OS, NULL);
	  return;
	}
    }

  /* 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)
	{
	  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 = 1;
      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 - 1) * ls[i].step;
    }
  return index;
}

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

#define MAX_READ 4096

static void
next_record_r (st_parameter_dt *dtp)
{
  gfc_offset new, record;
  int bytes_left, rlength, length;
  char *p;

  switch (current_mode (dtp))
    {
    case UNFORMATTED_SEQUENTIAL:

      /* Skip over tail */
      dtp->u.p.current_unit->bytes_left += sizeof (gfc_offset);
      
      /* Fall through...  */

    case FORMATTED_DIRECT:
    case UNFORMATTED_DIRECT:
      if (dtp->u.p.current_unit->bytes_left == 0)
	break;

      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;

	  /* 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 > 0)
	    {
	      rlength = length = (MAX_READ > dtp->u.p.current_unit->bytes_left) ?
		MAX_READ : dtp->u.p.current_unit->bytes_left;

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

	      dtp->u.p.current_unit->bytes_left -= length;
	    }
	}
      break;

    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)