URL https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [fortran/] [symbol.c] - Blame information for rev 712

Details | Compare with Previous | View Log

/* Maintain binary trees of symbols.
   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
   2009, 2010, 2011, 2012
   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 "parse.h"
#include "match.h"
#include "constructor.h"
 
 
/* Strings for all symbol attributes.  We use these for dumping the
   parse tree, in error messages, and also when reading and writing
   modules.  */
 
const mstring flavors[] =
{
  minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
  minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
  minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
  minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
  minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
  minit (NULL, -1)
};
 
const mstring procedures[] =
{
    minit ("UNKNOWN-PROC", PROC_UNKNOWN),
    minit ("MODULE-PROC", PROC_MODULE),
    minit ("INTERNAL-PROC", PROC_INTERNAL),
    minit ("DUMMY-PROC", PROC_DUMMY),
    minit ("INTRINSIC-PROC", PROC_INTRINSIC),
    minit ("EXTERNAL-PROC", PROC_EXTERNAL),
    minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
    minit (NULL, -1)
};
 
const mstring intents[] =
{
    minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
    minit ("IN", INTENT_IN),
    minit ("OUT", INTENT_OUT),
    minit ("INOUT", INTENT_INOUT),
    minit (NULL, -1)
};
 
const mstring access_types[] =
{
    minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
    minit ("PUBLIC", ACCESS_PUBLIC),
    minit ("PRIVATE", ACCESS_PRIVATE),
    minit (NULL, -1)
};
 
const mstring ifsrc_types[] =
{
    minit ("UNKNOWN", IFSRC_UNKNOWN),
    minit ("DECL", IFSRC_DECL),
    minit ("BODY", IFSRC_IFBODY)
};
 
const mstring save_status[] =
{
    minit ("UNKNOWN", SAVE_NONE),
    minit ("EXPLICIT-SAVE", SAVE_EXPLICIT),
    minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
};
 
/* This is to make sure the backend generates setup code in the correct
   order.  */
 
static int next_dummy_order = 1;
 
 
gfc_namespace *gfc_current_ns;
gfc_namespace *gfc_global_ns_list;
 
gfc_gsymbol *gfc_gsym_root = NULL;
 
static gfc_symbol *changed_syms = NULL;
 
gfc_dt_list *gfc_derived_types;
 
 
/* List of tentative typebound-procedures.  */
 
typedef struct tentative_tbp
{
  gfc_typebound_proc *proc;
  struct tentative_tbp *next;
}
tentative_tbp;
 
static tentative_tbp *tentative_tbp_list = NULL;
 
 
/*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
 
/* The following static variable indicates whether a particular element has
   been explicitly set or not.  */
 
static int new_flag[GFC_LETTERS];
 
 
/* Handle a correctly parsed IMPLICIT NONE.  */
 
void
gfc_set_implicit_none (void)
{
  int i;
 
  if (gfc_current_ns->seen_implicit_none)
    {
      gfc_error ("Duplicate IMPLICIT NONE statement at %C");
      return;
    }
 
  gfc_current_ns->seen_implicit_none = 1;
 
  for (i = 0; i < GFC_LETTERS; i++)
    {
      gfc_clear_ts (&gfc_current_ns->default_type[i]);
      gfc_current_ns->set_flag[i] = 1;
    }
}
 
 
/* Reset the implicit range flags.  */
 
void
gfc_clear_new_implicit (void)
{
  int i;
 
  for (i = 0; i < GFC_LETTERS; i++)
    new_flag[i] = 0;
}
 
 
/* Prepare for a new implicit range.  Sets flags in new_flag[].  */
 
gfc_try
gfc_add_new_implicit_range (int c1, int c2)
{
  int i;
 
  c1 -= 'a';
  c2 -= 'a';
 
  for (i = c1; i <= c2; i++)
    {
      if (new_flag[i])
        {
          gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
                     i + 'A');
          return FAILURE;
        }
 
      new_flag[i] = 1;
    }
 
  return SUCCESS;
}
 
 
/* Add a matched implicit range for gfc_set_implicit().  Check if merging
   the new implicit types back into the existing types will work.  */
 
gfc_try
gfc_merge_new_implicit (gfc_typespec *ts)
{
  int i;
 
  if (gfc_current_ns->seen_implicit_none)
    {
      gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
      return FAILURE;
    }
 
  for (i = 0; i < GFC_LETTERS; i++)
    {
      if (new_flag[i])
        {
          if (gfc_current_ns->set_flag[i])
            {
              gfc_error ("Letter %c already has an IMPLICIT type at %C",
                         i + 'A');
              return FAILURE;
            }
 
          gfc_current_ns->default_type[i] = *ts;
          gfc_current_ns->implicit_loc[i] = gfc_current_locus;
          gfc_current_ns->set_flag[i] = 1;
        }
    }
  return SUCCESS;
}
 
 
/* Given a symbol, return a pointer to the typespec for its default type.  */
 
gfc_typespec *
gfc_get_default_type (const char *name, gfc_namespace *ns)
{
  char letter;
 
  letter = name[0];
 
  if (gfc_option.flag_allow_leading_underscore && letter == '_')
    gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
                        "gfortran developers, and should not be used for "
                        "implicitly typed variables");
 
  if (letter < 'a' || letter > 'z')
    gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'", name);
 
  if (ns == NULL)
    ns = gfc_current_ns;
 
  return &ns->default_type[letter - 'a'];
}
 
 
/* Given a pointer to a symbol, set its type according to the first
   letter of its name.  Fails if the letter in question has no default
   type.  */
 
gfc_try
gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
{
  gfc_typespec *ts;
 
  if (sym->ts.type != BT_UNKNOWN)
    gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
 
  ts = gfc_get_default_type (sym->name, ns);
 
  if (ts->type == BT_UNKNOWN)
    {
      if (error_flag && !sym->attr.untyped)
        {
          gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
                     sym->name, &sym->declared_at);
          sym->attr.untyped = 1; /* Ensure we only give an error once.  */
        }
 
      return FAILURE;
    }
 
  sym->ts = *ts;
  sym->attr.implicit_type = 1;
 
  if (ts->type == BT_CHARACTER && ts->u.cl)
    sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl);
 
  if (sym->attr.is_bind_c == 1)
    {
      /* BIND(C) variables should not be implicitly declared.  */
      gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
                       "not be C interoperable", sym->name, &sym->declared_at);
      sym->ts.f90_type = sym->ts.type;
    }
 
  if (sym->attr.dummy != 0)
    {
      if (sym->ns->proc_name != NULL
          && (sym->ns->proc_name->attr.subroutine != 0
              || sym->ns->proc_name->attr.function != 0)
          && sym->ns->proc_name->attr.is_bind_c != 0)
        {
          /* Dummy args to a BIND(C) routine may not be interoperable if
             they are implicitly typed.  */
          gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
                           "be C interoperable but it is a dummy argument to "
                           "the BIND(C) procedure '%s' at %L", sym->name,
                           &(sym->declared_at), sym->ns->proc_name->name,
                           &(sym->ns->proc_name->declared_at));
          sym->ts.f90_type = sym->ts.type;
        }
    }
 
  return SUCCESS;
}
 
 
/* This function is called from parse.c(parse_progunit) to check the
   type of the function is not implicitly typed in the host namespace
   and to implicitly type the function result, if necessary.  */
 
void
gfc_check_function_type (gfc_namespace *ns)
{
  gfc_symbol *proc = ns->proc_name;
 
  if (!proc->attr.contained || proc->result->attr.implicit_type)
    return;
 
  if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL)
    {
      if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
                == SUCCESS)
        {
          if (proc->result != proc)
            {
              proc->ts = proc->result->ts;
              proc->as = gfc_copy_array_spec (proc->result->as);
              proc->attr.dimension = proc->result->attr.dimension;
              proc->attr.pointer = proc->result->attr.pointer;
              proc->attr.allocatable = proc->result->attr.allocatable;
            }
        }
      else if (!proc->result->attr.proc_pointer)
        {
          gfc_error ("Function result '%s' at %L has no IMPLICIT type",
                     proc->result->name, &proc->result->declared_at);
          proc->result->attr.untyped = 1;
        }
    }
}
 
 
/******************** Symbol attribute stuff *********************/
 
/* This is a generic conflict-checker.  We do this to avoid having a
   single conflict in two places.  */
 
#define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
#define conf2(a) if (attr->a) { a2 = a; goto conflict; }
#define conf_std(a, b, std) if (attr->a && attr->b)\
                              {\
                                a1 = a;\
                                a2 = b;\
                                standard = std;\
                                goto conflict_std;\
                              }
 
static gfc_try
check_conflict (symbol_attribute *attr, const char *name, locus *where)
{
  static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
    *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
    *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
    *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
    *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
    *privat = "PRIVATE", *recursive = "RECURSIVE",
    *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
    *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
    *function = "FUNCTION", *subroutine = "SUBROUTINE",
    *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
    *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
    *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
    *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
    *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
    *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
    *contiguous = "CONTIGUOUS", *generic = "GENERIC";
  static const char *threadprivate = "THREADPRIVATE";
 
  const char *a1, *a2;
  int standard;
 
  if (where == NULL)
    where = &gfc_current_locus;
 
  if (attr->pointer && attr->intent != INTENT_UNKNOWN)
    {
      a1 = pointer;
      a2 = intent;
      standard = GFC_STD_F2003;
      goto conflict_std;
    }
 
  if (attr->in_namelist && (attr->allocatable || attr->pointer))
    {
      a1 = in_namelist;
      a2 = attr->allocatable ? allocatable : pointer;
      standard = GFC_STD_F2003;
      goto conflict_std;
    }
 
  /* Check for attributes not allowed in a BLOCK DATA.  */
  if (gfc_current_state () == COMP_BLOCK_DATA)
    {
      a1 = NULL;
 
      if (attr->in_namelist)
        a1 = in_namelist;
      if (attr->allocatable)
        a1 = allocatable;
      if (attr->external)
        a1 = external;
      if (attr->optional)
        a1 = optional;
      if (attr->access == ACCESS_PRIVATE)
        a1 = privat;
      if (attr->access == ACCESS_PUBLIC)
        a1 = publik;
      if (attr->intent != INTENT_UNKNOWN)
        a1 = intent;
 
      if (a1 != NULL)
        {
          gfc_error
            ("%s attribute not allowed in BLOCK DATA program unit at %L",
             a1, where);
          return FAILURE;
        }
    }
 
  if (attr->save == SAVE_EXPLICIT)
    {
      conf (dummy, save);
      conf (in_common, save);
      conf (result, save);
 
      switch (attr->flavor)
        {
          case FL_PROGRAM:
          case FL_BLOCK_DATA:
          case FL_MODULE:
          case FL_LABEL:
          case FL_DERIVED:
          case FL_PARAMETER:
            a1 = gfc_code2string (flavors, attr->flavor);
            a2 = save;
            goto conflict;
          case FL_NAMELIST:
            gfc_error ("Namelist group name at %L cannot have the "
                       "SAVE attribute", where);
            return FAILURE;
            break;
          case FL_PROCEDURE:
            /* Conflicts between SAVE and PROCEDURE will be checked at
               resolution stage, see "resolve_fl_procedure".  */
          case FL_VARIABLE:
          default:
            break;
        }
    }
 
  conf (dummy, entry);
  conf (dummy, intrinsic);
  conf (dummy, threadprivate);
  conf (pointer, target);
  conf (pointer, intrinsic);
  conf (pointer, elemental);
  conf (allocatable, elemental);
 
  conf (target, external);
  conf (target, intrinsic);
 
  if (!attr->if_source)
    conf (external, dimension);   /* See Fortran 95's R504.  */
 
  conf (external, intrinsic);
  conf (entry, intrinsic);
 
  if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
    conf (external, subroutine);
 
  if (attr->proc_pointer && gfc_notify_std (GFC_STD_F2003,
                            "Fortran 2003: Procedure pointer at %C") == FAILURE)
    return FAILURE;
 
  conf (allocatable, pointer);
  conf_std (allocatable, dummy, GFC_STD_F2003);
  conf_std (allocatable, function, GFC_STD_F2003);
  conf_std (allocatable, result, GFC_STD_F2003);
  conf (elemental, recursive);
 
  conf (in_common, dummy);
  conf (in_common, allocatable);
  conf (in_common, codimension);
  conf (in_common, result);
 
  conf (in_equivalence, use_assoc);
  conf (in_equivalence, codimension);
  conf (in_equivalence, dummy);
  conf (in_equivalence, target);
  conf (in_equivalence, pointer);
  conf (in_equivalence, function);
  conf (in_equivalence, result);
  conf (in_equivalence, entry);
  conf (in_equivalence, allocatable);
  conf (in_equivalence, threadprivate);
 
  conf (dummy, result);
  conf (entry, result);
  conf (generic, result);
 
  conf (function, subroutine);
 
  if (!function && !subroutine)
    conf (is_bind_c, dummy);
 
  conf (is_bind_c, cray_pointer);
  conf (is_bind_c, cray_pointee);
  conf (is_bind_c, codimension);
  conf (is_bind_c, allocatable);
  conf (is_bind_c, elemental);
 
  /* Need to also get volatile attr, according to 5.1 of F2003 draft.
     Parameter conflict caught below.  Also, value cannot be specified
     for a dummy procedure.  */
 
  /* Cray pointer/pointee conflicts.  */
  conf (cray_pointer, cray_pointee);
  conf (cray_pointer, dimension);
  conf (cray_pointer, codimension);
  conf (cray_pointer, contiguous);
  conf (cray_pointer, pointer);
  conf (cray_pointer, target);
  conf (cray_pointer, allocatable);
  conf (cray_pointer, external);
  conf (cray_pointer, intrinsic);
  conf (cray_pointer, in_namelist);
  conf (cray_pointer, function);
  conf (cray_pointer, subroutine);
  conf (cray_pointer, entry);
 
  conf (cray_pointee, allocatable);
  conf (cray_pointer, contiguous);
  conf (cray_pointer, codimension);
  conf (cray_pointee, intent);
  conf (cray_pointee, optional);
  conf (cray_pointee, dummy);
  conf (cray_pointee, target);
  conf (cray_pointee, intrinsic);
  conf (cray_pointee, pointer);
  conf (cray_pointee, entry);
  conf (cray_pointee, in_common);
  conf (cray_pointee, in_equivalence);
  conf (cray_pointee, threadprivate);
 
  conf (data, dummy);
  conf (data, function);
  conf (data, result);
  conf (data, allocatable);
 
  conf (value, pointer)
  conf (value, allocatable)
  conf (value, subroutine)
  conf (value, function)
  conf (value, volatile_)
  conf (value, dimension)
  conf (value, codimension)
  conf (value, external)
 
  conf (codimension, result)
 
  if (attr->value
      && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
    {
      a1 = value;
      a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
      goto conflict;
    }
 
  conf (is_protected, intrinsic)
  conf (is_protected, in_common)
 
  conf (asynchronous, intrinsic)
  conf (asynchronous, external)
 
  conf (volatile_, intrinsic)
  conf (volatile_, external)
 
  if (attr->volatile_ && attr->intent == INTENT_IN)
    {
      a1 = volatile_;
      a2 = intent_in;
      goto conflict;
    }
 
  conf (procedure, allocatable)
  conf (procedure, dimension)
  conf (procedure, codimension)
  conf (procedure, intrinsic)
  conf (procedure, target)
  conf (procedure, value)
  conf (procedure, volatile_)
  conf (procedure, asynchronous)
  conf (procedure, entry)
 
  a1 = gfc_code2string (flavors, attr->flavor);
 
  if (attr->in_namelist
      && attr->flavor != FL_VARIABLE
      && attr->flavor != FL_PROCEDURE
      && attr->flavor != FL_UNKNOWN)
    {
      a2 = in_namelist;
      goto conflict;
    }
 
  switch (attr->flavor)
    {
    case FL_PROGRAM:
    case FL_BLOCK_DATA:
    case FL_MODULE:
    case FL_LABEL:
      conf2 (codimension);
      conf2 (dimension);
      conf2 (dummy);
      conf2 (volatile_);
      conf2 (asynchronous);
      conf2 (contiguous);
      conf2 (pointer);
      conf2 (is_protected);
      conf2 (target);
      conf2 (external);
      conf2 (intrinsic);
      conf2 (allocatable);
      conf2 (result);
      conf2 (in_namelist);
      conf2 (optional);
      conf2 (function);
      conf2 (subroutine);
      conf2 (threadprivate);
 
      if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
        {
          a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
          gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
            name, where);
          return FAILURE;
        }
 
      if (attr->is_bind_c)
        {
          gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
          return FAILURE;
        }
 
      break;
 
    case FL_VARIABLE:
      break;
 
    case FL_NAMELIST:
      conf2 (result);
      break;
 
    case FL_PROCEDURE:
      /* Conflicts with INTENT, SAVE and RESULT will be checked
         at resolution stage, see "resolve_fl_procedure".  */
 
      if (attr->subroutine)
        {
          a1 = subroutine;
          conf2 (target);
          conf2 (allocatable);
          conf2 (volatile_);
          conf2 (asynchronous);
          conf2 (in_namelist);
          conf2 (codimension);
          conf2 (dimension);
          conf2 (function);
          if (!attr->proc_pointer)
            conf2 (threadprivate);
        }
 
      if (!attr->proc_pointer)
        conf2 (in_common);
 
      switch (attr->proc)
        {
        case PROC_ST_FUNCTION:
          conf2 (dummy);
          conf2 (target);
          break;
 
        case PROC_MODULE:
          conf2 (dummy);
          break;
 
        case PROC_DUMMY:
          conf2 (result);
          conf2 (threadprivate);
          break;
 
        default:
          break;
        }
 
      break;
 
    case FL_DERIVED:
      conf2 (dummy);
      conf2 (pointer);
      conf2 (target);
      conf2 (external);
      conf2 (intrinsic);
      conf2 (allocatable);
      conf2 (optional);
      conf2 (entry);
      conf2 (function);
      conf2 (subroutine);
      conf2 (threadprivate);
      conf2 (result);
 
      if (attr->intent != INTENT_UNKNOWN)
        {
          a2 = intent;
          goto conflict;
        }
      break;
 
    case FL_PARAMETER:
      conf2 (external);
      conf2 (intrinsic);
      conf2 (optional);
      conf2 (allocatable);
      conf2 (function);
      conf2 (subroutine);
      conf2 (entry);
      conf2 (contiguous);
      conf2 (pointer);
      conf2 (is_protected);
      conf2 (target);
      conf2 (dummy);
      conf2 (in_common);
      conf2 (value);
      conf2 (volatile_);
      conf2 (asynchronous);
      conf2 (threadprivate);
      conf2 (value);
      conf2 (codimension);
      conf2 (result);
      if (!attr->is_iso_c)
        conf2 (is_bind_c);
      break;
 
    default:
      break;
    }
 
  return SUCCESS;
 
conflict:
  if (name == NULL)
    gfc_error ("%s attribute conflicts with %s attribute at %L",
               a1, a2, where);
  else
    gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
               a1, a2, name, where);
 
  return FAILURE;
 
