parse.c

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

  push_state (&s, COMP_DO, gfc_new_block);

  s.do_variable = stree;

  top->block = new_level (top);
  top->block->op = EXEC_DO;

loop:
  st = parse_executable (ST_NONE);

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

    case ST_ENDDO:
      if (s.ext.end_do_label != NULL
	  && s.ext.end_do_label != gfc_statement_label)
	gfc_error_now
	  ("Statement label in ENDDO at %C doesn't match DO label");

      if (gfc_statement_label != NULL)
	{
	  new_st.op = EXEC_NOP;
	  add_statement ();
	}
      break;

    case ST_IMPLIED_ENDDO:
      break;

    default:
      unexpected_statement (st);
      goto loop;
    }

  pop_state ();
  accept_statement (st);
}


/* Accept a series of executable statements.  We return the first
   statement that doesn't fit to the caller.  Any block statements are
   passed on to the correct handler, which usually passes the buck
   right back here.  */

static gfc_statement
parse_executable (gfc_statement st)
{
  int close_flag;

  if (st == ST_NONE)
    st = next_statement ();

  for (;; st = next_statement ())
    {

      close_flag = check_do_closure ();
      if (close_flag)
	switch (st)
	  {
	  case ST_GOTO:
	  case ST_END_PROGRAM:
	  case ST_RETURN:
	  case ST_EXIT:
	  case ST_END_FUNCTION:
	  case ST_CYCLE:
	  case ST_PAUSE:
	  case ST_STOP:
	  case ST_END_SUBROUTINE:

	  case ST_DO:
	  case ST_FORALL:
	  case ST_WHERE:
	  case ST_SELECT_CASE:
	    gfc_error
	      ("%s statement at %C cannot terminate a non-block DO loop",
	       gfc_ascii_statement (st));
	    break;

	  default:
	    break;
	  }

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

	case ST_FORMAT:
	case ST_DATA:
	case ST_ENTRY:
	case_executable:
	  accept_statement (st);
	  if (close_flag == 1)
	    return ST_IMPLIED_ENDDO;
	  continue;

	case ST_IF_BLOCK:
	  parse_if_block ();
	  continue;

	case ST_SELECT_CASE:
	  parse_select_block ();
	  continue;

	case ST_DO:
	  parse_do_block ();
	  if (check_do_closure () == 1)
	    return ST_IMPLIED_ENDDO;
	  continue;

	case ST_WHERE_BLOCK:
	  parse_where_block ();
	  continue;

	case ST_FORALL_BLOCK:
	  parse_forall_block ();
	  continue;

	default:
	  break;
	}

      break;
    }

  return st;
}


/* Parse a series of contained program units.  */

static void parse_progunit (gfc_statement);


/* Fix the symbols for sibling functions.  These are incorrectly added to
   the child namespace as the parser didn't know about this procedure.  */

static void
gfc_fixup_sibling_symbols (gfc_symbol * sym, gfc_namespace * siblings)
{
  gfc_namespace *ns;
  gfc_symtree *st;
  gfc_symbol *old_sym;

  sym->attr.referenced = 1;
  for (ns = siblings; ns; ns = ns->sibling)
    {
      gfc_find_sym_tree (sym->name, ns, 0, &st);
      if (!st)
        continue;

      old_sym = st->n.sym;
      if ((old_sym->attr.flavor == FL_PROCEDURE
	   || old_sym->ts.type == BT_UNKNOWN)
	  && old_sym->ns == ns
          && ! old_sym->attr.contained)
        {
          /* Replace it with the symbol from the parent namespace.  */
          st->n.sym = sym;
          sym->refs++;

          /* Free the old (local) symbol.  */
          old_sym->refs--;
          if (old_sym->refs == 0)
            gfc_free_symbol (old_sym);
        }

      /* Do the same for any contained procedures.  */
      gfc_fixup_sibling_symbols (sym, ns->contained);
    }
}

