gcc/fortran:

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

/* Perform type resolution on the various stuctures.
   Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007
   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 "obstack.h"
#include "bitmap.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 keep track of the nesting of blocks as we move through the
   code.  See resolve_branch() and resolve_code().  */

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

  /* This bitmap keeps track of the targets valid for a branch from
     inside this block.  */
  bitmap reachable_labels;
}
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;

/* We use bitmaps to determine if a branch target is valid.  */
static bitmap_obstack labels_obstack;

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

          if (sym->attr.function
                && sym->ts.type == BT_UNKNOWN
                && sym->attr.intrinsic)
            {
              gfc_intrinsic_sym *isym;
              isym = gfc_find_function (sym->name);
              if (isym == NULL || !isym->specific)
                {
                  gfc_error ("Unable to find a specific INTRINSIC procedure "
                             "for the reference '%s' at %L", sym->name,
                             &sym->declared_at);
                }
              sym->ts = isym->ts;
            }

          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) && !sym->attr.pointer
          && sym->attr.flavor != FL_PROCEDURE)
        {
          if (proc->attr.function && 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.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->ts.type == BT_UNKNOWN)
    {
      t = gfc_set_default_type (sym->result, 0, ns);

      if (t == FAILURE && !sym->result->attr.untyped)
        {
          if (sym->result == sym)
            gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
                       sym->name, &sym->declared_at);
          else
            gfc_error ("Result '%s' of contained function '%s' at %L has "
                       "no IMPLICIT type", sym->result->name, sym->name,
                       &sym->result->declared_at);
          sym->result->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->result->ts.type == BT_CHARACTER)
    {
      gfc_charlen *cl = sym->result->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;
    }
}


/* Flag the arguments that are not present in all entries.  */

static void
check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
{
  gfc_formal_arglist *f, *head;
  head = new_args;

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

      for (new_args = head; new_args; new_args = new_args->next)
        {
          if (new_args->sym == f->sym)
            break;
        }

      if (new_args)
        continue;

      f->sym->attr.not_always_present = 1;
    }
}


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

  /* Check the master formal arguments for any that are not
     present in all entry points.  */
  for (el = ns->entries; el; el = el->next)
    check_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 common blocks.  */
static void
resolve_common_blocks (gfc_symtree *common_root)
{
   gfc_symtree *symtree;
   gfc_symbol *sym;

   if (common_root == NULL)
     return;

   for (symtree = common_root; symtree->left; symtree = symtree->left);

   for (; symtree; symtree = symtree->right)
     {
        gfc_find_symbol (symtree->name, gfc_current_ns, 0, &sym);
        if (sym == NULL)
          continue;

        if (sym->attr.flavor == FL_PARAMETER)
          {
            gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
                       sym->name, &symtree->n.common->where,
                       &sym->declared_at);
          }

        if (sym->attr.intrinsic)
          {
            gfc_error ("COMMON block '%s' at %L is also an intrinsic "
                       "procedure", sym->name,
                       &symtree->n.common->where);
          }
        else if (sym->attr.result
                 ||(sym->attr.function && gfc_current_ns->proc_name == sym))
          {
            gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' "
                            "at %L that is also a function result", sym->name,
                            &symtree->n.common->where);
          }
        else if (sym->attr.flavor == FL_PROCEDURE
                && sym->attr.proc != PROC_INTERNAL
                && sym->attr.proc != PROC_ST_FUNCTION)
          {
            gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' "
                            "at %L that is also a global procedure", sym->name,
                            &symtree->n.common->where);
          }
     }
}


