parse.c

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

     SEQUENCE.  */
  if (error_flag == 0 && gfc_current_block ()->attr.sequence)
    for (c = gfc_current_block ()->components; c; c = c->next)
      {
	if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
	  {
	    gfc_error
	      ("Component %s of SEQUENCE type declared at %C does not "
	       "have the SEQUENCE attribute", c->ts.derived->name);
	  }
      }

  pop_state ();
}



/* Parse an ENUM.  */
 
static void
parse_enum (void)
{
  int error_flag;
  gfc_statement st;
  int compiling_enum;
  gfc_state_data s;
  int seen_enumerator = 0;

  error_flag = 0;

  push_state (&s, COMP_ENUM, gfc_new_block);

  compiling_enum = 1;

  while (compiling_enum)
    {
      st = next_statement ();
      switch (st)
        {
        case ST_NONE:
          unexpected_eof ();
          break;

        case ST_ENUMERATOR:
	  seen_enumerator = 1;
          accept_statement (st);
          break;

        case ST_END_ENUM:
          compiling_enum = 0;
	  if (!seen_enumerator)
            {
              gfc_error ("ENUM declaration at %C has no ENUMERATORS");
	      error_flag = 1;
            }
          accept_statement (st);
          break;

        default:
          gfc_free_enum_history ();
          unexpected_statement (st);
          break;
        }
    }
  pop_state ();
}

/* Parse an interface.  We must be able to deal with the possibility
   of recursive interfaces.  The parse_spec() subroutine is mutually
   recursive with parse_interface().  */

static gfc_statement parse_spec (gfc_statement);

static void
parse_interface (void)
{
  gfc_compile_state new_state, current_state;
  gfc_symbol *prog_unit, *sym;
  gfc_interface_info save;
  gfc_state_data s1, s2;
  gfc_statement st;

  accept_statement (ST_INTERFACE);

  current_interface.ns = gfc_current_ns;
  save = current_interface;

  sym = (current_interface.type == INTERFACE_GENERIC
	 || current_interface.type == INTERFACE_USER_OP) ? gfc_new_block : NULL;

  push_state (&s1, COMP_INTERFACE, sym);
  current_state = COMP_NONE;

loop:
  gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);

  st = next_statement ();
  switch (st)
    {
    case ST_NONE:
      unexpected_eof ();

    case ST_SUBROUTINE:
      new_state = COMP_SUBROUTINE;
      gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
				  gfc_new_block->formal, NULL);
      break;

    case ST_FUNCTION:
      new_state = COMP_FUNCTION;
      gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
				  gfc_new_block->formal, NULL);
      break;

    case ST_MODULE_PROC:	/* The module procedure matcher makes
				   sure the context is correct.  */
      accept_statement (st);
      gfc_free_namespace (gfc_current_ns);
      goto loop;

    case ST_END_INTERFACE:
      gfc_free_namespace (gfc_current_ns);
      gfc_current_ns = current_interface.ns;
      goto done;

    default:
      gfc_error ("Unexpected %s statement in INTERFACE block at %C",
		 gfc_ascii_statement (st));
      reject_statement ();
      gfc_free_namespace (gfc_current_ns);
      goto loop;
    }


  /* Make sure that a generic interface has only subroutines or
     functions and that the generic name has the right attribute.  */
  if (current_interface.type == INTERFACE_GENERIC)
    {
      if (current_state == COMP_NONE)
	{
	  if (new_state == COMP_FUNCTION)
	    gfc_add_function (&sym->attr, sym->name, NULL);
	  else if (new_state == COMP_SUBROUTINE)
	    gfc_add_subroutine (&sym->attr, sym->name, NULL);

	  current_state = new_state;
	}
      else
	{
	  if (new_state != current_state)
	    {
	      if (new_state == COMP_SUBROUTINE)
		gfc_error
		  ("SUBROUTINE at %C does not belong in a generic function "
		   "interface");

	      if (new_state == COMP_FUNCTION)
		gfc_error
		  ("FUNCTION at %C does not belong in a generic subroutine "
		   "interface");
	    }
	}
    }

  push_state (&s2, new_state, gfc_new_block);
  accept_statement (st);
  prog_unit = gfc_new_block;
  prog_unit->formal_ns = gfc_current_ns;

decl:
  /* Read data declaration statements.  */
  st = parse_spec (ST_NONE);

  if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
    {
      gfc_error ("Unexpected %s statement at %C in INTERFACE body",
		 gfc_ascii_statement (st));
      reject_statement ();
      goto decl;
    }

  current_interface = save;
  gfc_add_interface (prog_unit);

  pop_state ();
  goto loop;

done:
  pop_state ();
}


/* Parse a set of specification statements.  Returns the statement
   that doesn't fit.  */

