2006-12-03 Paul Thomas <pault@gcc.gnu.org>

[pf3gnuchains/gcc-fork.git] / gcc / fortran / resolve.c

/* Perform type resolution on the various stuctures.
   Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, 
   Inc.
   Contributed by Andy Vaught

This file is part of GCC.

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

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

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


#include "config.h"
#include "system.h"
#include "flags.h"
#include "gfortran.h"
#include "arith.h"  /* For gfc_compare_expr().  */
#include "dependency.h"

/* Types used in equivalence statements.  */

typedef enum seq_type
{
  SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
}
seq_type;

/* Stack to push the current if we descend into a block during
   resolution.  See resolve_branch() and resolve_code().  */

typedef struct code_stack
{
  struct gfc_code *head, *current;
  struct code_stack *prev;
}
code_stack;

static code_stack *cs_base = NULL;


/* Nonzero if we're inside a FORALL block.  */

static int forall_flag;

/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block.  */

static int omp_workshare_flag;

/* Nonzero if we are processing a formal arglist. The corresponding function
   resets the flag each time that it is read.  */
static int formal_arg_flag = 0;

/* True if we are resolving a specification expression.  */
static int specification_expr = 0;

/* The id of the last entry seen.  */
static int current_entry_id;

int
gfc_is_formal_arg (void)
{
  return formal_arg_flag;
}

/* Resolve types of formal argument lists.  These have to be done early so that
   the formal argument lists of module procedures can be copied to the
   containing module before the individual procedures are resolved
   individually.  We also resolve argument lists of procedures in interface
   blocks because they are self-contained scoping units.

   Since a dummy argument cannot be a non-dummy procedure, the only
   resort left for untyped names are the IMPLICIT types.  */

static void
resolve_formal_arglist (gfc_symbol * proc)
{
  gfc_formal_arglist *f;
  gfc_symbol *sym;
  int i;

  if (proc->result != NULL)
    sym = proc->result;
  else
    sym = proc;

  if (gfc_elemental (proc)
      || sym->attr.pointer || sym->attr.allocatable
      || (sym->as && sym->as->rank > 0))
    proc->attr.always_explicit = 1;

  formal_arg_flag = 1;

  for (f = proc->formal; f; f = f->next)
    {
      sym = f->sym;

      if (sym == NULL)
        {
          /* Alternate return placeholder.  */
          if (gfc_elemental (proc))
            gfc_error ("Alternate return specifier in elemental subroutine "
                       "'%s' at %L is not allowed", proc->name,
                       &proc->declared_at);
          if (proc->attr.function)
            gfc_error ("Alternate return specifier in function "
                       "'%s' at %L is not allowed", proc->name,
                       &proc->declared_at);
          continue;
        }

      if (sym->attr.if_source != IFSRC_UNKNOWN)
        resolve_formal_arglist (sym);

      if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
        {
          if (gfc_pure (proc) && !gfc_pure (sym))
            {
              gfc_error
                ("Dummy procedure '%s' of PURE procedure at %L must also "
                 "be PURE", sym->name, &sym->declared_at);
              continue;
            }

          if (gfc_elemental (proc))
            {
              gfc_error
                ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
                 &sym->declared_at);
              continue;
            }

          continue;
        }

      if (sym->ts.type == BT_UNKNOWN)
        {
          if (!sym->attr.function || sym->result == sym)
            gfc_set_default_type (sym, 1, sym->ns);
        }

      gfc_resolve_array_spec (sym->as, 0);

      /* We can't tell if an array with dimension (:) is assumed or deferred
         shape until we know if it has the pointer or allocatable attributes.
      */
      if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
          && !(sym->attr.pointer || sym->attr.allocatable))
        {
          sym->as->type = AS_ASSUMED_SHAPE;
          for (i = 0; i < sym->as->rank; i++)
            sym->as->lower[i] = gfc_int_expr (1);
        }

      if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
          || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
          || sym->attr.optional)
        proc->attr.always_explicit = 1;

      /* If the flavor is unknown at this point, it has to be a variable.
         A procedure specification would have already set the type.  */

      if (sym->attr.flavor == FL_UNKNOWN)
        gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);

      if (gfc_pure (proc))
        {
          if (proc->attr.function && !sym->attr.pointer
              && sym->attr.flavor != FL_PROCEDURE
              && sym->attr.intent != INTENT_IN)

            gfc_error ("Argument '%s' of pure function '%s' at %L must be "
                       "INTENT(IN)", sym->name, proc->name,
                       &sym->declared_at);

          if (proc->attr.subroutine && !sym->attr.pointer
              && sym->attr.intent == INTENT_UNKNOWN)

            gfc_error
              ("Argument '%s' of pure subroutine '%s' at %L must have "
               "its INTENT specified", sym->name, proc->name,
               &sym->declared_at);
        }


      if (gfc_elemental (proc))
        {
          if (sym->as != NULL)
            {
              gfc_error
                ("Argument '%s' of elemental procedure at %L must be scalar",
                 sym->name, &sym->declared_at);
              continue;
            }

          if (sym->attr.pointer)
            {
              gfc_error
                ("Argument '%s' of elemental procedure at %L cannot have "
                 "the POINTER attribute", sym->name, &sym->declared_at);
              continue;
            }
        }

      /* Each dummy shall be specified to be scalar.  */
      if (proc->attr.proc == PROC_ST_FUNCTION)
        {
          if (sym->as != NULL)
            {
              gfc_error
                ("Argument '%s' of statement function at %L must be scalar",
                 sym->name, &sym->declared_at);
              continue;
            }

          if (sym->ts.type == BT_CHARACTER)
            {
              gfc_charlen *cl = sym->ts.cl;
              if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
                {
                  gfc_error
                    ("Character-valued argument '%s' of statement function at "
                     "%L must have constant length",
                     sym->name, &sym->declared_at);
                  continue;
                }
            }
        }
    }
  formal_arg_flag = 0;
}


/* Work function called when searching for symbols that have argument lists
   associated with them.  */

static void
find_arglists (gfc_symbol * sym)
{

  if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
    return;

  resolve_formal_arglist (sym);
}


/* Given a namespace, resolve all formal argument lists within the namespace.
 */

static void
resolve_formal_arglists (gfc_namespace * ns)
{

  if (ns == NULL)
    return;

  gfc_traverse_ns (ns, find_arglists);
}


static void
resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
{
  try t;

  /* If this namespace is not a function, ignore it.  */
  if (! sym
      || !(sym->attr.function
           || sym->attr.flavor == FL_VARIABLE))
    return;

  /* Try to find out of what the return type is.  */
  if (sym->result != NULL)
    sym = sym->result;

  if (sym->ts.type == BT_UNKNOWN)
    {
      t = gfc_set_default_type (sym, 0, ns);

      if (t == FAILURE && !sym->attr.untyped)
        {
          gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
                     sym->name, &sym->declared_at); /* FIXME */
          sym->attr.untyped = 1;
        }
    }

  /*Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type,
    lists the only ways a character length value of * can be used: dummy arguments
    of procedures, named constants, and function results in external functions.
    Internal function results are not on that list; ergo, not permitted.  */

  if (sym->ts.type == BT_CHARACTER)
    {
      gfc_charlen *cl = sym->ts.cl;
      if (!cl || !cl->length)
        gfc_error ("Character-valued internal function '%s' at %L must "
                   "not be assumed length", sym->name, &sym->declared_at);
    }
}


/* Add NEW_ARGS to the formal argument list of PROC, taking care not to
   introduce duplicates.  */

static void
merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
{
  gfc_formal_arglist *f, *new_arglist;
  gfc_symbol *new_sym;

  for (; new_args != NULL; new_args = new_args->next)
    {
      new_sym = new_args->sym;
      /* See if this arg is already in the formal argument list.  */
      for (f = proc->formal; f; f = f->next)
        {
          if (new_sym == f->sym)
            break;
        }

      if (f)
        continue;

      /* Add a new argument.  Argument order is not important.  */
      new_arglist = gfc_get_formal_arglist ();
      new_arglist->sym = new_sym;
      new_arglist->next = proc->formal;
      proc->formal  = new_arglist;
    }
}


/* Resolve alternate entry points.  If a symbol has multiple entry points we
   create a new master symbol for the main routine, and turn the existing
   symbol into an entry point.  */