conflict_std:
  if (name == NULL)
    {
      return gfc_notify_std (standard, "Fortran 2003: %s attribute "
                             "with %s attribute at %L", a1, a2,
                             where);
    }
  else
    {
      return gfc_notify_std (standard, "Fortran 2003: %s attribute "
                             "with %s attribute in '%s' at %L",
                             a1, a2, name, where);
    }
}
 
#undef conf
#undef conf2
#undef conf_std
 
 
/* Mark a symbol as referenced.  */
 
void
gfc_set_sym_referenced (gfc_symbol *sym)
{
 
  if (sym->attr.referenced)
    return;
 
  sym->attr.referenced = 1;
 
  /* Remember which order dummy variables are accessed in.  */
  if (sym->attr.dummy)
    sym->dummy_order = next_dummy_order++;
}
 
 
/* Common subroutine called by attribute changing subroutines in order
   to prevent them from changing a symbol that has been
   use-associated.  Returns zero if it is OK to change the symbol,
   nonzero if not.  */
 
static int
check_used (symbol_attribute *attr, const char *name, locus *where)
{
 
  if (attr->use_assoc == 0)
    return 0;
 
  if (where == NULL)
    where = &gfc_current_locus;
 
  if (name == NULL)
    gfc_error ("Cannot change attributes of USE-associated symbol at %L",
               where);
  else
    gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
               name, where);
 
  return 1;
}
 
 
/* Generate an error because of a duplicate attribute.  */
 
static void
duplicate_attr (const char *attr, locus *where)
{
 
  if (where == NULL)
    where = &gfc_current_locus;
 
  gfc_error ("Duplicate %s attribute specified at %L", attr, where);
}
 
 
gfc_try
gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
                       locus *where ATTRIBUTE_UNUSED)
{
  attr->ext_attr |= 1 << ext_attr;
  return SUCCESS;
}
 
 
/* Called from decl.c (attr_decl1) to check attributes, when declared
   separately.  */
 
gfc_try
gfc_add_attribute (symbol_attribute *attr, locus *where)
{
  if (check_used (attr, NULL, where))
    return FAILURE;
 
  return check_conflict (attr, NULL, where);
}
 
 
gfc_try
gfc_add_allocatable (symbol_attribute *attr, locus *where)
{
 
  if (check_used (attr, NULL, where))
    return FAILURE;
 
  if (attr->allocatable)
    {
      duplicate_attr ("ALLOCATABLE", where);
      return FAILURE;
    }
 
  if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
      && gfc_find_state (COMP_INTERFACE) == FAILURE)
    {
      gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
                 where);
      return FAILURE;
    }
 
  attr->allocatable = 1;
  return check_conflict (attr, NULL, where);
}
 
 
gfc_try
gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
{
 
  if (check_used (attr, name, where))
    return FAILURE;
 
  if (attr->codimension)
    {
      duplicate_attr ("CODIMENSION", where);
      return FAILURE;
    }
 
  if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
      && gfc_find_state (COMP_INTERFACE) == FAILURE)
    {
      gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body "
                 "at %L", name, where);
      return FAILURE;
    }
 
  attr->codimension = 1;
  return check_conflict (attr, name, where);
}
 
 
gfc_try
gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
{
 
  if (check_used (attr, name, where))
    return FAILURE;
 
  if (attr->dimension)
    {
      duplicate_attr ("DIMENSION", where);
      return FAILURE;
    }
 
  if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
      && gfc_find_state (COMP_INTERFACE) == FAILURE)
    {
      gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
                 "at %L", name, where);
      return FAILURE;
    }
 
  attr->dimension = 1;
  return check_conflict (attr, name, where);
}
 
 
gfc_try
gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where)
{
 
  if (check_used (attr, name, where))
    return FAILURE;
 
  attr->contiguous = 1;
  return check_conflict (attr, name, where);
}
 
 
gfc_try
gfc_add_external (symbol_attribute *attr, locus *where)
{
 
  if (check_used (attr, NULL, where))
    return FAILURE;
 
  if (attr->external)
    {
      duplicate_attr ("EXTERNAL", where);
      return FAILURE;
    }
 
  if (attr->pointer && attr->if_source != IFSRC_IFBODY)
    {
      attr->pointer = 0;
      attr->proc_pointer = 1;
    }
 
  attr->external = 1;
 
  return check_conflict (attr, NULL, where);
}
 
 
gfc_try
gfc_add_intrinsic (symbol_attribute *attr, locus *where)
{
 
  if (check_used (attr, NULL, where))
    return FAILURE;
 
  if (attr->intrinsic)
    {
      duplicate_attr ("INTRINSIC", where);
      return FAILURE;
    }
 
  attr->intrinsic = 1;
 
  return check_conflict (attr, NULL, where);
}
 
 
gfc_try
gfc_add_optional (symbol_attribute *attr, locus *where)
{
 
  if (check_used (attr, NULL, where))
    return FAILURE;
 
  if (attr->optional)
    {
      duplicate_attr ("OPTIONAL", where);
      return FAILURE;
    }
 
  attr->optional = 1;
  return check_conflict (attr, NULL, where);
}
 
 
gfc_try
gfc_add_pointer (symbol_attribute *attr, locus *where)
{
 
  if (check_used (attr, NULL, where))
    return FAILURE;
 
  if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
      && gfc_find_state (COMP_INTERFACE) == FAILURE))
    {
      duplicate_attr ("POINTER", where);
      return FAILURE;
    }
 
  if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
      || (attr->if_source == IFSRC_IFBODY
      && gfc_find_state (COMP_INTERFACE) == FAILURE))
    attr->proc_pointer = 1;
  else
    attr->pointer = 1;
 
  return check_conflict (attr, NULL, where);
}
 
 
gfc_try
gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
{
 
  if (check_used (attr, NULL, where))
    return FAILURE;
 
  attr->cray_pointer = 1;
  return check_conflict (attr, NULL, where);
}
 
 
gfc_try
gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
{
 
  if (check_used (attr, NULL, where))
    return FAILURE;
 
  if (attr->cray_pointee)
    {
      gfc_error ("Cray Pointee at %L appears in multiple pointer()"
                 " statements", where);
      return FAILURE;
    }
 
  attr->cray_pointee = 1;
  return check_conflict (attr, NULL, where);
}
 
 
gfc_try
gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
{
  if (check_used (attr, name, where))
    return FAILURE;
 
  if (attr->is_protected)
    {
        if (gfc_notify_std (GFC_STD_LEGACY,
                            "Duplicate PROTECTED attribute specified at %L",
                            where)
            == FAILURE)
          return FAILURE;
    }
 
  attr->is_protected = 1;
  return check_conflict (attr, name, where);
}
 
 
gfc_try
gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
{
 
  if (check_used (attr, name, where))
    return FAILURE;
 
  attr->result = 1;
  return check_conflict (attr, name, where);
}
 
 
gfc_try
gfc_add_save (symbol_attribute *attr, save_state s, const char *name,
              locus *where)
{
 
  if (check_used (attr, name, where))
    return FAILURE;
 
  if (s == SAVE_EXPLICIT && gfc_pure (NULL))
    {
      gfc_error
        ("SAVE attribute at %L cannot be specified in a PURE procedure",
         where);
      return FAILURE;
    }
 
  if (s == SAVE_EXPLICIT && gfc_implicit_pure (NULL))
    gfc_current_ns->proc_name->attr.implicit_pure = 0;
 
  if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT)
    {
        if (gfc_notify_std (GFC_STD_LEGACY,
                            "Duplicate SAVE attribute specified at %L",
                            where)
            == FAILURE)
          return FAILURE;
    }
 
  attr->save = s;
  return check_conflict (attr, name, where);
}
 
 
gfc_try
gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
{
 
  if (check_used (attr, name, where))
    return FAILURE;
 
  if (attr->value)
    {
        if (gfc_notify_std (GFC_STD_LEGACY,
                            "Duplicate VALUE attribute specified at %L",
                            where)
            == FAILURE)
          return FAILURE;
    }
 
  attr->value = 1;
  return check_conflict (attr, name, where);
}
 
 
gfc_try
gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
{
  /* No check_used needed as 11.2.1 of the F2003 standard allows
     that the local identifier made accessible by a use statement can be
     given a VOLATILE attribute - unless it is a coarray (F2008, C560).  */
 
  if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
    if (gfc_notify_std (GFC_STD_LEGACY,
                        "Duplicate VOLATILE attribute specified at %L", where)
        == FAILURE)
      return FAILURE;
 
  attr->volatile_ = 1;
  attr->volatile_ns = gfc_current_ns;
  return check_conflict (attr, name, where);
}
 
 
gfc_try
gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
{
  /* No check_used needed as 11.2.1 of the F2003 standard allows
     that the local identifier made accessible by a use statement can be
     given a ASYNCHRONOUS attribute.  */
 
  if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
    if (gfc_notify_std (GFC_STD_LEGACY,
                        "Duplicate ASYNCHRONOUS attribute specified at %L",
                        where) == FAILURE)
      return FAILURE;
 
  attr->asynchronous = 1;
  attr->asynchronous_ns = gfc_current_ns;
  return check_conflict (attr, name, where);
}
 
 
gfc_try
gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
{
 
  if (check_used (attr, name, where))
    return FAILURE;
 
  if (attr->threadprivate)
    {
      duplicate_attr ("THREADPRIVATE", where);
      return FAILURE;
    }
 
  attr->threadprivate = 1;
  return check_conflict (attr, name, where);
}
 
 
gfc_try
gfc_add_target (symbol_attribute *attr, locus *where)
{
 
  if (check_used (attr, NULL, where))
    return FAILURE;
 
  if (attr->target)
    {
      duplicate_attr ("TARGET", where);
      return FAILURE;
    }
 
  attr->target = 1;
  return check_conflict (attr, NULL, where);
}
 
 
gfc_try
gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
{
 
  if (check_used (attr, name, where))
    return FAILURE;
 
  /* Duplicate dummy arguments are allowed due to ENTRY statements.  */
  attr->dummy = 1;
  return check_conflict (attr, name, where);
}
 
 
gfc_try
gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
{
 
  if (check_used (attr, name, where))
    return FAILURE;
 
  /* Duplicate attribute already checked for.  */
  attr->in_common = 1;
  return check_conflict (attr, name, where);
}
 
 
gfc_try
gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
{
 
  /* Duplicate attribute already checked for.  */
  attr->in_equivalence = 1;
  if (check_conflict (attr, name, where) == FAILURE)
    return FAILURE;
 
  if (attr->flavor == FL_VARIABLE)
    return SUCCESS;
 
  return gfc_add_flavor (attr, FL_VARIABLE, name, where);
}
 
 
gfc_try
gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
{
 
  if (check_used (attr, name, where))
    return FAILURE;
 
  attr->data = 1;
  return check_conflict (attr, name, where);
}
 
 
gfc_try
gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
{
 
  attr->in_namelist = 1;
  return check_conflict (attr, name, where);
}
 
 
gfc_try
gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
{
 
  if (check_used (attr, name, where))
    return FAILURE;
 
  attr->sequence = 1;
  return check_conflict (attr, name, where);
}
 
 
gfc_try
gfc_add_elemental (symbol_attribute *attr, locus *where)
{
 
  if (check_used (attr, NULL, where))
    return FAILURE;
 
  if (attr->elemental)
    {
      duplicate_attr ("ELEMENTAL", where);
      return FAILURE;
    }
 
  attr->elemental = 1;
  return check_conflict (attr, NULL, where);
}
 
 
gfc_try
gfc_add_pure (symbol_attribute *attr, locus *where)
{
 
  if (check_used (attr, NULL, where))
    return FAILURE;
 
  if (attr->pure)
    {
      duplicate_attr ("PURE", where);
      return FAILURE;
    }
 
  attr->pure = 1;
  return check_conflict (attr, NULL, where);
}
 
 
gfc_try
gfc_add_recursive (symbol_attribute *attr, locus *where)
{
 
  if (check_used (attr, NULL, where))
    return FAILURE;
 
  if (attr->recursive)
    {
      duplicate_attr ("RECURSIVE", where);
      return FAILURE;
    }
 
  attr->recursive = 1;
  return check_conflict (attr, NULL, where);
}
 
 
gfc_try
gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
{
 
  if (check_used (attr, name, where))
    return FAILURE;
 
  if (attr->entry)
    {
      duplicate_attr ("ENTRY", where);
      return FAILURE;
    }
 
  attr->entry = 1;
  return check_conflict (attr, name, where);
}
 
 
gfc_try
gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
{
 
  if (attr->flavor != FL_PROCEDURE
      && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
    return FAILURE;
 
  attr->function = 1;
  return check_conflict (attr, name, where);
}
 
 
gfc_try
gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
{
 
  if (attr->flavor != FL_PROCEDURE
      && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
    return FAILURE;
 
  attr->subroutine = 1;
  return check_conflict (attr, name, where);
}
 
 
gfc_try
gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
{
 
  if (attr->flavor != FL_PROCEDURE
      && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
    return FAILURE;
 
  attr->generic = 1;
  return check_conflict (attr, name, where);
}
 
 
gfc_try
gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
{
 
  if (check_used (attr, NULL, where))
    return FAILURE;
 
  if (attr->flavor != FL_PROCEDURE
      && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
    return FAILURE;
 
  if (attr->procedure)
    {
      duplicate_attr ("PROCEDURE", where);
      return FAILURE;
    }
 
  attr->procedure = 1;
 
  return check_conflict (attr, NULL, where);
}
 
 
gfc_try
gfc_add_abstract (symbol_attribute* attr, locus* where)
{
  if (attr->abstract)
    {
      duplicate_attr ("ABSTRACT", where);
      return FAILURE;
    }
 
  attr->abstract = 1;
  return SUCCESS;
}
 
 
/* Flavors are special because some flavors are not what Fortran
   considers attributes and can be reaffirmed multiple times.  */
 
gfc_try
gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
                locus *where)
{
 
  if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
       || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
       || f == FL_NAMELIST) && check_used (attr, name, where))
    return FAILURE;
 
  if (attr->flavor == f && f == FL_VARIABLE)
    return SUCCESS;
 
  if (attr->flavor != FL_UNKNOWN)
    {
      if (where == NULL)
        where = &gfc_current_locus;
 
      if (name)
        gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
                   gfc_code2string (flavors, attr->flavor), name,
                   gfc_code2string (flavors, f), where);
      else
        gfc_error ("%s attribute conflicts with %s attribute at %L",
                   gfc_code2string (flavors, attr->flavor),
                   gfc_code2string (flavors, f), where);
 
      return FAILURE;
    }
 
  attr->flavor = f;
 
  return check_conflict (attr, name, where);
}
 
 
gfc_try
gfc_add_procedure (symbol_attribute *attr, procedure_type t,
                   const char *name, locus *where)
{
 
  if (check_used (attr, name, where))
    return FAILURE;
 
  if (attr->flavor != FL_PROCEDURE
      && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
    return FAILURE;
 
  if (where == NULL)
    where = &gfc_current_locus;
 
  if (attr->proc != PROC_UNKNOWN)
    {
      gfc_error ("%s procedure at %L is already declared as %s procedure",
                 gfc_code2string (procedures, t), where,
                 gfc_code2string (procedures, attr->proc));
 
      return FAILURE;
    }
 
  attr->proc = t;
 
  /* Statement functions are always scalar and functions.  */
  if (t == PROC_ST_FUNCTION
      && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
          || attr->dimension))
    return FAILURE;
 
  return check_conflict (attr, name, where);
}
 
 
gfc_try
gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
{
 
  if (check_used (attr, NULL, where))
    return FAILURE;
 
  if (attr->intent == INTENT_UNKNOWN)
    {
      attr->intent = intent;
      return check_conflict (attr, NULL, where);
    }
 
  if (where == NULL)
    where = &gfc_current_locus;
 
  gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
             gfc_intent_string (attr->intent),
             gfc_intent_string (intent), where);
 
  return FAILURE;
}
 
 
/* No checks for use-association in public and private statements.  */
 
