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

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

This file is part of GCC.

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

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

You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3.  If not see
<http://www.gnu.org/licenses/>.  */

#include "config.h"
#include "system.h"
#include "flags.h"
#include "gfortran.h"
#include "obstack.h"
#include "bitmap.h"
#include "arith.h"  /* For gfc_compare_expr().  */
#include "dependency.h"
#include "data.h"
#include "target-memory.h" /* for gfc_simplify_transfer */

/* 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;
  struct code_stack *prev;

  /* This bitmap keeps track of the targets valid for a branch from
     inside this block except for END {IF|SELECT}s of enclosing
     blocks.  */
  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;
}

/* Is the symbol host associated?  */
static bool
is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns)
{
  for (ns = ns->parent; ns; ns = ns->parent)
    {      
      if (sym->ns == ns)
        return true;
    }

  return false;
}

/* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
   an ABSTRACT derived-type.  If where is not NULL, an error message with that
   locus is printed, optionally using name.  */

static gfc_try
resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
{
  if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract)
    {
      if (where)
        {
          if (name)
            gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
                       name, where, ts->u.derived->name);
          else
            gfc_error ("ABSTRACT type '%s' used at %L",
                       ts->u.derived->name, where);
        }

      return FAILURE;
    }

  return SUCCESS;
}


/* 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;
      sym->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 (proc->result)
            proc->result->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))
        {
          /* F2008, C1289.  */
          if (sym->attr.codimension)
            {
              gfc_error ("Coarray dummy argument '%s' at %L to elemental "
                         "procedure", sym->name, &sym->declared_at);
              continue;
            }

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

          if (sym->attr.flavor == FL_PROCEDURE)
            {
              gfc_error ("Dummy procedure '%s' not allowed in elemental "
                         "procedure '%s' at %L", sym->name, proc->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.u.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)
{
  gfc_try t;

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

  /* Try to find out of what the return type is.  */
  if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL)
    {
      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 if (!sym->result->attr.proc_pointer)
            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 and results of module
     procedures are not on this list, ergo, not permitted.  */

  if (sym->result->ts.type == BT_CHARACTER)
    {
      gfc_charlen *cl = sym->result->ts.u.cl;
      if (!cl || !cl->length)
        {
          /* See if this is a module-procedure and adapt error message
             accordingly.  */
          bool module_proc;
          gcc_assert (ns->parent && ns->parent->proc_name);
          module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);

          gfc_error ("Character-valued %s '%s' at %L must not be"
                     " assumed length",
                     module_proc ? _("module procedure")
                                 : _("internal function"),
                     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;

  /* Do the same for entries where the master is not a module
     procedure.  These are retained in the module namespace because
     of the module procedure declaration.  */
  for (el = el->next; el; el = el->next)
    if (el->sym->ns->proc_name->attr.flavor == FL_MODULE
          && el->sym->attr.mod_proc)
      el->sym->ns = ns;
  el = ns->entries;

  /* 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->name, 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->name, 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 && ns->entries->sym->result != el->sym->result
                      && gfc_compare_array_spec (as, fas) == 0)
            gfc_error ("Function %s at %L has entries with mismatched "
                       "array specifications", ns->entries->sym->name,
                       &ns->entries->sym->declared_at);
          /* The characteristics need to match and thus both need to have
             the same string length, i.e. both len=*, or both len=4.
             Having both len=<variable> is also possible, but difficult to
             check at compile time.  */
          else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl
                   && (((ts->u.cl->length && !fts->u.cl->length)
                        ||(!ts->u.cl->length && fts->u.cl->length))
                       || (ts->u.cl->length
                           && ts->u.cl->length->expr_type
                              != fts->u.cl->length->expr_type)
                       || (ts->u.cl->length
                           && ts->u.cl->length->expr_type == EXPR_CONSTANT
                           && mpz_cmp (ts->u.cl->length->value.integer,
                                       fts->u.cl->length->value.integer) != 0)))
            gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with "
                            "entries returning variables of different "
                            "string lengths", 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->name, 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;
}


static bool
has_default_initializer (gfc_symbol *der)
{
  gfc_component *c;

  gcc_assert (der->attr.flavor == FL_DERIVED);
  for (c = der->components; c; c = c->next)
    if ((c->ts.type != BT_DERIVED && c->initializer)
        || (c->ts.type == BT_DERIVED
            && (!c->attr.pointer && has_default_initializer (c->ts.u.derived))))
      break;

  return c != NULL;
}

/* Resolve common variables.  */
static void
resolve_common_vars (gfc_symbol *sym, bool named_common)
{
  gfc_symbol *csym = sym;

  for (; csym; csym = csym->common_next)
    {
      if (csym->value || csym->attr.data)
        {
          if (!csym->ns->is_block_data)
            gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
                            "but only in BLOCK DATA initialization is "
                            "allowed", csym->name, &csym->declared_at);
          else if (!named_common)
            gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
                            "in a blank COMMON but initialization is only "
                            "allowed in named common blocks", csym->name,
                            &csym->declared_at);
        }

      if (csym->ts.type != BT_DERIVED)
        continue;

      if (!(csym->ts.u.derived->attr.sequence
            || csym->ts.u.derived->attr.is_bind_c))
        gfc_error_now ("Derived type variable '%s' in COMMON at %L "
                       "has neither the SEQUENCE nor the BIND(C) "
                       "attribute", csym->name, &csym->declared_at);
      if (csym->ts.u.derived->attr.alloc_comp)
        gfc_error_now ("Derived type variable '%s' in COMMON at %L "
                       "has an ultimate component that is "
                       "allocatable", csym->name, &csym->declared_at);
      if (has_default_initializer (csym->ts.u.derived))
        gfc_error_now ("Derived type variable '%s' in COMMON at %L "
                       "may not have default initializer", csym->name,
                       &csym->declared_at);

      if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer)
        gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at);
    }
}

