gcc/fortran/match.cc

/* Matching subroutines in all sizes, shapes and colors.
   Copyright (C) 2000-2022 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 "coretypes.h"
#include "options.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;

/* List of type parameter expressions.  */
gfc_actual_arglist *type_param_spec_list;

/* 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";

    case INTRINSIC_NONE:
      return "none";

    /* DTIO  */
    case INTRINSIC_FORMATTED:
      return "formatted";
    case INTRINSIC_UNFORMATTED:
      return "unformatted";

    default:
      break;
    }

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


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

/* Matches a member separator. With standard FORTRAN this is '%', but with
   DEC structures we must carefully match dot ('.').
   Because operators are spelled ".op.", a dotted string such as "x.y.z..."
   can be either a component reference chain or a combination of binary
   operations.
   There is no real way to win because the string may be grammatically
   ambiguous. The following rules help avoid ambiguities - they match
   some behavior of other (older) compilers. If the rules here are changed
   the test cases should be updated. If the user has problems with these rules
   they probably deserve the consequences. Consider "x.y.z":
     (1) If any user defined operator ".y." exists, this is always y(x,z)
         (even if ".y." is the wrong type and/or x has a member y).
     (2) Otherwise if x has a member y, and y is itself a derived type,
         this is (x->y)->z, even if an intrinsic operator exists which
         can handle (x,z).
     (3) If x has no member y or (x->y) is not a derived type but ".y."
         is an intrinsic operator (such as ".eq."), this is y(x,z).
     (4) Lastly if there is no operator ".y." and x has no member "y", it is an
         error.
   It is worth noting that the logic here does not support mixed use of member
   accessors within a single string. That is, even if x has component y and y
   has component z, the following are all syntax errors:
         "x%y.z"  "x.y%z" "(x.y).z"  "(x%y)%z"
 */

match
gfc_match_member_sep(gfc_symbol *sym)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  locus dot_loc, start_loc;
  gfc_intrinsic_op iop;
  match m;
  gfc_symbol *tsym;
  gfc_component *c = NULL;

  /* What a relief: '%' is an unambiguous member separator.  */
  if (gfc_match_char ('%') == MATCH_YES)
    return MATCH_YES;

  /* Beware ye who enter here.  */
  if (!flag_dec_structure || !sym)
    return MATCH_NO;

  tsym = NULL;

  /* We may be given either a derived type variable or the derived type
    declaration itself (which actually contains the components);
    we need the latter to search for components.  */
  if (gfc_fl_struct (sym->attr.flavor))
    tsym = sym;
  else if (gfc_bt_struct (sym->ts.type))
    tsym = sym->ts.u.derived;

  iop = INTRINSIC_NONE;
  name[0] = '\0';
  m = MATCH_NO;

  /* If we have to reject come back here later.  */
  start_loc = gfc_current_locus;

  /* Look for a component access next.  */
  if (gfc_match_char ('.') != MATCH_YES)
    return MATCH_NO;

  /* If we accept, come back here.  */
  dot_loc = gfc_current_locus;

  /* Try to match a symbol name following the dot.  */
  if (gfc_match_name (name) != MATCH_YES)
    {
      gfc_error ("Expected structure component or operator name "
                 "after '.' at %C");
      goto error;
    }

  /* If no dot follows we have "x.y" which should be a component access.  */
  if (gfc_match_char ('.') != MATCH_YES)
    goto yes;

  /* Now we have a string "x.y.z" which could be a nested member access
    (x->y)->z or a binary operation y on x and z.  */

  /* First use any user-defined operators ".y."  */
  if (gfc_find_uop (name, sym->ns) != NULL)
    goto no;

  /* Match accesses to existing derived-type components for
    derived-type vars: "x.y.z" = (x->y)->z  */
  c = gfc_find_component(tsym, name, false, true, NULL);
  if (c && (gfc_bt_struct (c->ts.type) || c->ts.type == BT_CLASS))
    goto yes;

  /* If y is not a component or has no members, try intrinsic operators.  */
  gfc_current_locus = start_loc;
  if (gfc_match_intrinsic_op (&iop) != MATCH_YES)
    {
      /* If ".y." is not an intrinsic operator but y was a valid non-
        structure component, match and leave the trailing dot to be
        dealt with later.  */
      if (c)
        goto yes;

      gfc_error ("%qs is neither a defined operator nor a "
                 "structure component in dotted string at %C", name);
      goto error;
    }

  /* .y. is an intrinsic operator, overriding any possible member access.  */
  goto no;

  /* Return keeping the current locus consistent with the match result.  */
