list_read.c

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

	  p = write_block (dtp, 5);
#endif
	  if (!p)
	    goto query_return;
#ifdef HAVE_CRLF
	  memcpy (p, "&end\r\n", 6);
#else
	  memcpy (p, "&end\n", 5);
#endif
	}

      /* Flush the stream to force immediate output.  */

      flush (dtp->u.p.current_unit->s);
      unlock_unit (dtp->u.p.current_unit);
    }

query_return:

  /* Restore the current unit.  */

  dtp->u.p.current_unit = temp_unit;
  dtp->u.p.mode = READING;
  return;
}

/* Reads and stores the input for the namelist object nl.  For an array,
   the function loops over the ranges defined by the loop specification.
   This default to all the data or to the specification from a qualifier.
   nml_read_obj recursively calls itself to read derived types. It visits
   all its own components but only reads data for those that were touched
   when the name was parsed.  If a read error is encountered, an attempt is
   made to return to read a new object name because the standard allows too
   little data to be available.  On the other hand, too much data is an
   error.  */

static try
nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
	      namelist_info **pprev_nl, char *nml_err_msg,
	      index_type clow, index_type chigh)
{

  namelist_info * cmp;
  char * obj_name;
  int nml_carry;
  int len;
  int dim;
  index_type dlen;
  index_type m;
  index_type obj_name_len;
  void * pdata ;

  /* This object not touched in name parsing.  */

  if (!nl->touched)
    return SUCCESS;

  dtp->u.p.repeat_count = 0;
  eat_spaces (dtp);

  len = nl->len;
  switch (nl->type)
  {

    case GFC_DTYPE_INTEGER:
    case GFC_DTYPE_LOGICAL:
      dlen = len;
      break;

    case GFC_DTYPE_REAL:
      dlen = size_from_real_kind (len);
      break;

    case GFC_DTYPE_COMPLEX:
      dlen = size_from_complex_kind (len);
      break;

    case GFC_DTYPE_CHARACTER:
      dlen = chigh ? (chigh - clow + 1) : nl->string_length;
      break;

    default:
      dlen = 0;
    }

  do
    {

      /* Update the pointer to the data, using the current index vector  */

      pdata = (void*)(nl->mem_pos + offset);
      for (dim = 0; dim < nl->var_rank; dim++)
	pdata = (void*)(pdata + (nl->ls[dim].idx - nl->dim[dim].lbound) *
		 nl->dim[dim].stride * nl->size);

      /* Reset the error flag and try to read next value, if
	 dtp->u.p.repeat_count=0  */

      dtp->u.p.nml_read_error = 0;
      nml_carry = 0;
      if (--dtp->u.p.repeat_count <= 0)
	{
	  if (dtp->u.p.input_complete)
	    return SUCCESS;
	  if (dtp->u.p.at_eol)
	    finish_separator (dtp);
	  if (dtp->u.p.input_complete)
	    return SUCCESS;

	  /* GFC_TYPE_UNKNOWN through for nulls and is detected
	     after the switch block.  */

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

          switch (nl->type)
	  {
	  case GFC_DTYPE_INTEGER:
	      read_integer (dtp, len);
              break;

	  case GFC_DTYPE_LOGICAL:
	      read_logical (dtp, len);
              break;

	  case GFC_DTYPE_CHARACTER:
	      read_character (dtp, len);
              break;

	  case GFC_DTYPE_REAL:
	      read_real (dtp, len);
              break;

	  case GFC_DTYPE_COMPLEX:
              read_complex (dtp, len, dlen);
              break;

	  case GFC_DTYPE_DERIVED:
	    obj_name_len = strlen (nl->var_name) + 1;
	    obj_name = get_mem (obj_name_len+1);
	    strcpy (obj_name, nl->var_name);
	    strcat (obj_name, "%");

	    /* Now loop over the components. Update the component pointer
	       with the return value from nml_write_obj.  This loop jumps
	       past nested derived types by testing if the potential
	       component name contains '%'.  */

	    for (cmp = nl->next;
		 cmp &&
		   !strncmp (cmp->var_name, obj_name, obj_name_len) &&
		   !strchr (cmp->var_name + obj_name_len, '%');
		 cmp = cmp->next)
	      {

		if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
				  pprev_nl, nml_err_msg, clow, chigh)
		    == FAILURE)
		  {
		    free_mem (obj_name);
		    return FAILURE;
		  }

		if (dtp->u.p.input_complete)
		  {
		    free_mem (obj_name);
		    return SUCCESS;
		  }
	      }

	    free_mem (obj_name);
	    goto incr_idx;

          default:
	    st_sprintf (nml_err_msg, "Bad type for namelist object %s",
			nl->var_name);
	    internal_error (&dtp->common, nml_err_msg);
	    goto nml_err_ret;
          }
        }

      /* The standard permits array data to stop short of the number of
	 elements specified in the loop specification.  In this case, we
	 should be here with dtp->u.p.nml_read_error != 0.  Control returns to
	 nml_get_obj_data and an attempt is made to read object name.  */

      *pprev_nl = nl;
      if (dtp->u.p.nml_read_error)
	return SUCCESS;

      if (dtp->u.p.saved_type == GFC_DTYPE_UNKNOWN)
	goto incr_idx;


      /* Note the switch from GFC_DTYPE_type to BT_type at this point.
	 This comes about because the read functions return BT_types.  */

      switch (dtp->u.p.saved_type)
      {

	case BT_COMPLEX:
	case BT_REAL:
	case BT_INTEGER:
	case BT_LOGICAL:
	  memcpy (pdata, dtp->u.p.value, dlen);
	  break;

	case BT_CHARACTER:
	  m = (dlen < dtp->u.p.saved_used) ? dlen : dtp->u.p.saved_used;
	  pdata = (void*)( pdata + clow - 1 );
	  memcpy (pdata, dtp->u.p.saved_string, m);
	  if (m < dlen)
	    memset ((void*)( pdata + m ), ' ', dlen - m);
	break;

	default:
	  break;
      }

      /* Break out of loop if scalar.  */

      if (!nl->var_rank)
	break;

      /* Now increment the index vector.  */

