In gcc/: 2011-04-14 Nicola Pero <nicola.pero@meta-innovation.com>

[official-gcc.git] / gcc / fortran / match.c

/* Matching subroutines in all sizes, shapes and colors.
   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
   2009, 2010, 2011
   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 3, 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 COPYING3.  If not see
<http://www.gnu.org/licenses/>.  */

#include "config.h"
#include "system.h"
#include "flags.h"
#include "gfortran.h"
#include "match.h"
#include "parse.h"

int gfc_matching_ptr_assignment = 0;
int gfc_matching_procptr_assignment = 0;
bool gfc_matching_prefix = false;

/* Stack of SELECT TYPE statements.  */
gfc_select_type_stack *select_type_stack = NULL;

/* For debugging and diagnostic purposes.  Return the textual representation
   of the intrinsic operator OP.  */
const char *
gfc_op2string (gfc_intrinsic_op op)
{
  switch (op)
    {
    case INTRINSIC_UPLUS:
    case INTRINSIC_PLUS:
      return "+";

    case INTRINSIC_UMINUS:
    case INTRINSIC_MINUS:
      return "-";

    case INTRINSIC_POWER:
      return "**";
    case INTRINSIC_CONCAT:
      return "//";
    case INTRINSIC_TIMES:
      return "*";
    case INTRINSIC_DIVIDE:
      return "/";

    case INTRINSIC_AND:
      return ".and.";
    case INTRINSIC_OR:
      return ".or.";
    case INTRINSIC_EQV:
      return ".eqv.";
    case INTRINSIC_NEQV:
      return ".neqv.";

    case INTRINSIC_EQ_OS:
      return ".eq.";
    case INTRINSIC_EQ:
      return "==";
    case INTRINSIC_NE_OS:
      return ".ne.";
    case INTRINSIC_NE:
      return "/=";
    case INTRINSIC_GE_OS:
      return ".ge.";
    case INTRINSIC_GE:
      return ">=";
    case INTRINSIC_LE_OS:
      return ".le.";
    case INTRINSIC_LE:
      return "<=";
    case INTRINSIC_LT_OS:
      return ".lt.";
    case INTRINSIC_LT:
      return "<";
    case INTRINSIC_GT_OS:
      return ".gt.";
    case INTRINSIC_GT:
      return ">";
    case INTRINSIC_NOT:
      return ".not.";

    case INTRINSIC_ASSIGN:
      return "=";

    case INTRINSIC_PARENTHESES:
      return "parens";

    default:
      break;
    }

  gfc_internal_error ("gfc_op2string(): Bad code");
  /* Not reached.  */
}


/******************** Generic matching subroutines ************************/

/* This function scans the current statement counting the opened and closed
   parenthesis to make sure they are balanced.  */

match
gfc_match_parens (void)
{
  locus old_loc, where;
  int count;
  gfc_instring instring;
  gfc_char_t c, quote;

  old_loc = gfc_current_locus;
  count = 0;
  instring = NONSTRING;
  quote = ' ';

  for (;;)
    {
      c = gfc_next_char_literal (instring);
      if (c == '\n')
        break;
      if (quote == ' ' && ((c == '\'') || (c == '"')))
        {
          quote = c;
          instring = INSTRING_WARN;
          continue;
        }
      if (quote != ' ' && c == quote)
        {
          quote = ' ';
          instring = NONSTRING;
          continue;
        }

      if (c == '(' && quote == ' ')
        {
          count++;
          where = gfc_current_locus;
        }
      if (c == ')' && quote == ' ')
        {
          count--;
          where = gfc_current_locus;
        }
    }

  gfc_current_locus = old_loc;

  if (count > 0)
    {
      gfc_error ("Missing ')' in statement at or before %L", &where);
      return MATCH_ERROR;
    }
  if (count < 0)
    {
      gfc_error ("Missing '(' in statement at or before %L", &where);
      return MATCH_ERROR;
    }

  return MATCH_YES;
}


/* See if the next character is a special character that has
   escaped by a \ via the -fbackslash option.  */

match
gfc_match_special_char (gfc_char_t *res)
{
  int len, i;
  gfc_char_t c, n;
  match m;

  m = MATCH_YES;

  switch ((c = gfc_next_char_literal (INSTRING_WARN)))
    {
    case 'a':
      *res = '\a';
      break;
    case 'b':
      *res = '\b';
      break;
    case 't':
      *res = '\t';
      break;
    case 'f':
      *res = '\f';
      break;
    case 'n':
      *res = '\n';
      break;
    case 'r':
      *res = '\r';
      break;
    case 'v':
      *res = '\v';
      break;
    case '\\':
      *res = '\\';
      break;
    case '0':
      *res = '\0';
      break;

    case 'x':
    case 'u':
    case 'U':
      /* Hexadecimal form of wide characters.  */
      len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8));
      n = 0;
      for (i = 0; i < len; i++)
        {
          char buf[2] = { '\0', '\0' };

          c = gfc_next_char_literal (INSTRING_WARN);
          if (!gfc_wide_fits_in_byte (c)
              || !gfc_check_digit ((unsigned char) c, 16))
            return MATCH_NO;

          buf[0] = (unsigned char) c;
          n = n << 4;
          n += strtol (buf, NULL, 16);
        }
      *res = n;
      break;

    default:
      /* Unknown backslash codes are simply not expanded.  */
      m = MATCH_NO;
      break;
    }

  return m;
}


/* In free form, match at least one space.  Always matches in fixed
   form.  */

match
gfc_match_space (void)
{
  locus old_loc;
  char c;

  if (gfc_current_form == FORM_FIXED)
    return MATCH_YES;

  old_loc = gfc_current_locus;

  c = gfc_next_ascii_char ();
  if (!gfc_is_whitespace (c))
    {
      gfc_current_locus = old_loc;
      return MATCH_NO;
    }

  gfc_gobble_whitespace ();

  return MATCH_YES;
}


/* Match an end of statement.  End of statement is optional
   whitespace, followed by a ';' or '\n' or comment '!'.  If a
   semicolon is found, we continue to eat whitespace and semicolons.  */

match
gfc_match_eos (void)
{
  locus old_loc;
  int flag;
  char c;

  flag = 0;

  for (;;)
    {
      old_loc = gfc_current_locus;
      gfc_gobble_whitespace ();

      c = gfc_next_ascii_char ();
      switch (c)
        {
        case '!':
          do
            {
              c = gfc_next_ascii_char ();
            }
          while (c != '\n');

          /* Fall through.  */

        case '\n':
          return MATCH_YES;

        case ';':
          flag = 1;
          continue;
        }

      break;
    }

  gfc_current_locus = old_loc;
  return (flag) ? MATCH_YES : MATCH_NO;
}


/* Match a literal integer on the input, setting the value on
   MATCH_YES.  Literal ints occur in kind-parameters as well as
   old-style character length specifications.  If cnt is non-NULL it
   will be set to the number of digits.  */

match
gfc_match_small_literal_int (int *value, int *cnt)
{
  locus old_loc;
  char c;
  int i, j;

  old_loc = gfc_current_locus;

  *value = -1;
  gfc_gobble_whitespace ();
  c = gfc_next_ascii_char ();
  if (cnt)
    *cnt = 0;

  if (!ISDIGIT (c))
    {
      gfc_current_locus = old_loc;
      return MATCH_NO;
    }

  i = c - '0';
  j = 1;

  for (;;)
    {
      old_loc = gfc_current_locus;
      c = gfc_next_ascii_char ();

      if (!ISDIGIT (c))
        break;

      i = 10 * i + c - '0';
      j++;

      if (i > 99999999)
        {
          gfc_error ("Integer too large at %C");
          return MATCH_ERROR;
        }
    }

  gfc_current_locus = old_loc;

  *value = i;
  if (cnt)
    *cnt = j;
  return MATCH_YES;
}


/* Match a small, constant integer expression, like in a kind
   statement.  On MATCH_YES, 'value' is set.  */

match
gfc_match_small_int (int *value)
{
  gfc_expr *expr;
  const char *p;
  match m;
  int i;

  m = gfc_match_expr (&expr);
  if (m != MATCH_YES)
    return m;

  p = gfc_extract_int (expr, &i);
  gfc_free_expr (expr);

  if (p != NULL)
    {
      gfc_error (p);
      m = MATCH_ERROR;
    }

  *value = i;
  return m;
}


/* This function is the same as the gfc_match_small_int, except that
   we're keeping the pointer to the expr.  This function could just be
   removed and the previously mentioned one modified, though all calls
   to it would have to be modified then (and there were a number of
   them).  Return MATCH_ERROR if fail to extract the int; otherwise,
   return the result of gfc_match_expr().  The expr (if any) that was
   matched is returned in the parameter expr.  */

match
gfc_match_small_int_expr (int *value, gfc_expr **expr)
{
  const char *p;
  match m;
  int i;

  m = gfc_match_expr (expr);
  if (m != MATCH_YES)
    return m;

  p = gfc_extract_int (*expr, &i);

  if (p != NULL)
    {
      gfc_error (p);
      m = MATCH_ERROR;
    }

  *value = i;
  return m;
}


/* Matches a statement label.  Uses gfc_match_small_literal_int() to
   do most of the work.  */

match
gfc_match_st_label (gfc_st_label **label)
{
  locus old_loc;
  match m;
  int i, cnt;

  old_loc = gfc_current_locus;

  m = gfc_match_small_literal_int (&i, &cnt);
  if (m != MATCH_YES)
    return m;

  if (cnt > 5)
    {
      gfc_error ("Too many digits in statement label at %C");
      goto cleanup;
    }

  if (i == 0)
    {
      gfc_error ("Statement label at %C is zero");
      goto cleanup;
    }

  *label = gfc_get_st_label (i);
  return MATCH_YES;

cleanup:

  gfc_current_locus = old_loc;
  return MATCH_ERROR;
}


/* Match and validate a label associated with a named IF, DO or SELECT
   statement.  If the symbol does not have the label attribute, we add
   it.  We also make sure the symbol does not refer to another
   (active) block.  A matched label is pointed to by gfc_new_block.  */

match
gfc_match_label (void)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  match m;

  gfc_new_block = NULL;

  m = gfc_match (" %n :", name);
  if (m != MATCH_YES)
    return m;

  if (gfc_get_symbol (name, NULL, &gfc_new_block))
    {
      gfc_error ("Label name '%s' at %C is ambiguous", name);
      return MATCH_ERROR;
    }

  if (gfc_new_block->attr.flavor == FL_LABEL)
    {
      gfc_error ("Duplicate construct label '%s' at %C", name);
      return MATCH_ERROR;
    }

  if (gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
                      gfc_new_block->name, NULL) == FAILURE)
    return MATCH_ERROR;

  return MATCH_YES;
}


/* See if the current input looks like a name of some sort.  Modifies
   the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
   Note that options.c restricts max_identifier_length to not more
   than GFC_MAX_SYMBOL_LEN.  */

match
gfc_match_name (char *buffer)
{
  locus old_loc;
  int i;
  char c;

  old_loc = gfc_current_locus;
  gfc_gobble_whitespace ();

  c = gfc_next_ascii_char ();
  if (!(ISALPHA (c) || (c == '_' && gfc_option.flag_allow_leading_underscore)))
    {
      if (gfc_error_flag_test() == 0 && c != '(')
        gfc_error ("Invalid character in name at %C");
      gfc_current_locus = old_loc;
      return MATCH_NO;
    }

  i = 0;

  do
    {
      buffer[i++] = c;

      if (i > gfc_option.max_identifier_length)
        {
          gfc_error ("Name at %C is too long");
          return MATCH_ERROR;
        }

      old_loc = gfc_current_locus;
      c = gfc_next_ascii_char ();
    }
  while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$'));

  if (c == '$' && !gfc_option.flag_dollar_ok)
    {
      gfc_error ("Invalid character '$' at %C. Use -fdollar-ok to allow it "
                 "as an extension");
      return MATCH_ERROR;
    }

  buffer[i] = '\0';
  gfc_current_locus = old_loc;

  return MATCH_YES;
}


/* Match a valid name for C, which is almost the same as for Fortran,
   except that you can start with an underscore, etc..  It could have
   been done by modifying the gfc_match_name, but this way other
   things C allows can be added, such as no limits on the length.
   Right now, the length is limited to the same thing as Fortran..
   Also, by rewriting it, we use the gfc_next_char_C() to prevent the
   input characters from being automatically lower cased, since C is
   case sensitive.  The parameter, buffer, is used to return the name
   that is matched.  Return MATCH_ERROR if the name is too long
   (though this is a self-imposed limit), MATCH_NO if what we're
   seeing isn't a name, and MATCH_YES if we successfully match a C
   name.  */

match
gfc_match_name_C (char *buffer)
{
  locus old_loc;
  int i = 0;
  gfc_char_t c;

  old_loc = gfc_current_locus;
  gfc_gobble_whitespace ();

  /* Get the next char (first possible char of name) and see if
     it's valid for C (either a letter or an underscore).  */
  c = gfc_next_char_literal (INSTRING_WARN);

  /* If the user put nothing expect spaces between the quotes, it is valid
     and simply means there is no name= specifier and the name is the fortran
     symbol name, all lowercase.  */
  if (c == '"' || c == '\'')
    {
      buffer[0] = '\0';
      gfc_current_locus = old_loc;
      return MATCH_YES;
    }
  
  if (!ISALPHA (c) && c != '_')
    {
      gfc_error ("Invalid C name in NAME= specifier at %C");
      return MATCH_ERROR;
    }

  /* Continue to read valid variable name characters.  */
  do
    {
      gcc_assert (gfc_wide_fits_in_byte (c));

      buffer[i++] = (unsigned char) c;
      
    /* C does not define a maximum length of variable names, to my
       knowledge, but the compiler typically places a limit on them.
       For now, i'll use the same as the fortran limit for simplicity,
       but this may need to be changed to a dynamic buffer that can
       be realloc'ed here if necessary, or more likely, a larger
       upper-bound set.  */
      if (i > gfc_option.max_identifier_length)
        {
          gfc_error ("Name at %C is too long");
          return MATCH_ERROR;
        }
      
      old_loc = gfc_current_locus;
      
      /* Get next char; param means we're in a string.  */
      c = gfc_next_char_literal (INSTRING_WARN);
    } while (ISALNUM (c) || c == '_');

  buffer[i] = '\0';
  gfc_current_locus = old_loc;

  /* See if we stopped because of whitespace.  */
  if (c == ' ')
    {
      gfc_gobble_whitespace ();
      c = gfc_peek_ascii_char ();
      if (c != '"' && c != '\'')
        {
          gfc_error ("Embedded space in NAME= specifier at %C");
          return MATCH_ERROR;
        }
    }
  
  /* If we stopped because we had an invalid character for a C name, report
     that to the user by returning MATCH_NO.  */
  if (c != '"' && c != '\'')
    {
      gfc_error ("Invalid C name in NAME= specifier at %C");
      return MATCH_ERROR;
    }

  return MATCH_YES;
}


/* Match a symbol on the input.  Modifies the pointer to the symbol
   pointer if successful.  */