error:
  m = MATCH_ERROR;
no:
  gfc_current_locus = start_loc;
  return m;
yes:
  gfc_current_locus = dot_loc;
  return MATCH_YES;
}


/* 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 (;;)
    {
      if (count > 0)
	where = gfc_current_locus;
      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++;
	}
      if (c == ')' && quote == ' ')
	{
	  count--;
	  where = gfc_current_locus;
	}
    }

  gfc_current_locus = old_loc;

  if (count != 0)
    {
      gfc_error ("Missing %qs in statement at or before %L",
		 count > 0? ")":"(", &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.
   When gobble_ws is false, do not skip over leading blanks.  */

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

  old_loc = gfc_current_locus;

  *value = -1;
  if (gobble_ws)
    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;
  match m;
  int i;

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

  if (gfc_extract_int (expr, &i, 1))
    m = MATCH_ERROR;
  gfc_free_expr (expr);

  *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.  */

static 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 %qs at %C is ambiguous", name);
      return MATCH_ERROR;
    }

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

  if (!gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
		       gfc_new_block->name, NULL))
    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.cc restricts max_identifier_length to not more
   than GFC_MAX_SYMBOL_LEN.
   When gobble_ws is false, do not skip over leading blanks.  */

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

  old_loc = gfc_current_locus;
  if (gobble_ws)
    gfc_gobble_whitespace ();

  c = gfc_next_ascii_char ();
  if (!(ISALPHA (c) || (c == '_' && flag_allow_leading_underscore)))
    {
      /* Special cases for unary minus and plus, which allows for a sensible
	 error message for code of the form 'c = exp(-a*b) )' where an
	 extra ')' appears at the end of statement.  */
      if (!gfc_error_flag_test () && c != '(' && c != '-' && 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 == '_' || (flag_dollar_ok && c == '$'));

  if (c == '$' && !flag_dollar_ok)
    {
      gfc_fatal_error ("Invalid character %<$%> at %L. Use %<-fdollar-ok%> to "
		       "allow it as an extension", &old_loc);
      return MATCH_ERROR;
    }

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

  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.cc.  */

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;

	case 'x':
	  if (gfc_next_ascii_char () == 'o'
	      && gfc_next_ascii_char () == 'r'
	      && gfc_next_ascii_char () == '.')
	    {
              if (!gfc_notify_std (GFC_STD_LEGACY, ".XOR. operator at %C"))
                return MATCH_ERROR;
	      /* Matched ".xor." - equivalent to ".neqv.".  */
	      *result = INTRINSIC_NEQV;
	      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;

  if (var->symtree->n.sym->attr.dimension)
    {
      gfc_error ("Loop variable at %C cannot be an array");
      goto cleanup;
    }

  /* 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.
   When gobble_ws is false, do not skip over leading blanks.  */

match
gfc_match_char (char c, bool gobble_ws)
{
  locus where;

  where = gfc_current_locus;
  if (gobble_ws)
    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, except function references
   having a data pointer result)
   %   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);
	}
      /* FALLTHRU */

    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))
    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
      && rvalue->ts.type == BT_BOZ
      && lvalue->ts.type == BT_CLASS)
    {
      m = MATCH_ERROR;
      gfc_error ("BOZ literal constant at %L is neither a DATA statement "
		 "value nor an actual argument of INT/REAL/DBLE/CMPLX "
		 "intrinsic subprogram", &rvalue->where);
    }

  if (lvalue->expr_type == EXPR_CONSTANT)
    {
      /* This clobbers %len and %kind.  */
      m = MATCH_ERROR;
      gfc_error ("Assignment to a constant expression at %C");
    }

  if (m != MATCH_YES)
    {
      gfc_current_locus = old_loc;
      gfc_free_expr (lvalue);
      gfc_free_expr (rvalue);
      return m;
    }

  if (!lvalue->symtree)
    {
      gfc_free_expr (lvalue);
      gfc_free_expr (rvalue);
      return MATCH_ERROR;
    }


  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 || !lvalue->symtree)
    {
      m = MATCH_NO;
      goto cleanup;
    }

  if (lvalue->symtree->n.sym->attr.proc_pointer
      || gfc_is_proc_ptr_comp (lvalue))
    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)
      || !gfc_reference_st_label (l2, ST_LABEL_TARGET)
      || !gfc_reference_st_label (l3, ST_LABEL_TARGET))
    {
      gfc_free_expr (expr);
      return MATCH_ERROR;
    }

  if (!gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL,
		       "Arithmetic IF statement at %C"))
    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 ", &expr);
  if (m != MATCH_YES)
    return m;

  if (gfc_match_char ('(') != MATCH_YES)
    {
      gfc_error ("Missing %<(%> in IF-expression at %C");
      return MATCH_ERROR;
    }

  m = gfc_match ("%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)
	  || !gfc_reference_st_label (l2, ST_LABEL_TARGET)
	  || !gfc_reference_st_label (l3, ST_LABEL_TARGET))
	{
	  gfc_free_expr (expr);
	  return MATCH_ERROR;
	}

      if (!gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL,
			   "Arithmetic IF statement at %C"))
	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 ("change% team", gfc_match_change_team, ST_CHANGE_TEAM)
  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 ("end team", gfc_match_end_team, ST_END_TEAM)
  match ("error% stop", gfc_match_error_stop, ST_ERROR_STOP)
  match ("event% post", gfc_match_event_post, ST_EVENT_POST)
  match ("event% wait", gfc_match_event_wait, ST_EVENT_WAIT)
  match ("exit", gfc_match_exit, ST_EXIT)
  match ("fail% image", gfc_match_fail_image, ST_FAIL_IMAGE)
  match ("flush", gfc_match_flush, ST_FLUSH)
  match ("forall", match_simple_forall, ST_FORALL)
  match ("form% team", gfc_match_form_team, ST_FORM_TEAM)
  match ("go to", gfc_match_goto, ST_GOTO)
  match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
  match ("inquire", gfc_match_inquire, ST_INQUIRE)
  match ("lock", gfc_match_lock, ST_LOCK)
  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 ("sync% team", gfc_match_sync_team, ST_SYNC_TEAM)
  match ("unlock", gfc_match_unlock, ST_UNLOCK)
  match ("where", match_simple_where, ST_WHERE)
  match ("write", gfc_match_write, ST_WRITE)

  if (flag_dec)
    match ("type", gfc_match_print, ST_WRITE)

  /* 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 ())
    gfc_error ("Syntax error in IF-clause after %C");

  gfc_free_expr (expr);
  return MATCH_ERROR;

got_match:
  if (m == MATCH_NO)
    gfc_error ("Syntax error in IF-clause after %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 (EXEC_IF);
  p->next = XCNEW (gfc_code);
  *p->next = new_st;
  p->next->loc = gfc_current_locus;

  p->expr1 = expr;

  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 ("Invalid character(s) in ELSE statement after %C");
      return MATCH_ERROR;
    }

  if (strcmp (name, gfc_current_block ()->name) != 0)
    {
      gfc_error ("Label %qs at %C doesn't match IF label %qs",
		 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, *then;
  locus where;
  match m;

  if (gfc_match_char ('(') != MATCH_YES)
    {
      gfc_error ("Missing %<(%> in ELSE IF expression at %C");
      return MATCH_ERROR;
    }

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

  if (gfc_match_char (')') != MATCH_YES)
    {
      gfc_error ("Missing %<)%> in ELSE IF expression at %C");
      goto cleanup;
    }

  m = gfc_match (" then ", &then);

  where = gfc_current_locus;

  if (m == MATCH_YES && (gfc_match_eos () == MATCH_YES
			 || (gfc_current_block ()
			     && gfc_match_name (name) == MATCH_YES)))
    goto done;

  if (gfc_match_eos () == MATCH_YES)
    {
      gfc_error ("Missing THEN in ELSE IF statement after %L", &where);
      goto cleanup;
    }

  if (gfc_match_name (name) != MATCH_YES
      || gfc_current_block () == NULL
      || gfc_match_eos () != MATCH_YES)
    {
      gfc_error ("Syntax error in ELSE IF statement after %L", &where);
      goto cleanup;
    }

  if (strcmp (name, gfc_current_block ()->name) != 0)
    {
      gfc_error ("Label %qs after %L doesn't match IF label %qs",
		 name, &where, gfc_current_block ()->name);
      goto cleanup;
    }

  if (m != MATCH_YES)
    return m;

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)
    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_find_state (COMP_DO_CONCURRENT))
    {
      gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
		 "block");
      return MATCH_ERROR;
    }

  gfc_unset_implicit_pure (NULL);

  if (!gfc_notify_std (GFC_STD_F2008, "CRITICAL statement at %C"))
    return MATCH_ERROR;

  if (flag_coarray == GFC_FCOARRAY_NONE)
    {
       gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to "
			"enable");
       return MATCH_ERROR;
    }

  if (gfc_find_state (COMP_CRITICAL))
    {
      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))
    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 =>", newAssoc->name) != MATCH_YES)
	{
	  gfc_error ("Expected association at %C");
	  goto assocListError;
	}

      if (gfc_match (" %e", &newAssoc->target) != MATCH_YES)
	{
	  /* Have another go, allowing for procedure pointer selectors.  */
	  gfc_matching_procptr_assignment = 1;
	  if (gfc_match (" %e", &newAssoc->target) != MATCH_YES)
	    {
	      gfc_error ("Invalid association target at %C");
	      goto assocListError;
	    }
	  gfc_matching_procptr_assignment = 0;
	}
      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 %qs 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 target expression cannot be a BOZ literal constant.  */
      if (newAssoc->target->ts.type == BT_BOZ)
	{
	  gfc_error ("Association target at %L cannot be a BOZ literal "
		     "constant", &newAssoc->target->where);
	  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:
      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 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, *der_type;
  match m = MATCH_YES;
  gfc_actual_arglist *decl_type_param_list = NULL;
  bool is_pdt_template = false;

  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);

  /* Match the PDT spec list, if there.  */
  if (derived && derived->attr.flavor == FL_PROCEDURE)
    {
      gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &der_type);
      is_pdt_template = der_type
			&& der_type->attr.flavor == FL_DERIVED
			&& der_type->attr.pdt_template;
    }

  if (is_pdt_template)
    m = gfc_match_actual_arglist (1, &decl_type_param_list, true);

  if (m == MATCH_ERROR)
    {
      gfc_free_actual_arglist (decl_type_param_list);
      return m;
    }

  if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic)
    derived = gfc_find_dt_in_generic (derived);

  /* If this is a PDT, find the specific instance.  */
  if (m == MATCH_YES && is_pdt_template)
    {
      gfc_namespace *old_ns;

      old_ns = gfc_current_ns;
      while (gfc_current_ns && gfc_current_ns->parent)
	gfc_current_ns = gfc_current_ns->parent;

      if (type_param_spec_list)
	gfc_free_actual_arglist (type_param_spec_list);
      m = gfc_get_pdt_instance (decl_type_param_list, &der_type,
				&type_param_spec_list);
      gfc_free_actual_arglist (decl_type_param_list);

      if (m != MATCH_YES)
	return m;
      derived = der_type;
      gcc_assert (!derived->attr.pdt_template && derived->attr.pdt_type);
      gfc_set_sym_referenced (derived);

      gfc_current_ns = old_ns;
    }

  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.cc, 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.  */

