decl.c

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

  if (gfc_current_form == FORM_FREE)
    {
      c = gfc_peek_char();
      if (!gfc_is_whitespace(c) && c != '*' && c != '('
         && c != ':' && c != ',')
       return MATCH_NO;
    }

  m = gfc_match_kind_spec (ts);
  if (m == MATCH_NO && ts->type != BT_CHARACTER)
    m = gfc_match_old_kind_spec (ts);

  if (m == MATCH_NO)
    m = MATCH_YES;		/* No kind specifier found.  */

  return m;
}


/* Match an IMPLICIT NONE statement.  Actually, this statement is
   already matched in parse.c, or we would not end up here in the
   first place.  So the only thing we need to check, is if there is
   trailing garbage.  If not, the match is successful.  */

match
gfc_match_implicit_none (void)
{

  return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
}


/* Match the letter range(s) of an IMPLICIT statement.  */

static match
match_implicit_range (void)
{
  int c, c1, c2, inner;
  locus cur_loc;

  cur_loc = gfc_current_locus;

  gfc_gobble_whitespace ();
  c = gfc_next_char ();
  if (c != '(')
    {
      gfc_error ("Missing character range in IMPLICIT at %C");
      goto bad;
    }

  inner = 1;
  while (inner)
    {
      gfc_gobble_whitespace ();
      c1 = gfc_next_char ();
      if (!ISALPHA (c1))
	goto bad;

      gfc_gobble_whitespace ();
      c = gfc_next_char ();

      switch (c)
	{
	case ')':
	  inner = 0;		/* Fall through */

	case ',':
	  c2 = c1;
	  break;

	case '-':
	  gfc_gobble_whitespace ();
	  c2 = gfc_next_char ();
	  if (!ISALPHA (c2))
	    goto bad;

	  gfc_gobble_whitespace ();
	  c = gfc_next_char ();

	  if ((c != ',') && (c != ')'))
	    goto bad;
	  if (c == ')')
	    inner = 0;

	  break;

	default:
	  goto bad;
	}

      if (c1 > c2)
	{
	  gfc_error ("Letters must be in alphabetic order in "
		     "IMPLICIT statement at %C");
	  goto bad;
	}

      /* See if we can add the newly matched range to the pending
         implicits from this IMPLICIT statement.  We do not check for
         conflicts with whatever earlier IMPLICIT statements may have
         set.  This is done when we've successfully finished matching
         the current one.  */
      if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
	goto bad;
    }

  return MATCH_YES;

bad:
  gfc_syntax_error (ST_IMPLICIT);

  gfc_current_locus = cur_loc;
  return MATCH_ERROR;
}


/* Match an IMPLICIT statement, storing the types for
   gfc_set_implicit() if the statement is accepted by the parser.
   There is a strange looking, but legal syntactic construction
   possible.  It looks like:

     IMPLICIT INTEGER (a-b) (c-d)

   This is legal if "a-b" is a constant expression that happens to
   equal one of the legal kinds for integers.  The real problem
   happens with an implicit specification that looks like:

     IMPLICIT INTEGER (a-b)

   In this case, a typespec matcher that is "greedy" (as most of the
   matchers are) gobbles the character range as a kindspec, leaving
   nothing left.  We therefore have to go a bit more slowly in the
   matching process by inhibiting the kindspec checking during
   typespec matching and checking for a kind later.  */

match
gfc_match_implicit (void)
{
  gfc_typespec ts;
  locus cur_loc;
  int c;
  match m;

  /* We don't allow empty implicit statements.  */
  if (gfc_match_eos () == MATCH_YES)
    {
      gfc_error ("Empty IMPLICIT statement at %C");
      return MATCH_ERROR;
    }

  do
    {
      /* First cleanup.  */
      gfc_clear_new_implicit ();

      /* A basic type is mandatory here.  */
      m = match_type_spec (&ts, 1);
      if (m == MATCH_ERROR)
	goto error;
      if (m == MATCH_NO)
	goto syntax;

      cur_loc = gfc_current_locus;
      m = match_implicit_range ();

      if (m == MATCH_YES)
	{
	  /* We may have <TYPE> (<RANGE>).  */
	  gfc_gobble_whitespace ();
	  c = gfc_next_char ();
	  if ((c == '\n') || (c == ','))
	    {
	      /* Check for CHARACTER with no length parameter.  */
	      if (ts.type == BT_CHARACTER && !ts.cl)
		{
		  ts.kind = gfc_default_character_kind;
		  ts.cl = gfc_get_charlen ();
		  ts.cl->next = gfc_current_ns->cl_list;
		  gfc_current_ns->cl_list = ts.cl;
		  ts.cl->length = gfc_int_expr (1);
		}

	      /* Record the Successful match.  */
	      if (gfc_merge_new_implicit (&ts) != SUCCESS)
		return MATCH_ERROR;
	      continue;
	    }

	  gfc_current_locus = cur_loc;
	}

      /* Discard the (incorrectly) matched range.  */
      gfc_clear_new_implicit ();

      /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>).  */
      if (ts.type == BT_CHARACTER)
	m = match_char_spec (&ts);
      else
	{
	  m = gfc_match_kind_spec (&ts);
	  if (m == MATCH_NO)
	    {
	      m = gfc_match_old_kind_spec (&ts);
	      if (m == MATCH_ERROR)
		goto error;
	      if (m == MATCH_NO)
		goto syntax;
	    }
	}
      if (m == MATCH_ERROR)
	goto error;

      m = match_implicit_range ();
      if (m == MATCH_ERROR)
	goto error;
      if (m == MATCH_NO)
	goto syntax;

      gfc_gobble_whitespace ();
      c = gfc_next_char ();
      if ((c != '\n') && (c != ','))
	goto syntax;

      if (gfc_merge_new_implicit (&ts) != SUCCESS)
	return MATCH_ERROR;
    }
  while (c == ',');

  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_IMPLICIT);

