Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 183364)
--- gcc/fortran/trans-array.c	(working copy)
*************** static tree
*** 4719,4725 ****
  gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
  		     gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
  		     stmtblock_t * descriptor_block, tree * overflow,
! 		     gfc_expr *expr3)
  {
    tree type;
    tree tmp;
--- 4719,4725 ----
  gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
  		     gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
  		     stmtblock_t * descriptor_block, tree * overflow,
! 		     tree expr3_elem_size, tree *nelems, gfc_expr *expr3)
  {
    tree type;
    tree tmp;
*************** gfc_array_init_size (tree descriptor, in
*** 4876,4882 ****
    /* The stride is the number of elements in the array, so multiply by the
       size of an element to get the total size.  Obviously, if there ia a
       SOURCE expression (expr3) we must use its element size.  */
!   if (expr3 != NULL)
      {
        if (expr3->ts.type == BT_CLASS)
  	{
--- 4876,4884 ----
    /* The stride is the number of elements in the array, so multiply by the
       size of an element to get the total size.  Obviously, if there ia a
       SOURCE expression (expr3) we must use its element size.  */
!   if (expr3_elem_size != NULL_TREE)
!     tmp = expr3_elem_size;
!   else if (expr3 != NULL)
      {
        if (expr3->ts.type == BT_CLASS)
  	{
*************** gfc_array_init_size (tree descriptor, in
*** 4904,4909 ****
--- 4906,4912 ----
    if (rank == 0)
      return element_size;
  
+   *nelems = gfc_evaluate_now (stride, pblock);
    stride = fold_convert (size_type_node, stride);
  
    /* First check for overflow. Since an array of type character can
*************** gfc_array_init_size (tree descriptor, in
*** 4962,4968 ****
  
  bool
  gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
! 		    tree errlen, tree label_finish, gfc_expr *expr3)
  {
    tree tmp;
    tree pointer;
--- 4965,4972 ----
  
  bool
  gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
! 		    tree errlen, tree label_finish, tree expr3_elem_size,
! 		    tree *nelems, gfc_expr *expr3)
  {
    tree tmp;
    tree pointer;
*************** gfc_array_allocate (gfc_se * se, gfc_exp
*** 5047,5053 ****
    size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
  			      ref->u.ar.as->corank, &offset, lower, upper,
  			      &se->pre, &set_descriptor_block, &overflow,
! 			      expr3);
  
    if (dimension)
      {
--- 5051,5057 ----
    size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
  			      ref->u.ar.as->corank, &offset, lower, upper,
  			      &se->pre, &set_descriptor_block, &overflow,
! 			      expr3_elem_size, nelems, expr3);
  
    if (dimension)
      {
*************** gfc_array_allocate (gfc_se * se, gfc_exp
*** 5078,5083 ****
--- 5082,5090 ----
    gfc_start_block (&elseblock);
  
    /* Allocate memory to store the data.  */
+   if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
+     se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
+ 
    pointer = gfc_conv_descriptor_data_get (se->expr);
    STRIP_NOPS (pointer);
  
*************** gfc_array_allocate (gfc_se * se, gfc_exp
*** 5104,5110 ****
  
    gfc_add_expr_to_block (&se->pre, tmp);
  
!   if (expr->ts.type == BT_CLASS && expr3)
      {
        tmp = build_int_cst (unsigned_char_type_node, 0);
        /* With class objects, it is best to play safe and null the 
--- 5111,5118 ----
  
    gfc_add_expr_to_block (&se->pre, tmp);
  
!   if (expr->ts.type == BT_CLASS
! 	&& (expr3_elem_size != NULL_TREE || expr3))
      {
        tmp = build_int_cst (unsigned_char_type_node, 0);
        /* With class objects, it is best to play safe and null the 
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 183364)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_conv_derived_to_class (gfc_se *parms
*** 215,221 ****
     OOP-TODO: This could be improved by adding code that branched on
     the dynamic type being the same as the declared type. In this case
     the original class expression can be passed directly.  */ 
! static void
  gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
  			 gfc_typespec class_ts, bool elemental)
  {
--- 215,221 ----
     OOP-TODO: This could be improved by adding code that branched on
     the dynamic type being the same as the declared type. In this case
     the original class expression can be passed directly.  */ 
! void
  gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
  			 gfc_typespec class_ts, bool elemental)
  {
Index: gcc/fortran/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h	(revision 183364)
--- gcc/fortran/trans-array.h	(working copy)
*************** tree gfc_array_deallocate (tree, tree, t
*** 25,31 ****
  /* Generate code to initialize and allocate an array.  Statements are added to
     se, which should contain an expression for the array descriptor.  */
  bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
! 			 gfc_expr *);
  
  /* Allow the bounds of a loop to be set from a callee's array spec.  */
  void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
--- 25,31 ----
  /* Generate code to initialize and allocate an array.  Statements are added to
     se, which should contain an expression for the array descriptor.  */
  bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
! 			 tree, tree *, gfc_expr *);
  
  /* Allow the bounds of a loop to be set from a callee's array spec.  */
  void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 183364)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** gfc_trans_exit (gfc_code * code)
*** 4717,4722 ****
--- 4717,4816 ----
  }
  
  
+ 
+ /* Given a class array declaration and an index, returns the address
+    of the referenced element.  */
+ 
+ static tree
+ get_class_array_ref (tree index, tree class_decl)
+ {
+   tree data = gfc_class_data_get (class_decl);
+   tree size = gfc_vtable_size_get (class_decl);
+   tree offset = fold_build2_loc (input_location, MULT_EXPR,
+ 				 gfc_array_index_type,
+ 				 index, size);
+   tree ptr;
+   data = gfc_conv_descriptor_data_get (data);
+   ptr = fold_convert (pvoid_type_node, data);
+   ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
+   return fold_convert (TREE_TYPE (data), ptr);
+ }
+ 
+ 
+ /* Copies one class expression to another, assuming that if either
+    'to' or 'from' are arrays they are packed.  */
+ static tree
+ gfc_copy_class_to_class (tree from, tree to, tree nelems)
+ {
+   tree fcn;
+   tree fcn_type;
+   tree from_data;
+   tree to_data;
+   tree to_ref;
+   tree from_ref;
+   VEC(tree,gc) *args;
+   tree tmp;
+   tree index;
+   stmtblock_t loopbody;
+   stmtblock_t body;
+   gfc_loopinfo loop;
+ 
+   args = NULL;
+ 
+   fcn = gfc_vtable_copy_get (from);
+   fcn_type = TREE_TYPE (TREE_TYPE (fcn));
+ 
+   from_data = gfc_class_data_get (from);
+   to_data = gfc_class_data_get (to);
+ 
+   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
+     {
+       gfc_init_block (&body);
+       tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ 			     gfc_array_index_type, nelems,
+ 			     gfc_index_one_node);
+       nelems = gfc_evaluate_now (tmp, &body);
+       index = gfc_create_var (gfc_array_index_type, "S");
+ 
+       if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)))
+ 	{
+ 	  from_ref = get_class_array_ref (index, from);
+ 	  VEC_safe_push (tree, gc, args, from_ref);
+ 	}
+       else
+         VEC_safe_push (tree, gc, args, from_data);
+ 
+       to_ref = get_class_array_ref (index, to);
+       VEC_safe_push (tree, gc, args, to_ref);
+ 
+       tmp = build_call_vec (fcn_type, fcn, args);
+ 
+       /* Build the body of the loop.  */
+       gfc_init_block (&loopbody);
+       gfc_add_expr_to_block (&loopbody, tmp);
+ 
+       /* Build the loop and return.  */
+       gfc_init_loopinfo (&loop);
+       loop.dimen = 1;
+       loop.from[0] = gfc_index_zero_node;
+       loop.loopvar[0] = index;
+       loop.to[0] = nelems;
+       gfc_trans_scalarizing_loops (&loop, &loopbody);
+       gfc_add_block_to_block (&body, &loop.pre);
+       tmp = gfc_finish_block (&body);
+     }
+   else
+     {
+       gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)));
+       VEC_safe_push (tree, gc, args, from_data);
+       VEC_safe_push (tree, gc, args, to_data);
+       tmp = build_call_vec (fcn_type, fcn, args);
+     }
+ 
+   return tmp;
+ }
+ 
+ 
  /* Translate the ALLOCATE statement.  */
  
  tree