static void
resolve_entries (gfc_namespace * ns)
{
  gfc_namespace *old_ns;
  gfc_code *c;
  gfc_symbol *proc;
  gfc_entry_list *el;
  char name[GFC_MAX_SYMBOL_LEN + 1];
  static int master_count = 0;

  if (ns->proc_name == NULL)
    return;

  /* No need to do anything if this procedure doesn't have alternate entry
     points.  */
  if (!ns->entries)
    return;

  /* We may already have resolved alternate entry points.  */
  if (ns->proc_name->attr.entry_master)
    return;

  /* If this isn't a procedure something has gone horribly wrong.  */
  gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);

  /* Remember the current namespace.  */
  old_ns = gfc_current_ns;

  gfc_current_ns = ns;

  /* Add the main entry point to the list of entry points.  */
  el = gfc_get_entry_list ();
  el->sym = ns->proc_name;
  el->id = 0;
  el->next = ns->entries;
  ns->entries = el;
  ns->proc_name->attr.entry = 1;

  /* If it is a module function, it needs to be in the right namespace
     so that gfc_get_fake_result_decl can gather up the results. The
     need for this arose in get_proc_name, where these beasts were
     left in their own namespace, to keep prior references linked to
     the entry declaration.*/
  if (ns->proc_name->attr.function
        && ns->parent
        && ns->parent->proc_name->attr.flavor == FL_MODULE)
    el->sym->ns = ns;

  /* Add an entry statement for it.  */
  c = gfc_get_code ();
  c->op = EXEC_ENTRY;
  c->ext.entry = el;
  c->next = ns->code;
  ns->code = c;

  /* Create a new symbol for the master function.  */
  /* Give the internal function a unique name (within this file).
     Also include the function name so the user has some hope of figuring
     out what is going on.  */
  snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
            master_count++, ns->proc_name->name);
  gfc_get_ha_symbol (name, &proc);
  gcc_assert (proc != NULL);

  gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
  if (ns->proc_name->attr.subroutine)
    gfc_add_subroutine (&proc->attr, proc->name, NULL);
  else
    {
      gfc_symbol *sym;
      gfc_typespec *ts, *fts;
      gfc_array_spec *as, *fas;
      gfc_add_function (&proc->attr, proc->name, NULL);
      proc->result = proc;
      fas = ns->entries->sym->as;
      fas = fas ? fas : ns->entries->sym->result->as;
      fts = &ns->entries->sym->result->ts;
      if (fts->type == BT_UNKNOWN)
        fts = gfc_get_default_type (ns->entries->sym->result, NULL);
      for (el = ns->entries->next; el; el = el->next)
        {
          ts = &el->sym->result->ts;
          as = el->sym->as;
          as = as ? as : el->sym->result->as;
          if (ts->type == BT_UNKNOWN)
            ts = gfc_get_default_type (el->sym->result, NULL);

          if (! gfc_compare_types (ts, fts)
              || (el->sym->result->attr.dimension
                  != ns->entries->sym->result->attr.dimension)
              || (el->sym->result->attr.pointer
                  != ns->entries->sym->result->attr.pointer))
            break;

          else if (as && fas && gfc_compare_array_spec (as, fas) == 0)
            gfc_error ("Procedure %s at %L has entries with mismatched "
                       "array specifications", ns->entries->sym->name,
                       &ns->entries->sym->declared_at);
        }

      if (el == NULL)
        {
          sym = ns->entries->sym->result;
          /* All result types the same.  */
          proc->ts = *fts;
          if (sym->attr.dimension)
            gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
          if (sym->attr.pointer)
            gfc_add_pointer (&proc->attr, NULL);
        }
      else
        {
          /* Otherwise the result will be passed through a union by
             reference.  */
          proc->attr.mixed_entry_master = 1;
          for (el = ns->entries; el; el = el->next)
            {
              sym = el->sym->result;
              if (sym->attr.dimension)
              {
                if (el == ns->entries)
                  gfc_error
                  ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
                   sym->name, ns->entries->sym->name, &sym->declared_at);
                else
                  gfc_error
                    ("ENTRY result %s can't be an array in FUNCTION %s at %L",
                     sym->name, ns->entries->sym->name, &sym->declared_at);
              }
              else if (sym->attr.pointer)
              {
                if (el == ns->entries)
                  gfc_error
                  ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
                   sym->name, ns->entries->sym->name, &sym->declared_at);
                else
                  gfc_error
                    ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
                     sym->name, ns->entries->sym->name, &sym->declared_at);
              }
              else
                {
                  ts = &sym->ts;
                  if (ts->type == BT_UNKNOWN)
                    ts = gfc_get_default_type (sym, NULL);
                  switch (ts->type)
                    {
                    case BT_INTEGER:
                      if (ts->kind == gfc_default_integer_kind)
                        sym = NULL;
                      break;
                    case BT_REAL:
                      if (ts->kind == gfc_default_real_kind
                          || ts->kind == gfc_default_double_kind)
                        sym = NULL;
                      break;
                    case BT_COMPLEX:
                      if (ts->kind == gfc_default_complex_kind)
                        sym = NULL;
                      break;
                    case BT_LOGICAL:
                      if (ts->kind == gfc_default_logical_kind)
                        sym = NULL;
                      break;
                    case BT_UNKNOWN:
                      /* We will issue error elsewhere.  */
                      sym = NULL;
                      break;
                    default:
                      break;
                    }
                  if (sym)
                  {
                    if (el == ns->entries)
                      gfc_error
                        ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
                         sym->name, gfc_typename (ts), ns->entries->sym->name,
                         &sym->declared_at);
                    else
                      gfc_error
                        ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
                         sym->name, gfc_typename (ts), ns->entries->sym->name,
                         &sym->declared_at);
                  }
                }
            }
        }
    }
  proc->attr.access = ACCESS_PRIVATE;
  proc->attr.entry_master = 1;

  /* Merge all the entry point arguments.  */
  for (el = ns->entries; el; el = el->next)
    merge_argument_lists (proc, el->sym->formal);

  /* Use the master function for the function body.  */
  ns->proc_name = proc;

  /* Finalize the new symbols.  */
  gfc_commit_symbols ();

  /* Restore the original namespace.  */
  gfc_current_ns = old_ns;
}


/* Resolve contained function types.  Because contained functions can call one
   another, they have to be worked out before any of the contained procedures
   can be resolved.

   The good news is that if a function doesn't already have a type, the only
   way it can get one is through an IMPLICIT type or a RESULT variable, because
   by definition contained functions are contained namespace they're contained
   in, not in a sibling or parent namespace.  */

static void
resolve_contained_functions (gfc_namespace * ns)
{
  gfc_namespace *child;
  gfc_entry_list *el;

  resolve_formal_arglists (ns);

  for (child = ns->contained; child; child = child->sibling)
    {
      /* Resolve alternate entry points first.  */
      resolve_entries (child);

      /* Then check function return types.  */
      resolve_contained_fntype (child->proc_name, child);
      for (el = child->entries; el; el = el->next)
        resolve_contained_fntype (el->sym, child);
    }
}


/* Resolve all of the elements of a structure constructor and make sure that
   the types are correct.  */

static try
resolve_structure_cons (gfc_expr * expr)
{
  gfc_constructor *cons;
  gfc_component *comp;
  try t;
  symbol_attribute a;

  t = SUCCESS;
  cons = expr->value.constructor;
  /* A constructor may have references if it is the result of substituting a
     parameter variable.  In this case we just pull out the component we
     want.  */
  if (expr->ref)
    comp = expr->ref->u.c.sym->components;
  else
    comp = expr->ts.derived->components;

  for (; comp; comp = comp->next, cons = cons->next)
    {
      if (! cons->expr)
        continue;

      if (gfc_resolve_expr (cons->expr) == FAILURE)
        {
          t = FAILURE;
          continue;
        }

      if (cons->expr->expr_type != EXPR_NULL
            && comp->as && comp->as->rank != cons->expr->rank
            && (comp->allocatable || cons->expr->rank))
        {
          gfc_error ("The rank of the element in the derived type "
                     "constructor at %L does not match that of the "
                     "component (%d/%d)", &cons->expr->where,
                     cons->expr->rank, comp->as ? comp->as->rank : 0);
          t = FAILURE;
        }

      /* If we don't have the right type, try to convert it.  */

      if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
        {
          t = FAILURE;
          if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
            gfc_error ("The element in the derived type constructor at %L, "
                       "for pointer component '%s', is %s but should be %s",
                       &cons->expr->where, comp->name,
                       gfc_basic_typename (cons->expr->ts.type),
                       gfc_basic_typename (comp->ts.type));
          else
            t = gfc_convert_type (cons->expr, &comp->ts, 1);
        }

      if (!comp->pointer || cons->expr->expr_type == EXPR_NULL)
        continue;

      a = gfc_expr_attr (cons->expr);

      if (!a.pointer && !a.target)
        {
          t = FAILURE;
          gfc_error ("The element in the derived type constructor at %L, "
                     "for pointer component '%s' should be a POINTER or "
                     "a TARGET", &cons->expr->where, comp->name);
        }
    }

  return t;
}



/****************** Expression name resolution ******************/

/* Returns 0 if a symbol was not declared with a type or
   attribute declaration statement, nonzero otherwise.  */

static int
was_declared (gfc_symbol * sym)
{
  symbol_attribute a;

  a = sym->attr;

  if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
    return 1;

  if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
      || a.optional || a.pointer || a.save || a.target || a.volatile_ || a.value
      || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
    return 1;

  return 0;
}


/* Determine if a symbol is generic or not.  */

static int
generic_sym (gfc_symbol * sym)
{
  gfc_symbol *s;

  if (sym->attr.generic ||
      (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
    return 1;

  if (was_declared (sym) || sym->ns->parent == NULL)
    return 0;

  gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);

  return (s == NULL) ? 0 : generic_sym (s);
}


/* Determine if a symbol is specific or not.  */

static int
specific_sym (gfc_symbol * sym)
{
  gfc_symbol *s;

  if (sym->attr.if_source == IFSRC_IFBODY
      || sym->attr.proc == PROC_MODULE
      || sym->attr.proc == PROC_INTERNAL
      || sym->attr.proc == PROC_ST_FUNCTION
      || (sym->attr.intrinsic &&
          gfc_specific_intrinsic (sym->name))
      || sym->attr.external)
    return 1;

  if (was_declared (sym) || sym->ns->parent == NULL)
    return 0;

  gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);

  return (s == NULL) ? 0 : specific_sym (s);
}


/* Figure out if the procedure is specific, generic or unknown.  */

typedef enum
{ PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
proc_type;

static proc_type
procedure_kind (gfc_symbol * sym)
{

  if (generic_sym (sym))
    return PTYPE_GENERIC;

  if (specific_sym (sym))
    return PTYPE_SPECIFIC;

  return PTYPE_UNKNOWN;
}

/* Check references to assumed size arrays.  The flag need_full_assumed_size
   is nonzero when matching actual arguments.  */

static int need_full_assumed_size = 0;

static bool
check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e)
{
  gfc_ref * ref;
  int dim;
  int last = 1;

  if (need_full_assumed_size
        || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
      return false;

  for (ref = e->ref; ref; ref = ref->next)
    if (ref->type == REF_ARRAY)
      for (dim = 0; dim < ref->u.ar.as->rank; dim++)
        last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT);

  if (last)
    {
      gfc_error ("The upper bound in the last dimension must "
                 "appear in the reference to the assumed size "
                 "array '%s' at %L", sym->name, &e->where);
      return true;
    }
  return false;
}


/* Look for bad assumed size array references in argument expressions
  of elemental and array valued intrinsic procedures.  Since this is
  called from procedure resolution functions, it only recurses at
  operators.  */

static bool
resolve_assumed_size_actual (gfc_expr *e)
{
  if (e == NULL)
   return false;

  switch (e->expr_type)
    {
    case EXPR_VARIABLE:
      if (e->symtree
            && check_assumed_size_reference (e->symtree->n.sym, e))
        return true;
      break;

    case EXPR_OP:
      if (resolve_assumed_size_actual (e->value.op.op1)
            || resolve_assumed_size_actual (e->value.op.op2))
        return true;
      break;

    default:
      break;
    }
  return false;
}


/* Resolve an actual argument list.  Most of the time, this is just
   resolving the expressions in the list.
   The exception is that we sometimes have to decide whether arguments
   that look like procedure arguments are really simple variable
   references.  */

