gcc/fortran/decl.cc

/* Declaration statement matcher
   Copyright (C) 2002-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 "tree.h"
#include "gfortran.h"
#include "stringpool.h"
#include "match.h"
#include "parse.h"
#include "constructor.h"
#include "target.h"

/* Macros to access allocate memory for gfc_data_variable,
   gfc_data_value and gfc_data.  */
#define gfc_get_data_variable() XCNEW (gfc_data_variable)
#define gfc_get_data_value() XCNEW (gfc_data_value)
#define gfc_get_data() XCNEW (gfc_data)


static bool set_binding_label (const char **, const char *, int);


/* This flag is set if an old-style length selector is matched
   during a type-declaration statement.  */

static int old_char_selector;

/* When variables acquire types and attributes from a declaration
   statement, they get them from the following static variables.  The
   first part of a declaration sets these variables and the second
   part copies these into symbol structures.  */

static gfc_typespec current_ts;

static symbol_attribute current_attr;
static gfc_array_spec *current_as;
static int colon_seen;
static int attr_seen;

/* The current binding label (if any).  */
static const char* curr_binding_label;
/* Need to know how many identifiers are on the current data declaration
   line in case we're given the BIND(C) attribute with a NAME= specifier.  */
static int num_idents_on_line;
/* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
   can supply a name if the curr_binding_label is nil and NAME= was not.  */
static int has_name_equals = 0;

/* Initializer of the previous enumerator.  */

static gfc_expr *last_initializer;

/* History of all the enumerators is maintained, so that
   kind values of all the enumerators could be updated depending
   upon the maximum initialized value.  */

typedef struct enumerator_history
{
  gfc_symbol *sym;
  gfc_expr *initializer;
  struct enumerator_history *next;
}
enumerator_history;

/* Header of enum history chain.  */

static enumerator_history *enum_history = NULL;

/* Pointer of enum history node containing largest initializer.  */

static enumerator_history *max_enum = NULL;

/* gfc_new_block points to the symbol of a newly matched block.  */

gfc_symbol *gfc_new_block;

bool gfc_matching_function;

/* Set upon parsing a !GCC$ unroll n directive for use in the next loop.  */
int directive_unroll = -1;

/* Set upon parsing supported !GCC$ pragmas for use in the next loop.  */
bool directive_ivdep = false;
bool directive_vector = false;
bool directive_novector = false;

/* Map of middle-end built-ins that should be vectorized.  */
hash_map<nofree_string_hash, int> *gfc_vectorized_builtins;

/* If a kind expression of a component of a parameterized derived type is
   parameterized, temporarily store the expression here.  */
static gfc_expr *saved_kind_expr = NULL;

/* Used to store the parameter list arising in a PDT declaration and
   in the typespec of a PDT variable or component.  */
static gfc_actual_arglist *decl_type_param_list;
static gfc_actual_arglist *type_param_spec_list;

/********************* DATA statement subroutines *********************/

static bool in_match_data = false;

bool
gfc_in_match_data (void)
{
  return in_match_data;
}

static void
set_in_match_data (bool set_value)
{
  in_match_data = set_value;
}

/* Free a gfc_data_variable structure and everything beneath it.  */

static void
free_variable (gfc_data_variable *p)
{
  gfc_data_variable *q;

  for (; p; p = q)
    {
      q = p->next;
      gfc_free_expr (p->expr);
      gfc_free_iterator (&p->iter, 0);
      free_variable (p->list);
      free (p);
    }
}


/* Free a gfc_data_value structure and everything beneath it.  */

static void
free_value (gfc_data_value *p)
{
  gfc_data_value *q;

  for (; p; p = q)
    {
      q = p->next;
      mpz_clear (p->repeat);
      gfc_free_expr (p->expr);
      free (p);
    }
}


/* Free a list of gfc_data structures.  */

void
gfc_free_data (gfc_data *p)
{
  gfc_data *q;

  for (; p; p = q)
    {
      q = p->next;
      free_variable (p->var);
      free_value (p->value);
      free (p);
    }
}


/* Free all data in a namespace.  */

static void
gfc_free_data_all (gfc_namespace *ns)
{
  gfc_data *d;

  for (;ns->data;)
    {
      d = ns->data->next;
      free (ns->data);
      ns->data = d;
    }
}

/* Reject data parsed since the last restore point was marked.  */

void
gfc_reject_data (gfc_namespace *ns)
{
  gfc_data *d;

  while (ns->data && ns->data != ns->old_data)
    {
      d = ns->data->next;
      free (ns->data);
      ns->data = d;
    }
}

static match var_element (gfc_data_variable *);

/* Match a list of variables terminated by an iterator and a right
   parenthesis.  */

static match
var_list (gfc_data_variable *parent)
{
  gfc_data_variable *tail, var;
  match m;

  m = var_element (&var);
  if (m == MATCH_ERROR)
    return MATCH_ERROR;
  if (m == MATCH_NO)
    goto syntax;

  tail = gfc_get_data_variable ();
  *tail = var;

  parent->list = tail;

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

      m = gfc_match_iterator (&parent->iter, 1);
      if (m == MATCH_YES)
	break;
      if (m == MATCH_ERROR)
	return MATCH_ERROR;

      m = var_element (&var);
      if (m == MATCH_ERROR)
	return MATCH_ERROR;
      if (m == MATCH_NO)
	goto syntax;

      tail->next = gfc_get_data_variable ();
      tail = tail->next;

      *tail = var;
    }

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

syntax:
  gfc_syntax_error (ST_DATA);
  return MATCH_ERROR;
}


/* Match a single element in a data variable list, which can be a
   variable-iterator list.  */

static match
var_element (gfc_data_variable *new_var)
{
  match m;
  gfc_symbol *sym;

  memset (new_var, 0, sizeof (gfc_data_variable));

  if (gfc_match_char ('(') == MATCH_YES)
    return var_list (new_var);

  m = gfc_match_variable (&new_var->expr, 0);
  if (m != MATCH_YES)
    return m;

  if (new_var->expr->expr_type == EXPR_CONSTANT
      && new_var->expr->symtree == NULL)
    {
      gfc_error ("Inquiry parameter cannot appear in a "
		 "data-stmt-object-list at %C");
      return MATCH_ERROR;
    }

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

  /* Symbol should already have an associated type.  */
  if (!gfc_check_symbol_typed (sym, gfc_current_ns, false, gfc_current_locus))
    return MATCH_ERROR;

  if (!sym->attr.function && gfc_current_ns->parent
      && gfc_current_ns->parent == sym->ns)
    {
      gfc_error ("Host associated variable %qs may not be in the DATA "
		 "statement at %C", sym->name);
      return MATCH_ERROR;
    }

  if (gfc_current_state () != COMP_BLOCK_DATA
      && sym->attr.in_common
      && !gfc_notify_std (GFC_STD_GNU, "initialization of "
			  "common block variable %qs in DATA statement at %C",
			  sym->name))
    return MATCH_ERROR;

  if (!gfc_add_data (&sym->attr, sym->name, &new_var->expr->where))
    return MATCH_ERROR;

  return MATCH_YES;
}


/* Match the top-level list of data variables.  */

static match
top_var_list (gfc_data *d)
{
  gfc_data_variable var, *tail, *new_var;
  match m;

  tail = NULL;

  for (;;)
    {
      m = var_element (&var);
      if (m == MATCH_NO)
	goto syntax;
      if (m == MATCH_ERROR)
	return MATCH_ERROR;

      new_var = gfc_get_data_variable ();
      *new_var = var;
      if (new_var->expr)
	new_var->expr->where = gfc_current_locus;

      if (tail == NULL)
	d->var = new_var;
      else
	tail->next = new_var;

      tail = new_var;

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

  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_DATA);
  gfc_free_data_all (gfc_current_ns);
  return MATCH_ERROR;
}


static match
match_data_constant (gfc_expr **result)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_symbol *sym, *dt_sym = NULL;
  gfc_expr *expr;
  match m;
  locus old_loc;

  m = gfc_match_literal_constant (&expr, 1);
  if (m == MATCH_YES)
    {
      *result = expr;
      return MATCH_YES;
    }

  if (m == MATCH_ERROR)
    return MATCH_ERROR;

  m = gfc_match_null (result);
  if (m != MATCH_NO)
    return m;

  old_loc = gfc_current_locus;

  /* Should this be a structure component, try to match it
     before matching a name.  */
  m = gfc_match_rvalue (result);
  if (m == MATCH_ERROR)
    return m;

  if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
    {
      if (!gfc_simplify_expr (*result, 0))
	m = MATCH_ERROR;
      return m;
    }
  else if (m == MATCH_YES)
    {
      /* If a parameter inquiry ends up here, symtree is NULL but **result
	 contains the right constant expression.  Check here.  */
      if ((*result)->symtree == NULL
	  && (*result)->expr_type == EXPR_CONSTANT
	  && ((*result)->ts.type == BT_INTEGER
	      || (*result)->ts.type == BT_REAL))
	return m;

      /* F2018:R845 data-stmt-constant is initial-data-target.
	 A data-stmt-constant shall be ... initial-data-target if and
	 only if the corresponding data-stmt-object has the POINTER
	 attribute. ...  If data-stmt-constant is initial-data-target
	 the corresponding data statement object shall be
	 data-pointer-initialization compatible (7.5.4.6) with the initial
	 data target; the data statement object is initially associated
	 with the target.  */
      if ((*result)->symtree->n.sym->attr.save
	  && (*result)->symtree->n.sym->attr.target)
	return m;
      gfc_free_expr (*result);
    }

  gfc_current_locus = old_loc;

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

  if (gfc_find_symbol (name, NULL, 1, &sym))
    return MATCH_ERROR;

  if (sym && sym->attr.generic)
    dt_sym = gfc_find_dt_in_generic (sym);

  if (sym == NULL
      || (sym->attr.flavor != FL_PARAMETER
	  && (!dt_sym || !gfc_fl_struct (dt_sym->attr.flavor))))
    {
      gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
		 name);
      *result = NULL;
      return MATCH_ERROR;
    }
  else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor))
    return gfc_match_structure_constructor (dt_sym, result);

  /* Check to see if the value is an initialization array expression.  */
  if (sym->value->expr_type == EXPR_ARRAY)
    {
      gfc_current_locus = old_loc;

      m = gfc_match_init_expr (result);
      if (m == MATCH_ERROR)
	return m;

      if (m == MATCH_YES)
	{
	  if (!gfc_simplify_expr (*result, 0))
	    m = MATCH_ERROR;

	  if ((*result)->expr_type == EXPR_CONSTANT)
	    return m;
          else
	    {
	      gfc_error ("Invalid initializer %s in Data statement at %C", name);
	      return MATCH_ERROR;
	    }
	}
    }

  *result = gfc_copy_expr (sym->value);
  return MATCH_YES;
}


/* Match a list of values in a DATA statement.  The leading '/' has
   already been seen at this point.  */

