parse.c

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

    case_executable:
    case_exec_markers:
      type = ST_LABEL_TARGET;
      break;

    case ST_FORMAT:
      type = ST_LABEL_FORMAT;
      break;

      /* Statement labels are not restricted from appearing on a
         particular line.  However, there are plenty of situations
         where the resulting label can't be referenced.  */

    default:
      type = ST_LABEL_BAD_TARGET;
      break;
    }

  gfc_define_st_label (gfc_statement_label, type, &label_locus);

  new_st.here = gfc_statement_label;
}


/* Figures out what the enclosing program unit is.  This will be a
   function, subroutine, program, block data or module.  */

gfc_state_data *
gfc_enclosing_unit (gfc_compile_state * result)
{
  gfc_state_data *p;

  for (p = gfc_state_stack; p; p = p->previous)
    if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE
	|| p->state == COMP_MODULE || p->state == COMP_BLOCK_DATA
	|| p->state == COMP_PROGRAM)
      {

	if (result != NULL)
	  *result = p->state;
	return p;
      }

  if (result != NULL)
    *result = COMP_PROGRAM;
  return NULL;
}


/* Translate a statement enum to a string.  */

const char *
gfc_ascii_statement (gfc_statement st)
{
  const char *p;

  switch (st)
    {
    case ST_ARITHMETIC_IF:
      p = _("arithmetic IF");
      break;
    case ST_ALLOCATE:
      p = "ALLOCATE";
      break;
    case ST_ATTR_DECL:
      p = _("attribute declaration");
      break;
    case ST_BACKSPACE:
      p = "BACKSPACE";
      break;
    case ST_BLOCK_DATA:
      p = "BLOCK DATA";
      break;
    case ST_CALL:
      p = "CALL";
      break;
    case ST_CASE:
      p = "CASE";
      break;
    case ST_CLOSE:
      p = "CLOSE";
      break;
    case ST_COMMON:
      p = "COMMON";
      break;
    case ST_CONTINUE:
      p = "CONTINUE";
      break;
    case ST_CONTAINS:
      p = "CONTAINS";
      break;
    case ST_CYCLE:
      p = "CYCLE";
      break;
    case ST_DATA_DECL:
      p = _("data declaration");
      break;
    case ST_DATA:
      p = "DATA";
      break;
    case ST_DEALLOCATE:
      p = "DEALLOCATE";
      break;
    case ST_DERIVED_DECL:
      p = _("derived type declaration");
      break;
    case ST_DO:
      p = "DO";
      break;
    case ST_ELSE:
      p = "ELSE";
      break;
    case ST_ELSEIF:
      p = "ELSE IF";
      break;
    case ST_ELSEWHERE:
      p = "ELSEWHERE";
      break;
    case ST_END_BLOCK_DATA:
      p = "END BLOCK DATA";
      break;
    case ST_ENDDO:
      p = "END DO";
      break;
    case ST_END_FILE:
      p = "END FILE";
      break;
    case ST_END_FORALL:
      p = "END FORALL";
      break;
    case ST_END_FUNCTION:
      p = "END FUNCTION";
      break;
    case ST_ENDIF:
      p = "END IF";
      break;
    case ST_END_INTERFACE:
      p = "END INTERFACE";
      break;
    case ST_END_MODULE:
      p = "END MODULE";
      break;
    case ST_END_PROGRAM:
      p = "END PROGRAM";
      break;
    case ST_END_SELECT:
      p = "END SELECT";
      break;
    case ST_END_SUBROUTINE:
      p = "END SUBROUTINE";
      break;
    case ST_END_WHERE:
      p = "END WHERE";
      break;
    case ST_END_TYPE:
      p = "END TYPE";
      break;
    case ST_ENTRY:
      p = "ENTRY";
      break;
    case ST_EQUIVALENCE:
      p = "EQUIVALENCE";
      break;
    case ST_EXIT:
      p = "EXIT";
      break;
    case ST_FLUSH:
      p = "FLUSH";
      break;
    case ST_FORALL_BLOCK:	/* Fall through */
    case ST_FORALL:
      p = "FORALL";
      break;
    case ST_FORMAT:
      p = "FORMAT";
      break;
    case ST_FUNCTION:
      p = "FUNCTION";
      break;
    case ST_GOTO:
      p = "GOTO";
      break;
    case ST_IF_BLOCK:
      p = _("block IF");
      break;
    case ST_IMPLICIT:
      p = "IMPLICIT";
      break;
    case ST_IMPLICIT_NONE:
      p = "IMPLICIT NONE";
      break;
    case ST_IMPLIED_ENDDO:
      p = _("implied END DO");
      break;
    case ST_INQUIRE:
      p = "INQUIRE";
      break;
    case ST_INTERFACE:
      p = "INTERFACE";
      break;
    case ST_PARAMETER:
      p = "PARAMETER";
      break;
    case ST_PRIVATE:
      p = "PRIVATE";
      break;
    case ST_PUBLIC:
      p = "PUBLIC";
      break;
    case ST_MODULE:
      p = "MODULE";
      break;
    case ST_PAUSE:
      p = "PAUSE";
      break;
    case ST_MODULE_PROC:
      p = "MODULE PROCEDURE";
      break;
    case ST_NAMELIST:
      p = "NAMELIST";
      break;
    case ST_NULLIFY:
      p = "NULLIFY";
      break;
    case ST_OPEN:
      p = "OPEN";
      break;
    case ST_PROGRAM:
      p = "PROGRAM";
      break;
    case ST_READ:
      p = "READ";
      break;
    case ST_RETURN:
      p = "RETURN";
      break;
    case ST_REWIND:
      p = "REWIND";
      break;
    case ST_STOP:
      p = "STOP";
      break;
    case ST_SUBROUTINE:
      p = "SUBROUTINE";
      break;
    case ST_TYPE:
      p = "TYPE";
      break;
    case ST_USE:
      p = "USE";
      break;
    case ST_WHERE_BLOCK:	/* Fall through */
    case ST_WHERE:
      p = "WHERE";
      break;
    case ST_WRITE:
      p = "WRITE";
      break;
    case ST_ASSIGNMENT:
      p = _("assignment");
      break;
    case ST_POINTER_ASSIGNMENT:
      p = _("pointer assignment");
      break;
    case ST_SELECT_CASE:
      p = "SELECT CASE";
      break;
    case ST_SEQUENCE:
      p = "SEQUENCE";
      break;
    case ST_SIMPLE_IF:
      p = _("simple IF");
      break;
    case ST_STATEMENT_FUNCTION:
      p = "STATEMENT FUNCTION";
      break;
    case ST_LABEL_ASSIGNMENT:
      p = "LABEL ASSIGNMENT";
      break;
    case ST_ENUM:
      p = "ENUM DEFINITION";
      break;
    case ST_ENUMERATOR:
      p = "ENUMERATOR DEFINITION";
      break;
    case ST_END_ENUM:
      p = "END ENUM";
      break;
    default:
      gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
    }

  return p;
}


