[thirdparty/gcc.git] / gcc / fortran / class.c

/* 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);
	  gcc_assert (vtab);
	  c->ts.u.derived = vtab->ts.u.derived;
	}
      c->attr.access = ACCESS_PRIVATE;
      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;
}


/* Add a procedure pointer component to the vtype
   to represent a specific type-bound procedure.  */

static void
add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
{
  gfc_component *c;
  c = gfc_find_component (vtype, name, true, true);

  if (c == NULL)
    {
      /* Add procedure component.  */
      if (gfc_add_component (vtype, name, &c) == FAILURE)
	return;
      if (tb->u.specific)
	c->ts.interface = tb->u.specific->n.sym;

      if (!c->tb)
	c->tb = XCNEW (gfc_typebound_proc);
      *c->tb = *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;
    }
  else if (c->attr.proc_pointer && c->tb)
    {
      *c->tb = *tb;
      c->tb->ppc = 1;
      c->ts.interface = tb->u.specific->n.sym;	  
    }
}


/* Add all specific type-bound procedures in the symtree 'st' to a vtype.  */

static void
add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype)
{
  if (!st)
    return;

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

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

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

  if (!st->n.tb->is_generic && st->n.tb->u.specific)
    add_proc_comp (vtype, st->name, st->n.tb);
}


/* Copy procedure pointers components from the parent type.  */

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

  vtab = gfc_find_derived_vtab (declared);

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

      add_proc_comp (vtype, cmp->name, cmp->tb);
    }
}


/* Add procedure pointers for all type-bound procedures to a vtab.  */

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

  super_type = gfc_get_derived_super_type (derived);

  if (super_type && (super_type != derived))
    {
      /* Make sure that the PPCs appear in the same order as in the parent.  */
      copy_vtab_proc_comps (super_type, vtype);
      /* Only needed to get the PPC interfaces right.  */
      add_procs_to_declared_vtab (super_type, vtype);
    }

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

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


/* 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
   After these follow procedure pointer components for the
   specific type-bound procedures.  */

gfc_symbol *
gfc_find_derived_vtab (gfc_symbol *derived)
{
  gfc_namespace *ns;
  gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = 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->attr.access = ACCESS_PUBLIC;
	  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)
		goto cleanup;
	      vtype->attr.access = ACCESS_PUBLIC;
	      vtype->refs++;
	      gfc_set_sym_referenced (vtype);

	      /* Add component '$hash'.  */
	      if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
		goto cleanup;
	      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)
		goto cleanup;
	      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)
		goto cleanup;
	      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);
		  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);
	      vtype->attr.vtype = 1;
	    }

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

  found_sym = vtab;

cleanup:
  /* It is unexpected to have some symbols added at resolution or code
     generation time. We commit the changes in order to keep a clean state.  */
  if (found_sym)
    gfc_commit_symbols ();
  else
    gfc_undo_symbols ();

  return found_sym;
}