/* Resolve common blocks.  */
static void
resolve_common_blocks (gfc_symtree *common_root)
{
  gfc_symbol *sym;

  if (common_root == NULL)
    return;

  if (common_root->left)
    resolve_common_blocks (common_root->left);
  if (common_root->right)
    resolve_common_blocks (common_root->right);

  resolve_common_vars (common_root->n.common->head, true);

  gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
  if (sym == NULL)
    return;

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

  if (sym->attr.intrinsic)
    gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
               sym->name, &common_root->n.common->where);
  else if (sym->attr.result
           || gfc_is_function_return_value (sym, gfc_current_ns))
    gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L "
                    "that is also a function result", sym->name,
                    &common_root->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,
                    &common_root->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 gfc_try
resolve_structure_cons (gfc_expr *expr)
{
  gfc_constructor *cons;
  gfc_component *comp;
  gfc_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.u.derived->components;

  /* See if the user is trying to invoke a structure constructor for one of
     the iso_c_binding derived types.  */
  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
      && expr->ts.u.derived->ts.is_iso_c && cons
      && (cons->expr == NULL || cons->expr->expr_type != EXPR_NULL))
    {
      gfc_error ("Components of structure constructor '%s' at %L are PRIVATE",
                 expr->ts.u.derived->name, &(expr->where));
      return FAILURE;
    }

  /* Return if structure constructor is c_null_(fun)prt.  */
  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
      && expr->ts.u.derived->ts.is_iso_c && cons
      && cons->expr && cons->expr->expr_type == EXPR_NULL)
    return SUCCESS;

  for (; comp; comp = comp->next, cons = cons->next)
    {
      int rank;

      if (!cons->expr)
        continue;

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

      rank = comp->as ? comp->as->rank : 0;
      if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
          && (comp->attr.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, rank);
          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->attr.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 (cons->expr->expr_type == EXPR_NULL
          && !(comp->attr.pointer || comp->attr.allocatable
               || comp->attr.proc_pointer
               || (comp->ts.type == BT_CLASS
                   && (comp->ts.u.derived->components->attr.pointer
                       || comp->ts.u.derived->components->attr.allocatable))))
        {
          t = FAILURE;
          gfc_error ("The NULL in the derived type constructor at %L is "
                     "being applied to component '%s', which is neither "
                     "a POINTER nor ALLOCATABLE", &cons->expr->where,
                     comp->name);
        }

      if (!comp->attr.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);
        }

      /* F2003, C1272 (3).  */
      if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
          && gfc_impure_variable (cons->expr->symtree->n.sym))
        {
          t = FAILURE;
          gfc_error ("Invalid expression in the derived type constructor for pointer "
                     "component '%s' at %L in PURE procedure", comp->name,
                     &cons->expr->where);
        }
    }

  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
      || a.asynchronous || a.codimension)
    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);
  
  if (s != NULL)
    {
      if (s == sym)
        return 0;
      else
        return generic_sym (s);
    }

  return 0;
}


/* 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)
{
  if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
      return false;

  /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
     What should it be?  */
  if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
          && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
               && (e->ref->u.ar.type == AR_FULL))
    {
      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;
}