/* 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, procedure_type ptype)
{
  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;
          goto argument_list;
        }

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

          /* Check if a generic interface has a specific procedure
            with the same name before emitting an error.  */
          if (sym->attr.generic)
            {
              gfc_interface *p;
              for (p = sym->generic; p; p = p->next)
                if (strcmp (sym->name, p->sym->name) == 0)
                  {
                    e->symtree = gfc_find_symtree
                                           (p->sym->ns->sym_root, sym->name);
                    sym = p->sym;
                    break;
                  }

              if (p == NULL || e->symtree == NULL)
                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;

          /* If all else fails, see if we have a specific intrinsic.  */
          if (sym->attr.function
              && sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
            {
              gfc_intrinsic_sym *isym;
              isym = gfc_find_function (sym->name);
              if (isym == NULL || !isym->specific)
                {
                  gfc_error ("Unable to find a specific INTRINSIC procedure "
                             "for the reference '%s' at %L", sym->name,
                             &e->where);
                }
              sym->ts = isym->ts;
            }
          goto argument_list;
        }

      /* 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)
        {
          goto argument_list;
        }

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

      /* Expressions are assigned a default ts.type of BT_PROCEDURE in
         primary.c (match_actual_arg). If above code determines that it
         is a  variable instead, it needs to be resolved as it was not
         done at the beginning of this function.  */
      if (gfc_resolve_expr (e) != SUCCESS)
        return FAILURE;

    argument_list:
      /* Check argument list functions %VAL, %LOC and %REF.  There is
         nothing to do for %REF.  */
      if (arg->name && arg->name[0] == '%')
        {
          if (strncmp ("%VAL", arg->name, 4) == 0)
            {
              if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
                {
                  gfc_error ("By-value argument at %L is not of numeric "
                             "type", &e->where);
                  return FAILURE;
                }

              if (e->rank)
                {
                  gfc_error ("By-value argument at %L cannot be an array or "
                             "an array section", &e->where);
                return FAILURE;
                }

              /* Intrinsics are still PROC_UNKNOWN here.  However,
                 since same file external procedures are not resolvable
                 in gfortran, it is a good deal easier to leave them to
                 intrinsic.c.  */
              if (ptype != PROC_UNKNOWN
                  && ptype != PROC_DUMMY
                  && ptype != PROC_EXTERNAL
                  && ptype != PROC_MODULE)
                {
                  gfc_error ("By-value argument at %L is not allowed "
                             "in this context", &e->where);
                  return FAILURE;
                }
            }

          /* Statement functions have already been excluded above.  */
          else if (strncmp ("%LOC", arg->name, 4) == 0
                   && e->ts.type == BT_PROCEDURE)
            {
              if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
                {
                  gfc_error ("Passing internal procedure at %L by location "
                             "not allowed", &e->where);
                  return FAILURE;
                }
            }
        }
    }

  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->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.  See if the reference is to an intrinsic
     that possesses a matching interface.  14.1.2.4  */
  if (sym && !gfc_intrinsic_name (sym->name, 0))
    {
      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;
}