/* 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;
}
Commit	Line	Data
d15bac21 JW	1	/* Implementation of Fortran 2003 Polymorphism.
	2	Copyright (C) 2009, 2010
	3	Free Software Foundation, Inc.
	4	Contributed by Paul Richard Thomas & Janus Weil
	5
	6	This file is part of GCC.
	7
	8	GCC is free software; you can redistribute it and/or modify it under
	9	the terms of the GNU General Public License as published by the Free
	10	Software Foundation; either version 3, or (at your option) any later
	11	version.
	12
	13	GCC is distributed in the hope that it will be useful, but WITHOUT ANY
	14	WARRANTY; without even the implied warranty of MERCHANTABILITY or
	15	FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
	16	for more details.
	17
	18	You should have received a copy of the GNU General Public License
	19	along with GCC; see the file COPYING3. If not see
	20	<http://www.gnu.org/licenses/>. */
	21
	22
	23	/* class.c -- This file contains the front end functions needed to service
	24	the implementation of Fortran 2003 polymorphism and other
	25	object-oriented features. */
	26
	27
	28	/* Outline of the internal representation:
	29
	30	Each CLASS variable is encapsulated by a class container, which is a
	31	structure with two fields:
	32	* $data: A pointer to the actual data of the variable. This field has the
	33	declared type of the class variable and its attributes
	34	(pointer/allocatable/dimension/...).
	35	* $vptr: A pointer to the vtable entry (see below) of the dynamic type.
	36
	37	For each derived type we set up a "vtable" entry, i.e. a structure with the
	38	following fields:
	39	* $hash: A hash value serving as a unique identifier for this type.
	40	* $size: The size in bytes of the derived type.
	41	* $extends: A pointer to the vtable entry of the parent derived type.
	42	In addition to these fields, each vtable entry contains additional procedure
	43	pointer components, which contain pointers to the procedures which are bound
	44	to the type's "methods" (type-bound procedures). */
	45
	46
	47	#include "config.h"
	48	#include "system.h"
	49	#include "gfortran.h"
	50	#include "constructor.h"
	51
	52
	53	/* Insert a reference to the component of the given name.
	54	Only to be used with CLASS containers. */
	55
	56	void
	57	gfc_add_component_ref (gfc_expr e, const char name)
	58	{
	59	gfc_ref **tail = &(e->ref);
	60	gfc_ref *next = NULL;
	61	gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
	62	while (*tail != NULL)
	63	{
	64	if ((*tail)->type == REF_COMPONENT)
65	derived = (*tail)->u.c.component->ts.u.derived;
66	if ((tail)->type == REF_ARRAY && (tail)->next == NULL)
67	break;
68	tail = &((*tail)->next);
69	}
70	if (*tail != NULL && strcmp (name, "$data") == 0)
71	next = *tail;
72	(*tail) = gfc_get_ref();
73	(*tail)->next = next;
74	(*tail)->type = REF_COMPONENT;
75	(*tail)->u.c.sym = derived;
76	(*tail)->u.c.component = gfc_find_component (derived, name, true, true);
77	gcc_assert((*tail)->u.c.component);
78	if (!next)
79	e->ts = (*tail)->u.c.component->ts;
80	}
81
82
83	/* Build a NULL initializer for CLASS pointers,
84	initializing the $data and $vptr components to zero. */
85
86	gfc_expr *
87	gfc_class_null_initializer (gfc_typespec *ts)
88	{
89	gfc_expr *init;
90	gfc_component *comp;
91
92	init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
93	&ts->u.derived->declared_at);
94	init->ts = *ts;
95
96	for (comp = ts->u.derived->components; comp; comp = comp->next)
97	{
98	gfc_constructor *ctor = gfc_constructor_get();
99	ctor->expr = gfc_get_expr ();
100	ctor->expr->expr_type = EXPR_NULL;
101	ctor->expr->ts = comp->ts;
102	gfc_constructor_append (&init->value.constructor, ctor);
103	}
104
105	return init;
106	}
107
108
109	/* Build a polymorphic CLASS entity, using the symbol that comes from
110	build_sym. A CLASS entity is represented by an encapsulating type,
111	which contains the declared type as '$data' component, plus a pointer
112	component '$vptr' which determines the dynamic type. */
113
114	gfc_try
115	gfc_build_class_symbol (gfc_typespec ts, symbol_attribute attr,
116	gfc_array_spec **as, bool delayed_vtab)
117	{
118	char name[GFC_MAX_SYMBOL_LEN + 5];
119	gfc_symbol *fclass;
120	gfc_symbol *vtab;
121	gfc_component *c;
122
123	/* Determine the name of the encapsulating type. */
124	if ((as) && (as)->rank && attr->allocatable)
125	sprintf (name, "class$%s_%d_a", ts->u.derived->name, (*as)->rank);
126	else if ((as) && (as)->rank)
127	sprintf (name, "class$%s_%d", ts->u.derived->name, (*as)->rank);
128	else if (attr->pointer)
129	sprintf (name, "class$%s_p", ts->u.derived->name);
130	else if (attr->allocatable)
131	sprintf (name, "class$%s_a", ts->u.derived->name);
132	else
133	sprintf (name, "class$%s", ts->u.derived->name);
134
135	gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
136	if (fclass == NULL)
137	{
138	gfc_symtree *st;
139	/* If not there, create a new symbol. */
140	fclass = gfc_new_symbol (name, ts->u.derived->ns);
141	st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
142	st->n.sym = fclass;
143	gfc_set_sym_referenced (fclass);
144	fclass->refs++;
145	fclass->ts.type = BT_UNKNOWN;
146	fclass->attr.abstract = ts->u.derived->attr.abstract;
147	if (ts->u.derived->f2k_derived)
148	fclass->f2k_derived = gfc_get_namespace (NULL, 0);
149	if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
150	NULL, &gfc_current_locus) == FAILURE)
151	return FAILURE;
152
153	/* Add component '$data'. */
154	if (gfc_add_component (fclass, "$data", &c) == FAILURE)
155	return FAILURE;
156	c->ts = *ts;
157	c->ts.type = BT_DERIVED;
158	c->attr.access = ACCESS_PRIVATE;
159	c->ts.u.derived = ts->u.derived;
160	c->attr.class_pointer = attr->pointer;
161	c->attr.pointer = attr->pointer \|\| attr->dummy;
162	c->attr.allocatable = attr->allocatable;
163	c->attr.dimension = attr->dimension;
164	c->attr.codimension = attr->codimension;
165	c->attr.abstract = ts->u.derived->attr.abstract;
166	c->as = (*as);
167	c->initializer = NULL;
168
169	/* Add component '$vptr'. */
170	if (gfc_add_component (fclass, "$vptr", &c) == FAILURE)
171	return FAILURE;
172	c->ts.type = BT_DERIVED;
173	if (delayed_vtab)
174	c->ts.u.derived = NULL;
175	else
176	{
88ce8031	177	vtab = gfc_find_derived_vtab (ts->u.derived);
d15bac21 JW	178	gcc_assert (vtab);
	179	c->ts.u.derived = vtab->ts.u.derived;
	180	}
