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

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

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 ();

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);
 

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;
 }

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.  */

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)

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

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.  */

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);

gcc/testsuite/gfortran.dg/class_2.f03

 ! { dg-do compile }
+! { dg-options "-std=f2003" }
 !
 ! PR 40940: CLASS statement
 !

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" } }

gcc/testsuite/gfortran.dg/recursive_alloc_comp_1.f08

+! { 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

gcc/testsuite/gfortran.dg/recursive_alloc_comp_2.f08

+! { 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

gcc/testsuite/gfortran.dg/recursive_alloc_comp_3.f08

+! { 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

gcc/testsuite/gfortran.dg/recursive_alloc_comp_4.f08

+! { 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