static void
parse_contained (int module)
{
  gfc_namespace *ns, *parent_ns;
  gfc_state_data s1, s2;
  gfc_statement st;
  gfc_symbol *sym;
  gfc_entry_list *el;

  push_state (&s1, COMP_CONTAINS, NULL);
  parent_ns = gfc_current_ns;

  do
    {
      gfc_current_ns = gfc_get_namespace (parent_ns, 1);

      gfc_current_ns->sibling = parent_ns->contained;
      parent_ns->contained = gfc_current_ns;

      st = next_statement ();

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

	case ST_FUNCTION:
	case ST_SUBROUTINE:
	  accept_statement (st);

	  push_state (&s2,
		      (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
		      gfc_new_block);

	  /* For internal procedures, create/update the symbol in the
	     parent namespace.  */

	  if (!module)
	    {
	      if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
		gfc_error
		  ("Contained procedure '%s' at %C is already ambiguous",
		   gfc_new_block->name);
	      else
		{
		  if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
					 &gfc_new_block->declared_at) ==
		      SUCCESS)
		    {
		      if (st == ST_FUNCTION)
			gfc_add_function (&sym->attr, sym->name,
					  &gfc_new_block->declared_at);
		      else
			gfc_add_subroutine (&sym->attr, sym->name,
					    &gfc_new_block->declared_at);
		    }
		}

	      gfc_commit_symbols ();
	    }
          else
            sym = gfc_new_block;

          /* Mark this as a contained function, so it isn't replaced
             by other module functions.  */
          sym->attr.contained = 1;
	  sym->attr.referenced = 1;

	  parse_progunit (ST_NONE);

          /* Fix up any sibling functions that refer to this one.  */
          gfc_fixup_sibling_symbols (sym, gfc_current_ns);
	  /* Or refer to any of its alternate entry points.  */
	  for (el = gfc_current_ns->entries; el; el = el->next)
	    gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);

	  gfc_current_ns->code = s2.head;
	  gfc_current_ns = parent_ns;

	  pop_state ();
	  break;

        /* These statements are associated with the end of the host
           unit.  */
	case ST_END_FUNCTION:
	case ST_END_MODULE:
	case ST_END_PROGRAM:
	case ST_END_SUBROUTINE:
	  accept_statement (st);
	  break;

	default:
	  gfc_error ("Unexpected %s statement in CONTAINS section at %C",
		     gfc_ascii_statement (st));
	  reject_statement ();
	  break;
	}
    }
  while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
	 && st != ST_END_MODULE && st != ST_END_PROGRAM);

  /* The first namespace in the list is guaranteed to not have
     anything (worthwhile) in it.  */

  gfc_current_ns = parent_ns;

  ns = gfc_current_ns->contained;
  gfc_current_ns->contained = ns->sibling;
  gfc_free_namespace (ns);

  pop_state ();
}


/* Parse a PROGRAM, SUBROUTINE or FUNCTION unit.  */

static void
parse_progunit (gfc_statement st)
{
  gfc_state_data *p;
  int n;

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

    case ST_CONTAINS:
      goto contains;

    case_end:
      accept_statement (st);
      goto done;

    default:
      break;
    }

loop:
  for (;;)
    {
      st = parse_executable (st);

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

	case ST_CONTAINS:
	  goto contains;

	case_end:
	  accept_statement (st);
	  goto done;

	default:
	  break;
	}

      unexpected_statement (st);
      reject_statement ();
      st = next_statement ();
    }

contains:
  n = 0;

  for (p = gfc_state_stack; p; p = p->previous)
    if (p->state == COMP_CONTAINS)
      n++;

  if (gfc_find_state (COMP_MODULE) == SUCCESS)
    n--;

  if (n > 0)
    {
      gfc_error ("CONTAINS statement at %C is already in a contained "
		 "program unit");
      st = next_statement ();
      goto loop;
    }

  parse_contained (0);

done:
  gfc_current_ns->code = gfc_state_stack->head;
}


/* Come here to complain about a global symbol already in use as
   something else.  */

void
global_used (gfc_gsymbol *sym, locus *where)
{
  const char *name;

  if (where == NULL)
    where = &gfc_current_locus;

  switch(sym->type)
    {
    case GSYM_PROGRAM:
      name = "PROGRAM";
      break;
    case GSYM_FUNCTION:
      name = "FUNCTION";
      break;
    case GSYM_SUBROUTINE:
      name = "SUBROUTINE";
      break;
    case GSYM_COMMON:
      name = "COMMON";
      break;
    case GSYM_BLOCK_DATA:
      name = "BLOCK DATA";
      break;
    case GSYM_MODULE:
      name = "MODULE";
      break;
    default:
      gfc_internal_error ("gfc_gsymbol_type(): Bad type");
      name = NULL;
    }

  gfc_error("Global name '%s' at %L is already being used as a %s at %L",
	      sym->name, where, name, &sym->where);
}


/* Parse a block data program unit.  */

static void
parse_block_data (void)
{
  gfc_statement st;
  static locus blank_locus;
  static int blank_block=0;
  gfc_gsymbol *s;

  gfc_current_ns->proc_name = gfc_new_block;
  gfc_current_ns->is_block_data = 1;

  if (gfc_new_block == NULL)
    {
      if (blank_block)
       gfc_error ("Blank BLOCK DATA at %C conflicts with "
                  "prior BLOCK DATA at %L", &blank_locus);
      else
       {
         blank_block = 1;
         blank_locus = gfc_current_locus;
       }
    }
  else
    {
      s = gfc_get_gsymbol (gfc_new_block->name);
      if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
       global_used(s, NULL);
      else
       {
         s->type = GSYM_BLOCK_DATA;
         s->where = gfc_current_locus;
	 s->defined = 1;
       }
    }

  st = parse_spec (ST_NONE);

  while (st != ST_END_BLOCK_DATA)
    {
      gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
		 gfc_ascii_statement (st));
      reject_statement ();
      st = next_statement ();
    }
}