gfc_try
gfc_add_access (symbol_attribute *attr, gfc_access access,
                const char *name, locus *where)
{
 
  if (attr->access == ACCESS_UNKNOWN
        || (attr->use_assoc && attr->access != ACCESS_PRIVATE))
    {
      attr->access = access;
      return check_conflict (attr, name, where);
    }
 
  if (where == NULL)
    where = &gfc_current_locus;
  gfc_error ("ACCESS specification at %L was already specified", where);
 
  return FAILURE;
}
 
 
/* Set the is_bind_c field for the given symbol_attribute.  */
 
gfc_try
gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
                   int is_proc_lang_bind_spec)
{
 
  if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
    gfc_error_now ("BIND(C) attribute at %L can only be used for "
                   "variables or common blocks", where);
  else if (attr->is_bind_c)
    gfc_error_now ("Duplicate BIND attribute specified at %L", where);
  else
    attr->is_bind_c = 1;
 
  if (where == NULL)
    where = &gfc_current_locus;
 
  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where)
      == FAILURE)
    return FAILURE;
 
  return check_conflict (attr, name, where);
}
 
 
/* Set the extension field for the given symbol_attribute.  */
 
gfc_try
gfc_add_extension (symbol_attribute *attr, locus *where)
{
  if (where == NULL)
    where = &gfc_current_locus;
 
  if (attr->extension)
    gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
  else
    attr->extension = 1;
 
  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: EXTENDS at %L", where)
        == FAILURE)
    return FAILURE;
 
  return SUCCESS;
}
 
 
gfc_try
gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
                            gfc_formal_arglist * formal, locus *where)
{
 
  if (check_used (&sym->attr, sym->name, where))
    return FAILURE;
 
  if (where == NULL)
    where = &gfc_current_locus;
 
  if (sym->attr.if_source != IFSRC_UNKNOWN
      && sym->attr.if_source != IFSRC_DECL)
    {
      gfc_error ("Symbol '%s' at %L already has an explicit interface",
                 sym->name, where);
      return FAILURE;
    }
 
  if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
    {
      gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
                 "body", sym->name, where);
      return FAILURE;
    }
 
  sym->formal = formal;
  sym->attr.if_source = source;
 
  return SUCCESS;
}
 
 
/* Add a type to a symbol.  */
 
gfc_try
gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
{
  sym_flavor flavor;
  bt type;
 
  if (where == NULL)
    where = &gfc_current_locus;
 
  if (sym->result)
    type = sym->result->ts.type;
  else
    type = sym->ts.type;
 
  if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
    type = sym->ns->proc_name->ts.type;
 
  if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type))
    {
      if (sym->attr.use_assoc)
        gfc_error ("Symbol '%s' at %L conflicts with symbol from module '%s', "
                   "use-associated at %L", sym->name, where, sym->module,
                   &sym->declared_at);
      else
        gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
                 where, gfc_basic_typename (type));
      return FAILURE;
    }
 
  if (sym->attr.procedure && sym->ts.interface)
    {
      gfc_error ("Procedure '%s' at %L may not have basic type of %s",
                 sym->name, where, gfc_basic_typename (ts->type));
      return FAILURE;
    }
 
  flavor = sym->attr.flavor;
 
  if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
      || flavor == FL_LABEL
      || (flavor == FL_PROCEDURE && sym->attr.subroutine)
      || flavor == FL_DERIVED || flavor == FL_NAMELIST)
    {
      gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
      return FAILURE;
    }
 
  sym->ts = *ts;
  return SUCCESS;
}
 
 
/* Clears all attributes.  */
 
void
gfc_clear_attr (symbol_attribute *attr)
{
  memset (attr, 0, sizeof (symbol_attribute));
}
 
 
/* Check for missing attributes in the new symbol.  Currently does
   nothing, but it's not clear that it is unnecessary yet.  */
 
gfc_try
gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
                  locus *where ATTRIBUTE_UNUSED)
{
 
  return SUCCESS;
}
 
 
/* Copy an attribute to a symbol attribute, bit by bit.  Some
   attributes have a lot of side-effects but cannot be present given
   where we are called from, so we ignore some bits.  */
 
gfc_try
gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
{
  int is_proc_lang_bind_spec;
 
  /* In line with the other attributes, we only add bits but do not remove
     them; cf. also PR 41034.  */
  dest->ext_attr |= src->ext_attr;
 
  if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
    goto fail;
 
  if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
    goto fail;
  if (src->codimension && gfc_add_codimension (dest, NULL, where) == FAILURE)
    goto fail;
  if (src->contiguous && gfc_add_contiguous (dest, NULL, where) == FAILURE)
    goto fail;
  if (src->optional && gfc_add_optional (dest, where) == FAILURE)
    goto fail;
  if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
    goto fail;
  if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
    goto fail;
  if (src->save && gfc_add_save (dest, src->save, NULL, where) == FAILURE)
    goto fail;
  if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
    goto fail;
  if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
    goto fail;
  if (src->asynchronous && gfc_add_asynchronous (dest, NULL, where) == FAILURE)
    goto fail;
  if (src->threadprivate
      && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
    goto fail;
  if (src->target && gfc_add_target (dest, where) == FAILURE)
    goto fail;
  if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
    goto fail;
  if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
    goto fail;
  if (src->entry)
    dest->entry = 1;
 
  if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
    goto fail;
 
  if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
    goto fail;
 
  if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
    goto fail;
  if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
    goto fail;
  if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
    goto fail;
 
  if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
    goto fail;
  if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
    goto fail;
  if (src->pure && gfc_add_pure (dest, where) == FAILURE)
    goto fail;
  if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
    goto fail;
 
  if (src->flavor != FL_UNKNOWN
      && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
    goto fail;
 
  if (src->intent != INTENT_UNKNOWN
      && gfc_add_intent (dest, src->intent, where) == FAILURE)
    goto fail;
 
  if (src->access != ACCESS_UNKNOWN
      && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
    goto fail;
 
  if (gfc_missing_attr (dest, where) == FAILURE)
    goto fail;
 
  if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
    goto fail;
  if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
    goto fail;
 
  is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
  if (src->is_bind_c
      && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)
         != SUCCESS)
    return FAILURE;
 
  if (src->is_c_interop)
    dest->is_c_interop = 1;
  if (src->is_iso_c)
    dest->is_iso_c = 1;
 
  if (src->external && gfc_add_external (dest, where) == FAILURE)
    goto fail;
  if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
    goto fail;
  if (src->proc_pointer)
    dest->proc_pointer = 1;
 
  return SUCCESS;
 
fail:
  return FAILURE;
}
 
 
/************** Component name management ************/
 
/* Component names of a derived type form their own little namespaces
   that are separate from all other spaces.  The space is composed of
   a singly linked list of gfc_component structures whose head is
   located in the parent symbol.  */
 
 
/* Add a component name to a symbol.  The call fails if the name is
   already present.  On success, the component pointer is modified to
   point to the additional component structure.  */
 
gfc_try
gfc_add_component (gfc_symbol *sym, const char *name,
                   gfc_component **component)
{
  gfc_component *p, *tail;
 
  tail = NULL;
 
  for (p = sym->components; p; p = p->next)
    {
      if (strcmp (p->name, name) == 0)
        {
          gfc_error ("Component '%s' at %C already declared at %L",
                     name, &p->loc);
          return FAILURE;
        }
 
      tail = p;
    }
 
  if (sym->attr.extension
        && gfc_find_component (sym->components->ts.u.derived, name, true, true))
    {
      gfc_error ("Component '%s' at %C already in the parent type "
                 "at %L", name, &sym->components->ts.u.derived->declared_at);
      return FAILURE;
    }
 
  /* Allocate a new component.  */
  p = gfc_get_component ();
 
  if (tail == NULL)
    sym->components = p;
  else
    tail->next = p;
 
  p->name = gfc_get_string (name);
  p->loc = gfc_current_locus;
  p->ts.type = BT_UNKNOWN;
 
  *component = p;
  return SUCCESS;
}
 
 
/* Recursive function to switch derived types of all symbol in a
   namespace.  */
 
static void
switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
{
  gfc_symbol *sym;
 
  if (st == NULL)
    return;
 
  sym = st->n.sym;
  if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from)
    sym->ts.u.derived = to;
 
  switch_types (st->left, from, to);
  switch_types (st->right, from, to);
}
 
 
/* This subroutine is called when a derived type is used in order to
   make the final determination about which version to use.  The
   standard requires that a type be defined before it is 'used', but
   such types can appear in IMPLICIT statements before the actual
   definition.  'Using' in this context means declaring a variable to
   be that type or using the type constructor.
 
   If a type is used and the components haven't been defined, then we
   have to have a derived type in a parent unit.  We find the node in
   the other namespace and point the symtree node in this namespace to
   that node.  Further reference to this name point to the correct
   node.  If we can't find the node in a parent namespace, then we have
   an error.
 
   This subroutine takes a pointer to a symbol node and returns a
   pointer to the translated node or NULL for an error.  Usually there
   is no translation and we return the node we were passed.  */
 
gfc_symbol *
gfc_use_derived (gfc_symbol *sym)
{
  gfc_symbol *s;
  gfc_typespec *t;
  gfc_symtree *st;
  int i;
 
  if (!sym)
    return NULL;
 
  if (sym->attr.generic)
    sym = gfc_find_dt_in_generic (sym);
 
  if (sym->components != NULL || sym->attr.zero_comp)
    return sym;               /* Already defined.  */
 
  if (sym->ns->parent == NULL)
    goto bad;
 
  if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
    {
      gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
      return NULL;
    }
 
  if (s == NULL || s->attr.flavor != FL_DERIVED)
    goto bad;
 
  /* Get rid of symbol sym, translating all references to s.  */
  for (i = 0; i < GFC_LETTERS; i++)
    {
      t = &sym->ns->default_type[i];
      if (t->u.derived == sym)
        t->u.derived = s;
    }
 
  st = gfc_find_symtree (sym->ns->sym_root, sym->name);
  st->n.sym = s;
 
  s->refs++;
 
  /* Unlink from list of modified symbols.  */
  gfc_commit_symbol (sym);
 
  switch_types (sym->ns->sym_root, sym, s);
 
  /* TODO: Also have to replace sym -> s in other lists like
     namelists, common lists and interface lists.  */
  gfc_free_symbol (sym);
 
  return s;
 
bad:
  gfc_error ("Derived type '%s' at %C is being used before it is defined",
             sym->name);
  return NULL;
}
 
 
/* Given a derived type node and a component name, try to locate the
   component structure.  Returns the NULL pointer if the component is
   not found or the components are private.  If noaccess is set, no access
   checks are done.  */
 
gfc_component *
gfc_find_component (gfc_symbol *sym, const char *name,
                    bool noaccess, bool silent)
{
  gfc_component *p;
 
  if (name == NULL || sym == NULL)
    return NULL;
 
  sym = gfc_use_derived (sym);
 
  if (sym == NULL)
    return NULL;
 
  for (p = sym->components; p; p = p->next)
    if (strcmp (p->name, name) == 0)
      break;
 
  if (p && sym->attr.use_assoc && !noaccess)
    {
      bool is_parent_comp = sym->attr.extension && (p == sym->components);
      if (p->attr.access == ACCESS_PRIVATE ||
          (p->attr.access != ACCESS_PUBLIC
           && sym->component_access == ACCESS_PRIVATE
           && !is_parent_comp))
        {
          if (!silent)
            gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
                       name, sym->name);
          return NULL;
        }
    }
 
  if (p == NULL
        && sym->attr.extension
        && sym->components->ts.type == BT_DERIVED)
    {
      p = gfc_find_component (sym->components->ts.u.derived, name,
                              noaccess, silent);
      /* Do not overwrite the error.  */
      if (p == NULL)
        return p;
    }
 
  if (p == NULL && !silent)
    gfc_error ("'%s' at %C is not a member of the '%s' structure",
               name, sym->name);
 
  return p;
}
 
 
/* Given a symbol, free all of the component structures and everything
   they point to.  */
 
static void
free_components (gfc_component *p)
{
  gfc_component *q;
 
  for (; p; p = q)
    {
      q = p->next;
 
      gfc_free_array_spec (p->as);
      gfc_free_expr (p->initializer);
 
      gfc_free_formal_arglist (p->formal);
      gfc_free_namespace (p->formal_ns);
 
      free (p);
    }
}
 
 
/******************** Statement label management ********************/
 
/* Comparison function for statement labels, used for managing the
   binary tree.  */
 
