Skip to content

R
riscv-gcc-1
Commit d15bac21 by Janus Weil
Options

class.c (gfc_add_component_ref,gfc_class_null_initializer, [...]): Moved here from other places. 

2010-05-17  Janus Weil  <janus@gcc.gnu.org>

	* class.c (gfc_add_component_ref,gfc_class_null_initializer,
	gfc_build_class_symbol,add_proc_component,add_proc_comps, 
	add_procs_to_declared_vtab1,copy_vtab_proc_comps,
	add_procs_to_declared_vtab,add_generic_specifics, 
	add_generics_to_declared_vtab,gfc_find_derived_vtab,
	find_typebound_proc_uop,gfc_find_typebound_proc,
	gfc_find_typebound_user_op,gfc_find_typebound_intrinsic_op, 
	gfc_get_tbp_symtree): Moved here from other places.
	* expr.c (gfc_add_component_ref,gfc_class_null_initializer): Move to
	class.c.
	* gfortran.h (gfc_build_class_symbol,gfc_find_derived_vtab,
	gfc_find_typebound_proc,gfc_find_typebound_user_op,
	gfc_find_typebound_intrinsic_op,gfc_get_tbp_symtree,
	gfc_add_component_ref, gfc_class_null_initializer): Moved to class.c.
	* Make-lang.in: Add class.o.
	* symbol.c (gfc_build_class_symbol,add_proc_component,add_proc_comps,
	add_procs_to_declared_vtab1,copy_vtab_proc_comps,
	add_procs_to_declared_vtab,add_generic_specifics,
	add_generics_to_declared_vtab,gfc_find_derived_vtab,
	find_typebound_proc_uop,gfc_find_typebound_proc,
	gfc_find_typebound_user_op,gfc_find_typebound_intrinsic_op,
	gfc_get_tbp_symtree): Move to class.c.