match
gfc_match_type_spec (gfc_typespec *ts)
{
  match m;
  locus old_locus;
  char c, name[GFC_MAX_SYMBOL_LEN + 1];

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

  /* If c isn't [a-z], then return immediately.  */
  c = gfc_peek_ascii_char ();
  if (!ISALPHA(c))
    return MATCH_NO;

  type_param_spec_list = NULL;

  if (match_derived_type_spec (ts) == MATCH_YES)
    {
      /* Enforce F03:C401.  */
      if (ts->u.derived->attr.abstract)
	{
	  gfc_error ("Derived type %qs 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 ("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;
    }

  /* REAL is a real pain because it can be a type, intrinsic subprogram,
     or list item in a type-list of an OpenMP reduction clause.  Need to
     differentiate REAL([KIND]=scalar-int-initialization-expr) from
     REAL(A,[KIND]) and REAL(KIND,A).  Logically, when this code was
     written the use of LOGICAL as a type-spec or intrinsic subprogram
     was overlooked.  */

  m = gfc_match (" %n", name);
  if (m == MATCH_YES
      && (strcmp (name, "real") == 0 || strcmp (name, "logical") == 0))
    {
      char c;
      gfc_expr *e;
      locus where;

      if (*name == 'r')
	{
	  ts->type = BT_REAL;
	  ts->kind = gfc_default_real_kind;
	}
      else
	{
	  ts->type = BT_LOGICAL;
	  ts->kind = gfc_default_logical_kind;
	}

      gfc_gobble_whitespace ();

      /* Prevent REAL*4, etc.  */
      c = gfc_peek_ascii_char ();
      if (c == '*')
	{
	  gfc_error ("Invalid type-spec at %C");
	  return MATCH_ERROR;
	}

      /* Found leading colon in REAL::, a trailing ')' in for example
	 TYPE IS (REAL), or REAL, for an OpenMP list-item.  */
      if (c == ':' || c == ')' || (flag_openmp && c == ','))
	return MATCH_YES;

      /* Found something other than the opening '(' in REAL(...  */
      if (c != '(')
	return MATCH_NO;
      else
	gfc_next_char (); /* Burn the '('. */

      /* Look for the optional KIND=. */
      where = gfc_current_locus;
      m = gfc_match ("%n", name);
      if (m == MATCH_YES)
	{
	  gfc_gobble_whitespace ();
	  c = gfc_next_char ();
	  if (c == '=')
	    {
	      if (strcmp(name, "a") == 0 || strcmp(name, "l") == 0)
		return MATCH_NO;
	      else if (strcmp(name, "kind") == 0)
		goto found;
	      else
		return MATCH_ERROR;
	    }
	  else
	    gfc_current_locus = where;
	}
      else
	gfc_current_locus = where;

found:

      m = gfc_match_expr (&e);
      if (m == MATCH_NO || m == MATCH_ERROR)
	return m;

      /* If a comma appears, it is an intrinsic subprogram. */
      gfc_gobble_whitespace ();
      c = gfc_peek_ascii_char ();
      if (c == ',')
	{
	  gfc_free_expr (e);
	  return MATCH_NO;
	}

      /* If ')' appears, we have REAL(initialization-expr), here check for
	 a scalar integer initialization-expr and valid kind parameter. */
      if (c == ')')
	{
	  bool ok = true;
	  if (e->expr_type != EXPR_CONSTANT && e->expr_type != EXPR_VARIABLE)
	    ok = gfc_reduce_init_expr (e);
	  if (!ok || e->ts.type != BT_INTEGER || e->rank > 0)
	    {
	      gfc_free_expr (e);
	      return MATCH_NO;
	    }

	  if (e->expr_type != EXPR_CONSTANT)
	    goto ohno;

	  gfc_next_char (); /* Burn the ')'. */
	  ts->kind = (int) mpz_get_si (e->value.integer);
	  if (gfc_validate_kind (ts->type, ts->kind , true) == -1)
	    {
	      gfc_error ("Invalid type-spec at %C");
	      return MATCH_ERROR;
	    }

	  gfc_free_expr (e);

	  return MATCH_YES;
	}
    }

ohno:

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

kind_selector:

  gfc_gobble_whitespace ();

  /* This prevents INTEGER*4, etc.  */
  if (gfc_peek_ascii_char () == '*')
    {
      gfc_error ("Invalid type-spec at %C");
      return MATCH_ERROR;
    }

  m = gfc_match_kind_spec (ts, false);

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

  return m;
}


/******************** 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);
      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 = XCNEW (gfc_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 (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 = XCNEW (gfc_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 (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;
}


/* 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;

  memset (&iter, '\0', sizeof (gfc_iterator));
  label = 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;

  if (gfc_match (" concurrent") == MATCH_YES)
    {
      gfc_forall_iterator *head;
      gfc_expr *mask;

      if (!gfc_notify_std (GFC_STD_F2008, "DO CONCURRENT construct at %C"))
	return MATCH_ERROR;


      mask = NULL;
      head = NULL;
      m = match_forall_header (&head, &mask);

      if (m == MATCH_NO)
	return m;
      if (m == MATCH_ERROR)
	goto concurr_cleanup;

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

      if (label != NULL
	   && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET))
	goto concurr_cleanup;

      new_st.label1 = label;
      new_st.op = EXEC_DO_CONCURRENT;
      new_st.expr1 = mask;
      new_st.ext.forall_iterator = head;

      return MATCH_YES;

concurr_cleanup:
      gfc_syntax_error (ST_DO);
      gfc_free_expr (mask);
      gfc_free_forall_iterator (head);
      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_DO_TARGET))
    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 %qs 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 %qs 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 (p->state == COMP_DO_CONCURRENT
	     && (op == EXEC_EXIT || (sym && sym != p->sym)))
      {
	/* F2008, C821 & C845.  */
	gfc_error("%s statement at %C leaves DO CONCURRENT construct",
		  gfc_ascii_statement (st));
	return MATCH_ERROR;
      }
    else if ((sym && sym == p->sym)
	     || (!sym && (p->state == COMP_DO
			  || p->state == COMP_DO_CONCURRENT)))
      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 %qs",
		   gfc_ascii_statement (st), sym->name);

      return MATCH_ERROR;
    }

  /* Special checks for EXIT from non-loop constructs.  */
  switch (p->state)
    {
    case COMP_DO:
    case COMP_DO_CONCURRENT:
      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:
    case COMP_SELECT_RANK:
      gcc_assert (sym);
      if (op == EXEC_CYCLE)
	{
	  gfc_error ("CYCLE statement at %C is not applicable to non-loop"
		     " construct %qs", sym->name);
	  return MATCH_ERROR;
	}
      gcc_assert (op == EXEC_EXIT);
      if (!gfc_notify_std (GFC_STD_F2008, "EXIT statement with no"
			   " do-construct-name at %C"))
	return MATCH_ERROR;
      break;

    default:
      gfc_error ("%s statement at %C is not applicable to construct %qs",
		 gfc_ascii_statement (st), sym->name);
      return MATCH_ERROR;
    }

  if (o != NULL)
    {
      gfc_error (is_oacc (p)
		 ? G_("%s statement at %C leaving OpenACC structured block")
		 : G_("%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;

  int count = 1;
  if (cnt > 0
      && o != NULL
      && o->state == COMP_OMP_STRUCTURED_BLOCK)
    switch (o->head->op)
      {
      case EXEC_OACC_LOOP:
      case EXEC_OACC_KERNELS_LOOP:
      case EXEC_OACC_PARALLEL_LOOP:
      case EXEC_OACC_SERIAL_LOOP:
	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)
	  {
	    /* Both collapsed and tiled loops are lowered the same way, but are
	       not compatible.  In gfc_trans_omp_do, the tile is prioritized. */
	    if (o->previous->tail->ext.omp_clauses->tile_list)
	      {
		count = 0;
		gfc_expr_list *el
		  = o->previous->tail->ext.omp_clauses->tile_list;
		for ( ; el; el = el->next)
		  ++count;
	      }
	    else if (o->previous->tail->ext.omp_clauses->collapse > 1)
	      count = o->previous->tail->ext.omp_clauses->collapse;
	  }
	if (st == ST_EXIT && cnt <= count)
	  {
	    gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
	    return MATCH_ERROR;
	  }
	if (st == ST_CYCLE && cnt < count)
	  {
	    gfc_error (o->previous->tail->ext.omp_clauses->tile_list
		       ? G_("CYCLE statement at %C to non-innermost tiled "
			    "!$ACC LOOP loop")
		       : G_("CYCLE statement at %C to non-innermost collapsed "
			    "!$ACC LOOP loop"));
	    return MATCH_ERROR;
	  }
	break;
      case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
      case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
      case EXEC_OMP_TARGET_SIMD:
      case EXEC_OMP_TASKLOOP_SIMD:
      case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
      case EXEC_OMP_MASTER_TASKLOOP_SIMD:
      case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
      case EXEC_OMP_MASKED_TASKLOOP_SIMD:
      case EXEC_OMP_PARALLEL_DO_SIMD:
      case EXEC_OMP_DISTRIBUTE_SIMD:
      case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
      case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
      case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
      case EXEC_OMP_LOOP:
      case EXEC_OMP_PARALLEL_LOOP:
      case EXEC_OMP_TEAMS_LOOP:
      case EXEC_OMP_TARGET_PARALLEL_LOOP:
      case EXEC_OMP_TARGET_TEAMS_LOOP:
      case EXEC_OMP_DO:
      case EXEC_OMP_PARALLEL_DO:
      case EXEC_OMP_SIMD:
      case EXEC_OMP_DO_SIMD:
      case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
      case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
      case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
      case EXEC_OMP_TARGET_PARALLEL_DO:
      case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:

	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)
	  {
	    if (o->previous->tail->ext.omp_clauses->collapse > 1)
	      count = o->previous->tail->ext.omp_clauses->collapse;
	    if (o->previous->tail->ext.omp_clauses->orderedc)
	      count = o->previous->tail->ext.omp_clauses->orderedc;
	  }
	if (st == ST_EXIT && cnt <= count)
	  {
	    gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
	    return MATCH_ERROR;
	  }
	if (st == ST_CYCLE && cnt < count)
	  {
	    gfc_error ("CYCLE statement at %C to non-innermost collapsed "
		       "!$OMP DO loop");
	    return MATCH_ERROR;
	  }
	break;
      default:
	break;
      }

  /* 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 stop-code after an (ERROR) STOP or PAUSE statement.  The
   requirements for a stop-code differ in the standards.

Fortran 95 has

   R840 stop-stmt  is STOP [ stop-code ]
   R841 stop-code  is scalar-char-constant
                   or digit [ digit [ digit [ digit [ digit ] ] ] ]

Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850.
Fortran 2008 has

   R855 stop-stmt     is STOP [ stop-code ]
   R856 allstop-stmt  is ALL STOP [ stop-code ]
   R857 stop-code     is scalar-default-char-constant-expr
                      or scalar-int-constant-expr
Fortran 2018 has

   R1160 stop-stmt       is STOP [ stop-code ] [ , QUIET = scalar-logical-expr]
   R1161 error-stop-stmt is
                      ERROR STOP [ stop-code ] [ , QUIET = scalar-logical-expr]
   R1162 stop-code       is scalar-default-char-expr
                         or scalar-int-expr

For free-form source code, all standards contain a statement of the form:

   A blank shall be used to separate names, constants, or labels from
   adjacent keywords, names, constants, or labels.

A stop-code is not a name, constant, or label.  So, under Fortran 95 and 2003,

  STOP123

is valid, but it is invalid Fortran 2008.  */

static match
gfc_match_stopcode (gfc_statement st)
{
  gfc_expr *e = NULL;
  gfc_expr *quiet = NULL;
  match m;
  bool f95, f03, f08;
  char c;

  /* Set f95 for -std=f95.  */
  f95 = (gfc_option.allow_std == GFC_STD_OPT_F95);

  /* Set f03 for -std=f2003.  */
  f03 = (gfc_option.allow_std == GFC_STD_OPT_F03);

  /* Set f08 for -std=f2008.  */
  f08 = (gfc_option.allow_std == GFC_STD_OPT_F08);

  /* Plain STOP statement?  */
  if (gfc_match_eos () == MATCH_YES)
    goto checks;

  /* Look for a blank between STOP and the stop-code for F2008 or later.
     But allow for F2018's ,QUIET= specifier.  */
  c = gfc_peek_ascii_char ();

  if (gfc_current_form != FORM_FIXED && !(f95 || f03) && c != ',')
    {
      /* Look for end-of-statement.  There is no stop-code.  */
      if (c == '\n' || c == '!' || c == ';')
        goto done;

      if (c != ' ')
	{
	  gfc_error ("Blank required in %s statement near %C",
		     gfc_ascii_statement (st));
	  return MATCH_ERROR;
	}
    }

  if (c == ' ')
    {
      gfc_gobble_whitespace ();
      c = gfc_peek_ascii_char ();
    }
  if (c != ',')
    {
      int stopcode;
      locus old_locus;

      /* First look for the F95 or F2003 digit [...] construct.  */
      old_locus = gfc_current_locus;
      m = gfc_match_small_int (&stopcode);
      if (m == MATCH_YES && (f95 || f03))
	{
	  if (stopcode < 0)
	    {
	      gfc_error ("STOP code at %C cannot be negative");
	      return MATCH_ERROR;
	    }

	  if (stopcode > 99999)
	    {
	      gfc_error ("STOP code at %C contains too many digits");
	      return MATCH_ERROR;
	    }
	}

      /* Reset the locus and now load gfc_expr.  */
      gfc_current_locus = old_locus;
      m = gfc_match_expr (&e);
      if (m == MATCH_ERROR)
	goto cleanup;
      if (m == MATCH_NO)
	goto syntax;
    }

  if (gfc_match (" , quiet = %e", &quiet) == MATCH_YES)
    {
      if (!gfc_notify_std (GFC_STD_F2018, "QUIET= specifier for %s at %L",
			   gfc_ascii_statement (st), &quiet->where))
	goto cleanup;
    }

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

checks:

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

  gfc_unset_implicit_pure (NULL);

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

  if (e != NULL)
    {
      if (!gfc_simplify_expr (e, 0))
	goto cleanup;

      /* Test for F95 and F2003 style STOP stop-code.  */
      if (e->expr_type != EXPR_CONSTANT && (f95 || f03))
	{
	  gfc_error ("STOP code at %L must be a scalar CHARACTER constant "
		     "or digit[digit[digit[digit[digit]]]]", &e->where);
	  goto cleanup;
	}

      /* Use the machinery for an initialization expression to reduce the
	 stop-code to a constant.  */
      gfc_reduce_init_expr (e);

      /* Test for F2008 style STOP stop-code.  */
      if (e->expr_type != EXPR_CONSTANT && f08)
	{
	  gfc_error ("STOP code at %L must be a scalar default CHARACTER or "
		     "INTEGER constant expression", &e->where);
	  goto cleanup;
	}

      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_notify_std (GFC_STD_F2018,
			      "STOP code at %L must be default integer KIND=%d",
			      &e->where, (int) gfc_default_integer_kind))
	goto cleanup;
    }

  if (quiet != NULL)
    {
      if (!gfc_simplify_expr (quiet, 0))
	goto cleanup;

      if (quiet->rank != 0)
	{
	  gfc_error ("QUIET specifier at %L must be a scalar LOGICAL",
		     &quiet->where);
	  goto cleanup;
	}
    }

done:

  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.expr2 = quiet;
  new_st.ext.stop_code = -1;

  return MATCH_YES;

syntax:
  gfc_syntax_error (st);

cleanup:

  gfc_free_expr (e);
  gfc_free_expr (quiet);
  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, "PAUSE statement at %C"))
	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, "ERROR STOP statement at %C"))
    return MATCH_ERROR;

  return gfc_match_stopcode (ST_ERROR_STOP);
}