static int
compare_st_labels (void *a1, void *b1)
{
  int a = ((gfc_st_label *) a1)->value;
  int b = ((gfc_st_label *) b1)->value;
 
  return (b - a);
}
 
 
/* Free a single gfc_st_label structure, making sure the tree is not
   messed up.  This function is called only when some parse error
   occurs.  */
 
void
gfc_free_st_label (gfc_st_label *label)
{
 
  if (label == NULL)
    return;
 
  gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
 
  if (label->format != NULL)
    gfc_free_expr (label->format);
 
  free (label);
}
 
 
/* Free a whole tree of gfc_st_label structures.  */
 
static void
free_st_labels (gfc_st_label *label)
{
 
  if (label == NULL)
    return;
 
  free_st_labels (label->left);
  free_st_labels (label->right);
 
  if (label->format != NULL)
    gfc_free_expr (label->format);
  free (label);
}
 
 
/* Given a label number, search for and return a pointer to the label
   structure, creating it if it does not exist.  */
 
gfc_st_label *
gfc_get_st_label (int labelno)
{
  gfc_st_label *lp;
  gfc_namespace *ns;
 
  if (gfc_current_state () == COMP_DERIVED)
    ns = gfc_current_block ()->f2k_derived;
  else
    {
      /* Find the namespace of the scoping unit:
         If we're in a BLOCK construct, jump to the parent namespace.  */
      ns = gfc_current_ns;
      while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
        ns = ns->parent;
    }
 
  /* First see if the label is already in this namespace.  */
  lp = ns->st_labels;
  while (lp)
    {
      if (lp->value == labelno)
        return lp;
 
      if (lp->value < labelno)
        lp = lp->left;
      else
        lp = lp->right;
    }
 
  lp = XCNEW (gfc_st_label);
 
  lp->value = labelno;
  lp->defined = ST_LABEL_UNKNOWN;
  lp->referenced = ST_LABEL_UNKNOWN;
 
  gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);
 
  return lp;
}
 
 
/* Called when a statement with a statement label is about to be
   accepted.  We add the label to the list of the current namespace,
   making sure it hasn't been defined previously and referenced
   correctly.  */
 
void
gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
{
  int labelno;
 
  labelno = lp->value;
 
  if (lp->defined != ST_LABEL_UNKNOWN)
    gfc_error ("Duplicate statement label %d at %L and %L", labelno,
               &lp->where, label_locus);
  else
    {
      lp->where = *label_locus;
 
      switch (type)
        {
        case ST_LABEL_FORMAT:
          if (lp->referenced == ST_LABEL_TARGET)
            gfc_error ("Label %d at %C already referenced as branch target",
                       labelno);
          else
            lp->defined = ST_LABEL_FORMAT;
 
          break;
 
        case ST_LABEL_TARGET:
          if (lp->referenced == ST_LABEL_FORMAT)
            gfc_error ("Label %d at %C already referenced as a format label",
                       labelno);
          else
            lp->defined = ST_LABEL_TARGET;
 
          break;
 
        default:
          lp->defined = ST_LABEL_BAD_TARGET;
          lp->referenced = ST_LABEL_BAD_TARGET;
        }
    }
}
 
 
/* Reference a label.  Given a label and its type, see if that
   reference is consistent with what is known about that label,
   updating the unknown state.  Returns FAILURE if something goes
   wrong.  */
 
gfc_try
gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
{
  gfc_sl_type label_type;
  int labelno;
  gfc_try rc;
 
  if (lp == NULL)
    return SUCCESS;
 
  labelno = lp->value;
 
  if (lp->defined != ST_LABEL_UNKNOWN)
    label_type = lp->defined;
  else
    {
      label_type = lp->referenced;
      lp->where = gfc_current_locus;
    }
 
  if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
    {
      gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
      rc = FAILURE;
      goto done;
    }
 
  if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
      && type == ST_LABEL_FORMAT)
    {
      gfc_error ("Label %d at %C previously used as branch target", labelno);
      rc = FAILURE;
      goto done;
    }
 
  lp->referenced = type;
  rc = SUCCESS;
 
done:
  return rc;
}
 
 
/************** Symbol table management subroutines ****************/
 
/* Basic details: Fortran 95 requires a potentially unlimited number
   of distinct namespaces when compiling a program unit.  This case
   occurs during a compilation of internal subprograms because all of
   the internal subprograms must be read before we can start
   generating code for the host.
 
   Given the tricky nature of the Fortran grammar, we must be able to
   undo changes made to a symbol table if the current interpretation
   of a statement is found to be incorrect.  Whenever a symbol is
   looked up, we make a copy of it and link to it.  All of these
   symbols are kept in a singly linked list so that we can commit or
   undo the changes at a later time.
 
   A symtree may point to a symbol node outside of its namespace.  In
   this case, that symbol has been used as a host associated variable
   at some previous time.  */
 
/* Allocate a new namespace structure.  Copies the implicit types from
   PARENT if PARENT_TYPES is set.  */
 
gfc_namespace *
gfc_get_namespace (gfc_namespace *parent, int parent_types)
{
  gfc_namespace *ns;
  gfc_typespec *ts;
  int in;
  int i;
 
  ns = XCNEW (gfc_namespace);
  ns->sym_root = NULL;
  ns->uop_root = NULL;
  ns->tb_sym_root = NULL;
  ns->finalizers = NULL;
  ns->default_access = ACCESS_UNKNOWN;
  ns->parent = parent;
 
  for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
    {
      ns->operator_access[in] = ACCESS_UNKNOWN;
      ns->tb_op[in] = NULL;
    }
 
  /* Initialize default implicit types.  */
  for (i = 'a'; i <= 'z'; i++)
    {
      ns->set_flag[i - 'a'] = 0;
      ts = &ns->default_type[i - 'a'];
 
      if (parent_types && ns->parent != NULL)
        {
          /* Copy parent settings.  */
          *ts = ns->parent->default_type[i - 'a'];
          continue;
        }
 
      if (gfc_option.flag_implicit_none != 0)
        {
          gfc_clear_ts (ts);
          continue;
        }
 
      if ('i' <= i && i <= 'n')
        {
          ts->type = BT_INTEGER;
          ts->kind = gfc_default_integer_kind;
        }
      else
        {
          ts->type = BT_REAL;
          ts->kind = gfc_default_real_kind;
        }
    }
 
  ns->refs = 1;
 
  return ns;
}
 
 
/* Comparison function for symtree nodes.  */
 
static int
compare_symtree (void *_st1, void *_st2)
{
  gfc_symtree *st1, *st2;
 
  st1 = (gfc_symtree *) _st1;
  st2 = (gfc_symtree *) _st2;
 
  return strcmp (st1->name, st2->name);
}
 
 
/* Allocate a new symtree node and associate it with the new symbol.  */
 
gfc_symtree *
gfc_new_symtree (gfc_symtree **root, const char *name)
{
  gfc_symtree *st;
 
  st = XCNEW (gfc_symtree);
  st->name = gfc_get_string (name);
 
  gfc_insert_bbt (root, st, compare_symtree);
  return st;
}
 
 
/* Delete a symbol from the tree.  Does not free the symbol itself!  */
 
void
gfc_delete_symtree (gfc_symtree **root, const char *name)
{
  gfc_symtree st, *st0;
 
  st0 = gfc_find_symtree (*root, name);
 
  st.name = gfc_get_string (name);
  gfc_delete_bbt (root, &st, compare_symtree);
 
  free (st0);
}
 
 
/* Given a root symtree node and a name, try to find the symbol within
   the namespace.  Returns NULL if the symbol is not found.  */
 
gfc_symtree *
gfc_find_symtree (gfc_symtree *st, const char *name)
{
  int c;
 
  while (st != NULL)
    {
      c = strcmp (name, st->name);
      if (c == 0)
        return st;
 
      st = (c < 0) ? st->left : st->right;
    }
 
  return NULL;
}
 
 
/* Return a symtree node with a name that is guaranteed to be unique
   within the namespace and corresponds to an illegal fortran name.  */
 
gfc_symtree *
gfc_get_unique_symtree (gfc_namespace *ns)
{
  char name[GFC_MAX_SYMBOL_LEN + 1];
  static int serial = 0;
 
  sprintf (name, "@%d", serial++);
  return gfc_new_symtree (&ns->sym_root, name);
}
 
 
/* Given a name find a user operator node, creating it if it doesn't
   exist.  These are much simpler than symbols because they can't be
   ambiguous with one another.  */
 
gfc_user_op *
gfc_get_uop (const char *name)
{
  gfc_user_op *uop;
  gfc_symtree *st;
 
  st = gfc_find_symtree (gfc_current_ns->uop_root, name);
  if (st != NULL)
    return st->n.uop;
 
  st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
 
  uop = st->n.uop = XCNEW (gfc_user_op);
  uop->name = gfc_get_string (name);
  uop->access = ACCESS_UNKNOWN;
  uop->ns = gfc_current_ns;
 
  return uop;
}
 
 
/* Given a name find the user operator node.  Returns NULL if it does
   not exist.  */
 
gfc_user_op *
gfc_find_uop (const char *name, gfc_namespace *ns)
{
  gfc_symtree *st;
 
  if (ns == NULL)
    ns = gfc_current_ns;
 
  st = gfc_find_symtree (ns->uop_root, name);
  return (st == NULL) ? NULL : st->n.uop;
}
 
 
/* Remove a gfc_symbol structure and everything it points to.  */
 
void
gfc_free_symbol (gfc_symbol *sym)
{
 
  if (sym == NULL)
    return;
 
  gfc_free_array_spec (sym->as);
 
  free_components (sym->components);
 
  gfc_free_expr (sym->value);
 
  gfc_free_namelist (sym->namelist);
 
  gfc_free_namespace (sym->formal_ns);
 
  if (!sym->attr.generic_copy)
    gfc_free_interface (sym->generic);
 
  gfc_free_formal_arglist (sym->formal);
 
  gfc_free_namespace (sym->f2k_derived);
 
  free (sym);
}
 
 
/* Decrease the reference counter and free memory when we reach zero.  */
 
void
gfc_release_symbol (gfc_symbol *sym)
{
  if (sym == NULL)
    return;
 
  if (sym->formal_ns != NULL && sym->refs == 2)
    {
      /* As formal_ns contains a reference to sym, delete formal_ns just
         before the deletion of sym.  */
      gfc_namespace *ns = sym->formal_ns;
      sym->formal_ns = NULL;
      gfc_free_namespace (ns);
    }
 
  sym->refs--;
  if (sym->refs > 0)
    return;
 
  gcc_assert (sym->refs == 0);
  gfc_free_symbol (sym);
}
 
 
/* Allocate and initialize a new symbol node.  */
 
gfc_symbol *
gfc_new_symbol (const char *name, gfc_namespace *ns)
{
  gfc_symbol *p;
 
  p = XCNEW (gfc_symbol);
 
  gfc_clear_ts (&p->ts);
  gfc_clear_attr (&p->attr);
  p->ns = ns;
 
  p->declared_at = gfc_current_locus;
 
  if (strlen (name) > GFC_MAX_SYMBOL_LEN)
    gfc_internal_error ("new_symbol(): Symbol name too long");
 
  p->name = gfc_get_string (name);
 
  /* Make sure flags for symbol being C bound are clear initially.  */
  p->attr.is_bind_c = 0;
  p->attr.is_iso_c = 0;
 
  /* Clear the ptrs we may need.  */
  p->common_block = NULL;
  p->f2k_derived = NULL;
  p->assoc = NULL;
 
  return p;
}
 
 
/* Generate an error if a symbol is ambiguous.  */
 
static void
ambiguous_symbol (const char *name, gfc_symtree *st)
{
 
  if (st->n.sym->module)
    gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
               "from module '%s'", name, st->n.sym->name, st->n.sym->module);
  else
    gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
               "from current program unit", name, st->n.sym->name);
}
 
 
/* If we're in a SELECT TYPE block, check if the variable 'st' matches any
   selector on the stack. If yes, replace it by the corresponding temporary.  */
 
static void
select_type_insert_tmp (gfc_symtree **st)
{
  gfc_select_type_stack *stack = select_type_stack;
  for (; stack; stack = stack->prev)
    if ((*st)->n.sym == stack->selector && stack->tmp)
      *st = stack->tmp;
}
 
 
/* Look for a symtree in the current procedure -- that is, go up to
   parent namespaces but only if inside a BLOCK.  Returns NULL if not found.  */
 
gfc_symtree*
gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns)
{
  while (ns)
    {
      gfc_symtree* st = gfc_find_symtree (ns->sym_root, name);
      if (st)
        return st;
 
      if (!ns->construct_entities)
        break;
      ns = ns->parent;
    }
 
  return NULL;
}
 
 
/* Search for a symtree starting in the current namespace, resorting to
   any parent namespaces if requested by a nonzero parent_flag.
   Returns nonzero if the name is ambiguous.  */
 
int
gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
                   gfc_symtree **result)
{
  gfc_symtree *st;
 
  if (ns == NULL)
    ns = gfc_current_ns;
 
  do
    {
      st = gfc_find_symtree (ns->sym_root, name);
      if (st != NULL)
        {
          select_type_insert_tmp (&st);
 
          *result = st;
          /* Ambiguous generic interfaces are permitted, as long
             as the specific interfaces are different.  */
          if (st->ambiguous && !st->n.sym->attr.generic)
            {
              ambiguous_symbol (name, st);
              return 1;
            }
 
          return 0;
        }
 
      if (!parent_flag)
        break;
 
      ns = ns->parent;
    }
  while (ns != NULL);
 
  *result = NULL;
  return 0;
}
 
 
/* Same, but returns the symbol instead.  */
 
int
gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
                 gfc_symbol **result)
{
  gfc_symtree *st;
  int i;
 
  i = gfc_find_sym_tree (name, ns, parent_flag, &st);
 
  if (st == NULL)
    *result = NULL;
  else
    *result = st->n.sym;
 
  return i;
}
 
 
/* Save symbol with the information necessary to back it out.  */
 
static void
save_symbol_data (gfc_symbol *sym)
{
 
  if (sym->gfc_new || sym->old_symbol != NULL)
    return;
 
  sym->old_symbol = XCNEW (gfc_symbol);
  *(sym->old_symbol) = *sym;
 
  sym->tlink = changed_syms;
  changed_syms = sym;
}
 
 
/* Given a name, find a symbol, or create it if it does not exist yet
   in the current namespace.  If the symbol is found we make sure that
   it's OK.
 
   The integer return code indicates
 
     1   The symbol name was ambiguous
     2   The name meant to be established was already host associated.
 
   So if the return value is nonzero, then an error was issued.  */
 
int
gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
                  bool allow_subroutine)
{
  gfc_symtree *st;
  gfc_symbol *p;
 
  /* This doesn't usually happen during resolution.  */
  if (ns == NULL)
    ns = gfc_current_ns;
 
  /* Try to find the symbol in ns.  */
  st = gfc_find_symtree (ns->sym_root, name);
 
  if (st == NULL)
    {
      /* If not there, create a new symbol.  */
      p = gfc_new_symbol (name, ns);
 
      /* Add to the list of tentative symbols.  */
      p->old_symbol = NULL;
      p->tlink = changed_syms;
      p->mark = 1;
      p->gfc_new = 1;
      changed_syms = p;
 
      st = gfc_new_symtree (&ns->sym_root, name);
      st->n.sym = p;
      p->refs++;
 
    }
  else
    {
      /* Make sure the existing symbol is OK.  Ambiguous
         generic interfaces are permitted, as long as the
         specific interfaces are different.  */
      if (st->ambiguous && !st->n.sym->attr.generic)
        {
          ambiguous_symbol (name, st);
          return 1;
        }
 
      p = st->n.sym;
      if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
          && !(allow_subroutine && p->attr.subroutine)
          && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
          && (ns->has_import_set || p->attr.imported)))
        {
          /* Symbol is from another namespace.  */
          gfc_error ("Symbol '%s' at %C has already been host associated",
                     name);
          return 2;
        }
 
      p->mark = 1;
 
      /* Copy in case this symbol is changed.  */
      save_symbol_data (p);
    }
 
  *result = st;
  return 0;
}
 
 
int
gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
{
  gfc_symtree *st;
  int i;
 
  i = gfc_get_sym_tree (name, ns, &st, false);
  if (i != 0)
    return i;
 
  if (st)
    *result = st->n.sym;
  else
    *result = NULL;
  return i;
}
 
 
/* Subroutine that searches for a symbol, creating it if it doesn't
   exist, but tries to host-associate the symbol if possible.  */
 