static gfc_statement
parse_spec (gfc_statement st)
{
  st_state ss;

  verify_st_order (&ss, ST_NONE);
  if (st == ST_NONE)
    st = next_statement ();

loop:
  switch (st)
    {
    case ST_NONE:
      unexpected_eof ();

    case ST_FORMAT:
    case ST_ENTRY:
    case ST_DATA:	/* Not allowed in interfaces */
      if (gfc_current_state () == COMP_INTERFACE)
	break;

      /* Fall through */

    case ST_USE:
    case ST_IMPLICIT_NONE:
    case ST_IMPLICIT:
    case ST_PARAMETER:
    case ST_PUBLIC:
    case ST_PRIVATE:
    case ST_DERIVED_DECL:
    case_decl:
      if (verify_st_order (&ss, st) == FAILURE)
	{
	  reject_statement ();
	  st = next_statement ();
	  goto loop;
	}

      switch (st)
	{
	case ST_INTERFACE:
	  parse_interface ();
	  break;

	case ST_DERIVED_DECL:
	  parse_derived ();
	  break;

	case ST_PUBLIC:
	case ST_PRIVATE:
	  if (gfc_current_state () != COMP_MODULE)
	    {
	      gfc_error ("%s statement must appear in a MODULE",
			 gfc_ascii_statement (st));
	      break;
	    }

	  if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
	    {
	      gfc_error ("%s statement at %C follows another accessibility "
			 "specification", gfc_ascii_statement (st));
	      break;
	    }

	  gfc_current_ns->default_access = (st == ST_PUBLIC)
	    ? ACCESS_PUBLIC : ACCESS_PRIVATE;

	  break;

	default:
	  break;
	}

      accept_statement (st);
      st = next_statement ();
      goto loop;

    case ST_ENUM:
      accept_statement (st);
      parse_enum();
      st = next_statement ();
      goto loop;

    default:
      break;
    }

  return st;
}


/* Parse a WHERE block, (not a simple WHERE statement).  */

static void
parse_where_block (void)
{
  int seen_empty_else;
  gfc_code *top, *d;
  gfc_state_data s;
  gfc_statement st;

  accept_statement (ST_WHERE_BLOCK);
  top = gfc_state_stack->tail;

  push_state (&s, COMP_WHERE, gfc_new_block);

  d = add_statement ();
  d->expr = top->expr;
  d->op = EXEC_WHERE;

  top->expr = NULL;
  top->block = d;

  seen_empty_else = 0;

  do
    {
      st = next_statement ();
      switch (st)
	{
	case ST_NONE:
	  unexpected_eof ();

	case ST_WHERE_BLOCK:
	  parse_where_block ();
          break;

	case ST_ASSIGNMENT:
	case ST_WHERE:
	  accept_statement (st);
	  break;

	case ST_ELSEWHERE:
	  if (seen_empty_else)
	    {
	      gfc_error
		("ELSEWHERE statement at %C follows previous unmasked "
		 "ELSEWHERE");
	      break;
	    }

	  if (new_st.expr == NULL)
	    seen_empty_else = 1;

	  d = new_level (gfc_state_stack->head);
	  d->op = EXEC_WHERE;
	  d->expr = new_st.expr;

	  accept_statement (st);

	  break;

	case ST_END_WHERE:
	  accept_statement (st);
	  break;

	default:
	  gfc_error ("Unexpected %s statement in WHERE block at %C",
		     gfc_ascii_statement (st));
	  reject_statement ();
	  break;
	}

    }
  while (st != ST_END_WHERE);

  pop_state ();
}


/* Parse a FORALL block (not a simple FORALL statement).  */

static void
parse_forall_block (void)
{
  gfc_code *top, *d;
  gfc_state_data s;
  gfc_statement st;

  accept_statement (ST_FORALL_BLOCK);
  top = gfc_state_stack->tail;

  push_state (&s, COMP_FORALL, gfc_new_block);

  d = add_statement ();
  d->op = EXEC_FORALL;
  top->block = d;

  do
    {
      st = next_statement ();
      switch (st)
	{

	case ST_ASSIGNMENT:
	case ST_POINTER_ASSIGNMENT:
	case ST_WHERE:
	case ST_FORALL:
	  accept_statement (st);
	  break;

	case ST_WHERE_BLOCK:
	  parse_where_block ();
	  break;

	case ST_FORALL_BLOCK:
	  parse_forall_block ();
	  break;

	case ST_END_FORALL:
	  accept_statement (st);
	  break;

	case ST_NONE:
	  unexpected_eof ();

	default:
	  gfc_error ("Unexpected %s statement in FORALL block at %C",
		     gfc_ascii_statement (st));

	  reject_statement ();
	  break;
	}
    }
  while (st != ST_END_FORALL);

  pop_state ();
}


static gfc_statement parse_executable (gfc_statement);

/* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block.  */

