list_read.c

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

    }

 exp1:
  push_char (dtp, 'e');

  c = next_char (dtp);
  if (c != '+' && c != '-')
    push_char (dtp, '+');
  else
    {
      push_char (dtp, c);
      c = next_char (dtp);
    }

 exp2:
  if (!isdigit (c))
    goto bad_real;
  push_char (dtp, c);

  for (;;)
    {
      c = next_char (dtp);

      switch (c)
	{
	CASE_DIGITS:
	  push_char (dtp, c);
	  break;

	CASE_SEPARATORS:
	  goto done;

	default:
	  goto bad_real;
	}
    }

 done:
  unget_char (dtp, c);
  eat_separator (dtp);
  push_char (dtp, '\0');
  if (convert_real (dtp, dtp->u.p.value, dtp->u.p.saved_string, length))
    return;

  free_saved (dtp);
  dtp->u.p.saved_type = BT_REAL;
  return;

 bad_real:

  if (nml_bad_return (dtp, c))
    return;

  st_sprintf (message, "Bad real number in item %d of list input",
	      dtp->u.p.item_count);

  generate_error (&dtp->common, ERROR_READ_VALUE, message);
}


/* Check the current type against the saved type to make sure they are
   compatible.  Returns nonzero if incompatible.  */

static int
check_type (st_parameter_dt *dtp, bt type, int len)
{
  char message[100];

  if (dtp->u.p.saved_type != BT_NULL && dtp->u.p.saved_type != type)
    {
      st_sprintf (message, "Read type %s where %s was expected for item %d",
		  type_name (dtp->u.p.saved_type), type_name (type),
		  dtp->u.p.item_count);

      generate_error (&dtp->common, ERROR_READ_VALUE, message);
      return 1;
    }

  if (dtp->u.p.saved_type == BT_NULL || dtp->u.p.saved_type == BT_CHARACTER)
    return 0;

  if (dtp->u.p.saved_length != len)
    {
      st_sprintf (message,
		  "Read kind %d %s where kind %d is required for item %d",
		  dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len,
		  dtp->u.p.item_count);
      generate_error (&dtp->common, ERROR_READ_VALUE, message);
      return 1;
    }

  return 0;
}


/* Top level data transfer subroutine for list reads.  Because we have
   to deal with repeat counts, the data item is always saved after
   reading, usually in the dtp->u.p.value[] array.  If a repeat count is
   greater than one, we copy the data item multiple times.  */

static void
list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
			    size_t size)
{
  char c;
  int m;
  jmp_buf eof_jump;

  dtp->u.p.namelist_mode = 0;

  dtp->u.p.eof_jump = &eof_jump;
  if (setjmp (eof_jump))
    {
      generate_error (&dtp->common, ERROR_END, NULL);
      goto cleanup;
    }

  if (dtp->u.p.first_item)
    {
      dtp->u.p.first_item = 0;
      dtp->u.p.input_complete = 0;
      dtp->u.p.repeat_count = 1;
      dtp->u.p.at_eol = 0;

      c = eat_spaces (dtp);
      if (is_separator (c))
	{			/* Found a null value.  */
	  eat_separator (dtp);
	  dtp->u.p.repeat_count = 0;

	  /* eat_separator sets this flag if the separator was a comma */
	  if (dtp->u.p.comma_flag)
	    goto cleanup;

	  /* eat_separator sets this flag if the separator was a \n or \r */
	  if (dtp->u.p.at_eol)
	    finish_separator (dtp);
	  else
	    goto cleanup;
	}

    }
  else
    {
      if (dtp->u.p.input_complete)
	goto cleanup;

      if (dtp->u.p.repeat_count > 0)
	{
	  if (check_type (dtp, type, kind))
	    return;
	  goto set_value;
	}

      if (dtp->u.p.at_eol)
	finish_separator (dtp);
      else
        {
	  eat_spaces (dtp);
          /* trailing spaces prior to end of line */
	  if (dtp->u.p.at_eol)
	    finish_separator (dtp);
        }

      dtp->u.p.saved_type = BT_NULL;
      dtp->u.p.repeat_count = 1;
    }

  switch (type)
    {
    case BT_INTEGER:
      read_integer (dtp, kind);
      break;
    case BT_LOGICAL:
      read_logical (dtp, kind);
      break;
    case BT_CHARACTER:
      read_character (dtp, kind);
      break;
    case BT_REAL:
      read_real (dtp, kind);
      break;
    case BT_COMPLEX:
      read_complex (dtp, kind, size);
      break;
    default:
      internal_error (&dtp->common, "Bad type for list read");
    }

  if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_NULL)
    dtp->u.p.saved_length = size;

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

 set_value:
  switch (dtp->u.p.saved_type)
    {
    case BT_COMPLEX:
    case BT_INTEGER:
    case BT_REAL:
    case BT_LOGICAL:
      memcpy (p, dtp->u.p.value, size);
      break;

    case BT_CHARACTER:
      if (dtp->u.p.saved_string)
       {
	  m = ((int) size < dtp->u.p.saved_used)
	      ? (int) size : dtp->u.p.saved_used;
	  memcpy (p, dtp->u.p.saved_string, m);
       }
      else
	/* Just delimiters encountered, nothing to copy but SPACE.  */
        m = 0;

      if (m < (int) size)
	memset (((char *) p) + m, ' ', size - m);
      break;

    case BT_NULL:
      break;
    }

  if (--dtp->u.p.repeat_count <= 0)
    free_saved (dtp);

