procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/45516 ([F08] allocatable compontents of recursive type)

Browse source 
2016-10-25  Paul Thomas  <pault@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-25  Paul Thomas  <pault@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.

From-SVN: r241539
This commit is contained in:
Paul Thomas 2016-10-25 20:37:05 +00:00
parent 7c7dae6542
commit bf9f15ee55
14 changed files with 464 additions and 18 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

81
gcc/fortran/class.c
View file

@ -1347,6 +1347,8 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
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. */
@ -2191,6 +2193,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
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)
@ -2255,6 +2258,20 @@ gfc_find_derived_vtab (gfc_symbol *derived)
{
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,
@ -2427,6 +2444,66 @@ gfc_find_derived_vtab (gfc_symbol *derived)
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);
@ -2456,6 +2533,10 @@ cleanup:
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 ();

13
gcc/fortran/decl.c
View file

@ -1858,9 +1858,18 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
&& 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)
{
@ -4844,6 +4853,10 @@ gfc_match_data_decl (void)
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);

15
gcc/fortran/expr.c
View file

@ -3249,7 +3249,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform,
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
@ -3378,7 +3378,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
}
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;
@ -4144,6 +4144,7 @@ gfc_has_default_initializer (gfc_symbol *der)
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)
@ -4196,7 +4197,7 @@ gfc_default_initializer (gfc_typespec *ts)
}
/* 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. */
@ -5318,13 +5319,13 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
{
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;
@ -5332,7 +5333,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
{
if (n->iterator != NULL)
continue;
en = n->expr;
if (gfc_dep_compare_expr (ec, en) == 0)
{
@ -5349,6 +5350,6 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
}
}
}
return true;
}

7
gcc/fortran/resolve.c
View file

@ -13598,6 +13598,13 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
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. */

102
gcc/fortran/trans-array.c
View file

@ -8004,7 +8004,9 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
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);
@ -8109,6 +8111,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
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);
@ -8140,7 +8144,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
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,
@ -8148,7 +8153,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
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)
@ -8165,6 +8170,89 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
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))
@ -8227,6 +8315,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
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
@ -8414,8 +8503,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
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);
@ -8448,9 +8537,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
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)

2
gcc/fortran/trans-expr.c
View file

@ -158,6 +158,7 @@ gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
#define VTABLE_DEF_INIT_FIELD 3
#define VTABLE_COPY_FIELD 4
#define VTABLE_FINAL_FIELD 5
#define VTABLE_DEALLOCATE_FIELD 6
tree
@ -300,6 +301,7 @@ VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
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

16
gcc/fortran/trans-types.c
View file

@ -2524,7 +2524,11 @@ gfc_get_derived_type (gfc_symbol * derived, bool in_coarray)
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;
@ -2556,13 +2560,17 @@ gfc_get_derived_type (gfc_symbol * derived, bool in_coarray)
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
@ -2596,6 +2604,8 @@ gfc_get_derived_type (gfc_symbol * derived, bool 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. */
@ -2656,7 +2666,7 @@ gfc_get_derived_type (gfc_symbol * derived, bool in_coarray)
&& !(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. */

1
gcc/fortran/trans.h
View file

@ -403,6 +403,7 @@ tree gfc_vptr_extends_get (tree);
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);

1
gcc/testsuite/gfortran.dg/class_2.f03
View file

@ -1,4 +1,5 @@
! { dg-do compile }
! { dg-options "-std=f2003" }
!
! PR 40940: CLASS statement
!

2
gcc/testsuite/gfortran.dg/finalize_21.f90
View file

@ -8,4 +8,4 @@
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" } }

70
gcc/testsuite/gfortran.dg/recursive_alloc_comp_1.f08 Normal file
View file

@ -0,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

65
gcc/testsuite/gfortran.dg/recursive_alloc_comp_2.f08 Normal file
View file

@ -0,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

61
gcc/testsuite/gfortran.dg/recursive_alloc_comp_3.f08 Normal file
View file

@ -0,0 +1,61 @@
! { 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

46
gcc/testsuite/gfortran.dg/recursive_alloc_comp_4.f08 Normal file
View file

@ -0,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