static try
resolve_actual_arglist (gfc_actual_arglist * arg)
{
  gfc_symbol *sym;
  gfc_symtree *parent_st;
  gfc_expr *e;

  for (; arg; arg = arg->next)
    {

      e = arg->expr;
      if (e == NULL)
        {
          /* Check the label is a valid branching target.  */
          if (arg->label)
            {
              if (arg->label->defined == ST_LABEL_UNKNOWN)
                {
                  gfc_error ("Label %d referenced at %L is never defined",
                             arg->label->value, &arg->label->where);
                  return FAILURE;
                }
            }
          continue;
        }

      if (e->ts.type != BT_PROCEDURE)
        {
          if (gfc_resolve_expr (e) != SUCCESS)
            return FAILURE;
          continue;
        }

      /* See if the expression node should really be a variable
         reference.  */

      sym = e->symtree->n.sym;

      if (sym->attr.flavor == FL_PROCEDURE
          || sym->attr.intrinsic
          || sym->attr.external)
        {
          int actual_ok;

          /* If a procedure is not already determined to be something else
             check if it is intrinsic.  */
          if (!sym->attr.intrinsic
                && !(sym->attr.external || sym->attr.use_assoc
                       || sym->attr.if_source == IFSRC_IFBODY)
                && gfc_intrinsic_name (sym->name, sym->attr.subroutine))
            sym->attr.intrinsic = 1;

          if (sym->attr.proc == PROC_ST_FUNCTION)
            {
              gfc_error ("Statement function '%s' at %L is not allowed as an "
                         "actual argument", sym->name, &e->where);
            }

          actual_ok = gfc_intrinsic_actual_ok (sym->name, sym->attr.subroutine);
          if (sym->attr.intrinsic && actual_ok == 0)
            {
              gfc_error ("Intrinsic '%s' at %L is not allowed as an "
                         "actual argument", sym->name, &e->where);
            }

          if (sym->attr.contained && !sym->attr.use_assoc
              && sym->ns->proc_name->attr.flavor != FL_MODULE)
            {
              gfc_error ("Internal procedure '%s' is not allowed as an "
                         "actual argument at %L", sym->name, &e->where);
            }

          if (sym->attr.elemental && !sym->attr.intrinsic)
            {
              gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
                         "allowed as an actual argument at %L", sym->name,
                         &e->where);
            }

          if (sym->attr.generic)
            {
              gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
                         "allowed as an actual argument at %L", sym->name,
                         &e->where);
            }

          /* If the symbol is the function that names the current (or
             parent) scope, then we really have a variable reference.  */

          if (sym->attr.function && sym->result == sym
              && (sym->ns->proc_name == sym
                  || (sym->ns->parent != NULL
                      && sym->ns->parent->proc_name == sym)))
            goto got_variable;

          continue;
        }

      /* See if the name is a module procedure in a parent unit.  */

      if (was_declared (sym) || sym->ns->parent == NULL)
        goto got_variable;

      if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
        {
          gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
          return FAILURE;
        }

      if (parent_st == NULL)
        goto got_variable;

      sym = parent_st->n.sym;
      e->symtree = parent_st;           /* Point to the right thing.  */

      if (sym->attr.flavor == FL_PROCEDURE
          || sym->attr.intrinsic
          || sym->attr.external)
        {
          continue;
        }

    got_variable:
      e->expr_type = EXPR_VARIABLE;
      e->ts = sym->ts;
      if (sym->as != NULL)
        {
          e->rank = sym->as->rank;
          e->ref = gfc_get_ref ();
          e->ref->type = REF_ARRAY;
          e->ref->u.ar.type = AR_FULL;
          e->ref->u.ar.as = sym->as;
        }
    }

  return SUCCESS;
}


/* Do the checks of the actual argument list that are specific to elemental
   procedures.  If called with c == NULL, we have a function, otherwise if
   expr == NULL, we have a subroutine.  */
static try
resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
{
  gfc_actual_arglist *arg0;
  gfc_actual_arglist *arg;
  gfc_symbol *esym = NULL;
  gfc_intrinsic_sym *isym = NULL;
  gfc_expr *e = NULL;
  gfc_intrinsic_arg *iformal = NULL;
  gfc_formal_arglist *eformal = NULL;
  bool formal_optional = false;
  bool set_by_optional = false;
  int i;
  int rank = 0;

  /* Is this an elemental procedure?  */
  if (expr && expr->value.function.actual != NULL)
    {
      if (expr->value.function.esym != NULL
            && expr->value.function.esym->attr.elemental)
        {
          arg0 = expr->value.function.actual;
          esym = expr->value.function.esym;
        }
      else if (expr->value.function.isym != NULL
                 && expr->value.function.isym->elemental)
        {
          arg0 = expr->value.function.actual;
          isym = expr->value.function.isym;
        }
      else
        return SUCCESS;
    }
  else if (c && c->ext.actual != NULL
             && c->symtree->n.sym->attr.elemental)
    {
      arg0 = c->ext.actual;
      esym = c->symtree->n.sym;
    }
  else
    return SUCCESS;

  /* The rank of an elemental is the rank of its array argument(s).  */
  for (arg = arg0; arg; arg = arg->next)
    {
      if (arg->expr != NULL && arg->expr->rank > 0)
        {
          rank = arg->expr->rank;
          if (arg->expr->expr_type == EXPR_VARIABLE
                && arg->expr->symtree->n.sym->attr.optional)
            set_by_optional = true;

          /* Function specific; set the result rank and shape.  */
          if (expr)
            {
              expr->rank = rank;
              if (!expr->shape && arg->expr->shape)
                {
                  expr->shape = gfc_get_shape (rank);
                  for (i = 0; i < rank; i++)
                    mpz_init_set (expr->shape[i], arg->expr->shape[i]);
                }
            }
          break;
        }
    }

  /* If it is an array, it shall not be supplied as an actual argument
     to an elemental procedure unless an array of the same rank is supplied
     as an actual argument corresponding to a nonoptional dummy argument of
     that elemental procedure(12.4.1.5).  */
  formal_optional = false;
  if (isym)
    iformal = isym->formal;
  else
    eformal = esym->formal;

  for (arg = arg0; arg; arg = arg->next)
    {
      if (eformal)
        {
          if (eformal->sym && eformal->sym->attr.optional)
            formal_optional = true;
          eformal = eformal->next;
        }
      else if (isym && iformal)
        {
          if (iformal->optional)
            formal_optional = true;
          iformal = iformal->next;
        }
      else if (isym)
        formal_optional = true;

      if (pedantic && arg->expr != NULL
            && arg->expr->expr_type == EXPR_VARIABLE
            && arg->expr->symtree->n.sym->attr.optional
            && formal_optional
            && arg->expr->rank
            && (set_by_optional || arg->expr->rank != rank)
            && !(isym && isym->generic_id == GFC_ISYM_CONVERSION))
        {
          gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
                       "MISSING, it cannot be the actual argument of an "
                       "ELEMENTAL procedure unless there is a non-optional"
                       "argument with the same rank (12.4.1.5)",
                       arg->expr->symtree->n.sym->name, &arg->expr->where);
          return FAILURE;
        }
    }

  for (arg = arg0; arg; arg = arg->next)
    {
      if (arg->expr == NULL || arg->expr->rank == 0)
        continue;

      /* Being elemental, the last upper bound of an assumed size array
         argument must be present.  */
      if (resolve_assumed_size_actual (arg->expr))
        return FAILURE;

      if (expr)
        continue;

      /* Elemental subroutine array actual arguments must conform.  */
      if (e != NULL)
        {
          if (gfc_check_conformance ("elemental subroutine", arg->expr, e)
                == FAILURE)
            return FAILURE;
        }
      else
        e = arg->expr;
    }

  return SUCCESS;
}


/* Go through each actual argument in ACTUAL and see if it can be
   implemented as an inlined, non-copying intrinsic.  FNSYM is the
   function being called, or NULL if not known.  */

static void
find_noncopying_intrinsics (gfc_symbol * fnsym, gfc_actual_arglist * actual)
{
  gfc_actual_arglist *ap;
  gfc_expr *expr;

  for (ap = actual; ap; ap = ap->next)
    if (ap->expr
        && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
        && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
      ap->expr->inline_noncopying_intrinsic = 1;
}

/* This function does the checking of references to global procedures
   as defined in sections 18.1 and 14.1, respectively, of the Fortran
   77 and 95 standards.  It checks for a gsymbol for the name, making
   one if it does not already exist.  If it already exists, then the
   reference being resolved must correspond to the type of gsymbol.
   Otherwise, the new symbol is equipped with the attributes of the
   reference.  The corresponding code that is called in creating
   global entities is parse.c.  */

static void
resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
{
  gfc_gsymbol * gsym;
  unsigned int type;

  type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;

  gsym = gfc_get_gsymbol (sym->name);

  if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
    global_used (gsym, where);

  if (gsym->type == GSYM_UNKNOWN)
    {
      gsym->type = type;
      gsym->where = *where;
    }

  gsym->used = 1;
}

/************* Function resolution *************/

/* Resolve a function call known to be generic.
   Section 14.1.2.4.1.  */

static match
resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
{
  gfc_symbol *s;

  if (sym->attr.generic)
    {
      s =
        gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
      if (s != NULL)
        {
          expr->value.function.name = s->name;
          expr->value.function.esym = s;

          if (s->ts.type != BT_UNKNOWN)
            expr->ts = s->ts;
          else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
            expr->ts = s->result->ts;

          if (s->as != NULL)
            expr->rank = s->as->rank;
          else if (s->result != NULL && s->result->as != NULL)
            expr->rank = s->result->as->rank;

          return MATCH_YES;
        }

      /* TODO: Need to search for elemental references in generic interface */
    }

  if (sym->attr.intrinsic)
    return gfc_intrinsic_func_interface (expr, 0);

  return MATCH_NO;
}


static try
resolve_generic_f (gfc_expr * expr)
{
  gfc_symbol *sym;
  match m;

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

  for (;;)
    {
      m = resolve_generic_f0 (expr, sym);
      if (m == MATCH_YES)
        return SUCCESS;
      else if (m == MATCH_ERROR)
        return FAILURE;

generic:
      if (sym->ns->parent == NULL)
        break;
      gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);

      if (sym == NULL)
        break;
      if (!generic_sym (sym))
        goto generic;
    }

  /* Last ditch attempt.  */

  if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
    {
      gfc_error ("There is no specific function for the generic '%s' at %L",
                 expr->symtree->n.sym->name, &expr->where);
      return FAILURE;
    }

  m = gfc_intrinsic_func_interface (expr, 0);
  if (m == MATCH_YES)
    return SUCCESS;
  if (m == MATCH_NO)
    gfc_error
      ("Generic function '%s' at %L is not consistent with a specific "
       "intrinsic interface", expr->symtree->n.sym->name, &expr->where);

  return FAILURE;
}


/* Resolve a function call known to be specific.  */

static match
resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
{
  match m;

  if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
    {
      if (sym->attr.dummy)
        {
          sym->attr.proc = PROC_DUMMY;
          goto found;
        }

      sym->attr.proc = PROC_EXTERNAL;
      goto found;
    }

  if (sym->attr.proc == PROC_MODULE
      || sym->attr.proc == PROC_ST_FUNCTION
      || sym->attr.proc == PROC_INTERNAL)
    goto found;

  if (sym->attr.intrinsic)
    {
      m = gfc_intrinsic_func_interface (expr, 1);
      if (m == MATCH_YES)
        return MATCH_YES;
      if (m == MATCH_NO)
        gfc_error
          ("Function '%s' at %L is INTRINSIC but is not compatible with "
           "an intrinsic", sym->name, &expr->where);

      return MATCH_ERROR;
    }

  return MATCH_NO;

found:
  gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);

  expr->ts = sym->ts;
  expr->value.function.name = sym->name;
  expr->value.function.esym = sym;
  if (sym->as != NULL)
    expr->rank = sym->as->rank;

  return MATCH_YES;
}