cleanup:
  dtp->u.p.eof_jump = NULL;
}


void
list_formatted_read (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++;
      list_formatted_read_scalar (dtp, type, tmp + size*elem, kind, size);
    }
}


/* Finish a list read.  */

void
finish_list_read (st_parameter_dt *dtp)
{
  char c;

  free_saved (dtp);

  if (dtp->u.p.at_eol)
    {
      dtp->u.p.at_eol = 0;
      return;
    }

  do
    {
      c = next_char (dtp);
    }
  while (c != '\n');
}

/*			NAMELIST INPUT

void namelist_read (st_parameter_dt *dtp)
calls:
   static void nml_match_name (char *name, int len)
   static int nml_query (st_parameter_dt *dtp)
   static int nml_get_obj_data (st_parameter_dt *dtp,
				namelist_info **prev_nl, char *)
calls:
      static void nml_untouch_nodes (st_parameter_dt *dtp)
      static namelist_info * find_nml_node (st_parameter_dt *dtp,
					    char * var_name)
      static int nml_parse_qualifier(descriptor_dimension * ad,
				     array_loop_spec * ls, int rank, char *)
      static void nml_touch_nodes (namelist_info * nl)
      static int nml_read_obj (namelist_info *nl, index_type offset,
			       namelist_info **prev_nl, char *,
			       index_type clow, index_type chigh)
calls:
      -itself-  */

/* Inputs a rank-dimensional qualifier, which can contain
   singlets, doublets, triplets or ':' with the standard meanings.  */

static try
nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
		     array_loop_spec *ls, int rank, char *parse_err_msg)
{
  int dim;
  int indx;
  int neg;
  int null_flag;
  char c;

  /* The next character in the stream should be the '('.  */

  c = next_char (dtp);

  /* Process the qualifier, by dimension and triplet.  */

  for (dim=0; dim < rank; dim++ )
    {
      for (indx=0; indx<3; indx++)
	{
	  free_saved (dtp);
	  eat_spaces (dtp);
	  neg = 0;

	  /* Process a potential sign.  */
	  c = next_char (dtp);
	  switch (c)
	    {
	    case '-':
	      neg = 1;
	      break;

	    case '+':
	      break;

	    default:
	      unget_char (dtp, c);
	      break;
	    }

	  /* Process characters up to the next ':' , ',' or ')'.  */
	  for (;;)
	    {
	      c = next_char (dtp);

	      switch (c)
		{
		case ':':
		  break;

		case ',': case ')':
		  if ((c==',' && dim == rank -1)
		      || (c==')' && dim < rank -1))
		    {
		      st_sprintf (parse_err_msg,
				  "Bad number of index fields");
		      goto err_ret;
		    }
		  break;

		CASE_DIGITS:
		  push_char (dtp, c);
		  continue;

		case ' ': case '\t':
		  eat_spaces (dtp);
		  c = next_char (dtp);
		  break;

		default:
		  st_sprintf (parse_err_msg, "Bad character in index");
		  goto err_ret;
		}

	      if ((c == ',' || c == ')') && indx == 0
		  && dtp->u.p.saved_string == 0)
		{
		  st_sprintf (parse_err_msg, "Null index field");
		  goto err_ret;
		}

	      if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
		  || (indx == 2 && dtp->u.p.saved_string == 0))
		{
		  st_sprintf(parse_err_msg, "Bad index triplet");
		  goto err_ret;
		}

	      /* If '( : ? )' or '( ? : )' break and flag read failure.  */
	      null_flag = 0;
	      if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0)
		  || (indx==1 && dtp->u.p.saved_string == 0))
		{
		  null_flag = 1;
		  break;
		}

	      /* Now read the index.  */
	      if (convert_integer (dtp, sizeof(ssize_t), neg))
		{
		  st_sprintf (parse_err_msg, "Bad integer in index");
		  goto err_ret;
		}
	      break;
	    }

	  /* Feed the index values to the triplet arrays.  */
	  if (!null_flag)
	    {
	      if (indx == 0)
		memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
	      if (indx == 1)
		memcpy (&ls[dim].end, dtp->u.p.value, sizeof(ssize_t));
	      if (indx == 2)
		memcpy (&ls[dim].step, dtp->u.p.value, sizeof(ssize_t));
	    }

	  /* Singlet or doublet indices.  */
	  if (c==',' || c==')')
	    {
	      if (indx == 0)
		{
		  memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
		  ls[dim].end = ls[dim].start;
		}
	      break;
	    }
	}

      /* Check the values of the triplet indices.  */
      if ((ls[dim].start > (ssize_t)ad[dim].ubound)
	  || (ls[dim].start < (ssize_t)ad[dim].lbound)
	  || (ls[dim].end > (ssize_t)ad[dim].ubound)
	  || (ls[dim].end < (ssize_t)ad[dim].lbound))
	{
	  st_sprintf (parse_err_msg, "Index %d out of range", dim + 1);
	  goto err_ret;
	}
      if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
	  || (ls[dim].step == 0))
	{
	  st_sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
	  goto err_ret;
	}

      /* Initialise the loop index counter.  */
      ls[dim].idx = ls[dim].start;
    }
  eat_spaces (dtp);
  return SUCCESS;