/* Return true, if the symbol is an external procedure.  */
static bool
is_external_proc (gfc_symbol *sym)
{
  if (!sym->attr.dummy && !sym->attr.contained
        && !(sym->attr.intrinsic
              || gfc_intrinsic_name (sym->name, sym->attr.subroutine))
        && sym->attr.proc != PROC_ST_FUNCTION
        && !sym->attr.use_assoc
        && sym->name)
    return true;
  else
    return false;
}


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

  *name = NULL;

  if (e->symtree != NULL
        && e->symtree->n.sym != NULL
        && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
    return 1;

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


static try
is_scalar_expr_ptr (gfc_expr *expr)
{
  try retval = SUCCESS;
  gfc_ref *ref;
  int start;
  int end;

  /* See if we have a gfc_ref, which means we have a substring, array
     reference, or a component.  */
  if (expr->ref != NULL)
    {
      ref = expr->ref;
      while (ref->next != NULL)
        ref = ref->next;

      switch (ref->type)
        {
        case REF_SUBSTRING:
          if (ref->u.ss.length != NULL 
              && ref->u.ss.length->length != NULL
              && ref->u.ss.start
              && ref->u.ss.start->expr_type == EXPR_CONSTANT 
              && ref->u.ss.end
              && ref->u.ss.end->expr_type == EXPR_CONSTANT)
            {
              start = (int) mpz_get_si (ref->u.ss.start->value.integer);
              end = (int) mpz_get_si (ref->u.ss.end->value.integer);
              if (end - start + 1 != 1)
                retval = FAILURE;
            }
          else
            retval = FAILURE;
          break;
        case REF_ARRAY:
          if (ref->u.ar.type == AR_ELEMENT)
            retval = SUCCESS;
          else if (ref->u.ar.type == AR_FULL)
            {
              /* The user can give a full array if the array is of size 1.  */
              if (ref->u.ar.as != NULL
                  && ref->u.ar.as->rank == 1
                  && ref->u.ar.as->type == AS_EXPLICIT
                  && ref->u.ar.as->lower[0] != NULL
                  && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
                  && ref->u.ar.as->upper[0] != NULL
                  && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
                {
                  /* If we have a character string, we need to check if
                     its length is one.  */
                  if (expr->ts.type == BT_CHARACTER)
                    {
                      if (expr->ts.cl == NULL
                          || expr->ts.cl->length == NULL
                          || mpz_cmp_si (expr->ts.cl->length->value.integer, 1)
                          != 0)
                        retval = FAILURE;
                    }
                  else
                    {
                  /* We have constant lower and upper bounds.  If the
                     difference between is 1, it can be considered a
                     scalar.  */
                  start = (int) mpz_get_si
                                (ref->u.ar.as->lower[0]->value.integer);
                  end = (int) mpz_get_si
                              (ref->u.ar.as->upper[0]->value.integer);
                  if (end - start + 1 != 1)
                    retval = FAILURE;
                }
                }
              else
                retval = FAILURE;
            }
          else
            retval = FAILURE;
          break;
        default:
          retval = SUCCESS;
          break;
        }
    }
  else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
    {
      /* Character string.  Make sure it's of length 1.  */
      if (expr->ts.cl == NULL
          || expr->ts.cl->length == NULL
          || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0)
        retval = FAILURE;
    }
  else if (expr->rank != 0)
    retval = FAILURE;

  return retval;
}


/* Match one of the iso_c_binding functions (c_associated or c_loc)
   and, in the case of c_associated, set the binding label based on
   the arguments.  */

static try
gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
                          gfc_symbol **new_sym)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
  int optional_arg = 0;
  try retval = SUCCESS;
  gfc_symbol *args_sym;

  if (args->expr->expr_type == EXPR_CONSTANT
      || args->expr->expr_type == EXPR_OP
      || args->expr->expr_type == EXPR_NULL)
    {
      gfc_error ("Argument to '%s' at %L is not a variable",
                 sym->name, &(args->expr->where));
      return FAILURE;
    }

  args_sym = args->expr->symtree->n.sym;
   
  if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
    {
      /* If the user gave two args then they are providing something for
         the optional arg (the second cptr).  Therefore, set the name and
         binding label to the c_associated for two cptrs.  Otherwise,
         set c_associated to expect one cptr.  */
      if (args->next)
        {
          /* two args.  */
          sprintf (name, "%s_2", sym->name);
          sprintf (binding_label, "%s_2", sym->binding_label);
          optional_arg = 1;
        }
      else
        {
          /* one arg.  */
          sprintf (name, "%s_1", sym->name);
          sprintf (binding_label, "%s_1", sym->binding_label);
          optional_arg = 0;
        }

      /* Get a new symbol for the version of c_associated that
         will get called.  */
      *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
    }
  else if (sym->intmod_sym_id == ISOCBINDING_LOC
           || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
    {
      sprintf (name, "%s", sym->name);
      sprintf (binding_label, "%s", sym->binding_label);

      /* Error check the call.  */
      if (args->next != NULL)
        {
          gfc_error_now ("More actual than formal arguments in '%s' "
                         "call at %L", name, &(args->expr->where));
          retval = FAILURE;
        }
      else if (sym->intmod_sym_id == ISOCBINDING_LOC)
        {
          /* Make sure we have either the target or pointer attribute.  */
          if (!(args->expr->symtree->n.sym->attr.target)
              && !(args->expr->symtree->n.sym->attr.pointer))
            {
              gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
                             "a TARGET or an associated pointer",
                             args->expr->symtree->n.sym->name,
                             sym->name, &(args->expr->where));
              retval = FAILURE;
            }

          /* See if we have interoperable type and type param.  */
          if (verify_c_interop (&(args->expr->symtree->n.sym->ts),
                                args->expr->symtree->n.sym->name,
                                &(args->expr->where)) == SUCCESS
              || gfc_check_any_c_kind (&(args_sym->ts)) == SUCCESS)
            {
              if (args_sym->attr.target == 1)
                {
                  /* Case 1a, section 15.1.2.5, J3/04-007: variable that
                     has the target attribute and is interoperable.  */
                  /* Case 1b, section 15.1.2.5, J3/04-007: allocated
                     allocatable variable that has the TARGET attribute and
                     is not an array of zero size.  */
                  if (args_sym->attr.allocatable == 1)
                    {
                      if (args_sym->attr.dimension != 0 
                          && (args_sym->as && args_sym->as->rank == 0))
                        {
                          gfc_error_now ("Allocatable variable '%s' used as a "
                                         "parameter to '%s' at %L must not be "
                                         "an array of zero size",
                                         args_sym->name, sym->name,
                                         &(args->expr->where));
                          retval = FAILURE;
                        }
                    }
                  else
                    {
                      /* Make sure it's not a character string.  Arrays of
                         any type should be ok if the variable is of a C
                         interoperable type.  */
                      if (args_sym->ts.type == BT_CHARACTER 
                          && is_scalar_expr_ptr (args->expr) != SUCCESS)
                        {
                          gfc_error_now ("CHARACTER argument '%s' to '%s' at "
                                         "%L must have a length of 1",
                                         args_sym->name, sym->name,
                                         &(args->expr->where));
                          retval = FAILURE;
                        }
                    }
                }
              else if (args_sym->attr.pointer == 1
                       && is_scalar_expr_ptr (args->expr) != SUCCESS)
                {
                  /* Case 1c, section 15.1.2.5, J3/04-007: an associated
                     scalar pointer.  */
                  gfc_error_now ("Argument '%s' to '%s' at %L must be an "
                                 "associated scalar POINTER", args_sym->name,
                                 sym->name, &(args->expr->where));
                  retval = FAILURE;
                }
            }
          else
            {
              /* The parameter is not required to be C interoperable.  If it
                 is not C interoperable, it must be a nonpolymorphic scalar
                 with no length type parameters.  It still must have either
                 the pointer or target attribute, and it can be
                 allocatable (but must be allocated when c_loc is called).  */
              if (args_sym->attr.dimension != 0
                  && is_scalar_expr_ptr (args->expr) != SUCCESS)
                {
                  gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
                                 "scalar", args_sym->name, sym->name,
                                 &(args->expr->where));
                  retval = FAILURE;
                }
              else if (args_sym->ts.type == BT_CHARACTER 
                       && args_sym->ts.cl != NULL)
                {
                  gfc_error_now ("CHARACTER parameter '%s' to '%s' at %L "
                                 "cannot have a length type parameter",
                                 args_sym->name, sym->name,
                                 &(args->expr->where));
                  retval = FAILURE;
                }
            }
        }
      else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
        {
          if (args->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE)
            {
              /* TODO: Update this error message to allow for procedure
                 pointers once they are implemented.  */
              gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
                             "procedure",
                             args->expr->symtree->n.sym->name, sym->name,
                             &(args->expr->where));
              retval = FAILURE;
            }
          else if (args->expr->symtree->n.sym->attr.is_c_interop != 1)
            {
              gfc_error_now ("Parameter '%s' to '%s' at %L must be C "
                             "interoperable",
                             args->expr->symtree->n.sym->name, sym->name,
                             &(args->expr->where));
              retval = FAILURE;
            }
        }
      
      /* for c_loc/c_funloc, the new symbol is the same as the old one */
      *new_sym = sym;
    }
  else
    {
      gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
                          "iso_c_binding function: '%s'!\n", sym->name);
    }

  return retval;
}