/* Check a generic procedure, passed as an actual argument, to see if
   there is a matching specific name.  If none, it is an error, and if
   more than one, the reference is ambiguous.  */
static int
count_specific_procs (gfc_expr *e)
{
  int n;
  gfc_interface *p;
  gfc_symbol *sym;
        
  n = 0;
  sym = e->symtree->n.sym;

  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);
        n++;
      }

  if (n > 1)
    gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
               &e->where);

  if (n == 0)
    gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
               "argument at %L", sym->name, &e->where);

  return n;
}


/* See if a call to sym could possibly be a not allowed RECURSION because of
   a missing RECURIVE declaration.  This means that either sym is the current
   context itself, or sym is the parent of a contained procedure calling its
   non-RECURSIVE containing procedure.
   This also works if sym is an ENTRY.  */

static bool
is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
{
  gfc_symbol* proc_sym;
  gfc_symbol* context_proc;
  gfc_namespace* real_context;

  if (sym->attr.flavor == FL_PROGRAM)
    return false;

  gcc_assert (sym->attr.flavor == FL_PROCEDURE);

  /* If we've got an ENTRY, find real procedure.  */
  if (sym->attr.entry && sym->ns->entries)
    proc_sym = sym->ns->entries->sym;
  else
    proc_sym = sym;

  /* If sym is RECURSIVE, all is well of course.  */
  if (proc_sym->attr.recursive || gfc_option.flag_recursive)
    return false;

  /* Find the context procedure's "real" symbol if it has entries.
     We look for a procedure symbol, so recurse on the parents if we don't
     find one (like in case of a BLOCK construct).  */
  for (real_context = context; ; real_context = real_context->parent)
    {
      /* We should find something, eventually!  */
      gcc_assert (real_context);

      context_proc = (real_context->entries ? real_context->entries->sym
                                            : real_context->proc_name);

      /* In some special cases, there may not be a proc_name, like for this
         invalid code:
         real(bad_kind()) function foo () ...
         when checking the call to bad_kind ().
         In these cases, we simply return here and assume that the
         call is ok.  */
      if (!context_proc)
        return false;

      if (context_proc->attr.flavor != FL_LABEL)
        break;
    }

  /* A call from sym's body to itself is recursion, of course.  */
  if (context_proc == proc_sym)
    return true;

  /* The same is true if context is a contained procedure and sym the
     containing one.  */
  if (context_proc->attr.contained)
    {
      gfc_symbol* parent_proc;

      gcc_assert (context->parent);
      parent_proc = (context->parent->entries ? context->parent->entries->sym
                                              : context->parent->proc_name);

      if (parent_proc == proc_sym)
        return true;
    }

  return false;
}


/* Resolve an intrinsic procedure: Set its function/subroutine attribute,
   its typespec and formal argument list.  */

static gfc_try
resolve_intrinsic (gfc_symbol *sym, locus *loc)
{
  gfc_intrinsic_sym* isym;
  const char* symstd;

  if (sym->formal)
    return SUCCESS;

  /* We already know this one is an intrinsic, so we don't call
     gfc_is_intrinsic for full checking but rather use gfc_find_function and
     gfc_find_subroutine directly to check whether it is a function or
     subroutine.  */

  if ((isym = gfc_find_function (sym->name)))
    {
      if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
          && !sym->attr.implicit_type)
        gfc_warning ("Type specified for intrinsic function '%s' at %L is"
                      " ignored", sym->name, &sym->declared_at);

      if (!sym->attr.function &&
          gfc_add_function (&sym->attr, sym->name, loc) == FAILURE)
        return FAILURE;

      sym->ts = isym->ts;
    }
  else if ((isym = gfc_find_subroutine (sym->name)))
    {
      if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
        {
          gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type"
                      " specifier", sym->name, &sym->declared_at);
          return FAILURE;
        }

      if (!sym->attr.subroutine &&
          gfc_add_subroutine (&sym->attr, sym->name, loc) == FAILURE)
        return FAILURE;
    }
  else
    {
      gfc_error ("'%s' declared INTRINSIC at %L does not exist", sym->name,
                 &sym->declared_at);
      return FAILURE;
    }

  gfc_copy_formal_args_intr (sym, isym);

  /* Check it is actually available in the standard settings.  */
  if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
      == FAILURE)
    {
      gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
                 " available in the current standard settings but %s.  Use"
                 " an appropriate -std=* option or enable -fall-intrinsics"
                 " in order to use it.",
                 sym->name, &sym->declared_at, symstd);
      return FAILURE;
    }

  return SUCCESS;
}