error:
  return MATCH_ERROR;
}


/* Matches an attribute specification including array specs.  If
   successful, leaves the variables current_attr and current_as
   holding the specification.  Also sets the colon_seen variable for
   later use by matchers associated with initializations.

   This subroutine is a little tricky in the sense that we don't know
   if we really have an attr-spec until we hit the double colon.
   Until that time, we can only return MATCH_NO.  This forces us to
   check for duplicate specification at this level.  */

static match
match_attr_spec (void)
{

  /* Modifiers that can exist in a type statement.  */
  typedef enum
  { GFC_DECL_BEGIN = 0,
    DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
    DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
    DECL_PARAMETER, DECL_POINTER, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE,
    DECL_TARGET, DECL_COLON, DECL_NONE,
    GFC_DECL_END /* Sentinel */
  }
  decl_types;

/* GFC_DECL_END is the sentinel, index starts at 0.  */
#define NUM_DECL GFC_DECL_END

  static mstring decls[] = {
    minit (", allocatable", DECL_ALLOCATABLE),
    minit (", dimension", DECL_DIMENSION),
    minit (", external", DECL_EXTERNAL),
    minit (", intent ( in )", DECL_IN),
    minit (", intent ( out )", DECL_OUT),
    minit (", intent ( in out )", DECL_INOUT),
    minit (", intrinsic", DECL_INTRINSIC),
    minit (", optional", DECL_OPTIONAL),
    minit (", parameter", DECL_PARAMETER),
    minit (", pointer", DECL_POINTER),
    minit (", private", DECL_PRIVATE),
    minit (", public", DECL_PUBLIC),
    minit (", save", DECL_SAVE),
    minit (", target", DECL_TARGET),
    minit ("::", DECL_COLON),
    minit (NULL, DECL_NONE)
  };

  locus start, seen_at[NUM_DECL];
  int seen[NUM_DECL];
  decl_types d;
  const char *attr;
  match m;
  try t;

  gfc_clear_attr (&current_attr);
  start = gfc_current_locus;

  current_as = NULL;
  colon_seen = 0;

  /* See if we get all of the keywords up to the final double colon.  */
  for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
    seen[d] = 0;

  for (;;)
    {
      d = (decl_types) gfc_match_strings (decls);
      if (d == DECL_NONE || d == DECL_COLON)
	break;
       
      if (gfc_current_state () == COMP_ENUM)
        {
          gfc_error ("Enumerator cannot have attributes %C");
          return MATCH_ERROR;
        }

      seen[d]++;
      seen_at[d] = gfc_current_locus;

      if (d == DECL_DIMENSION)
	{
	  m = gfc_match_array_spec (&current_as);

	  if (m == MATCH_NO)
	    {
	      gfc_error ("Missing dimension specification at %C");
	      m = MATCH_ERROR;
	    }

	  if (m == MATCH_ERROR)
	    goto cleanup;
	}
    }

  /* If we are parsing an enumeration and have ensured that no other
     attributes are present we can now set the parameter attribute.  */
  if (gfc_current_state () == COMP_ENUM)
    {
      t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, NULL);
      if (t == FAILURE)
        {
          m = MATCH_ERROR;
          goto cleanup;
        }
    }

  /* No double colon, so assume that we've been looking at something
     else the whole time.  */
  if (d == DECL_NONE)
    {
      m = MATCH_NO;
      goto cleanup;
    }

  /* Since we've seen a double colon, we have to be looking at an
     attr-spec.  This means that we can now issue errors.  */
  for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
    if (seen[d] > 1)
      {
	switch (d)
	  {
	  case DECL_ALLOCATABLE:
	    attr = "ALLOCATABLE";
	    break;
	  case DECL_DIMENSION:
	    attr = "DIMENSION";
	    break;
	  case DECL_EXTERNAL:
	    attr = "EXTERNAL";
	    break;
	  case DECL_IN:
	    attr = "INTENT (IN)";
	    break;
	  case DECL_OUT:
	    attr = "INTENT (OUT)";
	    break;
	  case DECL_INOUT:
	    attr = "INTENT (IN OUT)";
	    break;
	  case DECL_INTRINSIC:
	    attr = "INTRINSIC";
	    break;
	  case DECL_OPTIONAL:
	    attr = "OPTIONAL";
	    break;
	  case DECL_PARAMETER:
	    attr = "PARAMETER";
	    break;
	  case DECL_POINTER:
	    attr = "POINTER";
	    break;
	  case DECL_PRIVATE:
	    attr = "PRIVATE";
	    break;
	  case DECL_PUBLIC:
	    attr = "PUBLIC";
	    break;
	  case DECL_SAVE:
	    attr = "SAVE";
	    break;
	  case DECL_TARGET:
	    attr = "TARGET";
	    break;
	  default:
	    attr = NULL;	/* This shouldn't happen */
	  }

	gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
	m = MATCH_ERROR;
	goto cleanup;
      }

  /* Now that we've dealt with duplicate attributes, add the attributes
     to the current attribute.  */
  for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
    {
      if (seen[d] == 0)
	continue;

      if (gfc_current_state () == COMP_DERIVED
	  && d != DECL_DIMENSION && d != DECL_POINTER
	  && d != DECL_COLON && d != DECL_NONE)
	{

	  gfc_error ("Attribute at %L is not allowed in a TYPE definition",
		     &seen_at[d]);
	  m = MATCH_ERROR;
	  goto cleanup;
	}

      if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
	     && gfc_current_state () != COMP_MODULE)
	{
	  if (d == DECL_PRIVATE)
	    attr = "PRIVATE";
	  else
	    attr = "PUBLIC";

	  gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
		     attr, &seen_at[d]);
	  m = MATCH_ERROR;
	  goto cleanup;
	}

      switch (d)
	{
	case DECL_ALLOCATABLE:
	  t = gfc_add_allocatable (&current_attr, &seen_at[d]);
	  break;

	case DECL_DIMENSION:
	  t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
	  break;

	case DECL_EXTERNAL:
	  t = gfc_add_external (&current_attr, &seen_at[d]);
	  break;

	case DECL_IN:
	  t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
	  break;

	case DECL_OUT:
	  t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
	  break;

	case DECL_INOUT:
	  t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
	  break;

	case DECL_INTRINSIC:
	  t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
	  break;

	case DECL_OPTIONAL:
	  t = gfc_add_optional (&current_attr, &seen_at[d]);
	  break;

	case DECL_PARAMETER:
	  t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, &seen_at[d]);
	  break;

	case DECL_POINTER:
	  t = gfc_add_pointer (&current_attr, &seen_at[d]);
	  break;

	case DECL_PRIVATE:
	  t = gfc_add_access (&current_attr, ACCESS_PRIVATE, NULL,
			      &seen_at[d]);
	  break;

	case DECL_PUBLIC:
	  t = gfc_add_access (&current_attr, ACCESS_PUBLIC, NULL,
			      &seen_at[d]);
	  break;

	case DECL_SAVE:
	  t = gfc_add_save (&current_attr, NULL, &seen_at[d]);
	  break;

	case DECL_TARGET:
	  t = gfc_add_target (&current_attr, &seen_at[d]);
	  break;

	default:
	  gfc_internal_error ("match_attr_spec(): Bad attribute");
	}

      if (t == FAILURE)
	{
	  m = MATCH_ERROR;
	  goto cleanup;
	}
    }

  colon_seen = 1;
  return MATCH_YES;

cleanup:
  gfc_current_locus = start;
  gfc_free_array_spec (current_as);
  current_as = NULL;
  return m;
}


/* Match a data declaration statement.  */

match
gfc_match_data_decl (void)
{
  gfc_symbol *sym;
  match m;
  int elem;

  m = match_type_spec (&current_ts, 0);
  if (m != MATCH_YES)
    return m;

  if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
    {
      sym = gfc_use_derived (current_ts.derived);

      if (sym == NULL)
	{
	  m = MATCH_ERROR;
	  goto cleanup;
	}

      current_ts.derived = sym;
    }

  m = match_attr_spec ();
  if (m == MATCH_ERROR)
    {
      m = MATCH_NO;
      goto cleanup;
    }

  if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL)
    {

      if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
	goto ok;