static void
parse_if_block (void)
{
  gfc_code *top, *d;
  gfc_statement st;
  locus else_locus;
  gfc_state_data s;
  int seen_else;

  seen_else = 0;
  accept_statement (ST_IF_BLOCK);

  top = gfc_state_stack->tail;
  push_state (&s, COMP_IF, gfc_new_block);

  new_st.op = EXEC_IF;
  d = add_statement ();

  d->expr = top->expr;
  top->expr = NULL;
  top->block = d;

  do
    {
      st = parse_executable (ST_NONE);

      switch (st)
	{
	case ST_NONE:
	  unexpected_eof ();

	case ST_ELSEIF:
	  if (seen_else)
	    {
	      gfc_error
		("ELSE IF statement at %C cannot follow ELSE statement at %L",
		 &else_locus);

	      reject_statement ();
	      break;
	    }

	  d = new_level (gfc_state_stack->head);
	  d->op = EXEC_IF;
	  d->expr = new_st.expr;

	  accept_statement (st);

	  break;

	case ST_ELSE:
	  if (seen_else)
	    {
	      gfc_error ("Duplicate ELSE statements at %L and %C",
			 &else_locus);
	      reject_statement ();
	      break;
	    }

	  seen_else = 1;
	  else_locus = gfc_current_locus;

	  d = new_level (gfc_state_stack->head);
	  d->op = EXEC_IF;

	  accept_statement (st);

	  break;

	case ST_ENDIF:
	  break;

	default:
	  unexpected_statement (st);
	  break;
	}
    }
  while (st != ST_ENDIF);

  pop_state ();
  accept_statement (st);
}


/* Parse a SELECT block.  */

static void
parse_select_block (void)
{
  gfc_statement st;
  gfc_code *cp;
  gfc_state_data s;

  accept_statement (ST_SELECT_CASE);

  cp = gfc_state_stack->tail;
  push_state (&s, COMP_SELECT, gfc_new_block);

  /* Make sure that the next statement is a CASE or END SELECT.  */
  for (;;)
    {
      st = next_statement ();
      if (st == ST_NONE)
	unexpected_eof ();
      if (st == ST_END_SELECT)
	{
	  /* Empty SELECT CASE is OK.  */
	  accept_statement (st);
	  pop_state ();
	  return;
	}
      if (st == ST_CASE)
	break;

      gfc_error
	("Expected a CASE or END SELECT statement following SELECT CASE "
	 "at %C");

      reject_statement ();
    }

  /* At this point, we're got a nonempty select block.  */
  cp = new_level (cp);
  *cp = new_st;

  accept_statement (st);

  do
    {
      st = parse_executable (ST_NONE);
      switch (st)
	{
	case ST_NONE:
	  unexpected_eof ();

	case ST_CASE:
	  cp = new_level (gfc_state_stack->head);
	  *cp = new_st;
	  gfc_clear_new_st ();

	  accept_statement (st);
	  /* Fall through */

	case ST_END_SELECT:
	  break;

        /* Can't have an executable statement because of
           parse_executable().  */
	default:
	  unexpected_statement (st);
	  break;
	}
    }
  while (st != ST_END_SELECT);

  pop_state ();
  accept_statement (st);
}


/* Given a symbol, make sure it is not an iteration variable for a DO
   statement.  This subroutine is called when the symbol is seen in a
   context that causes it to become redefined.  If the symbol is an
   iterator, we generate an error message and return nonzero.  */

int 
gfc_check_do_variable (gfc_symtree *st)
{
  gfc_state_data *s;

  for (s=gfc_state_stack; s; s = s->previous)
    if (s->do_variable == st)
      {
	gfc_error_now("Variable '%s' at %C cannot be redefined inside "
		      "loop beginning at %L", st->name, &s->head->loc);
	return 1;
      }

  return 0;
}
  

/* Checks to see if the current statement label closes an enddo.
   Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
   an error) if it incorrectly closes an ENDDO.  */

static int
check_do_closure (void)
{
  gfc_state_data *p;

  if (gfc_statement_label == NULL)
    return 0;

  for (p = gfc_state_stack; p; p = p->previous)
    if (p->state == COMP_DO)
      break;

  if (p == NULL)
    return 0;		/* No loops to close */

  if (p->ext.end_do_label == gfc_statement_label)
    {

      if (p == gfc_state_stack)
	return 1;

      gfc_error
	("End of nonblock DO statement at %C is within another block");
      return 2;
    }

  /* At this point, the label doesn't terminate the innermost loop.
     Make sure it doesn't terminate another one.  */
  for (; p; p = p->previous)
    if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
      {
	gfc_error ("End of nonblock DO statement at %C is interwoven "
		   "with another DO loop");
	return 2;
      }

  return 0;
}


/* Parse a DO loop.  Note that the ST_CYCLE and ST_EXIT statements are
   handled inside of parse_executable(), because they aren't really
   loop statements.  */

static void
parse_do_block (void)
{
  gfc_statement st;
  gfc_code *top;
  gfc_state_data s;
  gfc_symtree *stree;

  s.ext.end_do_label = new_st.label;

  if (new_st.ext.iterator != NULL)
    stree = new_st.ext.iterator->var->symtree;
  else
    stree = NULL;

  accept_statement (ST_DO);

  top = gfc_state_stack->tail;