/* Resolve a procedure expression, like passing it to a called procedure or as
   RHS for a procedure pointer assignment.  */

static gfc_try
resolve_procedure_expression (gfc_expr* expr)
{
  gfc_symbol* sym;

  if (expr->expr_type != EXPR_VARIABLE)
    return SUCCESS;
  gcc_assert (expr->symtree);

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

  if (sym->attr.intrinsic)
    resolve_intrinsic (sym, &expr->where);

  if (sym->attr.flavor != FL_PROCEDURE
      || (sym->attr.function && sym->result == sym))
    return SUCCESS;

  /* A non-RECURSIVE procedure that is used as procedure expression within its
     own body is in danger of being called recursively.  */
  if (is_illegal_recursion (sym, gfc_current_ns))
    gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
                 " itself recursively.  Declare it RECURSIVE or use"
                 " -frecursive", sym->name, &expr->where);
  
  return SUCCESS;
}


/* 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 gfc_try
resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
                        bool no_formal_args)
{
  gfc_symbol *sym;
  gfc_symtree *parent_st;
  gfc_expr *e;
  int save_need_full_assumed_size;
  gfc_component *comp;
        
  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 (gfc_is_proc_ptr_comp (e, &comp))
        {
          e->ts = comp->ts;
          if (e->expr_type == EXPR_PPC)
            {
              if (comp->as != NULL)
                e->rank = comp->as->rank;
              e->expr_type = EXPR_FUNCTION;
            }
          if (gfc_resolve_expr (e) == FAILURE)                          
            return FAILURE; 
          goto argument_list;
        }

      if (e->expr_type == EXPR_VARIABLE
            && e->symtree->n.sym->attr.generic
            && no_formal_args
            && count_specific_procs (e) != 1)
        return FAILURE;

      if (e->ts.type != BT_PROCEDURE)
        {
          save_need_full_assumed_size = need_full_assumed_size;
          if (e->expr_type != EXPR_VARIABLE)
            need_full_assumed_size = 0;
          if (gfc_resolve_expr (e) != SUCCESS)
            return FAILURE;
          need_full_assumed_size = save_need_full_assumed_size;
          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_is_intrinsic (sym, sym->attr.subroutine, e->where))
            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 && count_specific_procs (e) != 1)
            return FAILURE;
          
          /* Just in case a specific was found for the expression.  */
          sym = e->symtree->n.sym;

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

          if (gfc_is_function_return_value (sym, sym->ns))
            goto got_variable;

          /* If all else fails, see if we have a specific intrinsic.  */
          if (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);
                  return FAILURE;
                }
              sym->ts = isym->ts;
              sym->attr.intrinsic = 1;
              sym->attr.function = 1;
            }

          if (gfc_resolve_expr (e) == FAILURE)
            return FAILURE;
          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)
        {
          if (gfc_resolve_expr (e) == FAILURE)
            return FAILURE;
          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.  */
      save_need_full_assumed_size = need_full_assumed_size;
      if (e->expr_type != EXPR_VARIABLE)
        need_full_assumed_size = 0;
      if (gfc_resolve_expr (e) != SUCCESS)
        return FAILURE;
      need_full_assumed_size = save_need_full_assumed_size;

    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 gfc_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)
    {
      arg0 = c->ext.actual;
      
      if (c->resolved_sym)
        esym = c->resolved_sym;
      else
        esym = c->symtree->n.sym;
      gcc_assert (esym);

      if (!esym->attr.elemental)
        return SUCCESS;
    }
  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;

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

  /* INTENT(OUT) is only allowed for subroutines; if any actual argument
     is an array, the intent inout/out variable needs to be also an array.  */
  if (rank > 0 && esym && expr == NULL)
    for (eformal = esym->formal, arg = arg0; arg && eformal;
         arg = arg->next, eformal = eformal->next)
      if ((eformal->sym->attr.intent == INTENT_OUT
           || eformal->sym->attr.intent == INTENT_INOUT)
          && arg->expr && arg->expr->rank == 0)
        {
          gfc_error ("Actual argument at %L for INTENT(%s) dummy '%s' of "
                     "ELEMENTAL subroutine '%s' is a scalar, but another "
                     "actual argument is an array", &arg->expr->where,
                     (eformal->sym->attr.intent == INTENT_OUT) ? "OUT"
                     : "INOUT", eformal->sym->name, esym->name);
          return FAILURE;
        }
  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,
                                         NOT_ELEMENTAL))
      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.

   In addition, for all but -std=legacy, the gsymbols are used to
   check the interfaces of external procedures from the same file.
   The namespace of the gsymbol is resolved and then, once this is
   done the interface is checked.  */


