/* Implementation of Fortran 2003 Polymorphism. Copyright (C) 2009, 2010 Free Software Foundation, Inc. Contributed by Paul Richard Thomas and 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 . */ /* 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; } /* Tells whether the expression E is a reference to a (scalar) class container. Scalar because array class containers usually have an array reference after them, and gfc_fix_class_refs will add the missing "_data" component reference in that case. */ bool gfc_is_class_container_ref (gfc_expr *e) { gfc_ref *ref; bool result; if (e->expr_type != EXPR_VARIABLE) return e->ts.type == BT_CLASS; if (e->symtree->n.sym->ts.type == BT_CLASS) result = true; else result = false; for (ref = e->ref; ref; ref = ref->next) { if (ref->type != REF_COMPONENT) result = false; else if (ref->u.c.component->ts.type == BT_CLASS) result = true; else result = false; } return result; } /* 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; }