incr_idx:

      nml_carry = 1;
      for (dim = 0; dim < nl->var_rank; dim++)
	{
	  nl->ls[dim].idx += nml_carry * nl->ls[dim].step;
	  nml_carry = 0;
	  if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end))
	      ||
	      ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end)))
	    {
	      nl->ls[dim].idx = nl->ls[dim].start;
	      nml_carry = 1;
	    }
        }
    } while (!nml_carry);

  if (dtp->u.p.repeat_count > 1)
    {
       st_sprintf (nml_err_msg, "Repeat count too large for namelist object %s" ,
		   nl->var_name );
       goto nml_err_ret;
    }
  return SUCCESS;

nml_err_ret:

  return FAILURE;
}

/* Parses the object name, including array and substring qualifiers.  It
   iterates over derived type components, touching those components and
   setting their loop specifications, if there is a qualifier.  If the
   object is itself a derived type, its components and subcomponents are
   touched.  nml_read_obj is called at the end and this reads the data in
   the manner specified by the object name.  */

static try
nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
		  char *nml_err_msg)
{
  char c;
  namelist_info * nl;
  namelist_info * first_nl = NULL;
  namelist_info * root_nl = NULL;
  int dim;
  int component_flag;
  char parse_err_msg[30];
  index_type clow, chigh;

  /* Look for end of input or object name.  If '?' or '=?' are encountered
     in stdin, print the node names or the namelist to stdout.  */

  eat_separator (dtp);
  if (dtp->u.p.input_complete)
    return SUCCESS;

  if (dtp->u.p.at_eol)
    finish_separator (dtp);
  if (dtp->u.p.input_complete)
    return SUCCESS;

  c = next_char (dtp);
  switch (c)
    {
    case '=':
      c = next_char (dtp);
      if (c != '?')
	{
	  st_sprintf (nml_err_msg, "namelist read: missplaced = sign");
	  goto nml_err_ret;
	}
      nml_query (dtp, '=');
      return SUCCESS;

    case '?':
      nml_query (dtp, '?');
      return SUCCESS;

    case '$':
    case '&':
      nml_match_name (dtp, "end", 3);
      if (dtp->u.p.nml_read_error)
	{
	  st_sprintf (nml_err_msg, "namelist not terminated with / or &end");
	  goto nml_err_ret;
	}
    case '/':
      dtp->u.p.input_complete = 1;
      return SUCCESS;

    default :
      break;
    }

  /* Untouch all nodes of the namelist and reset the flag that is set for
     derived type components.  */

  nml_untouch_nodes (dtp);
  component_flag = 0;

  /* Get the object name - should '!' and '\n' be permitted separators?  */

get_name:

  free_saved (dtp);

  do
    {
      push_char (dtp, tolower(c));
      c = next_char (dtp);
    } while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));

  unget_char (dtp, c);

  /* Check that the name is in the namelist and get pointer to object.
     Three error conditions exist: (i) An attempt is being made to
     identify a non-existent object, following a failed data read or
     (ii) The object name does not exist or (iii) Too many data items
     are present for an object.  (iii) gives the same error message
     as (i)  */

  push_char (dtp, '\0');

  if (component_flag)
    {
      size_t var_len = strlen (root_nl->var_name);
      size_t saved_len
	= dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0;
      char ext_name[var_len + saved_len + 1];

      memcpy (ext_name, root_nl->var_name, var_len);
      if (dtp->u.p.saved_string)
	memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len);
      ext_name[var_len + saved_len] = '\0';
      nl = find_nml_node (dtp, ext_name);
    }
  else
    nl = find_nml_node (dtp, dtp->u.p.saved_string);

  if (nl == NULL)
    {
      if (dtp->u.p.nml_read_error && *pprev_nl)
	st_sprintf (nml_err_msg, "Bad data for namelist object %s",
		    (*pprev_nl)->var_name);

      else
	st_sprintf (nml_err_msg, "Cannot match namelist object name %s",
		    dtp->u.p.saved_string);

      goto nml_err_ret;
    }

  /* Get the length, data length, base pointer and rank of the variable.
     Set the default loop specification first.  */

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