static bool
not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
{
  if (!gsym_ns->proc_name->attr.recursive)
    return true;

  if (sym->ns == gsym_ns)
    return false;

  if (sym->ns->parent && sym->ns->parent == gsym_ns)
    return false;

  return true;
}

static bool
not_entry_self_reference  (gfc_symbol *sym, gfc_namespace *gsym_ns)
{
  if (gsym_ns->entries)
    {
      gfc_entry_list *entry = gsym_ns->entries;

      for (; entry; entry = entry->next)
        {
          if (strcmp (sym->name, entry->sym->name) == 0)
            {
              if (strcmp (gsym_ns->proc_name->name,
                          sym->ns->proc_name->name) == 0)
                return false;

              if (sym->ns->parent
                  && strcmp (gsym_ns->proc_name->name,
                             sym->ns->parent->proc_name->name) == 0)
                return false;
            }
        }
    }
  return true;
}

static void
resolve_global_procedure (gfc_symbol *sym, locus *where,
                          gfc_actual_arglist **actual, int sub)
{
  gfc_gsymbol * gsym;
  gfc_namespace *ns;
  enum gfc_symbol_type type;

  type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;

  gsym = gfc_get_gsymbol (sym->name);

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

  if (gfc_option.flag_whole_file
        && sym->attr.if_source == IFSRC_UNKNOWN
        && gsym->type != GSYM_UNKNOWN
        && gsym->ns
        && gsym->ns->resolved != -1
        && gsym->ns->proc_name
        && not_in_recursive (sym, gsym->ns)
        && not_entry_self_reference (sym, gsym->ns))
    {
      /* Make sure that translation for the gsymbol occurs before
         the procedure currently being resolved.  */
      ns = gsym->ns->resolved ? NULL : gfc_global_ns_list;
      for (; ns && ns != gsym->ns; ns = ns->sibling)
        {
          if (ns->sibling == gsym->ns)
            {
              ns->sibling = gsym->ns->sibling;
              gsym->ns->sibling = gfc_global_ns_list;
              gfc_global_ns_list = gsym->ns;
              break;
            }
        }

      if (!gsym->ns->resolved)
        {
          gfc_dt_list *old_dt_list;

          /* Stash away derived types so that the backend_decls do not
             get mixed up.  */
          old_dt_list = gfc_derived_types;
          gfc_derived_types = NULL;

          gfc_resolve (gsym->ns);

          /* Store the new derived types with the global namespace.  */
          if (gfc_derived_types)
            gsym->ns->derived_types = gfc_derived_types;

          /* Restore the derived types of this namespace.  */
          gfc_derived_types = old_dt_list;
        }

      if (gsym->ns->proc_name->attr.function
            && gsym->ns->proc_name->as
            && gsym->ns->proc_name->as->rank
            && (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank))
        gfc_error ("The reference to function '%s' at %L either needs an "
                   "explicit INTERFACE or the rank is incorrect", sym->name,
                   where);
     
      /* Non-assumed length character functions.  */
      if (sym->attr.function && sym->ts.type == BT_CHARACTER
            && gsym->ns->proc_name->ts.u.cl != NULL
            && gsym->ns->proc_name->ts.u.cl->length != NULL)
        {
          gfc_charlen *cl = sym->ts.u.cl;

          if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN
                && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
            {
              gfc_error ("Nonconstant character-length function '%s' at %L "
                         "must have an explicit interface", sym->name,
                         &sym->declared_at);
            }
        }

      if (gfc_option.flag_whole_file == 1
            || ((gfc_option.warn_std & GFC_STD_LEGACY)
                  &&
               !(gfc_option.warn_std & GFC_STD_GNU)))
        gfc_errors_to_warnings (1);

      gfc_procedure_use (gsym->ns->proc_name, actual, where);

      gfc_errors_to_warnings (0);
    }

  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;

          gfc_set_sym_referenced (expr->value.function.esym);

          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 gfc_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_is_intrinsic (sym, 0, expr->where))
    {
      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);

  if (sym->result)
    expr->ts = sym->result->ts;
  else
    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 gfc_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 gfc_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_is_intrinsic (sym, 0, expr->where))
    {
      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->name, 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_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
        && sym->attr.proc != PROC_ST_FUNCTION
        && !sym->attr.use_assoc
        && sym->name)
    return true;

  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_stmt_function (gfc_expr *, gfc_symbol *);

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 pure_stmt_function (e, e->symtree->n.sym);

  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 bool
impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym,
                 int *f ATTRIBUTE_UNUSED)
{
  const char *name;

  /* Don't bother recursing into other statement functions
     since they will be checked individually for purity.  */
  if (e->expr_type != EXPR_FUNCTION
        || !e->symtree
        || e->symtree->n.sym == sym
        || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
    return false;

  return pure_function (e, &name) ? false : true;
}


static int
pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
{
  return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1;
}


static gfc_try
is_scalar_expr_ptr (gfc_expr *expr)
{
  gfc_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.u.cl == NULL
                          || expr->ts.u.cl->length == NULL
                          || mpz_cmp_si (expr->ts.u.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.u.cl == NULL
          || expr->ts.u.cl->length == NULL
          || mpz_cmp_si (expr->ts.u.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 gfc_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, is_pointer = 0;
  gfc_try retval = SUCCESS;
  gfc_symbol *args_sym;
  gfc_typespec *arg_ts;

  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;

  /* The typespec for the actual arg should be that stored in the expr
     and not necessarily that of the expr symbol (args_sym), because
     the actual expression could be a part-ref of the expr symbol.  */
  arg_ts = &(args->expr->ts);

  is_pointer = gfc_is_data_pointer (args->expr);
    
  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_sym->attr.target && !is_pointer)
            {
              gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
                             "a TARGET or an associated pointer",
                             args_sym->name,
                             sym->name, &(args->expr->where));
              retval = FAILURE;
            }

          /* See if we have interoperable type and type param.  */
          if (verify_c_interop (arg_ts) == SUCCESS
              || gfc_check_any_c_kind (arg_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
                    {
                      /* A non-allocatable target variable with C
                         interoperable type and type parameters must be
                         interoperable.  */
                      if (args_sym && args_sym->attr.dimension)
                        {
                          if (args_sym->as->type == AS_ASSUMED_SHAPE)
                            {
                              gfc_error ("Assumed-shape array '%s' at %L "
                                         "cannot be an argument to the "
                                         "procedure '%s' because "
                                         "it is not C interoperable",
                                         args_sym->name,
                                         &(args->expr->where), sym->name);
                              retval = FAILURE;
                            }
                          else if (args_sym->as->type == AS_DEFERRED)
                            {
                              gfc_error ("Deferred-shape array '%s' at %L "
                                         "cannot be an argument to the "
                                         "procedure '%s' because "
                                         "it is not C interoperable",
                                         args_sym->name,
                                         &(args->expr->where), sym->name);
                              retval = FAILURE;
                            }
                        }
                              
                      /* 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 (arg_ts->type == BT_CHARACTER)
                        if (arg_ts->u.cl != NULL
                            && (arg_ts->u.cl->length == NULL
                                || arg_ts->u.cl->length->expr_type
                                   != EXPR_CONSTANT
                                || mpz_cmp_si
                                    (arg_ts->u.cl->length->value.integer, 1)
                                   != 0)
                            && 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 (is_pointer
                       && 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->expr->rank != 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 (arg_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 (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
        {
          if (args_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_sym->name, sym->name,
                             &(args->expr->where));
              retval = FAILURE;
            }
          else if (args_sym->attr.is_bind_c != 1)
            {
              gfc_error_now ("Parameter '%s' to '%s' at %L must be "
                             "BIND(C)",
                             args_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 gfc_try
resolve_function (gfc_expr *expr)
{
  gfc_actual_arglist *arg;
  gfc_symbol *sym;
  const char *name;
  gfc_try t;
  int temp;
  procedure_type p = PROC_INTRINSIC;
  bool no_formal_args;

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

  /* If this is a procedure pointer component, it has already been resolved.  */
  if (gfc_is_proc_ptr_comp (expr, NULL))
    return SUCCESS;
  
  if (sym && sym->attr.intrinsic
      && resolve_intrinsic (sym, &expr->where) == FAILURE)
    return FAILURE;

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

  /* If this ia a deferred TBP with an abstract interface (which may
     of course be referenced), expr->value.function.esym will be set.  */
  if (sym && sym->attr.abstract && !expr->value.function.esym)
    {
      gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
                 sym->name, &expr->where);
      return 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 (expr->symtree && expr->symtree->n.sym)
    p = expr->symtree->n.sym->attr.proc;

  no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
  if (resolve_actual_arglist (expr->value.function.actual,
                              p, no_formal_args) == 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 the procedure is external, check for usage.  */
  if (sym && is_external_proc (sym))
    resolve_global_procedure (sym, &expr->where,
                              &expr->value.function.actual, 0);

  if (sym && sym->ts.type == BT_CHARACTER
      && sym->ts.u.cl
      && sym->ts.u.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.  */

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

              if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
                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;
      esym = expr->value.function.esym;

      if (is_illegal_recursion (esym, gfc_current_ns))
      {
        if (esym->attr.entry && esym->ns->entries)
          gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
                     " function '%s' is not RECURSIVE",
                     esym->name, &expr->where, esym->ns->entries->sym->name);
        else
          gfc_error ("Function '%s' at %L cannot be called recursively, as it"
                     " is not RECURSIVE", esym->name, &expr->where);

        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.u.cl->length);
    }

  if (t == SUCCESS
        && !((expr->value.function.esym
                && expr->value.function.esym->attr.elemental)
                        ||
             (expr->value.function.isym
                && expr->value.function.isym->elemental)))
    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->symtree->n.sym->result->attr.proc_pointer)
        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 gfc_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_is_intrinsic (sym, 1, c->loc))
    {
      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;
        }

      if (arg->ts.type == BT_CHARACTER)
        /* Kind info for character strings not needed.  */
        kind = 0;

      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;

  /* Make sure the actual arguments are in the necessary order (based on the 
     formal args) before resolving.  */
  gfc_procedure_use (sym, &c->ext.actual, &(c->loc));

  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 if the second arg has non-zero
                 rank.  We must also check that the type and rank are
                 correct since we short-circuit this check in
                 gfc_procedure_use() (called above to sort actual args).  */
              if (c->ext.actual->next->expr->rank != 0)
                {
                  if(c->ext.actual->next->next == NULL 
                     || c->ext.actual->next->next->expr == NULL)
                    {
                      m = MATCH_ERROR;
                      gfc_error ("Missing SHAPE parameter for call to %s "
                                 "at %L", sym->name, &(c->loc));
                    }
                  else if (c->ext.actual->next->next->expr->ts.type
                           != BT_INTEGER
                           || c->ext.actual->next->next->expr->rank != 1)
                    {
                      m = MATCH_ERROR;
                      gfc_error ("SHAPE parameter for call to %s at %L must "
                                 "be a rank 1 INTEGER array", sym->name,
                                 &(c->loc));
                    }
                }
            }
        }
      
      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
    {
      /* no differences for c_loc or c_funloc */
      new_sym = sym;
    }

  /* set the resolved symbol */
  if (m != MATCH_ERROR)
    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 gfc_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 gfc_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_is_intrinsic (sym, 1, c->loc))
    {
      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 gfc_try
resolve_call (gfc_code *c)
{
  gfc_try t;
  procedure_type ptype = PROC_INTRINSIC;
  gfc_symbol *csym, *sym;
  bool no_formal_args;

  csym = c->symtree ? c->symtree->n.sym : NULL;

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

  if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
    {
      gfc_symtree *st;
      gfc_find_sym_tree (csym->name, gfc_current_ns, 1, &st);
      sym = st ? st->n.sym : NULL;
      if (sym && csym != sym
              && sym->ns == gfc_current_ns
              && sym->attr.flavor == FL_PROCEDURE
              && sym->attr.contained)
        {
          sym->refs++;
          if (csym->attr.generic)
            c->symtree->n.sym = sym;
          else
            c->symtree = st;
          csym = c->symtree->n.sym;
        }
    }

  /* If this ia a deferred TBP with an abstract interface
     (which may of course be referenced), c->expr1 will be set.  */
  if (csym && csym->attr.abstract && !c->expr1)
    {
      gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
                 csym->name, &c->loc);
      return FAILURE;
    }

  /* Subroutines without the RECURSIVE attribution are not allowed to
   * call themselves.  */
  if (csym && is_illegal_recursion (csym, gfc_current_ns))
    {
      if (csym->attr.entry && csym->ns->entries)
        gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
                   " subroutine '%s' is not RECURSIVE",
                   csym->name, &c->loc, csym->ns->entries->sym->name);
      else
        gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
                   " is not RECURSIVE", csym->name, &c->loc);

      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 (csym)
    ptype = csym->attr.proc;

  no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
  if (resolve_actual_arglist (c->ext.actual, ptype,
                              no_formal_args) == FAILURE)
    return FAILURE;

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

  /* If external, check for usage.  */
  if (csym && is_external_proc (csym))
    resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);

  t = SUCCESS;
  if (c->resolved_sym == NULL)
    {
      c->resolved_isym = NULL;
      switch (procedure_kind (csym))
        {
        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 && !(c->resolved_sym && c->resolved_sym->attr.elemental))
    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 gfc_try
compare_shapes (gfc_expr *op1, gfc_expr *op2)
{
  gfc_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 gfc_try
resolve_operator (gfc_expr *e)
{
  gfc_expr *op1, *op2;
  char msg[200];
  bool dual_locus_error;
  gfc_try t;

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

  switch (e->value.op.op)
    {
    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.op)
    {
    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.op), 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, 1);
          break;
        }

      sprintf (msg,
               _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
               gfc_op2string (e->value.op.op), 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
          && op1->ts.kind == op2->ts.kind)
        {
          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.op), 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
          && op1->ts.kind == op2->ts.kind)
        {
          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, 1);

          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.op == INTRINSIC_EQ 
                  || e->value.op.op == INTRINSIC_EQ_OS)
                 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
      else
        sprintf (msg,
                 _("Operands of comparison operator '%s' at %%L are %s/%s"),
                 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
                 gfc_typename (&op2->ts));

      goto bad_op;

    case INTRINSIC_USER:
      if (e->value.op.uop->op == 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:
      e->ts = op1->ts;
      if (e->ts.type == BT_CHARACTER)
        e->ts.u.cl = op1->ts.u.cl;
      break;

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

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

  t = SUCCESS;

  switch (e->value.op.op)
    {
    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_PARENTHESES:
    case INTRINSIC_NOT:
    case INTRINSIC_UPLUS:
    case INTRINSIC_UMINUS:
      /* Simply copy arrayness attribute */
      e->rank = op1->rank;

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

      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; e.g. variable references to
         PARAMETER arrays.  */
      if (!gfc_is_constant_expr (e))
        t = SUCCESS;
    }
  return t;

bad_op:

  {
    bool real_error;
    if (gfc_extend_expr (e, &real_error) == SUCCESS)
      return SUCCESS;

    if (real_error)
      return FAILURE;
  }

  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 either of the types isn't INTEGER, we must have
     raised an error earlier.  */

  if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
    return CMP_UNKNOWN;

  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 gfc_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->dimen_type[i])
    {
    case DIMEN_VECTOR:
      break;

    case DIMEN_ELEMENT:
      if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
        {
          gfc_warning ("Array reference at %L is out of bounds "
                       "(%ld < %ld) in dimension %d", &ar->c_where[i],
                       mpz_get_si (ar->start[i]->value.integer),
                       mpz_get_si (as->lower[i]->value.integer), i+1);
          return SUCCESS;
        }
      if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
        {
          gfc_warning ("Array reference at %L is out of bounds "
                       "(%ld > %ld) in dimension %d", &ar->c_where[i],
                       mpz_get_si (ar->start[i]->value.integer),
                       mpz_get_si (as->upper[i]->value.integer), i+1);
          return SUCCESS;
        }

      break;

    case DIMEN_RANGE:
      {
#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)
              {
                gfc_warning ("Lower array reference at %L is out of bounds "
                       "(%ld < %ld) in dimension %d", &ar->c_where[i],
                       mpz_get_si (AR_START->value.integer),
                       mpz_get_si (as->lower[i]->value.integer), i+1);
                return SUCCESS;
              }
            if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
              {
                gfc_warning ("Lower array reference at %L is out of bounds "
                       "(%ld > %ld) in dimension %d", &ar->c_where[i],
                       mpz_get_si (AR_START->value.integer),
                       mpz_get_si (as->upper[i]->value.integer), i+1);
                return SUCCESS;
              }
          }

        /* 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)
              {
                gfc_warning ("Upper array reference at %L is out of bounds "
                       "(%ld < %ld) in dimension %d", &ar->c_where[i],
                       mpz_get_si (last_value),
                       mpz_get_si (as->lower[i]->value.integer), i+1);
                mpz_clear (last_value);
                return SUCCESS;
              }
            if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
              {
                gfc_warning ("Upper array reference at %L is out of bounds "
                       "(%ld > %ld) in dimension %d", &ar->c_where[i],
                       mpz_get_si (last_value),
                       mpz_get_si (as->upper[i]->value.integer), i+1);
                mpz_clear (last_value);
                return SUCCESS;
              }
          }
        mpz_clear (last_value);

#undef AR_START
#undef AR_END
      }
      break;

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

  return SUCCESS;
}


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

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

gfc_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, found %s",
                 &index->where, gfc_basic_typename (index->ts.type));
      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.  */

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

      gfc_clear_ts (&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.  */