/* Implementation of Fortran 2003 Polymorphism.
Copyright (C) 2009, 2010
Free Software Foundation, Inc.
- Contributed by Paul Richard Thomas & Janus Weil
+ Contributed by Paul Richard Thomas <pault@gcc.gnu.org>
+ and Janus Weil <janus@gcc.gnu.org>
This file is part of GCC.
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
+ * _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.
+ * _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). */
+ * _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 "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;
+
+ if (e->expr_type == EXPR_VARIABLE)
+ ts = &e->symtree->n.sym->ts;
+ else
+ {
+ gfc_symbol *func;
+
+ gcc_assert (e->expr_type == EXPR_FUNCTION);
+ if (e->value.function.esym != NULL)
+ func = e->value.function.esym;
+ else
+ func = e->symtree->n.sym;
+
+ if (func->result != NULL)
+ ts = &func->result->ts;
+ else
+ ts = &func->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. */
+ Only to be used with CLASS containers and vtables. */
void
gfc_add_component_ref (gfc_expr *e, const char *name)
while (*tail != NULL)
{
if ((*tail)->type == REF_COMPONENT)
- derived = (*tail)->u.c.component->ts.u.derived;
+ {
+ 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)
+ if (*tail != NULL && strcmp (name, "_data") == 0)
next = *tail;
(*tail) = gfc_get_ref();
(*tail)->next = next;
}
+/* 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 and $vptr components to zero. */
+ initializing the _data component to NULL and
+ the _vptr component to the declared type. */
gfc_expr *
gfc_class_null_initializer (gfc_typespec *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;
+ 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);
}
}
+/* 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. */
+ 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];
+ 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. */
- 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);
+ 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", ts->u.derived->name);
+ sprintf (name, "__class_%s_p", tname);
else if (attr->allocatable)
- sprintf (name, "class$%s_a", ts->u.derived->name);
+ sprintf (name, "__class_%s_a", tname);
else
- sprintf (name, "class$%s", ts->u.derived->name);
+ sprintf (name, "__class_%s", tname);
gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
if (fclass == NULL)
NULL, &gfc_current_locus) == FAILURE)
return FAILURE;
- /* Add component '$data'. */
- if (gfc_add_component (fclass, "$data", &c) == 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.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->as = (*as);
c->initializer = NULL;
- /* Add component '$vptr'. */
- if (gfc_add_component (fclass, "$vptr", &c) == FAILURE)
+ /* Add component '_vptr'. */
+ if (gfc_add_component (fclass, "_vptr", &c) == FAILURE)
return FAILURE;
c->ts.type = BT_DERIVED;
if (delayed_vtab)
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. */
}
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 = 0;
- (*as) = NULL; /* XXX */
+ attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
+ (*as) = NULL;
return SUCCESS;
}
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)
}
-/* 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
- After these follow procedure pointer components for the
- specific type-bound procedures. */
+/* 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;
- char name[2 * GFC_MAX_SYMBOL_LEN + 8];
-
+ 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)
if (ns)
{
- sprintf (name, "vtab$%s", derived->name);
- gfc_find_symbol (name, ns, 0, &vtab);
+ 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_current_locus) == FAILURE)
goto cleanup;
vtab->attr.target = 1;
- vtab->attr.save = SAVE_EXPLICIT;
+ vtab->attr.save = SAVE_IMPLICIT;
vtab->attr.vtab = 1;
vtab->attr.access = ACCESS_PUBLIC;
gfc_set_sym_referenced (vtab);
- sprintf (name, "vtype$%s", derived->name);
+ sprintf (name, "__vtype_%s", tname);
gfc_find_symbol (name, ns, 0, &vtype);
if (vtype == NULL)
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)
+ /* Add component '_hash'. */
+ if (gfc_add_component (vtype, "_hash", &c) == FAILURE)
goto cleanup;
c->ts.type = BT_INTEGER;
c->ts.kind = 4;
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)
+ /* Add component '_size'. */
+ if (gfc_add_component (vtype, "_size", &c) == FAILURE)
goto cleanup;
c->ts.type = BT_INTEGER;
c->ts.kind = 4;
c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
NULL, 0);
- /* Add component $extends. */
- if (gfc_add_component (vtype, "$extends", &c) == FAILURE)
+ /* Add component _extends. */
+ if (gfc_add_component (vtype, "_extends", &c) == FAILURE)
goto cleanup;
c->attr.pointer = 1;
c->attr.access = ACCESS_PRIVATE;
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);
- vtype->attr.vtype = 1;
}
+have_vtype:
vtab->ts.u.derived = vtype;
vtab->value = gfc_default_initializer (&vtab->ts);
}
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 ();
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;
+ if (derived->f2k_derived)
+ /* Set correct symbol-root. */
+ root = (uop ? derived->f2k_derived->tb_uop_root
+ : derived->f2k_derived->tb_sym_root);
+ else
+ return NULL;
+
/* 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)
OSDN Git Service
