/* Implementation of Fortran 2003 Polymorphism.
   Copyright (C) 2009, 2010
   Free Software Foundation, Inc.
   Contributed by Paul Richard Thomas & Janus Weil

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


/* class.c -- This file contains the front end functions needed to service
              the implementation of Fortran 2003 polymorphism and other
              object-oriented features.  */


/* Outline of the internal representation:

   Each CLASS variable is encapsulated by a class container, which is a
   structure with two fields:
    * $data: A pointer to the actual data of the variable. This field has the
             declared type of the class variable and its attributes
             (pointer/allocatable/dimension/...).
    * $vptr: A pointer to the vtable entry (see below) of the dynamic type.
    
   For each derived type we set up a "vtable" entry, i.e. a structure with the
   following fields:
    * $hash: A hash value serving as a unique identifier for this type.
    * $size: The size in bytes of the derived type.
    * $extends: A pointer to the vtable entry of the parent derived type.
   In addition to these fields, each vtable entry contains additional procedure
   pointer components, which contain pointers to the procedures which are bound
   to the type's "methods" (type-bound procedures).  */


#include "config.h"
#include "system.h"
#include "gfortran.h"
#include "constructor.h"


/* Insert a reference to the component of the given name.
   Only to be used with CLASS containers.  */

void
gfc_add_component_ref (gfc_expr *e, const char *name)
{
  gfc_ref **tail = &(e->ref);
  gfc_ref *next = NULL;
  gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
  while (*tail != NULL)
    {
      if ((*tail)->type == REF_COMPONENT)
	derived = (*tail)->u.c.component->ts.u.derived;
      if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
	break;
      tail = &((*tail)->next);
    }
  if (*tail != NULL && strcmp (name, "$data") == 0)
    next = *tail;
  (*tail) = gfc_get_ref();
  (*tail)->next = next;
  (*tail)->type = REF_COMPONENT;
  (*tail)->u.c.sym = derived;
  (*tail)->u.c.component = gfc_find_component (derived, name, true, true);
  gcc_assert((*tail)->u.c.component);
  if (!next)
    e->ts = (*tail)->u.c.component->ts;
}


/* Build a NULL initializer for CLASS pointers,
   initializing the $data and $vptr components to zero.  */

gfc_expr *
gfc_class_null_initializer (gfc_typespec *ts)
{
  gfc_expr *init;
  gfc_component *comp;
  
  init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
					     &ts->u.derived->declared_at);
  init->ts = *ts;
  
  for (comp = ts->u.derived->components; comp; comp = comp->next)
    {
      gfc_constructor *ctor = gfc_constructor_get();
      ctor->expr = gfc_get_expr ();
      ctor->expr->expr_type = EXPR_NULL;
      ctor->expr->ts = comp->ts;
      gfc_constructor_append (&init->value.constructor, ctor);
    }

  return init;
}


/* Build a polymorphic CLASS entity, using the symbol that comes from
   build_sym. A CLASS entity is represented by an encapsulating type,
   which contains the declared type as '$data' component, plus a pointer
   component '$vptr' which determines the dynamic type.  */