err_ret:

  return FAILURE;
}

static namelist_info *
find_nml_node (st_parameter_dt *dtp, char * var_name)
{
  namelist_info * t = dtp->u.p.ionml;
  while (t != NULL)
    {
      if (strcmp (var_name, t->var_name) == 0)
	{
	  t->touched = 1;
	  return t;
	}
      t = t->next;
    }
  return NULL;
}

/* Visits all the components of a derived type that have
   not explicitly been identified in the namelist input.
   touched is set and the loop specification initialised
   to default values  */

static void
nml_touch_nodes (namelist_info * nl)
{
  index_type len = strlen (nl->var_name) + 1;
  int dim;
  char * ext_name = (char*)get_mem (len + 1);
  strcpy (ext_name, nl->var_name);
  strcat (ext_name, "%");
  for (nl = nl->next; nl; nl = nl->next)
    {
      if (strncmp (nl->var_name, ext_name, len) == 0)
	{
	  nl->touched = 1;
	  for (dim=0; dim < nl->var_rank; dim++)
	    {
	      nl->ls[dim].step = 1;
	      nl->ls[dim].end = nl->dim[dim].ubound;
	      nl->ls[dim].start = nl->dim[dim].lbound;
	      nl->ls[dim].idx = nl->ls[dim].start;
	    }
	}
      else
	break;
    }
  free_mem (ext_name);
  return;
}

/* Resets touched for the entire list of nml_nodes, ready for a
   new object.  */

static void
nml_untouch_nodes (st_parameter_dt *dtp)
{
  namelist_info * t;
  for (t = dtp->u.p.ionml; t; t = t->next)
    t->touched = 0;
  return;
}

/* Attempts to input name to namelist name.  Returns
   dtp->u.p.nml_read_error = 1 on no match.  */

static void
nml_match_name (st_parameter_dt *dtp, const char *name, index_type len)
{
  index_type i;
  char c;
  dtp->u.p.nml_read_error = 0;
  for (i = 0; i < len; i++)
    {
      c = next_char (dtp);
      if (tolower (c) != tolower (name[i]))
	{
	  dtp->u.p.nml_read_error = 1;
	  break;
	}
    }
}

/* If the namelist read is from stdin, output the current state of the
   namelist to stdout.  This is used to implement the non-standard query
   features, ? and =?. If c == '=' the full namelist is printed. Otherwise
   the names alone are printed.  */

static void
nml_query (st_parameter_dt *dtp, char c)
{
  gfc_unit * temp_unit;
  namelist_info * nl;
  index_type len;
  char * p;

  if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
    return;

  /* Store the current unit and transfer to stdout.  */

  temp_unit = dtp->u.p.current_unit;
  dtp->u.p.current_unit = find_unit (options.stdout_unit);

  if (dtp->u.p.current_unit)
    {
      dtp->u.p.mode = WRITING;
      next_record (dtp, 0);

      /* Write the namelist in its entirety.  */

      if (c == '=')
	namelist_write (dtp);

      /* Or write the list of names.  */

      else
	{

	  /* "&namelist_name\n"  */

	  len = dtp->namelist_name_len;
#ifdef HAVE_CRLF
	  p = write_block (dtp, len + 3);
#else
	  p = write_block (dtp, len + 2);
#endif
	  if (!p)
	    goto query_return;
	  memcpy (p, "&", 1);
	  memcpy ((char*)(p + 1), dtp->namelist_name, len);
#ifdef HAVE_CRLF
	  memcpy ((char*)(p + len + 1), "\r\n", 2);
#else
	  memcpy ((char*)(p + len + 1), "\n", 1);
#endif
	  for (nl = dtp->u.p.ionml; nl; nl = nl->next)
	    {

	      /* " var_name\n"  */

	      len = strlen (nl->var_name);
#ifdef HAVE_CRLF
	      p = write_block (dtp, len + 3);
#else
	      p = write_block (dtp, len + 2);
#endif
	      if (!p)
		goto query_return;
	      memcpy (p, " ", 1);
	      memcpy ((char*)(p + 1), nl->var_name, len);
#ifdef HAVE_CRLF
	      memcpy ((char*)(p + len + 1), "\r\n", 2);
#else
	      memcpy ((char*)(p + len + 1), "\n", 1);
#endif
	    }

	  /* "&end\n"  */

#ifdef HAVE_CRLF
	  p = write_block (dtp, 6);
#else