static match
top_val_list (gfc_data *data)
{
  gfc_data_value *new_val, *tail;
  gfc_expr *expr;
  match m;

  tail = NULL;

  for (;;)
    {
      m = match_data_constant (&expr);
      if (m == MATCH_NO)
	goto syntax;
      if (m == MATCH_ERROR)
	return MATCH_ERROR;

      new_val = gfc_get_data_value ();
      mpz_init (new_val->repeat);

      if (tail == NULL)
	data->value = new_val;
      else
	tail->next = new_val;

      tail = new_val;

      if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
	{
	  tail->expr = expr;
	  mpz_set_ui (tail->repeat, 1);
	}
      else
	{
	  mpz_set (tail->repeat, expr->value.integer);
	  gfc_free_expr (expr);

	  m = match_data_constant (&tail->expr);
	  if (m == MATCH_NO)
	    goto syntax;
	  if (m == MATCH_ERROR)
	    return MATCH_ERROR;
	}

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

  return MATCH_YES;

syntax:
  gfc_syntax_error (ST_DATA);
  gfc_free_data_all (gfc_current_ns);
  return MATCH_ERROR;
}


/* Matches an old style initialization.  */

static match
match_old_style_init (const char *name)
{
  match m;
  gfc_symtree *st;
  gfc_symbol *sym;
  gfc_data *newdata, *nd;

  /* Set up data structure to hold initializers.  */
  gfc_find_sym_tree (name, NULL, 0, &st);
  sym = st->n.sym;

  newdata = gfc_get_data ();
  newdata->var = gfc_get_data_variable ();
  newdata->var->expr = gfc_get_variable_expr (st);
  newdata->var->expr->where = sym->declared_at;
  newdata->where = gfc_current_locus;

  /* Match initial value list. This also eats the terminal '/'.  */
  m = top_val_list (newdata);
  if (m != MATCH_YES)
    {
      free (newdata);
      return m;
    }

  /* Check that a BOZ did not creep into an old-style initialization.  */
  for (nd = newdata; nd; nd = nd->next)
    {
      if (nd->value->expr->ts.type == BT_BOZ
	  && gfc_invalid_boz (G_("BOZ at %L cannot appear in an old-style "
			      "initialization"), &nd->value->expr->where))
	return MATCH_ERROR;

      if (nd->var->expr->ts.type != BT_INTEGER
	  && nd->var->expr->ts.type != BT_REAL
	  && nd->value->expr->ts.type == BT_BOZ)
	{
	  gfc_error (G_("BOZ literal constant near %L cannot be assigned to "
		     "a %qs variable in an old-style initialization"),
		     &nd->value->expr->where,
		     gfc_typename (&nd->value->expr->ts));
	  return MATCH_ERROR;
	}
    }

  if (gfc_pure (NULL))
    {
      gfc_error ("Initialization at %C is not allowed in a PURE procedure");
      free (newdata);
      return MATCH_ERROR;
    }
  gfc_unset_implicit_pure (gfc_current_ns->proc_name);

  /* Mark the variable as having appeared in a data statement.  */
  if (!gfc_add_data (&sym->attr, sym->name, &sym->declared_at))
    {
      free (newdata);
      return MATCH_ERROR;
    }

  /* Chain in namespace list of DATA initializers.  */
  newdata->next = gfc_current_ns->data;
  gfc_current_ns->data = newdata;

  return m;
}


/* Match the stuff following a DATA statement. If ERROR_FLAG is set,
   we are matching a DATA statement and are therefore issuing an error
   if we encounter something unexpected, if not, we're trying to match
   an old-style initialization expression of the form INTEGER I /2/.  */

match
gfc_match_data (void)
{
  gfc_data *new_data;
  gfc_expr *e;
  gfc_ref *ref;
  match m;
  char c;

  /* DATA has been matched.  In free form source code, the next character
     needs to be whitespace or '(' from an implied do-loop.  Check that
     here.  */
  c = gfc_peek_ascii_char ();
  if (gfc_current_form == FORM_FREE && !gfc_is_whitespace (c) && c != '(')
    return MATCH_NO;

  /* Before parsing the rest of a DATA statement, check F2008:c1206.  */
  if ((gfc_current_state () == COMP_FUNCTION
       || gfc_current_state () == COMP_SUBROUTINE)
      && gfc_state_stack->previous->state == COMP_INTERFACE)
    {
      gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
      return MATCH_ERROR;
    }

  set_in_match_data (true);

  for (;;)
    {
      new_data = gfc_get_data ();
      new_data->where = gfc_current_locus;

      m = top_var_list (new_data);
      if (m != MATCH_YES)
	goto cleanup;

      if (new_data->var->iter.var
	  && new_data->var->iter.var->ts.type == BT_INTEGER
	  && new_data->var->iter.var->symtree->n.sym->attr.implied_index == 1
	  && new_data->var->list
	  && new_data->var->list->expr
	  && new_data->var->list->expr->ts.type == BT_CHARACTER
	  && new_data->var->list->expr->ref
	  && new_data->var->list->expr->ref->type == REF_SUBSTRING)
	{
	  gfc_error ("Invalid substring in data-implied-do at %L in DATA "
		     "statement", &new_data->var->list->expr->where);
	  goto cleanup;
	}

      /* Check for an entity with an allocatable component, which is not
	 allowed.  */
      e = new_data->var->expr;
      if (e)
	{
	  bool invalid;

	  invalid = false;
	  for (ref = e->ref; ref; ref = ref->next)
	    if ((ref->type == REF_COMPONENT
		 && ref->u.c.component->attr.allocatable)
		|| (ref->type == REF_ARRAY
		    && e->symtree->n.sym->attr.pointer != 1
		    && ref->u.ar.as && ref->u.ar.as->type == AS_DEFERRED))
	      invalid = true;

	  if (invalid)
	    {
	      gfc_error ("Allocatable component or deferred-shaped array "
			 "near %C in DATA statement");
	      goto cleanup;
	    }

	  /* F2008:C567 (R536) A data-i-do-object or a variable that appears
	     as a data-stmt-object shall not be an object designator in which
	     a pointer appears other than as the entire rightmost part-ref.  */
	  if (!e->ref && e->ts.type == BT_DERIVED
	      && e->symtree->n.sym->attr.pointer)
	    goto partref;

	  ref = e->ref;
	  if (e->symtree->n.sym->ts.type == BT_DERIVED
	      && e->symtree->n.sym->attr.pointer
	      && ref->type == REF_COMPONENT)
	    goto partref;

	  for (; ref; ref = ref->next)
	    if (ref->type == REF_COMPONENT
		&& ref->u.c.component->attr.pointer
		&& ref->next)
	      goto partref;
	}

      m = top_val_list (new_data);
      if (m != MATCH_YES)
	goto cleanup;

      new_data->next = gfc_current_ns->data;
      gfc_current_ns->data = new_data;

      /* A BOZ literal constant cannot appear in a structure constructor.
	 Check for that here for a data statement value.  */
      if (new_data->value->expr->ts.type == BT_DERIVED
	  && new_data->value->expr->value.constructor)
	{
	  gfc_constructor *c;
	  c = gfc_constructor_first (new_data->value->expr->value.constructor);
	  for (; c; c = gfc_constructor_next (c))
	    if (c->expr && c->expr->ts.type == BT_BOZ)
	      {
		gfc_error ("BOZ literal constant at %L cannot appear in a "
			   "structure constructor", &c->expr->where);
		return MATCH_ERROR;
	      }
	}

      if (gfc_match_eos () == MATCH_YES)
	break;

      gfc_match_char (',');	/* Optional comma */
    }

  set_in_match_data (false);

  if (gfc_pure (NULL))
    {
      gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
      return MATCH_ERROR;
    }
  gfc_unset_implicit_pure (gfc_current_ns->proc_name);

  return MATCH_YES;

partref:

  gfc_error ("part-ref with pointer attribute near %L is not "
	     "rightmost part-ref of data-stmt-object",
	     &e->where);

cleanup:
  set_in_match_data (false);
  gfc_free_data (new_data);
  return MATCH_ERROR;
}


/************************ Declaration statements *********************/


/* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
   list). The difference here is the expression is a list of constants
   and is surrounded by '/'.
   The typespec ts must match the typespec of the variable which the
   clist is initializing.
   The arrayspec tells whether this should match a list of constants
   corresponding to array elements or a scalar (as == NULL).  */

static match
match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as)
{
  gfc_constructor_base array_head = NULL;
  gfc_expr *expr = NULL;
  match m = MATCH_ERROR;
  locus where;
  mpz_t repeat, cons_size, as_size;
  bool scalar;
  int cmp;

  gcc_assert (ts);

  /* We have already matched '/' - now look for a constant list, as with
     top_val_list from decl.cc, but append the result to an array.  */
  if (gfc_match ("/") == MATCH_YES)
    {
      gfc_error ("Empty old style initializer list at %C");
      return MATCH_ERROR;
    }

  where = gfc_current_locus;
  scalar = !as || !as->rank;

  if (!scalar && !spec_size (as, &as_size))
    {
      gfc_error ("Array in initializer list at %L must have an explicit shape",
		 as->type == AS_EXPLICIT ? &as->upper[0]->where : &where);
      /* Nothing to cleanup yet.  */
      return MATCH_ERROR;
    }

  mpz_init_set_ui (repeat, 0);

  for (;;)
    {
      m = match_data_constant (&expr);
      if (m != MATCH_YES)
        expr = NULL; /* match_data_constant may set expr to garbage */
      if (m == MATCH_NO)
        goto syntax;
      if (m == MATCH_ERROR)
        goto cleanup;

      /* Found r in repeat spec r*c; look for the constant to repeat.  */
      if ( gfc_match_char ('*') == MATCH_YES)
        {
          if (scalar)
            {
              gfc_error ("Repeat spec invalid in scalar initializer at %C");
              goto cleanup;
            }
          if (expr->ts.type != BT_INTEGER)
            {
              gfc_error ("Repeat spec must be an integer at %C");
              goto cleanup;
            }
          mpz_set (repeat, expr->value.integer);
          gfc_free_expr (expr);
          expr = NULL;

          m = match_data_constant (&expr);
          if (m == MATCH_NO)
	    {
	      m = MATCH_ERROR;
	      gfc_error ("Expected data constant after repeat spec at %C");
	    }
          if (m != MATCH_YES)
            goto cleanup;
        }
      /* No repeat spec, we matched the data constant itself. */
      else
        mpz_set_ui (repeat, 1);

      if (!scalar)
        {
          /* Add the constant initializer as many times as repeated. */
          for (; mpz_cmp_ui (repeat, 0) > 0; mpz_sub_ui (repeat, repeat, 1))
            {
              /* Make sure types of elements match */
              if(ts && !gfc_compare_types (&expr->ts, ts)
                    && !gfc_convert_type (expr, ts, 1))
                goto cleanup;

              gfc_constructor_append_expr (&array_head,
                  gfc_copy_expr (expr), &gfc_current_locus);
            }

          gfc_free_expr (expr);
          expr = NULL;
        }

      /* For scalar initializers quit after one element.  */
      else
        {
          if(gfc_match_char ('/') != MATCH_YES)
            {
              gfc_error ("End of scalar initializer expected at %C");
              goto cleanup;
            }
          break;
        }

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

  /* If we break early from here out, we encountered an error.  */
  m = MATCH_ERROR;

  /* Set up expr as an array constructor. */
  if (!scalar)
    {
      expr = gfc_get_array_expr (ts->type, ts->kind, &where);
      expr->ts = *ts;
      expr->value.constructor = array_head;

      /* Validate sizes.  We built expr ourselves, so cons_size will be
	 constant (we fail above for non-constant expressions).
	 We still need to verify that the sizes match.  */
      gcc_assert (gfc_array_size (expr, &cons_size));
      cmp = mpz_cmp (cons_size, as_size);
      if (cmp < 0)
	gfc_error ("Not enough elements in array initializer at %C");
      else if (cmp > 0)
	gfc_error ("Too many elements in array initializer at %C");
      mpz_clear (cons_size);
      if (cmp)
	goto cleanup;

      /* Set the rank/shape to match the LHS as auto-reshape is implied. */
      expr->rank = as->rank;
      expr->shape = gfc_get_shape (as->rank);
      for (int i = 0; i < as->rank; ++i)
	spec_dimen_size (as, i, &expr->shape[i]);
    }

  /* Make sure scalar types match. */
  else if (!gfc_compare_types (&expr->ts, ts)
           && !gfc_convert_type (expr, ts, 1))
    goto cleanup;

  if (expr->ts.u.cl)
    expr->ts.u.cl->length_from_typespec = 1;

  *result = expr;
  m = MATCH_YES;
  goto done;

syntax:
  m = MATCH_ERROR;
  gfc_error ("Syntax error in old style initializer list at %C");

cleanup:
  if (expr)
    expr->value.constructor = NULL;
  gfc_free_expr (expr);
  gfc_constructor_free (array_head);

done:
  mpz_clear (repeat);
  if (!scalar)
    mpz_clear (as_size);
  return m;
}


/* Auxiliary function to merge DIMENSION and CODIMENSION array specs.  */

static bool
merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
{
  if ((from->type == AS_ASSUMED_RANK && to->corank)
      || (to->type == AS_ASSUMED_RANK && from->corank))
    {
      gfc_error ("The assumed-rank array at %C shall not have a codimension");
      return false;
    }

  if (to->rank == 0 && from->rank > 0)
    {
      to->rank = from->rank;
      to->type = from->type;
      to->cray_pointee = from->cray_pointee;
      to->cp_was_assumed = from->cp_was_assumed;

      for (int i = to->corank - 1; i >= 0; i--)
	{
	  /* Do not exceed the limits on lower[] and upper[].  gfortran
	     cleans up elsewhere.  */
	  int j = from->rank + i;
	  if (j >= GFC_MAX_DIMENSIONS)
	    break;

	  to->lower[j] = to->lower[i];
	  to->upper[j] = to->upper[i];
	}
      for (int i = 0; i < from->rank; i++)
	{
	  if (copy)
	    {
	      to->lower[i] = gfc_copy_expr (from->lower[i]);
	      to->upper[i] = gfc_copy_expr (from->upper[i]);
	    }
	  else
	    {
	      to->lower[i] = from->lower[i];
	      to->upper[i] = from->upper[i];
	    }
	}
    }
  else if (to->corank == 0 && from->corank > 0)
    {
      to->corank = from->corank;
      to->cotype = from->cotype;

      for (int i = 0; i < from->corank; i++)
	{
	  /* Do not exceed the limits on lower[] and upper[].  gfortran
	     cleans up elsewhere.  */
	  int k = from->rank + i;
	  int j = to->rank + i;
	  if (j >= GFC_MAX_DIMENSIONS)
	    break;

	  if (copy)
	    {
	      to->lower[j] = gfc_copy_expr (from->lower[k]);
	      to->upper[j] = gfc_copy_expr (from->upper[k]);
	    }
	  else
	    {
	      to->lower[j] = from->lower[k];
	      to->upper[j] = from->upper[k];
	    }
	}
    }

  if (to->rank + to->corank > GFC_MAX_DIMENSIONS)
    {
      gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
		 "allowed dimensions of %d",
		 to->rank, to->corank, GFC_MAX_DIMENSIONS);
      to->corank = GFC_MAX_DIMENSIONS - to->rank;
      return false;
    }
  return true;
}