gfc_try
gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
			gfc_array_spec **as, bool delayed_vtab)
{
  char name[GFC_MAX_SYMBOL_LEN + 5];
  gfc_symbol *fclass;
  gfc_symbol *vtab;
  gfc_component *c;

  /* Determine the name of the encapsulating type.  */
  if ((*as) && (*as)->rank && attr->allocatable)
    sprintf (name, "class$%s_%d_a", ts->u.derived->name, (*as)->rank);
  else if ((*as) && (*as)->rank)
    sprintf (name, "class$%s_%d", ts->u.derived->name, (*as)->rank);
  else if (attr->pointer)
    sprintf (name, "class$%s_p", ts->u.derived->name);
  else if (attr->allocatable)
    sprintf (name, "class$%s_a", ts->u.derived->name);
  else
    sprintf (name, "class$%s", ts->u.derived->name);

  gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
  if (fclass == NULL)
    {
      gfc_symtree *st;
      /* If not there, create a new symbol.  */
      fclass = gfc_new_symbol (name, ts->u.derived->ns);
      st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
      st->n.sym = fclass;
      gfc_set_sym_referenced (fclass);
      fclass->refs++;
      fclass->ts.type = BT_UNKNOWN;
      fclass->attr.abstract = ts->u.derived->attr.abstract;
      if (ts->u.derived->f2k_derived)
	fclass->f2k_derived = gfc_get_namespace (NULL, 0);
      if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
	  NULL, &gfc_current_locus) == FAILURE)
	return FAILURE;

      /* Add component '$data'.  */
      if (gfc_add_component (fclass, "$data", &c) == FAILURE)
	return FAILURE;
      c->ts = *ts;
      c->ts.type = BT_DERIVED;
      c->attr.access = ACCESS_PRIVATE;
      c->ts.u.derived = ts->u.derived;
      c->attr.class_pointer = attr->pointer;
      c->attr.pointer = attr->pointer || attr->dummy;
      c->attr.allocatable = attr->allocatable;
      c->attr.dimension = attr->dimension;
      c->attr.codimension = attr->codimension;
      c->attr.abstract = ts->u.derived->attr.abstract;
      c->as = (*as);
      c->initializer = NULL;

      /* Add component '$vptr'.  */
      if (gfc_add_component (fclass, "$vptr", &c) == FAILURE)
	return FAILURE;
      c->ts.type = BT_DERIVED;
      if (delayed_vtab)
	c->ts.u.derived = NULL;
      else
	{
	  vtab = gfc_find_derived_vtab (ts->u.derived, false);
	  gcc_assert (vtab);
	  c->ts.u.derived = vtab->ts.u.derived;
	}
      c->attr.pointer = 1;
    }

  /* Since the extension field is 8 bit wide, we can only have
     up to 255 extension levels.  */
  if (ts->u.derived->attr.extension == 255)
    {
      gfc_error ("Maximum extension level reached with type '%s' at %L",
		 ts->u.derived->name, &ts->u.derived->declared_at);
      return FAILURE;
    }
    
  fclass->attr.extension = ts->u.derived->attr.extension + 1;
  fclass->attr.is_class = 1;
  ts->u.derived = fclass;
  attr->allocatable = attr->pointer = attr->dimension = 0;
  (*as) = NULL;  /* XXX */
  return SUCCESS;
}


static void
add_proc_component (gfc_component *c, gfc_symbol *vtype,
		    gfc_symtree *st, gfc_symbol *specific,
		    bool is_generic, bool is_generic_specific)
{
  /* Add procedure component.  */
  if (is_generic)
    {
      if (gfc_add_component (vtype, specific->name, &c) == FAILURE)
	return;
      c->ts.interface = specific;
    }
  else if (c && is_generic_specific)
    {
      c->ts.interface = st->n.tb->u.specific->n.sym;
    }
  else
    {
      c = gfc_find_component (vtype, st->name, true, true);
      if (!c && gfc_add_component (vtype, st->name, &c) == FAILURE)
	return;
      c->ts.interface = st->n.tb->u.specific->n.sym;
    }

  if (!c->tb)
    c->tb = XCNEW (gfc_typebound_proc);
  *c->tb = *st->n.tb;
  c->tb->ppc = 1;
  c->attr.procedure = 1;
  c->attr.proc_pointer = 1;
  c->attr.flavor = FL_PROCEDURE;
  c->attr.access = ACCESS_PRIVATE;
  c->attr.external = 1;
  c->attr.untyped = 1;
  c->attr.if_source = IFSRC_IFBODY;

  /* A static initializer cannot be used here because the specific
     function is not a constant; internal compiler error: in
     output_constant, at varasm.c:4623  */
  c->initializer = NULL;
}