int
gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
{
  gfc_symtree *st;
  int i;
 
  i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
 
  if (st != NULL)
    {
      save_symbol_data (st->n.sym);
      *result = st;
      return i;
    }
 
  if (gfc_current_ns->parent != NULL)
    {
      i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
      if (i)
        return i;
 
      if (st != NULL)
        {
          *result = st;
          return 0;
        }
    }
 
  return gfc_get_sym_tree (name, gfc_current_ns, result, false);
}
 
 
int
gfc_get_ha_symbol (const char *name, gfc_symbol **result)
{
  int i;
  gfc_symtree *st;
 
  i = gfc_get_ha_sym_tree (name, &st);
 
  if (st)
    *result = st->n.sym;
  else
    *result = NULL;
 
  return i;
}
 
/* Undoes all the changes made to symbols in the current statement.
   This subroutine is made simpler due to the fact that attributes are
   never removed once added.  */
 
void
gfc_undo_symbols (void)
{
  gfc_symbol *p, *q, *old;
  tentative_tbp *tbp, *tbq;
 
  for (p = changed_syms; p; p = q)
    {
      q = p->tlink;
 
      if (p->gfc_new)
        {
          /* Symbol was new.  */
          if (p->attr.in_common && p->common_block && p->common_block->head)
            {
              /* If the symbol was added to any common block, it
                 needs to be removed to stop the resolver looking
                 for a (possibly) dead symbol.  */
 
              if (p->common_block->head == p)
                p->common_block->head = p->common_next;
              else
                {
                  gfc_symbol *cparent, *csym;
 
                  cparent = p->common_block->head;
                  csym = cparent->common_next;
 
                  while (csym != p)
                    {
                      cparent = csym;
                      csym = csym->common_next;
                    }
 
                  gcc_assert(cparent->common_next == p);
 
                  cparent->common_next = csym->common_next;
                }
            }
 
          /* The derived type is saved in the symtree with the first
             letter capitalized; the all lower-case version to the
             derived type contains its associated generic function.  */
          if (p->attr.flavor == FL_DERIVED)
            gfc_delete_symtree (&p->ns->sym_root, gfc_get_string ("%c%s",
                        (char) TOUPPER ((unsigned char) p->name[0]),
                        &p->name[1]));
          else
            gfc_delete_symtree (&p->ns->sym_root, p->name);
 
          gfc_release_symbol (p);
          continue;
        }
 
      /* Restore previous state of symbol.  Just copy simple stuff.  */
      p->mark = 0;
      old = p->old_symbol;
 
      p->ts.type = old->ts.type;
      p->ts.kind = old->ts.kind;
 
      p->attr = old->attr;
 
      if (p->value != old->value)
        {
          gfc_free_expr (old->value);
          p->value = NULL;
        }
 
      if (p->as != old->as)
        {
          if (p->as)
            gfc_free_array_spec (p->as);
          p->as = old->as;
        }
 
      p->generic = old->generic;
      p->component_access = old->component_access;
 
      if (p->namelist != NULL && old->namelist == NULL)
        {
          gfc_free_namelist (p->namelist);
          p->namelist = NULL;
        }
      else
        {
          if (p->namelist_tail != old->namelist_tail)
            {
              gfc_free_namelist (old->namelist_tail);
              old->namelist_tail->next = NULL;
            }
        }
 
      p->namelist_tail = old->namelist_tail;
 
      if (p->formal != old->formal)
        {
          gfc_free_formal_arglist (p->formal);
          p->formal = old->formal;
        }
 
      free (p->old_symbol);
      p->old_symbol = NULL;
      p->tlink = NULL;
    }
 
  changed_syms = NULL;
 
  for (tbp = tentative_tbp_list; tbp; tbp = tbq)
    {
      tbq = tbp->next;
      /* Procedure is already marked `error' by default.  */
      free (tbp);
    }
  tentative_tbp_list = NULL;
}
 
 
/* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
   components of old_symbol that might need deallocation are the "allocatables"
   that are restored in gfc_undo_symbols(), with two exceptions: namelist and
   namelist_tail.  In case these differ between old_symbol and sym, it's just
   because sym->namelist has gotten a few more items.  */
 
static void
free_old_symbol (gfc_symbol *sym)
{
 
  if (sym->old_symbol == NULL)
    return;
 
  if (sym->old_symbol->as != sym->as)
    gfc_free_array_spec (sym->old_symbol->as);
 
  if (sym->old_symbol->value != sym->value)
    gfc_free_expr (sym->old_symbol->value);
 
  if (sym->old_symbol->formal != sym->formal)
    gfc_free_formal_arglist (sym->old_symbol->formal);
 
  free (sym->old_symbol);
  sym->old_symbol = NULL;
}
 
 
/* Makes the changes made in the current statement permanent-- gets
   rid of undo information.  */
 
void
gfc_commit_symbols (void)
{
  gfc_symbol *p, *q;
  tentative_tbp *tbp, *tbq;
 
  for (p = changed_syms; p; p = q)
    {
      q = p->tlink;
      p->tlink = NULL;
      p->mark = 0;
      p->gfc_new = 0;
      free_old_symbol (p);
    }
  changed_syms = NULL;
 
  for (tbp = tentative_tbp_list; tbp; tbp = tbq)
    {
      tbq = tbp->next;
      tbp->proc->error = 0;
      free (tbp);
    }
  tentative_tbp_list = NULL;
}
 
 
/* Makes the changes made in one symbol permanent -- gets rid of undo
   information.  */
 
void
gfc_commit_symbol (gfc_symbol *sym)
{
  gfc_symbol *p;
 
  if (changed_syms == sym)
    changed_syms = sym->tlink;
  else
    {
      for (p = changed_syms; p; p = p->tlink)
        if (p->tlink == sym)
          {
            p->tlink = sym->tlink;
            break;
          }
    }
 
  sym->tlink = NULL;
  sym->mark = 0;
  sym->gfc_new = 0;
 
  free_old_symbol (sym);
}
 
 
/* Recursively free trees containing type-bound procedures.  */
 
static void
free_tb_tree (gfc_symtree *t)
{
  if (t == NULL)
    return;
 
  free_tb_tree (t->left);
  free_tb_tree (t->right);
 
  /* TODO: Free type-bound procedure structs themselves; probably needs some
     sort of ref-counting mechanism.  */
 
  free (t);
}
 
 
/* Recursive function that deletes an entire tree and all the common
   head structures it points to.  */
 
static void
free_common_tree (gfc_symtree * common_tree)
{
  if (common_tree == NULL)
    return;
 
  free_common_tree (common_tree->left);
  free_common_tree (common_tree->right);
 
  free (common_tree);
}
 
 
/* Recursive function that deletes an entire tree and all the user
   operator nodes that it contains.  */
 
static void
free_uop_tree (gfc_symtree *uop_tree)
{
  if (uop_tree == NULL)
    return;
 
  free_uop_tree (uop_tree->left);
  free_uop_tree (uop_tree->right);
 
  gfc_free_interface (uop_tree->n.uop->op);
  free (uop_tree->n.uop);
  free (uop_tree);
}
 
 
/* Recursive function that deletes an entire tree and all the symbols
   that it contains.  */
 
static void
free_sym_tree (gfc_symtree *sym_tree)
{
  if (sym_tree == NULL)
    return;
 
  free_sym_tree (sym_tree->left);
  free_sym_tree (sym_tree->right);
 
  gfc_release_symbol (sym_tree->n.sym);
  free (sym_tree);
}
 
 
/* Free the derived type list.  */
 
void
gfc_free_dt_list (void)
{
  gfc_dt_list *dt, *n;
 
  for (dt = gfc_derived_types; dt; dt = n)
    {
      n = dt->next;
      free (dt);
    }
 
  gfc_derived_types = NULL;
}
 
 
/* Free the gfc_equiv_info's.  */
 
static void
gfc_free_equiv_infos (gfc_equiv_info *s)
{
  if (s == NULL)
    return;
  gfc_free_equiv_infos (s->next);
  free (s);
}
 
 
/* Free the gfc_equiv_lists.  */
 
static void
gfc_free_equiv_lists (gfc_equiv_list *l)
{
  if (l == NULL)
    return;
  gfc_free_equiv_lists (l->next);
  gfc_free_equiv_infos (l->equiv);
  free (l);
}
 
 
/* Free a finalizer procedure list.  */
 
void
gfc_free_finalizer (gfc_finalizer* el)
{
  if (el)
    {
      gfc_release_symbol (el->proc_sym);
      free (el);
    }
}
 
static void
gfc_free_finalizer_list (gfc_finalizer* list)
{
  while (list)
    {
      gfc_finalizer* current = list;
      list = list->next;
      gfc_free_finalizer (current);
    }
}
 
 
/* Create a new gfc_charlen structure and add it to a namespace.
   If 'old_cl' is given, the newly created charlen will be a copy of it.  */
 
gfc_charlen*
gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
{
  gfc_charlen *cl;
  cl = gfc_get_charlen ();
 
  /* Copy old_cl.  */
  if (old_cl)
    {
      /* Put into namespace, but don't allow reject_statement
         to free it if old_cl is given.  */
      gfc_charlen **prev = &ns->cl_list;
      cl->next = ns->old_cl_list;
      while (*prev != ns->old_cl_list)
        prev = &(*prev)->next;
      *prev = cl;
      ns->old_cl_list = cl;
      cl->length = gfc_copy_expr (old_cl->length);
      cl->length_from_typespec = old_cl->length_from_typespec;
      cl->backend_decl = old_cl->backend_decl;
      cl->passed_length = old_cl->passed_length;
      cl->resolved = old_cl->resolved;
    }
  else
    {
      /* Put into namespace.  */
      cl->next = ns->cl_list;
      ns->cl_list = cl;
    }
 
  return cl;
}
 
 
/* Free the charlen list from cl to end (end is not freed).
   Free the whole list if end is NULL.  */
 
void
gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
{
  gfc_charlen *cl2;
 
  for (; cl != end; cl = cl2)
    {
      gcc_assert (cl);
 
      cl2 = cl->next;
      gfc_free_expr (cl->length);
      free (cl);
    }
}
 
 
/* Free entry list structs.  */
 
static void
free_entry_list (gfc_entry_list *el)
{
  gfc_entry_list *next;
 
  if (el == NULL)
    return;
 
  next = el->next;
  free (el);
  free_entry_list (next);
}
 
 
/* Free a namespace structure and everything below it.  Interface
   lists associated with intrinsic operators are not freed.  These are
   taken care of when a specific name is freed.  */
 
void
gfc_free_namespace (gfc_namespace *ns)
{
  gfc_namespace *p, *q;
  int i;
 
  if (ns == NULL)
    return;
 
  ns->refs--;
  if (ns->refs > 0)
    return;
  gcc_assert (ns->refs == 0);
 
  gfc_free_statements (ns->code);
 
  free_sym_tree (ns->sym_root);
  free_uop_tree (ns->uop_root);
  free_common_tree (ns->common_root);
  free_tb_tree (ns->tb_sym_root);
  free_tb_tree (ns->tb_uop_root);
  gfc_free_finalizer_list (ns->finalizers);
  gfc_free_charlen (ns->cl_list, NULL);
  free_st_labels (ns->st_labels);
 
  free_entry_list (ns->entries);
  gfc_free_equiv (ns->equiv);
  gfc_free_equiv_lists (ns->equiv_lists);
  gfc_free_use_stmts (ns->use_stmts);
 
  for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
    gfc_free_interface (ns->op[i]);
 
  gfc_free_data (ns->data);
  p = ns->contained;
  free (ns);
 
  /* Recursively free any contained namespaces.  */
  while (p != NULL)
    {
      q = p;
      p = p->sibling;
      gfc_free_namespace (q);
    }
}
 
 
void
gfc_symbol_init_2 (void)
{
 
  gfc_current_ns = gfc_get_namespace (NULL, 0);
}
 
 
void
gfc_symbol_done_2 (void)
{
 
  gfc_free_namespace (gfc_current_ns);
  gfc_current_ns = NULL;
  gfc_free_dt_list ();
}
 
 
/* Count how many nodes a symtree has.  */
 
static unsigned
count_st_nodes (const gfc_symtree *st)
{
  unsigned nodes;
  if (!st)
    return 0;
 
  nodes = count_st_nodes (st->left);
  nodes++;
  nodes += count_st_nodes (st->right);
 
  return nodes;
}
 
 
/* Convert symtree tree into symtree vector.  */
 
static unsigned
fill_st_vector (gfc_symtree *st, gfc_symtree **st_vec, unsigned node_cntr)
{
  if (!st)
    return node_cntr;
 
  node_cntr = fill_st_vector (st->left, st_vec, node_cntr);
  st_vec[node_cntr++] = st;
  node_cntr = fill_st_vector (st->right, st_vec, node_cntr);
 
  return node_cntr;
}
 
 
/* Traverse namespace.  As the functions might modify the symtree, we store the
   symtree as a vector and operate on this vector.  Note: We assume that
   sym_func or st_func never deletes nodes from the symtree - only adding is
   allowed. Additionally, newly added nodes are not traversed.  */
 
static void
do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *),
                     void (*sym_func) (gfc_symbol *))
{
  gfc_symtree **st_vec;
  unsigned nodes, i, node_cntr;
 
  gcc_assert ((st_func && !sym_func) || (!st_func && sym_func));
  nodes = count_st_nodes (st);
  st_vec = XALLOCAVEC (gfc_symtree *, nodes);
  node_cntr = 0;
  fill_st_vector (st, st_vec, node_cntr);
 
  if (sym_func)
    {
      /* Clear marks.  */
      for (i = 0; i < nodes; i++)
        st_vec[i]->n.sym->mark = 0;
      for (i = 0; i < nodes; i++)
        if (!st_vec[i]->n.sym->mark)
          {
            (*sym_func) (st_vec[i]->n.sym);
            st_vec[i]->n.sym->mark = 1;
          }
     }
   else
      for (i = 0; i < nodes; i++)
        (*st_func) (st_vec[i]);
}
 
 
/* Recursively traverse the symtree nodes.  */
 
void
gfc_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *))
{
  do_traverse_symtree (st, st_func, NULL);
}
 
 
/* Call a given function for all symbols in the namespace.  We take
   care that each gfc_symbol node is called exactly once.  */
 
void
gfc_traverse_ns (gfc_namespace *ns, void (*sym_func) (gfc_symbol *))
{
  do_traverse_symtree (ns->sym_root, NULL, sym_func);
}
 
 
/* Return TRUE when name is the name of an intrinsic type.  */
 
bool
gfc_is_intrinsic_typename (const char *name)
{
  if (strcmp (name, "integer") == 0
      || strcmp (name, "real") == 0
      || strcmp (name, "character") == 0
      || strcmp (name, "logical") == 0
      || strcmp (name, "complex") == 0
      || strcmp (name, "doubleprecision") == 0
      || strcmp (name, "doublecomplex") == 0)
    return true;
  else
    return false;
}
 
 
/* Return TRUE if the symbol is an automatic variable.  */
 
