From 19387b11ddf1e6d3a00e07958e4d135d58f53ad3 Mon Sep 17 00:00:00 2001 From: janus Date: Mon, 17 May 2010 18:45:32 +0000 Subject: [PATCH] 2010-05-17 Janus Weil * 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159506 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 25 ++ gcc/fortran/Make-lang.in | 14 +- gcc/fortran/expr.c | 56 ---- gcc/fortran/gfortran.h | 28 +- gcc/fortran/symbol.c | 691 ----------------------------------------------- 5 files changed, 47 insertions(+), 767 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 6e632d1a0cb..45fe11a8e17 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,28 @@ +2010-05-17 Janus Weil + + * 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 * trans-types.c (gfc_init_types): Use build_function_type_list. diff --git a/gcc/fortran/Make-lang.in b/gcc/fortran/Make-lang.in index d9544a4e06e..49ffdf963bf 100644 --- a/gcc/fortran/Make-lang.in +++ b/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 \ diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 382d1fe6452..75f27be80ee 100644 --- a/gcc/fortran/expr.c +++ b/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. */ diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 96acaa4574e..c14bcce9423 100644 --- a/gcc/fortran/gfortran.h +++ b/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 */ diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index ceb45bfa6ec..b719de11044 100644 --- a/gcc/fortran/symbol.c +++ b/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; -} -- 2.11.0