Check in gcc sources for prebuilt toolchains in Eclair.

1 files changed, 3256 insertions, 0 deletions

diff --git a/gcc-4.2.1/gcc/fortran/parse.c b/gcc-4.2.1/gcc/fortran/parse.c
new file mode 100644
index 000000000..e929c8946
--- /dev/null
+++ b/gcc-4.2.1/gcc/fortran/parse.c
@@ -0,0 +1,3256 @@
+/* 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;
+}
+
+static gfc_statement
+decode_omp_directive (void)
+{
+  locus old_locus;
+  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_pure (NULL))
+    {
+      gfc_error_now ("OpenMP directives at %C may not appear in PURE or ELEMENTAL procedures");
+      gfc_error_recovery ();
+      return ST_NONE;
+    }
+
+  old_locus = gfc_current_locus;
+
+  /* General OpenMP directive 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 ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
+      break;
+    case 'b':
+      match ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
+      break;
+    case 'c':
+      match ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
+      break;
+    case 'd':
+      match ("do", gfc_match_omp_do, ST_OMP_DO);
+      break;
+    case 'e':
+      match ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL);
+      match ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
+      match ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER);
+      match ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED);
+      match ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO);
+      match ("end parallel sections", gfc_match_omp_eos,
+	     ST_OMP_END_PARALLEL_SECTIONS);
+      match ("end parallel workshare", gfc_match_omp_eos,
+	     ST_OMP_END_PARALLEL_WORKSHARE);
+      match ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL);
+      match ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
+      match ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
+      match ("end workshare", gfc_match_omp_end_nowait,
+	     ST_OMP_END_WORKSHARE);
+      break;
+    case 'f':
+      match ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
+      break;
+    case 'm':
+      match ("master", gfc_match_omp_master, ST_OMP_MASTER);
+      break;
+    case 'o':
+      match ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
+      break;
+    case 'p':
+      match ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
+      match ("parallel sections", gfc_match_omp_parallel_sections,
+	     ST_OMP_PARALLEL_SECTIONS);
+      match ("parallel workshare", gfc_match_omp_parallel_workshare,
+	     ST_OMP_PARALLEL_WORKSHARE);
+      match ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL);
+      break;
+    case 's':
+      match ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
+      match ("section", gfc_match_omp_eos, ST_OMP_SECTION);
+      match ("single", gfc_match_omp_single, ST_OMP_SINGLE);
+      break;
+    case 't':
+      match ("threadprivate", gfc_match_omp_threadprivate,
+	     ST_OMP_THREADPRIVATE);
+    case 'w':
+      match ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
+      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 OpenMP directive 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, at_bol;
+
+  at_bol = gfc_at_bol ();
+  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 ("Zero is not a valid statement label at %C");
+
+	  do
+	    c = gfc_next_char ();
+	  while (ISDIGIT(c));
+
+	  if (!gfc_is_whitespace (c))
+	    gfc_error_now ("Non-numeric character in statement label at %C");
+
+	  return ST_NONE;
+	}
+      else
+	{
+	  label_locus = gfc_current_locus;
+
+	  gfc_gobble_whitespace ();
+
+	  if (at_bol && gfc_peek_char () == ';')
+	    {
+	      gfc_error_now
+		("Semicolon at %C needs to be preceded by statement");
+	      gfc_next_char (); /* Eat up the semicolon.  */
+	      return ST_NONE;
+	    }
+
+	  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;
+	    }
+	}
+    }
+  else if (c == '!')
+    {
+      /* Comments have already been skipped by the time we get here,
+	 except for OpenMP directives.  */
+      if (gfc_option.flag_openmp)
+	{
+	  int i;
+
+	  c = gfc_next_char ();
+	  for (i = 0; i < 5; i++, c = gfc_next_char ())
+	    gcc_assert (c == "!$omp"[i]);
+
+	  gcc_assert (c == ' ');
+	  gfc_gobble_whitespace ();
+	  return decode_omp_directive ();
+	}
+    }
+
+  if (at_bol && c == ';')
+    {
+      gfc_error_now ("Semicolon at %C needs to be preceded by statement");
+      gfc_next_char (); /* Eat up the semicolon.  */
+      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, except for OpenMP directives.  */
+	case '*':
+	  if (gfc_option.flag_openmp)
+	    {
+	      for (i = 0; i < 5; i++, c = gfc_next_char_literal (0))
+		gcc_assert (TOLOWER (c) == "*$omp"[i]);
+
+	      if (c != ' ' && c != '0')
+		{
+		  gfc_buffer_error (0);
+		  gfc_error ("Bad continuation line at %C");
+		  return ST_NONE;
+		}
+
+	      return decode_omp_directive ();
+	    }
+	  /* FALLTHROUGH */
+
+	  /* 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 (c == ';')
+    {
+      gfc_error_now ("Semicolon at %C needs to be preceded by statement");
+      return ST_NONE;
+    }
+
+  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 ("Ignoring statement label in empty statement 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
+	      && 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: case ST_OMP_FLUSH: \
+  case ST_OMP_BARRIER
+
+/* 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: case ST_OMP_PARALLEL: \
+  case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
+  case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
+  case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
+  case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE
+
+/* 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: case ST_OMP_THREADPRIVATE
+
+/* 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:
+    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;
+    case ST_OMP_ATOMIC:
+      p = "!$OMP ATOMIC";
+      break;
+    case ST_OMP_BARRIER:
+      p = "!$OMP BARRIER";
+      break;
+    case ST_OMP_CRITICAL:
+      p = "!$OMP CRITICAL";
+      break;
+    case ST_OMP_DO:
+      p = "!$OMP DO";
+      break;
+    case ST_OMP_END_CRITICAL:
+      p = "!$OMP END CRITICAL";
+      break;
+    case ST_OMP_END_DO:
+      p = "!$OMP END DO";
+      break;
+    case ST_OMP_END_MASTER:
+      p = "!$OMP END MASTER";
+      break;
+    case ST_OMP_END_ORDERED:
+      p = "!$OMP END ORDERED";
+      break;
+    case ST_OMP_END_PARALLEL:
+      p = "!$OMP END PARALLEL";
+      break;
+    case ST_OMP_END_PARALLEL_DO:
+      p = "!$OMP END PARALLEL DO";
+      break;
+    case ST_OMP_END_PARALLEL_SECTIONS:
+      p = "!$OMP END PARALLEL SECTIONS";
+      break;
+    case ST_OMP_END_PARALLEL_WORKSHARE:
+      p = "!$OMP END PARALLEL WORKSHARE";
+      break;
+    case ST_OMP_END_SECTIONS:
+      p = "!$OMP END SECTIONS";
+      break;
+    case ST_OMP_END_SINGLE:
+      p = "!$OMP END SINGLE";
+      break;
+    case ST_OMP_END_WORKSHARE:
+      p = "!$OMP END WORKSHARE";
+      break;
+    case ST_OMP_FLUSH:
+      p = "!$OMP FLUSH";
+      break;
+    case ST_OMP_MASTER:
+      p = "!$OMP MASTER";
+      break;
+    case ST_OMP_ORDERED:
+      p = "!$OMP ORDERED";
+      break;
+    case ST_OMP_PARALLEL:
+      p = "!$OMP PARALLEL";
+      break;
+    case ST_OMP_PARALLEL_DO:
+      p = "!$OMP PARALLEL DO";
+      break;
+    case ST_OMP_PARALLEL_SECTIONS:
+      p = "!$OMP PARALLEL SECTIONS";
+      break;
+    case ST_OMP_PARALLEL_WORKSHARE:
+      p = "!$OMP PARALLEL WORKSHARE";
+      break;
+    case ST_OMP_SECTIONS:
+      p = "!$OMP SECTIONS";
+      break;
+    case ST_OMP_SECTION:
+      p = "!$OMP SECTION";
+      break;
+    case ST_OMP_SINGLE:
+      p = "!$OMP SINGLE";
+      break;
+    case ST_OMP_THREADPRIVATE:
+      p = "!$OMP THREADPRIVATE";
+      break;
+    case ST_OMP_WORKSHARE:
+      p = "!$OMP WORKSHARE";
+      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_new_block = NULL;
+  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_state_data s;
+  gfc_symbol *sym;
+  gfc_component *c;
+
+  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;
+	}
+    }
+
+  /* Look for allocatable components.  */
+  sym = gfc_current_block ();
+  for (c = sym->components; c; c = c->next)
+    {
+      if (c->allocatable || (c->ts.type == BT_DERIVED
+		    	     && c->ts.derived->attr.alloc_comp))
+	{
+	  sym->attr.alloc_comp = 1;
+	  break;
+	}
+     }
+
+  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;
+  locus proc_locus;
+
+  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;
+  proc_locus = gfc_current_locus;
+
+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 ();
+
+  if (current_interface.ns
+	&& current_interface.ns->proc_name
+	&& strcmp (current_interface.ns->proc_name->name,
+		   prog_unit->name) == 0)
+    gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
+	       "enclosing procedure", prog_unit->name, &proc_locus);
+
+  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;
+  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:
+     /* If the do-stmt of this DO construct has a do-construct-name,
+	the corresponding end-do must be an end-do-stmt (with a matching
+	name, but in that case we must have seen ST_ENDDO first).
+	We only complain about this in pedantic mode.  */
+     if (gfc_current_block () != NULL)
+	gfc_error_now
+	  ("named block DO at %L requires matching ENDDO name",
+	   &gfc_current_block()->declared_at);
+
+      break;
+
+    default:
+      unexpected_statement (st);
+      goto loop;
+    }
+
+  pop_state ();
+  accept_statement (st);
+}
+
+
+/* Parse the statements of OpenMP do/parallel do.  */
+
+static gfc_statement
+parse_omp_do (gfc_statement omp_st)
+{
+  gfc_statement st;
+  gfc_code *cp, *np;
+  gfc_state_data s;
+
+  accept_statement (omp_st);
+
+  cp = gfc_state_stack->tail;
+  push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
+  np = new_level (cp);
+  np->op = cp->op;
+  np->block = NULL;
+
+  for (;;)
+    {
+      st = next_statement ();
+      if (st == ST_NONE)
+	unexpected_eof ();
+      else if (st == ST_DO)
+	break;
+      else
+	unexpected_statement (st);
+    }
+
+  parse_do_block ();
+  if (gfc_statement_label != NULL
+      && gfc_state_stack->previous != NULL
+      && gfc_state_stack->previous->state == COMP_DO
+      && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
+    {
+      /* In
+         DO 100 I=1,10
+           !$OMP DO
+             DO J=1,10
+             ...
+             100 CONTINUE
+         there should be no !$OMP END DO.  */
+      pop_state ();
+      return ST_IMPLIED_ENDDO;
+    }
+
+  check_do_closure ();
+  pop_state ();
+
+  st = next_statement ();
+  if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
+    {
+      if (new_st.op == EXEC_OMP_END_NOWAIT)
+	cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
+      else
+	gcc_assert (new_st.op == EXEC_NOP);
+      gfc_clear_new_st ();
+      gfc_commit_symbols ();
+      gfc_warning_check ();
+      st = next_statement ();
+    }
+  return st;
+}
+
+
+/* Parse the statements of OpenMP atomic directive.  */
+
+static void
+parse_omp_atomic (void)
+{
+  gfc_statement st;
+  gfc_code *cp, *np;
+  gfc_state_data s;
+
+  accept_statement (ST_OMP_ATOMIC);
+
+  cp = gfc_state_stack->tail;
+  push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
+  np = new_level (cp);
+  np->op = cp->op;
+  np->block = NULL;
+
+  for (;;)
+    {
+      st = next_statement ();
+      if (st == ST_NONE)
+	unexpected_eof ();
+      else if (st == ST_ASSIGNMENT)
+	break;
+      else
+	unexpected_statement (st);
+    }
+
+  accept_statement (st);
+
+  pop_state ();
+}
+
+
+/* Parse the statements of an OpenMP structured block.  */
+
+static void
+parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
+{
+  gfc_statement st, omp_end_st;
+  gfc_code *cp, *np;
+  gfc_state_data s;
+
+  accept_statement (omp_st);
+
+  cp = gfc_state_stack->tail;
+  push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
+  np = new_level (cp);
+  np->op = cp->op;
+  np->block = NULL;
+
+  switch (omp_st)
+    {
+    case ST_OMP_PARALLEL:
+      omp_end_st = ST_OMP_END_PARALLEL;
+      break;
+    case ST_OMP_PARALLEL_SECTIONS:
+      omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
+      break;
+    case ST_OMP_SECTIONS:
+      omp_end_st = ST_OMP_END_SECTIONS;
+      break;
+    case ST_OMP_ORDERED:
+      omp_end_st = ST_OMP_END_ORDERED;
+      break;
+    case ST_OMP_CRITICAL:
+      omp_end_st = ST_OMP_END_CRITICAL;
+      break;
+    case ST_OMP_MASTER:
+      omp_end_st = ST_OMP_END_MASTER;
+      break;
+    case ST_OMP_SINGLE:
+      omp_end_st = ST_OMP_END_SINGLE;
+      break;
+    case ST_OMP_WORKSHARE:
+      omp_end_st = ST_OMP_END_WORKSHARE;
+      break;
+    case ST_OMP_PARALLEL_WORKSHARE:
+      omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
+      break;
+    default:
+      gcc_unreachable ();
+    }
+
+  do
+    {
+      if (workshare_stmts_only)
+	{
+	  /* Inside of !$omp workshare, only
+	     scalar assignments
+	     array assignments
+	     where statements and constructs
+	     forall statements and constructs
+	     !$omp atomic
+	     !$omp critical
+	     !$omp parallel
+	     are allowed.  For !$omp critical these
+	     restrictions apply recursively.  */
+	  bool cycle = true;
+
+	  st = next_statement ();
+	  for (;;)
+	    {
+	      switch (st)
+		{
+		case ST_NONE:
+		  unexpected_eof ();
+
+		case ST_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_OMP_PARALLEL:
+		case ST_OMP_PARALLEL_SECTIONS:
+		  parse_omp_structured_block (st, false);
+		  break;
+
+		case ST_OMP_PARALLEL_WORKSHARE:
+		case ST_OMP_CRITICAL:
+		  parse_omp_structured_block (st, true);
+		  break;
+
+		case ST_OMP_PARALLEL_DO:
+		  st = parse_omp_do (st);
+		  continue;
+
+		case ST_OMP_ATOMIC:
+		  parse_omp_atomic ();
+		  break;
+
+		default:
+		  cycle = false;
+		  break;
+		}
+
+	      if (!cycle)
+		break;
+
+	      st = next_statement ();
+	    }
+	}
+      else
+	st = parse_executable (ST_NONE);
+      if (st == ST_NONE)
+	unexpected_eof ();
+      else if (st == ST_OMP_SECTION
+	       && (omp_st == ST_OMP_SECTIONS
+		   || omp_st == ST_OMP_PARALLEL_SECTIONS))
+	{
+	  np = new_level (np);
+	  np->op = cp->op;
+	  np->block = NULL;
+	}
+      else if (st != omp_end_st)
+	unexpected_statement (st);
+    }
+  while (st != omp_end_st);
+
+  switch (new_st.op)
+    {
+    case EXEC_OMP_END_NOWAIT:
+      cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
+      break;
+    case EXEC_OMP_CRITICAL:
+      if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
+	  || (new_st.ext.omp_name != NULL
+	      && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
+	gfc_error ("Name after !$omp critical and !$omp end critical does"
+		   " not match at %C");
+      gfc_free ((char *) new_st.ext.omp_name);
+      break;
+    case EXEC_OMP_END_SINGLE:
+      cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
+	= new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
+      new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
+      gfc_free_omp_clauses (new_st.ext.omp_clauses);
+      break;
+    case EXEC_NOP:
+      break;
+    default:
+      gcc_unreachable ();
+    }
+
+  gfc_clear_new_st ();
+  gfc_commit_symbols ();
+  gfc_warning_check ();
+  pop_state ();
+}
+
+
+/* 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 (;;)
+    {
+      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;
+	  break;
+
+	case ST_IF_BLOCK:
+	  parse_if_block ();
+	  break;
+
+	case ST_SELECT_CASE:
+	  parse_select_block ();
+	  break;
+
+	case ST_DO:
+	  parse_do_block ();
+	  if (check_do_closure () == 1)
+	    return ST_IMPLIED_ENDDO;
+	  break;
+
+	case ST_WHERE_BLOCK:
+	  parse_where_block ();
+	  break;
+
+	case ST_FORALL_BLOCK:
+	  parse_forall_block ();
+	  break;
+
+	case ST_OMP_PARALLEL:
+	case ST_OMP_PARALLEL_SECTIONS:
+	case ST_OMP_SECTIONS:
+	case ST_OMP_ORDERED:
+	case ST_OMP_CRITICAL:
+	case ST_OMP_MASTER:
+	case ST_OMP_SINGLE:
+	  parse_omp_structured_block (st, false);
+	  break;
+
+	case ST_OMP_WORKSHARE:
+	case ST_OMP_PARALLEL_WORKSHARE:
+	  parse_omp_structured_block (st, true);
+	  break;
+
+	case ST_OMP_DO:
+	case ST_OMP_PARALLEL_DO:
+	  st = parse_omp_do (st);
+	  if (st == ST_IMPLIED_ENDDO)
+	    return st;
+	  continue;
+
+	case ST_OMP_ATOMIC:
+	  parse_omp_atomic ();
+	  break;
+
+	default:
+	  return st;
+	}
+
+      st = next_statement ();
+    }
+}
+
+
+/* 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 || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
+	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 = &top;
+
+  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;
+}