static bool
gfc_is_var_automatic (gfc_symbol *sym)
{
  /* Pointer and allocatable variables are never automatic.  */
  if (sym->attr.pointer || sym->attr.allocatable)
    return false;
  /* Check for arrays with non-constant size.  */
  if (sym->attr.dimension && sym->as
      && !gfc_is_compile_time_shape (sym->as))
    return true;
  /* Check for non-constant length character variables.  */
  if (sym->ts.type == BT_CHARACTER
      && sym->ts.u.cl
      && !gfc_is_constant_expr (sym->ts.u.cl->length))
    return true;
  return false;
}
 
/* Given a symbol, mark it as SAVEd if it is allowed.  */
 
static void
save_symbol (gfc_symbol *sym)
{
 
  if (sym->attr.use_assoc)
    return;
 
  if (sym->attr.in_common
      || sym->attr.dummy
      || sym->attr.result
      || sym->attr.flavor != FL_VARIABLE)
    return;
  /* Automatic objects are not saved.  */
  if (gfc_is_var_automatic (sym))
    return;
  gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at);
}
 
 
/* Mark those symbols which can be SAVEd as such.  */
 
void
gfc_save_all (gfc_namespace *ns)
{
  gfc_traverse_ns (ns, save_symbol);
}
 
 
/* Make sure that no changes to symbols are pending.  */
 
void
gfc_enforce_clean_symbol_state(void)
{
  gcc_assert (changed_syms == NULL);
}
 
 
/************** Global symbol handling ************/
 
 
/* Search a tree for the global symbol.  */
 
gfc_gsymbol *
gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
{
  int c;
 
  if (symbol == NULL)
    return NULL;
 
  while (symbol)
    {
      c = strcmp (name, symbol->name);
      if (!c)
        return symbol;
 
      symbol = (c < 0) ? symbol->left : symbol->right;
    }
 
  return NULL;
}
 
 
/* Compare two global symbols. Used for managing the BB tree.  */
 
static int
gsym_compare (void *_s1, void *_s2)
{
  gfc_gsymbol *s1, *s2;
 
  s1 = (gfc_gsymbol *) _s1;
  s2 = (gfc_gsymbol *) _s2;
  return strcmp (s1->name, s2->name);
}
 
 
/* Get a global symbol, creating it if it doesn't exist.  */
 
gfc_gsymbol *
gfc_get_gsymbol (const char *name)
{
  gfc_gsymbol *s;
 
  s = gfc_find_gsymbol (gfc_gsym_root, name);
  if (s != NULL)
    return s;
 
  s = XCNEW (gfc_gsymbol);
  s->type = GSYM_UNKNOWN;
  s->name = gfc_get_string (name);
 
  gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
 
  return s;
}
 
 
static gfc_symbol *
get_iso_c_binding_dt (int sym_id)
{
  gfc_dt_list *dt_list;
 
  dt_list = gfc_derived_types;
 
  /* Loop through the derived types in the name list, searching for
     the desired symbol from iso_c_binding.  Search the parent namespaces
     if necessary and requested to (parent_flag).  */
  while (dt_list != NULL)
    {
      if (dt_list->derived->from_intmod != INTMOD_NONE
          && dt_list->derived->intmod_sym_id == sym_id)
        return dt_list->derived;
 
      dt_list = dt_list->next;
    }
 
  return NULL;
}
 
 
/* Verifies that the given derived type symbol, derived_sym, is interoperable
   with C.  This is necessary for any derived type that is BIND(C) and for
   derived types that are parameters to functions that are BIND(C).  All
   fields of the derived type are required to be interoperable, and are tested
   for such.  If an error occurs, the errors are reported here, allowing for
   multiple errors to be handled for a single derived type.  */
 
gfc_try
verify_bind_c_derived_type (gfc_symbol *derived_sym)
{
  gfc_component *curr_comp = NULL;
  gfc_try is_c_interop = FAILURE;
  gfc_try retval = SUCCESS;
 
  if (derived_sym == NULL)
    gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
                        "unexpectedly NULL");
 
  /* If we've already looked at this derived symbol, do not look at it again
     so we don't repeat warnings/errors.  */
  if (derived_sym->ts.is_c_interop)
    return SUCCESS;
 
  /* The derived type must have the BIND attribute to be interoperable
     J3/04-007, Section 15.2.3.  */
  if (derived_sym->attr.is_bind_c != 1)
    {
      derived_sym->ts.is_c_interop = 0;
      gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
                     "attribute to be C interoperable", derived_sym->name,
                     &(derived_sym->declared_at));
      retval = FAILURE;
    }
 
  curr_comp = derived_sym->components;
 
  /* Fortran 2003 allows an empty derived type.  C99 appears to disallow an
     empty struct.  Section 15.2 in Fortran 2003 states:  "The following
     subclauses define the conditions under which a Fortran entity is
     interoperable.  If a Fortran entity is interoperable, an equivalent
     entity may be defined by means of C and the Fortran entity is said
     to be interoperable with the C entity.  There does not have to be such
     an interoperating C entity."
  */
  if (curr_comp == NULL)
    {
      gfc_warning ("Derived type '%s' with BIND(C) attribute at %L is empty, "
                   "and may be inaccessible by the C companion processor",
                   derived_sym->name, &(derived_sym->declared_at));
      derived_sym->ts.is_c_interop = 1;
      derived_sym->attr.is_bind_c = 1;
      return SUCCESS;
    }
 
 
  /* Initialize the derived type as being C interoperable.
     If we find an error in the components, this will be set false.  */
  derived_sym->ts.is_c_interop = 1;
 
  /* Loop through the list of components to verify that the kind of
     each is a C interoperable type.  */
  do
    {
      /* The components cannot be pointers (fortran sense).
         J3/04-007, Section 15.2.3, C1505.      */
      if (curr_comp->attr.pointer != 0)
        {
          gfc_error ("Component '%s' at %L cannot have the "
                     "POINTER attribute because it is a member "
                     "of the BIND(C) derived type '%s' at %L",
                     curr_comp->name, &(curr_comp->loc),
                     derived_sym->name, &(derived_sym->declared_at));
          retval = FAILURE;
        }
 
      if (curr_comp->attr.proc_pointer != 0)
        {
          gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
                     " of the BIND(C) derived type '%s' at %L", curr_comp->name,
                     &curr_comp->loc, derived_sym->name,
                     &derived_sym->declared_at);
          retval = FAILURE;
        }
 
      /* The components cannot be allocatable.
         J3/04-007, Section 15.2.3, C1505.      */
      if (curr_comp->attr.allocatable != 0)
        {
          gfc_error ("Component '%s' at %L cannot have the "
                     "ALLOCATABLE attribute because it is a member "
                     "of the BIND(C) derived type '%s' at %L",
                     curr_comp->name, &(curr_comp->loc),
                     derived_sym->name, &(derived_sym->declared_at));
          retval = FAILURE;
        }
 
      /* BIND(C) derived types must have interoperable components.  */
      if (curr_comp->ts.type == BT_DERIVED
          && curr_comp->ts.u.derived->ts.is_iso_c != 1
          && curr_comp->ts.u.derived != derived_sym)
        {
          /* This should be allowed; the draft says a derived-type can not
             have type parameters if it is has the BIND attribute.  Type
             parameters seem to be for making parameterized derived types.
             There's no need to verify the type if it is c_ptr/c_funptr.  */
          retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
        }
      else
        {
          /* Grab the typespec for the given component and test the kind.  */
          is_c_interop = gfc_verify_c_interop (&(curr_comp->ts));
 
          if (is_c_interop != SUCCESS)
            {
              /* Report warning and continue since not fatal.  The
                 draft does specify a constraint that requires all fields
                 to interoperate, but if the user says real(4), etc., it
                 may interoperate with *something* in C, but the compiler
                 most likely won't know exactly what.  Further, it may not
                 interoperate with the same data type(s) in C if the user
                 recompiles with different flags (e.g., -m32 and -m64 on
                 x86_64 and using integer(4) to claim interop with a
                 C_LONG).  */
              if (derived_sym->attr.is_bind_c == 1)
                /* If the derived type is bind(c), all fields must be
                   interop.  */
                gfc_warning ("Component '%s' in derived type '%s' at %L "
                             "may not be C interoperable, even though "
                             "derived type '%s' is BIND(C)",
                             curr_comp->name, derived_sym->name,
                             &(curr_comp->loc), derived_sym->name);
              else
                /* If derived type is param to bind(c) routine, or to one
                   of the iso_c_binding procs, it must be interoperable, so
                   all fields must interop too.  */
                gfc_warning ("Component '%s' in derived type '%s' at %L "
                             "may not be C interoperable",
                             curr_comp->name, derived_sym->name,
                             &(curr_comp->loc));
            }
        }
 
      curr_comp = curr_comp->next;
    } while (curr_comp != NULL);
 
 
  /* Make sure we don't have conflicts with the attributes.  */
  if (derived_sym->attr.access == ACCESS_PRIVATE)
    {
      gfc_error ("Derived type '%s' at %L cannot be declared with both "
                 "PRIVATE and BIND(C) attributes", derived_sym->name,
                 &(derived_sym->declared_at));
      retval = FAILURE;
    }
 
  if (derived_sym->attr.sequence != 0)
    {
      gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
                 "attribute because it is BIND(C)", derived_sym->name,
                 &(derived_sym->declared_at));
      retval = FAILURE;
    }
 
  /* Mark the derived type as not being C interoperable if we found an
     error.  If there were only warnings, proceed with the assumption
     it's interoperable.  */
  if (retval == FAILURE)
    derived_sym->ts.is_c_interop = 0;
 
  return retval;
}
 
 
/* Generate symbols for the named constants c_null_ptr and c_null_funptr.  */
 
static gfc_try
gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
                           const char *module_name)
{
  gfc_symtree *tmp_symtree;
  gfc_symbol *tmp_sym;
  gfc_constructor *c;
 
  tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
 
  if (tmp_symtree != NULL)
    tmp_sym = tmp_symtree->n.sym;
  else
    {
      tmp_sym = NULL;
      gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
                          "create symbol for %s", ptr_name);
    }
 
  tmp_sym->ts.is_c_interop = 1;
  tmp_sym->attr.is_c_interop = 1;
  tmp_sym->ts.is_iso_c = 1;
  tmp_sym->ts.type = BT_DERIVED;
  tmp_sym->attr.flavor = FL_PARAMETER;
 
  /* The c_ptr and c_funptr derived types will provide the
     definition for c_null_ptr and c_null_funptr, respectively.  */
  if (ptr_id == ISOCBINDING_NULL_PTR)
    tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
  else
    tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
  if (tmp_sym->ts.u.derived == NULL)
    {
      /* This can occur if the user forgot to declare c_ptr or
         c_funptr and they're trying to use one of the procedures
         that has arg(s) of the missing type.  In this case, a
         regular version of the thing should have been put in the
         current ns.  */
 
      generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
                                   ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
                                   (const char *) (ptr_id == ISOCBINDING_NULL_PTR
                                   ? "c_ptr"
                                   : "c_funptr"));
      tmp_sym->ts.u.derived =
        get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
                              ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
    }
 
  /* Module name is some mangled version of iso_c_binding.  */
  tmp_sym->module = gfc_get_string (module_name);
 
  /* Say it's from the iso_c_binding module.  */
  tmp_sym->attr.is_iso_c = 1;
 
  tmp_sym->attr.use_assoc = 1;
  tmp_sym->attr.is_bind_c = 1;
  /* Since we never generate a call to this symbol, don't set the
     binding_label.  */
 
  /* Set the c_address field of c_null_ptr and c_null_funptr to
     the value of NULL.  */
  tmp_sym->value = gfc_get_expr ();
  tmp_sym->value->expr_type = EXPR_STRUCTURE;
  tmp_sym->value->ts.type = BT_DERIVED;
  tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
  gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
  c = gfc_constructor_first (tmp_sym->value->value.constructor);
  c->expr = gfc_get_expr ();
  c->expr->expr_type = EXPR_NULL;
  c->expr->ts.is_iso_c = 1;
 
  return SUCCESS;
}
 
 
/* Add a formal argument, gfc_formal_arglist, to the
   end of the given list of arguments.  Set the reference to the
   provided symbol, param_sym, in the argument.  */
 
static void
add_formal_arg (gfc_formal_arglist **head,
                gfc_formal_arglist **tail,
                gfc_formal_arglist *formal_arg,
                gfc_symbol *param_sym)
{
  /* Put in list, either as first arg or at the tail (curr arg).  */
  if (*head == NULL)
    *head = *tail = formal_arg;
  else
    {
      (*tail)->next = formal_arg;
      (*tail) = formal_arg;
    }
 
  (*tail)->sym = param_sym;
  (*tail)->next = NULL;
 
  return;
}
 
 
/* Generates a symbol representing the CPTR argument to an
   iso_c_binding procedure.  Also, create a gfc_formal_arglist for the
   CPTR and add it to the provided argument list.  */
 
static void
gen_cptr_param (gfc_formal_arglist **head,
                gfc_formal_arglist **tail,
                const char *module_name,
                gfc_namespace *ns, const char *c_ptr_name,
                int iso_c_sym_id)
{
  gfc_symbol *param_sym = NULL;
  gfc_symbol *c_ptr_sym = NULL;
  gfc_symtree *param_symtree = NULL;
  gfc_formal_arglist *formal_arg = NULL;
  const char *c_ptr_in;
  const char *c_ptr_type = NULL;
 
  if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
    c_ptr_type = "c_funptr";
  else
    c_ptr_type = "c_ptr";
 
  if(c_ptr_name == NULL)
    c_ptr_in = "gfc_cptr__";
  else
    c_ptr_in = c_ptr_name;
  gfc_get_sym_tree (c_ptr_in, ns, &param_symtree, false);
  if (param_symtree != NULL)
    param_sym = param_symtree->n.sym;
  else
    gfc_internal_error ("gen_cptr_param(): Unable to "
                        "create symbol for %s", c_ptr_in);
 
  /* Set up the appropriate fields for the new c_ptr param sym.  */
  param_sym->refs++;
  param_sym->attr.flavor = FL_DERIVED;
  param_sym->ts.type = BT_DERIVED;
  param_sym->attr.intent = INTENT_IN;
  param_sym->attr.dummy = 1;
 
  /* This will pass the ptr to the iso_c routines as a (void *).  */
  param_sym->attr.value = 1;
  param_sym->attr.use_assoc = 1;
 
  /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
     (user renamed).  */
  if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
    c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
  else
    c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
  if (c_ptr_sym == NULL)
    {
      /* This can happen if the user did not define c_ptr but they are
         trying to use one of the iso_c_binding functions that need it.  */
      if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
        generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
                                     (const char *)c_ptr_type);
      else
        generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
                                     (const char *)c_ptr_type);
 
      gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
    }
 
  param_sym->ts.u.derived = c_ptr_sym;
  param_sym->module = gfc_get_string (module_name);
 
  /* Make new formal arg.  */
  formal_arg = gfc_get_formal_arglist ();
  /* Add arg to list of formal args (the CPTR arg).  */
  add_formal_arg (head, tail, formal_arg, param_sym);
 
  /* Validate changes.  */
  gfc_commit_symbol (param_sym);
}
 
 
/* Generates a symbol representing the FPTR argument to an
   iso_c_binding procedure.  Also, create a gfc_formal_arglist for the
   FPTR and add it to the provided argument list.  */
 