match
gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
{
  char buffer[GFC_MAX_SYMBOL_LEN + 1];
  match m;

  m = gfc_match_name (buffer);
  if (m != MATCH_YES)
    return m;

  if (host_assoc)
    return (gfc_get_ha_sym_tree (buffer, matched_symbol))
            ? MATCH_ERROR : MATCH_YES;

  if (gfc_get_sym_tree (buffer, NULL, matched_symbol, false))
    return MATCH_ERROR;

  return MATCH_YES;
}


match
gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
{
  gfc_symtree *st;
  match m;

  m = gfc_match_sym_tree (&st, host_assoc);

  if (m == MATCH_YES)
    {
      if (st)
        *matched_symbol = st->n.sym;
      else
        *matched_symbol = NULL;
    }
  else
    *matched_symbol = NULL;
  return m;
}


/* Match an intrinsic operator.  Returns an INTRINSIC enum. While matching, 
   we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this 
   in matchexp.c.  */

match
gfc_match_intrinsic_op (gfc_intrinsic_op *result)
{
  locus orig_loc = gfc_current_locus;
  char ch;

  gfc_gobble_whitespace ();
  ch = gfc_next_ascii_char ();
  switch (ch)
    {
    case '+':
      /* Matched "+".  */
      *result = INTRINSIC_PLUS;
      return MATCH_YES;

    case '-':
      /* Matched "-".  */
      *result = INTRINSIC_MINUS;
      return MATCH_YES;

    case '=':
      if (gfc_next_ascii_char () == '=')
        {
          /* Matched "==".  */
          *result = INTRINSIC_EQ;
          return MATCH_YES;
        }
      break;

    case '<':
      if (gfc_peek_ascii_char () == '=')
        {
          /* Matched "<=".  */
          gfc_next_ascii_char ();
          *result = INTRINSIC_LE;
          return MATCH_YES;
        }
      /* Matched "<".  */
      *result = INTRINSIC_LT;
      return MATCH_YES;

    case '>':
      if (gfc_peek_ascii_char () == '=')
        {
          /* Matched ">=".  */
          gfc_next_ascii_char ();
          *result = INTRINSIC_GE;
          return MATCH_YES;
        }
      /* Matched ">".  */
      *result = INTRINSIC_GT;
      return MATCH_YES;

    case '*':
      if (gfc_peek_ascii_char () == '*')
        {
          /* Matched "**".  */
          gfc_next_ascii_char ();
          *result = INTRINSIC_POWER;
          return MATCH_YES;
        }
      /* Matched "*".  */
      *result = INTRINSIC_TIMES;
      return MATCH_YES;

    case '/':
      ch = gfc_peek_ascii_char ();
      if (ch == '=')
        {
          /* Matched "/=".  */
          gfc_next_ascii_char ();
          *result = INTRINSIC_NE;
          return MATCH_YES;
        }
      else if (ch == '/')
        {
          /* Matched "//".  */
          gfc_next_ascii_char ();
          *result = INTRINSIC_CONCAT;
          return MATCH_YES;
        }
      /* Matched "/".  */
      *result = INTRINSIC_DIVIDE;
      return MATCH_YES;

    case '.':
      ch = gfc_next_ascii_char ();
      switch (ch)
        {
        case 'a':
          if (gfc_next_ascii_char () == 'n'
              && gfc_next_ascii_char () == 'd'
              && gfc_next_ascii_char () == '.')
            {
              /* Matched ".and.".  */
              *result = INTRINSIC_AND;
              return MATCH_YES;
            }
          break;

        case 'e':
          if (gfc_next_ascii_char () == 'q')
            {
              ch = gfc_next_ascii_char ();
              if (ch == '.')
                {
                  /* Matched ".eq.".  */
                  *result = INTRINSIC_EQ_OS;
                  return MATCH_YES;
                }
              else if (ch == 'v')
                {
                  if (gfc_next_ascii_char () == '.')
                    {
                      /* Matched ".eqv.".  */
                      *result = INTRINSIC_EQV;
                      return MATCH_YES;
                    }
                }
            }
          break;

        case 'g':
          ch = gfc_next_ascii_char ();
          if (ch == 'e')
            {
              if (gfc_next_ascii_char () == '.')
                {
                  /* Matched ".ge.".  */
                  *result = INTRINSIC_GE_OS;
                  return MATCH_YES;
                }
            }
          else if (ch == 't')
            {
              if (gfc_next_ascii_char () == '.')
                {
                  /* Matched ".gt.".  */
                  *result = INTRINSIC_GT_OS;
                  return MATCH_YES;
                }
            }
          break;

        case 'l':
          ch = gfc_next_ascii_char ();
          if (ch == 'e')
            {
              if (gfc_next_ascii_char () == '.')
                {
                  /* Matched ".le.".  */
                  *result = INTRINSIC_LE_OS;
                  return MATCH_YES;
                }
            }
          else if (ch == 't')
            {
              if (gfc_next_ascii_char () == '.')
                {
                  /* Matched ".lt.".  */
                  *result = INTRINSIC_LT_OS;
                  return MATCH_YES;
                }
            }
          break;

        case 'n':
          ch = gfc_next_ascii_char ();
          if (ch == 'e')
            {
              ch = gfc_next_ascii_char ();
              if (ch == '.')
                {
                  /* Matched ".ne.".  */
                  *result = INTRINSIC_NE_OS;
                  return MATCH_YES;
                }
              else if (ch == 'q')
                {
                  if (gfc_next_ascii_char () == 'v'
                      && gfc_next_ascii_char () == '.')
                    {
                      /* Matched ".neqv.".  */
                      *result = INTRINSIC_NEQV;
                      return MATCH_YES;
                    }
                }
            }
          else if (ch == 'o')
            {
              if (gfc_next_ascii_char () == 't'
                  && gfc_next_ascii_char () == '.')
                {
                  /* Matched ".not.".  */
                  *result = INTRINSIC_NOT;
                  return MATCH_YES;
                }
            }
          break;

        case 'o':
          if (gfc_next_ascii_char () == 'r'
              && gfc_next_ascii_char () == '.')
            {
              /* Matched ".or.".  */
              *result = INTRINSIC_OR;
              return MATCH_YES;
            }
          break;

        default:
          break;
        }
      break;

    default:
      break;
    }

  gfc_current_locus = orig_loc;
  return MATCH_NO;
}


/* Match a loop control phrase:

    <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]

   If the final integer expression is not present, a constant unity
   expression is returned.  We don't return MATCH_ERROR until after
   the equals sign is seen.  */

match
gfc_match_iterator (gfc_iterator *iter, int init_flag)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_expr *var, *e1, *e2, *e3;
  locus start;
  match m;

  e1 = e2 = e3 = NULL;

  /* Match the start of an iterator without affecting the symbol table.  */

  start = gfc_current_locus;
  m = gfc_match (" %n =", name);
  gfc_current_locus = start;

  if (m != MATCH_YES)
    return MATCH_NO;

  m = gfc_match_variable (&var, 0);
  if (m != MATCH_YES)
    return MATCH_NO;

  /* F2008, C617 & C565.  */
  if (var->symtree->n.sym->attr.codimension)
    {
      gfc_error ("Loop variable at %C cannot be a coarray");
      goto cleanup;
    }

  if (var->ref != NULL)
    {
      gfc_error ("Loop variable at %C cannot be a sub-component");
      goto cleanup;
    }

  gfc_match_char ('=');

  var->symtree->n.sym->attr.implied_index = 1;

  m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
  if (m == MATCH_NO)
    goto syntax;
  if (m == MATCH_ERROR)
    goto cleanup;

  if (gfc_match_char (',') != MATCH_YES)
    goto syntax;

  m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
  if (m == MATCH_NO)
    goto syntax;
  if (m == MATCH_ERROR)
    goto cleanup;

  if (gfc_match_char (',') != MATCH_YES)
    {
      e3 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
      goto done;
    }

  m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
  if (m == MATCH_ERROR)
    goto cleanup;
  if (m == MATCH_NO)
    {
      gfc_error ("Expected a step value in iterator at %C");
      goto cleanup;
    }

done:
  iter->var = var;
  iter->start = e1;
  iter->end = e2;
  iter->step = e3;
  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in iterator at %C");

cleanup:
  gfc_free_expr (e1);
  gfc_free_expr (e2);
  gfc_free_expr (e3);

  return MATCH_ERROR;
}


/* Tries to match the next non-whitespace character on the input.
   This subroutine does not return MATCH_ERROR.  */

match
gfc_match_char (char c)
{
  locus where;

  where = gfc_current_locus;
  gfc_gobble_whitespace ();

  if (gfc_next_ascii_char () == c)
    return MATCH_YES;

  gfc_current_locus = where;
  return MATCH_NO;
}


/* General purpose matching subroutine.  The target string is a
   scanf-like format string in which spaces correspond to arbitrary
   whitespace (including no whitespace), characters correspond to
   themselves.  The %-codes are:

   %%  Literal percent sign
   %e  Expression, pointer to a pointer is set
   %s  Symbol, pointer to the symbol is set
   %n  Name, character buffer is set to name
   %t  Matches end of statement.
   %o  Matches an intrinsic operator, returned as an INTRINSIC enum.
   %l  Matches a statement label
   %v  Matches a variable expression (an lvalue)
   %   Matches a required space (in free form) and optional spaces.  */

match
gfc_match (const char *target, ...)
{
  gfc_st_label **label;
  int matches, *ip;
  locus old_loc;
  va_list argp;
  char c, *np;
  match m, n;
  void **vp;
  const char *p;

  old_loc = gfc_current_locus;
  va_start (argp, target);
  m = MATCH_NO;
  matches = 0;
  p = target;

loop:
  c = *p++;
  switch (c)
    {
    case ' ':
      gfc_gobble_whitespace ();
      goto loop;
    case '\0':
      m = MATCH_YES;
      break;

    case '%':
      c = *p++;
      switch (c)
        {
        case 'e':
          vp = va_arg (argp, void **);
          n = gfc_match_expr ((gfc_expr **) vp);
          if (n != MATCH_YES)
            {
              m = n;
              goto not_yes;
            }

          matches++;
          goto loop;

        case 'v':
          vp = va_arg (argp, void **);
          n = gfc_match_variable ((gfc_expr **) vp, 0);
          if (n != MATCH_YES)
            {
              m = n;
              goto not_yes;
            }

          matches++;
          goto loop;

        case 's':
          vp = va_arg (argp, void **);
          n = gfc_match_symbol ((gfc_symbol **) vp, 0);
          if (n != MATCH_YES)
            {
              m = n;
              goto not_yes;
            }

          matches++;
          goto loop;

        case 'n':
          np = va_arg (argp, char *);
          n = gfc_match_name (np);
          if (n != MATCH_YES)
            {
              m = n;
              goto not_yes;
            }

          matches++;
          goto loop;

        case 'l':
          label = va_arg (argp, gfc_st_label **);
          n = gfc_match_st_label (label);
          if (n != MATCH_YES)
            {
              m = n;
              goto not_yes;
            }

          matches++;
          goto loop;

        case 'o':
          ip = va_arg (argp, int *);
          n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
          if (n != MATCH_YES)
            {
              m = n;
              goto not_yes;
            }

          matches++;
          goto loop;

        case 't':
          if (gfc_match_eos () != MATCH_YES)
            {
              m = MATCH_NO;
              goto not_yes;
            }
          goto loop;

        case ' ':
          if (gfc_match_space () == MATCH_YES)
            goto loop;
          m = MATCH_NO;
          goto not_yes;

        case '%':
          break;        /* Fall through to character matcher.  */

        default:
          gfc_internal_error ("gfc_match(): Bad match code %c", c);
        }

    default:

      /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
         expect an upper case character here!  */
      gcc_assert (TOLOWER (c) == c);

      if (c == gfc_next_ascii_char ())
        goto loop;
      break;
    }

not_yes:
  va_end (argp);

  if (m != MATCH_YES)
    {
      /* Clean up after a failed match.  */
      gfc_current_locus = old_loc;
      va_start (argp, target);

      p = target;
      for (; matches > 0; matches--)
        {
          while (*p++ != '%');

          switch (*p++)
            {
            case '%':
              matches++;
              break;            /* Skip.  */

            /* Matches that don't have to be undone */
            case 'o':
            case 'l':
            case 'n':
            case 's':
              (void) va_arg (argp, void **);
              break;

            case 'e':
            case 'v':
              vp = va_arg (argp, void **);
              gfc_free_expr ((struct gfc_expr *)*vp);
              *vp = NULL;
              break;
            }
        }

      va_end (argp);
    }

  return m;
}


/*********************** Statement level matching **********************/

/* Matches the start of a program unit, which is the program keyword
   followed by an obligatory symbol.  */

match
gfc_match_program (void)
{
  gfc_symbol *sym;
  match m;

  m = gfc_match ("% %s%t", &sym);

  if (m == MATCH_NO)
    {
      gfc_error ("Invalid form of PROGRAM statement at %C");
      m = MATCH_ERROR;
    }

  if (m == MATCH_ERROR)
    return m;

  if (gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL) == FAILURE)
    return MATCH_ERROR;

  gfc_new_block = sym;

  return MATCH_YES;
}


/* Match a simple assignment statement.  */

match
gfc_match_assignment (void)
{
  gfc_expr *lvalue, *rvalue;
  locus old_loc;
  match m;

  old_loc = gfc_current_locus;

  lvalue = NULL;
  m = gfc_match (" %v =", &lvalue);
  if (m != MATCH_YES)
    {
      gfc_current_locus = old_loc;
      gfc_free_expr (lvalue);
      return MATCH_NO;
    }

  rvalue = NULL;
  m = gfc_match (" %e%t", &rvalue);
  if (m != MATCH_YES)
    {
      gfc_current_locus = old_loc;
      gfc_free_expr (lvalue);
      gfc_free_expr (rvalue);
      return m;
    }

  gfc_set_sym_referenced (lvalue->symtree->n.sym);

  new_st.op = EXEC_ASSIGN;
  new_st.expr1 = lvalue;
  new_st.expr2 = rvalue;

  gfc_check_do_variable (lvalue->symtree);

  return MATCH_YES;
}


/* Match a pointer assignment statement.  */

match
gfc_match_pointer_assignment (void)
{
  gfc_expr *lvalue, *rvalue;
  locus old_loc;
  match m;

  old_loc = gfc_current_locus;

  lvalue = rvalue = NULL;
  gfc_matching_ptr_assignment = 0;
  gfc_matching_procptr_assignment = 0;

  m = gfc_match (" %v =>", &lvalue);
  if (m != MATCH_YES)
    {
      m = MATCH_NO;
      goto cleanup;
    }

  if (lvalue->symtree->n.sym->attr.proc_pointer
      || gfc_is_proc_ptr_comp (lvalue, NULL))
    gfc_matching_procptr_assignment = 1;
  else
    gfc_matching_ptr_assignment = 1;

  m = gfc_match (" %e%t", &rvalue);
  gfc_matching_ptr_assignment = 0;
  gfc_matching_procptr_assignment = 0;
  if (m != MATCH_YES)
    goto cleanup;

  new_st.op = EXEC_POINTER_ASSIGN;
  new_st.expr1 = lvalue;
  new_st.expr2 = rvalue;

  return MATCH_YES;

cleanup:
  gfc_current_locus = old_loc;
  gfc_free_expr (lvalue);
  gfc_free_expr (rvalue);
  return m;
}


