parse.c

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

/* Main parser.
   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
   Free Software Foundation, Inc.
   Contributed by Andy Vaught

This file is part of GCC.

GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 2, or (at your option) any later
version.

GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.

You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING.  If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.  */


#include "config.h"
#include "system.h"
#include <setjmp.h>
#include "gfortran.h"
#include "match.h"
#include "parse.h"

/* Current statement label.  Zero means no statement label.  Because
   new_st can get wiped during statement matching, we have to keep it
   separate.  */

gfc_st_label *gfc_statement_label;

static locus label_locus;
static jmp_buf eof_buf;

gfc_state_data *gfc_state_stack;

/* TODO: Re-order functions to kill these forward decls.  */
static void check_statement_label (gfc_statement);
static void undo_new_statement (void);
static void reject_statement (void);

/* A sort of half-matching function.  We try to match the word on the
   input with the passed string.  If this succeeds, we call the
   keyword-dependent matching function that will match the rest of the
   statement.  For single keywords, the matching subroutine is
   gfc_match_eos().  */

static match
match_word (const char *str, match (*subr) (void), locus * old_locus)
{
  match m;

  if (str != NULL)
    {
      m = gfc_match (str);
      if (m != MATCH_YES)
	return m;
    }

  m = (*subr) ();

  if (m != MATCH_YES)
    {
      gfc_current_locus = *old_locus;
      reject_statement ();
    }

  return m;
}


/* Figure out what the next statement is, (mostly) regardless of
   proper ordering.  The do...while(0) is there to prevent if/else
   ambiguity.  */

#define match(keyword, subr, st)				\
    do {                                                        \
      if (match_word(keyword, subr, &old_locus) == MATCH_YES)	\
        return st;						\
      else							\
        undo_new_statement ();                                  \
    } while (0);