/* Match an intent specification.  Since this can only happen after an
   INTENT word, a legal intent-spec must follow.  */

static sym_intent
match_intent_spec (void)
{

  if (gfc_match (" ( in out )") == MATCH_YES)
    return INTENT_INOUT;
  if (gfc_match (" ( in )") == MATCH_YES)
    return INTENT_IN;
  if (gfc_match (" ( out )") == MATCH_YES)
    return INTENT_OUT;

  gfc_error ("Bad INTENT specification at %C");
  return INTENT_UNKNOWN;
}


/* Matches a character length specification, which is either a
   specification expression, '*', or ':'.  */

static match
char_len_param_value (gfc_expr **expr, bool *deferred)
{
  match m;

  *expr = NULL;
  *deferred = false;

  if (gfc_match_char ('*') == MATCH_YES)
    return MATCH_YES;

  if (gfc_match_char (':') == MATCH_YES)
    {
      if (!gfc_notify_std (GFC_STD_F2003, "deferred type parameter at %C"))
	return MATCH_ERROR;

      *deferred = true;

      return MATCH_YES;
    }

  m = gfc_match_expr (expr);

  if (m == MATCH_NO || m == MATCH_ERROR)
    return m;

  if (!gfc_expr_check_typed (*expr, gfc_current_ns, false))
    return MATCH_ERROR;

  /* If gfortran gets an EXPR_OP, try to simplifiy it.  This catches things
     like CHARACTER(([1])).   */
  if ((*expr)->expr_type == EXPR_OP)
    gfc_simplify_expr (*expr, 1);

  if ((*expr)->expr_type == EXPR_FUNCTION)
    {
      if ((*expr)->ts.type == BT_INTEGER
	  || ((*expr)->ts.type == BT_UNKNOWN
	      && strcmp((*expr)->symtree->name, "null") != 0))
	return MATCH_YES;

      goto syntax;
    }
  else if ((*expr)->expr_type == EXPR_CONSTANT)
    {
      /* F2008, 4.4.3.1:  The length is a type parameter; its kind is
	 processor dependent and its value is greater than or equal to zero.
	 F2008, 4.4.3.2:  If the character length parameter value evaluates
	 to a negative value, the length of character entities declared
	 is zero.  */

      if ((*expr)->ts.type == BT_INTEGER)
	{
	  if (mpz_cmp_si ((*expr)->value.integer, 0) < 0)
	    mpz_set_si ((*expr)->value.integer, 0);
	}
      else
	goto syntax;
    }
  else if ((*expr)->expr_type == EXPR_ARRAY)
    goto syntax;
  else if ((*expr)->expr_type == EXPR_VARIABLE)
    {
      bool t;
      gfc_expr *e;

      e = gfc_copy_expr (*expr);

      /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
	 which causes an ICE if gfc_reduce_init_expr() is called.  */
      if (e->ref && e->ref->type == REF_ARRAY
	  && e->ref->u.ar.type == AR_UNKNOWN
	  && e->ref->u.ar.dimen_type[0] == DIMEN_RANGE)
	goto syntax;

      t = gfc_reduce_init_expr (e);

      if (!t && e->ts.type == BT_UNKNOWN
	  && e->symtree->n.sym->attr.untyped == 1
	  && (flag_implicit_none
	      || e->symtree->n.sym->ns->seen_implicit_none == 1
	      || e->symtree->n.sym->ns->parent->seen_implicit_none == 1))
	{
	  gfc_free_expr (e);
	  goto syntax;
	}

      if ((e->ref && e->ref->type == REF_ARRAY
	   && e->ref->u.ar.type != AR_ELEMENT)
	  || (!e->ref && e->expr_type == EXPR_ARRAY))
	{
	  gfc_free_expr (e);
	  goto syntax;
	}

      gfc_free_expr (e);
    }

  if (gfc_seen_div0)
    m = MATCH_ERROR;

  return m;

syntax:
  gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where);
  return MATCH_ERROR;
}


/* A character length is a '*' followed by a literal integer or a
   char_len_param_value in parenthesis.  */

static match
match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check)
{
  int length;
  match m;

  *deferred = false;
  m = gfc_match_char ('*');
  if (m != MATCH_YES)
    return m;

  m = gfc_match_small_literal_int (&length, NULL);
  if (m == MATCH_ERROR)
    return m;

  if (m == MATCH_YES)
    {
      if (obsolescent_check
	  && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C"))
	return MATCH_ERROR;
      *expr = gfc_get_int_expr (gfc_charlen_int_kind, NULL, length);
      return m;
    }

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

  m = char_len_param_value (expr, deferred);
  if (m != MATCH_YES && gfc_matching_function)
    {
      gfc_undo_symbols ();
      m = MATCH_YES;
    }

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

  if (gfc_match_char (')') == MATCH_NO)
    {
      gfc_free_expr (*expr);
      *expr = NULL;
      goto syntax;
    }

  return MATCH_YES;

syntax:
  gfc_error ("Syntax error in character length specification at %C");
  return MATCH_ERROR;
}


/* Special subroutine for finding a symbol.  Check if the name is found
   in the current name space.  If not, and we're compiling a function or
   subroutine and the parent compilation unit is an interface, then check
   to see if the name we've been given is the name of the interface
   (located in another namespace).  */

static int
find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
{
  gfc_state_data *s;
  gfc_symtree *st;
  int i;

  i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine);
  if (i == 0)
    {
      *result = st ? st->n.sym : NULL;
      goto end;
    }

  if (gfc_current_state () != COMP_SUBROUTINE
      && gfc_current_state () != COMP_FUNCTION)
    goto end;

  s = gfc_state_stack->previous;
  if (s == NULL)
    goto end;

  if (s->state != COMP_INTERFACE)
    goto end;
  if (s->sym == NULL)
    goto end;		  /* Nameless interface.  */

  if (strcmp (name, s->sym->name) == 0)
    {
      *result = s->sym;
      return 0;
    }

end:
  return i;
}


/* Special subroutine for getting a symbol node associated with a
   procedure name, used in SUBROUTINE and FUNCTION statements.  The
   symbol is created in the parent using with symtree node in the
   child unit pointing to the symbol.  If the current namespace has no
   parent, then the symbol is just created in the current unit.  */