/* Check to see if there is a qualifier: if so, parse it.*/

  if (c == '(' && nl->var_rank)
    {
      if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
			       parse_err_msg) == FAILURE)
	{
	  st_sprintf (nml_err_msg, "%s for namelist variable %s",
		      parse_err_msg, nl->var_name);
	  goto nml_err_ret;
	}
      c = next_char (dtp);
      unget_char (dtp, c);
    }

  /* Now parse a derived type component. The root namelist_info address
     is backed up, as is the previous component level.  The  component flag
     is set and the iteration is made by jumping back to get_name.  */

  if (c == '%')
    {

      if (nl->type != GFC_DTYPE_DERIVED)
	{
	  st_sprintf (nml_err_msg, "Attempt to get derived component for %s",
		      nl->var_name);
	  goto nml_err_ret;
	}

      if (!component_flag)
	first_nl = nl;

      root_nl = nl;
      component_flag = 1;
      c = next_char (dtp);
      goto get_name;

    }

  /* Parse a character qualifier, if present.  chigh = 0 is a default
     that signals that the string length = string_length.  */

  clow = 1;
  chigh = 0;

  if (c == '(' && nl->type == GFC_DTYPE_CHARACTER)
    {
      descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
      array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };

      if (nml_parse_qualifier (dtp, chd, ind, 1, parse_err_msg) == FAILURE)
	{
	  st_sprintf (nml_err_msg, "%s for namelist variable %s",
		      parse_err_msg, nl->var_name);
	  goto nml_err_ret;
	}

      clow = ind[0].start;
      chigh = ind[0].end;

      if (ind[0].step != 1)
	{
	  st_sprintf (nml_err_msg,
		      "Bad step in substring for namelist object %s",
		      nl->var_name);
	  goto nml_err_ret;
	}

      c = next_char (dtp);
      unget_char (dtp, c);
    }

  /* If a derived type touch its components and restore the root
     namelist_info if we have parsed a qualified derived type
     component.  */

  if (nl->type == GFC_DTYPE_DERIVED)
    nml_touch_nodes (nl);
  if (component_flag)
    nl = first_nl;

  /*make sure no extraneous qualifiers are there.*/

  if (c == '(')
    {
      st_sprintf (nml_err_msg, "Qualifier for a scalar or non-character"
		  " namelist object %s", nl->var_name);
      goto nml_err_ret;
    }