static try
resolve_specific_f (gfc_expr * expr)
{
  gfc_symbol *sym;
  match m;

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

  for (;;)
    {
      m = resolve_specific_f0 (sym, expr);
      if (m == MATCH_YES)
        return SUCCESS;
      if (m == MATCH_ERROR)
        return FAILURE;

      if (sym->ns->parent == NULL)
        break;

      gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);

      if (sym == NULL)
        break;
    }

  gfc_error ("Unable to resolve the specific function '%s' at %L",
             expr->symtree->n.sym->name, &expr->where);

  return SUCCESS;
}


/* Resolve a procedure call not known to be generic nor specific.  */

static try
resolve_unknown_f (gfc_expr * expr)
{
  gfc_symbol *sym;
  gfc_typespec *ts;

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

  if (sym->attr.dummy)
    {
      sym->attr.proc = PROC_DUMMY;
      expr->value.function.name = sym->name;
      goto set_type;
    }

  /* See if we have an intrinsic function reference.  */

  if (gfc_intrinsic_name (sym->name, 0))
    {
      if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
        return SUCCESS;
      return FAILURE;
    }

  /* The reference is to an external name.  */

  sym->attr.proc = PROC_EXTERNAL;
  expr->value.function.name = sym->name;
  expr->value.function.esym = expr->symtree->n.sym;

  if (sym->as != NULL)
    expr->rank = sym->as->rank;

  /* Type of the expression is either the type of the symbol or the
     default type of the symbol.  */

set_type:
  gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);

  if (sym->ts.type != BT_UNKNOWN)
    expr->ts = sym->ts;
  else
    {
      ts = gfc_get_default_type (sym, sym->ns);

      if (ts->type == BT_UNKNOWN)
        {
          gfc_error ("Function '%s' at %L has no IMPLICIT type",
                     sym->name, &expr->where);
          return FAILURE;
        }
      else
        expr->ts = *ts;
    }

  return SUCCESS;
}


/* Figure out if a function reference is pure or not.  Also set the name
   of the function for a potential error message.  Return nonzero if the
   function is PURE, zero if not.  */

static int
pure_function (gfc_expr * e, const char **name)
{
  int pure;

  if (e->value.function.esym)
    {
      pure = gfc_pure (e->value.function.esym);
      *name = e->value.function.esym->name;
    }
  else if (e->value.function.isym)
    {
      pure = e->value.function.isym->pure
        || e->value.function.isym->elemental;
      *name = e->value.function.isym->name;
    }
  else
    {
      /* Implicit functions are not pure.  */
      pure = 0;
      *name = e->value.function.name;
    }

  return pure;
}


/* Resolve a function call, which means resolving the arguments, then figuring
   out which entity the name refers to.  */
/* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
   to INTENT(OUT) or INTENT(INOUT).  */

static try
resolve_function (gfc_expr * expr)
{
  gfc_actual_arglist *arg;
  gfc_symbol * sym;
  const char *name;
  try t;
  int temp;

  sym = NULL;
  if (expr->symtree)
    sym = expr->symtree->n.sym;

  /* If the procedure is not internal, a statement function or a module
     procedure,it must be external and should be checked for usage.  */
  if (sym && !sym->attr.dummy && !sym->attr.contained
        && sym->attr.proc != PROC_ST_FUNCTION
        && !sym->attr.use_assoc)
    resolve_global_procedure (sym, &expr->where, 0);

  /* Switch off assumed size checking and do this again for certain kinds
     of procedure, once the procedure itself is resolved.  */
  need_full_assumed_size++;

  if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
    return FAILURE;

  /* Resume assumed_size checking. */
  need_full_assumed_size--;

  if (sym && sym->ts.type == BT_CHARACTER
        && sym->ts.cl
        && sym->ts.cl->length == NULL
        && !sym->attr.dummy
        && expr->value.function.esym == NULL
        && !sym->attr.contained)
    {
      /* Internal procedures are taken care of in resolve_contained_fntype.  */
      gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
                 "be used at %L since it is not a dummy argument",
                 sym->name, &expr->where);
      return FAILURE;
    }

/* See if function is already resolved.  */

  if (expr->value.function.name != NULL)
    {
      if (expr->ts.type == BT_UNKNOWN)
        expr->ts = sym->ts;
      t = SUCCESS;
    }
  else
    {
      /* Apply the rules of section 14.1.2.  */

      switch (procedure_kind (sym))
        {
        case PTYPE_GENERIC:
          t = resolve_generic_f (expr);
          break;

        case PTYPE_SPECIFIC:
          t = resolve_specific_f (expr);
          break;

        case PTYPE_UNKNOWN:
          t = resolve_unknown_f (expr);
          break;

        default:
          gfc_internal_error ("resolve_function(): bad function type");
        }
    }

  /* If the expression is still a function (it might have simplified),
     then we check to see if we are calling an elemental function.  */

  if (expr->expr_type != EXPR_FUNCTION)
    return t;

  temp = need_full_assumed_size;
  need_full_assumed_size = 0;

  if (resolve_elemental_actual (expr, NULL) == FAILURE)
    return FAILURE;

  if (omp_workshare_flag
      && expr->value.function.esym
      && ! gfc_elemental (expr->value.function.esym))
    {
      gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed"
                 " in WORKSHARE construct", expr->value.function.esym->name,
                 &expr->where);
      t = FAILURE;
    }

  else if (expr->value.function.actual != NULL
             && expr->value.function.isym != NULL
             && expr->value.function.isym->generic_id != GFC_ISYM_LBOUND
             && expr->value.function.isym->generic_id != GFC_ISYM_LOC
             && expr->value.function.isym->generic_id != GFC_ISYM_PRESENT)
    {
      /* Array intrinsics must also have the last upper bound of an
         assumed size array argument.  UBOUND and SIZE have to be
         excluded from the check if the second argument is anything
         than a constant.  */
      int inquiry;
      inquiry = expr->value.function.isym->generic_id == GFC_ISYM_UBOUND
                  || expr->value.function.isym->generic_id == GFC_ISYM_SIZE;

      for (arg = expr->value.function.actual; arg; arg = arg->next)
        {
          if (inquiry && arg->next != NULL && arg->next->expr
                && arg->next->expr->expr_type != EXPR_CONSTANT)
            break;

          if (arg->expr != NULL
                && arg->expr->rank > 0
                && resolve_assumed_size_actual (arg->expr))
            return FAILURE;
        }
    }

  need_full_assumed_size = temp;

  if (!pure_function (expr, &name) && name)
    {
      if (forall_flag)
        {
          gfc_error
            ("reference to non-PURE function '%s' at %L inside a "
             "FORALL %s", name, &expr->where, forall_flag == 2 ?
             "mask" : "block");
          t = FAILURE;
        }
      else if (gfc_pure (NULL))
        {
          gfc_error ("Function reference to '%s' at %L is to a non-PURE "
                     "procedure within a PURE procedure", name, &expr->where);
          t = FAILURE;
        }
    }

  /* Functions without the RECURSIVE attribution are not allowed to
   * call themselves.  */
  if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
    {
      gfc_symbol *esym, *proc;
      esym = expr->value.function.esym;
      proc = gfc_current_ns->proc_name;
      if (esym == proc)
      {
        gfc_error ("Function '%s' at %L cannot call itself, as it is not "
                   "RECURSIVE", name, &expr->where);
        t = FAILURE;
      }

      if (esym->attr.entry && esym->ns->entries && proc->ns->entries
          && esym->ns->entries->sym == proc->ns->entries->sym)
      {
        gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
                   "'%s' is not declared as RECURSIVE",
                   esym->name, &expr->where, esym->ns->entries->sym->name);
        t = FAILURE;
      }
    }

  /* Character lengths of use associated functions may contains references to
     symbols not referenced from the current program unit otherwise.  Make sure
     those symbols are marked as referenced.  */

  if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
      && expr->value.function.esym->attr.use_assoc)
    {
      gfc_expr_set_symbols_referenced (expr->ts.cl->length);
    }

  if (t == SUCCESS)
    find_noncopying_intrinsics (expr->value.function.esym,
                                expr->value.function.actual);
  return t;
}


/************* Subroutine resolution *************/

static void
pure_subroutine (gfc_code * c, gfc_symbol * sym)
{

  if (gfc_pure (sym))
    return;

  if (forall_flag)
    gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
               sym->name, &c->loc);
  else if (gfc_pure (NULL))
    gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
               &c->loc);
}


static match
resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
{
  gfc_symbol *s;

  if (sym->attr.generic)
    {
      s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
      if (s != NULL)
        {
          c->resolved_sym = s;
          pure_subroutine (c, s);
          return MATCH_YES;
        }

      /* TODO: Need to search for elemental references in generic interface.  */
    }

  if (sym->attr.intrinsic)
    return gfc_intrinsic_sub_interface (c, 0);

  return MATCH_NO;
}


static try
resolve_generic_s (gfc_code * c)
{
  gfc_symbol *sym;
  match m;

  sym = c->symtree->n.sym;

  for (;;)
    {
      m = resolve_generic_s0 (c, sym);
      if (m == MATCH_YES)
        return SUCCESS;
      else if (m == MATCH_ERROR)
        return FAILURE;

generic:
      if (sym->ns->parent == NULL)
        break;
      gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);

      if (sym == NULL)
        break;
      if (!generic_sym (sym))
        goto generic;
    }

  /* Last ditch attempt.  */
  sym = c->symtree->n.sym;
  if (!gfc_generic_intrinsic (sym->name))
    {
      gfc_error
        ("There is no specific subroutine for the generic '%s' at %L",
         sym->name, &c->loc);
      return FAILURE;
    }

  m = gfc_intrinsic_sub_interface (c, 0);
  if (m == MATCH_YES)
    return SUCCESS;
  if (m == MATCH_NO)
    gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
               "intrinsic subroutine interface", sym->name, &c->loc);

  return FAILURE;
}


/* Resolve a subroutine call known to be specific.  */

static match
resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
{
  match m;

  if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
    {
      if (sym->attr.dummy)
        {
          sym->attr.proc = PROC_DUMMY;
          goto found;
        }

      sym->attr.proc = PROC_EXTERNAL;
      goto found;
    }

  if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
    goto found;

  if (sym->attr.intrinsic)
    {
      m = gfc_intrinsic_sub_interface (c, 1);
      if (m == MATCH_YES)
        return MATCH_YES;
      if (m == MATCH_NO)
        gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
                   "with an intrinsic", sym->name, &c->loc);

      return MATCH_ERROR;
    }

  return MATCH_NO;

found:
  gfc_procedure_use (sym, &c->ext.actual, &c->loc);

  c->resolved_sym = sym;
  pure_subroutine (c, sym);

  return MATCH_YES;
}