static int
get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
{
  gfc_symtree *st;
  gfc_symbol *sym;
  int rc = 0;

  /* Module functions have to be left in their own namespace because
     they have potentially (almost certainly!) already been referenced.
     In this sense, they are rather like external functions.  This is
     fixed up in resolve.cc(resolve_entries), where the symbol name-
     space is set to point to the master function, so that the fake
     result mechanism can work.  */
  if (module_fcn_entry)
    {
      /* Present if entry is declared to be a module procedure.  */
      rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);

      if (*result == NULL)
	rc = gfc_get_symbol (name, NULL, result);
      else if (!gfc_get_symbol (name, NULL, &sym) && sym
		 && (*result)->ts.type == BT_UNKNOWN
		 && sym->attr.flavor == FL_UNKNOWN)
	/* Pick up the typespec for the entry, if declared in the function
	   body.  Note that this symbol is FL_UNKNOWN because it will
	   only have appeared in a type declaration.  The local symtree
	   is set to point to the module symbol and a unique symtree
	   to the local version.  This latter ensures a correct clearing
	   of the symbols.  */
	{
	  /* If the ENTRY proceeds its specification, we need to ensure
	     that this does not raise a "has no IMPLICIT type" error.  */
	  if (sym->ts.type == BT_UNKNOWN)
	    sym->attr.untyped = 1;

	  (*result)->ts = sym->ts;

	  /* Put the symbol in the procedure namespace so that, should
	     the ENTRY precede its specification, the specification
	     can be applied.  */
	  (*result)->ns = gfc_current_ns;

	  gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
	  st->n.sym = *result;
	  st = gfc_get_unique_symtree (gfc_current_ns);
	  sym->refs++;
	  st->n.sym = sym;
	}
    }
  else
    rc = gfc_get_symbol (name, gfc_current_ns->parent, result);

  if (rc)
    return rc;

  sym = *result;
  if (sym->attr.proc == PROC_ST_FUNCTION)
    return rc;

  if (sym->attr.module_procedure && sym->attr.if_source == IFSRC_IFBODY)
    {
      /* Create a partially populated interface symbol to carry the
	 characteristics of the procedure and the result.  */
      sym->tlink = gfc_new_symbol (name, sym->ns);
      gfc_add_type (sym->tlink, &(sym->ts), &gfc_current_locus);
      gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL);
      if (sym->attr.dimension)
	sym->tlink->as = gfc_copy_array_spec (sym->as);

      /* Ideally, at this point, a copy would be made of the formal
	 arguments and their namespace. However, this does not appear
	 to be necessary, albeit at the expense of not being able to
	 use gfc_compare_interfaces directly.  */

      if (sym->result && sym->result != sym)
	{
	  sym->tlink->result = sym->result;
	  sym->result = NULL;
	}
      else if (sym->result)
	{
	  sym->tlink->result = sym->tlink;
	}
    }
  else if (sym && !sym->gfc_new
	   && gfc_current_state () != COMP_INTERFACE)
    {
      /* Trap another encompassed procedure with the same name.  All
	 these conditions are necessary to avoid picking up an entry
	 whose name clashes with that of the encompassing procedure;
	 this is handled using gsymbols to register unique, globally
	 accessible names.  */
      if (sym->attr.flavor != 0
	  && sym->attr.proc != 0
	  && (sym->attr.subroutine || sym->attr.function || sym->attr.entry)
	  && sym->attr.if_source != IFSRC_UNKNOWN)
	{
	  gfc_error_now ("Procedure %qs at %C is already defined at %L",
			 name, &sym->declared_at);
	  return true;
	}
      if (sym->attr.flavor != 0
	  && sym->attr.entry && sym->attr.if_source != IFSRC_UNKNOWN)
	{
	  gfc_error_now ("Procedure %qs at %C is already defined at %L",
			 name, &sym->declared_at);
	  return true;
	}

      if (sym->attr.external && sym->attr.procedure
	  && gfc_current_state () == COMP_CONTAINS)
	{
	  gfc_error_now ("Contained procedure %qs at %C clashes with "
			 "procedure defined at %L",
			 name, &sym->declared_at);
	  return true;
	}

      /* Trap a procedure with a name the same as interface in the
	 encompassing scope.  */
      if (sym->attr.generic != 0
	  && (sym->attr.subroutine || sym->attr.function)
	  && !sym->attr.mod_proc)
	{
	  gfc_error_now ("Name %qs at %C is already defined"
			 " as a generic interface at %L",
			 name, &sym->declared_at);
	  return true;
	}

      /* Trap declarations of attributes in encompassing scope.  The
	 signature for this is that ts.kind is nonzero for no-CLASS
	 entity.  For a CLASS entity, ts.kind is zero.  */
      if ((sym->ts.kind != 0 || sym->ts.type == BT_CLASS)
	  && !sym->attr.implicit_type
	  && sym->attr.proc == 0
	  && gfc_current_ns->parent != NULL
	  && sym->attr.access == 0
	  && !module_fcn_entry)
	{
	  gfc_error_now ("Procedure %qs at %C has an explicit interface "
		       "from a previous declaration",  name);
	  return true;
	}
    }

  /* C1246 (R1225) MODULE shall appear only in the function-stmt or
     subroutine-stmt of a module subprogram or of a nonabstract interface
     body that is declared in the scoping unit of a module or submodule.  */
  if (sym->attr.external
      && (sym->attr.subroutine || sym->attr.function)
      && sym->attr.if_source == IFSRC_IFBODY
      && !current_attr.module_procedure
      && sym->attr.proc == PROC_MODULE
      && gfc_state_stack->state == COMP_CONTAINS)
    {
      gfc_error_now ("Procedure %qs defined in interface body at %L "
		     "clashes with internal procedure defined at %C",
		     name, &sym->declared_at);
      return true;
    }

  if (sym && !sym->gfc_new
      && sym->attr.flavor != FL_UNKNOWN
      && sym->attr.referenced == 0 && sym->attr.subroutine == 1
      && gfc_state_stack->state == COMP_CONTAINS
      && gfc_state_stack->previous->state == COMP_SUBROUTINE)
    {
      gfc_error_now ("Procedure %qs at %C is already defined at %L",
		     name, &sym->declared_at);
      return true;
    }

  if (gfc_current_ns->parent == NULL || *result == NULL)
    return rc;

  /* Module function entries will already have a symtree in
     the current namespace but will need one at module level.  */
  if (module_fcn_entry)
    {
      /* Present if entry is declared to be a module procedure.  */
      rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
      if (st == NULL)
	st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
    }
  else
    st = gfc_new_symtree (&gfc_current_ns->sym_root, name);

  st->n.sym = sym;
  sym->refs++;

  /* See if the procedure should be a module procedure.  */

  if (((sym->ns->proc_name != NULL
	&& sym->ns->proc_name->attr.flavor == FL_MODULE
	&& sym->attr.proc != PROC_MODULE)
       || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
      && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
    rc = 2;

  return rc;
}


/* Verify that the given symbol representing a parameter is C
   interoperable, by checking to see if it was marked as such after
   its declaration.  If the given symbol is not interoperable, a
   warning is reported, thus removing the need to return the status to
   the calling function.  The standard does not require the user use
   one of the iso_c_binding named constants to declare an
   interoperable parameter, but we can't be sure if the param is C
   interop or not if the user doesn't.  For example, integer(4) may be
   legal Fortran, but doesn't have meaning in C.  It may interop with
   a number of the C types, which causes a problem because the
   compiler can't know which one.  This code is almost certainly not
   portable, and the user will get what they deserve if the C type
   across platforms isn't always interoperable with integer(4).  If
   the user had used something like integer(c_int) or integer(c_long),
   the compiler could have automatically handled the varying sizes
   across platforms.  */

bool
gfc_verify_c_interop_param (gfc_symbol *sym)
{
  int is_c_interop = 0;
  bool retval = true;

  /* We check implicitly typed variables in symbol.cc:gfc_set_default_type().
     Don't repeat the checks here.  */
  if (sym->attr.implicit_type)
    return true;

  /* For subroutines or functions that are passed to a BIND(C) procedure,
     they're interoperable if they're BIND(C) and their params are all
     interoperable.  */
  if (sym->attr.flavor == FL_PROCEDURE)
    {
      if (sym->attr.is_bind_c == 0)
        {
          gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
			 "attribute to be C interoperable", sym->name,
			 &(sym->declared_at));
          return false;
        }
      else
        {
          if (sym->attr.is_c_interop == 1)
            /* We've already checked this procedure; don't check it again.  */
            return true;
          else
            return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
                                      sym->common_block);
        }
    }

  /* See if we've stored a reference to a procedure that owns sym.  */
  if (sym->ns != NULL && sym->ns->proc_name != NULL)
    {
      if (sym->ns->proc_name->attr.is_bind_c == 1)
	{
	  is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0);

	  if (is_c_interop != 1)
	    {
	      /* Make personalized messages to give better feedback.  */
	      if (sym->ts.type == BT_DERIVED)
		gfc_error ("Variable %qs at %L is a dummy argument to the "
			   "BIND(C) procedure %qs but is not C interoperable "
			   "because derived type %qs is not C interoperable",
			   sym->name, &(sym->declared_at),
			   sym->ns->proc_name->name,
			   sym->ts.u.derived->name);
	      else if (sym->ts.type == BT_CLASS)
		gfc_error ("Variable %qs at %L is a dummy argument to the "
			   "BIND(C) procedure %qs but is not C interoperable "
			   "because it is polymorphic",
			   sym->name, &(sym->declared_at),
			   sym->ns->proc_name->name);
	      else if (warn_c_binding_type)
		gfc_warning (OPT_Wc_binding_type,
			     "Variable %qs at %L is a dummy argument of the "
			     "BIND(C) procedure %qs but may not be C "
			     "interoperable",
			     sym->name, &(sym->declared_at),
			     sym->ns->proc_name->name);
	    }

	  /* Per F2018, 18.3.6 (5), pointer + contiguous is not permitted.  */
	  if (sym->attr.pointer && sym->attr.contiguous)
	    gfc_error ("Dummy argument %qs at %L may not be a pointer with "
		       "CONTIGUOUS attribute as procedure %qs is BIND(C)",
		       sym->name, &sym->declared_at, sym->ns->proc_name->name);

	  /* Per F2018, C1557, pointer/allocatable dummies to a bind(c)
	     procedure that are default-initialized are not permitted.  */
	  if ((sym->attr.pointer || sym->attr.allocatable)
	      && sym->ts.type == BT_DERIVED
	      && gfc_has_default_initializer (sym->ts.u.derived))
	    {
	      gfc_error ("Default-initialized %s dummy argument %qs "
			 "at %L is not permitted in BIND(C) procedure %qs",
			 (sym->attr.pointer ? "pointer" : "allocatable"),
			 sym->name, &sym->declared_at,
			 sym->ns->proc_name->name);
	      retval = false;
	    }

          /* Character strings are only C interoperable if they have a
	     length of 1.  However, as an argument they are also iteroperable
	     when passed as descriptor (which requires len=: or len=*).  */
	  if (sym->ts.type == BT_CHARACTER)
	    {
	      gfc_charlen *cl = sym->ts.u.cl;

	      if (sym->attr.allocatable || sym->attr.pointer)
		{
		  /* F2018, 18.3.6 (6).  */
		  if (!sym->ts.deferred)
		    {
		      if (sym->attr.allocatable)
			gfc_error ("Allocatable character dummy argument %qs "
				   "at %L must have deferred length as "
				   "procedure %qs is BIND(C)", sym->name,
				   &sym->declared_at, sym->ns->proc_name->name);
		      else
			gfc_error ("Pointer character dummy argument %qs at %L "
				   "must have deferred length as procedure %qs "
				   "is BIND(C)", sym->name, &sym->declared_at,
				   sym->ns->proc_name->name);
		      retval = false;
		    }
		  else if (!gfc_notify_std (GFC_STD_F2018,
					    "Deferred-length character dummy "
					    "argument %qs at %L of procedure "
					    "%qs with BIND(C) attribute",
					    sym->name, &sym->declared_at,
					    sym->ns->proc_name->name))
		    retval = false;
		}
	      else if (sym->attr.value
		       && (!cl || !cl->length
			   || cl->length->expr_type != EXPR_CONSTANT
			   || mpz_cmp_si (cl->length->value.integer, 1) != 0))
		{
		  gfc_error ("Character dummy argument %qs at %L must be "
			     "of length 1 as it has the VALUE attribute",
			     sym->name, &sym->declared_at);
		  retval = false;
		}
	      else if (!cl || !cl->length)
		{
		  /* Assumed length; F2018, 18.3.6 (5)(2).
		     Uses the CFI array descriptor - also for scalars and
		     explicit-size/assumed-size arrays.  */
		  if (!gfc_notify_std (GFC_STD_F2018,
				      "Assumed-length character dummy argument "
				      "%qs at %L of procedure %qs with BIND(C) "
				      "attribute", sym->name, &sym->declared_at,
				      sym->ns->proc_name->name))
		    retval = false;
		}
	      else if (cl->length->expr_type != EXPR_CONSTANT
		       || mpz_cmp_si (cl->length->value.integer, 1) != 0)
		{
		  /* F2018, 18.3.6, (5), item 4.  */
		  if (!sym->attr.dimension
		      || sym->as->type == AS_ASSUMED_SIZE
		      || sym->as->type == AS_EXPLICIT)
		    {
		      gfc_error ("Character dummy argument %qs at %L must be "
				 "of constant length of one or assumed length, "
				 "unless it has assumed shape or assumed rank, "
				 "as procedure %qs has the BIND(C) attribute",
				 sym->name, &sym->declared_at,
				 sym->ns->proc_name->name);
		      retval = false;
		    }
		  /* else: valid only since F2018 - and an assumed-shape/rank
		     array; however, gfc_notify_std is already called when
		     those array types are used. Thus, silently accept F200x. */
		}
	    }

	  /* We have to make sure that any param to a bind(c) routine does
	     not have the allocatable, pointer, or optional attributes,
	     according to J3/04-007, section 5.1.  */
	  if (sym->attr.allocatable == 1
	      && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
				  "ALLOCATABLE attribute in procedure %qs "
				  "with BIND(C)", sym->name,
				  &(sym->declared_at),
				  sym->ns->proc_name->name))
	    retval = false;

	  if (sym->attr.pointer == 1
	      && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
				  "POINTER attribute in procedure %qs "
				  "with BIND(C)", sym->name,
				  &(sym->declared_at),
				  sym->ns->proc_name->name))
	    retval = false;

	  if (sym->attr.optional == 1 && sym->attr.value)
	    {
	      gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
			 "and the VALUE attribute because procedure %qs "
			 "is BIND(C)", sym->name, &(sym->declared_at),
			 sym->ns->proc_name->name);
	      retval = false;
	    }
	  else if (sym->attr.optional == 1
		   && !gfc_notify_std (GFC_STD_F2018, "Variable %qs "
				       "at %L with OPTIONAL attribute in "
				       "procedure %qs which is BIND(C)",
				       sym->name, &(sym->declared_at),
				       sym->ns->proc_name->name))
	    retval = false;

          /* Make sure that if it has the dimension attribute, that it is
	     either assumed size or explicit shape. Deferred shape is already
	     covered by the pointer/allocatable attribute.  */
	  if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE
	      && !gfc_notify_std (GFC_STD_F2018, "Assumed-shape array %qs "
				  "at %L as dummy argument to the BIND(C) "
				  "procedure %qs at %L", sym->name,
				  &(sym->declared_at),
				  sym->ns->proc_name->name,
				  &(sym->ns->proc_name->declared_at)))
	    retval = false;
	}
    }

  return retval;
}



