+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.
# 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 \
--- /dev/null
+/* 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;
+}
}
-/* 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 *
}
-/* 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. */
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 *);
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);
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);
/* 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 */
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;
-}
OSDN Git Service