static try
resolve_specific_s (gfc_code * c)
{
  gfc_symbol *sym;
  match m;

  sym = c->symtree->n.sym;

  for (;;)
    {
      m = resolve_specific_s0 (c, sym);
      if (m == MATCH_YES)
        return SUCCESS;
      if (m == MATCH_ERROR)
        return FAILURE;

      if (sym->ns->parent == NULL)
        break;

      gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);

      if (sym == NULL)
        break;
    }

  sym = c->symtree->n.sym;
  gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
             sym->name, &c->loc);

  return FAILURE;
}


/* Resolve a subroutine call not known to be generic nor specific.  */

static try
resolve_unknown_s (gfc_code * c)
{
  gfc_symbol *sym;

  sym = c->symtree->n.sym;

  if (sym->attr.dummy)
    {
      sym->attr.proc = PROC_DUMMY;
      goto found;
    }

  /* See if we have an intrinsic function reference.  */

  if (gfc_intrinsic_name (sym->name, 1))
    {
      if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
        return SUCCESS;
      return FAILURE;
    }

  /* The reference is to an external name.  */

found:
  gfc_procedure_use (sym, &c->ext.actual, &c->loc);

  c->resolved_sym = sym;

  pure_subroutine (c, sym);

  return SUCCESS;
}


/* Resolve a subroutine call.  Although it was tempting to use the same code
   for functions, subroutines and functions are stored differently and this
   makes things awkward.  */

static try
resolve_call (gfc_code * c)
{
  try t;

  if (c->symtree && c->symtree->n.sym
        && c->symtree->n.sym->ts.type != BT_UNKNOWN)
    {
      gfc_error ("'%s' at %L has a type, which is not consistent with "
                 "the CALL at %L", c->symtree->n.sym->name,
                 &c->symtree->n.sym->declared_at, &c->loc);
      return FAILURE;
    }

  /* If the procedure is not internal or module, it must be external and
     should be checked for usage.  */
  if (c->symtree && c->symtree->n.sym
        && !c->symtree->n.sym->attr.dummy
        && !c->symtree->n.sym->attr.contained
        && !c->symtree->n.sym->attr.use_assoc)
    resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);

  /* Subroutines without the RECURSIVE attribution are not allowed to
   * call themselves.  */
  if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
    {
      gfc_symbol *csym, *proc;
      csym = c->symtree->n.sym;
      proc = gfc_current_ns->proc_name;
      if (csym == proc)
      {
        gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
                   "RECURSIVE", csym->name, &c->loc);
        t = FAILURE;
      }

      if (csym->attr.entry && csym->ns->entries && proc->ns->entries
          && csym->ns->entries->sym == proc->ns->entries->sym)
      {
        gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
                   "'%s' is not declared as RECURSIVE",
                   csym->name, &c->loc, csym->ns->entries->sym->name);
        t = FAILURE;
      }
    }

  /* Switch off assumed size checking and do this again for certain kinds
     of procedure, once the procedure itself is resolved.  */
  need_full_assumed_size++;

  if (resolve_actual_arglist (c->ext.actual) == FAILURE)
    return FAILURE;

  /* Resume assumed_size checking. */
  need_full_assumed_size--;


  t = SUCCESS;
  if (c->resolved_sym == NULL)
    switch (procedure_kind (c->symtree->n.sym))
      {
      case PTYPE_GENERIC:
        t = resolve_generic_s (c);
        break;

      case PTYPE_SPECIFIC:
        t = resolve_specific_s (c);
        break;

      case PTYPE_UNKNOWN:
        t = resolve_unknown_s (c);
        break;

      default:
        gfc_internal_error ("resolve_subroutine(): bad function type");
      }

  /* Some checks of elemental subroutine actual arguments.  */
  if (resolve_elemental_actual (NULL, c) == FAILURE)
    return FAILURE;

  if (t == SUCCESS)
    find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
  return t;
}

/* Compare the shapes of two arrays that have non-NULL shapes.  If both
   op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
   match.  If both op1->shape and op2->shape are non-NULL return FAILURE
   if their shapes do not match.  If either op1->shape or op2->shape is
   NULL, return SUCCESS.  */

static try
compare_shapes (gfc_expr * op1, gfc_expr * op2)
{
  try t;
  int i;

  t = SUCCESS;

  if (op1->shape != NULL && op2->shape != NULL)
    {
      for (i = 0; i < op1->rank; i++)
        {
          if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
           {
             gfc_error ("Shapes for operands at %L and %L are not conformable",
                         &op1->where, &op2->where);
             t = FAILURE;
             break;
           }
        }
    }

  return t;
}

/* Resolve an operator expression node.  This can involve replacing the
   operation with a user defined function call.  */

static try
resolve_operator (gfc_expr * e)
{
  gfc_expr *op1, *op2;
  char msg[200];
  try t;

  /* Resolve all subnodes-- give them types.  */

  switch (e->value.op.operator)
    {
    default:
      if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
        return FAILURE;

    /* Fall through...  */

    case INTRINSIC_NOT:
    case INTRINSIC_UPLUS:
    case INTRINSIC_UMINUS:
    case INTRINSIC_PARENTHESES:
      if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
        return FAILURE;
      break;
    }

  /* Typecheck the new node.  */

  op1 = e->value.op.op1;
  op2 = e->value.op.op2;

  switch (e->value.op.operator)
    {
    case INTRINSIC_UPLUS:
    case INTRINSIC_UMINUS:
      if (op1->ts.type == BT_INTEGER
          || op1->ts.type == BT_REAL
          || op1->ts.type == BT_COMPLEX)
        {
          e->ts = op1->ts;
          break;
        }

      sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
               gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
      goto bad_op;

    case INTRINSIC_PLUS:
    case INTRINSIC_MINUS:
    case INTRINSIC_TIMES:
    case INTRINSIC_DIVIDE:
    case INTRINSIC_POWER:
      if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
        {
          gfc_type_convert_binary (e);
          break;
        }

      sprintf (msg,
               _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
               gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
               gfc_typename (&op2->ts));
      goto bad_op;

    case INTRINSIC_CONCAT:
      if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
        {
          e->ts.type = BT_CHARACTER;
          e->ts.kind = op1->ts.kind;
          break;
        }

      sprintf (msg,
               _("Operands of string concatenation operator at %%L are %s/%s"),
               gfc_typename (&op1->ts), gfc_typename (&op2->ts));
      goto bad_op;

    case INTRINSIC_AND:
    case INTRINSIC_OR:
    case INTRINSIC_EQV:
    case INTRINSIC_NEQV:
      if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
        {
          e->ts.type = BT_LOGICAL;
          e->ts.kind = gfc_kind_max (op1, op2);
          if (op1->ts.kind < e->ts.kind)
            gfc_convert_type (op1, &e->ts, 2);
          else if (op2->ts.kind < e->ts.kind)
            gfc_convert_type (op2, &e->ts, 2);
          break;
        }

      sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
               gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
               gfc_typename (&op2->ts));

      goto bad_op;

    case INTRINSIC_NOT:
      if (op1->ts.type == BT_LOGICAL)
        {
          e->ts.type = BT_LOGICAL;
          e->ts.kind = op1->ts.kind;
          break;
        }

      sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
               gfc_typename (&op1->ts));
      goto bad_op;

    case INTRINSIC_GT:
    case INTRINSIC_GE:
    case INTRINSIC_LT:
    case INTRINSIC_LE:
      if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
        {
          strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
          goto bad_op;
        }

      /* Fall through...  */

    case INTRINSIC_EQ:
    case INTRINSIC_NE:
      if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
        {
          e->ts.type = BT_LOGICAL;
          e->ts.kind = gfc_default_logical_kind;
          break;
        }

      if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
        {
          gfc_type_convert_binary (e);

          e->ts.type = BT_LOGICAL;
          e->ts.kind = gfc_default_logical_kind;
          break;
        }

      if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
        sprintf (msg,
                 _("Logicals at %%L must be compared with %s instead of %s"),
                 e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
                 gfc_op2string (e->value.op.operator));
      else
        sprintf (msg,
                 _("Operands of comparison operator '%s' at %%L are %s/%s"),
                 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
                 gfc_typename (&op2->ts));

      goto bad_op;

    case INTRINSIC_USER:
      if (op2 == NULL)
        sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
                 e->value.op.uop->name, gfc_typename (&op1->ts));
      else
        sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
                 e->value.op.uop->name, gfc_typename (&op1->ts),
                 gfc_typename (&op2->ts));

      goto bad_op;

    case INTRINSIC_PARENTHESES:
      break;

    default:
      gfc_internal_error ("resolve_operator(): Bad intrinsic");
    }

  /* Deal with arrayness of an operand through an operator.  */

  t = SUCCESS;

  switch (e->value.op.operator)
    {
    case INTRINSIC_PLUS:
    case INTRINSIC_MINUS:
    case INTRINSIC_TIMES:
    case INTRINSIC_DIVIDE:
    case INTRINSIC_POWER:
    case INTRINSIC_CONCAT:
    case INTRINSIC_AND:
    case INTRINSIC_OR:
    case INTRINSIC_EQV:
    case INTRINSIC_NEQV:
    case INTRINSIC_EQ:
    case INTRINSIC_NE:
    case INTRINSIC_GT:
    case INTRINSIC_GE:
    case INTRINSIC_LT:
    case INTRINSIC_LE:

      if (op1->rank == 0 && op2->rank == 0)
        e->rank = 0;

      if (op1->rank == 0 && op2->rank != 0)
        {
          e->rank = op2->rank;

          if (e->shape == NULL)
            e->shape = gfc_copy_shape (op2->shape, op2->rank);
        }

      if (op1->rank != 0 && op2->rank == 0)
        {
          e->rank = op1->rank;

          if (e->shape == NULL)
            e->shape = gfc_copy_shape (op1->shape, op1->rank);
        }

      if (op1->rank != 0 && op2->rank != 0)
        {
          if (op1->rank == op2->rank)
            {
              e->rank = op1->rank;
              if (e->shape == NULL)
                {
                  t = compare_shapes(op1, op2);
                  if (t == FAILURE)
                    e->shape = NULL;
                  else
                e->shape = gfc_copy_shape (op1->shape, op1->rank);
                }
            }
          else
            {
              gfc_error ("Inconsistent ranks for operator at %L and %L",
                         &op1->where, &op2->where);
              t = FAILURE;

              /* Allow higher level expressions to work.  */
              e->rank = 0;
            }
        }

      break;

    case INTRINSIC_NOT:
    case INTRINSIC_UPLUS:
    case INTRINSIC_UMINUS:
    case INTRINSIC_PARENTHESES:
      e->rank = op1->rank;

      if (e->shape == NULL)
        e->shape = gfc_copy_shape (op1->shape, op1->rank);

      /* Simply copy arrayness attribute */
      break;

    default:
      break;
    }

  /* Attempt to simplify the expression.  */
  if (t == SUCCESS)
    t = gfc_simplify_expr (e, 0);
  return t;