/* Match EVENT POST/WAIT statement. Syntax:
     EVENT POST ( event-variable [, sync-stat-list] )
     EVENT WAIT ( event-variable [, wait-spec-list] )
   with
      wait-spec-list  is  sync-stat-list  or until-spec
      until-spec  is  UNTIL_COUNT = scalar-int-expr
      sync-stat  is  STAT= or ERRMSG=.  */

static match
event_statement (gfc_statement st)
{
  match m;
  gfc_expr *tmp, *eventvar, *until_count, *stat, *errmsg;
  bool saw_until_count, saw_stat, saw_errmsg;

  tmp = eventvar = until_count = stat = errmsg = NULL;
  saw_until_count = saw_stat = saw_errmsg = false;

  if (gfc_pure (NULL))
    {
      gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
		 st == ST_EVENT_POST ? "POST" : "WAIT");
      return MATCH_ERROR;
    }

  gfc_unset_implicit_pure (NULL);

  if (flag_coarray == GFC_FCOARRAY_NONE)
    {
       gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
       return MATCH_ERROR;
    }

  if (gfc_find_state (COMP_CRITICAL))
    {
      gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
		 st == ST_EVENT_POST ? "POST" : "WAIT");
      return MATCH_ERROR;
    }

  if (gfc_find_state (COMP_DO_CONCURRENT))
    {
      gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
		 "block", st == ST_EVENT_POST ? "POST" : "WAIT");
      return MATCH_ERROR;
    }

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

  if (gfc_match ("%e", &eventvar) != 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;

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

	  tmp = NULL;
	  break;
	}

      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;

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

	  tmp = NULL;
	  break;
	}

      m = gfc_match (" until_count = %e", &tmp);
      if (m == MATCH_ERROR || st == ST_EVENT_POST)
	goto syntax;