primary.c

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

	    ("Real number at %C has a 'q' exponent and an explicit kind");
	  goto cleanup;
	}
      kind = gfc_option.q_kind;
      break;

    default:
      if (kind == -2)
	kind = gfc_default_real_kind;

      if (gfc_validate_kind (BT_REAL, kind, true) < 0)
	{
	  gfc_error ("Invalid real kind %d at %C", kind);
	  goto cleanup;
	}
    }

  e = gfc_convert_real (buffer, kind, &gfc_current_locus);
  if (negate)
    mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);

  switch (gfc_range_check (e))
    {
    case ARITH_OK:
      break;
    case ARITH_OVERFLOW:
      gfc_error ("Real constant overflows its kind at %C");
      goto cleanup;

    case ARITH_UNDERFLOW:
      if (gfc_option.warn_underflow)
        gfc_warning ("Real constant underflows its kind at %C");
      mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
      break;

    default:
      gfc_internal_error ("gfc_range_check() returned bad value");
    }

  *result = e;
  return MATCH_YES;

cleanup:
  gfc_free_expr (e);
  return MATCH_ERROR;
}


/* Match a substring reference.  */

static match
match_substring (gfc_charlen * cl, int init, gfc_ref ** result)
{
  gfc_expr *start, *end;
  locus old_loc;
  gfc_ref *ref;
  match m;

  start = NULL;
  end = NULL;

  old_loc = gfc_current_locus;

  m = gfc_match_char ('(');
  if (m != MATCH_YES)
    return MATCH_NO;

  if (gfc_match_char (':') != MATCH_YES)
    {
      if (init)
	m = gfc_match_init_expr (&start);
      else
	m = gfc_match_expr (&start);

      if (m != MATCH_YES)
	{
	  m = MATCH_NO;
	  goto cleanup;
	}

      m = gfc_match_char (':');
      if (m != MATCH_YES)
	goto cleanup;
    }

  if (gfc_match_char (')') != MATCH_YES)
    {
      if (init)
	m = gfc_match_init_expr (&end);
      else
	m = gfc_match_expr (&end);

      if (m == MATCH_NO)
	goto syntax;
      if (m == MATCH_ERROR)
	goto cleanup;

      m = gfc_match_char (')');
      if (m == MATCH_NO)
	goto syntax;
    }

  /* Optimize away the (:) reference.  */
  if (start == NULL && end == NULL)
    ref = NULL;
  else
    {
      ref = gfc_get_ref ();

      ref->type = REF_SUBSTRING;
      if (start == NULL)
	start = gfc_int_expr (1);
      ref->u.ss.start = start;
      if (end == NULL && cl)
	end = gfc_copy_expr (cl->length);
      ref->u.ss.end = end;
      ref->u.ss.length = cl;
    }

  *result = ref;
  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in SUBSTRING specification at %C");
  m = MATCH_ERROR;

cleanup:
  gfc_free_expr (start);
  gfc_free_expr (end);

  gfc_current_locus = old_loc;
  return m;
}


/* Reads the next character of a string constant, taking care to
   return doubled delimiters on the input as a single instance of
   the delimiter.

   Special return values are:
     -1   End of the string, as determined by the delimiter
     -2   Unterminated string detected

   Backslash codes are also expanded at this time.  */

static int
next_string_char (char delimiter)
{
  locus old_locus;
  int c;

  c = gfc_next_char_literal (1);

  if (c == '\n')
    return -2;

  if (gfc_option.flag_backslash && c == '\\')
    {
      old_locus = gfc_current_locus;

      switch (gfc_next_char_literal (1))
	{
	case 'a':
	  c = '\a';
	  break;
	case 'b':
	  c = '\b';
	  break;
	case 't':
	  c = '\t';
	  break;
	case 'f':
	  c = '\f';
	  break;
	case 'n':
	  c = '\n';
	  break;
	case 'r':
	  c = '\r';
	  break;
	case 'v':
	  c = '\v';
	  break;
	case '\\':
	  c = '\\';
	  break;

	default:
	  /* Unknown backslash codes are simply not expanded */
	  gfc_current_locus = old_locus;
	  break;
	}
    }

  if (c != delimiter)
    return c;

  old_locus = gfc_current_locus;
  c = gfc_next_char_literal (1);

  if (c == delimiter)
    return c;
  gfc_current_locus = old_locus;

  return -1;
}