bad_op:

  if (gfc_extend_expr (e) == SUCCESS)
    return SUCCESS;

  gfc_error (msg, &e->where);

  return FAILURE;
}


/************** Array resolution subroutines **************/


typedef enum
{ CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
comparison;

/* Compare two integer expressions.  */

static comparison
compare_bound (gfc_expr * a, gfc_expr * b)
{
  int i;

  if (a == NULL || a->expr_type != EXPR_CONSTANT
      || b == NULL || b->expr_type != EXPR_CONSTANT)
    return CMP_UNKNOWN;

  if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
    gfc_internal_error ("compare_bound(): Bad expression");

  i = mpz_cmp (a->value.integer, b->value.integer);

  if (i < 0)
    return CMP_LT;
  if (i > 0)
    return CMP_GT;
  return CMP_EQ;
}


/* Compare an integer expression with an integer.  */

static comparison
compare_bound_int (gfc_expr * a, int b)
{
  int i;

  if (a == NULL || a->expr_type != EXPR_CONSTANT)
    return CMP_UNKNOWN;

  if (a->ts.type != BT_INTEGER)
    gfc_internal_error ("compare_bound_int(): Bad expression");

  i = mpz_cmp_si (a->value.integer, b);

  if (i < 0)
    return CMP_LT;
  if (i > 0)
    return CMP_GT;
  return CMP_EQ;
}


/* Compare an integer expression with a mpz_t.  */

static comparison
compare_bound_mpz_t (gfc_expr * a, mpz_t b)
{
  int i;

  if (a == NULL || a->expr_type != EXPR_CONSTANT)
    return CMP_UNKNOWN;

  if (a->ts.type != BT_INTEGER)
    gfc_internal_error ("compare_bound_int(): Bad expression");

  i = mpz_cmp (a->value.integer, b);

  if (i < 0)
    return CMP_LT;
  if (i > 0)
    return CMP_GT;
  return CMP_EQ;
}


/* Compute the last value of a sequence given by a triplet.  
   Return 0 if it wasn't able to compute the last value, or if the
   sequence if empty, and 1 otherwise.  */

static int
compute_last_value_for_triplet (gfc_expr * start, gfc_expr * end,
                                gfc_expr * stride, mpz_t last)
{
  mpz_t rem;

  if (start == NULL || start->expr_type != EXPR_CONSTANT
      || end == NULL || end->expr_type != EXPR_CONSTANT
      || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
    return 0;

  if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
      || (stride != NULL && stride->ts.type != BT_INTEGER))
    return 0;

  if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
    {
      if (compare_bound (start, end) == CMP_GT)
        return 0;
      mpz_set (last, end->value.integer);
      return 1;
    }

  if (compare_bound_int (stride, 0) == CMP_GT)
    {
      /* Stride is positive */
      if (mpz_cmp (start->value.integer, end->value.integer) > 0)
        return 0;
    }
  else
    {
      /* Stride is negative */
      if (mpz_cmp (start->value.integer, end->value.integer) < 0)
        return 0;
    }

  mpz_init (rem);
  mpz_sub (rem, end->value.integer, start->value.integer);
  mpz_tdiv_r (rem, rem, stride->value.integer);
  mpz_sub (last, end->value.integer, rem);
  mpz_clear (rem);

  return 1;
}


/* Compare a single dimension of an array reference to the array
   specification.  */

static try
check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
{
  mpz_t last_value;

/* Given start, end and stride values, calculate the minimum and
   maximum referenced indexes.  */

  switch (ar->type)
    {
    case AR_FULL:
      break;

    case AR_ELEMENT:
      if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
        goto bound;
      if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
        goto bound;

      break;

    case AR_SECTION:
      if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
        {
          gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
          return FAILURE;
        }

#define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
#define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])

      if (compare_bound (AR_START, AR_END) == CMP_EQ
          && (compare_bound (AR_START, as->lower[i]) == CMP_LT
              || compare_bound (AR_START, as->upper[i]) == CMP_GT))
        goto bound;

      if (((compare_bound_int (ar->stride[i], 0) == CMP_GT
            || ar->stride[i] == NULL)
           && compare_bound (AR_START, AR_END) != CMP_GT)
          || (compare_bound_int (ar->stride[i], 0) == CMP_LT
              && compare_bound (AR_START, AR_END) != CMP_LT))
        {
          if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
            goto bound;
          if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
            goto bound;
        }

      mpz_init (last_value);
      if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
                                          last_value))
        {
          if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT
              || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
            {
              mpz_clear (last_value);
              goto bound;
            }
        }
      mpz_clear (last_value);

#undef AR_START
#undef AR_END

      break;

    default:
      gfc_internal_error ("check_dimension(): Bad array reference");
    }

  return SUCCESS;

bound:
  gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
  return SUCCESS;
}


/* Compare an array reference with an array specification.  */

static try
compare_spec_to_ref (gfc_array_ref * ar)
{
  gfc_array_spec *as;
  int i;

  as = ar->as;
  i = as->rank - 1;
  /* TODO: Full array sections are only allowed as actual parameters.  */
  if (as->type == AS_ASSUMED_SIZE
      && (/*ar->type == AR_FULL
          ||*/ (ar->type == AR_SECTION
              && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
    {
      gfc_error ("Rightmost upper bound of assumed size array section"
                 " not specified at %L", &ar->where);
      return FAILURE;
    }

  if (ar->type == AR_FULL)
    return SUCCESS;

  if (as->rank != ar->dimen)
    {
      gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
                 &ar->where, ar->dimen, as->rank);
      return FAILURE;
    }

  for (i = 0; i < as->rank; i++)
    if (check_dimension (i, ar, as) == FAILURE)
      return FAILURE;

  return SUCCESS;
}


/* Resolve one part of an array index.  */

try
gfc_resolve_index (gfc_expr * index, int check_scalar)
{
  gfc_typespec ts;

  if (index == NULL)
    return SUCCESS;

  if (gfc_resolve_expr (index) == FAILURE)
    return FAILURE;

  if (check_scalar && index->rank != 0)
    {
      gfc_error ("Array index at %L must be scalar", &index->where);
      return FAILURE;
    }

  if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
    {
      gfc_error ("Array index at %L must be of INTEGER type",
                 &index->where);
      return FAILURE;
    }

  if (index->ts.type == BT_REAL)
    if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
                        &index->where) == FAILURE)
      return FAILURE;

  if (index->ts.kind != gfc_index_integer_kind
      || index->ts.type != BT_INTEGER)
    {
      gfc_clear_ts (&ts);
      ts.type = BT_INTEGER;
      ts.kind = gfc_index_integer_kind;

      gfc_convert_type_warn (index, &ts, 2, 0);
    }

  return SUCCESS;
}

/* Resolve a dim argument to an intrinsic function.  */

try
gfc_resolve_dim_arg (gfc_expr *dim)
{
  if (dim == NULL)
    return SUCCESS;

  if (gfc_resolve_expr (dim) == FAILURE)
    return FAILURE;

  if (dim->rank != 0)
    {
      gfc_error ("Argument dim at %L must be scalar", &dim->where);
      return FAILURE;

    }
  if (dim->ts.type != BT_INTEGER)
    {
      gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
      return FAILURE;
    }
  if (dim->ts.kind != gfc_index_integer_kind)
    {
      gfc_typespec ts;

      ts.type = BT_INTEGER;
      ts.kind = gfc_index_integer_kind;

      gfc_convert_type_warn (dim, &ts, 2, 0);
    }

  return SUCCESS;
}

/* Given an expression that contains array references, update those array
   references to point to the right array specifications.  While this is
   filled in during matching, this information is difficult to save and load
   in a module, so we take care of it here.

   The idea here is that the original array reference comes from the
   base symbol.  We traverse the list of reference structures, setting
   the stored reference to references.  Component references can
   provide an additional array specification.  */

static void
find_array_spec (gfc_expr * e)
{
  gfc_array_spec *as;
  gfc_component *c;
  gfc_symbol *derived;
  gfc_ref *ref;

  as = e->symtree->n.sym->as;
  derived = NULL;

  for (ref = e->ref; ref; ref = ref->next)
    switch (ref->type)
      {
      case REF_ARRAY:
        if (as == NULL)
          gfc_internal_error ("find_array_spec(): Missing spec");

        ref->u.ar.as = as;
        as = NULL;
        break;

      case REF_COMPONENT:
        if (derived == NULL)
          derived = e->symtree->n.sym->ts.derived;

        c = derived->components;

        for (; c; c = c->next)
          if (c == ref->u.c.component)
            {
              /* Track the sequence of component references.  */
              if (c->ts.type == BT_DERIVED)
                derived = c->ts.derived;
              break;
            }

        if (c == NULL)
          gfc_internal_error ("find_array_spec(): Component not found");

        if (c->dimension)
          {
            if (as != NULL)
              gfc_internal_error ("find_array_spec(): unused as(1)");
            as = c->as;
          }

        break;

      case REF_SUBSTRING:
        break;
      }

  if (as != NULL)
    gfc_internal_error ("find_array_spec(): unused as(2)");
}


/* Resolve an array reference.  */

static try
resolve_array_ref (gfc_array_ref * ar)
{
  int i, check_scalar;
  gfc_expr *e;

  for (i = 0; i < ar->dimen; i++)
    {
      check_scalar = ar->dimen_type[i] == DIMEN_RANGE;

      if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
        return FAILURE;
      if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
        return FAILURE;
      if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
        return FAILURE;

      e = ar->start[i];

      if (ar->dimen_type[i] == DIMEN_UNKNOWN)
        switch (e->rank)
          {
          case 0:
            ar->dimen_type[i] = DIMEN_ELEMENT;
            break;

          case 1:
            ar->dimen_type[i] = DIMEN_VECTOR;
            if (e->expr_type == EXPR_VARIABLE
                   && e->symtree->n.sym->ts.type == BT_DERIVED)
              ar->start[i] = gfc_get_parentheses (e);
            break;

          default:
            gfc_error ("Array index at %L is an array of rank %d",
                       &ar->c_where[i], e->rank);
            return FAILURE;
          }
    }

  /* If the reference type is unknown, figure out what kind it is.  */

  if (ar->type == AR_UNKNOWN)
    {
      ar->type = AR_ELEMENT;
      for (i = 0; i < ar->dimen; i++)
        if (ar->dimen_type[i] == DIMEN_RANGE
            || ar->dimen_type[i] == DIMEN_VECTOR)
          {
            ar->type = AR_SECTION;
            break;
          }
    }

  if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
    return FAILURE;

  return SUCCESS;
}