static void
add_proc_comps (gfc_component *c, gfc_symbol *vtype,
		gfc_symtree *st, bool is_generic)
{
  if (c == NULL && !is_generic)
    {
      add_proc_component (c, vtype, st, NULL, false, false);
    }
  else if (is_generic && st->n.tb && vtype->components == NULL)
    {
      gfc_tbp_generic* g;
      gfc_symbol * specific;
      for (g = st->n.tb->u.generic; g; g = g->next)
	{
	  if (!g->specific)
	    continue;
	  specific = g->specific->u.specific->n.sym;
	  add_proc_component (NULL, vtype, st, specific, true, false);
	}
    }
  else if (c->attr.proc_pointer && c->tb)
    {
      *c->tb = *st->n.tb;
      c->tb->ppc = 1;
      c->ts.interface = st->n.tb->u.specific->n.sym;	  
    }
}

static void
add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype,
			     bool resolved)
{
  gfc_component *c;
  gfc_symbol *generic;
  char name[3 * GFC_MAX_SYMBOL_LEN + 10];

  if (!st)
    return;

  if (st->left)
    add_procs_to_declared_vtab1 (st->left, vtype, resolved);

  if (st->right)
    add_procs_to_declared_vtab1 (st->right, vtype, resolved);

  if (!st->n.tb)
    return;

  if (!st->n.tb->is_generic && st->n.tb->u.specific)
    {
      c = gfc_find_component (vtype, st->name, true, true);
      add_proc_comps (c, vtype, st, false);
    }
  else if (st->n.tb->is_generic)
    {
      c = gfc_find_component (vtype, st->name, true, true);

      if (c == NULL)
	{
	  /* Add derived type component with generic name.  */
	  if (gfc_add_component (vtype, st->name, &c) == FAILURE)
	    return;
	  c->ts.type = BT_DERIVED;
	  c->attr.flavor = FL_VARIABLE;
	  c->attr.pointer = 1;

	  /* Add a special empty derived type as a placeholder.  */
	  sprintf (name, "$empty");
	  gfc_find_symbol (name, vtype->ns, 0, &generic);
	  if (generic == NULL)
	    {
	      gfc_get_symbol (name, vtype->ns, &generic);
	      generic->attr.flavor = FL_DERIVED;
	      generic->refs++;
	      gfc_set_sym_referenced (generic);
	      generic->ts.type = BT_UNKNOWN;
	      generic->attr.zero_comp = 1;
	    }

	  c->ts.u.derived = generic;
	}
    }
}


static void
copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype,
		      bool resolved)
{
  gfc_component *c, *cmp;
  gfc_symbol *vtab;

  vtab = gfc_find_derived_vtab (declared, resolved);

  for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
    {
      if (gfc_find_component (vtype, cmp->name, true, true))
	continue;

      if (gfc_add_component (vtype, cmp->name, &c) == FAILURE)
	return;

      if (cmp->ts.type == BT_DERIVED)
	{
	  c->ts = cmp->ts;
	  c->ts.u.derived = cmp->ts.u.derived;
	  c->attr.flavor = FL_VARIABLE;
	  c->attr.pointer = 1;
	  c->initializer = NULL;
	  continue;
	}

      c->tb = XCNEW (gfc_typebound_proc);
      *c->tb = *cmp->tb;
      c->attr.procedure = 1;
      c->attr.proc_pointer = 1;
      c->attr.flavor = FL_PROCEDURE;
      c->attr.access = ACCESS_PRIVATE;
      c->attr.external = 1;
      c->ts.interface = cmp->ts.interface;
      c->attr.untyped = 1;
      c->attr.if_source = IFSRC_IFBODY;
      c->initializer = NULL;
    }
}

static void
add_procs_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype,
			    gfc_symbol *derived, bool resolved)
{
  gfc_symbol* super_type;

  super_type = gfc_get_derived_super_type (declared);

  if (super_type && (super_type != declared))
    add_procs_to_declared_vtab (super_type, vtype, derived, resolved);

  if (declared != derived)
    copy_vtab_proc_comps (declared, vtype, resolved);

  if (declared->f2k_derived && declared->f2k_derived->tb_sym_root)
    add_procs_to_declared_vtab1 (declared->f2k_derived->tb_sym_root,
				 vtype, resolved);

  if (declared->f2k_derived && declared->f2k_derived->tb_uop_root)
    add_procs_to_declared_vtab1 (declared->f2k_derived->tb_uop_root,
				 vtype, resolved);
}