/* Create a symbol for the main program and assign it to ns->proc_name.  */
 
static void 
main_program_symbol (gfc_namespace * ns)
{
  gfc_symbol *main_program;
  symbol_attribute attr;

  gfc_get_symbol ("MAIN__", ns, &main_program);
  gfc_clear_attr (&attr);
  attr.flavor = FL_PROCEDURE;
  attr.proc = PROC_UNKNOWN;
  attr.subroutine = 1;
  attr.access = ACCESS_PUBLIC;
  attr.is_main_program = 1;
  main_program->attr = attr;
  main_program->declared_at = gfc_current_locus;
  ns->proc_name = main_program;
  gfc_commit_symbols ();
}


/* Do whatever is necessary to accept the last statement.  */

static void
accept_statement (gfc_statement st)
{

  switch (st)
    {
    case ST_USE:
      gfc_use_module ();
      break;

    case ST_IMPLICIT_NONE:
      gfc_set_implicit_none ();
      break;

    case ST_IMPLICIT:
      break;

    case ST_FUNCTION:
    case ST_SUBROUTINE:
    case ST_MODULE:
      gfc_current_ns->proc_name = gfc_new_block;
      break;

      /* If the statement is the end of a block, lay down a special code
         that allows a branch to the end of the block from within the
         construct.  */

    case ST_ENDIF:
    case ST_END_SELECT:
      if (gfc_statement_label != NULL)
	{
	  new_st.op = EXEC_NOP;
	  add_statement ();
	}

      break;

      /* The end-of-program unit statements do not get the special
         marker and require a statement of some sort if they are a
         branch target.  */

    case ST_END_PROGRAM:
    case ST_END_FUNCTION:
    case ST_END_SUBROUTINE:
      if (gfc_statement_label != NULL)
	{
	  new_st.op = EXEC_RETURN;
	  add_statement ();
	}

      break;

    case ST_ENTRY:
    case_executable:
    case_exec_markers:
      add_statement ();
      break;

    default:
      break;
    }

  gfc_commit_symbols ();
  gfc_warning_check ();
  gfc_clear_new_st ();
}