/* We try to match an easy arithmetic IF statement. This only happens
   when just after having encountered a simple IF statement. This code
   is really duplicate with parts of the gfc_match_if code, but this is
   *much* easier.  */

static match
match_arithmetic_if (void)
{
  gfc_st_label *l1, *l2, *l3;
  gfc_expr *expr;
  match m;

  m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
  if (m != MATCH_YES)
    return m;

  if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
      || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
      || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
    {
      gfc_free_expr (expr);
      return MATCH_ERROR;
    }

  if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Arithmetic IF "
                      "statement at %C") == FAILURE)
    return MATCH_ERROR;

  new_st.op = EXEC_ARITHMETIC_IF;
  new_st.expr1 = expr;
  new_st.label1 = l1;
  new_st.label2 = l2;
  new_st.label3 = l3;

  return MATCH_YES;
}


/* The IF statement is a bit of a pain.  First of all, there are three
   forms of it, the simple IF, the IF that starts a block and the
   arithmetic IF.

   There is a problem with the simple IF and that is the fact that we
   only have a single level of undo information on symbols.  What this
   means is for a simple IF, we must re-match the whole IF statement
   multiple times in order to guarantee that the symbol table ends up
   in the proper state.  */

static match match_simple_forall (void);
static match match_simple_where (void);

match
gfc_match_if (gfc_statement *if_type)
{
  gfc_expr *expr;
  gfc_st_label *l1, *l2, *l3;
  locus old_loc, old_loc2;
  gfc_code *p;
  match m, n;

  n = gfc_match_label ();
  if (n == MATCH_ERROR)
    return n;

  old_loc = gfc_current_locus;

  m = gfc_match (" if ( %e", &expr);
  if (m != MATCH_YES)
    return m;

  old_loc2 = gfc_current_locus;
  gfc_current_locus = old_loc;
  
  if (gfc_match_parens () == MATCH_ERROR)
    return MATCH_ERROR;

  gfc_current_locus = old_loc2;

  if (gfc_match_char (')') != MATCH_YES)
    {
      gfc_error ("Syntax error in IF-expression at %C");
      gfc_free_expr (expr);
      return MATCH_ERROR;
    }

  m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);

  if (m == MATCH_YES)
    {
      if (n == MATCH_YES)
        {
          gfc_error ("Block label not appropriate for arithmetic IF "
                     "statement at %C");
          gfc_free_expr (expr);
          return MATCH_ERROR;
        }

      if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
          || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
          || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
        {
          gfc_free_expr (expr);
          return MATCH_ERROR;
        }
      
      if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Arithmetic IF "
                          "statement at %C") == FAILURE)
        return MATCH_ERROR;

      new_st.op = EXEC_ARITHMETIC_IF;
      new_st.expr1 = expr;
      new_st.label1 = l1;
      new_st.label2 = l2;
      new_st.label3 = l3;

      *if_type = ST_ARITHMETIC_IF;
      return MATCH_YES;
    }

  if (gfc_match (" then%t") == MATCH_YES)
    {
      new_st.op = EXEC_IF;
      new_st.expr1 = expr;
      *if_type = ST_IF_BLOCK;
      return MATCH_YES;
    }

  if (n == MATCH_YES)
    {
      gfc_error ("Block label is not appropriate for IF statement at %C");
      gfc_free_expr (expr);
      return MATCH_ERROR;
    }

  /* At this point the only thing left is a simple IF statement.  At
     this point, n has to be MATCH_NO, so we don't have to worry about
     re-matching a block label.  From what we've got so far, try
     matching an assignment.  */

  *if_type = ST_SIMPLE_IF;

  m = gfc_match_assignment ();
  if (m == MATCH_YES)
    goto got_match;

  gfc_free_expr (expr);
  gfc_undo_symbols ();
  gfc_current_locus = old_loc;

  /* m can be MATCH_NO or MATCH_ERROR, here.  For MATCH_ERROR, a mangled
     assignment was found.  For MATCH_NO, continue to call the various
     matchers.  */
  if (m == MATCH_ERROR)
    return MATCH_ERROR;

  gfc_match (" if ( %e ) ", &expr);     /* Guaranteed to match.  */

  m = gfc_match_pointer_assignment ();
  if (m == MATCH_YES)
    goto got_match;

  gfc_free_expr (expr);
  gfc_undo_symbols ();
  gfc_current_locus = old_loc;

  gfc_match (" if ( %e ) ", &expr);     /* Guaranteed to match.  */

  /* Look at the next keyword to see which matcher to call.  Matching
     the keyword doesn't affect the symbol table, so we don't have to
     restore between tries.  */

#define match(string, subr, statement) \
  if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }

  gfc_clear_error ();

  match ("allocate", gfc_match_allocate, ST_ALLOCATE)
  match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
  match ("backspace", gfc_match_backspace, ST_BACKSPACE)
  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 ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
  match ("end file", gfc_match_endfile, ST_END_FILE)
  match ("error stop", gfc_match_error_stop, ST_ERROR_STOP)
  match ("exit", gfc_match_exit, ST_EXIT)
  match ("flush", gfc_match_flush, ST_FLUSH)
  match ("forall", match_simple_forall, ST_FORALL)
  match ("go to", gfc_match_goto, ST_GOTO)
  match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
  match ("inquire", gfc_match_inquire, ST_INQUIRE)
  match ("nullify", gfc_match_nullify, ST_NULLIFY)
  match ("open", gfc_match_open, ST_OPEN)
  match ("pause", gfc_match_pause, ST_NONE)
  match ("print", gfc_match_print, ST_WRITE)
  match ("read", gfc_match_read, ST_READ)
  match ("return", gfc_match_return, ST_RETURN)
  match ("rewind", gfc_match_rewind, ST_REWIND)
  match ("stop", gfc_match_stop, ST_STOP)
  match ("wait", gfc_match_wait, ST_WAIT)
  match ("sync all", gfc_match_sync_all, ST_SYNC_CALL);
  match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
  match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
  match ("where", match_simple_where, ST_WHERE)
  match ("write", gfc_match_write, ST_WRITE)

  /* The gfc_match_assignment() above may have returned a MATCH_NO
     where the assignment was to a named constant.  Check that 
     special case here.  */
  m = gfc_match_assignment ();
  if (m == MATCH_NO)
   {
      gfc_error ("Cannot assign to a named constant at %C");
      gfc_free_expr (expr);
      gfc_undo_symbols ();
      gfc_current_locus = old_loc;
      return MATCH_ERROR;
   }

  /* 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 ("Unclassifiable statement in IF-clause at %C");

  gfc_free_expr (expr);
  return MATCH_ERROR;

got_match:
  if (m == MATCH_NO)
    gfc_error ("Syntax error in IF-clause at %C");
  if (m != MATCH_YES)
    {
      gfc_free_expr (expr);
      return MATCH_ERROR;
    }

  /* At this point, we've matched the single IF and the action clause
     is in new_st.  Rearrange things so that the IF statement appears
     in new_st.  */

  p = gfc_get_code ();
  p->next = gfc_get_code ();
  *p->next = new_st;
  p->next->loc = gfc_current_locus;

  p->expr1 = expr;
  p->op = EXEC_IF;

  gfc_clear_new_st ();

  new_st.op = EXEC_IF;
  new_st.block = p;

  return MATCH_YES;
}

#undef match


/* Match an ELSE statement.  */

match
gfc_match_else (void)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];

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

  if (gfc_match_name (name) != MATCH_YES
      || gfc_current_block () == NULL
      || gfc_match_eos () != MATCH_YES)
    {
      gfc_error ("Unexpected junk after ELSE statement at %C");
      return MATCH_ERROR;
    }

  if (strcmp (name, gfc_current_block ()->name) != 0)
    {
      gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
                 name, gfc_current_block ()->name);
      return MATCH_ERROR;
    }

  return MATCH_YES;
}


/* Match an ELSE IF statement.  */

match
gfc_match_elseif (void)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_expr *expr;
  match m;

  m = gfc_match (" ( %e ) then", &expr);
  if (m != MATCH_YES)
    return m;

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

  if (gfc_match_name (name) != MATCH_YES
      || gfc_current_block () == NULL
      || gfc_match_eos () != MATCH_YES)
    {
      gfc_error ("Unexpected junk after ELSE IF statement at %C");
      goto cleanup;
    }

  if (strcmp (name, gfc_current_block ()->name) != 0)
    {
      gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
                 name, gfc_current_block ()->name);
      goto cleanup;
    }

done:
  new_st.op = EXEC_IF;
  new_st.expr1 = expr;
  return MATCH_YES;

cleanup:
  gfc_free_expr (expr);
  return MATCH_ERROR;
}


/* Free a gfc_iterator structure.  */

void
gfc_free_iterator (gfc_iterator *iter, int flag)
{

  if (iter == NULL)
    return;

  gfc_free_expr (iter->var);
  gfc_free_expr (iter->start);
  gfc_free_expr (iter->end);
  gfc_free_expr (iter->step);

  if (flag)
    gfc_free (iter);
}


/* Match a CRITICAL statement.  */
match
gfc_match_critical (void)
{
  gfc_st_label *label = NULL;

  if (gfc_match_label () == MATCH_ERROR)
    return MATCH_ERROR;

  if (gfc_match (" critical") != MATCH_YES)
    return MATCH_NO;

  if (gfc_match_st_label (&label) == MATCH_ERROR)
    return MATCH_ERROR;

  if (gfc_match_eos () != MATCH_YES)
    {
      gfc_syntax_error (ST_CRITICAL);
      return MATCH_ERROR;
    }

  if (gfc_pure (NULL))
    {
      gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
      return MATCH_ERROR;
    }

  if (gfc_implicit_pure (NULL))
    gfc_current_ns->proc_name->attr.implicit_pure = 0;

  if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CRITICAL statement at %C")
      == FAILURE)
    return MATCH_ERROR;

  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
    {
       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
       return MATCH_ERROR;
    }

  if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
    {
      gfc_error ("Nested CRITICAL block at %C");
      return MATCH_ERROR;
    }

  new_st.op = EXEC_CRITICAL;

  if (label != NULL
      && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
    return MATCH_ERROR;

  return MATCH_YES;
}


/* Match a BLOCK statement.  */

match
gfc_match_block (void)
{
  match m;

  if (gfc_match_label () == MATCH_ERROR)
    return MATCH_ERROR;

  if (gfc_match (" block") != MATCH_YES)
    return MATCH_NO;

  /* For this to be a correct BLOCK statement, the line must end now.  */
  m = gfc_match_eos ();
  if (m == MATCH_ERROR)
    return MATCH_ERROR;
  if (m == MATCH_NO)
    return MATCH_NO;

  return MATCH_YES;
}


/* Match an ASSOCIATE statement.  */

match
gfc_match_associate (void)
{
  if (gfc_match_label () == MATCH_ERROR)
    return MATCH_ERROR;

  if (gfc_match (" associate") != MATCH_YES)
    return MATCH_NO;

  /* Match the association list.  */
  if (gfc_match_char ('(') != MATCH_YES)
    {
      gfc_error ("Expected association list at %C");
      return MATCH_ERROR;
    }
  new_st.ext.block.assoc = NULL;
  while (true)
    {
      gfc_association_list* newAssoc = gfc_get_association_list ();
      gfc_association_list* a;

      /* Match the next association.  */
      if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target)
            != MATCH_YES)
        {
          gfc_error ("Expected association at %C");
          goto assocListError;
        }
      newAssoc->where = gfc_current_locus;

      /* Check that the current name is not yet in the list.  */
      for (a = new_st.ext.block.assoc; a; a = a->next)
        if (!strcmp (a->name, newAssoc->name))
          {
            gfc_error ("Duplicate name '%s' in association at %C",
                       newAssoc->name);
            goto assocListError;
          }

      /* The target expression must not be coindexed.  */
      if (gfc_is_coindexed (newAssoc->target))
        {
          gfc_error ("Association target at %C must not be coindexed");
          goto assocListError;
        }

      /* The `variable' field is left blank for now; because the target is not
         yet resolved, we can't use gfc_has_vector_subscript to determine it
         for now.  This is set during resolution.  */

      /* Put it into the list.  */
      newAssoc->next = new_st.ext.block.assoc;
      new_st.ext.block.assoc = newAssoc;

      /* Try next one or end if closing parenthesis is found.  */
      gfc_gobble_whitespace ();
      if (gfc_peek_char () == ')')
        break;
      if (gfc_match_char (',') != MATCH_YES)
        {
          gfc_error ("Expected ')' or ',' at %C");
          return MATCH_ERROR;
        }

      continue;

assocListError:
      gfc_free (newAssoc);
      goto error;
    }
  if (gfc_match_char (')') != MATCH_YES)
    {
      /* This should never happen as we peek above.  */
      gcc_unreachable ();
    }

  if (gfc_match_eos () != MATCH_YES)
    {
      gfc_error ("Junk after ASSOCIATE statement at %C");
      goto error;
    }

  return MATCH_YES;

error:
  gfc_free_association_list (new_st.ext.block.assoc);
  return MATCH_ERROR;
}


/* Match a DO statement.  */

match
gfc_match_do (void)
{
  gfc_iterator iter, *ip;
  locus old_loc;
  gfc_st_label *label;
  match m;

  old_loc = gfc_current_locus;

  label = NULL;
  iter.var = iter.start = iter.end = iter.step = NULL;

  m = gfc_match_label ();
  if (m == MATCH_ERROR)
    return m;

  if (gfc_match (" do") != MATCH_YES)
    return MATCH_NO;

  m = gfc_match_st_label (&label);
  if (m == MATCH_ERROR)
    goto cleanup;

  /* Match an infinite DO, make it like a DO WHILE(.TRUE.).  */

  if (gfc_match_eos () == MATCH_YES)
    {
      iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true);
      new_st.op = EXEC_DO_WHILE;
      goto done;
    }

  /* Match an optional comma, if no comma is found, a space is obligatory.  */
  if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
    return MATCH_NO;

  /* Check for balanced parens.  */
  
  if (gfc_match_parens () == MATCH_ERROR)
    return MATCH_ERROR;

  /* See if we have a DO WHILE.  */
  if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
    {
      new_st.op = EXEC_DO_WHILE;
      goto done;
    }

  /* The abortive DO WHILE may have done something to the symbol
     table, so we start over.  */
  gfc_undo_symbols ();
  gfc_current_locus = old_loc;

  gfc_match_label ();           /* This won't error.  */
  gfc_match (" do ");           /* This will work.  */

  gfc_match_st_label (&label);  /* Can't error out.  */
  gfc_match_char (',');         /* Optional comma.  */

  m = gfc_match_iterator (&iter, 0);
  if (m == MATCH_NO)
    return MATCH_NO;
  if (m == MATCH_ERROR)
    goto cleanup;

  iter.var->symtree->n.sym->attr.implied_index = 0;
  gfc_check_do_variable (iter.var->symtree);

  if (gfc_match_eos () != MATCH_YES)
    {
      gfc_syntax_error (ST_DO);
      goto cleanup;
    }

  new_st.op = EXEC_DO;