/* Special case of gfc_match_name() that matches a parameter kind name
   before a string constant.  This takes case of the weird but legal
   case of:

     kind_____'string'

   where kind____ is a parameter. gfc_match_name() will happily slurp
   up all the underscores, which leads to problems.  If we return
   MATCH_YES, the parse pointer points to the final underscore, which
   is not part of the name.  We never return MATCH_ERROR-- errors in
   the name will be detected later.  */

static match
match_charkind_name (char *name)
{
  locus old_loc;
  char c, peek;
  int len;

  gfc_gobble_whitespace ();
  c = gfc_next_char ();
  if (!ISALPHA (c))
    return MATCH_NO;

  *name++ = c;
  len = 1;

  for (;;)
    {
      old_loc = gfc_current_locus;
      c = gfc_next_char ();

      if (c == '_')
	{
	  peek = gfc_peek_char ();

	  if (peek == '\'' || peek == '\"')
	    {
	      gfc_current_locus = old_loc;
	      *name = '\0';
	      return MATCH_YES;
	    }
	}

      if (!ISALNUM (c)
	  && c != '_'
	  && (gfc_option.flag_dollar_ok && c != '$'))
	break;

      *name++ = c;
      if (++len > GFC_MAX_SYMBOL_LEN)
	break;
    }

  return MATCH_NO;
}


/* See if the current input matches a character constant.  Lots of
   contortions have to be done to match the kind parameter which comes
   before the actual string.  The main consideration is that we don't
   want to error out too quickly.  For example, we don't actually do
   any validation of the kinds until we have actually seen a legal
   delimiter.  Using match_kind_param() generates errors too quickly.  */

static match
match_string_constant (gfc_expr ** result)
{
  char *p, name[GFC_MAX_SYMBOL_LEN + 1];
  int i, c, kind, length, delimiter;
  locus old_locus, start_locus;
  gfc_symbol *sym;
  gfc_expr *e;
  const char *q;
  match m;

  old_locus = gfc_current_locus;

  gfc_gobble_whitespace ();

  start_locus = gfc_current_locus;

  c = gfc_next_char ();
  if (c == '\'' || c == '"')
    {
      kind = gfc_default_character_kind;
      goto got_delim;
    }

  if (ISDIGIT (c))
    {
      kind = 0;

      while (ISDIGIT (c))
	{
	  kind = kind * 10 + c - '0';
	  if (kind > 9999999)
	    goto no_match;
	  c = gfc_next_char ();
	}

    }
  else
    {
      gfc_current_locus = old_locus;

      m = match_charkind_name (name);
      if (m != MATCH_YES)
	goto no_match;

      if (gfc_find_symbol (name, NULL, 1, &sym)
	  || sym == NULL
	  || sym->attr.flavor != FL_PARAMETER)
	goto no_match;

      kind = -1;
      c = gfc_next_char ();
    }

  if (c == ' ')
    {
      gfc_gobble_whitespace ();
      c = gfc_next_char ();
    }

  if (c != '_')
    goto no_match;

  gfc_gobble_whitespace ();
  start_locus = gfc_current_locus;

  c = gfc_next_char ();
  if (c != '\'' && c != '"')
    goto no_match;

  if (kind == -1)
    {
      q = gfc_extract_int (sym->value, &kind);
      if (q != NULL)
	{
	  gfc_error (q);
	  return MATCH_ERROR;
	}
    }

  if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
    {
      gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
      return MATCH_ERROR;
    }

got_delim:
  /* Scan the string into a block of memory by first figuring out how
     long it is, allocating the structure, then re-reading it.  This
     isn't particularly efficient, but string constants aren't that
     common in most code.  TODO: Use obstacks?  */

  delimiter = c;
  length = 0;

  for (;;)
    {
      c = next_string_char (delimiter);
      if (c == -1)
	break;
      if (c == -2)
	{
	  gfc_current_locus = start_locus;
	  gfc_error ("Unterminated character constant beginning at %C");
	  return MATCH_ERROR;
	}

      length++;
    }

  /* Peek at the next character to see if it is a b, o, z, or x for the
     postfixed BOZ literal constants.  */
  c = gfc_peek_char ();
  if (c == 'b' || c == 'o' || c =='z' || c == 'x')
    goto no_match;


  e = gfc_get_expr ();

  e->expr_type = EXPR_CONSTANT;
  e->ref = NULL;
  e->ts.type = BT_CHARACTER;
  e->ts.kind = kind;
  e->where = start_locus;

  e->value.character.string = p = gfc_getmem (length + 1);
  e->value.character.length = length;

  gfc_current_locus = start_locus;
  gfc_next_char ();		/* Skip delimiter */

  for (i = 0; i < length; i++)
    *p++ = next_string_char (delimiter);

  *p = '\0';	/* TODO: C-style string is for development/debug purposes.  */

  if (next_string_char (delimiter) != -1)
    gfc_internal_error ("match_string_constant(): Delimiter not found");

  if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
    e->expr_type = EXPR_SUBSTRING;

  *result = e;

  return MATCH_YES;

no_match:
  gfc_current_locus = old_locus;
  return MATCH_NO;
}


