format.c

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

      tail->repeat = 1;
      goto between_desc;

    case FMT_COLON:
      get_fnode (fmt, &head, &tail, FMT_COLON);
      tail->repeat = 1;
      goto optional_comma;

    case FMT_SLASH:
      get_fnode (fmt, &head, &tail, FMT_SLASH);
      tail->repeat = 1;
      tail->u.r = 1;
      goto optional_comma;

    case FMT_DOLLAR:
      get_fnode (fmt, &head, &tail, FMT_DOLLAR);
      tail->repeat = 1;
      notify_std (GFC_STD_GNU, "Extension: $ descriptor");
      goto between_desc;

    case FMT_T:
    case FMT_TL:
    case FMT_TR:
      t2 = format_lex (fmt);
      if (t2 != FMT_POSINT)
	{
	  fmt->error = posint_required;
	  goto finished;
	}
      get_fnode (fmt, &head, &tail, t);
      tail->u.n = fmt->value;
      tail->repeat = 1;
      goto between_desc;

    case FMT_I:
    case FMT_B:
    case FMT_O:
    case FMT_Z:
    case FMT_E:
    case FMT_EN:
    case FMT_ES:
    case FMT_D:
    case FMT_L:
    case FMT_A:
    case FMT_F:
    case FMT_G:
      repeat = 1;
      goto data_desc;

    case FMT_H:
      get_fnode (fmt, &head, &tail, FMT_STRING);

      if (fmt->format_string_len < 1)
	{
	  fmt->error = bad_hollerith;
	  goto finished;
	}

      tail->u.string.p = fmt->format_string;
      tail->u.string.length = 1;
      tail->repeat = 1;

      fmt->format_string++;
      fmt->format_string_len--;

      goto between_desc;

    case FMT_END:
      fmt->error = unexpected_end;
      goto finished;

    case FMT_BADSTRING:
      goto finished;

    case FMT_RPAREN:
      goto finished;

    default:
      fmt->error = unexpected_element;
      goto finished;
    }

  /* In this state, t must currently be a data descriptor.  Deal with
     things that can/must follow the descriptor */
 data_desc:
  switch (t)
    {
    case FMT_P:
      t = format_lex (fmt);
      if (t == FMT_POSINT)
	{
	  fmt->error = "Repeat count cannot follow P descriptor";
	  goto finished;
	}

      fmt->saved_token = t;
      get_fnode (fmt, &head, &tail, FMT_P);

      goto optional_comma;

    case FMT_L:
      t = format_lex (fmt);
      if (t != FMT_POSINT)
	{
	  fmt->error = posint_required;
	  goto finished;
	}

      get_fnode (fmt, &head, &tail, FMT_L);
      tail->u.n = fmt->value;
      tail->repeat = repeat;
      break;

    case FMT_A:
      t = format_lex (fmt);
      if (t != FMT_POSINT)
	{
	  fmt->saved_token = t;
	  fmt->value = -1;		/* Width not present */
	}

      get_fnode (fmt, &head, &tail, FMT_A);
      tail->repeat = repeat;
      tail->u.n = fmt->value;
      break;

    case FMT_D:
    case FMT_E:
    case FMT_F:
    case FMT_G:
    case FMT_EN:
    case FMT_ES:
      get_fnode (fmt, &head, &tail, t);
      tail->repeat = repeat;

      u = format_lex (fmt);
      if (t == FMT_F || dtp->u.p.mode == WRITING)
	{
	  if (u != FMT_POSINT && u != FMT_ZERO)
	    {
	      fmt->error = nonneg_required;
	      goto finished;
	    }
	}
      else
	{
	  if (u != FMT_POSINT)
	    {
	      fmt->error = posint_required;
	      goto finished;
	    }
	}

      tail->u.real.w = fmt->value;
      t2 = t;
      t = format_lex (fmt);
      if (t != FMT_PERIOD)
	{
	  fmt->error = period_required;
	  goto finished;
	}

      t = format_lex (fmt);
      if (t != FMT_ZERO && t != FMT_POSINT)
	{
	  fmt->error = nonneg_required;
	  goto finished;
	}

      tail->u.real.d = fmt->value;

      if (t == FMT_D || t == FMT_F)
	break;

      tail->u.real.e = -1;

      /* Look for optional exponent */
      t = format_lex (fmt);
      if (t != FMT_E)
	fmt->saved_token = t;
      else
	{
	  t = format_lex (fmt);
	  if (t != FMT_POSINT)
	    {
	      fmt->error = "Positive exponent width required in format";
	      goto finished;
	    }

	  tail->u.real.e = fmt->value;
	}

      break;

    case FMT_H:
      if (repeat > fmt->format_string_len)
	{
	  fmt->error = bad_hollerith;
	  goto finished;
	}

      get_fnode (fmt, &head, &tail, FMT_STRING);

      tail->u.string.p = fmt->format_string;
      tail->u.string.length = repeat;
      tail->repeat = 1;

      fmt->format_string += fmt->value;
      fmt->format_string_len -= repeat;

      break;

    case FMT_I:
    case FMT_B:
    case FMT_O:
    case FMT_Z:
      get_fnode (fmt, &head, &tail, t);
      tail->repeat = repeat;

      t = format_lex (fmt);

      if (dtp->u.p.mode == READING)
	{
	  if (t != FMT_POSINT)
	    {
	      fmt->error = posint_required;
	      goto finished;
	    }
	}
      else
	{
	  if (t != FMT_ZERO && t != FMT_POSINT)
	    {
	      fmt->error = nonneg_required;
	      goto finished;
	    }
	}

      tail->u.integer.w = fmt->value;
      tail->u.integer.m = -1;

      t = format_lex (fmt);
      if (t != FMT_PERIOD)
	{
	  fmt->saved_token = t;
	}
      else
	{
	  t = format_lex (fmt);
	  if (t != FMT_ZERO && t != FMT_POSINT)
	    {
	      fmt->error = nonneg_required;
	      goto finished;
	    }

	  tail->u.integer.m = fmt->value;
	}

      if (tail->u.integer.w != 0 && tail->u.integer.m > tail->u.integer.w)
	{
	  fmt->error = "Minimum digits exceeds field width";
	  goto finished;
	}

      break;

    default:
      fmt->error = unexpected_element;
      goto finished;
    }

  /* Between a descriptor and what comes next */
 between_desc:
  t = format_lex (fmt);
  switch (t)
    {
    case FMT_COMMA:
      goto format_item;

    case FMT_RPAREN:
      goto finished;

    case FMT_SLASH:
      get_fnode (fmt, &head, &tail, FMT_SLASH);
      tail->repeat = 1;

      /* Fall Through */

    case FMT_COLON:
      goto optional_comma;

    case FMT_END:
      fmt->error = unexpected_end;
      goto finished;

    default:
      /* Assume a missing comma, this is a GNU extension */
      goto format_item_1;
    }

  /* Optional comma is a weird between state where we've just finished
     reading a colon, slash or P descriptor. */
 optional_comma:
  t = format_lex (fmt);
  switch (t)
    {
    case FMT_COMMA:
      break;

    case FMT_RPAREN:
      goto finished;

    default:			/* Assume that we have another format item */
      fmt->saved_token = t;
      break;
    }

  goto format_item;

 finished:
  return head;
}