done:
  if (label != NULL
      && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
    goto cleanup;

  new_st.label1 = label;

  if (new_st.op == EXEC_DO_WHILE)
    new_st.expr1 = iter.end;
  else
    {
      new_st.ext.iterator = ip = gfc_get_iterator ();
      *ip = iter;
    }

  return MATCH_YES;

cleanup:
  gfc_free_iterator (&iter, 0);

  return MATCH_ERROR;
}


/* Match an EXIT or CYCLE statement.  */

static match
match_exit_cycle (gfc_statement st, gfc_exec_op op)
{
  gfc_state_data *p, *o;
  gfc_symbol *sym;
  match m;
  int cnt;

  if (gfc_match_eos () == MATCH_YES)
    sym = NULL;
  else
    {
      char name[GFC_MAX_SYMBOL_LEN + 1];
      gfc_symtree* stree;

      m = gfc_match ("% %n%t", name);
      if (m == MATCH_ERROR)
        return MATCH_ERROR;
      if (m == MATCH_NO)
        {
          gfc_syntax_error (st);
          return MATCH_ERROR;
        }

      /* Find the corresponding symbol.  If there's a BLOCK statement
         between here and the label, it is not in gfc_current_ns but a parent
         namespace!  */
      stree = gfc_find_symtree_in_proc (name, gfc_current_ns);
      if (!stree)
        {
          gfc_error ("Name '%s' in %s statement at %C is unknown",
                     name, gfc_ascii_statement (st));
          return MATCH_ERROR;
        }

      sym = stree->n.sym;
      if (sym->attr.flavor != FL_LABEL)
        {
          gfc_error ("Name '%s' in %s statement at %C is not a construct name",
                     name, gfc_ascii_statement (st));
          return MATCH_ERROR;
        }
    }

  /* Find the loop specified by the label (or lack of a label).  */
  for (o = NULL, p = gfc_state_stack; p; p = p->previous)
    if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
      o = p;
    else if (p->state == COMP_CRITICAL)
      {
        gfc_error("%s statement at %C leaves CRITICAL construct",
                  gfc_ascii_statement (st));
        return MATCH_ERROR;
      }
    else if ((sym && sym == p->sym) || (!sym && p->state == COMP_DO))
      break;

  if (p == NULL)
    {
      if (sym == NULL)
        gfc_error ("%s statement at %C is not within a construct",
                   gfc_ascii_statement (st));
      else
        gfc_error ("%s statement at %C is not within construct '%s'",
                   gfc_ascii_statement (st), sym->name);

      return MATCH_ERROR;
    }

  /* Special checks for EXIT from non-loop constructs.  */
  switch (p->state)
    {
    case COMP_DO:
      break;

    case COMP_CRITICAL:
      /* This is already handled above.  */
      gcc_unreachable ();

    case COMP_ASSOCIATE:
    case COMP_BLOCK:
    case COMP_IF:
    case COMP_SELECT:
    case COMP_SELECT_TYPE:
      gcc_assert (sym);
      if (op == EXEC_CYCLE)
        {
          gfc_error ("CYCLE statement at %C is not applicable to non-loop"
                     " construct '%s'", sym->name);
          return MATCH_ERROR;
        }
      gcc_assert (op == EXEC_EXIT);
      if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: EXIT statement with no"
                          " do-construct-name at %C") == FAILURE)
        return MATCH_ERROR;
      break;
      
    default:
      gfc_error ("%s statement at %C is not applicable to construct '%s'",
                 gfc_ascii_statement (st), sym->name);
      return MATCH_ERROR;
    }

  if (o != NULL)
    {
      gfc_error ("%s statement at %C leaving OpenMP structured block",
                 gfc_ascii_statement (st));
      return MATCH_ERROR;
    }

  for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++)
    o = o->previous;
  if (cnt > 0
      && o != NULL
      && o->state == COMP_OMP_STRUCTURED_BLOCK
      && (o->head->op == EXEC_OMP_DO
          || o->head->op == EXEC_OMP_PARALLEL_DO))
    {
      int collapse = 1;
      gcc_assert (o->head->next != NULL
                  && (o->head->next->op == EXEC_DO
                      || o->head->next->op == EXEC_DO_WHILE)
                  && o->previous != NULL
                  && o->previous->tail->op == o->head->op);
      if (o->previous->tail->ext.omp_clauses != NULL
          && o->previous->tail->ext.omp_clauses->collapse > 1)
        collapse = o->previous->tail->ext.omp_clauses->collapse;
      if (st == ST_EXIT && cnt <= collapse)
        {
          gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
          return MATCH_ERROR;
        }
      if (st == ST_CYCLE && cnt < collapse)
        {
          gfc_error ("CYCLE statement at %C to non-innermost collapsed"
                     " !$OMP DO loop");
          return MATCH_ERROR;
        }
    }

  /* Save the first statement in the construct - needed by the backend.  */
  new_st.ext.which_construct = p->construct;

  new_st.op = op;

  return MATCH_YES;
}


/* Match the EXIT statement.  */

match
gfc_match_exit (void)
{
  return match_exit_cycle (ST_EXIT, EXEC_EXIT);
}


/* Match the CYCLE statement.  */

match
gfc_match_cycle (void)
{
  return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
}


/* Match a number or character constant after an (ALL) STOP or PAUSE statement.  */

static match
gfc_match_stopcode (gfc_statement st)
{
  gfc_expr *e;
  match m;

  e = NULL;

  if (gfc_match_eos () != MATCH_YES)
    {
      m = gfc_match_init_expr (&e);
      if (m == MATCH_ERROR)
        goto cleanup;
      if (m == MATCH_NO)
        goto syntax;

      if (gfc_match_eos () != MATCH_YES)
        goto syntax;
    }

  if (gfc_pure (NULL))
    {
      gfc_error ("%s statement not allowed in PURE procedure at %C",
                 gfc_ascii_statement (st));
      goto cleanup;
    }

  if (gfc_implicit_pure (NULL))
    gfc_current_ns->proc_name->attr.implicit_pure = 0;

  if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS)
    {
      gfc_error ("Image control statement STOP at %C in CRITICAL block");
      goto cleanup;
    }

  if (e != NULL)
    {
      if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER))
        {
          gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
                     &e->where);
          goto cleanup;
        }

      if (e->rank != 0)
        {
          gfc_error ("STOP code at %L must be scalar",
                     &e->where);
          goto cleanup;
        }

      if (e->ts.type == BT_CHARACTER
          && e->ts.kind != gfc_default_character_kind)
        {
          gfc_error ("STOP code at %L must be default character KIND=%d",
                     &e->where, (int) gfc_default_character_kind);
          goto cleanup;
        }

      if (e->ts.type == BT_INTEGER
          && e->ts.kind != gfc_default_integer_kind)
        {
          gfc_error ("STOP code at %L must be default integer KIND=%d",
                     &e->where, (int) gfc_default_integer_kind);
          goto cleanup;
        }
    }

  switch (st)
    {
    case ST_STOP:
      new_st.op = EXEC_STOP;
      break;
    case ST_ERROR_STOP:
      new_st.op = EXEC_ERROR_STOP;
      break;
    case ST_PAUSE:
      new_st.op = EXEC_PAUSE;
      break;
    default:
      gcc_unreachable ();
    }

  new_st.expr1 = e;
  new_st.ext.stop_code = -1;

  return MATCH_YES;

syntax:
  gfc_syntax_error (st);

cleanup:

  gfc_free_expr (e);
  return MATCH_ERROR;
}


/* Match the (deprecated) PAUSE statement.  */

match
gfc_match_pause (void)
{
  match m;

  m = gfc_match_stopcode (ST_PAUSE);
  if (m == MATCH_YES)
    {
      if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement"
          " at %C")
          == FAILURE)
        m = MATCH_ERROR;
    }
  return m;
}


/* Match the STOP statement.  */

match
gfc_match_stop (void)
{
  return gfc_match_stopcode (ST_STOP);
}


/* Match the ERROR STOP statement.  */

match
gfc_match_error_stop (void)
{
  if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: ERROR STOP statement at %C")
      == FAILURE)
    return MATCH_ERROR;

  return gfc_match_stopcode (ST_ERROR_STOP);
}


/* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
     SYNC ALL [(sync-stat-list)]
     SYNC MEMORY [(sync-stat-list)]
     SYNC IMAGES (image-set [, sync-stat-list] )
   with sync-stat is int-expr or *.  */

static match
sync_statement (gfc_statement st)
{
  match m;
  gfc_expr *tmp, *imageset, *stat, *errmsg;
  bool saw_stat, saw_errmsg;

  tmp = imageset = stat = errmsg = NULL;
  saw_stat = saw_errmsg = false;

  if (gfc_pure (NULL))
    {
      gfc_error ("Image control statement SYNC at %C in PURE procedure");
      return MATCH_ERROR;
    }

  if (gfc_implicit_pure (NULL))
    gfc_current_ns->proc_name->attr.implicit_pure = 0;

  if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SYNC statement at %C")
      == FAILURE)
    return MATCH_ERROR;

  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
    {
       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
       return MATCH_ERROR;
    }

  if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
    {
      gfc_error ("Image control statement SYNC at %C in CRITICAL block");
      return MATCH_ERROR;
    }
        
  if (gfc_match_eos () == MATCH_YES)
    {
      if (st == ST_SYNC_IMAGES)
        goto syntax;
      goto done;
    }

  if (gfc_match_char ('(') != MATCH_YES)
    goto syntax;

  if (st == ST_SYNC_IMAGES)
    {
      /* Denote '*' as imageset == NULL.  */
      m = gfc_match_char ('*');
      if (m == MATCH_ERROR)
        goto syntax;
      if (m == MATCH_NO)
        {
          if (gfc_match ("%e", &imageset) != MATCH_YES)
            goto syntax;
        }
      m = gfc_match_char (',');
      if (m == MATCH_ERROR)
        goto syntax;
      if (m == MATCH_NO)
        {
          m = gfc_match_char (')');
          if (m == MATCH_YES)
            goto done;
          goto syntax;
        }
    }

  for (;;)
    {
      m = gfc_match (" stat = %v", &tmp);
      if (m == MATCH_ERROR)
        goto syntax;
      if (m == MATCH_YES)
        {
          if (saw_stat)
            {
              gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
              goto cleanup;
            }
          stat = tmp;
          saw_stat = true;

          if (gfc_match_char (',') == MATCH_YES)
            continue;
        }

      m = gfc_match (" errmsg = %v", &tmp);
      if (m == MATCH_ERROR)
        goto syntax;
      if (m == MATCH_YES)
        {
          if (saw_errmsg)
            {
              gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
              goto cleanup;
            }
          errmsg = tmp;
          saw_errmsg = true;

          if (gfc_match_char (',') == MATCH_YES)
            continue;
        }

      gfc_gobble_whitespace ();

      if (gfc_peek_char () == ')')
        break;

      goto syntax;
    }

  if (gfc_match (" )%t") != MATCH_YES)
    goto syntax;

done:
  switch (st)
    {
    case ST_SYNC_ALL:
      new_st.op = EXEC_SYNC_ALL;
      break;
    case ST_SYNC_IMAGES:
      new_st.op = EXEC_SYNC_IMAGES;
      break;
    case ST_SYNC_MEMORY:
      new_st.op = EXEC_SYNC_MEMORY;
      break;
    default:
      gcc_unreachable ();
    }

  new_st.expr1 = imageset;
  new_st.expr2 = stat;
  new_st.expr3 = errmsg;

  return MATCH_YES;

syntax:
  gfc_syntax_error (st);

cleanup:
  gfc_free_expr (tmp);
  gfc_free_expr (imageset);
  gfc_free_expr (stat);
  gfc_free_expr (errmsg);

  return MATCH_ERROR;
}


/* Match SYNC ALL statement.  */

match
gfc_match_sync_all (void)
{
  return sync_statement (ST_SYNC_ALL);
}


/* Match SYNC IMAGES statement.  */

match
gfc_match_sync_images (void)
{
  return sync_statement (ST_SYNC_IMAGES);
}


/* Match SYNC MEMORY statement.  */

match
gfc_match_sync_memory (void)
{
  return sync_statement (ST_SYNC_MEMORY);
}


/* Match a CONTINUE statement.  */

match
gfc_match_continue (void)
{
  if (gfc_match_eos () != MATCH_YES)
    {
      gfc_syntax_error (ST_CONTINUE);
      return MATCH_ERROR;
    }

  new_st.op = EXEC_CONTINUE;
  return MATCH_YES;
}


/* Match the (deprecated) ASSIGN statement.  */

match
gfc_match_assign (void)
{
  gfc_expr *expr;
  gfc_st_label *label;

  if (gfc_match (" %l", &label) == MATCH_YES)
    {
      if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
        return MATCH_ERROR;
      if (gfc_match (" to %v%t", &expr) == MATCH_YES)
        {
          if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN "
                              "statement at %C")
              == FAILURE)
            return MATCH_ERROR;

          expr->symtree->n.sym->attr.assign = 1;

          new_st.op = EXEC_LABEL_ASSIGN;
          new_st.label1 = label;
          new_st.expr1 = expr;
          return MATCH_YES;
        }
    }
  return MATCH_NO;
}


/* Match the GO TO statement.  As a computed GOTO statement is
   matched, it is transformed into an equivalent SELECT block.  No
   tree is necessary, and the resulting jumps-to-jumps are
   specifically optimized away by the back end.  */

match
gfc_match_goto (void)
{
  gfc_code *head, *tail;
  gfc_expr *expr;
  gfc_case *cp;
  gfc_st_label *label;
  int i;
  match m;

  if (gfc_match (" %l%t", &label) == MATCH_YES)
    {
      if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
        return MATCH_ERROR;

      new_st.op = EXEC_GOTO;
      new_st.label1 = label;
      return MATCH_YES;
    }

  /* The assigned GO TO statement.  */ 

  if (gfc_match_variable (&expr, 0) == MATCH_YES)
    {
      if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO "
                          "statement at %C")
          == FAILURE)
        return MATCH_ERROR;

      new_st.op = EXEC_GOTO;
      new_st.expr1 = expr;

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

      /* Match label list.  */
      gfc_match_char (',');
      if (gfc_match_char ('(') != MATCH_YES)
        {
          gfc_syntax_error (ST_GOTO);
          return MATCH_ERROR;
        }
      head = tail = NULL;

      do
        {
          m = gfc_match_st_label (&label);
          if (m != MATCH_YES)
            goto syntax;

          if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
            goto cleanup;

          if (head == NULL)
            head = tail = gfc_get_code ();
          else
            {
              tail->block = gfc_get_code ();
              tail = tail->block;
            }

          tail->label1 = label;
          tail->op = EXEC_GOTO;
        }
      while (gfc_match_char (',') == MATCH_YES);

      if (gfc_match (")%t") != MATCH_YES)
        goto syntax;

      if (head == NULL)
        {
           gfc_error ("Statement label list in GOTO at %C cannot be empty");
           goto syntax;
        }
      new_st.block = head;

      return MATCH_YES;
    }

  /* Last chance is a computed GO TO statement.  */
  if (gfc_match_char ('(') != MATCH_YES)
    {
      gfc_syntax_error (ST_GOTO);
      return MATCH_ERROR;
    }

  head = tail = NULL;
  i = 1;

  do
    {
      m = gfc_match_st_label (&label);
      if (m != MATCH_YES)
        goto syntax;

      if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
        goto cleanup;

      if (head == NULL)
        head = tail = gfc_get_code ();
      else
        {
          tail->block = gfc_get_code ();
          tail = tail->block;
        }

      cp = gfc_get_case ();
      cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind,
                                             NULL, i++);

      tail->op = EXEC_SELECT;
      tail->ext.block.case_list = cp;

      tail->next = gfc_get_code ();
      tail->next->op = EXEC_GOTO;
      tail->next->label1 = label;
    }
  while (gfc_match_char (',') == MATCH_YES);

  if (gfc_match_char (')') != MATCH_YES)
    goto syntax;

  if (head == NULL)
    {
      gfc_error ("Statement label list in GOTO at %C cannot be empty");
      goto syntax;
    }

  /* Get the rest of the statement.  */
  gfc_match_char (',');

  if (gfc_match (" %e%t", &expr) != MATCH_YES)
    goto syntax;

  if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Computed GOTO "
                      "at %C") == FAILURE)
    return MATCH_ERROR;

  /* At this point, a computed GOTO has been fully matched and an
     equivalent SELECT statement constructed.  */

  new_st.op = EXEC_SELECT;
  new_st.expr1 = NULL;

  /* Hack: For a "real" SELECT, the expression is in expr. We put
     it in expr2 so we can distinguish then and produce the correct
     diagnostics.  */
  new_st.expr2 = expr;
  new_st.block = head;
  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_GOTO);
