From: Paul Thomas Date: Tue, 25 Oct 2016 20:37:05 +0000 (+0000) Subject: re PR fortran/45516 ([F08] allocatable compontents of recursive type) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=bf9f15ee55f5b291f7d3c0dfa4192e9e5924a2a5;p=gcc.git re PR fortran/45516 ([F08] allocatable compontents of recursive type) 2016-10-25 Paul Thomas 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 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 --- diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index be1ddf85c9f..400c22abaf5 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -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 (); diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 6c9d0570df7..f18eb41bc50 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -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); diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index b3acf1d5d73..ed639a7a7e4 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -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; } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 8cee007af17..785203b4dc2 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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. */ diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index de21cc0d1a7..74935b181f6 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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) diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index e57d3b9faf6..689ea7e4ef3 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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 diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 05122d90616..eda0351119a 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -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. */ diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index f76fff81a92..4306200eb03 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -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); diff --git a/gcc/testsuite/gfortran.dg/class_2.f03 b/gcc/testsuite/gfortran.dg/class_2.f03 index 3a75d55682c..58b0b4ad572 100644 --- a/gcc/testsuite/gfortran.dg/class_2.f03 +++ b/gcc/testsuite/gfortran.dg/class_2.f03 @@ -1,4 +1,5 @@ ! { dg-do compile } +! { dg-options "-std=f2003" } ! ! PR 40940: CLASS statement ! diff --git a/gcc/testsuite/gfortran.dg/finalize_21.f90 b/gcc/testsuite/gfortran.dg/finalize_21.f90 index 6df1f31b10f..5a8fec3d139 100644 --- a/gcc/testsuite/gfortran.dg/finalize_21.f90 +++ b/gcc/testsuite/gfortran.dg/finalize_21.f90 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/recursive_alloc_comp_1.f08 b/gcc/testsuite/gfortran.dg/recursive_alloc_comp_1.f08 new file mode 100644 index 00000000000..383eff49106 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/recursive_alloc_comp_1.f08 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/recursive_alloc_comp_2.f08 b/gcc/testsuite/gfortran.dg/recursive_alloc_comp_2.f08 new file mode 100644 index 00000000000..85ab14b9a48 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/recursive_alloc_comp_2.f08 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/recursive_alloc_comp_3.f08 b/gcc/testsuite/gfortran.dg/recursive_alloc_comp_3.f08 new file mode 100644 index 00000000000..d7f8f6622be --- /dev/null +++ b/gcc/testsuite/gfortran.dg/recursive_alloc_comp_3.f08 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/recursive_alloc_comp_4.f08 b/gcc/testsuite/gfortran.dg/recursive_alloc_comp_4.f08 new file mode 100644 index 00000000000..75fd8b0d368 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/recursive_alloc_comp_4.f08 @@ -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