From-SVN: r159506
parent d5d74497
Showing with 844 additions and 767 deletions
gcc/fortran/ChangeLog
2010-05-17 Janus Weil <janus@gcc.gnu.org>
* class.c (gfc_add_component_ref,gfc_class_null_initializer,
gfc_build_class_symbol,add_proc_component,add_proc_comps,
add_procs_to_declared_vtab1,copy_vtab_proc_comps,
add_procs_to_declared_vtab,add_generic_specifics,
add_generics_to_declared_vtab,gfc_find_derived_vtab,
find_typebound_proc_uop,gfc_find_typebound_proc,
gfc_find_typebound_user_op,gfc_find_typebound_intrinsic_op,
gfc_get_tbp_symtree): Moved here from other places.
* expr.c (gfc_add_component_ref,gfc_class_null_initializer): Move to
class.c.
* gfortran.h (gfc_build_class_symbol,gfc_find_derived_vtab,
gfc_find_typebound_proc,gfc_find_typebound_user_op,
gfc_find_typebound_intrinsic_op,gfc_get_tbp_symtree,
gfc_add_component_ref, gfc_class_null_initializer): Moved to class.c.
* Make-lang.in: Add class.o.
* symbol.c (gfc_build_class_symbol,add_proc_component,add_proc_comps,
add_procs_to_declared_vtab1,copy_vtab_proc_comps,
add_procs_to_declared_vtab,add_generic_specifics,
add_generics_to_declared_vtab,gfc_find_derived_vtab,
find_typebound_proc_uop,gfc_find_typebound_proc,
gfc_find_typebound_user_op,gfc_find_typebound_intrinsic_op,
gfc_get_tbp_symtree): Move to class.c.
2010-05-17 Nathan Froyd <froydnj@codesourcery.com>
* trans-types.c (gfc_init_types): Use build_function_type_list.
......
gcc/fortran/Make-lang.in
......@@ -53,13 +53,13 @@ fortran-warn = $(STRICT_WARN)
# from the parse tree to GENERIC
F95_PARSER_OBJS = fortran/arith.o fortran/array.o fortran/bbt.o \
fortran/check.o fortran/constructor.o fortran/cpp.o fortran/data.o \
fortran/decl.o fortran/dump-parse-tree.o fortran/error.o fortran/expr.o \
fortran/interface.o fortran/intrinsic.o fortran/io.o fortran/iresolve.o \
fortran/match.o fortran/matchexp.o fortran/misc.o fortran/module.o \
fortran/openmp.o fortran/options.o fortran/parse.o fortran/primary.o \
fortran/resolve.o fortran/scanner.o fortran/simplify.o fortran/st.o \
fortran/symbol.o fortran/target-memory.o
fortran/check.o fortran/class.o fortran/constructor.o fortran/cpp.o \
fortran/data.o fortran/decl.o fortran/dump-parse-tree.o fortran/error.o \
fortran/expr.o fortran/interface.o fortran/intrinsic.o fortran/io.o \
fortran/iresolve.o fortran/match.o fortran/matchexp.o fortran/misc.o \
fortran/module.o fortran/openmp.o fortran/options.o fortran/parse.o \
fortran/primary.o fortran/resolve.o fortran/scanner.o fortran/simplify.o \
fortran/st.o fortran/symbol.o fortran/target-memory.o
F95_OBJS = $(F95_PARSER_OBJS) $(FORTRAN_TARGET_OBJS) \
fortran/convert.o fortran/dependency.o fortran/f95-lang.o \
......
gcc/fortran/class.c 0 → 100644
/* 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;
}
gcc/fortran/expr.c
......@@ -676,36 +676,6 @@ gfc_has_vector_index (gfc_expr *e)
}
/* 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;
}
/* Copy a shape array. */
mpz_t *
......@@ -3628,32 +3598,6 @@ gfc_default_initializer (gfc_typespec *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;
}
/* Given a symbol, create an expression node with that symbol as a
variable. If the symbol is array valued, setup a reference of the
whole array. */
......
gcc/fortran/gfortran.h
......@@ -2512,22 +2512,11 @@ void gfc_free_dt_list (void);
gfc_gsymbol *gfc_get_gsymbol (const char *);
gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
gfc_array_spec **, bool);
gfc_symbol *gfc_find_derived_vtab (gfc_symbol *, bool);
gfc_typebound_proc* gfc_get_typebound_proc (void);
gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
gfc_symbol* gfc_get_ultimate_derived_super_type (gfc_symbol*);
bool gfc_type_is_extension_of (gfc_symbol *, gfc_symbol *);
bool gfc_type_compatible (gfc_typespec *, gfc_typespec *);
gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*,
const char*, bool, locus*);
gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*,
const char*, bool, locus*);
gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, gfc_try*,
gfc_intrinsic_op, bool,
locus*);
gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
void gfc_copy_formal_args (gfc_symbol *, gfc_symbol *);
void gfc_copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *);
......@@ -2593,7 +2582,6 @@ gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
const char *gfc_extract_int (gfc_expr *, int *);
bool is_subref_array (gfc_expr *);
void gfc_add_component_ref (gfc_expr *, const char *);
gfc_expr *gfc_build_conversion (gfc_expr *);
void gfc_free_ref_list (gfc_ref *);
void gfc_type_convert_binary (gfc_expr *, int);
......@@ -2630,7 +2618,6 @@ gfc_try gfc_check_pointer_assign (gfc_expr *, gfc_expr *);
gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *);
gfc_expr *gfc_default_initializer (gfc_typespec *);
gfc_expr *gfc_class_null_initializer (gfc_typespec *);
gfc_expr *gfc_get_variable_expr (gfc_symtree *);
gfc_array_spec *gfc_get_full_arrayspec_from_expr (gfc_expr *expr);
......@@ -2785,4 +2772,19 @@ int gfc_is_data_pointer (gfc_expr *);
/* check.c */
gfc_try gfc_check_same_strlen (const gfc_expr*, const gfc_expr*, const char*);
/* class.c */
void gfc_add_component_ref (gfc_expr *, const char *);
gfc_expr *gfc_class_null_initializer (gfc_typespec *);
gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
gfc_array_spec **, bool);
gfc_symbol *gfc_find_derived_vtab (gfc_symbol *, bool);
gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*,
const char*, bool, locus*);
gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*,
const char*, bool, locus*);
gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, gfc_try*,
gfc_intrinsic_op, bool,
locus*);
gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
#endif /* GCC_GFORTRAN_H */
gcc/fortran/symbol.c
......@@ -4699,694 +4699,3 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
else
return 0;
}
/* 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;
}
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment