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. */
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;
/* Find the top-level namespace. */
for (ns = gfc_current_ns; ns; ns = ns->parent)
{
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->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. */
+ sprintf (name, "__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. */
if (!derived->attr.unlimited_polymorphic)
add_procs_to_declared_vtab (derived, vtype);
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 ();
&& current_ts.u.derived == gfc_current_block ()
&& current_attr.pointer == 0)
{
+ if (current_attr.allocatable
+ && !gfc_notify_std(GFC_STD_F2008, "Component at %C "
+ "must have the POINTER attribute"))
+ {
+ return false;
+ }
+ else if (current_attr.allocatable == 0)
+ {
gfc_error ("Component at %C must have the POINTER attribute");
return false;
}
+ }
if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
{
if (current_attr.pointer && gfc_comp_struct (gfc_current_state ()))
goto ok;
+ if (current_attr.allocatable && gfc_current_state () == COMP_DERIVED
+ && current_ts.u.derived == gfc_current_block ())
+ goto ok;
+
gfc_find_symbol (current_ts.u.derived->name,
current_ts.u.derived->ns, 1, &sym);
if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
&& lvalue->symtree->n.sym->attr.data
&& !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L used to "
- "initialize non-integer variable %qs",
+ "initialize non-integer variable %qs",
&rvalue->where, lvalue->symtree->n.sym->name))
return false;
else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
}
if (!gfc_notify_std (GFC_STD_F2003, "Bounds specification "
- "for %qs in pointer assignment at %L",
+ "for %qs in pointer assignment at %L",
lvalue->symtree->n.sym->name, &lvalue->where))
return false;
if (gfc_bt_struct (c->ts.type))
{
if (!c->attr.pointer && !c->attr.proc_pointer
+ && !(c->attr.allocatable && der == c->ts.u.derived)
&& gfc_has_default_initializer (c->ts.u.derived))
return true;
if (c->attr.pointer && c->initializer)
}
-/* Get or generate an expression for a default initializer of a derived type.
+/* Get or generate an expression for a default initializer of a derived type.
If -finit-derived is specified, generate default initialization expressions
for components that lack them when generate is set. */
{
gfc_constructor *c, *n;
gfc_expr *ec, *en;
-
+
for (c = gfc_constructor_first (arr->value.constructor);
c != NULL; c = gfc_constructor_next (c))
{
if (c == NULL || c->iterator != NULL)
continue;
-
+
ec = c->expr;
for (n = gfc_constructor_next (c); n != NULL;
{
if (n->iterator != NULL)
continue;
-
+
en = n->expr;
if (gfc_dep_compare_expr (ec, en) == 0)
{
}
}
}
-
+
return true;
}
return false;
}
+ /* If an allocatable component derived type is of the same type as
+ the enclosing derived type, we need a vtable generating so that
+ the __deallocate procedure is created. */
+ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && c->ts.u.derived == sym && c->attr.allocatable == 1)
+ gfc_find_vtab (&c->ts);
+
/* Ensure that all the derived type components are put on the
derived type list; even in formal namespaces, where derived type
pointer components might not have been declared. */
tree vref, dref;
tree null_cond = NULL_TREE;
tree add_when_allocated;
+ tree dealloc_fndecl;
bool called_dealloc_with_status;
+ gfc_symbol *vtab;
gfc_init_block (&fnblock);
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;
+
cdecl = c->backend_decl;
ctype = TREE_TYPE (cdecl);
if (c->attr.allocatable && !c->attr.proc_pointer
&& (c->attr.dimension
|| (c->attr.codimension
- && purpose != DEALLOCATE_ALLOC_COMP_NO_CAF)))
+ && purpose != DEALLOCATE_ALLOC_COMP_NO_CAF))
+ && !same_type)
{
if (comp == NULL_TREE)
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension, NULL);
gfc_add_expr_to_block (&tmpblock, tmp);
}
- else if (c->attr.allocatable && !c->attr.codimension)
+ else if (c->attr.allocatable && !c->attr.codimension && !same_type)
{
/* Allocatable scalar components. */
if (comp == NULL_TREE)
build_int_cst (TREE_TYPE (comp), 0));
gfc_add_expr_to_block (&tmpblock, tmp);
}
+ else if (c->attr.allocatable && !c->attr.codimension)
+ {
+ /* Case of recursive allocatable derived types. */
+ tree is_allocated;
+ tree ubound;
+ tree cdesc;
+ tree zero = build_int_cst (gfc_array_index_type, 0);
+ tree unity = build_int_cst (gfc_array_index_type, 1);
+ tree data;
+ stmtblock_t dealloc_block;
+
+ gfc_init_block (&dealloc_block);
+
+ /* Convert the component into a rank 1 descriptor type. */
+ if (comp == NULL_TREE)
+ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
+
+ if (c->attr.dimension)
+ {
+ tmp = gfc_get_element_type (TREE_TYPE (comp));
+ ubound = gfc_full_array_size (&dealloc_block, comp, c->as->rank);
+ }
+ else
+ {
+ tmp = TREE_TYPE (comp);
+ ubound = build_int_cst (gfc_array_index_type, 1);
+ }
+
+ cdesc = gfc_get_array_type_bounds (tmp, 1, 0,
+ &unity, &ubound, 1,
+ GFC_ARRAY_ALLOCATABLE, false);
+
+ cdesc = gfc_create_var (cdesc, "cdesc");
+ DECL_ARTIFICIAL (cdesc) = 1;
+
+ gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc),
+ gfc_get_dtype_rank_type (1, tmp));
+ gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc,
+ zero, unity);
+ gfc_conv_descriptor_stride_set (&dealloc_block, cdesc,
+ zero, unity);
+ gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc,
+ zero, ubound);
+
+ if (c->attr.dimension)
+ data = gfc_conv_descriptor_data_get (comp);
+ else
+ data = comp;
+
+ gfc_conv_descriptor_data_set (&dealloc_block, cdesc, data);
+
+ /* Now call the deallocator. */
+ vtab = gfc_find_vtab (&c->ts);
+ if (vtab->backend_decl == NULL)
+ gfc_get_symbol_decl (vtab);
+ tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
+ dealloc_fndecl = gfc_vptr_deallocate_get (tmp);
+ dealloc_fndecl = build_fold_indirect_ref_loc (input_location,
+ dealloc_fndecl);
+ tmp = build_int_cst (TREE_TYPE (data), 0);
+ is_allocated = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, tmp,
+ data);
+ cdesc = gfc_build_addr_expr (NULL_TREE, cdesc);
+
+ tmp = build_call_expr_loc (input_location,
+ dealloc_fndecl, 1,
+ cdesc);
+ gfc_add_expr_to_block (&dealloc_block, tmp);
+
+ tmp = gfc_finish_block (&dealloc_block);
+
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, is_allocated, tmp,
+ build_empty_stmt (input_location));
+
+ gfc_add_expr_to_block (&tmpblock, tmp);
+
+ gfc_add_modify (&tmpblock, data,
+ build_int_cst (TREE_TYPE (data), 0));
+ }
+
else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable
&& (!CLASS_DATA (c)->attr.codimension
|| purpose != DEALLOCATE_ALLOC_COMP_NO_CAF))
if (cmp_has_alloc_comps
&& !c->attr.pointer && !c->attr.proc_pointer
+ && !same_type
&& !called_dealloc_with_status)
{
/* Do not deallocate the components of ultimate pointer
components that are really allocated, the deep copy code has to
be generated first and then added to the if-block in
gfc_duplicate_allocatable (). */
- if (cmp_has_alloc_comps
- && !c->attr.proc_pointer)
+ if (cmp_has_alloc_comps && !c->attr.proc_pointer
+ && !same_type)
{
rank = c->as ? c->as->rank : 0;
tmp = fold_convert (TREE_TYPE (dcmp), comp);
false, false, size, NULL_TREE);
gfc_add_expr_to_block (&fnblock, tmp);
}
- else if (c->attr.allocatable && !c->attr.proc_pointer
- && (!(cmp_has_alloc_comps && c->as)
- || c->attr.codimension))
+ else if (c->attr.allocatable && !c->attr.proc_pointer && !same_type
+ && (!(cmp_has_alloc_comps && c->as) || c->attr.codimension))
{
rank = c->as ? c->as->rank : 0;
if (c->attr.codimension)
#define VTABLE_DEF_INIT_FIELD 3
#define VTABLE_COPY_FIELD 4
#define VTABLE_FINAL_FIELD 5
+#define VTABLE_DEALLOCATE_FIELD 6
tree
VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
+VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
/* The size field is returned as an array index type. Therefore treat
non-procedure pointer components have no backend_decl. */
for (c = derived->components; c; c = c->next)
{
- if (!c->attr.proc_pointer && c->backend_decl == NULL)
+ bool same_alloc_type = c->attr.allocatable
+ && derived == c->ts.u.derived;
+ if (!c->attr.proc_pointer
+ && !same_alloc_type
+ && c->backend_decl == NULL)
break;
else if (c->next == NULL)
return derived->backend_decl;
will be built and so we can return the type. */
for (c = derived->components; c; c = c->next)
{
+ bool same_alloc_type = c->attr.allocatable
+ && derived == c->ts.u.derived;
+
if (c->ts.type == BT_UNION && c->ts.u.derived->backend_decl == NULL)
c->ts.u.derived->backend_decl = gfc_get_union_type (c->ts.u.derived);
if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
continue;
- if ((!c->attr.pointer && !c->attr.proc_pointer)
+ if ((!c->attr.pointer && !c->attr.proc_pointer
+ && !same_alloc_type)
|| c->ts.u.derived->backend_decl == NULL)
c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived,
in_coarray
types are built as part of gfc_get_union_type. */
for (c = derived->components; c; c = c->next)
{
+ bool same_alloc_type = c->attr.allocatable
+ && derived == c->ts.u.derived;
/* Prevent infinite recursion, when the procedure pointer type is
the same as derived, by forcing the procedure pointer component to
be built as if the explicit interface does not exist. */
&& !(unlimited_entity && c == derived->components))
field_type = build_pointer_type (field_type);
- if (c->attr.pointer)
+ if (c->attr.pointer || same_alloc_type)
field_type = gfc_nonrestricted_type (field_type);
/* vtype fields can point to different types to the base type. */
tree gfc_vptr_def_init_get (tree);
tree gfc_vptr_copy_get (tree);
tree gfc_vptr_final_get (tree);
+tree gfc_vptr_deallocate_get (tree);
void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
void gfc_reset_len (stmtblock_t *, gfc_expr *);
tree gfc_get_vptr_from_expr (tree);
! { dg-do compile }
+! { dg-options "-std=f2003" }
!
! PR 40940: CLASS statement
!
class(*), allocatable :: var
end
-! { dg-final { scan-tree-dump "static struct __vtype__STAR __vtab__STAR = {._hash=0, ._size=., ._extends=0B, ._def_init=0B, ._copy=0B, ._final=0B};" "original" } }
+! { dg-final { scan-tree-dump "static struct __vtype__STAR __vtab__STAR = {._hash=0, ._size=., ._extends=0B, ._def_init=0B, ._copy=0B, ._final=0B, ._deallocate=0B};" "original" } }
--- /dev/null
+! { dg-do run }
+!
+! Tests functionality of recursive allocatable derived types.
+!
+ type :: recurses
+ type(recurses), allocatable :: c
+ integer, allocatable :: ia
+ end type
+
+ type(recurses), allocatable, target :: a, d
+ type(recurses), pointer :: b
+
+ integer :: total = 0
+
+! Check chained allocation.
+ allocate(a)
+ a%ia = 1
+ allocate (a%c)
+ a%c%ia = 2
+
+! Check move_alloc.
+ allocate (d)
+ d%ia = 3
+ call move_alloc (d, a%c%c)
+
+ if (a%ia .ne. 1) call abort
+ if (a%c%ia .ne. 2) call abort
+ if (a%c%c%ia .ne. 3) call abort
+
+! Check that we can point anywhere in the chain
+ b => a%c%c
+ if (b%ia .ne. 3) call abort
+ b => a%c
+ if (b%ia .ne. 2) call abort
+
+! Check that the pointer can be used as if it were an element in the chain.
+ if (.not.allocated (b%c)) call abort
+ b => a%c%c
+ if (.not.allocated (b%c)) allocate (b%c)
+ b%c%ia = 4
+ if (a%c%c%c%ia .ne. 4) call abort
+
+! A rudimentary iterator.
+ b => a
+ do while (associated (b))
+ total = total + b%ia
+ b => b%c
+ end do
+ if (total .ne. 10) call abort
+
+! Take one element out of the chain.
+ call move_alloc (a%c%c, d)
+ call move_alloc (d%c, a%c%c)
+ if (d%ia .ne. 3) call abort
+ deallocate (d)
+
+! Checkcount of remaining chain.
+ total = 0
+ b => a
+ do while (associated (b))
+ total = total + b%ia
+ b => b%c
+ end do
+ if (total .ne. 7) call abort
+
+! Deallocate to check that there are no memory leaks.
+ deallocate (a%c%c)
+ deallocate (a%c)
+ deallocate (a)
+end
--- /dev/null
+! { dg-do run }
+!
+! Tests functionality of recursive allocatable derived types.
+!
+module m
+ type :: recurses
+ type(recurses), allocatable :: left
+ type(recurses), allocatable :: right
+ integer, allocatable :: ia
+ end type
+contains
+! Obtain checksum from "keys".
+ recursive function foo (this) result (res)
+ type(recurses) :: this
+ integer :: res
+ res = this%ia
+ if (allocated (this%left)) res = res + foo (this%left)
+ if (allocated (this%right)) res = res + foo (this%right)
+ end function
+! Return pointer to member of binary tree matching "key", null otherwise.
+ recursive function bar (this, key) result (res)
+ type(recurses), target :: this
+ type(recurses), pointer :: res
+ integer :: key
+ if (key .eq. this%ia) then
+ res => this
+ return
+ else
+ res => NULL ()
+ end if
+ if (allocated (this%left)) res => bar (this%left, key)
+ if (associated (res)) return
+ if (allocated (this%right)) res => bar (this%right, key)
+ end function
+end module
+
+ use m
+ type(recurses), allocatable, target :: a
+ type(recurses), pointer :: b => NULL ()
+
+! Check chained allocation.
+ allocate(a)
+ a%ia = 1
+ allocate (a%left)
+ a%left%ia = 2
+ allocate (a%left%left)
+ a%left%left%ia = 3
+ allocate (a%left%right)
+ a%left%right%ia = 4
+ allocate (a%right)
+ a%right%ia = 5
+
+! Checksum OK?
+ if (foo(a) .ne. 15) call abort
+
+! Return pointer to tree item that is present.
+ b => bar (a, 3)
+ if (.not.associated (b) .or. (b%ia .ne. 3)) call abort
+! Return NULL to tree item that is not present.
+ b => bar (a, 6)
+ if (associated (b)) call abort
+
+! Deallocate to check that there are no memory leaks.
+ deallocate (a)
+end
--- /dev/null
+! { dg-do run }
+!
+! Tests functionality of recursive allocatable derived types.
+!
+module m
+ type :: stack
+ integer :: value
+ integer :: index
+ type(stack), allocatable :: next
+ end type stack
+end module
+
+ use m
+! Here is how to add a new entry at the top of the stack:
+ type (stack), allocatable :: top, temp, dum
+
+ call poke (1)
+ call poke (2)
+ call poke (3)
+ if (top%index .ne. 3) call abort
+ call output (top)
+ call pop
+ if (top%index .ne. 2) call abort
+ call output (top)
+ deallocate (top)
+contains
+ subroutine output (arg)
+ type(stack), target, allocatable :: arg
+ type(stack), pointer :: ptr
+
+ if (.not.allocated (arg)) then
+ print *, "empty stack"
+ return
+ end if
+
+ print *, " idx value"
+ ptr => arg
+ do while (associated (ptr))
+ print *, ptr%index, " ", ptr%value
+ ptr => ptr%next
+ end do
+ end subroutine
+ subroutine poke(arg)
+ integer :: arg
+ integer :: idx
+ if (allocated (top)) then
+ idx = top%index + 1
+ else
+ idx = 1
+ end if
+ allocate (temp)
+ temp%value = arg
+ temp%index = idx
+ call move_alloc(top,temp%next)
+ call move_alloc(temp,top)
+ end subroutine
+ subroutine pop
+ call move_alloc(top%next,temp)
+ call move_alloc(temp,top)
+ end subroutine
+end
--- /dev/null
+! { dg-do run }
+!
+! Tests functionality of recursive allocatable derived types.
+! Here the recursive components are arrays, unlike the first three testcases.
+! Notice that array components are fiendishly difficult to use :-(
+!
+module m
+ type :: recurses
+ type(recurses), allocatable :: c(:)
+ integer, allocatable :: ia
+ end type
+end module
+
+ use m
+ type(recurses), allocatable, target :: a, d(:)
+ type(recurses), pointer :: b1
+
+ integer :: total = 0
+
+! Check chained allocation.
+ allocate(a)
+ a%ia = 1
+ allocate (a%c(2))
+ b1 => a%c(1)
+ b1%ia = 2
+
+! Check move_alloc.
+ allocate (d(2))
+ d(1)%ia = 3
+ d(2)%ia = 4
+ b1 => d(2)
+ allocate (b1%c(1))
+ b1 => b1%c(1)
+ b1%ia = 5
+ call move_alloc (d, a%c(2)%c)
+
+ if (a%ia .ne. 1) call abort
+ if (a%c(1)%ia .ne. 2) call abort
+ if (a%c(2)%c(1)%ia .ne. 3) call abort
+ if (a%c(2)%c(2)%ia .ne. 4) call abort
+ if (a%c(2)%c(2)%c(1)%ia .ne. 5) call abort
+
+ if (allocated (a)) deallocate (a)
+ if (allocated (d)) deallocate (d)
+
+end
projects / gcc.git / commitdiff