f3f98a1e	181	c->attr.access = ACCESS_PRIVATE;
d15bac21 JW	182	c->attr.pointer = 1;
	183	}
	184
	185	/* Since the extension field is 8 bit wide, we can only have
	186	up to 255 extension levels. */
	187	if (ts->u.derived->attr.extension == 255)
	188	{
	189	gfc_error ("Maximum extension level reached with type '%s' at %L",
	190	ts->u.derived->name, &ts->u.derived->declared_at);
	191	return FAILURE;
	192	}
	193
	194	fclass->attr.extension = ts->u.derived->attr.extension + 1;
	195	fclass->attr.is_class = 1;
	196	ts->u.derived = fclass;
	197	attr->allocatable = attr->pointer = attr->dimension = 0;
	198	(as) = NULL; / XXX */
	199	return SUCCESS;
	200	}
	201
	202
88ce8031 JW	203	/* Add a procedure pointer component to the vtype
	204	to represent a specific type-bound procedure. */
	205
d15bac21	206	static void
88ce8031	207	add_proc_comp (gfc_symbol vtype, const char name, gfc_typebound_proc *tb)
d15bac21	208	{
88ce8031 JW	209	gfc_component *c;
	210	c = gfc_find_component (vtype, name, true, true);
	211
	212	if (c == NULL)
d15bac21	213	{
88ce8031 JW	214	/* Add procedure component. */
88ce8031 JW	215	if (gfc_add_component (vtype, name, &c) == FAILURE)
d15bac21	216	return;
88ce8031 JW	217	if (tb->u.specific)
88ce8031 JW	218	c->ts.interface = tb->u.specific->n.sym;
d15bac21	219
88ce8031 JW	220	if (!c->tb)
	221	c->tb = XCNEW (gfc_typebound_proc);
	222	c->tb = tb;
	223	c->tb->ppc = 1;
	224	c->attr.procedure = 1;
	225	c->attr.proc_pointer = 1;
	226	c->attr.flavor = FL_PROCEDURE;
	227	c->attr.access = ACCESS_PRIVATE;
	228	c->attr.external = 1;
	229	c->attr.untyped = 1;
	230	c->attr.if_source = IFSRC_IFBODY;
d15bac21	231
88ce8031 JW	232	/* A static initializer cannot be used here because the specific
	233	function is not a constant; internal compiler error: in
	234	output_constant, at varasm.c:4623 */
	235	c->initializer = NULL;
d15bac21 JW	236	}
	237	else if (c->attr.proc_pointer && c->tb)
	238	{
88ce8031	239	c->tb = tb;
d15bac21	240	c->tb->ppc = 1;
88ce8031	241	c->ts.interface = tb->u.specific->n.sym;
d15bac21 JW	242	}
	243	}
	244
