URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [fortran/] [class.c] - Rev 712
Compare with Previous | Blame | View Log
/* Implementation of Fortran 2003 Polymorphism. Copyright (C) 2009, 2010 Free Software Foundation, Inc. Contributed by Paul Richard Thomas <pault@gcc.gnu.org> and Janus Weil <janus@gcc.gnu.org> 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. * _def_init: A pointer to a default initialized variable of this type. * _copy: A procedure pointer to a copying procedure. After these follow procedure pointer components for the specific type-bound procedures. */ #include "config.h" #include "system.h" #include "gfortran.h" #include "constructor.h" /* Inserts a derived type component reference in a data reference chain. TS: base type of the ref chain so far, in which we will pick the component REF: the address of the GFC_REF pointer to update NAME: name of the component to insert Note that component insertion makes sense only if we are at the end of the chain (*REF == NULL) or if we are adding a missing "_data" component to access the actual contents of a class object. */ static void insert_component_ref (gfc_typespec *ts, gfc_ref **ref, const char * const name) { gfc_symbol *type_sym; gfc_ref *new_ref; gcc_assert (ts->type == BT_DERIVED || ts->type == BT_CLASS); type_sym = ts->u.derived; new_ref = gfc_get_ref (); new_ref->type = REF_COMPONENT; new_ref->next = *ref; new_ref->u.c.sym = type_sym; new_ref->u.c.component = gfc_find_component (type_sym, name, true, true); gcc_assert (new_ref->u.c.component); if (new_ref->next) { gfc_ref *next = NULL; /* We need to update the base type in the trailing reference chain to that of the new component. */ gcc_assert (strcmp (name, "_data") == 0); if (new_ref->next->type == REF_COMPONENT) next = new_ref->next; else if (new_ref->next->type == REF_ARRAY && new_ref->next->next && new_ref->next->next->type == REF_COMPONENT) next = new_ref->next->next; if (next != NULL) { gcc_assert (new_ref->u.c.component->ts.type == BT_CLASS || new_ref->u.c.component->ts.type == BT_DERIVED); next->u.c.sym = new_ref->u.c.component->ts.u.derived; } } *ref = new_ref; } /* Tells whether we need to add a "_data" reference to access REF subobject from an object of type TS. If FIRST_REF_IN_CHAIN is set, then the base object accessed by REF is a variable; in other words it is a full object, not a subobject. */ static bool class_data_ref_missing (gfc_typespec *ts, gfc_ref *ref, bool first_ref_in_chain) { /* Only class containers may need the "_data" reference. */ if (ts->type != BT_CLASS) return false; /* Accessing a class container with an array reference is certainly wrong. */ if (ref->type != REF_COMPONENT) return true; /* Accessing the class container's fields is fine. */ if (ref->u.c.component->name[0] == '_') return false; /* At this point we have a class container with a non class container's field component reference. We don't want to add the "_data" component if we are at the first reference and the symbol's type is an extended derived type. In that case, conv_parent_component_references will do the right thing so it is not absolutely necessary. Omitting it prevents a regression (see class_41.f03) in the interface mapping mechanism. When evaluating string lengths depending on dummy arguments, we create a fake symbol with a type equal to that of the dummy type. However, because of type extension, the backend type (corresponding to the actual argument) can have a different (extended) type. Adding the "_data" component explicitly, using the base type, confuses the gfc_conv_component_ref code which deals with the extended type. */ if (first_ref_in_chain && ts->u.derived->attr.extension) return false; /* We have a class container with a non class container's field component reference that doesn't fall into the above. */ return true; } /* Browse through a data reference chain and add the missing "_data" references when a subobject of a class object is accessed without it. Note that it doesn't add the "_data" reference when the class container is the last element in the reference chain. */ void gfc_fix_class_refs (gfc_expr *e) { gfc_typespec *ts; gfc_ref **ref; if ((e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION) || (e->expr_type == EXPR_FUNCTION && e->value.function.isym != NULL)) return; ts = &e->symtree->n.sym->ts; for (ref = &e->ref; *ref != NULL; ref = &(*ref)->next) { if (class_data_ref_missing (ts, *ref, ref == &e->ref)) insert_component_ref (ts, ref, "_data"); if ((*ref)->type == REF_COMPONENT) ts = &(*ref)->u.c.component->ts; } } /* Insert a reference to the component of the given name. Only to be used with CLASS containers and vtables. */ 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) { if (strcmp ((*tail)->u.c.component->name, "_data") == 0 && (*tail)->next && (*tail)->next->type == REF_ARRAY && (*tail)->next->next == NULL) return; 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; } /* This is used to add both the _data component reference and an array reference to class expressions. Used in translation of intrinsic array inquiry functions. */ void gfc_add_class_array_ref (gfc_expr *e) { int rank = CLASS_DATA (e)->as->rank; gfc_array_spec *as = CLASS_DATA (e)->as; gfc_ref *ref = NULL; gfc_add_component_ref (e, "_data"); e->rank = rank; for (ref = e->ref; ref; ref = ref->next) if (!ref->next) break; if (ref->type != REF_ARRAY) { ref->next = gfc_get_ref (); ref = ref->next; ref->type = REF_ARRAY; ref->u.ar.type = AR_FULL; ref->u.ar.as = as; } } /* Unfortunately, class array expressions can appear in various conditions; with and without both _data component and an arrayspec. This function deals with that variability. The previous reference to 'ref' is to a class array. */ static bool class_array_ref_detected (gfc_ref *ref, bool *full_array) { bool no_data = false; bool with_data = false; /* An array reference with no _data component. */ if (ref && ref->type == REF_ARRAY && !ref->next && ref->u.ar.type != AR_ELEMENT) { if (full_array) *full_array = ref->u.ar.type == AR_FULL; no_data = true; } /* Cover cases where _data appears, with or without an array ref. */ if (ref && ref->type == REF_COMPONENT && strcmp (ref->u.c.component->name, "_data") == 0) { if (!ref->next) { with_data = true; if (full_array) *full_array = true; } else if (ref->next && ref->next->type == REF_ARRAY && !ref->next->next && ref->type == REF_COMPONENT && ref->next->type == REF_ARRAY && ref->next->u.ar.type != AR_ELEMENT) { with_data = true; if (full_array) *full_array = ref->next->u.ar.type == AR_FULL; } } return no_data || with_data; } /* Returns true if the expression contains a reference to a class array. Notice that class array elements return false. */ bool gfc_is_class_array_ref (gfc_expr *e, bool *full_array) { gfc_ref *ref; if (!e->rank) return false; if (full_array) *full_array= false; /* Is this a class array object? ie. Is the symbol of type class? */ if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS && CLASS_DATA (e->symtree->n.sym) && CLASS_DATA (e->symtree->n.sym)->attr.dimension && class_array_ref_detected (e->ref, full_array)) return true; /* Or is this a class array component reference? */ for (ref = e->ref; ref; ref = ref->next) { if (ref->type == REF_COMPONENT && ref->u.c.component->ts.type == BT_CLASS && CLASS_DATA (ref->u.c.component)->attr.dimension && class_array_ref_detected (ref->next, full_array)) return true; } return false; } /* Returns true if the expression is a reference to a class scalar. This function is necessary because such expressions can be dressed with a reference to the _data component and so have a type other than BT_CLASS. */ bool gfc_is_class_scalar_expr (gfc_expr *e) { gfc_ref *ref; if (e->rank) return false; /* Is this a class object? */ if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS && CLASS_DATA (e->symtree->n.sym) && !CLASS_DATA (e->symtree->n.sym)->attr.dimension && (e->ref == NULL || (strcmp (e->ref->u.c.component->name, "_data") == 0 && e->ref->next == NULL))) return true; /* Or is the final reference BT_CLASS or _data? */ for (ref = e->ref; ref; ref = ref->next) { if (ref->type == REF_COMPONENT && ref->u.c.component->ts.type == BT_CLASS && CLASS_DATA (ref->u.c.component) && !CLASS_DATA (ref->u.c.component)->attr.dimension && (ref->next == NULL || (strcmp (ref->next->u.c.component->name, "_data") == 0 && ref->next->next == NULL))) return true; } return false; } /* Build a NULL initializer for CLASS pointers, initializing the _data component to NULL and the _vptr component to the declared type. */ 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(); if (strcmp (comp->name, "_vptr") == 0) ctor->expr = gfc_lval_expr_from_sym (gfc_find_derived_vtab (ts->u.derived)); else ctor->expr = gfc_get_null_expr (NULL); gfc_constructor_append (&init->value.constructor, ctor); } return init; } /* Create a unique string identifier for a derived type, composed of its name and module name. This is used to construct unique names for the class containers and vtab symbols. */ static void get_unique_type_string (char *string, gfc_symbol *derived) { char dt_name[GFC_MAX_SYMBOL_LEN+1]; sprintf (dt_name, "%s", derived->name); dt_name[0] = TOUPPER (dt_name[0]); if (derived->module) sprintf (string, "%s_%s", derived->module, dt_name); else if (derived->ns->proc_name) sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_name); else sprintf (string, "_%s", dt_name); } /* A relative of 'get_unique_type_string' which makes sure the generated string will not be too long (replacing it by a hash string if needed). */ static void get_unique_hashed_string (char *string, gfc_symbol *derived) { char tmp[2*GFC_MAX_SYMBOL_LEN+2]; get_unique_type_string (&tmp[0], derived); /* If string is too long, use hash value in hex representation (allow for extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab). We need space to for 15 characters "__class_" + symbol name + "_%d_%da", where %d is the (co)rank which can be up to n = 15. */ if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 15) { int h = gfc_hash_value (derived); sprintf (string, "%X", h); } else strcpy (string, tmp); } /* Assign a hash value for a derived type. The algorithm is that of SDBM. */ unsigned int gfc_hash_value (gfc_symbol *sym) { unsigned int hash = 0; char c[2*(GFC_MAX_SYMBOL_LEN+1)]; int i, len; get_unique_type_string (&c[0], sym); len = strlen (c); for (i = 0; i < len; i++) hash = (hash << 6) + (hash << 16) - hash + c[i]; /* Return the hash but take the modulus for the sake of module read, even though this slightly increases the chance of collision. */ return (hash % 100000000); } /* 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+1], tname[GFC_MAX_SYMBOL_LEN+1]; gfc_symbol *fclass; gfc_symbol *vtab; gfc_component *c; if (as && *as && (*as)->type == AS_ASSUMED_SIZE) { gfc_error ("Assumed size polymorphic objects or components, such " "as that at %C, have not yet been implemented"); return FAILURE; } if (attr->class_ok) /* Class container has already been built. */ return SUCCESS; attr->class_ok = attr->dummy || attr->pointer || attr->allocatable || attr->select_type_temporary; if (!attr->class_ok) /* We can not build the class container yet. */ return SUCCESS; /* Determine the name of the encapsulating type. */ get_unique_hashed_string (tname, ts->u.derived); if ((*as) && attr->allocatable) sprintf (name, "__class_%s_%d_%da", tname, (*as)->rank, (*as)->corank); else if ((*as)) sprintf (name, "__class_%s_%d_%d", tname, (*as)->rank, (*as)->corank); else if (attr->pointer) sprintf (name, "__class_%s_p", tname); else if (attr->allocatable) sprintf (name, "__class_%s_a", tname); else sprintf (name, "__class_%s", tname); 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 && !attr->allocatable) || attr->select_type_temporary; c->attr.allocatable = attr->allocatable; c->attr.dimension = attr->dimension; c->attr.codimension = attr->codimension; c->attr.abstract = ts->u.derived->attr.abstract; c->as = (*as); c->initializer = NULL; /* Add component '_vptr'. */ if (gfc_add_component (fclass, "_vptr", &c) == FAILURE) return FAILURE; c->ts.type = BT_DERIVED; if (delayed_vtab) c->ts.u.derived = NULL; else { vtab = gfc_find_derived_vtab (ts->u.derived); gcc_assert (vtab); c->ts.u.derived = vtab->ts.u.derived; } c->attr.access = ACCESS_PRIVATE; c->attr.pointer = 1; } else if (!fclass->f2k_derived) fclass->f2k_derived = gfc_get_namespace (NULL, 0); /* 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.alloc_comp = ts->u.derived->attr.alloc_comp; fclass->attr.is_class = 1; ts->u.derived = fclass; attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0; (*as) = NULL; return SUCCESS; } /* Add a procedure pointer component to the vtype to represent a specific type-bound procedure. */ static void add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb) { gfc_component *c; if (tb->non_overridable) return; c = gfc_find_component (vtype, name, true, true); if (c == NULL) { /* Add procedure component. */ if (gfc_add_component (vtype, name, &c) == FAILURE) return; if (!c->tb) c->tb = XCNEW (gfc_typebound_proc); *c->tb = *tb; c->tb->ppc = 1; c->attr.procedure = 1; c->attr.proc_pointer = 1; c->attr.flavor = FL_PROCEDURE; c->attr.access = ACCESS_PRIVATE; c->attr.external = 1; c->attr.untyped = 1; c->attr.if_source = IFSRC_IFBODY; } else if (c->attr.proc_pointer && c->tb) { *c->tb = *tb; c->tb->ppc = 1; } if (tb->u.specific) { c->ts.interface = tb->u.specific->n.sym; if (!tb->deferred) c->initializer = gfc_get_variable_expr (tb->u.specific); } } /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */ static void add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype) { if (!st) return; if (st->left) add_procs_to_declared_vtab1 (st->left, vtype); if (st->right) add_procs_to_declared_vtab1 (st->right, vtype); if (st->n.tb && !st->n.tb->error && !st->n.tb->is_generic && st->n.tb->u.specific) add_proc_comp (vtype, st->name, st->n.tb); } /* Copy procedure pointers components from the parent type. */ static void copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype) { gfc_component *cmp; gfc_symbol *vtab; vtab = gfc_find_derived_vtab (declared); for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next) { if (gfc_find_component (vtype, cmp->name, true, true)) continue; add_proc_comp (vtype, cmp->name, cmp->tb); } } /* Add procedure pointers for all type-bound procedures to a vtab. */ static void add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype) { gfc_symbol* super_type; super_type = gfc_get_derived_super_type (derived); if (super_type && (super_type != derived)) { /* Make sure that the PPCs appear in the same order as in the parent. */ copy_vtab_proc_comps (super_type, vtype); /* Only needed to get the PPC initializers right. */ add_procs_to_declared_vtab (super_type, vtype); } if (derived->f2k_derived && derived->f2k_derived->tb_sym_root) add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype); if (derived->f2k_derived && derived->f2k_derived->tb_uop_root) add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype); } /* Find (or generate) the symbol for a derived type's vtab. */ gfc_symbol * gfc_find_derived_vtab (gfc_symbol *derived) { gfc_namespace *ns; gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL; gfc_symbol *copy = NULL, *src = NULL, *dst = NULL; /* Find the top-level namespace (MODULE or PROGRAM). */ for (ns = gfc_current_ns; ns; ns = ns->parent) if (!ns->parent) break; /* If the type is a class container, use the underlying derived type. */ if (derived->attr.is_class) derived = gfc_get_derived_super_type (derived); if (ns) { char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1]; get_unique_hashed_string (tname, derived); sprintf (name, "__vtab_%s", tname); /* Look for the vtab symbol in various namespaces. */ gfc_find_symbol (name, gfc_current_ns, 0, &vtab); if (vtab == NULL) gfc_find_symbol (name, ns, 0, &vtab); if (vtab == NULL) gfc_find_symbol (name, derived->ns, 0, &vtab); if (vtab == NULL) { gfc_get_symbol (name, ns, &vtab); vtab->ts.type = BT_DERIVED; if (gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL, &gfc_current_locus) == FAILURE) goto cleanup; vtab->attr.target = 1; vtab->attr.save = SAVE_IMPLICIT; vtab->attr.vtab = 1; vtab->attr.access = ACCESS_PUBLIC; gfc_set_sym_referenced (vtab); sprintf (name, "__vtype_%s", tname); gfc_find_symbol (name, ns, 0, &vtype); if (vtype == NULL) { gfc_component *c; gfc_symbol *parent = NULL, *parent_vtab = NULL; gfc_get_symbol (name, ns, &vtype); if (gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL, &gfc_current_locus) == FAILURE) goto cleanup; vtype->attr.access = ACCESS_PUBLIC; vtype->attr.vtype = 1; gfc_set_sym_referenced (vtype); /* Add component '_hash'. */ if (gfc_add_component (vtype, "_hash", &c) == FAILURE) goto cleanup; c->ts.type = BT_INTEGER; c->ts.kind = 4; c->attr.access = ACCESS_PRIVATE; c->initializer = gfc_get_int_expr (gfc_default_integer_kind, NULL, derived->hash_value); /* Add component '_size'. */ if (gfc_add_component (vtype, "_size", &c) == FAILURE) goto cleanup; c->ts.type = BT_INTEGER; c->ts.kind = 4; c->attr.access = ACCESS_PRIVATE; /* Remember the derived type in ts.u.derived, so that the correct initializer can be set later on (in gfc_conv_structure). */ c->ts.u.derived = derived; c->initializer = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); /* Add component _extends. */ if (gfc_add_component (vtype, "_extends", &c) == FAILURE) goto cleanup; c->attr.pointer = 1; c->attr.access = ACCESS_PRIVATE; parent = gfc_get_derived_super_type (derived); if (parent) { parent_vtab = gfc_find_derived_vtab (parent); c->ts.type = BT_DERIVED; c->ts.u.derived = parent_vtab->ts.u.derived; c->initializer = gfc_get_expr (); c->initializer->expr_type = EXPR_VARIABLE; gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, 0, &c->initializer->symtree); } else { c->ts.type = BT_DERIVED; c->ts.u.derived = vtype; c->initializer = gfc_get_null_expr (NULL); } if (derived->components == NULL && !derived->attr.zero_comp) { /* At this point an error must have occurred. Prevent further errors on the vtype components. */ found_sym = vtab; goto have_vtype; } /* Add component _def_init. */ if (gfc_add_component (vtype, "_def_init", &c) == FAILURE) goto cleanup; c->attr.pointer = 1; c->attr.access = ACCESS_PRIVATE; c->ts.type = BT_DERIVED; c->ts.u.derived = derived; if (derived->attr.abstract) c->initializer = gfc_get_null_expr (NULL); else { /* Construct default initialization variable. */ sprintf (name, "__def_init_%s", tname); gfc_get_symbol (name, ns, &def_init); def_init->attr.target = 1; def_init->attr.save = SAVE_IMPLICIT; def_init->attr.access = ACCESS_PUBLIC; def_init->attr.flavor = FL_VARIABLE; gfc_set_sym_referenced (def_init); def_init->ts.type = BT_DERIVED; def_init->ts.u.derived = derived; def_init->value = gfc_default_initializer (&def_init->ts); c->initializer = gfc_lval_expr_from_sym (def_init); } /* Add component _copy. */ if (gfc_add_component (vtype, "_copy", &c) == FAILURE) goto cleanup; c->attr.proc_pointer = 1; c->attr.access = ACCESS_PRIVATE; c->tb = XCNEW (gfc_typebound_proc); c->tb->ppc = 1; if (derived->attr.abstract) c->initializer = gfc_get_null_expr (NULL); else { /* Set up namespace. */ gfc_namespace *sub_ns = gfc_get_namespace (ns, 0); sub_ns->sibling = ns->contained; ns->contained = sub_ns; sub_ns->resolved = 1; /* Set up procedure symbol. */ sprintf (name, "__copy_%s", tname); gfc_get_symbol (name, sub_ns, ©); sub_ns->proc_name = copy; copy->attr.flavor = FL_PROCEDURE; copy->attr.subroutine = 1; copy->attr.pure = 1; copy->attr.if_source = IFSRC_DECL; /* This is elemental so that arrays are automatically treated correctly by the scalarizer. */ copy->attr.elemental = 1; if (ns->proc_name->attr.flavor == FL_MODULE) copy->module = ns->proc_name->name; gfc_set_sym_referenced (copy); /* Set up formal arguments. */ gfc_get_symbol ("src", sub_ns, &src); src->ts.type = BT_DERIVED; src->ts.u.derived = derived; src->attr.flavor = FL_VARIABLE; src->attr.dummy = 1; src->attr.intent = INTENT_IN; gfc_set_sym_referenced (src); copy->formal = gfc_get_formal_arglist (); copy->formal->sym = src; gfc_get_symbol ("dst", sub_ns, &dst); dst->ts.type = BT_DERIVED; dst->ts.u.derived = derived; dst->attr.flavor = FL_VARIABLE; dst->attr.dummy = 1; dst->attr.intent = INTENT_OUT; gfc_set_sym_referenced (dst); copy->formal->next = gfc_get_formal_arglist (); copy->formal->next->sym = dst; /* Set up code. */ sub_ns->code = gfc_get_code (); sub_ns->code->op = EXEC_INIT_ASSIGN; sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst); sub_ns->code->expr2 = gfc_lval_expr_from_sym (src); /* Set initializer. */ c->initializer = gfc_lval_expr_from_sym (copy); c->ts.interface = copy; } /* Add procedure pointers for type-bound procedures. */ add_procs_to_declared_vtab (derived, vtype); } have_vtype: vtab->ts.u.derived = vtype; vtab->value = gfc_default_initializer (&vtab->ts); } } found_sym = vtab; cleanup: /* It is unexpected to have some symbols added at resolution or code generation time. We commit the changes in order to keep a clean state. */ if (found_sym) { gfc_commit_symbol (vtab); if (vtype) gfc_commit_symbol (vtype); if (def_init) gfc_commit_symbol (def_init); if (copy) gfc_commit_symbol (copy); if (src) gfc_commit_symbol (src); if (dst) gfc_commit_symbol (dst); } else gfc_undo_symbols (); return found_sym; } /* General worker function to find either a type-bound procedure or a type-bound user operator. */ static gfc_symtree* find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t, const char* name, bool noaccess, bool uop, locus* where) { gfc_symtree* res; gfc_symtree* root; /* Set correct symbol-root. */ gcc_assert (derived->f2k_derived); root = (uop ? derived->f2k_derived->tb_uop_root : derived->f2k_derived->tb_sym_root); /* Set default to failure. */ if (t) *t = FAILURE; /* Try to find it in the current type's namespace. */ res = gfc_find_symtree (root, name); if (res && res->n.tb && !res->n.tb->error) { /* We found one. */ if (t) *t = SUCCESS; if (!noaccess && derived->attr.use_assoc && res->n.tb->access == ACCESS_PRIVATE) { if (where) gfc_error ("'%s' of '%s' is PRIVATE at %L", name, derived->name, where); if (t) *t = FAILURE; } return res; } /* Otherwise, recurse on parent type if derived is an extension. */ if (derived->attr.extension) { gfc_symbol* super_type; super_type = gfc_get_derived_super_type (derived); gcc_assert (super_type); return find_typebound_proc_uop (super_type, t, name, noaccess, uop, where); } /* Nothing found. */ return NULL; } /* Find a type-bound procedure or user operator by name for a derived-type (looking recursively through the super-types). */ gfc_symtree* gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t, const char* name, bool noaccess, locus* where) { return find_typebound_proc_uop (derived, t, name, noaccess, false, where); } gfc_symtree* gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t, const char* name, bool noaccess, locus* where) { return find_typebound_proc_uop (derived, t, name, noaccess, true, where); } /* Find a type-bound intrinsic operator looking recursively through the super-type hierarchy. */ gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t, gfc_intrinsic_op op, bool noaccess, locus* where) { gfc_typebound_proc* res; /* Set default to failure. */ if (t) *t = FAILURE; /* Try to find it in the current type's namespace. */ if (derived->f2k_derived) res = derived->f2k_derived->tb_op[op]; else res = NULL; /* Check access. */ if (res && !res->error) { /* We found one. */ if (t) *t = SUCCESS; if (!noaccess && derived->attr.use_assoc && res->access == ACCESS_PRIVATE) { if (where) gfc_error ("'%s' of '%s' is PRIVATE at %L", gfc_op2string (op), derived->name, where); if (t) *t = FAILURE; } return res; } /* Otherwise, recurse on parent type if derived is an extension. */ if (derived->attr.extension) { gfc_symbol* super_type; super_type = gfc_get_derived_super_type (derived); gcc_assert (super_type); return gfc_find_typebound_intrinsic_op (super_type, t, op, noaccess, where); } /* Nothing found. */ return NULL; } /* Get a typebound-procedure symtree or create and insert it if not yet present. This is like a very simplified version of gfc_get_sym_tree for tbp-symtrees rather than regular ones. */ gfc_symtree* gfc_get_tbp_symtree (gfc_symtree **root, const char *name) { gfc_symtree *result; result = gfc_find_symtree (*root, name); if (!result) { result = gfc_new_symtree (root, name); gcc_assert (result); result->n.tb = NULL; } return result; }