static
void add_generic_specifics (gfc_symbol *declared, gfc_symbol *vtab,
			    const char *name)
{
  gfc_tbp_generic* g;
  gfc_symbol * specific1;
  gfc_symbol * specific2;
  gfc_symtree *st = NULL;
  gfc_component *c;

  /* Find the generic procedure using the component name.  */
  st = gfc_find_typebound_proc (declared, NULL, name, true, NULL);
  if (st == NULL)
    st = gfc_find_typebound_user_op (declared, NULL, name, true, NULL);

  if (st == NULL)
    return;

  /* Add procedure pointer components for the specific procedures. */
  for (g = st->n.tb->u.generic; g; g = g->next)
    {
      if (!g->specific)
	continue;
      specific1 = g->specific_st->n.tb->u.specific->n.sym;

      c = vtab->ts.u.derived->components;
      specific2 = NULL;

      /* Override identical specific interface.  */
      if (vtab->ts.u.derived->components)
	{
	  for (; c; c= c->next)
	    {
	      specific2 = c->ts.interface;
	      if (gfc_compare_interfaces (specific2, specific1,
					  specific1->name, 0, 0, NULL, 0))
		break;
	    }
	}

      add_proc_component (c, vtab->ts.u.derived, g->specific_st,
			  NULL, false, true);
      vtab->ts.u.derived->attr.zero_comp = 0;
    }
}


static void
add_generics_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype,
			       gfc_symbol *derived, bool resolved)
{
  gfc_component *cmp;
  gfc_symtree *st = NULL;
  gfc_symbol * vtab;
  char name[2 * GFC_MAX_SYMBOL_LEN + 8];
  gfc_symbol* super_type;

  gcc_assert (resolved);

  for (cmp = vtype->components; cmp; cmp = cmp->next)
    {
      if (cmp->ts.type != BT_DERIVED)
	continue;

      /* The only derived type that does not represent a generic
	 procedure is the pointer to the parent vtab.  */
      if (cmp->ts.u.derived
	    && strcmp (cmp->ts.u.derived->name, "$extends") == 0)
	continue;

      /* Find the generic procedure using the component name.  */
      st = gfc_find_typebound_proc (declared, NULL, cmp->name,
				    true, NULL);
      if (st == NULL)
	st = gfc_find_typebound_user_op (declared, NULL, cmp->name,
					 true, NULL);

      /* Should be an error but we pass on it for now.  */
      if (st == NULL || !st->n.tb->is_generic)
	continue;

      vtab = NULL;

      /* Build a vtab and a special vtype, with only the procedure
	 pointer fields, to carry the pointers to the specific
	 procedures.  Should this name ever be changed, the same
	 should be done in trans-expr.c(gfc_trans_assign_vtab_procs). */
      sprintf (name, "vtab$%s$%s", vtype->name, cmp->name);
      gfc_find_symbol (name, derived->ns, 0, &vtab);
      if (vtab == NULL)
	{
	  gfc_get_symbol (name, derived->ns, &vtab);
	  vtab->ts.type = BT_DERIVED;
	  vtab->attr.flavor = FL_VARIABLE;
	  vtab->attr.target = 1;
	  vtab->attr.save = SAVE_EXPLICIT;
	  vtab->attr.vtab = 1;
	  vtab->refs++;
	  gfc_set_sym_referenced (vtab);
	  sprintf (name, "%s$%s", vtype->name, cmp->name);
	  
	  gfc_find_symbol (name, derived->ns, 0, &cmp->ts.u.derived);
	  if (cmp->ts.u.derived == NULL
		|| (strcmp (cmp->ts.u.derived->name, "$empty") == 0))
	    {
	      gfc_get_symbol (name, derived->ns, &cmp->ts.u.derived);
	      if (gfc_add_flavor (&cmp->ts.u.derived->attr, FL_DERIVED,
				  NULL, &gfc_current_locus) == FAILURE)
		return;
	      cmp->ts.u.derived->refs++;
	      gfc_set_sym_referenced (cmp->ts.u.derived);
	      cmp->ts.u.derived->attr.vtype = 1;
	      cmp->ts.u.derived->attr.zero_comp = 1;
	    }
	  vtab->ts.u.derived = cmp->ts.u.derived;
	}

      /* Store this for later use in setting the pointer.  */
      cmp->ts.interface = vtab;

      if (vtab->ts.u.derived->components)
	continue;

      super_type = gfc_get_derived_super_type (declared);

      if (super_type && (super_type != declared))
	add_generic_specifics (super_type, vtab, cmp->name);

      add_generic_specifics (declared, vtab, cmp->name);
    }
}