/* Undo anything tentative that has been built for the current
   statement.  */

static void
reject_statement (void)
{

  gfc_undo_symbols ();
  gfc_clear_warning ();
  undo_new_statement ();
}


/* Generic complaint about an out of order statement.  We also do
   whatever is necessary to clean up.  */

static void
unexpected_statement (gfc_statement st)
{

  gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));

  reject_statement ();
}


/* Given the next statement seen by the matcher, make sure that it is
   in proper order with the last.  This subroutine is initialized by
   calling it with an argument of ST_NONE.  If there is a problem, we
   issue an error and return FAILURE.  Otherwise we return SUCCESS.

   Individual parsers need to verify that the statements seen are
   valid before calling here, ie ENTRY statements are not allowed in
   INTERFACE blocks.  The following diagram is taken from the standard:

            +---------------------------------------+
            | program  subroutine  function  module |
            +---------------------------------------+
            |                 use                   |
            |---------------------------------------+
            |        |        implicit none         |
            |        +-----------+------------------+
            |        | parameter |  implicit        |
            |        +-----------+------------------+
            | format |           |  derived type    |
            | entry  | parameter |  interface       |
            |        |   data    |  specification   |
            |        |           |  statement func  |
            |        +-----------+------------------+
            |        |   data    |    executable    |
            +--------+-----------+------------------+
            |                contains               |
            +---------------------------------------+
            |      internal module/subprogram       |
            +---------------------------------------+
            |                   end                 |
            +---------------------------------------+

*/

typedef struct
{
  enum
  { ORDER_START, ORDER_USE, ORDER_IMPLICIT_NONE, ORDER_IMPLICIT,
    ORDER_SPEC, ORDER_EXEC
  }
  state;
  gfc_statement last_statement;
  locus where;
}
st_state;

static try
verify_st_order (st_state * p, gfc_statement st)
{

  switch (st)
    {
    case ST_NONE:
      p->state = ORDER_START;
      break;

    case ST_USE:
      if (p->state > ORDER_USE)
	goto order;
      p->state = ORDER_USE;
      break;

    case ST_IMPLICIT_NONE:
      if (p->state > ORDER_IMPLICIT_NONE)
	goto order;

   /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
      statement disqualifies a USE but not an IMPLICIT NONE.
      Duplicate IMPLICIT NONEs are caught when the implicit types
      are set.  */

      p->state = ORDER_IMPLICIT_NONE;
      break;

    case ST_IMPLICIT:
      if (p->state > ORDER_IMPLICIT)
	goto order;
      p->state = ORDER_IMPLICIT;
      break;

    case ST_FORMAT:
    case ST_ENTRY:
      if (p->state < ORDER_IMPLICIT_NONE)
	p->state = ORDER_IMPLICIT_NONE;
      break;

    case ST_PARAMETER:
      if (p->state >= ORDER_EXEC)
	goto order;
      if (p->state < ORDER_IMPLICIT)
	p->state = ORDER_IMPLICIT;
      break;

    case ST_DATA:
      if (p->state < ORDER_SPEC)
	p->state = ORDER_SPEC;
      break;

    case ST_PUBLIC:
    case ST_PRIVATE:
    case ST_DERIVED_DECL:
    case_decl:
      if (p->state >= ORDER_EXEC)
	goto order;
      if (p->state < ORDER_SPEC)
	p->state = ORDER_SPEC;
      break;

    case_executable:
    case_exec_markers:
      if (p->state < ORDER_EXEC)
	p->state = ORDER_EXEC;
      break;

    default:
      gfc_internal_error
	("Unexpected %s statement in verify_st_order() at %C",
	 gfc_ascii_statement (st));
    }

  /* All is well, record the statement in case we need it next time.  */
  p->where = gfc_current_locus;
  p->last_statement = st;
  return SUCCESS;

order:
  gfc_error ("%s statement at %C cannot follow %s statement at %L",
	     gfc_ascii_statement (st),
	     gfc_ascii_statement (p->last_statement), &p->where);

  return FAILURE;
}