/* format_error()-- Generate an error message for a format statement.
 * If the node that gives the location of the error is NULL, the error
 * is assumed to happen at parse time, and the current location of the
 * parser is shown.
 *
 * We generate a message showing where the problem is.  We take extra
 * care to print only the relevant part of the format if it is longer
 * than a standard 80 column display. */

void
format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
{
  int width, i, j, offset;
  char *p, buffer[300];
  format_data *fmt = dtp->u.p.fmt;

  if (f != NULL)
    fmt->format_string = f->source;

  st_sprintf (buffer, "%s\n", message);

  j = fmt->format_string - dtp->format;

  offset = (j > 60) ? j - 40 : 0;

  j -= offset;
  width = dtp->format_len - offset;

  if (width > 80)
    width = 80;

  /* Show the format */

  p = strchr (buffer, '\0');

  memcpy (p, dtp->format + offset, width);

  p += width;
  *p++ = '\n';

  /* Show where the problem is */

  for (i = 1; i < j; i++)
    *p++ = ' ';

  *p++ = '^';
  *p = '\0';

  generate_error (&dtp->common, ERROR_FORMAT, buffer);
}


/* parse_format()-- Parse a format string.  */

void
parse_format (st_parameter_dt *dtp)
{
  format_data *fmt;

  dtp->u.p.fmt = fmt = get_mem (sizeof (format_data));
  fmt->format_string = dtp->format;
  fmt->format_string_len = dtp->format_len;

  fmt->string = NULL;
  fmt->saved_token = FMT_NONE;
  fmt->error = NULL;
  fmt->value = 0;

  /* Initialize variables used during traversal of the tree */

  fmt->reversion_ok = 0;
  fmt->saved_format = NULL;

  /* Allocate the first format node as the root of the tree */

  fmt->last = &fmt->array;
  fmt->last->next = NULL;
  fmt->avail = &fmt->array.array[0];

  memset (fmt->avail, 0, sizeof (*fmt->avail));
  fmt->avail->format = FMT_LPAREN;
  fmt->avail->repeat = 1;
  fmt->avail++;

  if (format_lex (fmt) == FMT_LPAREN)
    fmt->array.array[0].u.child = parse_format_list (dtp);
  else
    fmt->error = "Missing initial left parenthesis in format";

  if (fmt->error)
    format_error (dtp, NULL, fmt->error);
}