static try
resolve_substring (gfc_ref * ref)
{

  if (ref->u.ss.start != NULL)
    {
      if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
        return FAILURE;

      if (ref->u.ss.start->ts.type != BT_INTEGER)
        {
          gfc_error ("Substring start index at %L must be of type INTEGER",
                     &ref->u.ss.start->where);
          return FAILURE;
        }

      if (ref->u.ss.start->rank != 0)
        {
          gfc_error ("Substring start index at %L must be scalar",
                     &ref->u.ss.start->where);
          return FAILURE;
        }

      if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
          && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
              || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
        {
          gfc_error ("Substring start index at %L is less than one",
                     &ref->u.ss.start->where);
          return FAILURE;
        }
    }

  if (ref->u.ss.end != NULL)
    {
      if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
        return FAILURE;

      if (ref->u.ss.end->ts.type != BT_INTEGER)
        {
          gfc_error ("Substring end index at %L must be of type INTEGER",
                     &ref->u.ss.end->where);
          return FAILURE;
        }

      if (ref->u.ss.end->rank != 0)
        {
          gfc_error ("Substring end index at %L must be scalar",
                     &ref->u.ss.end->where);
          return FAILURE;
        }

      if (ref->u.ss.length != NULL
          && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
          && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
              || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
        {
          gfc_error ("Substring end index at %L exceeds the string length",
                     &ref->u.ss.start->where);
          return FAILURE;
        }
    }

  return SUCCESS;
}


/* Resolve subtype references.  */

static try
resolve_ref (gfc_expr * expr)
{
  int current_part_dimension, n_components, seen_part_dimension;
  gfc_ref *ref;

  for (ref = expr->ref; ref; ref = ref->next)
    if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
      {
        find_array_spec (expr);
        break;
      }

  for (ref = expr->ref; ref; ref = ref->next)
    switch (ref->type)
      {
      case REF_ARRAY:
        if (resolve_array_ref (&ref->u.ar) == FAILURE)
          return FAILURE;
        break;

      case REF_COMPONENT:
        break;

      case REF_SUBSTRING:
        resolve_substring (ref);
        break;
      }

  /* Check constraints on part references.  */

  current_part_dimension = 0;
  seen_part_dimension = 0;
  n_components = 0;

  for (ref = expr->ref; ref; ref = ref->next)
    {
      switch (ref->type)
        {
        case REF_ARRAY:
          switch (ref->u.ar.type)
            {
            case AR_FULL:
            case AR_SECTION:
              current_part_dimension = 1;
              break;

            case AR_ELEMENT:
              current_part_dimension = 0;
              break;

            case AR_UNKNOWN:
              gfc_internal_error ("resolve_ref(): Bad array reference");
            }

          break;

        case REF_COMPONENT:
          if (current_part_dimension || seen_part_dimension)
            {
              if (ref->u.c.component->pointer)
                {
                  gfc_error
                    ("Component to the right of a part reference with nonzero "
                     "rank must not have the POINTER attribute at %L",
                     &expr->where);
                  return FAILURE;
                }
              else if (ref->u.c.component->allocatable)
                {
                  gfc_error
                    ("Component to the right of a part reference with nonzero "
                     "rank must not have the ALLOCATABLE attribute at %L",
                     &expr->where);
                  return FAILURE;
                }
            }

          n_components++;
          break;

        case REF_SUBSTRING:
          break;
        }

      if (((ref->type == REF_COMPONENT && n_components > 1)
           || ref->next == NULL)
          && current_part_dimension
          && seen_part_dimension)
        {

          gfc_error ("Two or more part references with nonzero rank must "
                     "not be specified at %L", &expr->where);
          return FAILURE;
        }

      if (ref->type == REF_COMPONENT)
        {
          if (current_part_dimension)
            seen_part_dimension = 1;

          /* reset to make sure */
          current_part_dimension = 0;
        }
    }

  return SUCCESS;
}


/* Given an expression, determine its shape.  This is easier than it sounds.
   Leaves the shape array NULL if it is not possible to determine the shape.  */

static void
expression_shape (gfc_expr * e)
{
  mpz_t array[GFC_MAX_DIMENSIONS];
  int i;

  if (e->rank == 0 || e->shape != NULL)
    return;

  for (i = 0; i < e->rank; i++)
    if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
      goto fail;

  e->shape = gfc_get_shape (e->rank);

  memcpy (e->shape, array, e->rank * sizeof (mpz_t));

  return;

fail:
  for (i--; i >= 0; i--)
    mpz_clear (array[i]);
}


/* Given a variable expression node, compute the rank of the expression by
   examining the base symbol and any reference structures it may have.  */

static void
expression_rank (gfc_expr * e)
{
  gfc_ref *ref;
  int i, rank;

  if (e->ref == NULL)
    {
      if (e->expr_type == EXPR_ARRAY)
        goto done;
      /* Constructors can have a rank different from one via RESHAPE().  */

      if (e->symtree == NULL)
        {
          e->rank = 0;
          goto done;
        }

      e->rank = (e->symtree->n.sym->as == NULL)
                  ? 0 : e->symtree->n.sym->as->rank;
      goto done;
    }

  rank = 0;

  for (ref = e->ref; ref; ref = ref->next)
    {
      if (ref->type != REF_ARRAY)
        continue;

      if (ref->u.ar.type == AR_FULL)
        {
          rank = ref->u.ar.as->rank;
          break;
        }

      if (ref->u.ar.type == AR_SECTION)
        {
          /* Figure out the rank of the section.  */
          if (rank != 0)
            gfc_internal_error ("expression_rank(): Two array specs");

          for (i = 0; i < ref->u.ar.dimen; i++)
            if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
                || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
              rank++;

          break;
        }
    }

  e->rank = rank;

done:
  expression_shape (e);
}


/* Resolve a variable expression.  */

static try
resolve_variable (gfc_expr * e)
{
  gfc_symbol *sym;
  try t;

  t = SUCCESS;

  if (e->symtree == NULL)
    return FAILURE;

  if (e->ref && resolve_ref (e) == FAILURE)
    return FAILURE;

  sym = e->symtree->n.sym;
  if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
    {
      e->ts.type = BT_PROCEDURE;
      return SUCCESS;
    }

  if (sym->ts.type != BT_UNKNOWN)
    gfc_variable_attr (e, &e->ts);
  else
    {
      /* Must be a simple variable reference.  */
      if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
        return FAILURE;
      e->ts = sym->ts;
    }

  if (check_assumed_size_reference (sym, e))
    return FAILURE;

  /* Deal with forward references to entries during resolve_code, to
     satisfy, at least partially, 12.5.2.5.  */
  if (gfc_current_ns->entries
        && current_entry_id == sym->entry_id
        && cs_base
        && cs_base->current
        && cs_base->current->op != EXEC_ENTRY)
    {
      gfc_entry_list *entry;
      gfc_formal_arglist *formal;
      int n;
      bool seen;

      /* If the symbol is a dummy...  */
      if (sym->attr.dummy)
        {
          entry = gfc_current_ns->entries;
          seen = false;

          /* ...test if the symbol is a parameter of previous entries.  */
          for (; entry && entry->id <= current_entry_id; entry = entry->next)
            for (formal = entry->sym->formal; formal; formal = formal->next)
              {
                if (formal->sym && sym->name == formal->sym->name)
                  seen = true;
              }

          /*  If it has not been seen as a dummy, this is an error.  */
          if (!seen)
            {
              if (specification_expr)
                gfc_error ("Variable '%s',used in a specification expression, "
                           "is referenced at %L before the ENTRY statement "
                           "in which it is a parameter",
                           sym->name, &cs_base->current->loc);
              else
                gfc_error ("Variable '%s' is used at %L before the ENTRY "
                           "statement in which it is a parameter",
                           sym->name, &cs_base->current->loc);
              t = FAILURE;
            }
        }

      /* Now do the same check on the specification expressions.  */
      specification_expr = 1;
      if (sym->ts.type == BT_CHARACTER
            && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
        t = FAILURE;

      if (sym->as)
        for (n = 0; n < sym->as->rank; n++)
          {
             specification_expr = 1;
             if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
               t = FAILURE;
             specification_expr = 1;
             if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
               t = FAILURE;
          }
      specification_expr = 0;

      if (t == SUCCESS)
        /* Update the symbol's entry level.  */
        sym->entry_id = current_entry_id + 1;
    }

  return t;
}


/* Resolve an expression.  That is, make sure that types of operands agree
   with their operators, intrinsic operators are converted to function calls
   for overloaded types and unresolved function references are resolved.  */

try
gfc_resolve_expr (gfc_expr * e)
{
  try t;

  if (e == NULL)
    return SUCCESS;

  switch (e->expr_type)
    {
    case EXPR_OP:
      t = resolve_operator (e);
      break;

    case EXPR_FUNCTION:
      t = resolve_function (e);
      break;

    case EXPR_VARIABLE:
      t = resolve_variable (e);
      if (t == SUCCESS)
        expression_rank (e);
      break;

    case EXPR_SUBSTRING:
      t = resolve_ref (e);
      break;

    case EXPR_CONSTANT:
    case EXPR_NULL:
      t = SUCCESS;
      break;

    case EXPR_ARRAY:
      t = FAILURE;
      if (resolve_ref (e) == FAILURE)
        break;

      t = gfc_resolve_array_constructor (e);
      /* Also try to expand a constructor.  */
      if (t == SUCCESS)
        {
          expression_rank (e);
          gfc_expand_constructor (e);
        }

      /* This provides the opportunity for the length of constructors with character
        valued function elements to propogate the string length to the expression.  */
      if (e->ts.type == BT_CHARACTER)
        gfc_resolve_character_array_constructor (e);

      break;

    case EXPR_STRUCTURE:
      t = resolve_ref (e);
      if (t == FAILURE)
        break;

      t = resolve_structure_cons (e);
      if (t == FAILURE)
        break;

      t = gfc_simplify_expr (e, 0);
      break;

    default:
      gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
    }

  return t;
}


/* Resolve an expression from an iterator.  They must be scalar and have
   INTEGER or (optionally) REAL type.  */

static try
gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
                           const char * name_msgid)
{
  if (gfc_resolve_expr (expr) == FAILURE)
    return FAILURE;

  if (expr->rank != 0)
    {
      gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
      return FAILURE;
    }

  if (!(expr->ts.type == BT_INTEGER
        || (expr->ts.type == BT_REAL && real_ok)))
    {
      if (real_ok)
        gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
                   &expr->where);
      else
        gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
      return FAILURE;
    }
  return SUCCESS;
}


/* Resolve the expressions in an iterator structure.  If REAL_OK is
   false allow only INTEGER type iterators, otherwise allow REAL types.  */