/* Function called by variable_decl() that adds a name to the symbol table.  */

static bool
build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
	   gfc_array_spec **as, locus *var_locus)
{
  symbol_attribute attr;
  gfc_symbol *sym;
  int upper;
  gfc_symtree *st;

  /* Symbols in a submodule are host associated from the parent module or
     submodules. Therefore, they can be overridden by declarations in the
     submodule scope. Deal with this by attaching the existing symbol to
     a new symtree and recycling the old symtree with a new symbol...  */
  st = gfc_find_symtree (gfc_current_ns->sym_root, name);
  if (st != NULL && gfc_state_stack->state == COMP_SUBMODULE
      && st->n.sym != NULL
      && st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule)
    {
      gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
      s->n.sym = st->n.sym;
      sym = gfc_new_symbol (name, gfc_current_ns);


      st->n.sym = sym;
      sym->refs++;
      gfc_set_sym_referenced (sym);
    }
  /* ...Otherwise generate a new symtree and new symbol.  */
  else if (gfc_get_symbol (name, NULL, &sym))
    return false;

  /* Check if the name has already been defined as a type.  The
     first letter of the symtree will be in upper case then.  Of
     course, this is only necessary if the upper case letter is
     actually different.  */

  upper = TOUPPER(name[0]);
  if (upper != name[0])
    {
      char u_name[GFC_MAX_SYMBOL_LEN + 1];
      gfc_symtree *st;

      gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN);
      strcpy (u_name, name);
      u_name[0] = upper;

      st = gfc_find_symtree (gfc_current_ns->sym_root, u_name);

      /* STRUCTURE types can alias symbol names */
      if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT)
	{
	  gfc_error ("Symbol %qs at %C also declared as a type at %L", name,
		     &st->n.sym->declared_at);
	  return false;
	}
    }

  /* Start updating the symbol table.  Add basic type attribute if present.  */
  if (current_ts.type != BT_UNKNOWN
      && (sym->attr.implicit_type == 0
	  || !gfc_compare_types (&sym->ts, &current_ts))
      && !gfc_add_type (sym, &current_ts, var_locus))
    return false;

  if (sym->ts.type == BT_CHARACTER)
    {
      sym->ts.u.cl = cl;
      sym->ts.deferred = cl_deferred;
    }

  /* Add dimension attribute if present.  */
  if (!gfc_set_array_spec (sym, *as, var_locus))
    return false;
  *as = NULL;

  /* Add attribute to symbol.  The copy is so that we can reset the
     dimension attribute.  */
  attr = current_attr;
  attr.dimension = 0;
  attr.codimension = 0;

  if (!gfc_copy_attr (&sym->attr, &attr, var_locus))
    return false;

  /* Finish any work that may need to be done for the binding label,
     if it's a bind(c).  The bind(c) attr is found before the symbol
     is made, and before the symbol name (for data decls), so the
     current_ts is holding the binding label, or nothing if the
     name= attr wasn't given.  Therefore, test here if we're dealing
     with a bind(c) and make sure the binding label is set correctly.  */
  if (sym->attr.is_bind_c == 1)
    {
      if (!sym->binding_label)
        {
	  /* Set the binding label and verify that if a NAME= was specified
	     then only one identifier was in the entity-decl-list.  */
	  if (!set_binding_label (&sym->binding_label, sym->name,
				  num_idents_on_line))
            return false;
        }
    }

  /* See if we know we're in a common block, and if it's a bind(c)
     common then we need to make sure we're an interoperable type.  */
  if (sym->attr.in_common == 1)
    {
      /* Test the common block object.  */
      if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
          && sym->ts.is_c_interop != 1)
        {
          gfc_error_now ("Variable %qs in common block %qs at %C "
                         "must be declared with a C interoperable "
                         "kind since common block %qs is BIND(C)",
                         sym->name, sym->common_block->name,
                         sym->common_block->name);
          gfc_clear_error ();
        }
    }

  sym->attr.implied_index = 0;

  /* Use the parameter expressions for a parameterized derived type.  */
  if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
      && sym->ts.u.derived->attr.pdt_type && type_param_spec_list)
    sym->param_list = gfc_copy_actual_arglist (type_param_spec_list);

  if (sym->ts.type == BT_CLASS)
    return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);

  return true;
}


/* Set character constant to the given length. The constant will be padded or
   truncated.  If we're inside an array constructor without a typespec, we
   additionally check that all elements have the same length; check_len -1
   means no checking.  */

void
gfc_set_constant_character_len (gfc_charlen_t len, gfc_expr *expr,
				gfc_charlen_t check_len)
{
  gfc_char_t *s;
  gfc_charlen_t slen;

  if (expr->ts.type != BT_CHARACTER)
    return;

  if (expr->expr_type != EXPR_CONSTANT)
    {
      gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where);
      return;
    }

  slen = expr->value.character.length;
  if (len != slen)
    {
      s = gfc_get_wide_string (len + 1);
      memcpy (s, expr->value.character.string,
	      MIN (len, slen) * sizeof (gfc_char_t));
      if (len > slen)
	gfc_wide_memset (&s[slen], ' ', len - slen);

      if (warn_character_truncation && slen > len)
	gfc_warning_now (OPT_Wcharacter_truncation,
			 "CHARACTER expression at %L is being truncated "
			 "(%ld/%ld)", &expr->where,
			 (long) slen, (long) len);

      /* Apply the standard by 'hand' otherwise it gets cleared for
	 initializers.  */
      if (check_len != -1 && slen != check_len
          && !(gfc_option.allow_std & GFC_STD_GNU))
	gfc_error_now ("The CHARACTER elements of the array constructor "
		       "at %L must have the same length (%ld/%ld)",
		       &expr->where, (long) slen,
		       (long) check_len);

      s[len] = '\0';
      free (expr->value.character.string);
      expr->value.character.string = s;
      expr->value.character.length = len;
      /* If explicit representation was given, clear it
	 as it is no longer needed after padding.  */
      if (expr->representation.length)
	{
	  expr->representation.length = 0;
	  free (expr->representation.string);
	  expr->representation.string = NULL;
	}
    }
}


/* Function to create and update the enumerator history
   using the information passed as arguments.
   Pointer "max_enum" is also updated, to point to
   enum history node containing largest initializer.

   SYM points to the symbol node of enumerator.
   INIT points to its enumerator value.  */

static void
create_enum_history (gfc_symbol *sym, gfc_expr *init)
{
  enumerator_history *new_enum_history;
  gcc_assert (sym != NULL && init != NULL);

  new_enum_history = XCNEW (enumerator_history);

  new_enum_history->sym = sym;
  new_enum_history->initializer = init;
  new_enum_history->next = NULL;

  if (enum_history == NULL)
    {
      enum_history = new_enum_history;
      max_enum = enum_history;
    }
  else
    {
      new_enum_history->next = enum_history;
      enum_history = new_enum_history;

      if (mpz_cmp (max_enum->initializer->value.integer,
		   new_enum_history->initializer->value.integer) < 0)
	max_enum = new_enum_history;
    }
}


/* Function to free enum kind history.  */

void
gfc_free_enum_history (void)
{
  enumerator_history *current = enum_history;
  enumerator_history *next;

  while (current != NULL)
    {
      next = current->next;
      free (current);
      current = next;
    }
  max_enum = NULL;
  enum_history = NULL;
}


/* Function called by variable_decl() that adds an initialization
   expression to a symbol.  */