cleanup:
  gfc_free_statements (head);
  return MATCH_ERROR;
}


/* Frees a list of gfc_alloc structures.  */

void
gfc_free_alloc_list (gfc_alloc *p)
{
  gfc_alloc *q;

  for (; p; p = q)
    {
      q = p->next;
      gfc_free_expr (p->expr);
      gfc_free (p);
    }
}


/* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
   an accessible derived type.  */

static match
match_derived_type_spec (gfc_typespec *ts)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  locus old_locus; 
  gfc_symbol *derived;

  old_locus = gfc_current_locus;

  if (gfc_match ("%n", name) != MATCH_YES)
    {
       gfc_current_locus = old_locus;
       return MATCH_NO;
    }

  gfc_find_symbol (name, NULL, 1, &derived);

  if (derived && derived->attr.flavor == FL_DERIVED)
    {
      ts->type = BT_DERIVED;
      ts->u.derived = derived;
      return MATCH_YES;
    }

  gfc_current_locus = old_locus; 
  return MATCH_NO;
}


/* Match a Fortran 2003 type-spec (F03:R401).  This is similar to
   gfc_match_decl_type_spec() from decl.c, with the following exceptions:
   It only includes the intrinsic types from the Fortran 2003 standard
   (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
   the implicit_flag is not needed, so it was removed. Derived types are
   identified by their name alone.  */

static match
match_type_spec (gfc_typespec *ts)
{
  match m;
  locus old_locus;

  gfc_clear_ts (ts);
  gfc_gobble_whitespace ();
  old_locus = gfc_current_locus;

  if (match_derived_type_spec (ts) == MATCH_YES)
    {
      /* Enforce F03:C401.  */
      if (ts->u.derived->attr.abstract)
        {
          gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
                     ts->u.derived->name, &old_locus);
          return MATCH_ERROR;
        }
      return MATCH_YES;
    }

  if (gfc_match ("integer") == MATCH_YES)
    {
      ts->type = BT_INTEGER;
      ts->kind = gfc_default_integer_kind;
      goto kind_selector;
    }

  if (gfc_match ("real") == MATCH_YES)
    {
      ts->type = BT_REAL;
      ts->kind = gfc_default_real_kind;
      goto kind_selector;
    }

  if (gfc_match ("double precision") == MATCH_YES)
    {
      ts->type = BT_REAL;
      ts->kind = gfc_default_double_kind;
      return MATCH_YES;
    }

  if (gfc_match ("complex") == MATCH_YES)
    {
      ts->type = BT_COMPLEX;
      ts->kind = gfc_default_complex_kind;
      goto kind_selector;
    }

  if (gfc_match ("character") == MATCH_YES)
    {
      ts->type = BT_CHARACTER;

      m = gfc_match_char_spec (ts);

      if (m == MATCH_NO)
        m = MATCH_YES;

      return m;
    }

  if (gfc_match ("logical") == MATCH_YES)
    {
      ts->type = BT_LOGICAL;
      ts->kind = gfc_default_logical_kind;
      goto kind_selector;
    }

  /* If a type is not matched, simply return MATCH_NO.  */
  gfc_current_locus = old_locus;
  return MATCH_NO;

kind_selector:

  gfc_gobble_whitespace ();
  if (gfc_peek_ascii_char () == '*')
    {
      gfc_error ("Invalid type-spec at %C");
      return MATCH_ERROR;
    }

  m = gfc_match_kind_spec (ts, false);

  if (m == MATCH_NO)
    m = MATCH_YES;              /* No kind specifier found.  */

  return m;
}


/* Match an ALLOCATE statement.  */

match
gfc_match_allocate (void)
{
  gfc_alloc *head, *tail;
  gfc_expr *stat, *errmsg, *tmp, *source, *mold;
  gfc_typespec ts;
  gfc_symbol *sym;
  match m;
  locus old_locus, deferred_locus;
  bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;

  head = tail = NULL;
  stat = errmsg = source = mold = tmp = NULL;
  saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;

  if (gfc_match_char ('(') != MATCH_YES)
    goto syntax;

  /* Match an optional type-spec.  */
  old_locus = gfc_current_locus;
  m = match_type_spec (&ts);
  if (m == MATCH_ERROR)
    goto cleanup;
  else if (m == MATCH_NO)
    {
      char name[GFC_MAX_SYMBOL_LEN + 3];

      if (gfc_match ("%n :: ", name) == MATCH_YES)
        {
          gfc_error ("Error in type-spec at %L", &old_locus);
          goto cleanup;
        }

      ts.type = BT_UNKNOWN;
    }
  else
    {
      if (gfc_match (" :: ") == MATCH_YES)
        {
          if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in "
                              "ALLOCATE at %L", &old_locus) == FAILURE)
            goto cleanup;

          if (ts.deferred)
            {
              gfc_error ("Type-spec at %L cannot contain a deferred "
                         "type parameter", &old_locus);
              goto cleanup;
            }
        }
      else
        {
          ts.type = BT_UNKNOWN;
          gfc_current_locus = old_locus;
        }
    }

  for (;;)
    {
      if (head == NULL)
        head = tail = gfc_get_alloc ();
      else
        {
          tail->next = gfc_get_alloc ();
          tail = tail->next;
        }

      m = gfc_match_variable (&tail->expr, 0);
      if (m == MATCH_NO)
        goto syntax;
      if (m == MATCH_ERROR)
        goto cleanup;

      if (gfc_check_do_variable (tail->expr->symtree))
        goto cleanup;

      if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
        {
          gfc_error ("Bad allocate-object at %C for a PURE procedure");
          goto cleanup;
        }

      if (gfc_implicit_pure (NULL)
            && gfc_impure_variable (tail->expr->symtree->n.sym))
        gfc_current_ns->proc_name->attr.implicit_pure = 0;

      if (tail->expr->ts.deferred)
        {
          saw_deferred = true;
          deferred_locus = tail->expr->where;
        }

      /* The ALLOCATE statement had an optional typespec.  Check the
         constraints.  */
      if (ts.type != BT_UNKNOWN)
        {
          /* Enforce F03:C624.  */
          if (!gfc_type_compatible (&tail->expr->ts, &ts))
            {
              gfc_error ("Type of entity at %L is type incompatible with "
                         "typespec", &tail->expr->where);
              goto cleanup;
            }

          /* Enforce F03:C627.  */
          if (ts.kind != tail->expr->ts.kind)
            {
              gfc_error ("Kind type parameter for entity at %L differs from "
                         "the kind type parameter of the typespec",
                         &tail->expr->where);
              goto cleanup;
            }
        }

      if (tail->expr->ts.type == BT_DERIVED)
        tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);

      /* FIXME: disable the checking on derived types and arrays.  */
      sym = tail->expr->symtree->n.sym;
      b1 = !(tail->expr->ref
           && (tail->expr->ref->type == REF_COMPONENT
                || tail->expr->ref->type == REF_ARRAY));
      if (sym && sym->ts.type == BT_CLASS && sym->attr.class_ok)
        b2 = !(CLASS_DATA (sym)->attr.allocatable
               || CLASS_DATA (sym)->attr.class_pointer);
      else
        b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
                      || sym->attr.proc_pointer);
      b3 = sym && sym->ns && sym->ns->proc_name
           && (sym->ns->proc_name->attr.allocatable
                || sym->ns->proc_name->attr.pointer
                || sym->ns->proc_name->attr.proc_pointer);
      if (b1 && b2 && !b3)
        {
          gfc_error ("Allocate-object at %L is not a nonprocedure pointer "
                     "or an allocatable variable", &tail->expr->where);
          goto cleanup;
        }

      if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
        {
          gfc_error ("Shape specification for allocatable scalar at %C");
          goto cleanup;
        }

      if (gfc_match_char (',') != MATCH_YES)
        break;

alloc_opt_list:

      m = gfc_match (" stat = %v", &tmp);
      if (m == MATCH_ERROR)
        goto cleanup;
      if (m == MATCH_YES)
        {
          /* Enforce C630.  */
          if (saw_stat)
            {
              gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
              goto cleanup;
            }

          stat = tmp;
          tmp = NULL;
          saw_stat = true;

          if (gfc_check_do_variable (stat->symtree))
            goto cleanup;

          if (gfc_match_char (',') == MATCH_YES)
            goto alloc_opt_list;
        }

      m = gfc_match (" errmsg = %v", &tmp);
      if (m == MATCH_ERROR)
        goto cleanup;
      if (m == MATCH_YES)
        {
          if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG tag at %L",
                              &tmp->where) == FAILURE)
            goto cleanup;

          /* Enforce C630.  */
          if (saw_errmsg)
            {
              gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
              goto cleanup;
            }

          errmsg = tmp;
          tmp = NULL;
          saw_errmsg = true;

          if (gfc_match_char (',') == MATCH_YES)
            goto alloc_opt_list;
        }

      m = gfc_match (" source = %e", &tmp);
      if (m == MATCH_ERROR)
        goto cleanup;
      if (m == MATCH_YES)
        {
          if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SOURCE tag at %L",
                              &tmp->where) == FAILURE)
            goto cleanup;

          /* Enforce C630.  */
          if (saw_source)
            {
              gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
              goto cleanup;
            }

          /* The next 2 conditionals check C631.  */
          if (ts.type != BT_UNKNOWN)
            {
              gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
                         &tmp->where, &old_locus);
              goto cleanup;
            }

          if (head->next)
            {
              gfc_error ("SOURCE tag at %L requires only a single entity in "
                         "the allocation-list", &tmp->where);
              goto cleanup;
            }

          source = tmp;
          tmp = NULL;
          saw_source = true;

          if (gfc_match_char (',') == MATCH_YES)
            goto alloc_opt_list;
        }

      m = gfc_match (" mold = %e", &tmp);
      if (m == MATCH_ERROR)
        goto cleanup;
      if (m == MATCH_YES)
        {
          if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: MOLD tag at %L",
                              &tmp->where) == FAILURE)
            goto cleanup;

          /* Check F08:C636.  */
          if (saw_mold)
            {
              gfc_error ("Redundant MOLD tag found at %L ", &tmp->where);
              goto cleanup;
            }
  
          /* Check F08:C637.  */
          if (ts.type != BT_UNKNOWN)
            {
              gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
                         &tmp->where, &old_locus);
              goto cleanup;
            }

          mold = tmp;
          tmp = NULL;
          saw_mold = true;
          mold->mold = 1;

          if (gfc_match_char (',') == MATCH_YES)
            goto alloc_opt_list;
        }

        gfc_gobble_whitespace ();

        if (gfc_peek_char () == ')')
          break;
    }

  if (gfc_match (" )%t") != MATCH_YES)
    goto syntax;

  /* Check F08:C637.  */
  if (source && mold)
    {
      gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
                  &mold->where, &source->where);
      goto cleanup;
    }

  /* Check F03:C623,  */
  if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold)
    {
      gfc_error ("Allocate-object at %L with a deferred type parameter "
                 "requires either a type-spec or SOURCE tag or a MOLD tag",
                 &deferred_locus);
      goto cleanup;
    }
  
  new_st.op = EXEC_ALLOCATE;
  new_st.expr1 = stat;
  new_st.expr2 = errmsg;
  if (source)
    new_st.expr3 = source;
  else
    new_st.expr3 = mold;
  new_st.ext.alloc.list = head;
  new_st.ext.alloc.ts = ts;

  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_ALLOCATE);

cleanup:
  gfc_free_expr (errmsg);
  gfc_free_expr (source);
  gfc_free_expr (stat);
  gfc_free_expr (mold);
  if (tmp && tmp->expr_type) gfc_free_expr (tmp);
  gfc_free_alloc_list (head);
  return MATCH_ERROR;
}


/* Match a NULLIFY statement. A NULLIFY statement is transformed into
   a set of pointer assignments to intrinsic NULL().  */

match
gfc_match_nullify (void)
{
  gfc_code *tail;
  gfc_expr *e, *p;
  match m;

  tail = NULL;

  if (gfc_match_char ('(') != MATCH_YES)
    goto syntax;

  for (;;)
    {
      m = gfc_match_variable (&p, 0);
      if (m == MATCH_ERROR)
        goto cleanup;
      if (m == MATCH_NO)
        goto syntax;

      if (gfc_check_do_variable (p->symtree))
        goto cleanup;

      /* build ' => NULL() '.  */
      e = gfc_get_null_expr (&gfc_current_locus);

      /* Chain to list.  */
      if (tail == NULL)
        tail = &new_st;
      else
        {
          tail->next = gfc_get_code ();
          tail = tail->next;
        }

      tail->op = EXEC_POINTER_ASSIGN;
      tail->expr1 = p;
      tail->expr2 = e;

      if (gfc_match (" )%t") == MATCH_YES)
        break;
      if (gfc_match_char (',') != MATCH_YES)
        goto syntax;
    }

  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_NULLIFY);

cleanup:
  gfc_free_statements (new_st.next);
  new_st.next = NULL;
  gfc_free_expr (new_st.expr1);
  new_st.expr1 = NULL;
  gfc_free_expr (new_st.expr2);
  new_st.expr2 = NULL;
  return MATCH_ERROR;
}


/* Match a DEALLOCATE statement.  */