/* 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;
  procedure_type p = PROC_INTRINSIC;

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

  if (sym && sym->attr.flavor == FL_VARIABLE)
    {
      gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
      return FAILURE;
    }

  /* If the procedure is external, check for usage.  */
  if (sym && is_external_proc (sym))
    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 (expr->symtree && expr->symtree->n.sym)
    p = expr->symtree->n.sym->attr.proc;

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

  /* Need to setup the call to the correct c_associated, depending on
     the number of cptrs to user gives to compare.  */
  if (sym && sym->attr.is_iso_c == 1)
    {
      if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
          == FAILURE)
        return FAILURE;
      
      /* Get the symtree for the new symbol (resolved func).
         the old one will be freed later, when it's no longer used.  */
      gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
    }
  
  /* 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;
    }

#define GENERIC_ID expr->value.function.isym->id
  else if (expr->value.function.actual != NULL
           && expr->value.function.isym != NULL
           && GENERIC_ID != GFC_ISYM_LBOUND
           && GENERIC_ID != GFC_ISYM_LEN
           && GENERIC_ID != GFC_ISYM_LOC
           && 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 = GENERIC_ID == GFC_ISYM_UBOUND
                  || GENERIC_ID == GFC_ISYM_SIZE;

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

              if ((int)mpz_get_si (arg->next->expr->value.integer)
                        < arg->expr->rank)
                break;
            }

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

  need_full_assumed_size = temp;
  name = NULL;

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

  /* Make sure that the expression has a typespec that works.  */
  if (expr->ts.type == BT_UNKNOWN)
    {
      if (expr->symtree->n.sym->result
            && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
        expr->ts = expr->symtree->n.sym->result->ts;
    }

  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.  See if the reference is to an intrinsic
     that possesses a matching interface.  14.1.2.4  */
  sym = c->symtree->n.sym;

  if (!gfc_intrinsic_name (sym->name, 1))
    {
      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;
}


/* Set the name and binding label of the subroutine symbol in the call
   expression represented by 'c' to include the type and kind of the
   second parameter.  This function is for resolving the appropriate
   version of c_f_pointer() and c_f_procpointer().  For example, a
   call to c_f_pointer() for a default integer pointer could have a
   name of c_f_pointer_i4.  If no second arg exists, which is an error
   for these two functions, it defaults to the generic symbol's name
   and binding label.  */

static void
set_name_and_label (gfc_code *c, gfc_symbol *sym,
                    char *name, char *binding_label)
{
  gfc_expr *arg = NULL;
  char type;
  int kind;

  /* The second arg of c_f_pointer and c_f_procpointer determines
     the type and kind for the procedure name.  */
  arg = c->ext.actual->next->expr;

  if (arg != NULL)
    {
      /* Set up the name to have the given symbol's name,
         plus the type and kind.  */
      /* a derived type is marked with the type letter 'u' */
      if (arg->ts.type == BT_DERIVED)
        {
          type = 'd';
          kind = 0; /* set the kind as 0 for now */
        }
      else
        {
          type = gfc_type_letter (arg->ts.type);
          kind = arg->ts.kind;
        }
      sprintf (name, "%s_%c%d", sym->name, type, kind);
      /* Set up the binding label as the given symbol's label plus
         the type and kind.  */
      sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
    }
  else
    {
      /* If the second arg is missing, set the name and label as
         was, cause it should at least be found, and the missing
         arg error will be caught by compare_parameters().  */
      sprintf (name, "%s", sym->name);
      sprintf (binding_label, "%s", sym->binding_label);
    }
   
  return;
}


/* Resolve a generic version of the iso_c_binding procedure given
   (sym) to the specific one based on the type and kind of the
   argument(s).  Currently, this function resolves c_f_pointer() and
   c_f_procpointer based on the type and kind of the second argument
   (FPTR).  Other iso_c_binding procedures aren't specially handled.
   Upon successfully exiting, c->resolved_sym will hold the resolved
   symbol.  Returns MATCH_ERROR if an error occurred; MATCH_YES
   otherwise.  */

match
gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
{
  gfc_symbol *new_sym;
  /* this is fine, since we know the names won't use the max */
  char name[GFC_MAX_SYMBOL_LEN + 1];
  char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
  /* default to success; will override if find error */
  match m = MATCH_YES;
  gfc_symbol *tmp_sym;

  if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
      (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
    {
      set_name_and_label (c, sym, name, binding_label);
      
      if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
        {
          if (c->ext.actual != NULL && c->ext.actual->next != NULL)
            {
              /* Make sure we got a third arg.  The type/rank of it will
                 be checked later if it's there (gfc_procedure_use()).  */
              if (c->ext.actual->next->expr->rank != 0 &&
                  c->ext.actual->next->next == NULL)
                {
                  m = MATCH_ERROR;
                  gfc_error ("Missing SHAPE parameter for call to %s "
                             "at %L", sym->name, &(c->loc));
                }
              /* Make sure the param is a POINTER.  No need to make sure
                 it does not have INTENT(IN) since it is a POINTER.  */
              tmp_sym = c->ext.actual->next->expr->symtree->n.sym;
              if (tmp_sym != NULL && tmp_sym->attr.pointer != 1)
                {
                  gfc_error ("Argument '%s' to '%s' at %L "
                             "must have the POINTER attribute",
                             tmp_sym->name, sym->name, &(c->loc));
                  m = MATCH_ERROR;
                }
            }
        }
      
      if (m != MATCH_ERROR)
        {
          /* the 1 means to add the optional arg to formal list */
          new_sym = get_iso_c_sym (sym, name, binding_label, 1);
         
          /* for error reporting, say it's declared where the original was */
          new_sym->declared_at = sym->declared_at;
        }
    }
  else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
    {
      /* TODO: Figure out if this is even reacable; this part of the
         conditional may not be necessary.  */
      int num_args = 0;
      if (c->ext.actual->next == NULL)
        {
          /* The user did not give two args, so resolve to the version
             of c_associated expecting one arg.  */
          num_args = 1;
          /* get rid of the second arg */
          /* TODO!! Should free up the memory here!  */
          sym->formal->next = NULL;
        }
      else
        {
          num_args = 2;
        }

      new_sym = sym;
      sprintf (name, "%s_%d", sym->name, num_args);
      sprintf (binding_label, "%s_%d", sym->binding_label, num_args);
      sym->name = gfc_get_string (name);
      strcpy (sym->binding_label, binding_label);
    }
  else
    {
      /* no differences for c_loc or c_funloc */
      new_sym = sym;
    }

  /* set the resolved symbol */
  if (m != MATCH_ERROR)
    {
      gfc_procedure_use (new_sym, &c->ext.actual, &c->loc);
      c->resolved_sym = new_sym;
    }
  else
    c->resolved_sym = sym;
  
  return m;
}


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

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

  if(sym->attr.is_iso_c)
    {
      m = gfc_iso_c_sub_interface (c,sym);
      return 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;
  procedure_type ptype = PROC_INTRINSIC;

  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 external, check for usage.  */
  if (c->symtree && is_external_proc (c->symtree->n.sym))
    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 (c->symtree && c->symtree->n.sym)
    ptype = c->symtree->n.sym->attr.proc;

  if (resolve_actual_arglist (c->ext.actual, ptype) == 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];
  bool dual_locus_error;
  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;
  dual_locus_error = false;

  if ((op1 && op1->expr_type == EXPR_NULL)
      || (op2 && op2->expr_type == EXPR_NULL))
    {
      sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
      goto bad_op;
    }

  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_GT_OS:
    case INTRINSIC_GE:
    case INTRINSIC_GE_OS:
    case INTRINSIC_LT:
    case INTRINSIC_LT_OS:
    case INTRINSIC_LE:
    case INTRINSIC_LE_OS:
      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_EQ_OS:
    case INTRINSIC_NE:
    case INTRINSIC_NE_OS:
      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 (e->value.op.uop->operator == NULL)
        sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
      else 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_EQ_OS:
    case INTRINSIC_NE:
    case INTRINSIC_NE_OS:
    case INTRINSIC_GT:
    case INTRINSIC_GT_OS:
    case INTRINSIC_GE:
    case INTRINSIC_GE_OS:
    case INTRINSIC_LT:
    case INTRINSIC_LT_OS:
    case INTRINSIC_LE:
    case INTRINSIC_LE_OS:

      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
            {
              /* Allow higher level expressions to work.  */
              e->rank = 0;

              /* Try user-defined operators, and otherwise throw an error.  */
              dual_locus_error = true;
              sprintf (msg,
                       _("Inconsistent ranks for operator at %%L and %%L"));
              goto bad_op;
            }
        }

      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);
      /* Some calls do not succeed in simplification and return FAILURE
         even though there is no error; eg. variable references to
         PARAMETER arrays.  */
      if (!gfc_is_constant_expr (e))
        t = SUCCESS;
    }
  return t;

bad_op:

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

  if (dual_locus_error)
    gfc_error (msg, &op1->where, &op2->where);
  else
    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:
      {
#define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
#define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])

        comparison comp_start_end = compare_bound (AR_START, AR_END);

        /* Check for zero stride, which is not allowed.  */
        if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
          {
            gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
            return FAILURE;
          }

        /* if start == len || (stride > 0 && start < len)
                           || (stride < 0 && start > len),
           then the array section contains at least one element.  In this
           case, there is an out-of-bounds access if
           (start < lower || start > upper).  */
        if (compare_bound (AR_START, AR_END) == CMP_EQ
            || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
                 || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
            || (compare_bound_int (ar->stride[i], 0) == CMP_LT
                && comp_start_end == CMP_GT))
          {
            if (compare_bound (AR_START, as->lower[i]) == CMP_LT
                || compare_bound (AR_START, as->upper[i]) == CMP_GT)
              goto bound;
          }

        /* If we can compute the highest index of the array section,
           then it also has to be between lower and upper.  */
        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);