*************** gfc_trans_allocate (gfc_code * code)
*** 4740,4745 ****
--- 4834,4841 ----
    stmtblock_t post;
    gfc_expr *sz;
    gfc_se se_sz;
+   tree class_expr;
+   tree nelems;
  
    if (!code->ext.alloc.list)
      return NULL_TREE;
*************** gfc_trans_allocate (gfc_code * code)
*** 4793,4806 ****
        se.want_pointer = 1;
        se.descriptor_only = 1;
        gfc_conv_expr (&se, expr);
  
        if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
! 			       code->expr3))
  	{
  	  /* A scalar or derived type.  */
  
  	  /* Determine allocate size.  */
! 	  if (al->expr->ts.type == BT_CLASS && code->expr3)
  	    {
  	      if (code->expr3->ts.type == BT_CLASS)
  		{
--- 4889,4929 ----
        se.want_pointer = 1;
        se.descriptor_only = 1;
        gfc_conv_expr (&se, expr);
+       class_expr = NULL_TREE;
+ 
+       if (al->expr->ts.type == BT_CLASS
+ 	    && code->expr3
+ 	    && code->expr3->ts.type == BT_CLASS
+ 	    && code->expr3->expr_type != EXPR_VARIABLE)
+ 	{
+ 	  gfc_init_se (&se_sz, NULL);
+ 	  gfc_conv_expr_reference (&se_sz, code->expr3);
+ 	  gfc_conv_class_to_class (&se_sz, code->expr3,
+ 				   code->expr3->ts, false);
+ 	  gfc_add_block_to_block (&se.pre, &se_sz.pre);
+ 	  gfc_add_block_to_block (&se.post, &se_sz.post);
+ 	  class_expr = build_fold_indirect_ref_loc (input_location,
+ 						    se_sz.expr);
+ 	  class_expr = gfc_evaluate_now (class_expr, &se.pre);
+ 	  memsz = gfc_vtable_size_get (class_expr);
+ 	  /* This is the safest way of converting to a compatible
+ 	     type for use in the allocation.  */
+ 	  tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_index_zero_node));
+ 	  memsz = fold_convert (TREE_TYPE (tmp), memsz);
+ 	}
+       else
+ 	memsz = NULL_TREE;
  
+       nelems = NULL_TREE;
        if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
! 			       memsz, &nelems, code->expr3))
  	{
  	  /* A scalar or derived type.  */
  
  	  /* Determine allocate size.  */
! 	  if (al->expr->ts.type == BT_CLASS
! 		&& code->expr3
! 		&& memsz == NULL_TREE)
  	    {
  	      if (code->expr3->ts.type == BT_CLASS)
  		{
*************** gfc_trans_allocate (gfc_code * code)
*** 4956,4968 ****
        e = gfc_copy_expr (al->expr);
        if (e->ts.type == BT_CLASS)
  	{
! 	  gfc_expr *lhs,*rhs;
  	  gfc_se lse;
  
  	  lhs = gfc_expr_to_initialize (e);
  	  gfc_add_vptr_component (lhs);
! 	  rhs = NULL;
! 	  if (code->expr3 && code->expr3->ts.type == BT_CLASS)
  	    {
  	      /* Polymorphic SOURCE: VPTR must be determined at run time.  */
  	      rhs = gfc_copy_expr (code->expr3);
--- 5079,5101 ----
        e = gfc_copy_expr (al->expr);
        if (e->ts.type == BT_CLASS)
  	{
! 	  gfc_expr *lhs, *rhs;
  	  gfc_se lse;
  
  	  lhs = gfc_expr_to_initialize (e);
  	  gfc_add_vptr_component (lhs);
! 
! 	  if (class_expr != NULL_TREE)
! 	    {
! 	      /* Polymorphic SOURCE: VPTR must be determined at run time.  */
! 	      gfc_init_se (&lse, NULL);
! 	      lse.want_pointer = 1;
! 	      gfc_conv_expr (&lse, lhs);
! 	      tmp = gfc_class_vptr_get (class_expr);
! 	      gfc_add_modify (&block, lse.expr,
! 			fold_convert (TREE_TYPE (lse.expr), tmp));
! 	    }
! 	  else if (code->expr3 && code->expr3->ts.type == BT_CLASS)
  	    {
  	      /* Polymorphic SOURCE: VPTR must be determined at run time.  */
  	      rhs = gfc_copy_expr (code->expr3);
*************** gfc_trans_allocate (gfc_code * code)
*** 5011,5017 ****
  	  /* Initialization via SOURCE block
  	     (or static default initializer).  */
  	  gfc_expr *rhs = gfc_copy_expr (code->expr3);
! 	  if (al->expr->ts.type == BT_CLASS)
  	    {
  	      gfc_actual_arglist *actual;
  	      gfc_expr *ppc;
--- 5144,5157 ----
  	  /* Initialization via SOURCE block
  	     (or static default initializer).  */
  	  gfc_expr *rhs = gfc_copy_expr (code->expr3);
! 	  if (class_expr != NULL_TREE)
! 	    {
! 	      tree to;
! 	      to = TREE_OPERAND (se.expr, 0);
! 
! 	      tmp = gfc_copy_class_to_class (class_expr, to, nelems);
! 	    }
! 	  else if (al->expr->ts.type == BT_CLASS)
  	    {
  	      gfc_actual_arglist *actual;
  	      gfc_expr *ppc;
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h	(revision 183364)
--- gcc/fortran/trans.h	(working copy)
*************** tree gfc_vtable_size_get (tree);
*** 346,352 ****
  tree gfc_vtable_extends_get (tree);
  tree gfc_vtable_def_init_get (tree);
  tree gfc_vtable_copy_get (tree);
! 
  /* Initialize an init/cleanup block.  */
  void gfc_start_wrapped_block (gfc_wrapped_block* block, tree code);
  /* Add a pair of init/cleanup code to the block.  Each one might be a
--- 346,352 ----
  tree gfc_vtable_extends_get (tree);
  tree gfc_vtable_def_init_get (tree);
  tree gfc_vtable_copy_get (tree);
! void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool);
  /* Initialize an init/cleanup block.  */
  void gfc_start_wrapped_block (gfc_wrapped_block* block, tree code);
  /* Add a pair of init/cleanup code to the block.  Each one might be a
Index: gcc/testsuite/gfortran.dg/class_allocate_7.f03
===================================================================
*** gcc/testsuite/gfortran.dg/class_allocate_7.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/class_allocate_7.f03	(revision 0)
***************
*** 0 ****
--- 1,34 ----
+ ! { dg-do run }
+ ! PR51870 - ALLOCATE with class function expression for SOURCE failed.
+ ! This is the original test in the PR.
+ !
+ ! Reported by Tobias Burnus  <burnus@gcc.gnu.org>
+ !
+ module show_producer_class
+   implicit none
+   type integrand
+     integer :: variable = -1
+   end type integrand
+ 
+   type show_producer
+   contains
+     procedure ,nopass :: create_show
+   end type
+ contains
+   function create_show () result(new_integrand)
+     class(integrand) ,allocatable :: new_integrand
+     allocate(new_integrand)
+     new_integrand%variable = 99
+   end function
+ end module
+ 
+ program main
+   use show_producer_class
+   implicit none
+   class(integrand) ,allocatable :: kernel
+   type(show_producer) :: executive_producer
+ 
+   allocate(kernel,source=executive_producer%create_show ())
+   if (kernel%variable .ne. 99) call abort
+ end program
+ ! { dg-final { cleanup-modules "show_producer_class" } }
Index: gcc/testsuite/gfortran.dg/class_allocate_8.f03
===================================================================
*** gcc/testsuite/gfortran.dg/class_allocate_8.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/class_allocate_8.f03	(revision 0)
***************
*** 0 ****
--- 1,52 ----
+ ! { dg-do run }
+ ! PR51870 - ALLOCATE with class function expression for SOURCE failed.
+ ! This version of the test allocates class arrays.
+ !
+ ! Reported by Tobias Burnus  <burnus@gcc.gnu.org>
+ !
+ module show_producer_class
+   implicit none
+   type integrand
+     integer :: variable = 0
+   end type integrand
+ 
+   type show_producer
+   contains
+     procedure ,nopass :: create_show
+     procedure ,nopass :: create_show_array
+   end type
+ contains
+   function create_show () result(new_integrand)
+     class(integrand) ,allocatable :: new_integrand
+     allocate(new_integrand)
+     new_integrand%variable = -1
+   end function
+   function create_show_array (n) result(new_integrand)
+     class(integrand) ,allocatable :: new_integrand(:)
+     integer :: n, i
+     allocate(new_integrand(n))
+     select type (new_integrand)
+       type is (integrand); new_integrand%variable = [(i, i= 1, n)]
+     end select
+   end function
+ end module
+ 
+ program main
+   use show_producer_class
+   implicit none
+   class(integrand) ,allocatable :: kernel(:)
+   type(show_producer) :: executive_producer
+ 
+   allocate(kernel(5),source=executive_producer%create_show_array (5))
+   select type(kernel)
+     type is (integrand);  if (any (kernel%variable .ne. [1,2,3,4,5])) call abort
+   end select
+ 
+   deallocate (kernel)
+ 
+   allocate(kernel(3),source=executive_producer%create_show ())
+   select type(kernel)
+     type is (integrand); if (any (kernel%variable .ne. -1)) call abort
+   end select
+ end program
+ ! { dg-final { cleanup-modules "show_producer_class" } }
