{
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,
c->attr.access = ACCESS_PRIVATE;
c->tb = XCNEW (gfc_typebound_proc);
c->tb->ppc = 1;
- if (derived->attr.unlimited_polymorphic
- || derived->attr.abstract
- || !rdt)
+ if (derived->attr.unlimited_polymorphic || derived->attr.abstract
+ || !derived->attr.recursive)
c->initializer = gfc_get_null_expr (NULL);
else
{
bool
gfc_has_default_initializer (gfc_symbol *der)
{
+ static hash_set<gfc_symbol *> seen_derived_types;
gfc_component *c;
+ /* The rewrite to a result variable and breaks is only needed, because
+ there is no scope_guard in C++ yet. */
+ bool result = false;
gcc_assert (gfc_fl_struct (der->attr.flavor));
+ seen_derived_types.add (der);
for (c = der->components; c; c = c->next)
- if (gfc_bt_struct (c->ts.type))
+ if (gfc_bt_struct (c->ts.type)
+ && !seen_derived_types.contains (c->ts.u.derived))
{
- if (!c->attr.pointer && !c->attr.proc_pointer
- && !(c->attr.allocatable && der == c->ts.u.derived)
- && ((c->initializer
- && is_non_empty_structure_constructor (c->initializer))
- || gfc_has_default_initializer (c->ts.u.derived)))
- return true;
+ if (!c->attr.pointer && !c->attr.proc_pointer
+ && !(c->attr.allocatable && der == c->ts.u.derived)
+ && ((c->initializer
+ && is_non_empty_structure_constructor (c->initializer))
+ || gfc_has_default_initializer (c->ts.u.derived)))
+ {
+ result = true;
+ break;
+ }
if (c->attr.pointer && c->initializer)
- return true;
+ {
+ result = true;
+ break;
+ }
}
else
{
- if (c->initializer)
- return true;
+ if (c->initializer)
+ {
+ result = true;
+ break;
+ }
}
- return false;
+ seen_derived_types.remove (der);
+ return result;
}
return true;
}
+/* Figure if the derived type is using itself directly in one of its components
+ or through referencing other derived types. The information is required to
+ generate the __deallocate and __final type bound procedures to ensure
+ freeing larger hierarchies of derived types with allocatable objects. */
+
+static void
+resolve_cyclic_derived_type (gfc_symbol *derived)
+{
+ hash_set<gfc_symbol *> seen, to_examin;
+ gfc_component *c;
+ seen.add (derived);
+ to_examin.add (derived);
+ while (!to_examin.is_empty ())
+ {
+ gfc_symbol *cand = *to_examin.begin ();
+ to_examin.remove (cand);
+ for (c = cand->components; c; c = c->next)
+ if (c->ts.type == BT_DERIVED)
+ {
+ if (c->ts.u.derived == derived)
+ {
+ derived->attr.recursive = 1;
+ return;
+ }
+ else if (!seen.contains (c->ts.u.derived))
+ {
+ seen.add (c->ts.u.derived);
+ to_examin.add (c->ts.u.derived);
+ }
+ }
+ else if (c->ts.type == BT_CLASS)
+ {
+ if (!c->attr.class_ok)
+ continue;
+ if (CLASS_DATA (c)->ts.u.derived == derived)
+ {
+ derived->attr.recursive = 1;
+ return;
+ }
+ else if (!seen.contains (CLASS_DATA (c)->ts.u.derived))
+ {
+ seen.add (CLASS_DATA (c)->ts.u.derived);
+ to_examin.add (CLASS_DATA (c)->ts.u.derived);
+ }
+ }
+ }
+}
/* Resolve the components of a derived type. This does not have to wait until
resolution stage, but can be done as soon as the dt declaration has been
return false;
}
+ /* Resolving components below, may create vtabs for which the cyclic type
+ information needs to be present. */
+ resolve_cyclic_derived_type (sym);
+
c = (sym->attr.is_class) ? CLASS_DATA (sym->components)
: sym->components;
return true;
}
-
/* The following procedure does the full resolution of a derived type,
including resolution of all type-bound procedures (if present). In contrast
to 'resolve_fl_derived0' this can only be done after the module has been
being vtables or pdt templates. If this is not done class declarations
in external procedures wind up with their own version and so SELECT TYPE
fails because the vptrs do not have the same address. */
- if (gfc_option.allow_std & GFC_STD_F2003
- && sym->ns->proc_name
- && sym->ns->proc_name->attr.flavor == FL_MODULE
+ if (gfc_option.allow_std & GFC_STD_F2003 && sym->ns->proc_name
+ && (sym->ns->proc_name->attr.flavor == FL_MODULE
+ || (sym->attr.recursive && sym->attr.alloc_comp))
&& sym->attr.access != ACCESS_PRIVATE
&& !(sym->attr.vtype || sym->attr.pdt_template))
{
int caf_dereg_mode;
symbol_attribute *attr;
bool deallocate_called;
+ static hash_set<gfc_symbol *> seen_derived_types;
gfc_init_block (&fnblock);
}
/* Otherwise, act on the components or recursively call self to
act on a chain of components. */
+ seen_derived_types.add (der_type);
for (c = der_type->components; c; c = c->next)
{
bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
|| c->ts.type == BT_CLASS)
&& c->ts.u.derived->attr.alloc_comp;
- bool same_type = (c->ts.type == BT_DERIVED && der_type == c->ts.u.derived)
- || (c->ts.type == BT_CLASS && der_type == CLASS_DATA (c)->ts.u.derived);
+ bool same_type
+ = (c->ts.type == BT_DERIVED
+ && seen_derived_types.contains (c->ts.u.derived))
+ || (c->ts.type == BT_CLASS
+ && seen_derived_types.contains (CLASS_DATA (c)->ts.u.derived));
bool is_pdt_type = c->ts.type == BT_DERIVED
&& c->ts.u.derived->attr.pdt_type;
if (c->ts.type == BT_CLASS)
{
attr = &CLASS_DATA (c)->attr;
- if (attr->class_pointer)
+ if (attr->class_pointer || c->attr.proc_pointer)
continue;
}
else
/* Handle all types of components besides components of the
same_type as the current one, because those would create an
endless loop. */
- caf_dereg_mode
- = (caf_in_coarray (caf_mode) || attr->codimension)
- ? (gfc_caf_is_dealloc_only (caf_mode)
- ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
- : GFC_CAF_COARRAY_DEREGISTER)
- : GFC_CAF_COARRAY_NOCOARRAY;
+ caf_dereg_mode = (caf_in_coarray (caf_mode)
+ && (attr->dimension || c->caf_token))
+ || attr->codimension
+ ? (gfc_caf_is_dealloc_only (caf_mode)
+ ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
+ : GFC_CAF_COARRAY_DEREGISTER)
+ : GFC_CAF_COARRAY_NOCOARRAY;
caf_token = NULL_TREE;
/* Coarray components are handled directly by
break;
}
}
+ seen_derived_types.remove (der_type);
return gfc_finish_block (&fnblock);
}
}
if (last_caf_ref == NULL)
- return NULL_TREE;
+ {
+ gfc_free_expr (caf_expr);
+ return NULL_TREE;
+ }
tree comp = last_caf_ref->u.c.component->caf_token
? gfc_comp_caf_token (last_caf_ref->u.c.component)
gfc_se se;
bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
if (comp == NULL_TREE && comp_ref)
- return NULL_TREE;
+ {
+ gfc_free_expr (caf_expr);
+ return NULL_TREE;
+ }
gfc_init_se (&se, outerse);
gfc_free_ref_list (last_caf_ref->next);
last_caf_ref->next = NULL;
bh => bhGet(b,instance=2)
if (loc (b) .ne. loc(bh%hostNode)) STOP 8
end
-! { dg-final { scan-tree-dump-times "builtin_free" 12 "original" } }
+! { dg-final { scan-tree-dump-times "builtin_free" 16 "original" } }
--- /dev/null
+! { dg-do run }
+!
+! Check that PR116669 is fixed now.
+! Contributed by Dominik Gronkiewicz <gronki@gmail.com>
+
+program pr116669
+
+ implicit none (type, external)
+
+ type ast_expr_t
+ type(ast_opcall_t), allocatable :: op_call
+ end type
+
+ type ast_opcall_t
+ type(ast_expr_t), allocatable :: args(:)
+ end type
+
+ type(ast_opcall_t) :: o
+
+ allocate(o%args(2))
+ allocate(o%args(2)%op_call)
+ allocate(o%args(2)%op_call%args(3))
+
+ if (.NOT. allocated(o%args(2)%op_call%args)) stop 1
+
+ deallocate(o%args)
+end program
+
projects / thirdparty / gcc.git / commitdiff