static gfc_statement
decode_statement (void)
{
  gfc_statement st;
  locus old_locus;
  match m;
  int c;

#ifdef GFC_DEBUG
  gfc_symbol_state ();
#endif

  gfc_clear_error ();	/* Clear any pending errors.  */
  gfc_clear_warning ();	/* Clear any pending warnings.  */

  if (gfc_match_eos () == MATCH_YES)
    return ST_NONE;

  old_locus = gfc_current_locus;

  /* Try matching a data declaration or function declaration. The
      input "REALFUNCTIONA(N)" can mean several things in different
      contexts, so it (and its relatives) get special treatment.  */

  if (gfc_current_state () == COMP_NONE
      || gfc_current_state () == COMP_INTERFACE
      || gfc_current_state () == COMP_CONTAINS)
    {
      m = gfc_match_function_decl ();
      if (m == MATCH_YES)
	return ST_FUNCTION;
      else if (m == MATCH_ERROR)
	reject_statement ();

      gfc_undo_symbols ();
      gfc_current_locus = old_locus;
    }

  /* Match statements whose error messages are meant to be overwritten
     by something better.  */

  match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
  match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
  match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);

  match (NULL, gfc_match_data_decl, ST_DATA_DECL);
  match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);

  /* Try to match a subroutine statement, which has the same optional
     prefixes that functions can have.  */

  if (gfc_match_subroutine () == MATCH_YES)
    return ST_SUBROUTINE;
  gfc_undo_symbols ();
  gfc_current_locus = old_locus;

  /* Check for the IF, DO, SELECT, WHERE and FORALL statements, which
     might begin with a block label.  The match functions for these
     statements are unusual in that their keyword is not seen before
     the matcher is called.  */

  if (gfc_match_if (&st) == MATCH_YES)
    return st;
  gfc_undo_symbols ();
  gfc_current_locus = old_locus;

  if (gfc_match_where (&st) == MATCH_YES)
    return st;
  gfc_undo_symbols ();
  gfc_current_locus = old_locus;

  if (gfc_match_forall (&st) == MATCH_YES)
    return st;
  gfc_undo_symbols ();
  gfc_current_locus = old_locus;

  match (NULL, gfc_match_do, ST_DO);
  match (NULL, gfc_match_select, ST_SELECT_CASE);

  /* General statement matching: Instead of testing every possible
     statement, we eliminate most possibilities by peeking at the
     first character.  */

  c = gfc_peek_char ();

  switch (c)
    {
    case 'a':
      match ("allocate", gfc_match_allocate, ST_ALLOCATE);
      match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
      match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
      break;

    case 'b':
      match ("backspace", gfc_match_backspace, ST_BACKSPACE);
      match ("block data", gfc_match_block_data, ST_BLOCK_DATA);
      break;

    case 'c':
      match ("call", gfc_match_call, ST_CALL);
      match ("close", gfc_match_close, ST_CLOSE);
      match ("continue", gfc_match_continue, ST_CONTINUE);
      match ("cycle", gfc_match_cycle, ST_CYCLE);
      match ("case", gfc_match_case, ST_CASE);
      match ("common", gfc_match_common, ST_COMMON);
      match ("contains", gfc_match_eos, ST_CONTAINS);
      break;

    case 'd':
      match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE);
      match ("data", gfc_match_data, ST_DATA);
      match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
      break;

    case 'e':
      match ("end file", gfc_match_endfile, ST_END_FILE);
      match ("exit", gfc_match_exit, ST_EXIT);
      match ("else", gfc_match_else, ST_ELSE);
      match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
      match ("else if", gfc_match_elseif, ST_ELSEIF);
      match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);

      if (gfc_match_end (&st) == MATCH_YES)
	return st;

      match ("entry% ", gfc_match_entry, ST_ENTRY);
      match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
      match ("external", gfc_match_external, ST_ATTR_DECL);
      break;

    case 'f':
      match ("flush", gfc_match_flush, ST_FLUSH);
      match ("format", gfc_match_format, ST_FORMAT);
      break;

    case 'g':
      match ("go to", gfc_match_goto, ST_GOTO);
      break;

    case 'i':
      match ("inquire", gfc_match_inquire, ST_INQUIRE);
      match ("implicit", gfc_match_implicit, ST_IMPLICIT);
      match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
      match ("interface", gfc_match_interface, ST_INTERFACE);
      match ("intent", gfc_match_intent, ST_ATTR_DECL);
      match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
      break;

    case 'm':
      match ("module% procedure% ", gfc_match_modproc, ST_MODULE_PROC);
      match ("module", gfc_match_module, ST_MODULE);
      break;

    case 'n':
      match ("nullify", gfc_match_nullify, ST_NULLIFY);
      match ("namelist", gfc_match_namelist, ST_NAMELIST);
      break;

    case 'o':
      match ("open", gfc_match_open, ST_OPEN);
      match ("optional", gfc_match_optional, ST_ATTR_DECL);
      break;

    case 'p':
      match ("print", gfc_match_print, ST_WRITE);
      match ("parameter", gfc_match_parameter, ST_PARAMETER);
      match ("pause", gfc_match_pause, ST_PAUSE);
      match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
      if (gfc_match_private (&st) == MATCH_YES)
	return st;
      match ("program", gfc_match_program, ST_PROGRAM);
      if (gfc_match_public (&st) == MATCH_YES)
	return st;
      break;

    case 'r':
      match ("read", gfc_match_read, ST_READ);
      match ("return", gfc_match_return, ST_RETURN);
      match ("rewind", gfc_match_rewind, ST_REWIND);
      break;

    case 's':
      match ("sequence", gfc_match_eos, ST_SEQUENCE);
      match ("stop", gfc_match_stop, ST_STOP);
      match ("save", gfc_match_save, ST_ATTR_DECL);
      break;

    case 't':
      match ("target", gfc_match_target, ST_ATTR_DECL);
      match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
      break;

    case 'u':
      match ("use% ", gfc_match_use, ST_USE);
      break;

    case 'w':
      match ("write", gfc_match_write, ST_WRITE);
      break;
    }

  /* All else has failed, so give up.  See if any of the matchers has
     stored an error message of some sort.  */

  if (gfc_error_check () == 0)
    gfc_error_now ("Unclassifiable statement at %C");

  reject_statement ();

  gfc_error_recovery ();

  return ST_NONE;
}