match
gfc_match_deallocate (void)
{
  gfc_alloc *head, *tail;
  gfc_expr *stat, *errmsg, *tmp;
  gfc_symbol *sym;
  match m;
  bool saw_stat, saw_errmsg, b1, b2;

  head = tail = NULL;
  stat = errmsg = tmp = NULL;
  saw_stat = saw_errmsg = false;

  if (gfc_match_char ('(') != MATCH_YES)
    goto syntax;

  for (;;)
    {
      if (head == NULL)
        head = tail = gfc_get_alloc ();
      else
        {
          tail->next = gfc_get_alloc ();
          tail = tail->next;
        }

      m = gfc_match_variable (&tail->expr, 0);
      if (m == MATCH_ERROR)
        goto cleanup;
      if (m == MATCH_NO)
        goto syntax;

      if (gfc_check_do_variable (tail->expr->symtree))
        goto cleanup;

      sym = tail->expr->symtree->n.sym;

      if (gfc_pure (NULL) && gfc_impure_variable (sym))
        {
          gfc_error ("Illegal allocate-object at %C for a PURE procedure");
          goto cleanup;
        }

      if (gfc_implicit_pure (NULL) && gfc_impure_variable (sym))
        gfc_current_ns->proc_name->attr.implicit_pure = 0;

      /* FIXME: disable the checking on derived types.  */
      b1 = !(tail->expr->ref
           && (tail->expr->ref->type == REF_COMPONENT
               || tail->expr->ref->type == REF_ARRAY));
      if (sym && sym->ts.type == BT_CLASS)
        b2 = !(CLASS_DATA (sym)->attr.allocatable
               || CLASS_DATA (sym)->attr.class_pointer);
      else
        b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
                      || sym->attr.proc_pointer);
      if (b1 && b2)
        {
          gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
                     "or an allocatable variable");
          goto cleanup;
        }

      if (gfc_match_char (',') != MATCH_YES)
        break;

dealloc_opt_list:

      m = gfc_match (" stat = %v", &tmp);
      if (m == MATCH_ERROR)
        goto cleanup;
      if (m == MATCH_YES)
        {
          if (saw_stat)
            {
              gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
              gfc_free_expr (tmp);
              goto cleanup;
            }

          stat = tmp;
          saw_stat = true;

          if (gfc_check_do_variable (stat->symtree))
            goto cleanup;

          if (gfc_match_char (',') == MATCH_YES)
            goto dealloc_opt_list;
        }

      m = gfc_match (" errmsg = %v", &tmp);
      if (m == MATCH_ERROR)
        goto cleanup;
      if (m == MATCH_YES)
        {
          if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
                              &tmp->where) == FAILURE)
            goto cleanup;

          if (saw_errmsg)
            {
              gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
              gfc_free_expr (tmp);
              goto cleanup;
            }

          errmsg = tmp;
          saw_errmsg = true;

          if (gfc_match_char (',') == MATCH_YES)
            goto dealloc_opt_list;
        }

        gfc_gobble_whitespace ();

        if (gfc_peek_char () == ')')
          break;
    }

  if (gfc_match (" )%t") != MATCH_YES)
    goto syntax;

  new_st.op = EXEC_DEALLOCATE;
  new_st.expr1 = stat;
  new_st.expr2 = errmsg;
  new_st.ext.alloc.list = head;

  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_DEALLOCATE);

cleanup:
  gfc_free_expr (errmsg);
  gfc_free_expr (stat);
  gfc_free_alloc_list (head);
  return MATCH_ERROR;
}


/* Match a RETURN statement.  */

match
gfc_match_return (void)
{
  gfc_expr *e;
  match m;
  gfc_compile_state s;

  e = NULL;

  if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
    {
      gfc_error ("Image control statement RETURN at %C in CRITICAL block");
      return MATCH_ERROR;
    }

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

  if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
    {
      gfc_error ("Alternate RETURN statement at %C is only allowed within "
                 "a SUBROUTINE");
      goto cleanup;
    }

  if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Alternate RETURN "
                      "at %C") == FAILURE)
    return MATCH_ERROR;

  if (gfc_current_form == FORM_FREE)
    {
      /* The following are valid, so we can't require a blank after the
        RETURN keyword:
          return+1
          return(1)  */
      char c = gfc_peek_ascii_char ();
      if (ISALPHA (c) || ISDIGIT (c))
        return MATCH_NO;
    }

  m = gfc_match (" %e%t", &e);
  if (m == MATCH_YES)
    goto done;
  if (m == MATCH_ERROR)
    goto cleanup;

  gfc_syntax_error (ST_RETURN);

cleanup:
  gfc_free_expr (e);
  return MATCH_ERROR;

done:
  gfc_enclosing_unit (&s);
  if (s == COMP_PROGRAM
      && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
                        "main program at %C") == FAILURE)
      return MATCH_ERROR;

  new_st.op = EXEC_RETURN;
  new_st.expr1 = e;

  return MATCH_YES;
}


/* Match the call of a type-bound procedure, if CALL%var has already been 
   matched and var found to be a derived-type variable.  */

static match
match_typebound_call (gfc_symtree* varst)
{
  gfc_expr* base;
  match m;

  base = gfc_get_expr ();
  base->expr_type = EXPR_VARIABLE;
  base->symtree = varst;
  base->where = gfc_current_locus;
  gfc_set_sym_referenced (varst->n.sym);
  
  m = gfc_match_varspec (base, 0, true, true);
  if (m == MATCH_NO)
    gfc_error ("Expected component reference at %C");
  if (m != MATCH_YES)
    return MATCH_ERROR;

  if (gfc_match_eos () != MATCH_YES)
    {
      gfc_error ("Junk after CALL at %C");
      return MATCH_ERROR;
    }

  if (base->expr_type == EXPR_COMPCALL)
    new_st.op = EXEC_COMPCALL;
  else if (base->expr_type == EXPR_PPC)
    new_st.op = EXEC_CALL_PPC;
  else
    {
      gfc_error ("Expected type-bound procedure or procedure pointer component "
                 "at %C");
      return MATCH_ERROR;
    }
  new_st.expr1 = base;

  return MATCH_YES;
}


/* Match a CALL statement.  The tricky part here are possible
   alternate return specifiers.  We handle these by having all
   "subroutines" actually return an integer via a register that gives
   the return number.  If the call specifies alternate returns, we
   generate code for a SELECT statement whose case clauses contain
   GOTOs to the various labels.  */

match
gfc_match_call (void)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_actual_arglist *a, *arglist;
  gfc_case *new_case;
  gfc_symbol *sym;
  gfc_symtree *st;
  gfc_code *c;
  match m;
  int i;

  arglist = NULL;

  m = gfc_match ("% %n", name);
  if (m == MATCH_NO)
    goto syntax;
  if (m != MATCH_YES)
    return m;

  if (gfc_get_ha_sym_tree (name, &st))
    return MATCH_ERROR;

  sym = st->n.sym;

  /* If this is a variable of derived-type, it probably starts a type-bound
     procedure call.  */
  if ((sym->attr.flavor != FL_PROCEDURE
       || gfc_is_function_return_value (sym, gfc_current_ns))
      && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
    return match_typebound_call (st);

  /* If it does not seem to be callable (include functions so that the
     right association is made.  They are thrown out in resolution.)
     ...  */
  if (!sym->attr.generic
        && !sym->attr.subroutine
        && !sym->attr.function)
    {
      if (!(sym->attr.external && !sym->attr.referenced))
        {
          /* ...create a symbol in this scope...  */
          if (sym->ns != gfc_current_ns
                && gfc_get_sym_tree (name, NULL, &st, false) == 1)
            return MATCH_ERROR;

          if (sym != st->n.sym)
            sym = st->n.sym;
        }

      /* ...and then to try to make the symbol into a subroutine.  */
      if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
        return MATCH_ERROR;
    }

  gfc_set_sym_referenced (sym);

  if (gfc_match_eos () != MATCH_YES)
    {
      m = gfc_match_actual_arglist (1, &arglist);
      if (m == MATCH_NO)
        goto syntax;
      if (m == MATCH_ERROR)
        goto cleanup;

      if (gfc_match_eos () != MATCH_YES)
        goto syntax;
    }

  /* If any alternate return labels were found, construct a SELECT
     statement that will jump to the right place.  */

  i = 0;
  for (a = arglist; a; a = a->next)
    if (a->expr == NULL)
      i = 1;

  if (i)
    {
      gfc_symtree *select_st;
      gfc_symbol *select_sym;
      char name[GFC_MAX_SYMBOL_LEN + 1];

      new_st.next = c = gfc_get_code ();
      c->op = EXEC_SELECT;
      sprintf (name, "_result_%s", sym->name);
      gfc_get_ha_sym_tree (name, &select_st);   /* Can't fail.  */

      select_sym = select_st->n.sym;
      select_sym->ts.type = BT_INTEGER;
      select_sym->ts.kind = gfc_default_integer_kind;
      gfc_set_sym_referenced (select_sym);
      c->expr1 = gfc_get_expr ();
      c->expr1->expr_type = EXPR_VARIABLE;
      c->expr1->symtree = select_st;
      c->expr1->ts = select_sym->ts;
      c->expr1->where = gfc_current_locus;

      i = 0;
      for (a = arglist; a; a = a->next)
        {
          if (a->expr != NULL)
            continue;

          if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
            continue;

          i++;

          c->block = gfc_get_code ();
          c = c->block;
          c->op = EXEC_SELECT;

          new_case = gfc_get_case ();
          new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
          new_case->low = new_case->high;
          c->ext.block.case_list = new_case;

          c->next = gfc_get_code ();
          c->next->op = EXEC_GOTO;
          c->next->label1 = a->label;
        }
    }

  new_st.op = EXEC_CALL;
  new_st.symtree = st;
  new_st.ext.actual = arglist;

  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_CALL);

cleanup:
  gfc_free_actual_arglist (arglist);
  return MATCH_ERROR;
}


/* Given a name, return a pointer to the common head structure,
   creating it if it does not exist. If FROM_MODULE is nonzero, we
   mangle the name so that it doesn't interfere with commons defined 
   in the using namespace.
   TODO: Add to global symbol tree.  */

gfc_common_head *
gfc_get_common (const char *name, int from_module)
{
  gfc_symtree *st;
  static int serial = 0;
  char mangled_name[GFC_MAX_SYMBOL_LEN + 1];

  if (from_module)
    {
      /* A use associated common block is only needed to correctly layout
         the variables it contains.  */
      snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
      st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
    }
  else
    {
      st = gfc_find_symtree (gfc_current_ns->common_root, name);

      if (st == NULL)
        st = gfc_new_symtree (&gfc_current_ns->common_root, name);
    }

  if (st->n.common == NULL)
    {
      st->n.common = gfc_get_common_head ();
      st->n.common->where = gfc_current_locus;
      strcpy (st->n.common->name, name);
    }

  return st->n.common;
}


/* Match a common block name.  */

match match_common_name (char *name)
{
  match m;

  if (gfc_match_char ('/') == MATCH_NO)
    {
      name[0] = '\0';
      return MATCH_YES;
    }

  if (gfc_match_char ('/') == MATCH_YES)
    {
      name[0] = '\0';
      return MATCH_YES;
    }

  m = gfc_match_name (name);

  if (m == MATCH_ERROR)
    return MATCH_ERROR;
  if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
    return MATCH_YES;

  gfc_error ("Syntax error in common block name at %C");
  return MATCH_ERROR;
}


/* Match a COMMON statement.  */

match
gfc_match_common (void)
{
  gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_common_head *t;
  gfc_array_spec *as;
  gfc_equiv *e1, *e2;
  match m;
  gfc_gsymbol *gsym;

  old_blank_common = gfc_current_ns->blank_common.head;
  if (old_blank_common)
    {
      while (old_blank_common->common_next)
        old_blank_common = old_blank_common->common_next;
    }

  as = NULL;

  for (;;)
    {
      m = match_common_name (name);
      if (m == MATCH_ERROR)
        goto cleanup;

      gsym = gfc_get_gsymbol (name);
      if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
        {
          gfc_error ("Symbol '%s' at %C is already an external symbol that "
                     "is not COMMON", name);
          goto cleanup;
        }

      if (gsym->type == GSYM_UNKNOWN)
        {
          gsym->type = GSYM_COMMON;
          gsym->where = gfc_current_locus;
          gsym->defined = 1;
        }

      gsym->used = 1;

      if (name[0] == '\0')
        {
          t = &gfc_current_ns->blank_common;
          if (t->head == NULL)
            t->where = gfc_current_locus;
        }
      else
        {
          t = gfc_get_common (name, 0);
        }
      head = &t->head;

      if (*head == NULL)
        tail = NULL;
      else
        {
          tail = *head;
          while (tail->common_next)
            tail = tail->common_next;
        }

      /* Grab the list of symbols.  */
      for (;;)
        {
          m = gfc_match_symbol (&sym, 0);
          if (m == MATCH_ERROR)
            goto cleanup;
          if (m == MATCH_NO)
            goto syntax;

          /* Store a ref to the common block for error checking.  */
          sym->common_block = t;
          
          /* See if we know the current common block is bind(c), and if
             so, then see if we can check if the symbol is (which it'll
             need to be).  This can happen if the bind(c) attr stmt was
             applied to the common block, and the variable(s) already
             defined, before declaring the common block.  */
          if (t->is_bind_c == 1)
            {
              if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
                {
                  /* If we find an error, just print it and continue,
                     cause it's just semantic, and we can see if there
                     are more errors.  */
                  gfc_error_now ("Variable '%s' at %L in common block '%s' "
                                 "at %C must be declared with a C "
                                 "interoperable kind since common block "
                                 "'%s' is bind(c)",
                                 sym->name, &(sym->declared_at), t->name,
                                 t->name);
                }
              
              if (sym->attr.is_bind_c == 1)
                gfc_error_now ("Variable '%s' in common block "
                               "'%s' at %C can not be bind(c) since "
                               "it is not global", sym->name, t->name);
            }
          
          if (sym->attr.in_common)
            {
              gfc_error ("Symbol '%s' at %C is already in a COMMON block",
                         sym->name);
              goto cleanup;
            }

          if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
               || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
            {
              if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C "
                                               "can only be COMMON in "
                                               "BLOCK DATA", sym->name)
                  == FAILURE)
                goto cleanup;
            }

          if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
            goto cleanup;

          if (tail != NULL)
            tail->common_next = sym;
          else
            *head = sym;

          tail = sym;

          /* Deal with an optional array specification after the
             symbol name.  */
          m = gfc_match_array_spec (&as, true, true);
          if (m == MATCH_ERROR)
            goto cleanup;

          if (m == MATCH_YES)
            {
              if (as->type != AS_EXPLICIT)
                {
                  gfc_error ("Array specification for symbol '%s' in COMMON "
                             "at %C must be explicit", sym->name);
                  goto cleanup;
                }

              if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
                goto cleanup;

              if (sym->attr.pointer)
                {
                  gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
                             "POINTER array", sym->name);
                  goto cleanup;
                }

              sym->as = as;
              as = NULL;

            }

          sym->common_head = t;

          /* Check to see if the symbol is already in an equivalence group.
             If it is, set the other members as being in common.  */
          if (sym->attr.in_equivalence)
            {
              for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
                {
                  for (e2 = e1; e2; e2 = e2->eq)
                    if (e2->expr->symtree->n.sym == sym)
                      goto equiv_found;

                  continue;

          equiv_found:

                  for (e2 = e1; e2; e2 = e2->eq)
                    {
                      other = e2->expr->symtree->n.sym;
                      if (other->common_head
                          && other->common_head != sym->common_head)
                        {
                          gfc_error ("Symbol '%s', in COMMON block '%s' at "
                                     "%C is being indirectly equivalenced to "
                                     "another COMMON block '%s'",
                                     sym->name, sym->common_head->name,
                                     other->common_head->name);
                            goto cleanup;
                        }
                      other->attr.in_common = 1;
                      other->common_head = t;
                    }
                }
            }


          gfc_gobble_whitespace ();
          if (gfc_match_eos () == MATCH_YES)
            goto done;
          if (gfc_peek_ascii_char () == '/')
            break;
          if (gfc_match_char (',') != MATCH_YES)
            goto syntax;
          gfc_gobble_whitespace ();
          if (gfc_peek_ascii_char () == '/')
            break;
        }
    }