/* According to the standard, an equal sign MUST follow an object name. The
   following is possibly lax - it allows comments, blank lines and so on to
   intervene.  eat_spaces (dtp); c = next_char (dtp); would be compliant*/

  free_saved (dtp);

  eat_separator (dtp);
  if (dtp->u.p.input_complete)
    return SUCCESS;

  if (dtp->u.p.at_eol)
    finish_separator (dtp);
  if (dtp->u.p.input_complete)
    return SUCCESS;

  c = next_char (dtp);

  if (c != '=')
    {
      st_sprintf (nml_err_msg, "Equal sign must follow namelist object name %s",
		  nl->var_name);
      goto nml_err_ret;
    }

  if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, clow, chigh) == FAILURE)
    goto nml_err_ret;

  return SUCCESS;

nml_err_ret:

  return FAILURE;
}

/* Entry point for namelist input.  Goes through input until namelist name
  is matched.  Then cycles through nml_get_obj_data until the input is
  completed or there is an error.  */

void
namelist_read (st_parameter_dt *dtp)
{
  char c;
  jmp_buf eof_jump;
  char nml_err_msg[100];
  /* Pointer to the previously read object, in case attempt is made to read
     new object name.  Should this fail, error message can give previous
     name.  */
  namelist_info *prev_nl = NULL;

  dtp->u.p.namelist_mode = 1;
  dtp->u.p.input_complete = 0;

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

  /* Look for &namelist_name .  Skip all characters, testing for $nmlname.
     Exit on success or EOF. If '?' or '=?' encountered in stdin, print
     node names or namelist on stdout.  */

find_nml_name:
  switch (c = next_char (dtp))
    {
    case '$':
    case '&':
          break;

    case '=':
      c = next_char (dtp);
      if (c == '?')
	nml_query (dtp, '=');
      else
	unget_char (dtp, c);
      goto find_nml_name;

    case '?':
      nml_query (dtp, '?');

    default:
      goto find_nml_name;
    }

  /* Match the name of the namelist.  */

  nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);

  if (dtp->u.p.nml_read_error)
    goto find_nml_name;

  /* Ready to read namelist objects.  If there is an error in input
     from stdin, output the error message and continue.  */

  while (!dtp->u.p.input_complete)
    {
      if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg) == FAILURE)
	{
	  gfc_unit *u;

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

	  u = find_unit (options.stderr_unit);
	  st_printf ("%s\n", nml_err_msg);
	  if (u != NULL)
	    {
	      flush (u->s);
	      unlock_unit (u);
	    }
        }

   }

  dtp->u.p.eof_jump = NULL;
  free_saved (dtp);
  return;

  /* All namelist error calls return from here */

nml_err_ret:

  dtp->u.p.eof_jump = NULL;
  free_saved (dtp);
  generate_error (&dtp->common, ERROR_READ_VALUE, nml_err_msg);
  return;
}