/* Parse a module subprogram.  */

static void
parse_module (void)
{
  gfc_statement st;
  gfc_gsymbol *s;

  s = gfc_get_gsymbol (gfc_new_block->name);
  if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
    global_used(s, NULL);
  else
    {
      s->type = GSYM_MODULE;
      s->where = gfc_current_locus;
      s->defined = 1;
    }

  st = parse_spec (ST_NONE);

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

    case ST_CONTAINS:
      parse_contained (1);
      break;

    case ST_END_MODULE:
      accept_statement (st);
      break;

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

      reject_statement ();
      st = next_statement ();
      goto loop;
    }
}


/* Add a procedure name to the global symbol table.  */

static void
add_global_procedure (int sub)
{
  gfc_gsymbol *s;

  s = gfc_get_gsymbol(gfc_new_block->name);

  if (s->defined
	|| (s->type != GSYM_UNKNOWN && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
    global_used(s, NULL);
  else
    {
      s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
      s->where = gfc_current_locus;
      s->defined = 1;
    }
}


/* Add a program to the global symbol table.  */

static void
add_global_program (void)
{
  gfc_gsymbol *s;

  if (gfc_new_block == NULL)
    return;
  s = gfc_get_gsymbol (gfc_new_block->name);

  if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
    global_used(s, NULL);
  else
    {
      s->type = GSYM_PROGRAM;
      s->where = gfc_current_locus;
      s->defined = 1;
    }
}


/* Top level parser.  */

try
gfc_parse_file (void)
{
  int seen_program, errors_before, errors;
  gfc_state_data top, s;
  gfc_statement st;
  locus prog_locus;

  top.state = COMP_NONE;
  top.sym = NULL;
  top.previous = NULL;
  top.head = top.tail = NULL;
  top.do_variable = NULL;

  gfc_state_stack = ⊤

  gfc_clear_new_st ();

  gfc_statement_label = NULL;

  if (setjmp (eof_buf))
    return FAILURE;	/* Come here on unexpected EOF */

  seen_program = 0;

  /* Exit early for empty files.  */
  if (gfc_at_eof ())
    goto done;

loop:
  gfc_init_2 ();
  st = next_statement ();
  switch (st)
    {
    case ST_NONE:
      gfc_done_2 ();
      goto done;

    case ST_PROGRAM:
      if (seen_program)
	goto duplicate_main;
      seen_program = 1;
      prog_locus = gfc_current_locus;

      push_state (&s, COMP_PROGRAM, gfc_new_block);
      main_program_symbol(gfc_current_ns);
      accept_statement (st);
      add_global_program ();
      parse_progunit (ST_NONE);
      break;

    case ST_SUBROUTINE:
      add_global_procedure (1);
      push_state (&s, COMP_SUBROUTINE, gfc_new_block);
      accept_statement (st);
      parse_progunit (ST_NONE);
      break;

    case ST_FUNCTION:
      add_global_procedure (0);
      push_state (&s, COMP_FUNCTION, gfc_new_block);
      accept_statement (st);
      parse_progunit (ST_NONE);
      break;

    case ST_BLOCK_DATA:
      push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
      accept_statement (st);
      parse_block_data ();
      break;

    case ST_MODULE:
      push_state (&s, COMP_MODULE, gfc_new_block);
      accept_statement (st);

      gfc_get_errors (NULL, &errors_before);
      parse_module ();
      break;

    /* Anything else starts a nameless main program block.  */
    default:
      if (seen_program)
	goto duplicate_main;
      seen_program = 1;
      prog_locus = gfc_current_locus;

      push_state (&s, COMP_PROGRAM, gfc_new_block);
      main_program_symbol(gfc_current_ns);
      parse_progunit (st);
      break;
    }

  gfc_current_ns->code = s.head;

  gfc_resolve (gfc_current_ns);

  /* Dump the parse tree if requested.  */
  if (gfc_option.verbose)
    gfc_show_namespace (gfc_current_ns);

  gfc_get_errors (NULL, &errors);
  if (s.state == COMP_MODULE)
    {
      gfc_dump_module (s.sym->name, errors_before == errors);
      if (errors == 0 && ! gfc_option.flag_no_backend)
	gfc_generate_module_code (gfc_current_ns);
    }
  else
    {
      if (errors == 0 && ! gfc_option.flag_no_backend)
	gfc_generate_code (gfc_current_ns);
    }

  pop_state ();
  gfc_done_2 ();
  goto loop;

done:
  return SUCCESS;

duplicate_main:
  /* If we see a duplicate main program, shut down.  If the second
     instance is an implied main program, ie data decls or executable
     statements, we're in for lots of errors.  */
  gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
  reject_statement ();
  gfc_done_2 ();
  return SUCCESS;
}