88ce8031 JW	245
	246	/* Add all specific type-bound procedures in the symtree 'st' to a vtype. */
	247
d15bac21	248	static void
88ce8031	249	add_procs_to_declared_vtab1 (gfc_symtree st, gfc_symbol vtype)
d15bac21	250	{
d15bac21 JW	251	if (!st)
	252	return;
	253
	254	if (st->left)
88ce8031	255	add_procs_to_declared_vtab1 (st->left, vtype);
d15bac21 JW	256
d15bac21 JW	257	if (st->right)
88ce8031	258	add_procs_to_declared_vtab1 (st->right, vtype);
d15bac21 JW	259
	260	if (!st->n.tb)
	261	return;
	262
	263	if (!st->n.tb->is_generic && st->n.tb->u.specific)
88ce8031	264	add_proc_comp (vtype, st->name, st->n.tb);
d15bac21 JW	265	}
	266
	267
88ce8031 JW	268	/* Copy procedure pointers components from the parent type. */
88ce8031 JW	269
d15bac21	270	static void
88ce8031	271	copy_vtab_proc_comps (gfc_symbol declared, gfc_symbol vtype)
d15bac21	272	{
88ce8031	273	gfc_component *cmp;
d15bac21 JW	274	gfc_symbol *vtab;
d15bac21 JW	275
88ce8031	276	vtab = gfc_find_derived_vtab (declared);
d15bac21 JW	277
	278	for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
	279	{
	280	if (gfc_find_component (vtype, cmp->name, true, true))
	281	continue;
	282
88ce8031	283	add_proc_comp (vtype, cmp->name, cmp->tb);
d15bac21 JW	284	}
	285	}
	286
d15bac21	287
88ce8031	288	/* Add procedure pointers for all type-bound procedures to a vtab. */
d15bac21 JW	289
d15bac21 JW	290	static void
88ce8031	291	add_procs_to_declared_vtab (gfc_symbol derived, gfc_symbol vtype)
d15bac21	292	{
d15bac21 JW	293	gfc_symbol* super_type;
d15bac21 JW	294
88ce8031	295	super_type = gfc_get_derived_super_type (derived);
d15bac21	296
88ce8031	297	if (super_type && (super_type != derived))
d15bac21	298	{
88ce8031 JW	299	/* Make sure that the PPCs appear in the same order as in the parent. */
	300	copy_vtab_proc_comps (super_type, vtype);
	301	/* Only needed to get the PPC interfaces right. */
	302	add_procs_to_declared_vtab (super_type, vtype);
	303	}
d15bac21	304
88ce8031 JW	305	if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
88ce8031 JW	306	add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype);
d15bac21	307
88ce8031 JW	308	if (derived->f2k_derived && derived->f2k_derived->tb_uop_root)
88ce8031 JW	309	add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype);
d15bac21 JW	310	}
	311
	312
88ce8031 JW	313	/* Find the symbol for a derived type's vtab.
	314	A vtab has the following fields:
	315	* $hash a hash value used to identify the derived type
	316	* $size the size in bytes of the derived type
	317	* $extends a pointer to the vtable of the parent derived type
	318	After these follow procedure pointer components for the
	319	specific type-bound procedures. */