/* Find the symbol for a derived type's vtab.  A vtab has the following
   fields:
   $hash	a hash value used to identify the derived type
   $size	the size in bytes of the derived type
   $extends	a pointer to the vtable of the parent derived type
   then:
   procedure pointer components for the specific typebound procedures
   structure pointers to reduced vtabs that contain procedure
   pointers to the specific procedures.  */

gfc_symbol *
gfc_find_derived_vtab (gfc_symbol *derived, bool resolved)
{
  gfc_namespace *ns;
  gfc_symbol *vtab = NULL, *vtype = NULL;
  char name[2 * GFC_MAX_SYMBOL_LEN + 8];

  ns = gfc_current_ns;

  for (; ns; ns = ns->parent)
    if (!ns->parent)
      break;

  if (ns)
    {
      sprintf (name, "vtab$%s", derived->name);
      gfc_find_symbol (name, ns, 0, &vtab);

      if (vtab == NULL)
	{
	  gfc_get_symbol (name, ns, &vtab);
	  vtab->ts.type = BT_DERIVED;
	  vtab->attr.flavor = FL_VARIABLE;
	  vtab->attr.target = 1;
	  vtab->attr.save = SAVE_EXPLICIT;
	  vtab->attr.vtab = 1;
	  vtab->refs++;
	  gfc_set_sym_referenced (vtab);
	  sprintf (name, "vtype$%s", derived->name);
	  
	  gfc_find_symbol (name, ns, 0, &vtype);
	  if (vtype == NULL)
	    {
	      gfc_component *c;
	      gfc_symbol *parent = NULL, *parent_vtab = NULL;

	      gfc_get_symbol (name, ns, &vtype);
	      if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
				  NULL, &gfc_current_locus) == FAILURE)
		return NULL;
	      vtype->refs++;
	      gfc_set_sym_referenced (vtype);

	      /* Add component '$hash'.  */
	      if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
		return NULL;
	      c->ts.type = BT_INTEGER;
	      c->ts.kind = 4;
	      c->attr.access = ACCESS_PRIVATE;
	      c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
						 NULL, derived->hash_value);

	      /* Add component '$size'.  */
	      if (gfc_add_component (vtype, "$size", &c) == FAILURE)
		return NULL;
	      c->ts.type = BT_INTEGER;
	      c->ts.kind = 4;
	      c->attr.access = ACCESS_PRIVATE;
	      /* Remember the derived type in ts.u.derived,
		 so that the correct initializer can be set later on
		 (in gfc_conv_structure).  */
	      c->ts.u.derived = derived;
	      c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
						 NULL, 0);

	      /* Add component $extends.  */
	      if (gfc_add_component (vtype, "$extends", &c) == FAILURE)
		return NULL;
	      c->attr.pointer = 1;
	      c->attr.access = ACCESS_PRIVATE;
	      parent = gfc_get_derived_super_type (derived);
	      if (parent)
		{
		  parent_vtab = gfc_find_derived_vtab (parent, resolved);
		  c->ts.type = BT_DERIVED;
		  c->ts.u.derived = parent_vtab->ts.u.derived;
		  c->initializer = gfc_get_expr ();
		  c->initializer->expr_type = EXPR_VARIABLE;
		  gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
				     0, &c->initializer->symtree);
		}
	      else
		{
		  c->ts.type = BT_DERIVED;
		  c->ts.u.derived = vtype;
		  c->initializer = gfc_get_null_expr (NULL);
		}

	      add_procs_to_declared_vtab (derived, vtype, derived, resolved);
	      vtype->attr.vtype = 1;
	    }

	  vtab->ts.u.derived = vtype;
	  vtab->value = gfc_default_initializer (&vtab->ts);
	}
    }

  /* Catch the call just before the backend declarations are built, so that
     the generic procedures have been resolved and the specific procedures
     have formal interfaces that can be compared.  */
  if (resolved
	&& vtab->ts.u.derived
	&& vtab->ts.u.derived->backend_decl == NULL)
    add_generics_to_declared_vtab (derived, vtab->ts.u.derived,
				   derived, resolved);

  return vtab;
}