static void
gen_fptr_param (gfc_formal_arglist **head,
                gfc_formal_arglist **tail,
                const char *module_name,
                gfc_namespace *ns, const char *f_ptr_name, int proc)
{
  gfc_symbol *param_sym = NULL;
  gfc_symtree *param_symtree = NULL;
  gfc_formal_arglist *formal_arg = NULL;
  const char *f_ptr_out = "gfc_fptr__";
 
  if (f_ptr_name != NULL)
    f_ptr_out = f_ptr_name;
 
  gfc_get_sym_tree (f_ptr_out, ns, &param_symtree, false);
  if (param_symtree != NULL)
    param_sym = param_symtree->n.sym;
  else
    gfc_internal_error ("generateFPtrParam(): Unable to "
                        "create symbol for %s", f_ptr_out);
 
  /* Set up the necessary fields for the fptr output param sym.  */
  param_sym->refs++;
  if (proc)
    param_sym->attr.proc_pointer = 1;
  else
    param_sym->attr.pointer = 1;
  param_sym->attr.dummy = 1;
  param_sym->attr.use_assoc = 1;
 
  /* ISO C Binding type to allow any pointer type as actual param.  */
  param_sym->ts.type = BT_VOID;
  param_sym->module = gfc_get_string (module_name);
 
  /* Make the arg.  */
  formal_arg = gfc_get_formal_arglist ();
  /* Add arg to list of formal args.  */
  add_formal_arg (head, tail, formal_arg, param_sym);
 
  /* Validate changes.  */
  gfc_commit_symbol (param_sym);
}
 
 
/* Generates a symbol representing the optional SHAPE argument for the
   iso_c_binding c_f_pointer() procedure.  Also, create a
   gfc_formal_arglist for the SHAPE and add it to the provided
   argument list.  */
 
static void
gen_shape_param (gfc_formal_arglist **head,
                 gfc_formal_arglist **tail,
                 const char *module_name,
                 gfc_namespace *ns, const char *shape_param_name)
{
  gfc_symbol *param_sym = NULL;
  gfc_symtree *param_symtree = NULL;
  gfc_formal_arglist *formal_arg = NULL;
  const char *shape_param = "gfc_shape_array__";
 
  if (shape_param_name != NULL)
    shape_param = shape_param_name;
 
  gfc_get_sym_tree (shape_param, ns, &param_symtree, false);
  if (param_symtree != NULL)
    param_sym = param_symtree->n.sym;
  else
    gfc_internal_error ("generateShapeParam(): Unable to "
                        "create symbol for %s", shape_param);
 
  /* Set up the necessary fields for the shape input param sym.  */
  param_sym->refs++;
  param_sym->attr.dummy = 1;
  param_sym->attr.use_assoc = 1;
 
  /* Integer array, rank 1, describing the shape of the object.  Make it's
     type BT_VOID initially so we can accept any type/kind combination of
     integer.  During gfc_iso_c_sub_interface (resolve.c), we'll make it
     of BT_INTEGER type.  */
  param_sym->ts.type = BT_VOID;
 
  /* Initialize the kind to default integer.  However, it will be overridden
     during resolution to match the kind of the SHAPE parameter given as
     the actual argument (to allow for any valid integer kind).  */
  param_sym->ts.kind = gfc_default_integer_kind;
  param_sym->as = gfc_get_array_spec ();
 
  param_sym->as->rank = 1;
  param_sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
                                              NULL, 1);
 
  /* The extent is unknown until we get it.  The length give us
     the rank the incoming pointer.  */
  param_sym->as->type = AS_ASSUMED_SHAPE;
 
  /* The arg is also optional; it is required iff the second arg
     (fptr) is to an array, otherwise, it's ignored.  */
  param_sym->attr.optional = 1;
  param_sym->attr.intent = INTENT_IN;
  param_sym->attr.dimension = 1;
  param_sym->module = gfc_get_string (module_name);
 
  /* Make the arg.  */
  formal_arg = gfc_get_formal_arglist ();
  /* Add arg to list of formal args.  */
  add_formal_arg (head, tail, formal_arg, param_sym);
 
  /* Validate changes.  */
  gfc_commit_symbol (param_sym);
}
 
 
/* Add a procedure interface to the given symbol (i.e., store a
   reference to the list of formal arguments).  */
 
static void
add_proc_interface (gfc_symbol *sym, ifsrc source,
                    gfc_formal_arglist *formal)
{
 
  sym->formal = formal;
  sym->attr.if_source = source;
}
 
 
/* Copy the formal args from an existing symbol, src, into a new
   symbol, dest.  New formal args are created, and the description of
   each arg is set according to the existing ones.  This function is
   used when creating procedure declaration variables from a procedure
   declaration statement (see match_proc_decl()) to create the formal
   args based on the args of a given named interface.  */
 
void
gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
{
  gfc_formal_arglist *head = NULL;
  gfc_formal_arglist *tail = NULL;
  gfc_formal_arglist *formal_arg = NULL;
  gfc_formal_arglist *curr_arg = NULL;
  gfc_formal_arglist *formal_prev = NULL;
  /* Save current namespace so we can change it for formal args.  */
  gfc_namespace *parent_ns = gfc_current_ns;
 
  /* Create a new namespace, which will be the formal ns (namespace
     of the formal args).  */
  gfc_current_ns = gfc_get_namespace (parent_ns, 0);
  gfc_current_ns->proc_name = dest;
 
  for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
    {
      formal_arg = gfc_get_formal_arglist ();
      gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
 
      /* May need to copy more info for the symbol.  */
      formal_arg->sym->attr = curr_arg->sym->attr;
      formal_arg->sym->ts = curr_arg->sym->ts;
      formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
      gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
 
      /* If this isn't the first arg, set up the next ptr.  For the
        last arg built, the formal_arg->next will never get set to
        anything other than NULL.  */
      if (formal_prev != NULL)
        formal_prev->next = formal_arg;
      else
        formal_arg->next = NULL;
 
      formal_prev = formal_arg;
 
      /* Add arg to list of formal args.  */
      add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
 
      /* Validate changes.  */
      gfc_commit_symbol (formal_arg->sym);
    }
 
  /* Add the interface to the symbol.  */
  add_proc_interface (dest, IFSRC_DECL, head);
 
  /* Store the formal namespace information.  */
  if (dest->formal != NULL)
    /* The current ns should be that for the dest proc.  */
    dest->formal_ns = gfc_current_ns;
  /* Restore the current namespace to what it was on entry.  */
  gfc_current_ns = parent_ns;
}
 
 
void
gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
{
  gfc_formal_arglist *head = NULL;
  gfc_formal_arglist *tail = NULL;
  gfc_formal_arglist *formal_arg = NULL;
  gfc_intrinsic_arg *curr_arg = NULL;
  gfc_formal_arglist *formal_prev = NULL;
  /* Save current namespace so we can change it for formal args.  */
  gfc_namespace *parent_ns = gfc_current_ns;
 
  /* Create a new namespace, which will be the formal ns (namespace
     of the formal args).  */
  gfc_current_ns = gfc_get_namespace (parent_ns, 0);
  gfc_current_ns->proc_name = dest;
 
  for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
    {
      formal_arg = gfc_get_formal_arglist ();
      gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
 
      /* May need to copy more info for the symbol.  */
      formal_arg->sym->ts = curr_arg->ts;
      formal_arg->sym->attr.optional = curr_arg->optional;
      formal_arg->sym->attr.value = curr_arg->value;
      formal_arg->sym->attr.intent = curr_arg->intent;
      formal_arg->sym->attr.flavor = FL_VARIABLE;
      formal_arg->sym->attr.dummy = 1;
 
      if (formal_arg->sym->ts.type == BT_CHARACTER)
        formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
 
      /* If this isn't the first arg, set up the next ptr.  For the
        last arg built, the formal_arg->next will never get set to
        anything other than NULL.  */
      if (formal_prev != NULL)
        formal_prev->next = formal_arg;
      else
        formal_arg->next = NULL;
 
      formal_prev = formal_arg;
 
      /* Add arg to list of formal args.  */
      add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
 
      /* Validate changes.  */
      gfc_commit_symbol (formal_arg->sym);
    }
 
  /* Add the interface to the symbol.  */
  add_proc_interface (dest, IFSRC_DECL, head);
 
  /* Store the formal namespace information.  */
  if (dest->formal != NULL)
    /* The current ns should be that for the dest proc.  */
    dest->formal_ns = gfc_current_ns;
  /* Restore the current namespace to what it was on entry.  */
  gfc_current_ns = parent_ns;
}
 
 
void
gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src)
{
  gfc_formal_arglist *head = NULL;
  gfc_formal_arglist *tail = NULL;
  gfc_formal_arglist *formal_arg = NULL;
  gfc_formal_arglist *curr_arg = NULL;
  gfc_formal_arglist *formal_prev = NULL;
  /* Save current namespace so we can change it for formal args.  */
  gfc_namespace *parent_ns = gfc_current_ns;
 
  /* Create a new namespace, which will be the formal ns (namespace
     of the formal args).  */
  gfc_current_ns = gfc_get_namespace (parent_ns, 0);
  /* TODO: gfc_current_ns->proc_name = dest;*/
 
  for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
    {
      formal_arg = gfc_get_formal_arglist ();
      gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
 
      /* May need to copy more info for the symbol.  */
      formal_arg->sym->attr = curr_arg->sym->attr;
      formal_arg->sym->ts = curr_arg->sym->ts;
      formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
      gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
 
      /* If this isn't the first arg, set up the next ptr.  For the
        last arg built, the formal_arg->next will never get set to
        anything other than NULL.  */
      if (formal_prev != NULL)
        formal_prev->next = formal_arg;
      else
        formal_arg->next = NULL;
 
      formal_prev = formal_arg;
 
      /* Add arg to list of formal args.  */
      add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
 
      /* Validate changes.  */
      gfc_commit_symbol (formal_arg->sym);
    }
 
  /* Add the interface to the symbol.  */
  gfc_free_formal_arglist (dest->formal);
  dest->formal = head;
  dest->attr.if_source = IFSRC_DECL;
 
  /* Store the formal namespace information.  */
  if (dest->formal != NULL)
    /* The current ns should be that for the dest proc.  */
    dest->formal_ns = gfc_current_ns;
  /* Restore the current namespace to what it was on entry.  */
  gfc_current_ns = parent_ns;
}
 
 
/* Builds the parameter list for the iso_c_binding procedure
   c_f_pointer or c_f_procpointer.  The old_sym typically refers to a
   generic version of either the c_f_pointer or c_f_procpointer
   functions.  The new_proc_sym represents a "resolved" version of the
   symbol.  The functions are resolved to match the types of their
   parameters; for example, c_f_pointer(cptr, fptr) would resolve to
   something similar to c_f_pointer_i4 if the type of data object fptr
   pointed to was a default integer.  The actual name of the resolved
   procedure symbol is further mangled with the module name, etc., but
   the idea holds true.  */
 
static void
build_formal_args (gfc_symbol *new_proc_sym,
                   gfc_symbol *old_sym, int add_optional_arg)
{
  gfc_formal_arglist *head = NULL, *tail = NULL;
  gfc_namespace *parent_ns = NULL;
 
  parent_ns = gfc_current_ns;
  /* Create a new namespace, which will be the formal ns (namespace
     of the formal args).  */
  gfc_current_ns = gfc_get_namespace(parent_ns, 0);
  gfc_current_ns->proc_name = new_proc_sym;
 
  /* Generate the params.  */
  if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
    {
      gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
                      gfc_current_ns, "cptr", old_sym->intmod_sym_id);
      gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
                      gfc_current_ns, "fptr", 1);
    }
  else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
    {
      gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
                      gfc_current_ns, "cptr", old_sym->intmod_sym_id);
      gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
                      gfc_current_ns, "fptr", 0);
      /* If we're dealing with c_f_pointer, it has an optional third arg.  */
      gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
                       gfc_current_ns, "shape");
 
    }
  else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
    {
      /* c_associated has one required arg and one optional; both
         are c_ptrs.  */
      gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
                      gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
      if (add_optional_arg)
        {
          gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
                          gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
          /* The last param is optional so mark it as such.  */
          tail->sym->attr.optional = 1;
        }
    }
 
  /* Add the interface (store formal args to new_proc_sym).  */
  add_proc_interface (new_proc_sym, IFSRC_DECL, head);
 
  /* Set up the formal_ns pointer to the one created for the
     new procedure so it'll get cleaned up during gfc_free_symbol().  */
  new_proc_sym->formal_ns = gfc_current_ns;
 
  gfc_current_ns = parent_ns;
}
 
static int
std_for_isocbinding_symbol (int id)
{
  switch (id)
    {
#define NAMED_INTCST(a,b,c,d) \
      case a:\
        return d;
#include "iso-c-binding.def"
#undef NAMED_INTCST
 
#define NAMED_FUNCTION(a,b,c,d) \
      case a:\
        return d;
#include "iso-c-binding.def"
#undef NAMED_FUNCTION
 
       default:
         return GFC_STD_F2003;
    }
}
 
/* Generate the given set of C interoperable kind objects, or all
   interoperable kinds.  This function will only be given kind objects
   for valid iso_c_binding defined types because this is verified when
   the 'use' statement is parsed.  If the user gives an 'only' clause,
   the specific kinds are looked up; if they don't exist, an error is
   reported.  If the user does not give an 'only' clause, all
   iso_c_binding symbols are generated.  If a list of specific kinds
   is given, it must have a NULL in the first empty spot to mark the
   end of the list.  */
 
 
void
generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
                             const char *local_name)
{
  const char *const name = (local_name && local_name[0]) ? local_name
                                             : c_interop_kinds_table[s].name;
  gfc_symtree *tmp_symtree = NULL;
  gfc_symbol *tmp_sym = NULL;
  int index;
 
  if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
    return;
 
  tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
 
  /* Already exists in this scope so don't re-add it. */
  if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL
      && (!tmp_sym->attr.generic
          || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL)
      && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING)
    {
      if (tmp_sym->attr.flavor == FL_DERIVED
          && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id))
        {
          gfc_dt_list *dt_list;
          dt_list = gfc_get_dt_list ();
          dt_list->derived = tmp_sym;
          dt_list->next = gfc_derived_types;
          gfc_derived_types = dt_list;
        }
 
      return;
    }
 
  /* Create the sym tree in the current ns.  */
  gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
  if (tmp_symtree)
    tmp_sym = tmp_symtree->n.sym;
  else
    gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
                        "create symbol");
 
  /* Say what module this symbol belongs to.  */
  tmp_sym->module = gfc_get_string (mod_name);
  tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
  tmp_sym->intmod_sym_id = s;
 
  switch (s)
    {
 
#define NAMED_INTCST(a,b,c,d) case a : 
#define NAMED_REALCST(a,b,c,d) case a :
#define NAMED_CMPXCST(a,b,c,d) case a :
#define NAMED_LOGCST(a,b,c) case a :
#define NAMED_CHARKNDCST(a,b,c) case a :
#include "iso-c-binding.def"
 
        tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL,
                                           c_interop_kinds_table[s].value);
 
        /* Initialize an integer constant expression node.  */
        tmp_sym->attr.flavor = FL_PARAMETER;
        tmp_sym->ts.type = BT_INTEGER;
        tmp_sym->ts.kind = gfc_default_integer_kind;
 
        /* Mark this type as a C interoperable one.  */
        tmp_sym->ts.is_c_interop = 1;
        tmp_sym->ts.is_iso_c = 1;
        tmp_sym->value->ts.is_c_interop = 1;
        tmp_sym->value->ts.is_iso_c = 1;
        tmp_sym->attr.is_c_interop = 1;
 
        /* Tell what f90 type this c interop kind is valid.  */
        tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
 
        /* Say it's from the iso_c_binding module.  */
        tmp_sym->attr.is_iso_c = 1;
 
        /* Make it use associated.  */
        tmp_sym->attr.use_assoc = 1;
        break;
 
 