try
gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
{

  if (iter->var->ts.type == BT_REAL)
    gfc_notify_std (GFC_STD_F95_DEL,
                    "Obsolete: REAL DO loop iterator at %L",
                    &iter->var->where);

  if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
      == FAILURE)
    return FAILURE;

  if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
    {
      gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
                 &iter->var->where);
      return FAILURE;
    }

  if (gfc_resolve_iterator_expr (iter->start, real_ok,
                                 "Start expression in DO loop") == FAILURE)
    return FAILURE;

  if (gfc_resolve_iterator_expr (iter->end, real_ok,
                                 "End expression in DO loop") == FAILURE)
    return FAILURE;

  if (gfc_resolve_iterator_expr (iter->step, real_ok,
                                 "Step expression in DO loop") == FAILURE)
    return FAILURE;

  if (iter->step->expr_type == EXPR_CONSTANT)
    {
      if ((iter->step->ts.type == BT_INTEGER
           && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
          || (iter->step->ts.type == BT_REAL
              && mpfr_sgn (iter->step->value.real) == 0))
        {
          gfc_error ("Step expression in DO loop at %L cannot be zero",
                     &iter->step->where);
          return FAILURE;
        }
    }

  /* Convert start, end, and step to the same type as var.  */
  if (iter->start->ts.kind != iter->var->ts.kind
      || iter->start->ts.type != iter->var->ts.type)
    gfc_convert_type (iter->start, &iter->var->ts, 2);

  if (iter->end->ts.kind != iter->var->ts.kind
      || iter->end->ts.type != iter->var->ts.type)
    gfc_convert_type (iter->end, &iter->var->ts, 2);

  if (iter->step->ts.kind != iter->var->ts.kind
      || iter->step->ts.type != iter->var->ts.type)
    gfc_convert_type (iter->step, &iter->var->ts, 2);

  return SUCCESS;
}


/* Resolve a list of FORALL iterators.  The FORALL index-name is constrained
   to be a scalar INTEGER variable.  The subscripts and stride are scalar
   INTEGERs, and if stride is a constant it must be nonzero.  */

static void
resolve_forall_iterators (gfc_forall_iterator * iter)
{

  while (iter)
    {
      if (gfc_resolve_expr (iter->var) == SUCCESS
          && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
        gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
                   &iter->var->where);

      if (gfc_resolve_expr (iter->start) == SUCCESS
          && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
        gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
                   &iter->start->where);
      if (iter->var->ts.kind != iter->start->ts.kind)
        gfc_convert_type (iter->start, &iter->var->ts, 2);

      if (gfc_resolve_expr (iter->end) == SUCCESS
          && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
        gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
                   &iter->end->where);
      if (iter->var->ts.kind != iter->end->ts.kind)
        gfc_convert_type (iter->end, &iter->var->ts, 2);

      if (gfc_resolve_expr (iter->stride) == SUCCESS)
        {
          if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
            gfc_error ("FORALL stride expression at %L must be a scalar %s",
                        &iter->stride->where, "INTEGER");

          if (iter->stride->expr_type == EXPR_CONSTANT
              && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
            gfc_error ("FORALL stride expression at %L cannot be zero",
                       &iter->stride->where);
        }
      if (iter->var->ts.kind != iter->stride->ts.kind)
        gfc_convert_type (iter->stride, &iter->var->ts, 2);

      iter = iter->next;
    }
}


/* Given a pointer to a symbol that is a derived type, see if any components
   have the POINTER attribute.  The search is recursive if necessary.
   Returns zero if no pointer components are found, nonzero otherwise.  */

static int
derived_pointer (gfc_symbol * sym)
{
  gfc_component *c;

  for (c = sym->components; c; c = c->next)
    {
      if (c->pointer)
        return 1;

      if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
        return 1;
    }

  return 0;
}


/* Given a pointer to a symbol that is a derived type, see if it's
   inaccessible, i.e. if it's defined in another module and the components are
   PRIVATE.  The search is recursive if necessary.  Returns zero if no
   inaccessible components are found, nonzero otherwise.  */

static int
derived_inaccessible (gfc_symbol *sym)
{
  gfc_component *c;

  if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
    return 1;

  for (c = sym->components; c; c = c->next)
    {
        if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
          return 1;
    }

  return 0;
}


/* Resolve the argument of a deallocate expression.  The expression must be
   a pointer or a full array.  */

static try
resolve_deallocate_expr (gfc_expr * e)
{
  symbol_attribute attr;
  int allocatable;
  gfc_ref *ref;

  if (gfc_resolve_expr (e) == FAILURE)
    return FAILURE;

  attr = gfc_expr_attr (e);
  if (attr.pointer)
    return SUCCESS;

  if (e->expr_type != EXPR_VARIABLE)
    goto bad;

  allocatable = e->symtree->n.sym->attr.allocatable;
  for (ref = e->ref; ref; ref = ref->next)
    switch (ref->type)
      {
      case REF_ARRAY:
        if (ref->u.ar.type != AR_FULL)
          allocatable = 0;
        break;

      case REF_COMPONENT:
        allocatable = (ref->u.c.component->as != NULL
                       && ref->u.c.component->as->type == AS_DEFERRED);
        break;

      case REF_SUBSTRING:
        allocatable = 0;
        break;
      }

  if (allocatable == 0)
    {
    bad:
      gfc_error ("Expression in DEALLOCATE statement at %L must be "
                 "ALLOCATABLE or a POINTER", &e->where);
    }

  if (e->symtree->n.sym->attr.intent == INTENT_IN)
    {
      gfc_error ("Can't deallocate INTENT(IN) variable '%s' at %L",
                 e->symtree->n.sym->name, &e->where);
      return FAILURE;
    }

  return SUCCESS;
}

/* Returns true if the expression e contains a reference the symbol sym.  */
static bool
find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
{
  gfc_actual_arglist *arg;
  gfc_ref *ref;
  int i;
  bool rv = false;

  if (e == NULL)
    return rv;

  switch (e->expr_type)
    {
    case EXPR_FUNCTION:
      for (arg = e->value.function.actual; arg; arg = arg->next)
        rv = rv || find_sym_in_expr (sym, arg->expr);
      break;

    /* If the variable is not the same as the dependent, 'sym', and
       it is not marked as being declared and it is in the same
       namespace as 'sym', add it to the local declarations.  */
    case EXPR_VARIABLE:
      if (sym == e->symtree->n.sym)
        return true;
      break;

    case EXPR_OP:
      rv = rv || find_sym_in_expr (sym, e->value.op.op1);
      rv = rv || find_sym_in_expr (sym, e->value.op.op2);
      break;

    default:
      break;
    }

  if (e->ref)
    {
      for (ref = e->ref; ref; ref = ref->next)
        {
          switch (ref->type)
            {
            case REF_ARRAY:
              for (i = 0; i < ref->u.ar.dimen; i++)
                {
                  rv = rv || find_sym_in_expr (sym, ref->u.ar.start[i]);
                  rv = rv || find_sym_in_expr (sym, ref->u.ar.end[i]);
                  rv = rv || find_sym_in_expr (sym, ref->u.ar.stride[i]);
                }
              break;

            case REF_SUBSTRING:
              rv = rv || find_sym_in_expr (sym, ref->u.ss.start);
              rv = rv || find_sym_in_expr (sym, ref->u.ss.end);
              break;

            case REF_COMPONENT:
              if (ref->u.c.component->ts.type == BT_CHARACTER
                    && ref->u.c.component->ts.cl->length->expr_type
                                                != EXPR_CONSTANT)
                rv = rv || find_sym_in_expr (sym, ref->u.c.component->ts.cl->length);

              if (ref->u.c.component->as)
                for (i = 0; i < ref->u.c.component->as->rank; i++)
                  {
                    rv = rv || find_sym_in_expr (sym, ref->u.c.component->as->lower[i]);
                    rv = rv || find_sym_in_expr (sym, ref->u.c.component->as->upper[i]);
                  }
              break;
            }
        }
    }
  return rv;
}


/* Given the expression node e for an allocatable/pointer of derived type to be
   allocated, get the expression node to be initialized afterwards (needed for
   derived types with default initializers, and derived types with allocatable
   components that need nullification.)  */

static gfc_expr *
expr_to_initialize (gfc_expr * e)
{
  gfc_expr *result;
  gfc_ref *ref;
  int i;

  result = gfc_copy_expr (e);

  /* Change the last array reference from AR_ELEMENT to AR_FULL.  */
  for (ref = result->ref; ref; ref = ref->next)
    if (ref->type == REF_ARRAY && ref->next == NULL)
      {
        ref->u.ar.type = AR_FULL;

        for (i = 0; i < ref->u.ar.dimen; i++)
          ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;

        result->rank = ref->u.ar.dimen;
        break;
      }

  return result;
}


/* Resolve the expression in an ALLOCATE statement, doing the additional
   checks to see whether the expression is OK or not.  The expression must
   have a trailing array reference that gives the size of the array.  */

static try
resolve_allocate_expr (gfc_expr * e, gfc_code * code)
{
  int i, pointer, allocatable, dimension;
  symbol_attribute attr;
  gfc_ref *ref, *ref2;
  gfc_array_ref *ar;
  gfc_code *init_st;
  gfc_expr *init_e;
  gfc_symbol *sym;
  gfc_alloc *a;

  if (gfc_resolve_expr (e) == FAILURE)
    return FAILURE;

  if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
    sym = code->expr->symtree->n.sym;
  else
    sym = NULL;

  /* Make sure the expression is allocatable or a pointer.  If it is
     pointer, the next-to-last reference must be a pointer.  */

  ref2 = NULL;

  if (e->expr_type != EXPR_VARIABLE)
    {
      allocatable = 0;

      attr = gfc_expr_attr (e);
      pointer = attr.pointer;
      dimension = attr.dimension;

    }
  else
    {
      allocatable = e->symtree->n.sym->attr.allocatable;
      pointer = e->symtree->n.sym->attr.pointer;
      dimension = e->symtree->n.sym->attr.dimension;

      if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
        {
          gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
                     "not be allocated in the same statement at %L",
                      sym->name, &e->where);
          return FAILURE;
        }

      for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
        switch (ref->type)
          {
          case REF_ARRAY:
            if (ref->next != NULL)
              pointer = 0;
            break;

          case REF_COMPONENT:
            allocatable = (ref->u.c.component->as != NULL
                           && ref->u.c.component->as->type == AS_DEFERRED);

            pointer = ref->u.c.component->pointer;
            dimension = ref->u.c.component->dimension;
            break;

          case REF_SUBSTRING:
            allocatable = 0;
            pointer = 0;
            break;
          }
    }

  if (allocatable == 0 && pointer == 0)
    {
      gfc_error ("Expression in ALLOCATE statement at %L must be "
                 "ALLOCATABLE or a POINTER", &e->where);
      return FAILURE;
    }

  if (e->symtree->n.sym->attr.intent == INTENT_IN)
    {
      gfc_error ("Can't allocate INTENT(IN) variable '%s' at %L",
                 e->symtree->n.sym->name, &e->where);
      return FAILURE;
    }

  /* Add default initializer for those derived types that need them.  */
  if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
    {
        init_st = gfc_get_code ();
        init_st->loc = code->loc;
        init_st->op = EXEC_INIT_ASSIGN;
        init_st->expr = expr_to_initialize (e);
        init_st->expr2 = init_e;
        init_st->next = code->next;
        code->next = init_st;