done:
  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_COMMON);

cleanup:
  if (old_blank_common)
    old_blank_common->common_next = NULL;
  else
    gfc_current_ns->blank_common.head = NULL;
  gfc_free_array_spec (as);
  return MATCH_ERROR;
}


/* Match a BLOCK DATA program unit.  */

match
gfc_match_block_data (void)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_symbol *sym;
  match m;

  if (gfc_match_eos () == MATCH_YES)
    {
      gfc_new_block = NULL;
      return MATCH_YES;
    }

  m = gfc_match ("% %n%t", name);
  if (m != MATCH_YES)
    return MATCH_ERROR;

  if (gfc_get_symbol (name, NULL, &sym))
    return MATCH_ERROR;

  if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
    return MATCH_ERROR;

  gfc_new_block = sym;

  return MATCH_YES;
}


/* Free a namelist structure.  */

void
gfc_free_namelist (gfc_namelist *name)
{
  gfc_namelist *n;

  for (; name; name = n)
    {
      n = name->next;
      gfc_free (name);
    }
}


/* Match a NAMELIST statement.  */

match
gfc_match_namelist (void)
{
  gfc_symbol *group_name, *sym;
  gfc_namelist *nl;
  match m, m2;

  m = gfc_match (" / %s /", &group_name);
  if (m == MATCH_NO)
    goto syntax;
  if (m == MATCH_ERROR)
    goto error;

  for (;;)
    {
      if (group_name->ts.type != BT_UNKNOWN)
        {
          gfc_error ("Namelist group name '%s' at %C already has a basic "
                     "type of %s", group_name->name,
                     gfc_typename (&group_name->ts));
          return MATCH_ERROR;
        }

      if (group_name->attr.flavor == FL_NAMELIST
          && group_name->attr.use_assoc
          && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
                             "at %C already is USE associated and can"
                             "not be respecified.", group_name->name)
             == FAILURE)
        return MATCH_ERROR;

      if (group_name->attr.flavor != FL_NAMELIST
          && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
                             group_name->name, NULL) == FAILURE)
        return MATCH_ERROR;

      for (;;)
        {
          m = gfc_match_symbol (&sym, 1);
          if (m == MATCH_NO)
            goto syntax;
          if (m == MATCH_ERROR)
            goto error;

          if (sym->attr.in_namelist == 0
              && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
            goto error;

          /* Use gfc_error_check here, rather than goto error, so that
             these are the only errors for the next two lines.  */
          if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
            {
              gfc_error ("Assumed size array '%s' in namelist '%s' at "
                         "%C is not allowed", sym->name, group_name->name);
              gfc_error_check ();
            }

          nl = gfc_get_namelist ();
          nl->sym = sym;
          sym->refs++;

          if (group_name->namelist == NULL)
            group_name->namelist = group_name->namelist_tail = nl;
          else
            {
              group_name->namelist_tail->next = nl;
              group_name->namelist_tail = nl;
            }

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

          m = gfc_match_char (',');

          if (gfc_match_char ('/') == MATCH_YES)
            {
              m2 = gfc_match (" %s /", &group_name);
              if (m2 == MATCH_YES)
                break;
              if (m2 == MATCH_ERROR)
                goto error;
              goto syntax;
            }

          if (m != MATCH_YES)
            goto syntax;
        }
    }

done:
  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_NAMELIST);

error:
  return MATCH_ERROR;
}


/* Match a MODULE statement.  */

match
gfc_match_module (void)
{
  match m;

  m = gfc_match (" %s%t", &gfc_new_block);
  if (m != MATCH_YES)
    return m;

  if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
                      gfc_new_block->name, NULL) == FAILURE)
    return MATCH_ERROR;

  return MATCH_YES;
}


/* Free equivalence sets and lists.  Recursively is the easiest way to
   do this.  */

void
gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop)
{
  if (eq == stop)
    return;

  gfc_free_equiv (eq->eq);
  gfc_free_equiv_until (eq->next, stop);
  gfc_free_expr (eq->expr);
  gfc_free (eq);
}


void
gfc_free_equiv (gfc_equiv *eq)
{
  gfc_free_equiv_until (eq, NULL);
}


/* Match an EQUIVALENCE statement.  */

match
gfc_match_equivalence (void)
{
  gfc_equiv *eq, *set, *tail;
  gfc_ref *ref;
  gfc_symbol *sym;
  match m;
  gfc_common_head *common_head = NULL;
  bool common_flag;
  int cnt;

  tail = NULL;

  for (;;)
    {
      eq = gfc_get_equiv ();
      if (tail == NULL)
        tail = eq;

      eq->next = gfc_current_ns->equiv;
      gfc_current_ns->equiv = eq;

      if (gfc_match_char ('(') != MATCH_YES)
        goto syntax;

      set = eq;
      common_flag = FALSE;
      cnt = 0;

      for (;;)
        {
          m = gfc_match_equiv_variable (&set->expr);
          if (m == MATCH_ERROR)
            goto cleanup;
          if (m == MATCH_NO)
            goto syntax;

          /*  count the number of objects.  */
          cnt++;

          if (gfc_match_char ('%') == MATCH_YES)
            {
              gfc_error ("Derived type component %C is not a "
                         "permitted EQUIVALENCE member");
              goto cleanup;
            }

          for (ref = set->expr->ref; ref; ref = ref->next)
            if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
              {
                gfc_error ("Array reference in EQUIVALENCE at %C cannot "
                           "be an array section");
                goto cleanup;
              }

          sym = set->expr->symtree->n.sym;

          if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
            goto cleanup;

          if (sym->attr.in_common)
            {
              common_flag = TRUE;
              common_head = sym->common_head;
            }

          if (gfc_match_char (')') == MATCH_YES)
            break;

          if (gfc_match_char (',') != MATCH_YES)
            goto syntax;

          set->eq = gfc_get_equiv ();
          set = set->eq;
        }

      if (cnt < 2)
        {
          gfc_error ("EQUIVALENCE at %C requires two or more objects");
          goto cleanup;
        }

      /* If one of the members of an equivalence is in common, then
         mark them all as being in common.  Before doing this, check
         that members of the equivalence group are not in different
         common blocks.  */
      if (common_flag)
        for (set = eq; set; set = set->eq)
          {
            sym = set->expr->symtree->n.sym;
            if (sym->common_head && sym->common_head != common_head)
              {
                gfc_error ("Attempt to indirectly overlap COMMON "
                           "blocks %s and %s by EQUIVALENCE at %C",
                           sym->common_head->name, common_head->name);
                goto cleanup;
              }
            sym->attr.in_common = 1;
            sym->common_head = common_head;
          }

      if (gfc_match_eos () == MATCH_YES)
        break;
      if (gfc_match_char (',') != MATCH_YES)
        {
          gfc_error ("Expecting a comma in EQUIVALENCE at %C");
          goto cleanup;
        }
    }

  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_EQUIVALENCE);

cleanup:
  eq = tail->next;
  tail->next = NULL;

  gfc_free_equiv (gfc_current_ns->equiv);
  gfc_current_ns->equiv = eq;

  return MATCH_ERROR;
}


/* Check that a statement function is not recursive. This is done by looking
   for the statement function symbol(sym) by looking recursively through its
   expression(e).  If a reference to sym is found, true is returned.  
   12.5.4 requires that any variable of function that is implicitly typed
   shall have that type confirmed by any subsequent type declaration.  The
   implicit typing is conveniently done here.  */
static bool
recursive_stmt_fcn (gfc_expr *, gfc_symbol *);

static bool
check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
{

  if (e == NULL)
    return false;

  switch (e->expr_type)
    {
    case EXPR_FUNCTION:
      if (e->symtree == NULL)
        return false;

      /* Check the name before testing for nested recursion!  */
      if (sym->name == e->symtree->n.sym->name)
        return true;

      /* Catch recursion via other statement functions.  */
      if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
          && e->symtree->n.sym->value
          && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
        return true;

      if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
        gfc_set_default_type (e->symtree->n.sym, 0, NULL);

      break;

    case EXPR_VARIABLE:
      if (e->symtree && sym->name == e->symtree->n.sym->name)
        return true;

      if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
        gfc_set_default_type (e->symtree->n.sym, 0, NULL);
      break;

    default:
      break;
    }

  return false;
}


static bool
recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
{
  return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
}


/* Match a statement function declaration.  It is so easy to match
   non-statement function statements with a MATCH_ERROR as opposed to
   MATCH_NO that we suppress error message in most cases.  */

match
gfc_match_st_function (void)
{
  gfc_error_buf old_error;
  gfc_symbol *sym;
  gfc_expr *expr;
  match m;

  m = gfc_match_symbol (&sym, 0);
  if (m != MATCH_YES)
    return m;

  gfc_push_error (&old_error);

  if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
                         sym->name, NULL) == FAILURE)
    goto undo_error;

  if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
    goto undo_error;

  m = gfc_match (" = %e%t", &expr);
  if (m == MATCH_NO)
    goto undo_error;

  gfc_free_error (&old_error);
  if (m == MATCH_ERROR)
    return m;

  if (recursive_stmt_fcn (expr, sym))
    {
      gfc_error ("Statement function at %L is recursive", &expr->where);
      return MATCH_ERROR;
    }

  sym->value = expr;

  if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
                      "Statement function at %C") == FAILURE)
    return MATCH_ERROR;

  return MATCH_YES;

undo_error:
  gfc_pop_error (&old_error);
  return MATCH_NO;
}


/***************** SELECT CASE subroutines ******************/

/* Free a single case structure.  */

static void
free_case (gfc_case *p)
{
  if (p->low == p->high)
    p->high = NULL;
  gfc_free_expr (p->low);
  gfc_free_expr (p->high);
  gfc_free (p);
}


/* Free a list of case structures.  */

void
gfc_free_case_list (gfc_case *p)
{
  gfc_case *q;

  for (; p; p = q)
    {
      q = p->next;
      free_case (p);
    }
}


/* Match a single case selector.  */

static match
match_case_selector (gfc_case **cp)
{
  gfc_case *c;
  match m;

  c = gfc_get_case ();
  c->where = gfc_current_locus;

  if (gfc_match_char (':') == MATCH_YES)
    {
      m = gfc_match_init_expr (&c->high);
      if (m == MATCH_NO)
        goto need_expr;
      if (m == MATCH_ERROR)
        goto cleanup;
    }
  else
    {
      m = gfc_match_init_expr (&c->low);
      if (m == MATCH_ERROR)
        goto cleanup;
      if (m == MATCH_NO)
        goto need_expr;

      /* If we're not looking at a ':' now, make a range out of a single
         target.  Else get the upper bound for the case range.  */
      if (gfc_match_char (':') != MATCH_YES)
        c->high = c->low;
      else
        {
          m = gfc_match_init_expr (&c->high);
          if (m == MATCH_ERROR)
            goto cleanup;
          /* MATCH_NO is fine.  It's OK if nothing is there!  */
        }
    }

  *cp = c;
  return MATCH_YES;

need_expr:
  gfc_error ("Expected initialization expression in CASE at %C");

cleanup:
  free_case (c);
  return MATCH_ERROR;
}


/* Match the end of a case statement.  */

static match
match_case_eos (void)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  match m;

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

  /* If the case construct doesn't have a case-construct-name, we
     should have matched the EOS.  */
  if (!gfc_current_block ())
    return MATCH_NO;

  gfc_gobble_whitespace ();

  m = gfc_match_name (name);
  if (m != MATCH_YES)
    return m;

  if (strcmp (name, gfc_current_block ()->name) != 0)
    {
      gfc_error ("Expected block name '%s' of SELECT construct at %C",
                 gfc_current_block ()->name);
      return MATCH_ERROR;
    }

  return gfc_match_eos ();
}


/* Match a SELECT statement.  */

match
gfc_match_select (void)
{
  gfc_expr *expr;
  match m;

  m = gfc_match_label ();
  if (m == MATCH_ERROR)
    return m;

  m = gfc_match (" select case ( %e )%t", &expr);
  if (m != MATCH_YES)
    return m;

  new_st.op = EXEC_SELECT;
  new_st.expr1 = expr;

  return MATCH_YES;
}


/* Push the current selector onto the SELECT TYPE stack.  */

static void
select_type_push (gfc_symbol *sel)
{
  gfc_select_type_stack *top = gfc_get_select_type_stack ();
  top->selector = sel;
  top->tmp = NULL;
  top->prev = select_type_stack;

  select_type_stack = top;
}


/* Set the temporary for the current SELECT TYPE selector.  */

static void
select_type_set_tmp (gfc_typespec *ts)
{
  char name[GFC_MAX_SYMBOL_LEN];
  gfc_symtree *tmp;
  
  if (!ts)
    {
      select_type_stack->tmp = NULL;
      return;
    }
  
  if (!gfc_type_is_extensible (ts->u.derived))
    return;

  if (ts->type == BT_CLASS)
    sprintf (name, "__tmp_class_%s", ts->u.derived->name);
  else
    sprintf (name, "__tmp_type_%s", ts->u.derived->name);
  gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
  gfc_add_type (tmp->n.sym, ts, NULL);
  gfc_set_sym_referenced (tmp->n.sym);
  gfc_add_pointer (&tmp->n.sym->attr, NULL);
  gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
  if (ts->type == BT_CLASS)
    gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
                            &tmp->n.sym->as, false);
  tmp->n.sym->attr.select_type_temporary = 1;

  /* Add an association for it, so the rest of the parser knows it is
     an associate-name.  The target will be set during resolution.  */
  tmp->n.sym->assoc = gfc_get_association_list ();
  tmp->n.sym->assoc->dangling = 1;
  tmp->n.sym->assoc->st = tmp;

  select_type_stack->tmp = tmp;
}


/* Match a SELECT TYPE statement.  */

match
gfc_match_select_type (void)
{
  gfc_expr *expr1, *expr2 = NULL;
  match m;
  char name[GFC_MAX_SYMBOL_LEN];

  m = gfc_match_label ();
  if (m == MATCH_ERROR)
    return m;

  m = gfc_match (" select type ( ");
  if (m != MATCH_YES)
    return m;

  gfc_current_ns = gfc_build_block_ns (gfc_current_ns);

  m = gfc_match (" %n => %e", name, &expr2);
  if (m == MATCH_YES)
    {
      expr1 = gfc_get_expr();
      expr1->expr_type = EXPR_VARIABLE;
      if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
        {
          m = MATCH_ERROR;
          goto cleanup;
        }
      if (expr2->ts.type == BT_UNKNOWN)
        expr1->symtree->n.sym->attr.untyped = 1;
      else
        expr1->symtree->n.sym->ts = expr2->ts;
      expr1->symtree->n.sym->attr.flavor = FL_VARIABLE;
      expr1->symtree->n.sym->attr.referenced = 1;
      expr1->symtree->n.sym->attr.class_ok = 1;
    }
  else
    {
      m = gfc_match (" %e ", &expr1);
      if (m != MATCH_YES)
        goto cleanup;
    }

  m = gfc_match (" )%t");
  if (m != MATCH_YES)
    goto cleanup;

  /* Check for F03:C811.  */
  if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
    {
      gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
                 "use associate-name=>");
      m = MATCH_ERROR;
      goto cleanup;
    }

  new_st.op = EXEC_SELECT_TYPE;
  new_st.expr1 = expr1;
  new_st.expr2 = expr2;
  new_st.ext.block.ns = gfc_current_ns;

  select_type_push (expr1->symtree->n.sym);

  return MATCH_YES;
  