/* Handle an unexpected end of file.  This is a show-stopper...  */

static void unexpected_eof (void) ATTRIBUTE_NORETURN;

static void
unexpected_eof (void)
{
  gfc_state_data *p;

  gfc_error ("Unexpected end of file in '%s'", gfc_source_file);

  /* Memory cleanup.  Move to "second to last".  */
  for (p = gfc_state_stack; p && p->previous && p->previous->previous;
       p = p->previous);

  gfc_current_ns->code = (p && p->previous) ? p->head : NULL;
  gfc_done_2 ();

  longjmp (eof_buf, 1);
}


/* Parse a derived type.  */

static void
parse_derived (void)
{
  int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
  gfc_statement st;
  gfc_component *c;
  gfc_state_data s;

  error_flag = 0;

  accept_statement (ST_DERIVED_DECL);
  push_state (&s, COMP_DERIVED, gfc_new_block);

  gfc_new_block->component_access = ACCESS_PUBLIC;
  seen_private = 0;
  seen_sequence = 0;
  seen_component = 0;

  compiling_type = 1;

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

	case ST_DATA_DECL:
	  accept_statement (st);
	  seen_component = 1;
	  break;

	case ST_END_TYPE:
	  compiling_type = 0;

	  if (!seen_component)
	    {
	      gfc_error ("Derived type definition at %C has no components");
	      error_flag = 1;
	    }

	  accept_statement (ST_END_TYPE);
	  break;

	case ST_PRIVATE:
	  if (gfc_find_state (COMP_MODULE) == FAILURE)
	    {
	      gfc_error
		("PRIVATE statement in TYPE at %C must be inside a MODULE");
	      error_flag = 1;
	      break;
	    }

	  if (seen_component)
	    {
	      gfc_error ("PRIVATE statement at %C must precede "
			 "structure components");
	      error_flag = 1;
	      break;
	    }

	  if (seen_private)
	    {
	      gfc_error ("Duplicate PRIVATE statement at %C");
	      error_flag = 1;
	    }

	  s.sym->component_access = ACCESS_PRIVATE;
	  accept_statement (ST_PRIVATE);
	  seen_private = 1;
	  break;

	case ST_SEQUENCE:
	  if (seen_component)
	    {
	      gfc_error ("SEQUENCE statement at %C must precede "
			 "structure components");
	      error_flag = 1;
	      break;
	    }

	  if (gfc_current_block ()->attr.sequence)
	    gfc_warning ("SEQUENCE attribute at %C already specified in "
			 "TYPE statement");

	  if (seen_sequence)
	    {
	      gfc_error ("Duplicate SEQUENCE statement at %C");
	      error_flag = 1;
	    }

	  seen_sequence = 1;
	  gfc_add_sequence (&gfc_current_block ()->attr, 
			    gfc_current_block ()->name, NULL);
	  break;

	default:
	  unexpected_statement (st);
	  break;
	}
    }

  /* Sanity checks on the structure.  If the structure has the
     SEQUENCE attribute, then all component structures must also have