d15bac21 JW	320
d15bac21 JW	321	gfc_symbol *
88ce8031	322	gfc_find_derived_vtab (gfc_symbol *derived)
d15bac21 JW	323	{
d15bac21 JW	324	gfc_namespace *ns;
81fb8a48	325	gfc_symbol vtab = NULL, vtype = NULL, *found_sym = NULL;
d15bac21 JW	326	char name[2 * GFC_MAX_SYMBOL_LEN + 8];
	327
	328	ns = gfc_current_ns;
	329
	330	for (; ns; ns = ns->parent)
	331	if (!ns->parent)
	332	break;
	333
	334	if (ns)
	335	{
	336	sprintf (name, "vtab$%s", derived->name);
	337	gfc_find_symbol (name, ns, 0, &vtab);
	338
	339	if (vtab == NULL)
	340	{
	341	gfc_get_symbol (name, ns, &vtab);
	342	vtab->ts.type = BT_DERIVED;
	343	vtab->attr.flavor = FL_VARIABLE;
	344	vtab->attr.target = 1;
	345	vtab->attr.save = SAVE_EXPLICIT;
	346	vtab->attr.vtab = 1;
f3f98a1e	347	vtab->attr.access = ACCESS_PUBLIC;
d15bac21 JW	348	vtab->refs++;
	349	gfc_set_sym_referenced (vtab);
	350	sprintf (name, "vtype$%s", derived->name);
	351
	352	gfc_find_symbol (name, ns, 0, &vtype);
	353	if (vtype == NULL)
	354	{
	355	gfc_component *c;
	356	gfc_symbol parent = NULL, parent_vtab = NULL;
	357
	358	gfc_get_symbol (name, ns, &vtype);
	359	if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
	360	NULL, &gfc_current_locus) == FAILURE)
81fb8a48	361	goto cleanup;
f3f98a1e	362	vtype->attr.access = ACCESS_PUBLIC;
d15bac21 JW	363	vtype->refs++;
	364	gfc_set_sym_referenced (vtype);
	365
	366	/* Add component '$hash'. */
	367	if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
81fb8a48	368	goto cleanup;
d15bac21 JW	369	c->ts.type = BT_INTEGER;
	370	c->ts.kind = 4;
	371	c->attr.access = ACCESS_PRIVATE;
	372	c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
	373	NULL, derived->hash_value);
	374
	375	/* Add component '$size'. */
	376	if (gfc_add_component (vtype, "$size", &c) == FAILURE)
81fb8a48	377	goto cleanup;
d15bac21 JW	378	c->ts.type = BT_INTEGER;
	379	c->ts.kind = 4;
	380	c->attr.access = ACCESS_PRIVATE;
	381	/* Remember the derived type in ts.u.derived,
	382	so that the correct initializer can be set later on
	383	(in gfc_conv_structure). */
	384	c->ts.u.derived = derived;
	385	c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
	386	NULL, 0);
	387
	388	/* Add component $extends. */
	389	if (gfc_add_component (vtype, "$extends", &c) == FAILURE)
81fb8a48	390	goto cleanup;
d15bac21 JW	391	c->attr.pointer = 1;
	392	c->attr.access = ACCESS_PRIVATE;
	393	parent = gfc_get_derived_super_type (derived);
	394	if (parent)
	395	{
88ce8031	396	parent_vtab = gfc_find_derived_vtab (parent);
d15bac21 JW	397	c->ts.type = BT_DERIVED;
	398	c->ts.u.derived = parent_vtab->ts.u.derived;
	399	c->initializer = gfc_get_expr ();
	400	c->initializer->expr_type = EXPR_VARIABLE;
	401	gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
	402	0, &c->initializer->symtree);
	403	}
	404	else
	405	{
	406	c->ts.type = BT_DERIVED;
	407	c->ts.u.derived = vtype;
	408	c->initializer = gfc_get_null_expr (NULL);
	409	}
	410
88ce8031	411	add_procs_to_declared_vtab (derived, vtype);
d15bac21 JW	412	vtype->attr.vtype = 1;
	413	}
	414
	415	vtab->ts.u.derived = vtype;
	416	vtab->value = gfc_default_initializer (&vtab->ts);
	417	}
	418	}
	419
81fb8a48 MM	420	found_sym = vtab;
	421
	422	cleanup:
	423	/* It is unexpected to have some symbols added at resolution or code
	424	generation time. We commit the changes in order to keep a clean state. */
	425	if (found_sym)
	426	gfc_commit_symbols ();
	427	else
	428	gfc_undo_symbols ();
	429
	430	return found_sym;