static bool
add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
{
  symbol_attribute attr;
  gfc_symbol *sym;
  gfc_expr *init;

  init = *initp;
  if (find_special (name, &sym, false))
    return false;

  attr = sym->attr;

  /* If this symbol is confirming an implicit parameter type,
     then an initialization expression is not allowed.  */
  if (attr.flavor == FL_PARAMETER && sym->value != NULL)
    {
      if (*initp != NULL)
	{
	  gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
		     sym->name);
	  return false;
	}
      else
	return true;
    }

  if (init == NULL)
    {
      /* An initializer is required for PARAMETER declarations.  */
      if (attr.flavor == FL_PARAMETER)
	{
	  gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
	  return false;
	}
    }
  else
    {
      /* If a variable appears in a DATA block, it cannot have an
	 initializer.  */
      if (sym->attr.data)
	{
	  gfc_error ("Variable %qs at %C with an initializer already "
		     "appears in a DATA statement", sym->name);
	  return false;
	}

      /* Check if the assignment can happen. This has to be put off
	 until later for derived type variables and procedure pointers.  */
      if (!gfc_bt_struct (sym->ts.type) && !gfc_bt_struct (init->ts.type)
	  && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
	  && !sym->attr.proc_pointer
	  && !gfc_check_assign_symbol (sym, NULL, init))
	return false;

      if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
	    && init->ts.type == BT_CHARACTER)
	{
	  /* Update symbol character length according initializer.  */
	  if (!gfc_check_assign_symbol (sym, NULL, init))
	    return false;

	  if (sym->ts.u.cl->length == NULL)
	    {
	      gfc_charlen_t clen;
	      /* If there are multiple CHARACTER variables declared on the
		 same line, we don't want them to share the same length.  */
	      sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);

	      if (sym->attr.flavor == FL_PARAMETER)
		{
		  if (init->expr_type == EXPR_CONSTANT)
		    {
		      clen = init->value.character.length;
		      sym->ts.u.cl->length
				= gfc_get_int_expr (gfc_charlen_int_kind,
						    NULL, clen);
		    }
		  else if (init->expr_type == EXPR_ARRAY)
		    {
		      if (init->ts.u.cl && init->ts.u.cl->length)
			{
			  const gfc_expr *length = init->ts.u.cl->length;
			  if (length->expr_type != EXPR_CONSTANT)
			    {
			      gfc_error ("Cannot initialize parameter array "
					 "at %L "
					 "with variable length elements",
					 &sym->declared_at);
			      return false;
			    }
			  clen = mpz_get_si (length->value.integer);
			}
		      else if (init->value.constructor)
			{
			  gfc_constructor *c;
	                  c = gfc_constructor_first (init->value.constructor);
	                  clen = c->expr->value.character.length;
			}
		      else
			  gcc_unreachable ();
		      sym->ts.u.cl->length
				= gfc_get_int_expr (gfc_charlen_int_kind,
						    NULL, clen);
		    }
		  else if (init->ts.u.cl && init->ts.u.cl->length)
		    sym->ts.u.cl->length =
				gfc_copy_expr (init->ts.u.cl->length);
		}
	    }
	  /* Update initializer character length according symbol.  */
	  else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
	    {
	      if (!gfc_specification_expr (sym->ts.u.cl->length))
		return false;

	      int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind,
					 false);
	      /* resolve_charlen will complain later on if the length
		 is too large.  Just skeep the initialization in that case.  */
	      if (mpz_cmp (sym->ts.u.cl->length->value.integer,
			   gfc_integer_kinds[k].huge) <= 0)
		{
		  HOST_WIDE_INT len
		    = gfc_mpz_get_hwi (sym->ts.u.cl->length->value.integer);

		  if (init->expr_type == EXPR_CONSTANT)
		    gfc_set_constant_character_len (len, init, -1);
		  else if (init->expr_type == EXPR_ARRAY)
		    {
		      gfc_constructor *c;

		      /* Build a new charlen to prevent simplification from
			 deleting the length before it is resolved.  */
		      init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
		      init->ts.u.cl->length
			= gfc_copy_expr (sym->ts.u.cl->length);

		      for (c = gfc_constructor_first (init->value.constructor);
			   c; c = gfc_constructor_next (c))
			gfc_set_constant_character_len (len, c->expr, -1);
		    }
		}
	    }
	}

      if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension && sym->as
	  && sym->as->rank && init->rank && init->rank != sym->as->rank)
	{
	  gfc_error ("Rank mismatch of array at %L and its initializer "
		     "(%d/%d)", &sym->declared_at, sym->as->rank, init->rank);
	  return false;
	}

      /* If sym is implied-shape, set its upper bounds from init.  */
      if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
	  && sym->as->type == AS_IMPLIED_SHAPE)
	{
	  int dim;

	  if (init->rank == 0)
	    {
	      gfc_error ("Cannot initialize implied-shape array at %L"
			 " with scalar", &sym->declared_at);
	      return false;
	    }

	  /* The shape may be NULL for EXPR_ARRAY, set it.  */
	  if (init->shape == NULL)
	    {
	      gcc_assert (init->expr_type == EXPR_ARRAY);
	      init->shape = gfc_get_shape (1);
	      if (!gfc_array_size (init, &init->shape[0]))
		  gfc_internal_error ("gfc_array_size failed");
	    }

	  for (dim = 0; dim < sym->as->rank; ++dim)
	    {
	      int k;
	      gfc_expr *e, *lower;

	      lower = sym->as->lower[dim];

	      /* If the lower bound is an array element from another
		 parameterized array, then it is marked with EXPR_VARIABLE and
		 is an initialization expression.  Try to reduce it.  */
	      if (lower->expr_type == EXPR_VARIABLE)
		gfc_reduce_init_expr (lower);

	      if (lower->expr_type == EXPR_CONSTANT)
		{
		  /* All dimensions must be without upper bound.  */
		  gcc_assert (!sym->as->upper[dim]);

		  k = lower->ts.kind;
		  e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
		  mpz_add (e->value.integer, lower->value.integer,
			   init->shape[dim]);
		  mpz_sub_ui (e->value.integer, e->value.integer, 1);
		  sym->as->upper[dim] = e;
		}
	      else
		{
		  gfc_error ("Non-constant lower bound in implied-shape"
			     " declaration at %L", &lower->where);
		  return false;
		}
	    }

	  sym->as->type = AS_EXPLICIT;
	}

      /* Ensure that explicit bounds are simplified.  */
      if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
	  && sym->as->type == AS_EXPLICIT)
	{
	  for (int dim = 0; dim < sym->as->rank; ++dim)
	    {
	      gfc_expr *e;

	      e = sym->as->lower[dim];
	      if (e->expr_type != EXPR_CONSTANT)
		gfc_reduce_init_expr (e);

	      e = sym->as->upper[dim];
	      if (e->expr_type != EXPR_CONSTANT)
		gfc_reduce_init_expr (e);
	    }
	}

      /* Need to check if the expression we initialized this
	 to was one of the iso_c_binding named constants.  If so,
	 and we're a parameter (constant), let it be iso_c.
	 For example:
	 integer(c_int), parameter :: my_int = c_int
	 integer(my_int) :: my_int_2
	 If we mark my_int as iso_c (since we can see it's value
	 is equal to one of the named constants), then my_int_2
	 will be considered C interoperable.  */
      if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type))
	{
	  sym->ts.is_iso_c |= init->ts.is_iso_c;
	  sym->ts.is_c_interop |= init->ts.is_c_interop;
	  /* attr bits needed for module files.  */
	  sym->attr.is_iso_c |= init->ts.is_iso_c;
	  sym->attr.is_c_interop |= init->ts.is_c_interop;
	  if (init->ts.is_iso_c)
	    sym->ts.f90_type = init->ts.f90_type;
	}

      /* Add initializer.  Make sure we keep the ranks sane.  */
      if (sym->attr.dimension && init->rank == 0)
	{
	  mpz_t size;
	  gfc_expr *array;
	  int n;
	  if (sym->attr.flavor == FL_PARAMETER
	      && gfc_is_constant_expr (init)
	      && (init->expr_type == EXPR_CONSTANT
		  || init->expr_type == EXPR_STRUCTURE)
	      && spec_size (sym->as, &size)
	      && mpz_cmp_si (size, 0) > 0)
	    {
	      array = gfc_get_array_expr (init->ts.type, init->ts.kind,
					  &init->where);
	      if (init->ts.type == BT_DERIVED)
		array->ts.u.derived = init->ts.u.derived;
	      for (n = 0; n < (int)mpz_get_si (size); n++)
		gfc_constructor_append_expr (&array->value.constructor,
					     n == 0
						? init
						: gfc_copy_expr (init),
					     &init->where);

	      array->shape = gfc_get_shape (sym->as->rank);
	      for (n = 0; n < sym->as->rank; n++)
		spec_dimen_size (sym->as, n, &array->shape[n]);

	      init = array;
	      mpz_clear (size);
	    }
	  init->rank = sym->as->rank;
	}

      sym->value = init;
      if (sym->attr.save == SAVE_NONE)
	sym->attr.save = SAVE_IMPLICIT;
      *initp = NULL;
    }

  return true;
}


/* Function called by variable_decl() that adds a name to a structure
   being built.  */

static bool
build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
	      gfc_array_spec **as)
{
  gfc_state_data *s;
  gfc_component *c;

  /* F03:C438/C439. If the current symbol is of the same derived type that we're
     constructing, it must have the pointer attribute.  */
  if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
      && current_ts.u.derived == gfc_current_block ()
      && current_attr.pointer == 0)
    {
      if (current_attr.allocatable
	  && !gfc_notify_std(GFC_STD_F2008, "Component at %C "
			     "must have the POINTER attribute"))
	{
	  return false;
	}
      else if (current_attr.allocatable == 0)
	{
	  gfc_error ("Component at %C must have the POINTER attribute");
	  return false;
	}
    }

  /* F03:C437.  */
  if (current_ts.type == BT_CLASS
      && !(current_attr.pointer || current_attr.allocatable))
    {
      gfc_error ("Component %qs with CLASS at %C must be allocatable "
                 "or pointer", name);
      return false;
    }

  if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
    {
      if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
	{
	  gfc_error ("Array component of structure at %C must have explicit "
		     "or deferred shape");
	  return false;
	}
    }

  /* If we are in a nested union/map definition, gfc_add_component will not
     properly find repeated components because:
       (i) gfc_add_component does a flat search, where components of unions
           and maps are implicity chained so nested components may conflict.
      (ii) Unions and maps are not linked as components of their parent
           structures until after they are parsed.
     For (i) we use gfc_find_component which searches recursively, and for (ii)
     we search each block directly from the parse stack until we find the top
     level structure.  */

  s = gfc_state_stack;
  if (s->state == COMP_UNION || s->state == COMP_MAP)
    {
      while (s->state == COMP_UNION || gfc_comp_struct (s->state))
        {
          c = gfc_find_component (s->sym, name, true, true, NULL);
          if (c != NULL)
            {
              gfc_error_now ("Component %qs at %C already declared at %L",
                             name, &c->loc);
              return false;
            }
          /* Break after we've searched the entire chain.  */
          if (s->state == COMP_DERIVED || s->state == COMP_STRUCTURE)
            break;
          s = s->previous;
        }
    }

  if (!gfc_add_component (gfc_current_block(), name, &c))
    return false;

  c->ts = current_ts;
  if (c->ts.type == BT_CHARACTER)
    c->ts.u.cl = cl;

  if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED
      && (c->ts.kind == 0 || c->ts.type == BT_CHARACTER)
      && saved_kind_expr != NULL)
    c->kind_expr = gfc_copy_expr (saved_kind_expr);

  c->attr = current_attr;

  c->initializer = *init;
  *init = NULL;

  c->as = *as;
  if (c->as != NULL)
    {
      if (c->as->corank)
	c->attr.codimension = 1;
      if (c->as->rank)
	c->attr.dimension = 1;
    }
  *as = NULL;

  gfc_apply_init (&c->ts, &c->attr, c->initializer);

  /* Check array components.  */
  if (!c->attr.dimension)
    goto scalar;

  if (c->attr.pointer)
    {
      if (c->as->type != AS_DEFERRED)
	{
	  gfc_error ("Pointer array component of structure at %C must have a "
		     "deferred shape");
	  return false;
	}
    }
  else if (c->attr.allocatable)
    {
      if (c->as->type != AS_DEFERRED)
	{
	  gfc_error ("Allocatable component of structure at %C must have a "
		     "deferred shape");
	  return false;
	}
    }
  else
    {
      if (c->as->type != AS_EXPLICIT)
	{
	  gfc_error ("Array component of structure at %C must have an "
		     "explicit shape");
	  return false;
	}
    }