#undef match


/* Get the next statement in free form source.  */

static gfc_statement
next_free (void)
{
  match m;
  int c, d, cnt;

  gfc_gobble_whitespace ();

  c = gfc_peek_char ();

  if (ISDIGIT (c))
    {
      /* Found a statement label?  */
      m = gfc_match_st_label (&gfc_statement_label);

      d = gfc_peek_char ();
      if (m != MATCH_YES || !gfc_is_whitespace (d))
	{
	  gfc_match_small_literal_int (&c, &cnt);

	  if (cnt > 5)
	    gfc_error_now ("Too many digits in statement label at %C");
	  
	  if (c == 0)
	    gfc_error_now ("Statement label at %C is zero");

	  do
	    c = gfc_next_char ();
	  while (ISDIGIT(c));

	  if (!gfc_is_whitespace (c))
	    gfc_error_now ("Non-numeric character in statement label at %C");

	}
      else
	{
	  label_locus = gfc_current_locus;

	  gfc_gobble_whitespace ();

	  if (gfc_match_eos () == MATCH_YES)
	    {
	      gfc_warning_now
		("Ignoring statement label in empty statement at %C");
	      gfc_free_st_label (gfc_statement_label);
	      gfc_statement_label = NULL;
	      return ST_NONE;
	    }
	}
    }

  return decode_statement ();
}


/* Get the next statement in fixed-form source.  */

static gfc_statement
next_fixed (void)
{
  int label, digit_flag, i;
  locus loc;
  char c;

  if (!gfc_at_bol ())
    return decode_statement ();

  /* Skip past the current label field, parsing a statement label if
     one is there.  This is a weird number parser, since the number is
     contained within five columns and can have any kind of embedded
     spaces.  We also check for characters that make the rest of the
     line a comment.  */

  label = 0;
  digit_flag = 0;

  for (i = 0; i < 5; i++)
    {
      c = gfc_next_char_literal (0);

      switch (c)
	{
	case ' ':
	  break;

	case '0':
	case '1':
	case '2':
	case '3':
	case '4':
	case '5':
	case '6':
	case '7':
	case '8':
	case '9':
	  label = label * 10 + c - '0';
	  label_locus = gfc_current_locus;
	  digit_flag = 1;
	  break;

          /* Comments have already been skipped by the time we get
	     here so don't bother checking for them.  */

	default:
	  gfc_buffer_error (0);
	  gfc_error ("Non-numeric character in statement label at %C");
	  return ST_NONE;
	}
    }

  if (digit_flag)
    {
      if (label == 0)
	gfc_warning_now ("Zero is not a valid statement label at %C");
      else
	{
	  /* We've found a valid statement label.  */
	  gfc_statement_label = gfc_get_st_label (label);
	}
    }

  /* Since this line starts a statement, it cannot be a continuation
     of a previous statement.  If we see something here besides a
     space or zero, it must be a bad continuation line.  */

  c = gfc_next_char_literal (0);
  if (c == '\n')
    goto blank_line;

  if (c != ' ' && c!= '0')
    {
      gfc_buffer_error (0);
      gfc_error ("Bad continuation line at %C");
      return ST_NONE;
    }

  /* Now that we've taken care of the statement label columns, we have
     to make sure that the first nonblank character is not a '!'.  If
     it is, the rest of the line is a comment.  */

  do
    {
      loc = gfc_current_locus;
      c = gfc_next_char_literal (0);
    }
  while (gfc_is_whitespace (c));

  if (c == '!')
    goto blank_line;
  gfc_current_locus = loc;

  if (gfc_match_eos () == MATCH_YES)
    goto blank_line;

  /* At this point, we've got a nonblank statement to parse.  */
  return decode_statement ();

blank_line:
  if (digit_flag)
    gfc_warning ("Statement label in blank line will be " "ignored at %C");
  gfc_advance_line ();
  return ST_NONE;
}


/* Return the next non-ST_NONE statement to the caller.  We also worry
   about including files and the ends of include files at this stage.  */