cleanup:
  gfc_current_ns = gfc_current_ns->parent;
  return m;
}


/* Match a CASE statement.  */

match
gfc_match_case (void)
{
  gfc_case *c, *head, *tail;
  match m;

  head = tail = NULL;

  if (gfc_current_state () != COMP_SELECT)
    {
      gfc_error ("Unexpected CASE statement at %C");
      return MATCH_ERROR;
    }

  if (gfc_match ("% default") == MATCH_YES)
    {
      m = match_case_eos ();
      if (m == MATCH_NO)
        goto syntax;
      if (m == MATCH_ERROR)
        goto cleanup;

      new_st.op = EXEC_SELECT;
      c = gfc_get_case ();
      c->where = gfc_current_locus;
      new_st.ext.block.case_list = c;
      return MATCH_YES;
    }

  if (gfc_match_char ('(') != MATCH_YES)
    goto syntax;

  for (;;)
    {
      if (match_case_selector (&c) == MATCH_ERROR)
        goto cleanup;

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

      tail = c;

      if (gfc_match_char (')') == MATCH_YES)
        break;
      if (gfc_match_char (',') != MATCH_YES)
        goto syntax;
    }

  m = match_case_eos ();
  if (m == MATCH_NO)
    goto syntax;
  if (m == MATCH_ERROR)
    goto cleanup;

  new_st.op = EXEC_SELECT;
  new_st.ext.block.case_list = head;

  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in CASE specification at %C");

cleanup:
  gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
  return MATCH_ERROR;
}


/* Match a TYPE IS statement.  */

match
gfc_match_type_is (void)
{
  gfc_case *c = NULL;
  match m;

  if (gfc_current_state () != COMP_SELECT_TYPE)
    {
      gfc_error ("Unexpected TYPE IS statement at %C");
      return MATCH_ERROR;
    }

  if (gfc_match_char ('(') != MATCH_YES)
    goto syntax;

  c = gfc_get_case ();
  c->where = gfc_current_locus;

  /* TODO: Once unlimited polymorphism is implemented, we will need to call
     match_type_spec here.  */
  if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
    goto cleanup;

  if (gfc_match_char (')') != MATCH_YES)
    goto syntax;

  m = match_case_eos ();
  if (m == MATCH_NO)
    goto syntax;
  if (m == MATCH_ERROR)
    goto cleanup;

  new_st.op = EXEC_SELECT_TYPE;
  new_st.ext.block.case_list = c;

  /* Create temporary variable.  */
  select_type_set_tmp (&c->ts);

  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in TYPE IS specification at %C");

cleanup:
  if (c != NULL)
    gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
  return MATCH_ERROR;
}


/* Match a CLASS IS or CLASS DEFAULT statement.  */

match
gfc_match_class_is (void)
{
  gfc_case *c = NULL;
  match m;

  if (gfc_current_state () != COMP_SELECT_TYPE)
    return MATCH_NO;

  if (gfc_match ("% default") == MATCH_YES)
    {
      m = match_case_eos ();
      if (m == MATCH_NO)
        goto syntax;
      if (m == MATCH_ERROR)
        goto cleanup;

      new_st.op = EXEC_SELECT_TYPE;
      c = gfc_get_case ();
      c->where = gfc_current_locus;
      c->ts.type = BT_UNKNOWN;
      new_st.ext.block.case_list = c;
      select_type_set_tmp (NULL);
      return MATCH_YES;
    }

  m = gfc_match ("% is");
  if (m == MATCH_NO)
    goto syntax;
  if (m == MATCH_ERROR)
    goto cleanup;

  if (gfc_match_char ('(') != MATCH_YES)
    goto syntax;

  c = gfc_get_case ();
  c->where = gfc_current_locus;

  if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
    goto cleanup;

  if (c->ts.type == BT_DERIVED)
    c->ts.type = BT_CLASS;

  if (gfc_match_char (')') != MATCH_YES)
    goto syntax;

  m = match_case_eos ();
  if (m == MATCH_NO)
    goto syntax;
  if (m == MATCH_ERROR)
    goto cleanup;

  new_st.op = EXEC_SELECT_TYPE;
  new_st.ext.block.case_list = c;
  
  /* Create temporary variable.  */
  select_type_set_tmp (&c->ts);

  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in CLASS IS specification at %C");

cleanup:
  if (c != NULL)
    gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
  return MATCH_ERROR;
}


/********************* WHERE subroutines ********************/

/* Match the rest of a simple WHERE statement that follows an IF statement.  
 */

static match
match_simple_where (void)
{
  gfc_expr *expr;
  gfc_code *c;
  match m;

  m = gfc_match (" ( %e )", &expr);
  if (m != MATCH_YES)
    return m;

  m = gfc_match_assignment ();
  if (m == MATCH_NO)
    goto syntax;
  if (m == MATCH_ERROR)
    goto cleanup;

  if (gfc_match_eos () != MATCH_YES)
    goto syntax;

  c = gfc_get_code ();

  c->op = EXEC_WHERE;
  c->expr1 = expr;
  c->next = gfc_get_code ();

  *c->next = new_st;
  gfc_clear_new_st ();

  new_st.op = EXEC_WHERE;
  new_st.block = c;

  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_WHERE);

cleanup:
  gfc_free_expr (expr);
  return MATCH_ERROR;
}


/* Match a WHERE statement.  */

match
gfc_match_where (gfc_statement *st)
{
  gfc_expr *expr;
  match m0, m;
  gfc_code *c;

  m0 = gfc_match_label ();
  if (m0 == MATCH_ERROR)
    return m0;

  m = gfc_match (" where ( %e )", &expr);
  if (m != MATCH_YES)
    return m;

  if (gfc_match_eos () == MATCH_YES)
    {
      *st = ST_WHERE_BLOCK;
      new_st.op = EXEC_WHERE;
      new_st.expr1 = expr;
      return MATCH_YES;
    }

  m = gfc_match_assignment ();
  if (m == MATCH_NO)
    gfc_syntax_error (ST_WHERE);

  if (m != MATCH_YES)
    {
      gfc_free_expr (expr);
      return MATCH_ERROR;
    }

  /* We've got a simple WHERE statement.  */
  *st = ST_WHERE;
  c = gfc_get_code ();

  c->op = EXEC_WHERE;
  c->expr1 = expr;
  c->next = gfc_get_code ();

  *c->next = new_st;
  gfc_clear_new_st ();

  new_st.op = EXEC_WHERE;
  new_st.block = c;

  return MATCH_YES;
}


/* Match an ELSEWHERE statement.  We leave behind a WHERE node in
   new_st if successful.  */

match
gfc_match_elsewhere (void)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_expr *expr;
  match m;

  if (gfc_current_state () != COMP_WHERE)
    {
      gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
      return MATCH_ERROR;
    }

  expr = NULL;

  if (gfc_match_char ('(') == MATCH_YES)
    {
      m = gfc_match_expr (&expr);
      if (m == MATCH_NO)
        goto syntax;
      if (m == MATCH_ERROR)
        return MATCH_ERROR;

      if (gfc_match_char (')') != MATCH_YES)
        goto syntax;
    }

  if (gfc_match_eos () != MATCH_YES)
    {
      /* Only makes sense if we have a where-construct-name.  */
      if (!gfc_current_block ())
        {
          m = MATCH_ERROR;
          goto cleanup;
        }
      /* Better be a name at this point.  */
      m = gfc_match_name (name);
      if (m == MATCH_NO)
        goto syntax;
      if (m == MATCH_ERROR)
        goto cleanup;

      if (gfc_match_eos () != MATCH_YES)
        goto syntax;

      if (strcmp (name, gfc_current_block ()->name) != 0)
        {
          gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
                     name, gfc_current_block ()->name);
          goto cleanup;
        }
    }

  new_st.op = EXEC_WHERE;
  new_st.expr1 = expr;
  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_ELSEWHERE);

cleanup:
  gfc_free_expr (expr);
  return MATCH_ERROR;
}


/******************** FORALL subroutines ********************/

/* Free a list of FORALL iterators.  */

void
gfc_free_forall_iterator (gfc_forall_iterator *iter)
{
  gfc_forall_iterator *next;

  while (iter)
    {
      next = iter->next;
      gfc_free_expr (iter->var);
      gfc_free_expr (iter->start);
      gfc_free_expr (iter->end);
      gfc_free_expr (iter->stride);
      gfc_free (iter);
      iter = next;
    }
}


/* Match an iterator as part of a FORALL statement.  The format is:

     <var> = <start>:<end>[:<stride>]

   On MATCH_NO, the caller tests for the possibility that there is a
   scalar mask expression.  */

static match
match_forall_iterator (gfc_forall_iterator **result)
{
  gfc_forall_iterator *iter;
  locus where;
  match m;

  where = gfc_current_locus;
  iter = XCNEW (gfc_forall_iterator);

  m = gfc_match_expr (&iter->var);
  if (m != MATCH_YES)
    goto cleanup;

  if (gfc_match_char ('=') != MATCH_YES
      || iter->var->expr_type != EXPR_VARIABLE)
    {
      m = MATCH_NO;
      goto cleanup;
    }

  m = gfc_match_expr (&iter->start);
  if (m != MATCH_YES)
    goto cleanup;

  if (gfc_match_char (':') != MATCH_YES)
    goto syntax;

  m = gfc_match_expr (&iter->end);
  if (m == MATCH_NO)
    goto syntax;
  if (m == MATCH_ERROR)
    goto cleanup;

  if (gfc_match_char (':') == MATCH_NO)
    iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
  else
    {
      m = gfc_match_expr (&iter->stride);
      if (m == MATCH_NO)
        goto syntax;
      if (m == MATCH_ERROR)
        goto cleanup;
    }

  /* Mark the iteration variable's symbol as used as a FORALL index.  */
  iter->var->symtree->n.sym->forall_index = true;

  *result = iter;
  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in FORALL iterator at %C");
  m = MATCH_ERROR;

cleanup:

  gfc_current_locus = where;
  gfc_free_forall_iterator (iter);
  return m;
}


/* Match the header of a FORALL statement.  */

static match
match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
{
  gfc_forall_iterator *head, *tail, *new_iter;
  gfc_expr *msk;
  match m;

  gfc_gobble_whitespace ();

  head = tail = NULL;
  msk = NULL;

  if (gfc_match_char ('(') != MATCH_YES)
    return MATCH_NO;

  m = match_forall_iterator (&new_iter);
  if (m == MATCH_ERROR)
    goto cleanup;
  if (m == MATCH_NO)
    goto syntax;

  head = tail = new_iter;

  for (;;)
    {
      if (gfc_match_char (',') != MATCH_YES)
        break;

      m = match_forall_iterator (&new_iter);
      if (m == MATCH_ERROR)
        goto cleanup;

      if (m == MATCH_YES)
        {
          tail->next = new_iter;
          tail = new_iter;
          continue;
        }

      /* Have to have a mask expression.  */

      m = gfc_match_expr (&msk);
      if (m == MATCH_NO)
        goto syntax;
      if (m == MATCH_ERROR)
        goto cleanup;

      break;
    }

  if (gfc_match_char (')') == MATCH_NO)
    goto syntax;

  *phead = head;
  *mask = msk;
  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_FORALL);

cleanup:
  gfc_free_expr (msk);
  gfc_free_forall_iterator (head);

  return MATCH_ERROR;
}

/* Match the rest of a simple FORALL statement that follows an 
   IF statement.  */

static match
match_simple_forall (void)
{
  gfc_forall_iterator *head;
  gfc_expr *mask;
  gfc_code *c;
  match m;

  mask = NULL;
  head = NULL;
  c = NULL;

  m = match_forall_header (&head, &mask);

  if (m == MATCH_NO)
    goto syntax;
  if (m != MATCH_YES)
    goto cleanup;

  m = gfc_match_assignment ();

  if (m == MATCH_ERROR)
    goto cleanup;
  if (m == MATCH_NO)
    {
      m = gfc_match_pointer_assignment ();
      if (m == MATCH_ERROR)
        goto cleanup;
      if (m == MATCH_NO)
        goto syntax;
    }

  c = gfc_get_code ();
  *c = new_st;
  c->loc = gfc_current_locus;

  if (gfc_match_eos () != MATCH_YES)
    goto syntax;

  gfc_clear_new_st ();
  new_st.op = EXEC_FORALL;
  new_st.expr1 = mask;
  new_st.ext.forall_iterator = head;
  new_st.block = gfc_get_code ();

  new_st.block->op = EXEC_FORALL;
  new_st.block->next = c;

  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_FORALL);

cleanup:
  gfc_free_forall_iterator (head);
  gfc_free_expr (mask);

  return MATCH_ERROR;
}


/* Match a FORALL statement.  */

match
gfc_match_forall (gfc_statement *st)
{
  gfc_forall_iterator *head;
  gfc_expr *mask;
  gfc_code *c;
  match m0, m;

  head = NULL;
  mask = NULL;
  c = NULL;

  m0 = gfc_match_label ();
  if (m0 == MATCH_ERROR)
    return MATCH_ERROR;

  m = gfc_match (" forall");
  if (m != MATCH_YES)
    return m;

  m = match_forall_header (&head, &mask);
  if (m == MATCH_ERROR)
    goto cleanup;
  if (m == MATCH_NO)
    goto syntax;

  if (gfc_match_eos () == MATCH_YES)
    {
      *st = ST_FORALL_BLOCK;
      new_st.op = EXEC_FORALL;
      new_st.expr1 = mask;
      new_st.ext.forall_iterator = head;
      return MATCH_YES;
    }

  m = gfc_match_assignment ();
  if (m == MATCH_ERROR)
    goto cleanup;
  if (m == MATCH_NO)
    {
      m = gfc_match_pointer_assignment ();
      if (m == MATCH_ERROR)
        goto cleanup;
      if (m == MATCH_NO)
        goto syntax;
    }

  c = gfc_get_code ();
  *c = new_st;
  c->loc = gfc_current_locus;

  gfc_clear_new_st ();
  new_st.op = EXEC_FORALL;
  new_st.expr1 = mask;
  new_st.ext.forall_iterator = head;
  new_st.block = gfc_get_code ();
  new_st.block->op = EXEC_FORALL;
  new_st.block->next = c;

  *st = ST_FORALL;
  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_FORALL);

cleanup:
  gfc_free_forall_iterator (head);
  gfc_free_expr (mask);
  gfc_free_statements (c);
  return MATCH_NO;
}