/* revert()-- Do reversion of the format.  Control reverts to the left
 * parenthesis that matches the rightmost right parenthesis.  From our
 * tree structure, we are looking for the rightmost parenthesis node
 * at the second level, the first level always being a single
 * parenthesis node.  If this node doesn't exit, we use the top
 * level. */

static void
revert (st_parameter_dt *dtp)
{
  fnode *f, *r;
  format_data *fmt = dtp->u.p.fmt;

  dtp->u.p.reversion_flag = 1;

  r = NULL;

  for (f = fmt->array.array[0].u.child; f; f = f->next)
    if (f->format == FMT_LPAREN)
      r = f;

  /* If r is NULL because no node was found, the whole tree will be used */

  fmt->array.array[0].current = r;
  fmt->array.array[0].count = 0;
}


/* next_format0()-- Get the next format node without worrying about
 * reversion.  Returns NULL when we hit the end of the list.
 * Parenthesis nodes are incremented after the list has been
 * exhausted, other nodes are incremented before they are returned. */

static const fnode *
next_format0 (fnode * f)
{
  const fnode *r;

  if (f == NULL)
    return NULL;

  if (f->format != FMT_LPAREN)
    {
      f->count++;
      if (f->count <= f->repeat)
	return f;

      f->count = 0;
      return NULL;
    }

  /* Deal with a parenthesis node */

  for (; f->count < f->repeat; f->count++)
    {
      if (f->current == NULL)
	f->current = f->u.child;

      for (; f->current != NULL; f->current = f->current->next)
	{
	  r = next_format0 (f->current);
	  if (r != NULL)
	    return r;
	}
    }

  f->count = 0;
  return NULL;
}


/* next_format()-- Return the next format node.  If the format list
 * ends up being exhausted, we do reversion.  Reversion is only
 * allowed if the we've seen a data descriptor since the
 * initialization or the last reversion.  We return NULL if the there
 * are no more data descriptors to return (which is an error
 * condition). */

const fnode *
next_format (st_parameter_dt *dtp)
{
  format_token t;
  const fnode *f;
  format_data *fmt = dtp->u.p.fmt;

  if (fmt->saved_format != NULL)
    {				/* Deal with a pushed-back format node */
      f = fmt->saved_format;
      fmt->saved_format = NULL;
      goto done;
    }

  f = next_format0 (&fmt->array.array[0]);
  if (f == NULL)
    {
      if (!fmt->reversion_ok)
	return NULL;

      fmt->reversion_ok = 0;
      revert (dtp);

      f = next_format0 (&fmt->array.array[0]);
      if (f == NULL)
	{
	  format_error (dtp, NULL, reversion_error);
	  return NULL;
	}

      /* Push the first reverted token and return a colon node in case
       * there are no more data items. */

      fmt->saved_format = f;
      return &colon_node;
    }

  /* If this is a data edit descriptor, then reversion has become OK. */
 done:
  t = f->format;

  if (!fmt->reversion_ok &&
      (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))
    fmt->reversion_ok = 1;
  return f;
}


/* unget_format()-- Push the given format back so that it will be
 * returned on the next call to next_format() without affecting
 * counts.  This is necessary when we've encountered a data
 * descriptor, but don't know what the data item is yet.  The format
 * node is pushed back, and we return control to the main program,
 * which calls the library back with the data item (or not). */

void
unget_format (st_parameter_dt *dtp, const fnode *f)
{
  dtp->u.p.fmt->saved_format = f;
}