/* Match a .true. or .false.  */

static match
match_logical_constant (gfc_expr ** result)
{
  static mstring logical_ops[] = {
    minit (".false.", 0),
    minit (".true.", 1),
    minit (NULL, -1)
  };

  gfc_expr *e;
  int i, kind;

  i = gfc_match_strings (logical_ops);
  if (i == -1)
    return MATCH_NO;

  kind = get_kind ();
  if (kind == -1)
    return MATCH_ERROR;
  if (kind == -2)
    kind = gfc_default_logical_kind;

  if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
    gfc_error ("Bad kind for logical constant at %C");

  e = gfc_get_expr ();

  e->expr_type = EXPR_CONSTANT;
  e->value.logical = i;
  e->ts.type = BT_LOGICAL;
  e->ts.kind = kind;
  e->where = gfc_current_locus;

  *result = e;
  return MATCH_YES;
}


/* Match a real or imaginary part of a complex constant that is a
   symbolic constant.  */

static match
match_sym_complex_part (gfc_expr ** result)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_symbol *sym;
  gfc_expr *e;
  match m;

  m = gfc_match_name (name);
  if (m != MATCH_YES)
    return m;

  if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
    return MATCH_NO;

  if (sym->attr.flavor != FL_PARAMETER)
    {
      gfc_error ("Expected PARAMETER symbol in complex constant at %C");
      return MATCH_ERROR;
    }

  if (!gfc_numeric_ts (&sym->value->ts))
    {
      gfc_error ("Numeric PARAMETER required in complex constant at %C");
      return MATCH_ERROR;
    }

  if (sym->value->rank != 0)
    {
      gfc_error ("Scalar PARAMETER required in complex constant at %C");
      return MATCH_ERROR;
    }

  switch (sym->value->ts.type)
    {
    case BT_REAL:
      e = gfc_copy_expr (sym->value);
      break;

    case BT_COMPLEX:
      e = gfc_complex2real (sym->value, sym->value->ts.kind);
      if (e == NULL)
	goto error;
      break;

    case BT_INTEGER:
      e = gfc_int2real (sym->value, gfc_default_real_kind);
      if (e == NULL)
	goto error;
      break;

    default:
      gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
    }

  *result = e;			/* e is a scalar, real, constant expression */
  return MATCH_YES;

error:
  gfc_error ("Error converting PARAMETER constant in complex constant at %C");
  return MATCH_ERROR;
}


/* Match a real or imaginary part of a complex number.  */

static match
match_complex_part (gfc_expr ** result)
{
  match m;

  m = match_sym_complex_part (result);
  if (m != MATCH_NO)
    return m;

  m = match_real_constant (result, 1);
  if (m != MATCH_NO)
    return m;

  return match_integer_constant (result, 1);
}


/* Try to match a complex constant.  */

static match
match_complex_constant (gfc_expr ** result)
{
  gfc_expr *e, *real, *imag;
  gfc_error_buf old_error;
  gfc_typespec target;
  locus old_loc;
  int kind;
  match m;

  old_loc = gfc_current_locus;
  real = imag = e = NULL;

  m = gfc_match_char ('(');
  if (m != MATCH_YES)
    return m;

  gfc_push_error (&old_error);

  m = match_complex_part (&real);
  if (m == MATCH_NO)
    {
      gfc_free_error (&old_error);
      goto cleanup;
    }

  if (gfc_match_char (',') == MATCH_NO)
    {
      gfc_pop_error (&old_error);
      m = MATCH_NO;
      goto cleanup;
    }

  /* If m is error, then something was wrong with the real part and we