/* General worker function to find either a type-bound procedure or a
   type-bound user operator.  */

static gfc_symtree*
find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
			 const char* name, bool noaccess, bool uop,
			 locus* where)
{
  gfc_symtree* res;
  gfc_symtree* root;

  /* Set correct symbol-root.  */
  gcc_assert (derived->f2k_derived);
  root = (uop ? derived->f2k_derived->tb_uop_root
	      : derived->f2k_derived->tb_sym_root);

  /* Set default to failure.  */
  if (t)
    *t = FAILURE;

  /* Try to find it in the current type's namespace.  */
  res = gfc_find_symtree (root, name);
  if (res && res->n.tb && !res->n.tb->error)
    {
      /* We found one.  */
      if (t)
	*t = SUCCESS;

      if (!noaccess && derived->attr.use_assoc
	  && res->n.tb->access == ACCESS_PRIVATE)
	{
	  if (where)
	    gfc_error ("'%s' of '%s' is PRIVATE at %L",
		       name, derived->name, where);
	  if (t)
	    *t = FAILURE;
	}

      return res;
    }

  /* Otherwise, recurse on parent type if derived is an extension.  */
  if (derived->attr.extension)
    {
      gfc_symbol* super_type;
      super_type = gfc_get_derived_super_type (derived);
      gcc_assert (super_type);

      return find_typebound_proc_uop (super_type, t, name,
				      noaccess, uop, where);
    }

  /* Nothing found.  */
  return NULL;
}


/* Find a type-bound procedure or user operator by name for a derived-type
   (looking recursively through the super-types).  */

gfc_symtree*
gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
			 const char* name, bool noaccess, locus* where)
{
  return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
}

gfc_symtree*
gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
			    const char* name, bool noaccess, locus* where)
{
  return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
}


/* Find a type-bound intrinsic operator looking recursively through the
   super-type hierarchy.  */

gfc_typebound_proc*
gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
				 gfc_intrinsic_op op, bool noaccess,
				 locus* where)
{
  gfc_typebound_proc* res;

  /* Set default to failure.  */
  if (t)
    *t = FAILURE;

  /* Try to find it in the current type's namespace.  */
  if (derived->f2k_derived)
    res = derived->f2k_derived->tb_op[op];
  else  
    res = NULL;

  /* Check access.  */
  if (res && !res->error)
    {
      /* We found one.  */
      if (t)
	*t = SUCCESS;

      if (!noaccess && derived->attr.use_assoc
	  && res->access == ACCESS_PRIVATE)
	{
	  if (where)
	    gfc_error ("'%s' of '%s' is PRIVATE at %L",
		       gfc_op2string (op), derived->name, where);
	  if (t)
	    *t = FAILURE;
	}

      return res;
    }

  /* Otherwise, recurse on parent type if derived is an extension.  */
  if (derived->attr.extension)
    {
      gfc_symbol* super_type;
      super_type = gfc_get_derived_super_type (derived);
      gcc_assert (super_type);

      return gfc_find_typebound_intrinsic_op (super_type, t, op,
					      noaccess, where);
    }

  /* Nothing found.  */
  return NULL;
}


/* Get a typebound-procedure symtree or create and insert it if not yet
   present.  This is like a very simplified version of gfc_get_sym_tree for
   tbp-symtrees rather than regular ones.  */

gfc_symtree*
gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
{
  gfc_symtree *result;

  result = gfc_find_symtree (*root, name);
  if (!result)
    {
      result = gfc_new_symtree (root, name);
      gcc_assert (result);
      result->n.tb = NULL;
    }

  return result;
}