transfer.c

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

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

inline static int
write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
{
  size_t len = sizeof (gfc_offset);
  /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here.  */
  if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
    return swrite (dtp->u.p.current_unit->s, &buf, &len);
  else {
    gfc_offset p;
    reverse_memcpy (&p, &buf, sizeof (gfc_offset));
    return swrite (dtp->u.p.current_unit->s, &p, &len);
  }
}


/* Position to the next record in write mode.  */

static void
next_record_w (st_parameter_dt *dtp, int done)
{
  gfc_offset c, 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))
    {
    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:
      /* Bytes written.  */
      m = dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left;
      c = file_position (dtp->u.p.current_unit->s);

      /* Write the length tail.  */

      if (write_us_marker (dtp, m) != 0)
	goto io_error;

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

      if (sseek (dtp->u.p.current_unit->s, c - m - sizeof (gfc_offset))
		 == FAILURE)
	goto io_error;

      if (write_us_marker (dtp, m) != 0)
	goto io_error;

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

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

      break;

    case FORMATTED_SEQUENTIAL:

      if (dtp->u.p.current_unit->bytes_left == 0)
	break;
	
      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);

	      /* 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;
	}

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

  /* 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->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);
  else
    {
      dtp->u.p.current_unit->current_record = 0;
      if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
	{
	  /* Most systems buffer lines, so force the partial record
	     to be written out.  */
	  flush (dtp->u.p.current_unit->s);
	  dtp->u.p.seen_dollar = 0;
	  return;
	}

      next_record (dtp, 1);
    }

  sfree (dtp->u.p.current_unit->s);

  if (is_internal_unit (dtp))
    {
      if (is_array_io (dtp) && dtp->u.p.current_unit->ls != NULL)
	free_mem (dtp->u.p.current_unit->ls);
      sclose (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)
{
  flush(dtp->u.p.current_unit->s);
  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);
  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:
	if (dtp->u.p.current_unit->current_record > dtp->u.p.current_unit->last_record)
	  {
	    /* Get rid of whatever is after this record.  */
	    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);
  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--);
}