scalar:
  if (c->ts.type == BT_CLASS)
    return gfc_build_class_symbol (&c->ts, &c->attr, &c->as);

  if (c->attr.pdt_kind || c->attr.pdt_len)
    {
      gfc_symbol *sym;
      gfc_find_symbol (c->name, gfc_current_block ()->f2k_derived,
		       0, &sym);
      if (sym == NULL)
	{
	  gfc_error ("Type parameter %qs at %C has no corresponding entry "
		     "in the type parameter name list at %L",
		     c->name, &gfc_current_block ()->declared_at);
	  return false;
	}
      sym->ts = c->ts;
      sym->attr.pdt_kind = c->attr.pdt_kind;
      sym->attr.pdt_len = c->attr.pdt_len;
      if (c->initializer)
	sym->value = gfc_copy_expr (c->initializer);
      sym->attr.flavor = FL_VARIABLE;
    }

  if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
      && c->ts.u.derived && c->ts.u.derived->attr.pdt_template
      && decl_type_param_list)
    c->param_list = gfc_copy_actual_arglist (decl_type_param_list);

  return true;
}


/* Match a 'NULL()', and possibly take care of some side effects.  */

match
gfc_match_null (gfc_expr **result)
{
  gfc_symbol *sym;
  match m, m2 = MATCH_NO;

  if ((m = gfc_match (" null ( )")) == MATCH_ERROR)
    return MATCH_ERROR;

  if (m == MATCH_NO)
    {
      locus old_loc;
      char name[GFC_MAX_SYMBOL_LEN + 1];

      if ((m2 = gfc_match (" null (")) != MATCH_YES)
	return m2;

      old_loc = gfc_current_locus;
      if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR)
	return MATCH_ERROR;
      if (m2 != MATCH_YES
	  && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR))
	return MATCH_ERROR;
      if (m2 == MATCH_NO)
	{
	  gfc_current_locus = old_loc;
	  return MATCH_NO;
	}
    }

  /* The NULL symbol now has to be/become an intrinsic function.  */
  if (gfc_get_symbol ("null", NULL, &sym))
    {
      gfc_error ("NULL() initialization at %C is ambiguous");
      return MATCH_ERROR;
    }

  gfc_intrinsic_symbol (sym);

  if (sym->attr.proc != PROC_INTRINSIC
      && !(sym->attr.use_assoc && sym->attr.intrinsic)
      && (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL)
	  || !gfc_add_function (&sym->attr, sym->name, NULL)))
    return MATCH_ERROR;

  *result = gfc_get_null_expr (&gfc_current_locus);

  /* Invalid per F2008, C512.  */
  if (m2 == MATCH_YES)
    {
      gfc_error ("NULL() initialization at %C may not have MOLD");
      return MATCH_ERROR;
    }

  return MATCH_YES;
}


/* Match the initialization expr for a data pointer or procedure pointer.  */

static match
match_pointer_init (gfc_expr **init, int procptr)
{
  match m;

  if (gfc_pure (NULL) && !gfc_comp_struct (gfc_state_stack->state))
    {
      gfc_error ("Initialization of pointer at %C is not allowed in "
		 "a PURE procedure");
      return MATCH_ERROR;
    }
  gfc_unset_implicit_pure (gfc_current_ns->proc_name);

  /* Match NULL() initialization.  */
  m = gfc_match_null (init);
  if (m != MATCH_NO)
    return m;

  /* Match non-NULL initialization.  */
  gfc_matching_ptr_assignment = !procptr;
  gfc_matching_procptr_assignment = procptr;
  m = gfc_match_rvalue (init);
  gfc_matching_ptr_assignment = 0;
  gfc_matching_procptr_assignment = 0;
  if (m == MATCH_ERROR)
    return MATCH_ERROR;
  else if (m == MATCH_NO)
    {
      gfc_error ("Error in pointer initialization at %C");
      return MATCH_ERROR;
    }

  if (!procptr && !gfc_resolve_expr (*init))
    return MATCH_ERROR;

  if (!gfc_notify_std (GFC_STD_F2008, "non-NULL pointer "
		       "initialization at %C"))
    return MATCH_ERROR;

  return MATCH_YES;
}


static bool
check_function_name (char *name)
{
  /* In functions that have a RESULT variable defined, the function name always
     refers to function calls.  Therefore, the name is not allowed to appear in
     specification statements. When checking this, be careful about
     'hidden' procedure pointer results ('ppr@').  */

  if (gfc_current_state () == COMP_FUNCTION)
    {
      gfc_symbol *block = gfc_current_block ();
      if (block && block->result && block->result != block
	  && strcmp (block->result->name, "ppr@") != 0
	  && strcmp (block->name, name) == 0)
	{
	  gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
		     "from appearing in a specification statement",
		     block->result->name, &block->result->declared_at, name);
	  return false;
	}
    }

  return true;
}


/* Match a variable name with an optional initializer.  When this
   subroutine is called, a variable is expected to be parsed next.
   Depending on what is happening at the moment, updates either the
   symbol table or the current interface.  */