static gfc_statement
next_statement (void)
{
  gfc_statement st;

  gfc_new_block = NULL;

  for (;;)
    {
      gfc_statement_label = NULL;
      gfc_buffer_error (1);

      if (gfc_at_eol ())
	{
	  if (gfc_option.warn_line_truncation
	      && gfc_current_locus.lb->truncated)
	    gfc_warning_now ("Line truncated at %C");

	  gfc_advance_line ();
	}

      gfc_skip_comments ();

      if (gfc_at_end ())
	{
	  st = ST_NONE;
	  break;
	}

      st =
	(gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();

      if (st != ST_NONE)
	break;
    }

  gfc_buffer_error (0);

  if (st != ST_NONE)
    check_statement_label (st);

  return st;
}


/****************************** Parser ***********************************/

/* The parser subroutines are of type 'try' that fail if the file ends
   unexpectedly.  */

/* Macros that expand to case-labels for various classes of
   statements.  Start with executable statements that directly do
   things.  */

#define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
  case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
  case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
  case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
  case ST_PAUSE: case ST_STOP: case ST_WRITE: case ST_ASSIGNMENT: \
  case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
  case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
  case ST_LABEL_ASSIGNMENT: case ST_FLUSH

/* Statements that mark other executable statements.  */

#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \
  case ST_WHERE_BLOCK: case ST_SELECT_CASE

/* Declaration statements */

#define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
  case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
  case ST_TYPE: case ST_INTERFACE

/* Block end statements.  Errors associated with interchanging these
   are detected in gfc_match_end().  */

#define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
                 case ST_END_PROGRAM: case ST_END_SUBROUTINE


/* Push a new state onto the stack.  */

static void
push_state (gfc_state_data * p, gfc_compile_state new_state, gfc_symbol * sym)
{

  p->state = new_state;
  p->previous = gfc_state_stack;
  p->sym = sym;
  p->head = p->tail = NULL;
  p->do_variable = NULL;

  gfc_state_stack = p;
}


/* Pop the current state.  */

static void
pop_state (void)
{

  gfc_state_stack = gfc_state_stack->previous;
}


/* Try to find the given state in the state stack.  */

try
gfc_find_state (gfc_compile_state state)
{
  gfc_state_data *p;

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

  return (p == NULL) ? FAILURE : SUCCESS;
}


/* Starts a new level in the statement list.  */

static gfc_code *
new_level (gfc_code * q)
{
  gfc_code *p;

  p = q->block = gfc_get_code ();

  gfc_state_stack->head = gfc_state_stack->tail = p;

  return p;
}


/* Add the current new_st code structure and adds it to the current
   program unit.  As a side-effect, it zeroes the new_st.  */

static gfc_code *
add_statement (void)
{
  gfc_code *p;

  p = gfc_get_code ();
  *p = new_st;

  p->loc = gfc_current_locus;

  if (gfc_state_stack->head == NULL)
    gfc_state_stack->head = p;
  else
    gfc_state_stack->tail->next = p;

  while (p->next != NULL)
    p = p->next;

  gfc_state_stack->tail = p;

  gfc_clear_new_st ();

  return p;
}


/* Frees everything associated with the current statement.  */

static void
undo_new_statement (void)
{
  gfc_free_statements (new_st.block);
  gfc_free_statements (new_st.next);
  gfc_free_statement (&new_st);
  gfc_clear_new_st ();
}


/* If the current statement has a statement label, make sure that it
   is allowed to, or should have one.  */

static void
check_statement_label (gfc_statement st)
{
  gfc_sl_type type;

  if (gfc_statement_label == NULL)
    {
      if (st == ST_FORMAT)
	gfc_error ("FORMAT statement at %L does not have a statement label",
		   &new_st.loc);
      return;
    }

  switch (st)
    {
    case ST_END_PROGRAM:
    case ST_END_FUNCTION:
    case ST_END_SUBROUTINE:
    case ST_ENDDO:
    case ST_ENDIF:
    case ST_END_SELECT: