/* Implementation of Fortran 2003 Polymorphism.
- Copyright (C) 2009, 2010
- Free Software Foundation, Inc.
+ Copyright (C) 2009-2020 Free Software Foundation, Inc.
Contributed by Paul Richard Thomas <pault@gcc.gnu.org>
and Janus Weil <janus@gcc.gnu.org>
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.
-
+
+ Only for unlimited polymorphic classes:
+ * _len: An integer(C_SIZE_T) to store the string length when the unlimited
+ polymorphic pointer is used to point to a char array. The '_len'
+ component will be zero when no character array is stored in
+ '_data'.
+
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.
* _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.
+ * _final: A procedure pointer to a wrapper function, which frees
+ allocatable components and calls FINAL subroutines.
+
After these follow procedure pointer components for the specific
type-bound procedures. */
#include "config.h"
#include "system.h"
+#include "coretypes.h"
#include "gfortran.h"
#include "constructor.h"
+#include "target-memory.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_ref *new_ref;
+ int wcnt, ecnt;
+
+ gcc_assert (ts->type == BT_DERIVED || ts->type == BT_CLASS);
+
+ gfc_find_component (ts->u.derived, name, true, true, &new_ref);
+
+ gfc_get_errors (&wcnt, &ecnt);
+ if (ecnt > 0 && !new_ref)
+ return;
+ gcc_assert (new_ref->u.c.component);
+
+ while (new_ref->next)
+ new_ref = new_ref->next;
+ new_ref->next = *ref;
+
+ 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.
void
gfc_add_component_ref (gfc_expr *e, const char *name)
{
+ gfc_component *c;
gfc_ref **tail = &(e->ref);
- gfc_ref *next = NULL;
+ gfc_ref *ref, *next = NULL;
gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
while (*tail != NULL)
{
break;
tail = &((*tail)->next);
}
+ if (derived->components && derived->components->next &&
+ derived->components->next->ts.type == BT_DERIVED &&
+ derived->components->next->ts.u.derived == NULL)
+ {
+ /* Fix up missing vtype. */
+ gfc_symbol *vtab = gfc_find_derived_vtab (derived->components->ts.u.derived);
+ gcc_assert (vtab);
+ derived->components->next->ts.u.derived = vtab->ts.u.derived;
+ }
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;
+ else
+ /* Avoid losing memory. */
+ gfc_free_ref_list (*tail);
+ c = gfc_find_component (derived, name, true, true, tail);
+
+ if (c) {
+ for (ref = *tail; ref->next; ref = ref->next)
+ ;
+ ref->next = next;
+ if (!next)
+ e->ts = c->ts;
+ }
}
void
gfc_add_class_array_ref (gfc_expr *e)
{
- int rank = CLASS_DATA (e)->as->rank;
+ 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");
+ gfc_add_data_component (e);
e->rank = rank;
for (ref = e->ref; ref; ref = ref->next)
if (!ref->next)
ref = ref->next;
ref->type = REF_ARRAY;
ref->u.ar.type = AR_FULL;
- ref->u.ar.as = as;
+ ref->u.ar.as = as;
}
}
*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;
&& 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->type == REF_COMPONENT
+ && strcmp (e->ref->u.c.component->name, "_data") == 0
&& e->ref->next == NULL)))
return true;
&& 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->type == REF_COMPONENT
+ && strcmp (ref->next->u.c.component->name, "_data") == 0
&& ref->next->next == NULL)))
return true;
}
}
-/* Build a NULL initializer for CLASS pointers,
- initializing the _data component to NULL and
- the _vptr component to the declared type. */
+/* 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 an initializer for CLASS pointers,
+ initializing the _data component to the init_expr (or NULL) and the _vptr
+ component to the corresponding type (or the declared type, given by ts). */
gfc_expr *
-gfc_class_null_initializer (gfc_typespec *ts)
+gfc_class_initializer (gfc_typespec *ts, gfc_expr *init_expr)
{
gfc_expr *init;
gfc_component *comp;
-
+ gfc_symbol *vtab = NULL;
+
+ if (init_expr && init_expr->expr_type != EXPR_NULL)
+ vtab = gfc_find_vtab (&init_expr->ts);
+ else
+ vtab = gfc_find_vtab (ts);
+
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));
+ if (strcmp (comp->name, "_vptr") == 0 && vtab)
+ ctor->expr = gfc_lval_expr_from_sym (vtab);
+ else if (init_expr && init_expr->expr_type != EXPR_NULL)
+ ctor->expr = gfc_copy_expr (init_expr);
else
ctor->expr = gfc_get_null_expr (NULL);
gfc_constructor_append (&init->value.constructor, ctor);
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)
+ if (derived->attr.unlimited_polymorphic)
+ strcpy (dt_name, "STAR");
+ else
+ strcpy (dt_name, gfc_dt_upper_string (derived->name));
+ if (derived->attr.unlimited_polymorphic)
+ sprintf (string, "_%s", dt_name);
+ else 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);
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);
+}
+
+
+/* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */
+
+unsigned int
+gfc_intrinsic_hash_value (gfc_typespec *ts)
+{
+ unsigned int hash = 0;
+ const char *c = gfc_typename (ts);
+ int i, len;
+
+ len = strlen (c);
+
for (i = 0; i < len; i++)
hash = (hash << 6) + (hash << 16) - hash + c[i];
}
+/* Get the _len component from a class/derived object storing a string.
+ For unlimited polymorphic entities a ref to the _data component is available
+ while a ref to the _len component is needed. This routine traverese the
+ ref-chain and strips the last ref to a _data from it replacing it with a
+ ref to the _len component. */
+
+gfc_expr *
+gfc_get_len_component (gfc_expr *e, int k)
+{
+ gfc_expr *ptr;
+ gfc_ref *ref, **last;
+
+ ptr = gfc_copy_expr (e);
+
+ /* We need to remove the last _data component ref from ptr. */
+ last = &(ptr->ref);
+ ref = ptr->ref;
+ while (ref)
+ {
+ if (!ref->next
+ && ref->type == REF_COMPONENT
+ && strcmp ("_data", ref->u.c.component->name)== 0)
+ {
+ gfc_free_ref_list (ref);
+ *last = NULL;
+ break;
+ }
+ last = &(ref->next);
+ ref = ref->next;
+ }
+ /* And replace if with a ref to the _len component. */
+ gfc_add_len_component (ptr);
+ if (k != ptr->ts.kind)
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+ ts.type = BT_INTEGER;
+ ts.kind = k;
+ gfc_convert_type_warn (ptr, &ts, 2, 0);
+ }
+ return ptr;
+}
+
+
/* 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. */
+ component '_vptr' which determines the dynamic type. When this CLASS
+ entity is unlimited polymorphic, then also add a component '_len' to
+ store the length of string when that is stored in it. */
-gfc_try
+bool
gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
- gfc_array_spec **as, bool delayed_vtab)
+ gfc_array_spec **as)
{
- char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
+ char tname[GFC_MAX_SYMBOL_LEN+1];
+ char *name;
gfc_symbol *fclass;
gfc_symbol *vtab;
gfc_component *c;
+ gfc_namespace *ns;
+ int rank;
+
+ gcc_assert (as);
- if (as && *as && (*as)->type == AS_ASSUMED_SIZE)
+ if (*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;
+ return false;
}
if (attr->class_ok)
/* Class container has already been built. */
- return SUCCESS;
+ return true;
attr->class_ok = attr->dummy || attr->pointer || attr->allocatable
- || attr->select_type_temporary;
-
+ || attr->select_type_temporary || attr->associate_var;
+
if (!attr->class_ok)
- /* We can not build the class container yet. */
- return SUCCESS;
+ /* We cannot build the class container yet. */
+ return true;
/* Determine the name of the encapsulating type. */
+ rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*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);
+ name = xasprintf ("__class_%s_%d_%da", tname, rank, (*as)->corank);
+ else if ((*as) && attr->pointer)
+ name = xasprintf ("__class_%s_%d_%dp", tname, rank, (*as)->corank);
else if ((*as))
- sprintf (name, "__class_%s_%d_%d", tname, (*as)->rank, (*as)->corank);
+ name = xasprintf ("__class_%s_%d_%dt", tname, rank, (*as)->corank);
else if (attr->pointer)
- sprintf (name, "__class_%s_p", tname);
+ name = xasprintf ("__class_%s_p", tname);
else if (attr->allocatable)
- sprintf (name, "__class_%s_a", tname);
+ name = xasprintf ("__class_%s_a", tname);
else
- sprintf (name, "__class_%s", tname);
+ name = xasprintf ("__class_%s_t", tname);
- gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
+ if (ts->u.derived->attr.unlimited_polymorphic)
+ {
+ /* Find the top-level namespace. */
+ for (ns = gfc_current_ns; ns; ns = ns->parent)
+ if (!ns->parent)
+ break;
+ }
+ else
+ ns = ts->u.derived->ns;
+
+ gfc_find_symbol (name, 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);
+ fclass = gfc_new_symbol (name, ns);
+ st = gfc_new_symtree (&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;
+ if (!ts->u.derived->attr.unlimited_polymorphic)
+ fclass->attr.abstract = ts->u.derived->attr.abstract;
+ fclass->f2k_derived = gfc_get_namespace (NULL, 0);
+ if (!gfc_add_flavor (&fclass->attr, FL_DERIVED, NULL,
+ &gfc_current_locus))
+ return false;
/* Add component '_data'. */
- if (gfc_add_component (fclass, "_data", &c) == FAILURE)
- return FAILURE;
+ if (!gfc_add_component (fclass, "_data", &c))
+ return false;
c->ts = *ts;
c->ts.type = BT_DERIVED;
c->attr.access = ACCESS_PRIVATE;
c->attr.allocatable = attr->allocatable;
c->attr.dimension = attr->dimension;
c->attr.codimension = attr->codimension;
- c->attr.abstract = ts->u.derived->attr.abstract;
+ c->attr.abstract = fclass->attr.abstract;
c->as = (*as);
c->initializer = NULL;
/* Add component '_vptr'. */
- if (gfc_add_component (fclass, "_vptr", &c) == FAILURE)
- return FAILURE;
+ if (!gfc_add_component (fclass, "_vptr", &c))
+ return false;
c->ts.type = BT_DERIVED;
- if (delayed_vtab)
- c->ts.u.derived = NULL;
- else
+ c->attr.access = ACCESS_PRIVATE;
+ c->attr.pointer = 1;
+
+ if (ts->u.derived->attr.unlimited_polymorphic)
{
vtab = gfc_find_derived_vtab (ts->u.derived);
gcc_assert (vtab);
c->ts.u.derived = vtab->ts.u.derived;
+
+ /* Add component '_len'. Only unlimited polymorphic pointers may
+ have a string assigned to them, i.e., only those need the _len
+ component. */
+ if (!gfc_add_component (fclass, "_len", &c))
+ return false;
+ c->ts.type = BT_INTEGER;
+ c->ts.kind = gfc_charlen_int_kind;
+ c->attr.access = ACCESS_PRIVATE;
+ c->attr.artificial = 1;
}
- c->attr.access = ACCESS_PRIVATE;
- c->attr.pointer = 1;
+ else
+ /* Build vtab later. */
+ c->ts.u.derived = NULL;
}
- 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)
+ if (!ts->u.derived->attr.unlimited_polymorphic)
{
- gfc_error ("Maximum extension level reached with type '%s' at %L",
- ts->u.derived->name, &ts->u.derived->declared_at);
- return FAILURE;
+ /* 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 %qs at %L",
+ ts->u.derived->name, &ts->u.derived->declared_at);
+ return false;
+ }
+
+ fclass->attr.extension = ts->u.derived->attr.extension + 1;
+ fclass->attr.alloc_comp = ts->u.derived->attr.alloc_comp;
+ fclass->attr.coarray_comp = ts->u.derived->attr.coarray_comp;
}
-
- 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;
+ free (name);
+ return true;
}
{
gfc_component *c;
- if (tb->non_overridable)
+ if (tb->non_overridable && !tb->overridden)
return;
-
- c = gfc_find_component (vtype, name, true, true);
+
+ c = gfc_find_component (vtype, name, true, true, NULL);
if (c == NULL)
{
/* Add procedure component. */
- if (gfc_add_component (vtype, name, &c) == FAILURE)
+ if (!gfc_add_component (vtype, name, &c))
return;
if (!c->tb)
if (tb->u.specific)
{
- c->ts.interface = tb->u.specific->n.sym;
+ gfc_symbol *ifc = tb->u.specific->n.sym;
+ c->ts.interface = ifc;
if (!tb->deferred)
c->initializer = gfc_get_variable_expr (tb->u.specific);
+ c->attr.pure = ifc->attr.pure;
}
}
if (st->right)
add_procs_to_declared_vtab1 (st->right, vtype);
- if (st->n.tb && !st->n.tb->error
+ 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);
}
for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
{
- if (gfc_find_component (vtype, cmp->name, true, true))
+ if (gfc_find_component (vtype, cmp->name, true, true, NULL))
continue;
add_proc_comp (vtype, cmp->name, cmp->tb);
}
+/* Returns true if any of its nonpointer nonallocatable components or
+ their nonpointer nonallocatable subcomponents has a finalization
+ subroutine. */
+
+static bool
+has_finalizer_component (gfc_symbol *derived)
+{
+ gfc_component *c;
+
+ for (c = derived->components; c; c = c->next)
+ if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable)
+ {
+ if (c->ts.u.derived->f2k_derived
+ && c->ts.u.derived->f2k_derived->finalizers)
+ return true;
+
+ /* Stop infinite recursion through this function by inhibiting
+ calls when the derived type and that of the component are
+ the same. */
+ if (!gfc_compare_derived_types (derived, c->ts.u.derived)
+ && has_finalizer_component (c->ts.u.derived))
+ return true;
+ }
+ return false;
+}
+
+
+static bool
+comp_is_finalizable (gfc_component *comp)
+{
+ if (comp->attr.proc_pointer)
+ return false;
+ else if (comp->attr.allocatable && comp->ts.type != BT_CLASS)
+ return true;
+ else if (comp->ts.type == BT_DERIVED && !comp->attr.pointer
+ && (comp->ts.u.derived->attr.alloc_comp
+ || has_finalizer_component (comp->ts.u.derived)
+ || (comp->ts.u.derived->f2k_derived
+ && comp->ts.u.derived->f2k_derived->finalizers)))
+ return true;
+ else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+ && CLASS_DATA (comp)->attr.allocatable)
+ return true;
+ else
+ return false;
+}
+
+
+/* Call DEALLOCATE for the passed component if it is allocatable, if it is
+ neither allocatable nor a pointer but has a finalizer, call it. If it
+ is a nonpointer component with allocatable components or has finalizers, walk
+ them. Either of them is required; other nonallocatables and pointers aren't
+ handled gracefully.
+ Note: If the component is allocatable, the DEALLOCATE handling takes care
+ of calling the appropriate finalizers, coarray deregistering, and
+ deallocation of allocatable subcomponents. */
+
+static void
+finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
+ gfc_symbol *stat, gfc_symbol *fini_coarray, gfc_code **code,
+ gfc_namespace *sub_ns)
+{
+ gfc_expr *e;
+ gfc_ref *ref;
+
+ if (!comp_is_finalizable (comp))
+ return;
+
+ if (comp->finalized)
+ return;
+
+ e = gfc_copy_expr (expr);
+ if (!e->ref)
+ e->ref = ref = gfc_get_ref ();
+ else
+ {
+ for (ref = e->ref; ref->next; ref = ref->next)
+ ;
+ ref->next = gfc_get_ref ();
+ ref = ref->next;
+ }
+ ref->type = REF_COMPONENT;
+ ref->u.c.sym = derived;
+ ref->u.c.component = comp;
+ e->ts = comp->ts;
+
+ if (comp->attr.dimension || comp->attr.codimension
+ || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+ && (CLASS_DATA (comp)->attr.dimension
+ || CLASS_DATA (comp)->attr.codimension)))
+ {
+ ref->next = gfc_get_ref ();
+ ref->next->type = REF_ARRAY;
+ ref->next->u.ar.dimen = 0;
+ ref->next->u.ar.as = comp->ts.type == BT_CLASS ? CLASS_DATA (comp)->as
+ : comp->as;
+ e->rank = ref->next->u.ar.as->rank;
+ ref->next->u.ar.type = e->rank ? AR_FULL : AR_ELEMENT;
+ }
+
+ /* Call DEALLOCATE (comp, stat=ignore). */
+ if (comp->attr.allocatable
+ || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+ && CLASS_DATA (comp)->attr.allocatable))
+ {
+ gfc_code *dealloc, *block = NULL;
+
+ /* Add IF (fini_coarray). */
+ if (comp->attr.codimension
+ || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)
+ && CLASS_DATA (comp)->attr.codimension))
+ {
+ block = gfc_get_code (EXEC_IF);
+ if (*code)
+ {
+ (*code)->next = block;
+ (*code) = (*code)->next;
+ }
+ else
+ (*code) = block;
+
+ block->block = gfc_get_code (EXEC_IF);
+ block = block->block;
+ block->expr1 = gfc_lval_expr_from_sym (fini_coarray);
+ }
+
+ dealloc = gfc_get_code (EXEC_DEALLOCATE);
+
+ dealloc->ext.alloc.list = gfc_get_alloc ();
+ dealloc->ext.alloc.list->expr = e;
+ dealloc->expr1 = gfc_lval_expr_from_sym (stat);
+
+ gfc_code *cond = gfc_get_code (EXEC_IF);
+ cond->block = gfc_get_code (EXEC_IF);
+ cond->block->expr1 = gfc_get_expr ();
+ cond->block->expr1->expr_type = EXPR_FUNCTION;
+ cond->block->expr1->where = gfc_current_locus;
+ gfc_get_sym_tree ("associated", sub_ns, &cond->block->expr1->symtree, false);
+ cond->block->expr1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+ cond->block->expr1->symtree->n.sym->attr.intrinsic = 1;
+ cond->block->expr1->symtree->n.sym->result = cond->block->expr1->symtree->n.sym;
+ gfc_commit_symbol (cond->block->expr1->symtree->n.sym);
+ cond->block->expr1->ts.type = BT_LOGICAL;
+ cond->block->expr1->ts.kind = gfc_default_logical_kind;
+ cond->block->expr1->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_ASSOCIATED);
+ cond->block->expr1->value.function.actual = gfc_get_actual_arglist ();
+ cond->block->expr1->value.function.actual->expr = gfc_copy_expr (expr);
+ cond->block->expr1->value.function.actual->next = gfc_get_actual_arglist ();
+ cond->block->next = dealloc;
+
+ if (block)
+ block->next = cond;
+ else if (*code)
+ {
+ (*code)->next = cond;
+ (*code) = (*code)->next;
+ }
+ else
+ (*code) = cond;
+ }
+ else if (comp->ts.type == BT_DERIVED
+ && comp->ts.u.derived->f2k_derived
+ && comp->ts.u.derived->f2k_derived->finalizers)
+ {
+ /* Call FINAL_WRAPPER (comp); */
+ gfc_code *final_wrap;
+ gfc_symbol *vtab;
+ gfc_component *c;
+
+ vtab = gfc_find_derived_vtab (comp->ts.u.derived);
+ for (c = vtab->ts.u.derived->components; c; c = c->next)
+ if (strcmp (c->name, "_final") == 0)
+ break;
+
+ gcc_assert (c);
+ final_wrap = gfc_get_code (EXEC_CALL);
+ final_wrap->symtree = c->initializer->symtree;
+ final_wrap->resolved_sym = c->initializer->symtree->n.sym;
+ final_wrap->ext.actual = gfc_get_actual_arglist ();
+ final_wrap->ext.actual->expr = e;
+
+ if (*code)
+ {
+ (*code)->next = final_wrap;
+ (*code) = (*code)->next;
+ }
+ else
+ (*code) = final_wrap;
+ }
+ else
+ {
+ gfc_component *c;
+
+ for (c = comp->ts.u.derived->components; c; c = c->next)
+ finalize_component (e, comp->ts.u.derived, c, stat, fini_coarray, code,
+ sub_ns);
+ gfc_free_expr (e);
+ }
+ comp->finalized = true;
+}
+
+
+/* Generate code equivalent to
+ CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
+ + offset, c_ptr), ptr). */
+
+static gfc_code *
+finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
+ gfc_expr *offset, gfc_namespace *sub_ns)
+{
+ gfc_code *block;
+ gfc_expr *expr, *expr2;
+
+ /* C_F_POINTER(). */
+ block = gfc_get_code (EXEC_CALL);
+ gfc_get_sym_tree ("c_f_pointer", sub_ns, &block->symtree, true);
+ block->resolved_sym = block->symtree->n.sym;
+ block->resolved_sym->attr.flavor = FL_PROCEDURE;
+ block->resolved_sym->attr.intrinsic = 1;
+ block->resolved_sym->attr.subroutine = 1;
+ block->resolved_sym->from_intmod = INTMOD_ISO_C_BINDING;
+ block->resolved_sym->intmod_sym_id = ISOCBINDING_F_POINTER;
+ block->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER);
+ gfc_commit_symbol (block->resolved_sym);
+
+ /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */
+ block->ext.actual = gfc_get_actual_arglist ();
+ block->ext.actual->next = gfc_get_actual_arglist ();
+ block->ext.actual->next->expr = gfc_get_int_expr (gfc_index_integer_kind,
+ NULL, 0);
+ block->ext.actual->next->next = gfc_get_actual_arglist (); /* SIZE. */
+
+ /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
+
+ /* TRANSFER's first argument: C_LOC (array). */
+ expr = gfc_get_expr ();
+ expr->expr_type = EXPR_FUNCTION;
+ gfc_get_sym_tree ("c_loc", sub_ns, &expr->symtree, false);
+ expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+ expr->symtree->n.sym->intmod_sym_id = ISOCBINDING_LOC;
+ expr->symtree->n.sym->attr.intrinsic = 1;
+ expr->symtree->n.sym->from_intmod = INTMOD_ISO_C_BINDING;
+ expr->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC);
+ expr->value.function.actual = gfc_get_actual_arglist ();
+ expr->value.function.actual->expr
+ = gfc_lval_expr_from_sym (array);
+ expr->symtree->n.sym->result = expr->symtree->n.sym;
+ gfc_commit_symbol (expr->symtree->n.sym);
+ expr->ts.type = BT_INTEGER;
+ expr->ts.kind = gfc_index_integer_kind;
+ expr->where = gfc_current_locus;
+
+ /* TRANSFER. */
+ expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_TRANSFER, "transfer",
+ gfc_current_locus, 3, expr,
+ gfc_get_int_expr (gfc_index_integer_kind,
+ NULL, 0), NULL);
+ expr2->ts.type = BT_INTEGER;
+ expr2->ts.kind = gfc_index_integer_kind;
+
+ /* <array addr> + <offset>. */
+ block->ext.actual->expr = gfc_get_expr ();
+ block->ext.actual->expr->expr_type = EXPR_OP;
+ block->ext.actual->expr->value.op.op = INTRINSIC_PLUS;
+ block->ext.actual->expr->value.op.op1 = expr2;
+ block->ext.actual->expr->value.op.op2 = offset;
+ block->ext.actual->expr->ts = expr->ts;
+ block->ext.actual->expr->where = gfc_current_locus;
+
+ /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */
+ block->ext.actual->next = gfc_get_actual_arglist ();
+ block->ext.actual->next->expr = gfc_lval_expr_from_sym (ptr);
+ block->ext.actual->next->next = gfc_get_actual_arglist ();
+
+ return block;
+}
+
+
+/* Calculates the offset to the (idx+1)th element of an array, taking the
+ stride into account. It generates the code:
+ offset = 0
+ do idx2 = 1, rank
+ offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2)
+ end do
+ offset = offset * byte_stride. */
+
+static gfc_code*
+finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset,
+ gfc_symbol *strides, gfc_symbol *sizes,
+ gfc_symbol *byte_stride, gfc_expr *rank,
+ gfc_code *block, gfc_namespace *sub_ns)
+{
+ gfc_iterator *iter;
+ gfc_expr *expr, *expr2;
+
+ /* offset = 0. */
+ block->next = gfc_get_code (EXEC_ASSIGN);
+ block = block->next;
+ block->expr1 = gfc_lval_expr_from_sym (offset);
+ block->expr2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+
+ /* Create loop. */
+ iter = gfc_get_iterator ();
+ iter->var = gfc_lval_expr_from_sym (idx2);
+ iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+ iter->end = gfc_copy_expr (rank);
+ iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+ block->next = gfc_get_code (EXEC_DO);
+ block = block->next;
+ block->ext.iterator = iter;
+ block->block = gfc_get_code (EXEC_DO);
+
+ /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1)
+ * strides(idx2). */
+
+ /* mod (idx, sizes(idx2)). */
+ expr = gfc_lval_expr_from_sym (sizes);
+ expr->ref = gfc_get_ref ();
+ expr->ref->type = REF_ARRAY;
+ expr->ref->u.ar.as = sizes->as;
+ expr->ref->u.ar.type = AR_ELEMENT;
+ expr->ref->u.ar.dimen = 1;
+ expr->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+ expr->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2);
+ expr->where = sizes->declared_at;
+
+ expr = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_MOD, "mod",
+ gfc_current_locus, 2,
+ gfc_lval_expr_from_sym (idx), expr);
+ expr->ts = idx->ts;
+
+ /* (...) / sizes(idx2-1). */
+ expr2 = gfc_get_expr ();
+ expr2->expr_type = EXPR_OP;
+ expr2->value.op.op = INTRINSIC_DIVIDE;
+ expr2->value.op.op1 = expr;
+ expr2->value.op.op2 = gfc_lval_expr_from_sym (sizes);
+ expr2->value.op.op2->ref = gfc_get_ref ();
+ expr2->value.op.op2->ref->type = REF_ARRAY;
+ expr2->value.op.op2->ref->u.ar.as = sizes->as;
+ expr2->value.op.op2->ref->u.ar.type = AR_ELEMENT;
+ expr2->value.op.op2->ref->u.ar.dimen = 1;
+ expr2->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+ expr2->value.op.op2->ref->u.ar.start[0] = gfc_get_expr ();
+ expr2->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP;
+ expr2->value.op.op2->ref->u.ar.start[0]->where = gfc_current_locus;
+ expr2->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
+ expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1
+ = gfc_lval_expr_from_sym (idx2);
+ expr2->value.op.op2->ref->u.ar.start[0]->value.op.op2
+ = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+ expr2->value.op.op2->ref->u.ar.start[0]->ts
+ = expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts;
+ expr2->ts = idx->ts;
+ expr2->where = gfc_current_locus;
+
+ /* ... * strides(idx2). */
+ expr = gfc_get_expr ();
+ expr->expr_type = EXPR_OP;
+ expr->value.op.op = INTRINSIC_TIMES;
+ expr->value.op.op1 = expr2;
+ expr->value.op.op2 = gfc_lval_expr_from_sym (strides);
+ expr->value.op.op2->ref = gfc_get_ref ();
+ expr->value.op.op2->ref->type = REF_ARRAY;
+ expr->value.op.op2->ref->u.ar.type = AR_ELEMENT;
+ expr->value.op.op2->ref->u.ar.dimen = 1;
+ expr->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+ expr->value.op.op2->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2);
+ expr->value.op.op2->ref->u.ar.as = strides->as;
+ expr->ts = idx->ts;
+ expr->where = gfc_current_locus;
+
+ /* offset = offset + ... */
+ block->block->next = gfc_get_code (EXEC_ASSIGN);
+ block->block->next->expr1 = gfc_lval_expr_from_sym (offset);
+ block->block->next->expr2 = gfc_get_expr ();
+ block->block->next->expr2->expr_type = EXPR_OP;
+ block->block->next->expr2->value.op.op = INTRINSIC_PLUS;
+ block->block->next->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset);
+ block->block->next->expr2->value.op.op2 = expr;
+ block->block->next->expr2->ts = idx->ts;
+ block->block->next->expr2->where = gfc_current_locus;
+
+ /* After the loop: offset = offset * byte_stride. */
+ block->next = gfc_get_code (EXEC_ASSIGN);
+ block = block->next;
+ block->expr1 = gfc_lval_expr_from_sym (offset);
+ block->expr2 = gfc_get_expr ();
+ block->expr2->expr_type = EXPR_OP;
+ block->expr2->value.op.op = INTRINSIC_TIMES;
+ block->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset);
+ block->expr2->value.op.op2 = gfc_lval_expr_from_sym (byte_stride);
+ block->expr2->ts = block->expr2->value.op.op1->ts;
+ block->expr2->where = gfc_current_locus;
+ return block;
+}
+
+
+/* Insert code of the following form:
+
+ block
+ integer(c_intptr_t) :: i
+
+ if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
+ && (is_contiguous || !final_rank3->attr.contiguous
+ || final_rank3->as->type != AS_ASSUMED_SHAPE))
+ || 0 == STORAGE_SIZE (array)) then
+ call final_rank3 (array)
+ else
+ block
+ integer(c_intptr_t) :: offset, j
+ type(t) :: tmp(shape (array))
+
+ do i = 0, size (array)-1
+ offset = obtain_offset(i, strides, sizes, byte_stride)
+ addr = transfer (c_loc (array), addr) + offset
+ call c_f_pointer (transfer (addr, cptr), ptr)
+
+ addr = transfer (c_loc (tmp), addr)
+ + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE
+ call c_f_pointer (transfer (addr, cptr), ptr2)
+ ptr2 = ptr
+ end do
+ call final_rank3 (tmp)
+ end block
+ end if
+ block */
+
+static void
+finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
+ gfc_symbol *array, gfc_symbol *byte_stride,
+ gfc_symbol *idx, gfc_symbol *ptr,
+ gfc_symbol *nelem,
+ gfc_symbol *strides, gfc_symbol *sizes,
+ gfc_symbol *idx2, gfc_symbol *offset,
+ gfc_symbol *is_contiguous, gfc_expr *rank,
+ gfc_namespace *sub_ns)
+{
+ gfc_symbol *tmp_array, *ptr2;
+ gfc_expr *size_expr, *offset2, *expr;
+ gfc_namespace *ns;
+ gfc_iterator *iter;
+ gfc_code *block2;
+ int i;
+
+ block->next = gfc_get_code (EXEC_IF);
+ block = block->next;
+
+ block->block = gfc_get_code (EXEC_IF);
+ block = block->block;
+
+ /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
+ size_expr = gfc_get_expr ();
+ size_expr->where = gfc_current_locus;
+ size_expr->expr_type = EXPR_OP;
+ size_expr->value.op.op = INTRINSIC_DIVIDE;
+
+ /* STORAGE_SIZE (array,kind=c_intptr_t). */
+ size_expr->value.op.op1
+ = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE,
+ "storage_size", gfc_current_locus, 2,
+ gfc_lval_expr_from_sym (array),
+ gfc_get_int_expr (gfc_index_integer_kind,
+ NULL, 0));
+
+ /* NUMERIC_STORAGE_SIZE. */
+ size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
+ gfc_character_storage_size);
+ size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
+ size_expr->ts = size_expr->value.op.op1->ts;
+
+ /* IF condition: (stride == size_expr
+ && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous)
+ || is_contiguous)
+ || 0 == size_expr. */
+ block->expr1 = gfc_get_expr ();
+ block->expr1->ts.type = BT_LOGICAL;
+ block->expr1->ts.kind = gfc_default_logical_kind;
+ block->expr1->expr_type = EXPR_OP;
+ block->expr1->where = gfc_current_locus;
+
+ block->expr1->value.op.op = INTRINSIC_OR;
+
+ /* byte_stride == size_expr */
+ expr = gfc_get_expr ();
+ expr->ts.type = BT_LOGICAL;
+ expr->ts.kind = gfc_default_logical_kind;
+ expr->expr_type = EXPR_OP;
+ expr->where = gfc_current_locus;
+ expr->value.op.op = INTRINSIC_EQ;
+ expr->value.op.op1
+ = gfc_lval_expr_from_sym (byte_stride);
+ expr->value.op.op2 = size_expr;
+
+ /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
+ add is_contiguous check. */
+
+ if (fini->proc_tree->n.sym->formal->sym->as->type != AS_ASSUMED_SHAPE
+ || fini->proc_tree->n.sym->formal->sym->attr.contiguous)
+ {
+ gfc_expr *expr2;
+ expr2 = gfc_get_expr ();
+ expr2->ts.type = BT_LOGICAL;
+ expr2->ts.kind = gfc_default_logical_kind;
+ expr2->expr_type = EXPR_OP;
+ expr2->where = gfc_current_locus;
+ expr2->value.op.op = INTRINSIC_AND;
+ expr2->value.op.op1 = expr;
+ expr2->value.op.op2 = gfc_lval_expr_from_sym (is_contiguous);
+ expr = expr2;
+ }
+
+ block->expr1->value.op.op1 = expr;
+
+ /* 0 == size_expr */
+ block->expr1->value.op.op2 = gfc_get_expr ();
+ block->expr1->value.op.op2->ts.type = BT_LOGICAL;
+ block->expr1->value.op.op2->ts.kind = gfc_default_logical_kind;
+ block->expr1->value.op.op2->expr_type = EXPR_OP;
+ block->expr1->value.op.op2->where = gfc_current_locus;
+ block->expr1->value.op.op2->value.op.op = INTRINSIC_EQ;
+ block->expr1->value.op.op2->value.op.op1 =
+ gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+ block->expr1->value.op.op2->value.op.op2 = gfc_copy_expr (size_expr);
+
+ /* IF body: call final subroutine. */
+ block->next = gfc_get_code (EXEC_CALL);
+ block->next->symtree = fini->proc_tree;
+ block->next->resolved_sym = fini->proc_tree->n.sym;
+ block->next->ext.actual = gfc_get_actual_arglist ();
+ block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
+ block->next->ext.actual->next = gfc_get_actual_arglist ();
+ block->next->ext.actual->next->expr = gfc_copy_expr (size_expr);
+
+ /* ELSE. */
+
+ block->block = gfc_get_code (EXEC_IF);
+ block = block->block;
+
+ /* BLOCK ... END BLOCK. */
+ block->next = gfc_get_code (EXEC_BLOCK);
+ block = block->next;
+
+ ns = gfc_build_block_ns (sub_ns);
+ block->ext.block.ns = ns;
+ block->ext.block.assoc = NULL;
+
+ gfc_get_symbol ("ptr2", ns, &ptr2);
+ ptr2->ts.type = BT_DERIVED;
+ ptr2->ts.u.derived = array->ts.u.derived;
+ ptr2->attr.flavor = FL_VARIABLE;
+ ptr2->attr.pointer = 1;
+ ptr2->attr.artificial = 1;
+ gfc_set_sym_referenced (ptr2);
+ gfc_commit_symbol (ptr2);
+
+ gfc_get_symbol ("tmp_array", ns, &tmp_array);
+ tmp_array->ts.type = BT_DERIVED;
+ tmp_array->ts.u.derived = array->ts.u.derived;
+ tmp_array->attr.flavor = FL_VARIABLE;
+ tmp_array->attr.dimension = 1;
+ tmp_array->attr.artificial = 1;
+ tmp_array->as = gfc_get_array_spec();
+ tmp_array->attr.intent = INTENT_INOUT;
+ tmp_array->as->type = AS_EXPLICIT;
+ tmp_array->as->rank = fini->proc_tree->n.sym->formal->sym->as->rank;
+
+ for (i = 0; i < tmp_array->as->rank; i++)
+ {
+ gfc_expr *shape_expr;
+ tmp_array->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1);
+ /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */
+ shape_expr
+ = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size",
+ gfc_current_locus, 3,
+ gfc_lval_expr_from_sym (array),
+ gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, i+1),
+ gfc_get_int_expr (gfc_default_integer_kind,
+ NULL,
+ gfc_index_integer_kind));
+ shape_expr->ts.kind = gfc_index_integer_kind;
+ tmp_array->as->upper[i] = shape_expr;
+ }
+ gfc_set_sym_referenced (tmp_array);
+ gfc_commit_symbol (tmp_array);
+
+ /* Create loop. */
+ iter = gfc_get_iterator ();
+ iter->var = gfc_lval_expr_from_sym (idx);
+ iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+ iter->end = gfc_lval_expr_from_sym (nelem);
+ iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+
+ block = gfc_get_code (EXEC_DO);
+ ns->code = block;
+ block->ext.iterator = iter;
+ block->block = gfc_get_code (EXEC_DO);
+
+ /* Offset calculation for the new array: idx * size of type (in bytes). */
+ offset2 = gfc_get_expr ();
+ offset2->expr_type = EXPR_OP;
+ offset2->where = gfc_current_locus;
+ offset2->value.op.op = INTRINSIC_TIMES;
+ offset2->value.op.op1 = gfc_lval_expr_from_sym (idx);
+ offset2->value.op.op2 = gfc_copy_expr (size_expr);
+ offset2->ts = byte_stride->ts;
+
+ /* Offset calculation of "array". */
+ block2 = finalization_get_offset (idx, idx2, offset, strides, sizes,
+ byte_stride, rank, block->block, sub_ns);
+
+ /* Create code for
+ CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
+ + idx * stride, c_ptr), ptr). */
+ block2->next = finalization_scalarizer (array, ptr,
+ gfc_lval_expr_from_sym (offset),
+ sub_ns);
+ block2 = block2->next;
+ block2->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns);
+ block2 = block2->next;
+
+ /* ptr2 = ptr. */
+ block2->next = gfc_get_code (EXEC_ASSIGN);
+ block2 = block2->next;
+ block2->expr1 = gfc_lval_expr_from_sym (ptr2);
+ block2->expr2 = gfc_lval_expr_from_sym (ptr);
+
+ /* Call now the user's final subroutine. */
+ block->next = gfc_get_code (EXEC_CALL);
+ block = block->next;
+ block->symtree = fini->proc_tree;
+ block->resolved_sym = fini->proc_tree->n.sym;
+ block->ext.actual = gfc_get_actual_arglist ();
+ block->ext.actual->expr = gfc_lval_expr_from_sym (tmp_array);
+
+ if (fini->proc_tree->n.sym->formal->sym->attr.intent == INTENT_IN)
+ return;
+
+ /* Copy back. */
+
+ /* Loop. */
+ iter = gfc_get_iterator ();
+ iter->var = gfc_lval_expr_from_sym (idx);
+ iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+ iter->end = gfc_lval_expr_from_sym (nelem);
+ iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+
+ block->next = gfc_get_code (EXEC_DO);
+ block = block->next;
+ block->ext.iterator = iter;
+ block->block = gfc_get_code (EXEC_DO);
+
+ /* Offset calculation of "array". */
+ block2 = finalization_get_offset (idx, idx2, offset, strides, sizes,
+ byte_stride, rank, block->block, sub_ns);
+
+ /* Create code for
+ CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
+ + offset, c_ptr), ptr). */
+ block2->next = finalization_scalarizer (array, ptr,
+ gfc_lval_expr_from_sym (offset),
+ sub_ns);
+ block2 = block2->next;
+ block2->next = finalization_scalarizer (tmp_array, ptr2,
+ gfc_copy_expr (offset2), sub_ns);
+ block2 = block2->next;
+
+ /* ptr = ptr2. */
+ block2->next = gfc_get_code (EXEC_ASSIGN);
+ block2->next->expr1 = gfc_lval_expr_from_sym (ptr);
+ block2->next->expr2 = gfc_lval_expr_from_sym (ptr2);
+}
+
+
+/* Generate the finalization/polymorphic freeing wrapper subroutine for the
+ derived type "derived". The function first calls the approriate FINAL
+ subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable
+ components (but not the inherited ones). Last, it calls the wrapper
+ subroutine of the parent. The generated wrapper procedure takes as argument
+ an assumed-rank array.
+ If neither allocatable components nor FINAL subroutines exists, the vtab
+ will contain a NULL pointer.
+ The generated function has the form
+ _final(assumed-rank array, stride, skip_corarray)
+ where the array has to be contiguous (except of the lowest dimension). The
+ stride (in bytes) is used to allow different sizes for ancestor types by
+ skipping over the additionally added components in the scalarizer. If
+ "fini_coarray" is false, coarray components are not finalized to allow for
+ the correct semantic with intrinsic assignment. */
+
+static void
+generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
+ const char *tname, gfc_component *vtab_final)
+{
+ gfc_symbol *final, *array, *fini_coarray, *byte_stride, *sizes, *strides;
+ gfc_symbol *ptr = NULL, *idx, *idx2, *is_contiguous, *offset, *nelem;
+ gfc_component *comp;
+ gfc_namespace *sub_ns;
+ gfc_code *last_code, *block;
+ char *name;
+ bool finalizable_comp = false;
+ bool expr_null_wrapper = false;
+ gfc_expr *ancestor_wrapper = NULL, *rank;
+ gfc_iterator *iter;
+
+ if (derived->attr.unlimited_polymorphic)
+ {
+ vtab_final->initializer = gfc_get_null_expr (NULL);
+ return;
+ }
+
+ /* Search for the ancestor's finalizers. */
+ if (derived->attr.extension && derived->components
+ && (!derived->components->ts.u.derived->attr.abstract
+ || has_finalizer_component (derived)))
+ {
+ gfc_symbol *vtab;
+ gfc_component *comp;
+
+ vtab = gfc_find_derived_vtab (derived->components->ts.u.derived);
+ for (comp = vtab->ts.u.derived->components; comp; comp = comp->next)
+ if (comp->name[0] == '_' && comp->name[1] == 'f')
+ {
+ ancestor_wrapper = comp->initializer;
+ break;
+ }
+ }
+
+ /* No wrapper of the ancestor and no own FINAL subroutines and allocatable
+ components: Return a NULL() expression; we defer this a bit to have have
+ an interface declaration. */
+ if ((!ancestor_wrapper || ancestor_wrapper->expr_type == EXPR_NULL)
+ && !derived->attr.alloc_comp
+ && (!derived->f2k_derived || !derived->f2k_derived->finalizers)
+ && !has_finalizer_component (derived))
+ expr_null_wrapper = true;
+ else
+ /* Check whether there are new allocatable components. */
+ for (comp = derived->components; comp; comp = comp->next)
+ {
+ if (comp == derived->components && derived->attr.extension
+ && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
+ continue;
+
+ finalizable_comp |= comp_is_finalizable (comp);
+ }
+
+ /* If there is no new finalizer and no new allocatable, return with
+ an expr to the ancestor's one. */
+ if (!expr_null_wrapper && !finalizable_comp
+ && (!derived->f2k_derived || !derived->f2k_derived->finalizers))
+ {
+ gcc_assert (ancestor_wrapper && ancestor_wrapper->ref == NULL
+ && ancestor_wrapper->expr_type == EXPR_VARIABLE);
+ vtab_final->initializer = gfc_copy_expr (ancestor_wrapper);
+ vtab_final->ts.interface = vtab_final->initializer->symtree->n.sym;
+ return;
+ }
+
+ /* We now create a wrapper, which does the following:
+ 1. Call the suitable finalization subroutine for this type
+ 2. Loop over all noninherited allocatable components and noninherited
+ components with allocatable components and DEALLOCATE those; this will
+ take care of finalizers, coarray deregistering and allocatable
+ nested components.
+ 3. Call the ancestor's finalizer. */
+
+ /* Declare the wrapper function; it takes an assumed-rank array
+ and a VALUE logical as arguments. */
+
+ /* Set up the namespace. */
+ sub_ns = gfc_get_namespace (ns, 0);
+ sub_ns->sibling = ns->contained;
+ if (!expr_null_wrapper)
+ ns->contained = sub_ns;
+ sub_ns->resolved = 1;
+
+ /* Set up the procedure symbol. */
+ name = xasprintf ("__final_%s", tname);
+ gfc_get_symbol (name, sub_ns, &final);
+ sub_ns->proc_name = final;
+ final->attr.flavor = FL_PROCEDURE;
+ final->attr.function = 1;
+ final->attr.pure = 0;
+ final->attr.recursive = 1;
+ final->result = final;
+ final->ts.type = BT_INTEGER;
+ final->ts.kind = 4;
+ final->attr.artificial = 1;
+ final->attr.always_explicit = 1;
+ final->attr.if_source = expr_null_wrapper ? IFSRC_IFBODY : IFSRC_DECL;
+ if (ns->proc_name->attr.flavor == FL_MODULE)
+ final->module = ns->proc_name->name;
+ gfc_set_sym_referenced (final);
+ gfc_commit_symbol (final);
+
+ /* Set up formal argument. */
+ gfc_get_symbol ("array", sub_ns, &array);
+ array->ts.type = BT_DERIVED;
+ array->ts.u.derived = derived;
+ array->attr.flavor = FL_VARIABLE;
+ array->attr.dummy = 1;
+ array->attr.contiguous = 1;
+ array->attr.dimension = 1;
+ array->attr.artificial = 1;
+ array->as = gfc_get_array_spec();
+ array->as->type = AS_ASSUMED_RANK;
+ array->as->rank = -1;
+ array->attr.intent = INTENT_INOUT;
+ gfc_set_sym_referenced (array);
+ final->formal = gfc_get_formal_arglist ();
+ final->formal->sym = array;
+ gfc_commit_symbol (array);
+
+ /* Set up formal argument. */
+ gfc_get_symbol ("byte_stride", sub_ns, &byte_stride);
+ byte_stride->ts.type = BT_INTEGER;
+ byte_stride->ts.kind = gfc_index_integer_kind;
+ byte_stride->attr.flavor = FL_VARIABLE;
+ byte_stride->attr.dummy = 1;
+ byte_stride->attr.value = 1;
+ byte_stride->attr.artificial = 1;
+ gfc_set_sym_referenced (byte_stride);
+ final->formal->next = gfc_get_formal_arglist ();
+ final->formal->next->sym = byte_stride;
+ gfc_commit_symbol (byte_stride);
+
+ /* Set up formal argument. */
+ gfc_get_symbol ("fini_coarray", sub_ns, &fini_coarray);
+ fini_coarray->ts.type = BT_LOGICAL;
+ fini_coarray->ts.kind = 1;
+ fini_coarray->attr.flavor = FL_VARIABLE;
+ fini_coarray->attr.dummy = 1;
+ fini_coarray->attr.value = 1;
+ fini_coarray->attr.artificial = 1;
+ gfc_set_sym_referenced (fini_coarray);
+ final->formal->next->next = gfc_get_formal_arglist ();
+ final->formal->next->next->sym = fini_coarray;
+ gfc_commit_symbol (fini_coarray);
+
+ /* Return with a NULL() expression but with an interface which has
+ the formal arguments. */
+ if (expr_null_wrapper)
+ {
+ vtab_final->initializer = gfc_get_null_expr (NULL);
+ vtab_final->ts.interface = final;
+ return;
+ }
+
+ /* Local variables. */
+
+ gfc_get_symbol ("idx", sub_ns, &idx);
+ idx->ts.type = BT_INTEGER;
+ idx->ts.kind = gfc_index_integer_kind;
+ idx->attr.flavor = FL_VARIABLE;
+ idx->attr.artificial = 1;
+ gfc_set_sym_referenced (idx);
+ gfc_commit_symbol (idx);
+
+ gfc_get_symbol ("idx2", sub_ns, &idx2);
+ idx2->ts.type = BT_INTEGER;
+ idx2->ts.kind = gfc_index_integer_kind;
+ idx2->attr.flavor = FL_VARIABLE;
+ idx2->attr.artificial = 1;
+ gfc_set_sym_referenced (idx2);
+ gfc_commit_symbol (idx2);
+
+ gfc_get_symbol ("offset", sub_ns, &offset);
+ offset->ts.type = BT_INTEGER;
+ offset->ts.kind = gfc_index_integer_kind;
+ offset->attr.flavor = FL_VARIABLE;
+ offset->attr.artificial = 1;
+ gfc_set_sym_referenced (offset);
+ gfc_commit_symbol (offset);
+
+ /* Create RANK expression. */
+ rank = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_RANK, "rank",
+ gfc_current_locus, 1,
+ gfc_lval_expr_from_sym (array));
+ if (rank->ts.kind != idx->ts.kind)
+ gfc_convert_type_warn (rank, &idx->ts, 2, 0);
+
+ /* Create is_contiguous variable. */
+ gfc_get_symbol ("is_contiguous", sub_ns, &is_contiguous);
+ is_contiguous->ts.type = BT_LOGICAL;
+ is_contiguous->ts.kind = gfc_default_logical_kind;
+ is_contiguous->attr.flavor = FL_VARIABLE;
+ is_contiguous->attr.artificial = 1;
+ gfc_set_sym_referenced (is_contiguous);
+ gfc_commit_symbol (is_contiguous);
+
+ /* Create "sizes(0..rank)" variable, which contains the multiplied
+ up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
+ sizes(2) = sizes(1) * extent(dim=2) etc. */
+ gfc_get_symbol ("sizes", sub_ns, &sizes);
+ sizes->ts.type = BT_INTEGER;
+ sizes->ts.kind = gfc_index_integer_kind;
+ sizes->attr.flavor = FL_VARIABLE;
+ sizes->attr.dimension = 1;
+ sizes->attr.artificial = 1;
+ sizes->as = gfc_get_array_spec();
+ sizes->attr.intent = INTENT_INOUT;
+ sizes->as->type = AS_EXPLICIT;
+ sizes->as->rank = 1;
+ sizes->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+ sizes->as->upper[0] = gfc_copy_expr (rank);
+ gfc_set_sym_referenced (sizes);
+ gfc_commit_symbol (sizes);
+
+ /* Create "strides(1..rank)" variable, which contains the strides per
+ dimension. */
+ gfc_get_symbol ("strides", sub_ns, &strides);
+ strides->ts.type = BT_INTEGER;
+ strides->ts.kind = gfc_index_integer_kind;
+ strides->attr.flavor = FL_VARIABLE;
+ strides->attr.dimension = 1;
+ strides->attr.artificial = 1;
+ strides->as = gfc_get_array_spec();
+ strides->attr.intent = INTENT_INOUT;
+ strides->as->type = AS_EXPLICIT;
+ strides->as->rank = 1;
+ strides->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+ strides->as->upper[0] = gfc_copy_expr (rank);
+ gfc_set_sym_referenced (strides);
+ gfc_commit_symbol (strides);
+
+
+ /* Set return value to 0. */
+ last_code = gfc_get_code (EXEC_ASSIGN);
+ last_code->expr1 = gfc_lval_expr_from_sym (final);
+ last_code->expr2 = gfc_get_int_expr (4, NULL, 0);
+ sub_ns->code = last_code;
+
+ /* Set: is_contiguous = .true. */
+ last_code->next = gfc_get_code (EXEC_ASSIGN);
+ last_code = last_code->next;
+ last_code->expr1 = gfc_lval_expr_from_sym (is_contiguous);
+ last_code->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
+ &gfc_current_locus, true);
+
+ /* Set: sizes(0) = 1. */
+ last_code->next = gfc_get_code (EXEC_ASSIGN);
+ last_code = last_code->next;
+ last_code->expr1 = gfc_lval_expr_from_sym (sizes);
+ last_code->expr1->ref = gfc_get_ref ();
+ last_code->expr1->ref->type = REF_ARRAY;
+ last_code->expr1->ref->u.ar.type = AR_ELEMENT;
+ last_code->expr1->ref->u.ar.dimen = 1;
+ last_code->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+ last_code->expr1->ref->u.ar.start[0]
+ = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+ last_code->expr1->ref->u.ar.as = sizes->as;
+ last_code->expr2 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+
+ /* Create:
+ DO idx = 1, rank
+ strides(idx) = _F._stride (array, dim=idx)
+ sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind)
+ if (strides (idx) /= sizes(i-1)) is_contiguous = .false.
+ END DO. */
+
+ /* Create loop. */
+ iter = gfc_get_iterator ();
+ iter->var = gfc_lval_expr_from_sym (idx);
+ iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+ iter->end = gfc_copy_expr (rank);
+ iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+ last_code->next = gfc_get_code (EXEC_DO);
+ last_code = last_code->next;
+ last_code->ext.iterator = iter;
+ last_code->block = gfc_get_code (EXEC_DO);
+
+ /* strides(idx) = _F._stride(array,dim=idx). */
+ last_code->block->next = gfc_get_code (EXEC_ASSIGN);
+ block = last_code->block->next;
+
+ block->expr1 = gfc_lval_expr_from_sym (strides);
+ block->expr1->ref = gfc_get_ref ();
+ block->expr1->ref->type = REF_ARRAY;
+ block->expr1->ref->u.ar.type = AR_ELEMENT;
+ block->expr1->ref->u.ar.dimen = 1;
+ block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+ block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
+ block->expr1->ref->u.ar.as = strides->as;
+
+ block->expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STRIDE, "stride",
+ gfc_current_locus, 2,
+ gfc_lval_expr_from_sym (array),
+ gfc_lval_expr_from_sym (idx));
+
+ /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
+ block->next = gfc_get_code (EXEC_ASSIGN);
+ block = block->next;
+
+ /* sizes(idx) = ... */
+ block->expr1 = gfc_lval_expr_from_sym (sizes);
+ block->expr1->ref = gfc_get_ref ();
+ block->expr1->ref->type = REF_ARRAY;
+ block->expr1->ref->u.ar.type = AR_ELEMENT;
+ block->expr1->ref->u.ar.dimen = 1;
+ block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+ block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
+ block->expr1->ref->u.ar.as = sizes->as;
+
+ block->expr2 = gfc_get_expr ();
+ block->expr2->expr_type = EXPR_OP;
+ block->expr2->value.op.op = INTRINSIC_TIMES;
+ block->expr2->where = gfc_current_locus;
+
+ /* sizes(idx-1). */
+ block->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes);
+ block->expr2->value.op.op1->ref = gfc_get_ref ();
+ block->expr2->value.op.op1->ref->type = REF_ARRAY;
+ block->expr2->value.op.op1->ref->u.ar.as = sizes->as;
+ block->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT;
+ block->expr2->value.op.op1->ref->u.ar.dimen = 1;
+ block->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+ block->expr2->value.op.op1->ref->u.ar.start[0] = gfc_get_expr ();
+ block->expr2->value.op.op1->ref->u.ar.start[0]->expr_type = EXPR_OP;
+ block->expr2->value.op.op1->ref->u.ar.start[0]->where = gfc_current_locus;
+ block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
+ block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1
+ = gfc_lval_expr_from_sym (idx);
+ block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op2
+ = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+ block->expr2->value.op.op1->ref->u.ar.start[0]->ts
+ = block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1->ts;
+
+ /* size(array, dim=idx, kind=index_kind). */
+ block->expr2->value.op.op2
+ = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size",
+ gfc_current_locus, 3,
+ gfc_lval_expr_from_sym (array),
+ gfc_lval_expr_from_sym (idx),
+ gfc_get_int_expr (gfc_index_integer_kind,
+ NULL,
+ gfc_index_integer_kind));
+ block->expr2->value.op.op2->ts.kind = gfc_index_integer_kind;
+ block->expr2->ts = idx->ts;
+
+ /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */
+ block->next = gfc_get_code (EXEC_IF);
+ block = block->next;
+
+ block->block = gfc_get_code (EXEC_IF);
+ block = block->block;
+
+ /* if condition: strides(idx) /= sizes(idx-1). */
+ block->expr1 = gfc_get_expr ();
+ block->expr1->ts.type = BT_LOGICAL;
+ block->expr1->ts.kind = gfc_default_logical_kind;
+ block->expr1->expr_type = EXPR_OP;
+ block->expr1->where = gfc_current_locus;
+ block->expr1->value.op.op = INTRINSIC_NE;
+
+ block->expr1->value.op.op1 = gfc_lval_expr_from_sym (strides);
+ block->expr1->value.op.op1->ref = gfc_get_ref ();
+ block->expr1->value.op.op1->ref->type = REF_ARRAY;
+ block->expr1->value.op.op1->ref->u.ar.type = AR_ELEMENT;
+ block->expr1->value.op.op1->ref->u.ar.dimen = 1;
+ block->expr1->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+ block->expr1->value.op.op1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
+ block->expr1->value.op.op1->ref->u.ar.as = strides->as;
+
+ block->expr1->value.op.op2 = gfc_lval_expr_from_sym (sizes);
+ block->expr1->value.op.op2->ref = gfc_get_ref ();
+ block->expr1->value.op.op2->ref->type = REF_ARRAY;
+ block->expr1->value.op.op2->ref->u.ar.as = sizes->as;
+ block->expr1->value.op.op2->ref->u.ar.type = AR_ELEMENT;
+ block->expr1->value.op.op2->ref->u.ar.dimen = 1;
+ block->expr1->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+ block->expr1->value.op.op2->ref->u.ar.start[0] = gfc_get_expr ();
+ block->expr1->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP;
+ block->expr1->value.op.op2->ref->u.ar.start[0]->where = gfc_current_locus;
+ block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS;
+ block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1
+ = gfc_lval_expr_from_sym (idx);
+ block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op2
+ = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+ block->expr1->value.op.op2->ref->u.ar.start[0]->ts
+ = block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts;
+
+ /* if body: is_contiguous = .false. */
+ block->next = gfc_get_code (EXEC_ASSIGN);
+ block = block->next;
+ block->expr1 = gfc_lval_expr_from_sym (is_contiguous);
+ block->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
+ &gfc_current_locus, false);
+
+ /* Obtain the size (number of elements) of "array" MINUS ONE,
+ which is used in the scalarization. */
+ gfc_get_symbol ("nelem", sub_ns, &nelem);
+ nelem->ts.type = BT_INTEGER;
+ nelem->ts.kind = gfc_index_integer_kind;
+ nelem->attr.flavor = FL_VARIABLE;
+ nelem->attr.artificial = 1;
+ gfc_set_sym_referenced (nelem);
+ gfc_commit_symbol (nelem);
+
+ /* nelem = sizes (rank) - 1. */
+ last_code->next = gfc_get_code (EXEC_ASSIGN);
+ last_code = last_code->next;
+
+ last_code->expr1 = gfc_lval_expr_from_sym (nelem);
+
+ last_code->expr2 = gfc_get_expr ();
+ last_code->expr2->expr_type = EXPR_OP;
+ last_code->expr2->value.op.op = INTRINSIC_MINUS;
+ last_code->expr2->value.op.op2
+ = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+ last_code->expr2->ts = last_code->expr2->value.op.op2->ts;
+ last_code->expr2->where = gfc_current_locus;
+
+ last_code->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes);
+ last_code->expr2->value.op.op1->ref = gfc_get_ref ();
+ last_code->expr2->value.op.op1->ref->type = REF_ARRAY;
+ last_code->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT;
+ last_code->expr2->value.op.op1->ref->u.ar.dimen = 1;
+ last_code->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+ last_code->expr2->value.op.op1->ref->u.ar.start[0] = gfc_copy_expr (rank);
+ last_code->expr2->value.op.op1->ref->u.ar.as = sizes->as;
+
+ /* Call final subroutines. We now generate code like:
+ use iso_c_binding
+ integer, pointer :: ptr
+ type(c_ptr) :: cptr
+ integer(c_intptr_t) :: i, addr
+
+ select case (rank (array))
+ case (3)
+ ! If needed, the array is packed
+ call final_rank3 (array)
+ case default:
+ do i = 0, size (array)-1
+ addr = transfer (c_loc (array), addr) + i * stride
+ call c_f_pointer (transfer (addr, cptr), ptr)
+ call elemental_final (ptr)
+ end do
+ end select */
+
+ if (derived->f2k_derived && derived->f2k_derived->finalizers)
+ {
+ gfc_finalizer *fini, *fini_elem = NULL;
+
+ gfc_get_symbol ("ptr1", sub_ns, &ptr);
+ ptr->ts.type = BT_DERIVED;
+ ptr->ts.u.derived = derived;
+ ptr->attr.flavor = FL_VARIABLE;
+ ptr->attr.pointer = 1;
+ ptr->attr.artificial = 1;
+ gfc_set_sym_referenced (ptr);
+ gfc_commit_symbol (ptr);
+
+ /* SELECT CASE (RANK (array)). */
+ last_code->next = gfc_get_code (EXEC_SELECT);
+ last_code = last_code->next;
+ last_code->expr1 = gfc_copy_expr (rank);
+ block = NULL;
+
+ for (fini = derived->f2k_derived->finalizers; fini; fini = fini->next)
+ {
+ gcc_assert (fini->proc_tree); /* Should have been set in gfc_resolve_finalizers. */
+ if (fini->proc_tree->n.sym->attr.elemental)
+ {
+ fini_elem = fini;
+ continue;
+ }
+
+ /* CASE (fini_rank). */
+ if (block)
+ {
+ block->block = gfc_get_code (EXEC_SELECT);
+ block = block->block;
+ }
+ else
+ {
+ block = gfc_get_code (EXEC_SELECT);
+ last_code->block = block;
+ }
+ block->ext.block.case_list = gfc_get_case ();
+ block->ext.block.case_list->where = gfc_current_locus;
+ if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
+ block->ext.block.case_list->low
+ = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ fini->proc_tree->n.sym->formal->sym->as->rank);
+ else
+ block->ext.block.case_list->low
+ = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+ block->ext.block.case_list->high
+ = gfc_copy_expr (block->ext.block.case_list->low);
+
+ /* CALL fini_rank (array) - possibly with packing. */
+ if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
+ finalizer_insert_packed_call (block, fini, array, byte_stride,
+ idx, ptr, nelem, strides,
+ sizes, idx2, offset, is_contiguous,
+ rank, sub_ns);
+ else
+ {
+ block->next = gfc_get_code (EXEC_CALL);
+ block->next->symtree = fini->proc_tree;
+ block->next->resolved_sym = fini->proc_tree->n.sym;
+ block->next->ext.actual = gfc_get_actual_arglist ();
+ block->next->ext.actual->expr = gfc_lval_expr_from_sym (array);
+ }
+ }
+
+ /* Elemental call - scalarized. */
+ if (fini_elem)
+ {
+ /* CASE DEFAULT. */
+ if (block)
+ {
+ block->block = gfc_get_code (EXEC_SELECT);
+ block = block->block;
+ }
+ else
+ {
+ block = gfc_get_code (EXEC_SELECT);
+ last_code->block = block;
+ }
+ block->ext.block.case_list = gfc_get_case ();
+
+ /* Create loop. */
+ iter = gfc_get_iterator ();
+ iter->var = gfc_lval_expr_from_sym (idx);
+ iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+ iter->end = gfc_lval_expr_from_sym (nelem);
+ iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+ block->next = gfc_get_code (EXEC_DO);
+ block = block->next;
+ block->ext.iterator = iter;
+ block->block = gfc_get_code (EXEC_DO);
+
+ /* Offset calculation. */
+ block = finalization_get_offset (idx, idx2, offset, strides, sizes,
+ byte_stride, rank, block->block,
+ sub_ns);
+
+ /* Create code for
+ CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
+ + offset, c_ptr), ptr). */
+ block->next
+ = finalization_scalarizer (array, ptr,
+ gfc_lval_expr_from_sym (offset),
+ sub_ns);
+ block = block->next;
+
+ /* CALL final_elemental (array). */
+ block->next = gfc_get_code (EXEC_CALL);
+ block = block->next;
+ block->symtree = fini_elem->proc_tree;
+ block->resolved_sym = fini_elem->proc_sym;
+ block->ext.actual = gfc_get_actual_arglist ();
+ block->ext.actual->expr = gfc_lval_expr_from_sym (ptr);
+ }
+ }
+
+ /* Finalize and deallocate allocatable components. The same manual
+ scalarization is used as above. */
+
+ if (finalizable_comp)
+ {
+ gfc_symbol *stat;
+ gfc_code *block = NULL;
+
+ if (!ptr)
+ {
+ gfc_get_symbol ("ptr2", sub_ns, &ptr);
+ ptr->ts.type = BT_DERIVED;
+ ptr->ts.u.derived = derived;
+ ptr->attr.flavor = FL_VARIABLE;
+ ptr->attr.pointer = 1;
+ ptr->attr.artificial = 1;
+ gfc_set_sym_referenced (ptr);
+ gfc_commit_symbol (ptr);
+ }
+
+ gfc_get_symbol ("ignore", sub_ns, &stat);
+ stat->attr.flavor = FL_VARIABLE;
+ stat->attr.artificial = 1;
+ stat->ts.type = BT_INTEGER;
+ stat->ts.kind = gfc_default_integer_kind;
+ gfc_set_sym_referenced (stat);
+ gfc_commit_symbol (stat);
+
+ /* Create loop. */
+ iter = gfc_get_iterator ();
+ iter->var = gfc_lval_expr_from_sym (idx);
+ iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+ iter->end = gfc_lval_expr_from_sym (nelem);
+ iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
+ last_code->next = gfc_get_code (EXEC_DO);
+ last_code = last_code->next;
+ last_code->ext.iterator = iter;
+ last_code->block = gfc_get_code (EXEC_DO);
+
+ /* Offset calculation. */
+ block = finalization_get_offset (idx, idx2, offset, strides, sizes,
+ byte_stride, rank, last_code->block,
+ sub_ns);
+
+ /* Create code for
+ CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr)
+ + idx * stride, c_ptr), ptr). */
+ block->next = finalization_scalarizer (array, ptr,
+ gfc_lval_expr_from_sym(offset),
+ sub_ns);
+ block = block->next;
+
+ for (comp = derived->components; comp; comp = comp->next)
+ {
+ if (comp == derived->components && derived->attr.extension
+ && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
+ continue;
+
+ finalize_component (gfc_lval_expr_from_sym (ptr), derived, comp,
+ stat, fini_coarray, &block, sub_ns);
+ if (!last_code->block->next)
+ last_code->block->next = block;
+ }
+
+ }
+
+ /* Call the finalizer of the ancestor. */
+ if (ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL)
+ {
+ last_code->next = gfc_get_code (EXEC_CALL);
+ last_code = last_code->next;
+ last_code->symtree = ancestor_wrapper->symtree;
+ last_code->resolved_sym = ancestor_wrapper->symtree->n.sym;
+
+ last_code->ext.actual = gfc_get_actual_arglist ();
+ last_code->ext.actual->expr = gfc_lval_expr_from_sym (array);
+ last_code->ext.actual->next = gfc_get_actual_arglist ();
+ last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (byte_stride);
+ last_code->ext.actual->next->next = gfc_get_actual_arglist ();
+ last_code->ext.actual->next->next->expr
+ = gfc_lval_expr_from_sym (fini_coarray);
+ }
+
+ gfc_free_expr (rank);
+ vtab_final->initializer = gfc_lval_expr_from_sym (final);
+ vtab_final->ts.interface = final;
+ free (name);
+}
+
+
/* Add procedure pointers for all type-bound procedures to a vtab. */
static void
}
-/* Find (or generate) the symbol for a derived type's vtab. */
+/* 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;
+ gfc_gsymbol *gsym = NULL;
+ gfc_symbol *dealloc = NULL, *arg = NULL;
+
+ if (derived->attr.pdt_template)
+ return NULL;
- /* Find the top-level namespace (MODULE or PROGRAM). */
+ /* Find the top-level namespace. */
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)
+ if (!derived->attr.unlimited_polymorphic && derived->attr.is_class)
derived = gfc_get_derived_super_type (derived);
-
+
+ if (!derived)
+ return NULL;
+
+ /* Find the gsymbol for the module of use associated derived types. */
+ if ((derived->attr.use_assoc || derived->attr.used_in_submodule)
+ && !derived->attr.vtype && !derived->attr.is_class)
+ gsym = gfc_find_gsymbol (gfc_gsym_root, derived->module);
+ else
+ gsym = NULL;
+
+ /* Work in the gsymbol namespace if the top-level namespace is a module.
+ This ensures that the vtable is unique, which is required since we use
+ its address in SELECT TYPE. */
+ if (gsym && gsym->ns && ns && ns->proc_name
+ && ns->proc_name->attr.flavor == FL_MODULE)
+ ns = gsym->ns;
+
if (ns)
{
- char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
-
+ char tname[GFC_MAX_SYMBOL_LEN+1];
+ char *name;
+
get_unique_hashed_string (tname, derived);
- sprintf (name, "__vtab_%s", tname);
+ name = xasprintf ("__vtab_%s", tname);
/* Look for the vtab symbol in various namespaces. */
- gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
+ if (gsym && gsym->ns)
+ {
+ gfc_find_symbol (name, gsym->ns, 0, &vtab);
+ if (vtab)
+ ns = gsym->ns;
+ }
+ if (vtab == NULL)
+ gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
if (vtab == NULL)
gfc_find_symbol (name, 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)
+ if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
+ &gfc_current_locus))
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);
-
+ name = xasprintf ("__vtype_%s", tname);
+
gfc_find_symbol (name, ns, 0, &vtype);
if (vtype == NULL)
{
gfc_component *c;
gfc_symbol *parent = NULL, *parent_vtab = NULL;
+ bool rdt = false;
+
+ /* Is this a derived type with recursive allocatable
+ components? */
+ c = (derived->attr.unlimited_polymorphic
+ || derived->attr.abstract) ?
+ NULL : derived->components;
+ for (; c; c= c->next)
+ if (c->ts.type == BT_DERIVED
+ && c->ts.u.derived == derived)
+ {
+ rdt = true;
+ break;
+ }
gfc_get_symbol (name, ns, &vtype);
- if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
- NULL, &gfc_current_locus) == FAILURE)
+ if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL,
+ &gfc_current_locus))
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)
+ if (!gfc_add_component (vtype, "_hash", &c))
goto cleanup;
c->ts.type = BT_INTEGER;
c->ts.kind = 4;
NULL, derived->hash_value);
/* Add component '_size'. */
- if (gfc_add_component (vtype, "_size", &c) == FAILURE)
+ if (!gfc_add_component (vtype, "_size", &c))
goto cleanup;
c->ts.type = BT_INTEGER;
- c->ts.kind = 4;
+ c->ts.kind = gfc_size_kind;
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,
+ c->initializer = gfc_get_int_expr (gfc_size_kind,
NULL, 0);
/* Add component _extends. */
- if (gfc_add_component (vtype, "_extends", &c) == FAILURE)
+ if (!gfc_add_component (vtype, "_extends", &c))
goto cleanup;
c->attr.pointer = 1;
c->attr.access = ACCESS_PRIVATE;
- parent = gfc_get_derived_super_type (derived);
+ if (!derived->attr.unlimited_polymorphic)
+ parent = gfc_get_derived_super_type (derived);
+ else
+ parent = NULL;
+
if (parent)
{
parent_vtab = gfc_find_derived_vtab (parent);
c->initializer = gfc_get_null_expr (NULL);
}
- if (derived->components == NULL && !derived->attr.zero_comp)
+ if (!derived->attr.unlimited_polymorphic
+ && derived->components == NULL
+ && !derived->attr.zero_comp)
{
/* At this point an error must have occurred.
Prevent further errors on the vtype components. */
}
/* Add component _def_init. */
- if (gfc_add_component (vtype, "_def_init", &c) == FAILURE)
+ if (!gfc_add_component (vtype, "_def_init", &c))
goto cleanup;
c->attr.pointer = 1;
+ c->attr.artificial = 1;
c->attr.access = ACCESS_PRIVATE;
c->ts.type = BT_DERIVED;
c->ts.u.derived = derived;
- if (derived->attr.abstract)
+ if (derived->attr.unlimited_polymorphic
+ || derived->attr.abstract)
c->initializer = gfc_get_null_expr (NULL);
else
{
/* Construct default initialization variable. */
- sprintf (name, "__def_init_%s", tname);
+ name = xasprintf ("__def_init_%s", tname);
gfc_get_symbol (name, ns, &def_init);
def_init->attr.target = 1;
+ def_init->attr.artificial = 1;
def_init->attr.save = SAVE_IMPLICIT;
def_init->attr.access = ACCESS_PUBLIC;
def_init->attr.flavor = FL_VARIABLE;
}
/* Add component _copy. */
- if (gfc_add_component (vtype, "_copy", &c) == FAILURE)
+ if (!gfc_add_component (vtype, "_copy", &c))
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)
+ if (derived->attr.unlimited_polymorphic
+ || derived->attr.abstract)
c->initializer = gfc_get_null_expr (NULL);
else
{
ns->contained = sub_ns;
sub_ns->resolved = 1;
/* Set up procedure symbol. */
- sprintf (name, "__copy_%s", tname);
+ name = xasprintf ("__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.artificial = 1;
copy->attr.if_source = IFSRC_DECL;
/* This is elemental so that arrays are automatically
treated correctly by the scalarizer. */
src->ts.u.derived = derived;
src->attr.flavor = FL_VARIABLE;
src->attr.dummy = 1;
- src->attr.intent = INTENT_IN;
+ src->attr.artificial = 1;
+ src->attr.intent = INTENT_IN;
gfc_set_sym_referenced (src);
copy->formal = gfc_get_formal_arglist ();
copy->formal->sym = src;
dst->ts.u.derived = derived;
dst->attr.flavor = FL_VARIABLE;
dst->attr.dummy = 1;
- dst->attr.intent = INTENT_OUT;
+ dst->attr.artificial = 1;
+ dst->attr.intent = INTENT_INOUT;
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 = gfc_get_code (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->ts.interface = copy;
}
+ /* Add component _final, which contains a procedure pointer to
+ a wrapper which handles both the freeing of allocatable
+ components and the calls to finalization subroutines.
+ Note: The actual wrapper function can only be generated
+ at resolution time. */
+ if (!gfc_add_component (vtype, "_final", &c))
+ goto cleanup;
+ c->attr.proc_pointer = 1;
+ c->attr.access = ACCESS_PRIVATE;
+ c->attr.artificial = 1;
+ c->tb = XCNEW (gfc_typebound_proc);
+ c->tb->ppc = 1;
+ generate_finalization_wrapper (derived, ns, tname, c);
+
+ /* Add component _deallocate. */
+ if (!gfc_add_component (vtype, "_deallocate", &c))
+ 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.unlimited_polymorphic
+ || derived->attr.abstract
+ || !rdt)
+ 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. */
+ name = xasprintf ("__deallocate_%s", tname);
+ gfc_get_symbol (name, sub_ns, &dealloc);
+ sub_ns->proc_name = dealloc;
+ dealloc->attr.flavor = FL_PROCEDURE;
+ dealloc->attr.subroutine = 1;
+ dealloc->attr.pure = 1;
+ dealloc->attr.artificial = 1;
+ dealloc->attr.if_source = IFSRC_DECL;
+
+ if (ns->proc_name->attr.flavor == FL_MODULE)
+ dealloc->module = ns->proc_name->name;
+ gfc_set_sym_referenced (dealloc);
+ /* Set up formal argument. */
+ gfc_get_symbol ("arg", sub_ns, &arg);
+ arg->ts.type = BT_DERIVED;
+ arg->ts.u.derived = derived;
+ arg->attr.flavor = FL_VARIABLE;
+ arg->attr.dummy = 1;
+ arg->attr.artificial = 1;
+ arg->attr.intent = INTENT_INOUT;
+ arg->attr.dimension = 1;
+ arg->attr.allocatable = 1;
+ arg->as = gfc_get_array_spec();
+ arg->as->type = AS_ASSUMED_SHAPE;
+ arg->as->rank = 1;
+ arg->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1);
+ gfc_set_sym_referenced (arg);
+ dealloc->formal = gfc_get_formal_arglist ();
+ dealloc->formal->sym = arg;
+ /* Set up code. */
+ sub_ns->code = gfc_get_code (EXEC_DEALLOCATE);
+ sub_ns->code->ext.alloc.list = gfc_get_alloc ();
+ sub_ns->code->ext.alloc.list->expr
+ = gfc_lval_expr_from_sym (arg);
+ /* Set initializer. */
+ c->initializer = gfc_lval_expr_from_sym (dealloc);
+ c->ts.interface = dealloc;
+ }
+
/* Add procedure pointers for type-bound procedures. */
- add_procs_to_declared_vtab (derived, vtype);
- }
+ if (!derived->attr.unlimited_polymorphic)
+ add_procs_to_declared_vtab (derived, vtype);
+ }
have_vtype:
vtab->ts.u.derived = vtype;
vtab->value = gfc_default_initializer (&vtab->ts);
}
+ free (name);
}
found_sym = vtab;
gfc_commit_symbol (src);
if (dst)
gfc_commit_symbol (dst);
+ if (dealloc)
+ gfc_commit_symbol (dealloc);
+ if (arg)
+ gfc_commit_symbol (arg);
+ }
+ else
+ gfc_undo_symbols ();
+
+ return found_sym;
+}
+
+
+/* Check if a derived type is finalizable. That is the case if it
+ (1) has a FINAL subroutine or
+ (2) has a nonpointer nonallocatable component of finalizable type.
+ If it is finalizable, return an expression containing the
+ finalization wrapper. */
+
+bool
+gfc_is_finalizable (gfc_symbol *derived, gfc_expr **final_expr)
+{
+ gfc_symbol *vtab;
+ gfc_component *c;
+
+ /* (1) Check for FINAL subroutines. */
+ if (derived->f2k_derived && derived->f2k_derived->finalizers)
+ goto yes;
+
+ /* (2) Check for components of finalizable type. */
+ for (c = derived->components; c; c = c->next)
+ if (c->ts.type == BT_DERIVED
+ && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable
+ && gfc_is_finalizable (c->ts.u.derived, NULL))
+ goto yes;
+
+ return false;
+
+yes:
+ /* Make sure vtab is generated. */
+ vtab = gfc_find_derived_vtab (derived);
+ if (final_expr)
+ {
+ /* Return finalizer expression. */
+ gfc_component *final;
+ final = vtab->ts.u.derived->components->next->next->next->next->next;
+ gcc_assert (strcmp (final->name, "_final") == 0);
+ gcc_assert (final->initializer
+ && final->initializer->expr_type != EXPR_NULL);
+ *final_expr = final->initializer;
+ }
+ return true;
+}
+
+
+/* Find (or generate) the symbol for an intrinsic type's vtab. This is
+ needed to support unlimited polymorphism. */
+
+static gfc_symbol *
+find_intrinsic_vtab (gfc_typespec *ts)
+{
+ gfc_namespace *ns;
+ gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL;
+ gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
+
+ /* Find the top-level namespace. */
+ for (ns = gfc_current_ns; ns; ns = ns->parent)
+ if (!ns->parent)
+ break;
+
+ if (ns)
+ {
+ char tname[GFC_MAX_SYMBOL_LEN+1];
+ char *name;
+
+ /* Encode all types as TYPENAME_KIND_ including especially character
+ arrays, whose length is now consistently stored in the _len component
+ of the class-variable. */
+ sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);
+ name = xasprintf ("__vtab_%s", tname);
+
+ /* Look for the vtab symbol in the top-level namespace only. */
+ gfc_find_symbol (name, 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))
+ 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);
+ name = xasprintf ("__vtype_%s", tname);
+
+ gfc_find_symbol (name, ns, 0, &vtype);
+ if (vtype == NULL)
+ {
+ gfc_component *c;
+ int hash;
+ gfc_namespace *sub_ns;
+ gfc_namespace *contained;
+ gfc_expr *e;
+ size_t e_size;
+
+ gfc_get_symbol (name, ns, &vtype);
+ if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL,
+ &gfc_current_locus))
+ 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))
+ goto cleanup;
+ c->ts.type = BT_INTEGER;
+ c->ts.kind = 4;
+ c->attr.access = ACCESS_PRIVATE;
+ hash = gfc_intrinsic_hash_value (ts);
+ c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, hash);
+
+ /* Add component '_size'. */
+ if (!gfc_add_component (vtype, "_size", &c))
+ goto cleanup;
+ c->ts.type = BT_INTEGER;
+ c->ts.kind = gfc_size_kind;
+ c->attr.access = ACCESS_PRIVATE;
+
+ /* Build a minimal expression to make use of
+ target-memory.c/gfc_element_size for 'size'. Special handling
+ for character arrays, that are not constant sized: to support
+ len (str) * kind, only the kind information is stored in the
+ vtab. */
+ e = gfc_get_expr ();
+ e->ts = *ts;
+ e->expr_type = EXPR_VARIABLE;
+ if (ts->type == BT_CHARACTER)
+ e_size = ts->kind;
+ else
+ gfc_element_size (e, &e_size);
+ c->initializer = gfc_get_int_expr (gfc_size_kind,
+ NULL,
+ e_size);
+ gfc_free_expr (e);
+
+ /* Add component _extends. */
+ if (!gfc_add_component (vtype, "_extends", &c))
+ goto cleanup;
+ c->attr.pointer = 1;
+ c->attr.access = ACCESS_PRIVATE;
+ c->ts.type = BT_VOID;
+ c->initializer = gfc_get_null_expr (NULL);
+
+ /* Add component _def_init. */
+ if (!gfc_add_component (vtype, "_def_init", &c))
+ goto cleanup;
+ c->attr.pointer = 1;
+ c->attr.access = ACCESS_PRIVATE;
+ c->ts.type = BT_VOID;
+ c->initializer = gfc_get_null_expr (NULL);
+
+ /* Add component _copy. */
+ if (!gfc_add_component (vtype, "_copy", &c))
+ goto cleanup;
+ c->attr.proc_pointer = 1;
+ c->attr.access = ACCESS_PRIVATE;
+ c->tb = XCNEW (gfc_typebound_proc);
+ c->tb->ppc = 1;
+
+ if (ts->type != BT_CHARACTER)
+ name = xasprintf ("__copy_%s", tname);
+ else
+ {
+ /* __copy is always the same for characters.
+ Check to see if copy function already exists. */
+ name = xasprintf ("__copy_character_%d", ts->kind);
+ contained = ns->contained;
+ for (; contained; contained = contained->sibling)
+ if (contained->proc_name
+ && strcmp (name, contained->proc_name->name) == 0)
+ {
+ copy = contained->proc_name;
+ goto got_char_copy;
+ }
+ }
+
+ /* Set up 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. */
+ 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 && 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 = ts->type;
+ src->ts.kind = ts->kind;
+ 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 = ts->type;
+ dst->ts.kind = ts->kind;
+ dst->attr.flavor = FL_VARIABLE;
+ dst->attr.dummy = 1;
+ dst->attr.intent = INTENT_INOUT;
+ 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 (EXEC_INIT_ASSIGN);
+ sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
+ sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
+ got_char_copy:
+ /* Set initializer. */
+ c->initializer = gfc_lval_expr_from_sym (copy);
+ c->ts.interface = copy;
+
+ /* Add component _final. */
+ if (!gfc_add_component (vtype, "_final", &c))
+ goto cleanup;
+ c->attr.proc_pointer = 1;
+ c->attr.access = ACCESS_PRIVATE;
+ c->attr.artificial = 1;
+ c->tb = XCNEW (gfc_typebound_proc);
+ c->tb->ppc = 1;
+ c->initializer = gfc_get_null_expr (NULL);
+ }
+ vtab->ts.u.derived = vtype;
+ vtab->value = gfc_default_initializer (&vtab->ts);
+ }
+ free (name);
+ }
+
+ 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 (copy)
+ gfc_commit_symbol (copy);
+ if (src)
+ gfc_commit_symbol (src);
+ if (dst)
+ gfc_commit_symbol (dst);
}
else
gfc_undo_symbols ();
}
+/* Find (or generate) a vtab for an arbitrary type (derived or intrinsic). */
+
+gfc_symbol *
+gfc_find_vtab (gfc_typespec *ts)
+{
+ switch (ts->type)
+ {
+ case BT_UNKNOWN:
+ return NULL;
+ case BT_DERIVED:
+ return gfc_find_derived_vtab (ts->u.derived);
+ case BT_CLASS:
+ if (ts->u.derived->components && ts->u.derived->components->ts.u.derived)
+ return gfc_find_derived_vtab (ts->u.derived->components->ts.u.derived);
+ else
+ return NULL;
+ default:
+ return find_intrinsic_vtab (ts);
+ }
+}
+
+
/* 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,
+find_typebound_proc_uop (gfc_symbol* derived, bool* 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;
+ *t = false;
+
+ 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);
{
/* We found one. */
if (t)
- *t = SUCCESS;
+ *t = true;
if (!noaccess && derived->attr.use_assoc
&& res->n.tb->access == ACCESS_PRIVATE)
{
if (where)
- gfc_error ("'%s' of '%s' is PRIVATE at %L",
+ gfc_error ("%qs of %qs is PRIVATE at %L",
name, derived->name, where);
if (t)
- *t = FAILURE;
+ *t = false;
}
return res;
(looking recursively through the super-types). */
gfc_symtree*
-gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
+gfc_find_typebound_proc (gfc_symbol* derived, bool* 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,
+gfc_find_typebound_user_op (gfc_symbol* derived, bool* t,
const char* name, bool noaccess, locus* where)
{
return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
super-type hierarchy. */
gfc_typebound_proc*
-gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
+gfc_find_typebound_intrinsic_op (gfc_symbol* derived, bool* t,
gfc_intrinsic_op op, bool noaccess,
locus* where)
{
/* Set default to failure. */
if (t)
- *t = FAILURE;
+ *t = false;
/* Try to find it in the current type's namespace. */
if (derived->f2k_derived)
res = derived->f2k_derived->tb_op[op];
- else
+ else
res = NULL;
/* Check access. */
{
/* We found one. */
if (t)
- *t = SUCCESS;
+ *t = true;
if (!noaccess && derived->attr.use_assoc
&& res->access == ACCESS_PRIVATE)
{
if (where)
- gfc_error ("'%s' of '%s' is PRIVATE at %L",
+ gfc_error ("%qs of %qs is PRIVATE at %L",
gfc_op2string (op), derived->name, where);
if (t)
- *t = FAILURE;
+ *t = false;
}
return res;
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;
+ gfc_symtree *result = gfc_find_symtree (*root, name);
+ return result ? result : gfc_new_symtree (root, name);
}
projects / thirdparty / gcc.git / blobdiff