static match
variable_decl (int elem)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  static unsigned int fill_id = 0;
  gfc_expr *initializer, *char_len;
  gfc_array_spec *as;
  gfc_array_spec *cp_as; /* Extra copy for Cray Pointees.  */
  gfc_charlen *cl;
  bool cl_deferred;
  locus var_locus;
  match m;
  bool t;
  gfc_symbol *sym;
  char c;

  initializer = NULL;
  as = NULL;
  cp_as = NULL;

  /* When we get here, we've just matched a list of attributes and
     maybe a type and a double colon.  The next thing we expect to see
     is the name of the symbol.  */

  /* If we are parsing a structure with legacy support, we allow the symbol
     name to be '%FILL' which gives it an anonymous (inaccessible) name.  */
  m = MATCH_NO;
  gfc_gobble_whitespace ();
  c = gfc_peek_ascii_char ();
  if (c == '%')
    {
      gfc_next_ascii_char ();	/* Burn % character.  */
      m = gfc_match ("fill");
      if (m == MATCH_YES)
	{
	  if (gfc_current_state () != COMP_STRUCTURE)
	    {
	      if (flag_dec_structure)
		gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
	      else
		gfc_error ("%qs at %C is a DEC extension, enable with "
		       "%<-fdec-structure%>", "%FILL");
	      m = MATCH_ERROR;
	      goto cleanup;
	    }

	  if (attr_seen)
	    {
	      gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
	      m = MATCH_ERROR;
	      goto cleanup;
	    }

	  /* %FILL components are given invalid fortran names.  */
	  snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "%%FILL%u", fill_id++);
	}
      else
	{
	  gfc_error ("Invalid character %qc in variable name at %C", c);
	  return MATCH_ERROR;
	}
    }
  else
    {
      m = gfc_match_name (name);
      if (m != MATCH_YES)
	goto cleanup;
    }

  var_locus = gfc_current_locus;

  /* Now we could see the optional array spec. or character length.  */
  m = gfc_match_array_spec (&as, true, true);
  if (m == MATCH_ERROR)
    goto cleanup;

  if (m == MATCH_NO)
    as = gfc_copy_array_spec (current_as);
  else if (current_as
	   && !merge_array_spec (current_as, as, true))
    {
      m = MATCH_ERROR;
      goto cleanup;
    }

  if (flag_cray_pointer)
    cp_as = gfc_copy_array_spec (as);

  /* At this point, we know for sure if the symbol is PARAMETER and can thus
     determine (and check) whether it can be implied-shape.  If it
     was parsed as assumed-size, change it because PARAMETERs cannot
     be assumed-size.

     An explicit-shape-array cannot appear under several conditions.
     That check is done here as well.  */
  if (as)
    {
      if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
	{
	  m = MATCH_ERROR;
	  gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape",
		     name, &var_locus);
	  goto cleanup;
	}

      if (as->type == AS_ASSUMED_SIZE && as->rank == 1
	  && current_attr.flavor == FL_PARAMETER)
	as->type = AS_IMPLIED_SHAPE;

      if (as->type == AS_IMPLIED_SHAPE
	  && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L",
			      &var_locus))
	{
	  m = MATCH_ERROR;
	  goto cleanup;
	}

      gfc_seen_div0 = false;
      
      /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
	 constant expressions shall appear only in a subprogram, derived
	 type definition, BLOCK construct, or interface body.  */
      if (as->type == AS_EXPLICIT
	  && gfc_current_state () != COMP_BLOCK
	  && gfc_current_state () != COMP_DERIVED
	  && gfc_current_state () != COMP_FUNCTION
	  && gfc_current_state () != COMP_INTERFACE
	  && gfc_current_state () != COMP_SUBROUTINE)
	{
	  gfc_expr *e;
	  bool not_constant = false;

	  for (int i = 0; i < as->rank; i++)
	    {
	      e = gfc_copy_expr (as->lower[i]);
	      if (!gfc_resolve_expr (e) && gfc_seen_div0)
		{
		  m = MATCH_ERROR;
		  goto cleanup;
		}

	      gfc_simplify_expr (e, 0);
	      if (e && (e->expr_type != EXPR_CONSTANT))
		{
		  not_constant = true;
		  break;
		}
	      gfc_free_expr (e);

	      e = gfc_copy_expr (as->upper[i]);
	      if (!gfc_resolve_expr (e)  && gfc_seen_div0)
		{
		  m = MATCH_ERROR;
		  goto cleanup;
		}

	      gfc_simplify_expr (e, 0);
	      if (e && (e->expr_type != EXPR_CONSTANT))
		{
		  not_constant = true;
		  break;
		}
	      gfc_free_expr (e);
	    }

	  if (not_constant && e->ts.type != BT_INTEGER)
	    {
	      gfc_error ("Explicit array shape at %C must be constant of "
			 "INTEGER type and not %s type",
			 gfc_basic_typename (e->ts.type));
	      m = MATCH_ERROR;
	      goto cleanup;
	    }
	  if (not_constant)
	    {
	      gfc_error ("Explicit shaped array with nonconstant bounds at %C");
	      m = MATCH_ERROR;
	      goto cleanup;
	    }
	}
      if (as->type == AS_EXPLICIT)
	{
	  for (int i = 0; i < as->rank; i++)
	    {
	      gfc_expr *e, *n;
	      e = as->lower[i];
	      if (e->expr_type != EXPR_CONSTANT)
		{
		  n = gfc_copy_expr (e);
		  if (!gfc_simplify_expr (n, 1)  && gfc_seen_div0) 
		    {
		      m = MATCH_ERROR;
		      goto cleanup;
		    }

		  if (n->expr_type == EXPR_CONSTANT)
		    gfc_replace_expr (e, n);
		  else
		    gfc_free_expr (n);
		}
	      e = as->upper[i];
	      if (e->expr_type != EXPR_CONSTANT)
		{
		  n = gfc_copy_expr (e);
		  if (!gfc_simplify_expr (n, 1)  && gfc_seen_div0) 
		    {
		      m = MATCH_ERROR;
		      goto cleanup;
		    }
		  
		  if (n->expr_type == EXPR_CONSTANT)
		    gfc_replace_expr (e, n);
		  else
		    gfc_free_expr (n);
		}
	    }
	}
    }

  char_len = NULL;
  cl = NULL;
  cl_deferred = false;

  if (current_ts.type == BT_CHARACTER)
    {
      switch (match_char_length (&char_len, &cl_deferred, false))
	{
	case MATCH_YES:
	  cl = gfc_new_charlen (gfc_current_ns, NULL);

	  cl->length = char_len;
	  break;

	/* Non-constant lengths need to be copied after the first
	   element.  Also copy assumed lengths.  */
	case MATCH_NO:
	  if (elem > 1
	      && (current_ts.u.cl->length == NULL
		  || current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
	    {
	      cl = gfc_new_charlen (gfc_current_ns, NULL);
	      cl->length = gfc_copy_expr (current_ts.u.cl->length);
	    }
	  else
	    cl = current_ts.u.cl;

	  cl_deferred = current_ts.deferred;

	  break;

	case MATCH_ERROR:
	  goto cleanup;
	}
    }

  /* The dummy arguments and result of the abreviated form of MODULE
     PROCEDUREs, used in SUBMODULES should not be redefined.  */
  if (gfc_current_ns->proc_name
      && gfc_current_ns->proc_name->abr_modproc_decl)
    {
      gfc_find_symbol (name, gfc_current_ns, 1, &sym);
      if (sym != NULL && (sym->attr.dummy || sym->attr.result))
	{
	  m = MATCH_ERROR;
	  gfc_error ("%qs at %C is a redefinition of the declaration "
		     "in the corresponding interface for MODULE "
		     "PROCEDURE %qs", sym->name,
		     gfc_current_ns->proc_name->name);
	  goto cleanup;
	}
    }

  /* %FILL components may not have initializers.  */
  if (startswith (name, "%FILL") && gfc_match_eos () != MATCH_YES)
    {
      gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
      m = MATCH_ERROR;
      goto cleanup;
    }

  /*  If this symbol has already shown up in a Cray Pointer declaration,
      and this is not a component declaration,
      then we want to set the type & bail out.  */
  if (flag_cray_pointer && !gfc_comp_struct (gfc_current_state ()))
    {
      gfc_find_symbol (name, gfc_current_ns, 0, &sym);
      if (sym != NULL && sym->attr.cray_pointee)
	{
	  m = MATCH_YES;
	  if (!gfc_add_type (sym, &current_ts, &gfc_current_locus))
	    {
	      m = MATCH_ERROR;
	      goto cleanup;
	    }

	  /* Check to see if we have an array specification.  */
	  if (cp_as != NULL)
	    {
	      if (sym->as != NULL)
		{
		  gfc_error ("Duplicate array spec for Cray pointee at %C");
		  gfc_free_array_spec (cp_as);
		  m = MATCH_ERROR;
		  goto cleanup;
		}
	      else
		{
		  if (!gfc_set_array_spec (sym, cp_as, &var_locus))
		    gfc_internal_error ("Cannot set pointee array spec.");

		  /* Fix the array spec.  */
		  m = gfc_mod_pointee_as (sym->as);
		  if (m == MATCH_ERROR)
		    goto cleanup;
		}
	    }
	  goto cleanup;
	}
      else
	{
	  gfc_free_array_spec (cp_as);
	}
    }

  /* Procedure pointer as function result.  */
  if (gfc_current_state () == COMP_FUNCTION
      && strcmp ("ppr@", gfc_current_block ()->name) == 0
      && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
    strcpy (name, "ppr@");

  if (gfc_current_state () == COMP_FUNCTION
      && strcmp (name, gfc_current_block ()->name) == 0
      && gfc_current_block ()->result
      && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
    strcpy (name, "ppr@");

  /* OK, we've successfully matched the declaration.  Now put the
     symbol in the current namespace, because it might be used in the
     optional initialization expression for this symbol, e.g. this is
     perfectly legal:

     integer, parameter :: i = huge(i)

     This is only true for parameters or variables of a basic type.
     For components of derived types, it is not true, so we don't
     create a symbol for those yet.  If we fail to create the symbol,
     bail out.  */
  if (!gfc_comp_struct (gfc_current_state ())
      && !build_sym (name, cl, cl_deferred, &as, &var_locus))
    {
      m = MATCH_ERROR;
      goto cleanup;
    }

  if (!check_function_name (name))
    {
      m = MATCH_ERROR;
      goto cleanup;
    }

  /* We allow old-style initializations of the form
       integer i /2/, j(4) /3*3, 1/
     (if no colon has been seen). These are different from data
     statements in that initializers are only allowed to apply to the
     variable immediately preceding, i.e.
       integer i, j /1, 2/
     is not allowed. Therefore we have to do some work manually, that
     could otherwise be left to the matchers for DATA statements.  */

  if (!colon_seen && gfc_match (" /") == MATCH_YES)
    {
      if (!gfc_notify_std (GFC_STD_GNU, "Old-style "
			   "initialization at %C"))
	return MATCH_ERROR;

      /* Allow old style initializations for components of STRUCTUREs and MAPs
         but not components of derived types.  */
      else if (gfc_current_state () == COMP_DERIVED)
	{
	  gfc_error ("Invalid old style initialization for derived type "
		     "component at %C");
	  m = MATCH_ERROR;
	  goto cleanup;
	}

      /* For structure components, read the initializer as a special
         expression and let the rest of this function apply the initializer
         as usual.  */
      else if (gfc_comp_struct (gfc_current_state ()))
        {
          m = match_clist_expr (&initializer, &current_ts, as);
          if (m == MATCH_NO)
            gfc_error ("Syntax error in old style initialization of %s at %C",
                       name);
          if (m != MATCH_YES)
            goto cleanup;
        }

      /* Otherwise we treat the old style initialization just like a
         DATA declaration for the current variable.  */
      else
        return match_old_style_init (name);
    }

  /* The double colon must be present in order to have initializers.
     Otherwise the statement is ambiguous with an assignment statement.  */
  if (colon_seen)
    {
      if (gfc_match (" =>") == MATCH_YES)
	{
	  if (!current_attr.pointer)
	    {
	      gfc_error ("Initialization at %C isn't for a pointer variable");
	      m = MATCH_ERROR;
	      goto cleanup;
	    }

	  m = match_pointer_init (&initializer, 0);
	  if (m != MATCH_YES)
	    goto cleanup;

	  /* The target of a pointer initialization must have the SAVE
	     attribute.  A variable in PROGRAM, MODULE, or SUBMODULE scope
	     is implicit SAVEd.  Explicitly, set the SAVE_IMPLICIT value.  */
	  if (initializer->expr_type == EXPR_VARIABLE
	      && initializer->symtree->n.sym->attr.save == SAVE_NONE
	      && (gfc_current_state () == COMP_PROGRAM
		  || gfc_current_state () == COMP_MODULE
		  || gfc_current_state () == COMP_SUBMODULE))
	    initializer->symtree->n.sym->attr.save = SAVE_IMPLICIT;
	}
      else if (gfc_match_char ('=') == MATCH_YES)
	{
	  if (current_attr.pointer)
	    {
	      gfc_error ("Pointer initialization at %C requires %<=>%>, "
			 "not %<=%>");
	      m = MATCH_ERROR;
	      goto cleanup;
	    }

	  m = gfc_match_init_expr (&initializer);
	  if (m == MATCH_NO)
	    {
	      gfc_error ("Expected an initialization expression at %C");
	      m = MATCH_ERROR;
	    }

	  if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL)
	      && !gfc_comp_struct (gfc_state_stack->state))
	    {
	      gfc_error ("Initialization of variable at %C is not allowed in "
			 "a PURE procedure");
	      m = MATCH_ERROR;
	    }

	  if (current_attr.flavor != FL_PARAMETER
	      && !gfc_comp_struct (gfc_state_stack->state))
	    gfc_unset_implicit_pure (gfc_current_ns->proc_name);

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

  if (initializer != NULL && current_attr.allocatable
	&& gfc_comp_struct (gfc_current_state ()))
    {
      gfc_error ("Initialization of allocatable component at %C is not "
		 "allowed");
      m = MATCH_ERROR;
      goto cleanup;
    }

  if (gfc_current_state () == COMP_DERIVED
      && initializer && initializer->ts.type == BT_HOLLERITH)
    {
      gfc_error ("Initialization of structure component with a HOLLERITH "
		 "constant at %L is not allowed", &initializer->where);
      m = MATCH_ERROR;
      goto cleanup;
    }

  if (gfc_current_state () == COMP_DERIVED
      && gfc_current_block ()->attr.pdt_template)
    {
      gfc_symbol *param;
      gfc_find_symbol (name, gfc_current_block ()->f2k_derived,
		       0, &param);
      if (!param && (current_attr.pdt_kind || current_attr.pdt_len))
	{
	  gfc_error ("The component with KIND or LEN attribute at %C does not "
		     "not appear in the type parameter list at %L",
		     &gfc_current_block ()->declared_at);
	  m = MATCH_ERROR;
	  goto cleanup;
	}
      else if (param && !(current_attr.pdt_kind || current_attr.pdt_len))
	{
	  gfc_error ("The component at %C that appears in the type parameter "
		     "list at %L has neither the KIND nor LEN attribute",
		     &gfc_current_block ()->declared_at);
	  m = MATCH_ERROR;
	  goto cleanup;
	}
      else if (as && (current_attr.pdt_kind || current_attr.pdt_len))
	{
	  gfc_error ("The component at %C which is a type parameter must be "
		     "a scalar");
	  m = MATCH_ERROR;
	  goto cleanup;
	}
      else if (param && initializer)
	{
	  if (initializer->ts.type == BT_BOZ)
	    {
	      gfc_error ("BOZ literal constant at %L cannot appear as an "
			 "initializer", &initializer->where);
	      m = MATCH_ERROR;
      	      goto cleanup;
	    }
	  param->value = gfc_copy_expr (initializer);
	}
    }

  /* Before adding a possible initilizer, do a simple check for compatibility
     of lhs and rhs types.  Assigning a REAL value to a derived type is not a
     good thing.  */
  if (current_ts.type == BT_DERIVED && initializer
      && (gfc_numeric_ts (&initializer->ts)
	  || initializer->ts.type == BT_LOGICAL
	  || initializer->ts.type == BT_CHARACTER))
    {
      gfc_error ("Incompatible initialization between a derived type "
		 "entity and an entity with %qs type at %C",
		  gfc_typename (initializer));
      m = MATCH_ERROR;
      goto cleanup;
    }


  /* Add the initializer.  Note that it is fine if initializer is
     NULL here, because we sometimes also need to check if a
     declaration *must* have an initialization expression.  */
  if (!gfc_comp_struct (gfc_current_state ()))
    t = add_init_expr_to_sym (name, &initializer, &var_locus);
  else
    {
      if (current_ts.type == BT_DERIVED
	  && !current_attr.pointer && !initializer)
	initializer = gfc_default_initializer (&current_ts);
      t = build_struct (name, cl, &initializer, &as);