Dear All,
Please find attached the patch for allocatable components of recursive
type. The patch is pretty straightforward in that for the main part
they are treated exactly as their pointer equivalents. The exception
to this is the automatic deallocation of allocatable components. I
tried to use the vtable finalization wrapper to do this but found it
impossible to prevent the compilation going into an infinite loop on
trying to build the automatic deallocation code. I therefore added a
new field to the vtable that points to a component that does nothing
more than deallocate the component. This function takes a rank 1
array, which can be done safely for automatic deallocation of an
allocatable component.
The testcases indicate some of the possibilities for these components,
which provide the benefit of automatic garbage collection. As the
comment in the fourth testcase says, array components are fiendishly
difficult to use and, I suspect, will find very little application.
Bootstraps and regtests on FC21/x86_64 - OK for trunk?
Paul
2016-10-24 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/45516
* class.c (gfc_find_derived_vtab): Detect recursive allocatable
derived type components. If present, add '_deallocate' field to
the vtable and build the '__deallocate' function.
* decl.c (build_struct): Allow recursive allocatable derived
type components for -std=f2008 or more.
(gfc_match_data_decl): Accept these derived types.
* expr.c (gfc_has_default_initializer): Ditto.
* resolve.c (resolve_component): Make sure that the vtable is
built for these derived types.
* trans-array.c(structure_alloc_comps) : Use the '__deallocate'
function for the automatic deallocation of these types.
* trans-expr.c : Generate the deallocate accessor.
* trans.h : Add its prototype.
* trans-types.c (gfc_get_derived_type): Treat the recursive
allocatable components in the same way as the corresponding
pointer components.
2016-10-24 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/45516
* gfortran.dg/class_2.f03: Set -std=f2003.
* gfortran.dg/finalize_21.f90: Modify tree-dump.
* gfortran.dg/recursive_alloc_comp_1.f08: New test.
* gfortran.dg/recursive_alloc_comp_2.f08: New test.
* gfortran.dg/recursive_alloc_comp_3.f08: New test.
* gfortran.dg/recursive_alloc_comp_4.f08: New test.
Index: gcc/fortran/class.c
===================================================================
*** gcc/fortran/class.c (revision 241467)
--- gcc/fortran/class.c (working copy)
*************** gfc_find_derived_vtab (gfc_symbol *deriv
*** 2191,2196 ****
--- 2191,2197 ----
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_find_derived_vtab (gfc_symbol *deriv
*** 2255,2260 ****
--- 2256,2275 ----
{
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_find_derived_vtab (gfc_symbol *deriv
*** 2427,2432 ****
--- 2442,2507 ----
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);
*************** cleanup:
*** 2456,2461 ****
--- 2531,2540 ----
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 ();
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 241467)
--- gcc/fortran/decl.c (working copy)
*************** build_struct (const char *name, gfc_char
*** 1858,1866 ****
--- 1858,1875 ----
&& 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)
{
*************** gfc_match_data_decl (void)
*** 4844,4849 ****
--- 4853,4862 ----
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);
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c (revision 241467)
--- gcc/fortran/expr.c (working copy)
*************** gfc_has_default_initializer (gfc_symbol
*** 4144,4149 ****
--- 4144,4150 ----
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)
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 241467)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_component (gfc_component *c, gfc
*** 13493,13498 ****
--- 13493,13505 ----
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. */
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 241467)
--- gcc/fortran/trans-array.c (working copy)
*************** structure_alloc_comps (gfc_symbol * der_
*** 7976,7982 ****
--- 7976,7984 ----
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);
*************** structure_alloc_comps (gfc_symbol * der_
*** 8112,8118 ****
if (c->attr.allocatable && !c->attr.proc_pointer
&& (c->attr.dimension
|| (c->attr.codimension
! && purpose != DEALLOCATE_ALLOC_COMP_NO_CAF)))
{
if (comp == NULL_TREE)
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
--- 8114,8121 ----
if (c->attr.allocatable && !c->attr.proc_pointer
&& (c->attr.dimension
|| (c->attr.codimension
! && purpose != DEALLOCATE_ALLOC_COMP_NO_CAF))
! && !(c->ts.type == BT_DERIVED && der_type == c->ts.u.derived))
{
if (comp == NULL_TREE)
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
*************** structure_alloc_comps (gfc_symbol * der_
*** 8120,8126 ****
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)
{
/* Allocatable scalar components. */
if (comp == NULL_TREE)
--- 8123,8130 ----
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
! && !(c->ts.type == BT_DERIVED && der_type == c->ts.u.derived))
{
/* Allocatable scalar components. */
if (comp == NULL_TREE)
*************** structure_alloc_comps (gfc_symbol * der_
*** 8137,8142 ****
--- 8141,8222 ----
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;
+
+ /* 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 (&tmpblock, 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 (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
+ gfc_get_dtype_rank_type (1, tmp));
+ gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
+ zero, unity);
+ gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
+ zero, unity);
+ gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
+ zero, ubound);
+
+ if (c->attr.dimension)
+ data = gfc_conv_descriptor_data_get (comp);
+ else
+ data = comp;
+
+ gfc_conv_descriptor_data_set (&tmpblock, 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,
+ gfc_conv_descriptor_data_get
(cdesc));
+ cdesc = gfc_build_addr_expr (NULL_TREE, cdesc);
+
+ tmp = build_call_expr_loc (input_location,
+ dealloc_fndecl, 1,
+ cdesc);
+ 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))
*************** structure_alloc_comps (gfc_symbol * der_
*** 8199,8204 ****
--- 8279,8285 ----
if (cmp_has_alloc_comps
&& !c->attr.pointer && !c->attr.proc_pointer
+ && !(c->ts.type == BT_DERIVED && der_type == c->ts.u.derived)
&& !called_dealloc_with_status)
{
/* Do not deallocate the components of ultimate pointer
*************** structure_alloc_comps (gfc_symbol * der_
*** 8386,8393 ****
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)
{
rank = c->as ? c->as->rank : 0;
tmp = fold_convert (TREE_TYPE (dcmp), comp);
--- 8467,8474 ----
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
! && !(c->ts.type == BT_DERIVED && der_type == c->ts.u.derived))
{
rank = c->as ? c->as->rank : 0;
tmp = fold_convert (TREE_TYPE (dcmp), comp);
*************** structure_alloc_comps (gfc_symbol * der_
*** 8421,8426 ****
--- 8502,8508 ----
gfc_add_expr_to_block (&fnblock, tmp);
}
else if (c->attr.allocatable && !c->attr.proc_pointer
+ && !(c->ts.type == BT_DERIVED && der_type == c->ts.u.derived)
&& (!(cmp_has_alloc_comps && c->as)
|| c->attr.codimension))
{
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 241472)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_get_ultimate_alloc_ptr_comps_caf_tok
*** 158,163 ****
--- 158,164 ----
#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 (extends, VTABLE_EXTE
*** 300,305 ****
--- 301,307 ----
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
Index: gcc/fortran/trans-types.c
===================================================================
*** gcc/fortran/trans-types.c (revision 241467)
--- gcc/fortran/trans-types.c (working copy)
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 2524,2530 ****
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)
break;
else if (c->next == NULL)
return derived->backend_decl;
--- 2524,2532 ----
non-procedure pointer components have no backend_decl. */
for (c = derived->components; c; c = c->next)
{
! if (!c->attr.proc_pointer
! && !(c->attr.allocatable && (derived == c->ts.u.derived))
! && c->backend_decl == NULL)
break;
else if (c->next == NULL)
return derived->backend_decl;
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 2562,2568 ****
if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
continue;
! if ((!c->attr.pointer && !c->attr.proc_pointer)
|| c->ts.u.derived->backend_decl == NULL)
c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived,
in_coarray
--- 2564,2571 ----
if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
continue;
! if ((!c->attr.pointer && !c->attr.proc_pointer
! && !(c->attr.allocatable && (derived == c->ts.u.derived)))
|| c->ts.u.derived->backend_decl == NULL)
c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived,
in_coarray
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 2656,2662 ****
&& !(unlimited_entity && c == derived->components))
field_type = build_pointer_type (field_type);
! if (c->attr.pointer)
field_type = gfc_nonrestricted_type (field_type);
/* vtype fields can point to different types to the base type. */
--- 2659,2665 ----
&& !(unlimited_entity && c == derived->components))
field_type = build_pointer_type (field_type);
! if (c->attr.pointer || (c->attr.allocatable && (derived ==
c->ts.u.derived)))
field_type = gfc_nonrestricted_type (field_type);
/* vtype fields can point to different types to the base type. */
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h (revision 241467)
--- gcc/fortran/trans.h (working copy)
*************** tree gfc_vptr_extends_get (tree);
*** 403,408 ****
--- 403,409 ----
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);
Index: gcc/testsuite/gfortran.dg/class_2.f03
===================================================================
*** gcc/testsuite/gfortran.dg/class_2.f03 (revision 241467)
--- gcc/testsuite/gfortran.dg/class_2.f03 (working copy)
***************
*** 1,4 ****
--- 1,5 ----
! { dg-do compile }
+ ! { dg-options "-std=f2003" }
!
! PR 40940: CLASS statement
!
Index: gcc/testsuite/gfortran.dg/finalize_21.f90
===================================================================
*** gcc/testsuite/gfortran.dg/finalize_21.f90 (revision 241467)
--- gcc/testsuite/gfortran.dg/finalize_21.f90 (working copy)
***************
*** 8,11 ****
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" } }
--- 8,11 ----
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,
._deallocate=0B};" "original" } }
Index: gcc/testsuite/gfortran.dg/recursive_alloc_comp_1.f08
===================================================================
*** gcc/testsuite/gfortran.dg/recursive_alloc_comp_1.f08 (revision 0)
--- gcc/testsuite/gfortran.dg/recursive_alloc_comp_1.f08 (working copy)
***************
*** 0 ****
--- 1,70 ----
+ ! { 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
Index: gcc/testsuite/gfortran.dg/recursive_alloc_comp_2.f08
===================================================================
*** gcc/testsuite/gfortran.dg/recursive_alloc_comp_2.f08 (revision 0)
--- gcc/testsuite/gfortran.dg/recursive_alloc_comp_2.f08 (working copy)
***************
*** 0 ****
--- 1,65 ----
+ ! { 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
Index: gcc/testsuite/gfortran.dg/recursive_alloc_comp_3.f08
===================================================================
*** gcc/testsuite/gfortran.dg/recursive_alloc_comp_3.f08 (revision 0)
--- gcc/testsuite/gfortran.dg/recursive_alloc_comp_3.f08 (working copy)
***************
*** 0 ****
--- 1,59 ----
+ ! { dg-do run }
+ !
+ ! Tests functionality of recursive allocatable derived types.
+ !
+ module m
+ type :: stack
+ real :: 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.0)
+ call poke (2.0)
+ call poke (3.0)
+ call output (top)
+ call pop
+ 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)
+ real :: 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
Index: gcc/testsuite/gfortran.dg/recursive_alloc_comp_4.f08
===================================================================
*** gcc/testsuite/gfortran.dg/recursive_alloc_comp_4.f08 (revision 0)
--- gcc/testsuite/gfortran.dg/recursive_alloc_comp_4.f08 (working copy)
***************
*** 0 ****
--- 1,46 ----
+ ! { 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