#define NAMED_CHARCST(a,b,c) case a :
#include "iso-c-binding.def"
 
        /* Initialize an integer constant expression node for the
           length of the character.  */
        tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
                                                 &gfc_current_locus, NULL, 1);
        tmp_sym->value->ts.is_c_interop = 1;
        tmp_sym->value->ts.is_iso_c = 1;
        tmp_sym->value->value.character.length = 1;
        tmp_sym->value->value.character.string[0]
          = (gfc_char_t) c_interop_kinds_table[s].value;
        tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
        tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
                                                     NULL, 1);
 
        /* May not need this in both attr and ts, but do need in
           attr for writing module file.  */
        tmp_sym->attr.is_c_interop = 1;
 
        tmp_sym->attr.flavor = FL_PARAMETER;
        tmp_sym->ts.type = BT_CHARACTER;
 
        /* Need to set it to the C_CHAR kind.  */
        tmp_sym->ts.kind = gfc_default_character_kind;
 
        /* Mark this type as a C interoperable one.  */
        tmp_sym->ts.is_c_interop = 1;
        tmp_sym->ts.is_iso_c = 1;
 
        /* Tell what f90 type this c interop kind is valid.  */
        tmp_sym->ts.f90_type = BT_CHARACTER;
 
        /* Say it's from the iso_c_binding module.  */
        tmp_sym->attr.is_iso_c = 1;
 
        /* Make it use associated.  */
        tmp_sym->attr.use_assoc = 1;
        break;
 
      case ISOCBINDING_PTR:
      case ISOCBINDING_FUNPTR:
        {
          gfc_interface *intr, *head;
          gfc_symbol *dt_sym;
          const char *hidden_name;
          gfc_dt_list **dt_list_ptr = NULL;
          gfc_component *tmp_comp = NULL;
          char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
 
          hidden_name = gfc_get_string ("%c%s",
                            (char) TOUPPER ((unsigned char) tmp_sym->name[0]),
                            &tmp_sym->name[1]);
 
          /* Generate real derived type.  */
          tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
                                          hidden_name);
 
          if (tmp_symtree != NULL)
            gcc_unreachable ();
          gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
          if (tmp_symtree)
            dt_sym = tmp_symtree->n.sym;
          else
            gcc_unreachable ();
 
          /* Generate an artificial generic function.  */
          dt_sym->name = gfc_get_string (tmp_sym->name);
          head = tmp_sym->generic;
          intr = gfc_get_interface ();
          intr->sym = dt_sym;
          intr->where = gfc_current_locus;
          intr->next = head;
          tmp_sym->generic = intr;
 
          if (!tmp_sym->attr.generic
              && gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL)
                 == FAILURE)
            return;
 
          if (!tmp_sym->attr.function
              && gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL)
                 == FAILURE)
            return;
 
          /* Say what module this symbol belongs to.  */
          dt_sym->module = gfc_get_string (mod_name);
          dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
          dt_sym->intmod_sym_id = s;
 
          /* Initialize an integer constant expression node.  */
          dt_sym->attr.flavor = FL_DERIVED;
          dt_sym->ts.is_c_interop = 1;
          dt_sym->attr.is_c_interop = 1;
          dt_sym->attr.is_iso_c = 1;
          dt_sym->ts.is_iso_c = 1;
          dt_sym->ts.type = BT_DERIVED;
 
          /* A derived type must have the bind attribute to be
             interoperable (J3/04-007, Section 15.2.3), even though
             the binding label is not used.  */
          dt_sym->attr.is_bind_c = 1;
 
          dt_sym->attr.referenced = 1;
          dt_sym->ts.u.derived = dt_sym;
 
          /* Add the symbol created for the derived type to the current ns.  */
          dt_list_ptr = &(gfc_derived_types);
          while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
            dt_list_ptr = &((*dt_list_ptr)->next);
 
          /* There is already at least one derived type in the list, so append
             the one we're currently building for c_ptr or c_funptr.  */
          if (*dt_list_ptr != NULL)
            dt_list_ptr = &((*dt_list_ptr)->next);
          (*dt_list_ptr) = gfc_get_dt_list ();
          (*dt_list_ptr)->derived = dt_sym;
          (*dt_list_ptr)->next = NULL;
 
          /* Set up the component of the derived type, which will be
             an integer with kind equal to c_ptr_size.  Mangle the name of
             the field for the c_address to prevent the curious user from
             trying to access it from Fortran.  */
          sprintf (comp_name, "__%s_%s", dt_sym->name, "c_address");
          gfc_add_component (dt_sym, comp_name, &tmp_comp);
          if (tmp_comp == NULL)
          gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
                              "create component for c_address");
 
          tmp_comp->ts.type = BT_INTEGER;
 
          /* Set this because the module will need to read/write this field.  */
          tmp_comp->ts.f90_type = BT_INTEGER;
 
          /* The kinds for c_ptr and c_funptr are the same.  */
          index = get_c_kind ("c_ptr", c_interop_kinds_table);
          tmp_comp->ts.kind = c_interop_kinds_table[index].value;
 
          tmp_comp->attr.pointer = 0;
          tmp_comp->attr.dimension = 0;
 
          /* Mark the component as C interoperable.  */
          tmp_comp->ts.is_c_interop = 1;
 
          /* Make it use associated (iso_c_binding module).  */
          dt_sym->attr.use_assoc = 1;
        }
 
        break;
 
      case ISOCBINDING_NULL_PTR:
      case ISOCBINDING_NULL_FUNPTR:
        gen_special_c_interop_ptr (s, name, mod_name);
        break;
 
      case ISOCBINDING_F_POINTER:
      case ISOCBINDING_ASSOCIATED:
      case ISOCBINDING_LOC:
      case ISOCBINDING_FUNLOC:
      case ISOCBINDING_F_PROCPOINTER:
 
        tmp_sym->attr.proc = PROC_MODULE;
 
        /* Use the procedure's name as it is in the iso_c_binding module for
           setting the binding label in case the user renamed the symbol.  */
        tmp_sym->binding_label =
          gfc_get_string ("%s_%s", mod_name,
                          c_interop_kinds_table[s].name);
        tmp_sym->attr.is_iso_c = 1;
        if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
          tmp_sym->attr.subroutine = 1;
        else
          {
            /* TODO!  This needs to be finished more for the expr of the
               function or something!
               This may not need to be here, because trying to do c_loc
               as an external.  */
            if (s == ISOCBINDING_ASSOCIATED)
              {
                tmp_sym->attr.function = 1;
                tmp_sym->ts.type = BT_LOGICAL;
                tmp_sym->ts.kind = gfc_default_logical_kind;
                tmp_sym->result = tmp_sym;
              }
            else
              {
               /* Here, we're taking the simple approach.  We're defining
                  c_loc as an external identifier so the compiler will put
                  what we expect on the stack for the address we want the
                  C address of.  */
                tmp_sym->ts.type = BT_DERIVED;
                if (s == ISOCBINDING_LOC)
                  tmp_sym->ts.u.derived =
                    get_iso_c_binding_dt (ISOCBINDING_PTR);
                else
                  tmp_sym->ts.u.derived =
                    get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
 
                if (tmp_sym->ts.u.derived == NULL)
                  {
                    /* Create the necessary derived type so we can continue
                       processing the file.  */
                    generate_isocbinding_symbol
                      (mod_name, s == ISOCBINDING_FUNLOC
                                ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
                      (const char *)(s == ISOCBINDING_FUNLOC
                                ? "c_funptr" : "c_ptr"));
                    tmp_sym->ts.u.derived =
                    get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
                                            ? ISOCBINDING_FUNPTR
                                            : ISOCBINDING_PTR);
                  }
 
                /* The function result is itself (no result clause).  */
                tmp_sym->result = tmp_sym;
                tmp_sym->attr.external = 1;
                tmp_sym->attr.use_assoc = 0;
                tmp_sym->attr.pure = 1;
                tmp_sym->attr.if_source = IFSRC_UNKNOWN;
                tmp_sym->attr.proc = PROC_UNKNOWN;
              }
          }
 
        tmp_sym->attr.flavor = FL_PROCEDURE;
        tmp_sym->attr.contained = 0;
 
       /* Try using this builder routine, with the new and old symbols
          both being the generic iso_c proc sym being created.  This
          will create the formal args (and the new namespace for them).
          Don't build an arg list for c_loc because we're going to treat
          c_loc as an external procedure.  */
        if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
          /* The 1 says to add any optional args, if applicable.  */
          build_formal_args (tmp_sym, tmp_sym, 1);
 
        /* Set this after setting up the symbol, to prevent error messages.  */
        tmp_sym->attr.use_assoc = 1;
 
        /* This symbol will not be referenced directly.  It will be
           resolved to the implementation for the given f90 kind.  */
        tmp_sym->attr.referenced = 0;
 
        break;
 
      default:
        gcc_unreachable ();
    }
  gfc_commit_symbol (tmp_sym);
}
 
 
/* Creates a new symbol based off of an old iso_c symbol, with a new
   binding label.  This function can be used to create a new,
   resolved, version of a procedure symbol for c_f_pointer or
   c_f_procpointer that is based on the generic symbols.  A new
   parameter list is created for the new symbol using
   build_formal_args().  The add_optional_flag specifies whether the
   to add the optional SHAPE argument.  The new symbol is
   returned.  */
 
gfc_symbol *
get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
               const char *new_binding_label, int add_optional_arg)
{
  gfc_symtree *new_symtree = NULL;
 
  /* See if we have a symbol by that name already available, looking
     through any parent namespaces.  */
  gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
  if (new_symtree != NULL)
    /* Return the existing symbol.  */
    return new_symtree->n.sym;
 
  /* Create the symtree/symbol, with attempted host association.  */
  gfc_get_ha_sym_tree (new_name, &new_symtree);
  if (new_symtree == NULL)
    gfc_internal_error ("get_iso_c_sym(): Unable to create "
                        "symtree for '%s'", new_name);
 
  /* Now fill in the fields of the resolved symbol with the old sym.  */
  new_symtree->n.sym->binding_label = new_binding_label;
  new_symtree->n.sym->attr = old_sym->attr;
  new_symtree->n.sym->ts = old_sym->ts;
  new_symtree->n.sym->module = gfc_get_string (old_sym->module);
  new_symtree->n.sym->from_intmod = old_sym->from_intmod;
  new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
  if (old_sym->attr.function)
    new_symtree->n.sym->result = new_symtree->n.sym;
  /* Build the formal arg list.  */
  build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
 
  gfc_commit_symbol (new_symtree->n.sym);
 
  return new_symtree->n.sym;
}
 
 
/* Check that a symbol is already typed.  If strict is not set, an untyped
   symbol is acceptable for non-standard-conforming mode.  */
 
gfc_try
gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
                        bool strict, locus where)
{
  gcc_assert (sym);
 
  if (gfc_matching_prefix)
    return SUCCESS;
 
  /* Check for the type and try to give it an implicit one.  */
  if (sym->ts.type == BT_UNKNOWN
      && gfc_set_default_type (sym, 0, ns) == FAILURE)
    {
      if (strict)
        {
          gfc_error ("Symbol '%s' is used before it is typed at %L",
                     sym->name, &where);
          return FAILURE;
        }
 
      if (gfc_notify_std (GFC_STD_GNU,
                          "Extension: Symbol '%s' is used before"
                          " it is typed at %L", sym->name, &where) == FAILURE)
        return FAILURE;
    }
 
  /* Everything is ok.  */
  return SUCCESS;
}
 
 
/* Construct a typebound-procedure structure.  Those are stored in a tentative
   list and marked `error' until symbols are committed.  */
 
gfc_typebound_proc*
gfc_get_typebound_proc (gfc_typebound_proc *tb0)
{
  gfc_typebound_proc *result;
  tentative_tbp *list_node;
 
  result = XCNEW (gfc_typebound_proc);
  if (tb0)
    *result = *tb0;
  result->error = 1;
 
  list_node = XCNEW (tentative_tbp);
  list_node->next = tentative_tbp_list;
  list_node->proc = result;
  tentative_tbp_list = list_node;
 
  return result;
}
 
 
/* Get the super-type of a given derived type.  */
 
gfc_symbol*
gfc_get_derived_super_type (gfc_symbol* derived)
{
  if (derived && derived->attr.generic)
    derived = gfc_find_dt_in_generic (derived);
 
  if (!derived->attr.extension)
    return NULL;
 
  gcc_assert (derived->components);
  gcc_assert (derived->components->ts.type == BT_DERIVED);
  gcc_assert (derived->components->ts.u.derived);
 
  if (derived->components->ts.u.derived->attr.generic)
    return gfc_find_dt_in_generic (derived->components->ts.u.derived);
 
  return derived->components->ts.u.derived;
}
 
 
/* Get the ultimate super-type of a given derived type.  */
 
gfc_symbol*
gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
{
  if (!derived->attr.extension)
    return NULL;
 
  derived = gfc_get_derived_super_type (derived);
 
  if (derived->attr.extension)
    return gfc_get_ultimate_derived_super_type (derived);
  else
    return derived;
}
 
 
/* Check if a derived type t2 is an extension of (or equal to) a type t1.  */
 
bool
gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
{
  while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
    t2 = gfc_get_derived_super_type (t2);
  return gfc_compare_derived_types (t1, t2);
}
 
 
/* Check if two typespecs are type compatible (F03:5.1.1.2):
   If ts1 is nonpolymorphic, ts2 must be the same type.
   If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1.  */
 
bool
gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
{
  bool is_class1 = (ts1->type == BT_CLASS);
  bool is_class2 = (ts2->type == BT_CLASS);
  bool is_derived1 = (ts1->type == BT_DERIVED);
  bool is_derived2 = (ts2->type == BT_DERIVED);
 
  if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
    return (ts1->type == ts2->type);
 
  if (is_derived1 && is_derived2)
    return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
 
  if (is_class1 && is_derived2)
    return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
                                     ts2->u.derived);
  else if (is_class1 && is_class2)
    return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
                                     ts2->u.derived->components->ts.u.derived);
  else
    return 0;
}
 
 
/* Find the parent-namespace of the current function.  If we're inside
   BLOCK constructs, it may not be the current one.  */
 
gfc_namespace*
gfc_find_proc_namespace (gfc_namespace* ns)
{
  while (ns->construct_entities)
    {
      ns = ns->parent;
      gcc_assert (ns);
    }
 
  return ns;
}
 
 
/* Check if an associate-variable should be translated as an `implicit' pointer
   internally (if it is associated to a variable and not an array with
   descriptor).  */
 
bool
gfc_is_associate_pointer (gfc_symbol* sym)
{
  if (!sym->assoc)
    return false;
 
  if (!sym->assoc->variable)
    return false;
 
  if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)
    return false;
 
  return true;
}
 
 
gfc_symbol *
gfc_find_dt_in_generic (gfc_symbol *sym)
{
  gfc_interface *intr = NULL;
 
  if (!sym || sym->attr.flavor == FL_DERIVED)
    return sym;
 
  if (sym->attr.generic)
    for (intr = (sym ? sym->generic : NULL); intr; intr = intr->next)
      if (intr->sym->attr.flavor == FL_DERIVED)
        break;
  return intr ? intr->sym : NULL;
}
Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [fortran/] [symbol.c] - Blame information for rev 712

Line No.	Rev	Author	Line
1	712	jeremybenn	`/* Maintain binary trees of symbols.`
2			`Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,`
3			`2009, 2010, 2011, 2012`
4			`Free Software Foundation, Inc.`
5			`Contributed by Andy Vaught`
6
7			`This file is part of GCC.`
8
9			`GCC is free software; you can redistribute it and/or modify it under`
10			`the terms of the GNU General Public License as published by the Free`
11			`Software Foundation; either version 3, or (at your option) any later`
12			`version.`
13
14			`GCC is distributed in the hope that it will be useful, but WITHOUT ANY`
15			`WARRANTY; without even the implied warranty of MERCHANTABILITY or`
16			`FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License`
17			`for more details.`
18
19			`You should have received a copy of the GNU General Public License`
20			`along with GCC; see the file COPYING3. If not see`
21			`<http://www.gnu.org/licenses/>. */`
22
23
24			`#include "config.h"`
25			`#include "system.h"`
26			`#include "flags.h"`
27			`#include "gfortran.h"`
28			`#include "parse.h"`
29			`#include "match.h"`
30			`#include "constructor.h"`
31
32
33			`/* Strings for all symbol attributes. We use these for dumping the`
34			`parse tree, in error messages, and also when reading and writing`
35			`modules. */`
36
37			`const mstring flavors[] =`
38			`{`
39			`minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),`
40			`minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),`