d15bac21 JW	431	}
	432
	433
	434	/* General worker function to find either a type-bound procedure or a
	435	type-bound user operator. */
	436
	437	static gfc_symtree*
	438	find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
	439	const char* name, bool noaccess, bool uop,
	440	locus* where)
	441	{
	442	gfc_symtree* res;
	443	gfc_symtree* root;
	444
	445	/* Set correct symbol-root. */
	446	gcc_assert (derived->f2k_derived);
	447	root = (uop ? derived->f2k_derived->tb_uop_root
	448	: derived->f2k_derived->tb_sym_root);
	449
	450	/* Set default to failure. */
	451	if (t)
	452	*t = FAILURE;
	453
	454	/* Try to find it in the current type's namespace. */
	455	res = gfc_find_symtree (root, name);
	456	if (res && res->n.tb && !res->n.tb->error)
	457	{
	458	/* We found one. */
	459	if (t)
	460	*t = SUCCESS;
	461
	462	if (!noaccess && derived->attr.use_assoc
	463	&& res->n.tb->access == ACCESS_PRIVATE)
	464	{
	465	if (where)
	466	gfc_error ("'%s' of '%s' is PRIVATE at %L",
	467	name, derived->name, where);
	468	if (t)
	469	*t = FAILURE;
	470	}
	471
	472	return res;
	473	}
	474
	475	/* Otherwise, recurse on parent type if derived is an extension. */
	476	if (derived->attr.extension)
	477	{
	478	gfc_symbol* super_type;
	479	super_type = gfc_get_derived_super_type (derived);
	480	gcc_assert (super_type);
	481
	482	return find_typebound_proc_uop (super_type, t, name,
	483	noaccess, uop, where);
	484	}
	485
	486	/* Nothing found. */
	487	return NULL;
	488	}
	489
	490
	491	/* Find a type-bound procedure or user operator by name for a derived-type
	492	(looking recursively through the super-types). */
	493
	494	gfc_symtree*
495	gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
496	const char* name, bool noaccess, locus* where)
497	{
498	return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
499	}
500
501	gfc_symtree*
502	gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
503	const char* name, bool noaccess, locus* where)
504	{
505	return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
506	}
507
508
509	/* Find a type-bound intrinsic operator looking recursively through the
510	super-type hierarchy. */
511
512	gfc_typebound_proc*
513	gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
514	gfc_intrinsic_op op, bool noaccess,
515	locus* where)
516	{
517	gfc_typebound_proc* res;
518
519	/* Set default to failure. */
520	if (t)
521	*t = FAILURE;
522
523	/* Try to find it in the current type's namespace. */
524	if (derived->f2k_derived)
525	res = derived->f2k_derived->tb_op[op];
526	else
527	res = NULL;
528
529	/* Check access. */
530	if (res && !res->error)
531	{
532	/* We found one. */
533	if (t)
534	*t = SUCCESS;
535
536	if (!noaccess && derived->attr.use_assoc
537	&& res->access == ACCESS_PRIVATE)
538	{
539	if (where)
540	gfc_error ("'%s' of '%s' is PRIVATE at %L",
541	gfc_op2string (op), derived->name, where);
542	if (t)
543	*t = FAILURE;
544	}
545
546	return res;
547	}
548
549	/* Otherwise, recurse on parent type if derived is an extension. */
550	if (derived->attr.extension)
551	{
552	gfc_symbol* super_type;
553	super_type = gfc_get_derived_super_type (derived);
554	gcc_assert (super_type);
555
556	return gfc_find_typebound_intrinsic_op (super_type, t, op,
557	noaccess, where);
558	}
559
560	/* Nothing found. */
561	return NULL;
562	}
563
564
565	/* Get a typebound-procedure symtree or create and insert it if not yet
566	present. This is like a very simplified version of gfc_get_sym_tree for
567	tbp-symtrees rather than regular ones. */
568
569	gfc_symtree*
570	gfc_get_tbp_symtree (gfc_symtree *root, const char name)
571	{
572	gfc_symtree *result;
573
574	result = gfc_find_symtree (*root, name);
575	if (!result)
576	{
577	result = gfc_new_symtree (root, name);
578	gcc_assert (result);
579	result->n.tb = NULL;
580	}
581
582	return result;
583	}