[Patch, fortran] PR51870 - [OOP] ICE with ALLOCATE and SOURCE-expr function returning BT_CLASS

[Patch, fortran] PR51870 - [OOP] ICE with ALLOCATE and SOURCE-expr function returning BT_CLASS

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 2122 bytes --]

Dear All,

The attached is quite straightforward - for non-variable class STATUS
expressions, the class object is extracted, together with the element
size for the dynamic type.  These are then used for the allocation and
the copy of the source data into the allocated object.

Note that I have begged off including variables in this process, given
the stage that we are at with 4.7.0.  This means that the patch only
affects the part that was broken.  Early in 4.8.0, gfc_trans_allocate
will have to undergo a massive clean up. Too many people, myself
included, have left their fingerprints on it :-)

I realized at the last moment that get_class_array_ref and
gfc_copy_class_to_class should be moved to trans-expr.c.  The former
should also be called from trans.c(gfc_build_array_ref) and the
repeated code removed form there.  I will do this before commiting.

Bootstrapped and regtested on FC9/x86_64 - OK for trunk?

Cheers

Paul

 2012-01-22  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/51870
	* trans-array.c (gfc_array_init_size): Add two extra arguments
	to convey the dynamic element size of a calls object and to
	return the number of elements that have been allocated.
	(gfc_array_allocate): Add the same arguments and use them to
	call gfc_array_init_size.  Before the allocation dereference
	the data pointer, if necessary. Set the allocated array to zero
	if the class element size or expr3 are non-null.
	* trans-expr.c (gfc_conv_class_to_class): Give this function
	global scope.
	* trans-array.h : Update prototype for gfc_array_allocate.
	* trans-stmt.c (get_class_array_ref): New function.
	(gfc_copy_class_to_class): New function.
	(gfc_trans_allocate): For non-variable class STATUS expressions
	extract the class object and the dynamic element size. Use the
	latter to call gfc_array_allocate and the former for setting
	the vptr and, via gfc_copy_class_to_class, to copy to the
	allocated data.
	* trans.h : Prototype for gfc_conv_class_to_class.

2012-01-22  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/51870
	* gfortran.dg/class_allocate_7.f03: New.
	* gfortran.dg/class_allocate_8.f03: New.

[-- Attachment #2: copy.diff --]
[-- Type: text/x-patch, Size: 17254 bytes --]

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

Re: [Patch, fortran] PR51870 - [OOP] ICE with ALLOCATE and SOURCE-expr function returning BT_CLASS

[Tobias Burnus]

Dear Paul,

Paul Richard Thomas wrote:
> The attached is quite straightforward - for non-variable class STATUS
> expressions,

I believe that you mean source-expr (i.e. SOURCE= and MOLD=) and not STATUS.


> Note that I have begged off including variables in this process, given
> the stage that we are at with 4.7.0.

That's appreciated. I think that 4.7 will be released relatively 
soonish, given that there are just 83 serious regressions (9 P1, 66 P2, 
8 P3; 63 P4, 56 P4). The plan was to release around mid-March to 
beginning of April. Given the low number of regressions, it might be 
slightly earlier, though not much as the release managers want to give 
users some time to find more regressions.

> This means that the patch only affects the part that was broken.  Early in 4.8.0, gfc_trans_allocate will have to undergo a massive clean up.

Clean-ups are also appreciated ;-)

  * * *

I somehow liked your draft patch more:

* The big program which I reduced to the test case in PR 51870 fails 
with the current patch - only the reduced test case of the PR works. The 
failure of the bigger program is - at runt time - a SIGABRT at
#6  0x409175 in __show_class_MOD___copy_show_class_Show

* It also fixed PR 48705. Your current patch fixes the reduced test case 
(comment 1) of that PR, but no longer the original version, which fails 
at the end of the program ("end program" line) at run time (SIGABRT). 
Valgrind shows:
  Invalid write of size 8
     at 0x4009B3: __generic_deferred_MOD___copy_generic_deferred_Vec (in 
/dev/shm/a.out)

(I assume both programs have the same issue.)

Thus, I would prefer if you could have a look at the latter PR.

>   2012-01-22  Paul Thomas<pault@gcc.gnu.org>
> 	PR fortran/51870

Could you also add PR fortran/51943 and PR 51946? (I think those are 
effectively the same examples. Also the full example 
ssdSource/chapter08/puppeteer_f2003 works for me.)


+         /* 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);

How about:
+         memsz = fold_convert (size_type_node, memsz);


           /* Determine allocate size.  */
-         if (al->expr->ts.type == BT_CLASS && code->expr3)
+         if (al->expr->ts.type == BT_CLASS
+ && code->expr3
+ && memsz == NULL_TREE)
             {

Indentation looks wrong.


    for (al = code->ext.alloc.list; al != NULL; al = al->next)
      {
...
+         class_expr = build_fold_indirect_ref_loc (input_location,
+                                                   se_sz.expr);
+         class_expr = gfc_evaluate_now (class_expr, &se.pre);

I have the feeling that you evaluate the function multiple times. 
Actually, for*

allocate(kernel, kernel2, mold=executive_producer%create_show() )

I find:

         D.1890 = create_show ();
         (struct __vtype_show_producer_class_Integrand *) kernel._vptr = 
(struct __vtype_show_producer_class_Integrand *) D.1890._vptr;
         (void) __builtin_memcpy ((void *) kernel._data, (void *) 
&create_show (), 4);

         D.1892 = create_show ();
         (struct __vtype_show_producer_class_Integrand *) kernel2._vptr 
= (struct __vtype_show_producer_class_Integrand *) D.1892._vptr;
         (void) __builtin_memcpy ((void *) kernel2._data, (void *) 
&create_show (), 4);

Thus, one evaluates the function 4 times instead of only once. 
Additionally, MOLD= does not invoke the default initializer (as expected 
for MOLD=) but memcopy (as expected for SOURCE=).

The memcpy is also wrong. If CLASS(integrand) (of create_show) returned 
a derived type with allocatable components, one had to to a deep copy. 
As this is not known at compile time, a call to vtab->__copy is required.

And a last issue: If one changes in
    type(show_producer), allocatable :: executive_producer
the TYPE to CLASS one gets still an ICE in conv_function_val.

Tobias

* Ditto for SOURCE=, though there one runs into PR51953 as F2003 only 
allowed one allocate-object.

Re: [Patch, fortran] PR51870 - [OOP] ICE with ALLOCATE and SOURCE-expr function returning BT_CLASS

[Paul Richard Thomas]

Dear Tobias,


>
> I believe that you mean source-expr (i.e. SOURCE= and MOLD=) and not STATUS.

It was late when I wrote the mail :-)


> I somehow liked your draft patch more:

It caused regressions, though!

>
> * The big program which I reduced to the test case in PR 51870 fails with
> the current patch - only the reduced test case of the PR works. The failure
> of the bigger program is - at runt time - a SIGABRT at
> #6  0x409175 in __show_class_MOD___copy_show_class_Show
>
> * It also fixed PR 48705. Your current patch fixes the reduced test case
> (comment 1) of that PR, but no longer the original version, which fails at
> the end of the program ("end program" line) at run time (SIGABRT). Valgrind
> shows:
>  Invalid write of size 8
>    at 0x4009B3: __generic_deferred_MOD___copy_generic_deferred_Vec (in
> /dev/shm/a.out)
>
> (I assume both programs have the same issue.)
>
> Thus, I would prefer if you could have a look at the latter PR.

Hah! OK

>
>
>>  2012-01-22  Paul Thomas<pault@gcc.gnu.org>
>>        PR fortran/51870
>
>
> Could you also add PR fortran/51943 and PR 51946? (I think those are
> effectively the same examples. Also the full example
> ssdSource/chapter08/puppeteer_f2003 works for me.)

I am happy to comply with that one !

>
>
> +         /* 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);
>
> How about:
> +         memsz = fold_convert (size_type_node, memsz);

No - it does not work.  It was the first thing that I tried. The
actual representation is character (kind=4), I think, and this cuased
fold_convert to barf.  I chose to go the route above since it is
always going to be correct for any platform.  In fact, tmp =
TYPE_SIZE_UNIT (gfc_array_index_type); would have been still neater.
If trans-types.c generates an appropriate type, I would be curious to
know which it is, since I have encountered this wrinkle before.

>
>
>          /* Determine allocate size.  */
> -         if (al->expr->ts.type == BT_CLASS && code->expr3)
> +         if (al->expr->ts.type == BT_CLASS
> + && code->expr3
> + && memsz == NULL_TREE)
>            {
>
> Indentation looks wrong.

I'll take a look.

>
>
>   for (al = code->ext.alloc.list; al != NULL; al = al->next)
>     {
> ...
> +         class_expr = build_fold_indirect_ref_loc (input_location,
> +                                                   se_sz.expr);
> +         class_expr = gfc_evaluate_now (class_expr, &se.pre);
>
> I have the feeling that you evaluate the function multiple times. Actually,
> for*

Not for SOURCE=.... in this case, the allocate list is only allowed one member.

>
> allocate(kernel, kernel2, mold=executive_producer%create_show() )
>
> I find:
>
>        D.1890 = create_show ();
>        (struct __vtype_show_producer_class_Integrand *) kernel._vptr =
> (struct __vtype_show_producer_class_Integrand *) D.1890._vptr;
>        (void) __builtin_memcpy ((void *) kernel._data, (void *) &create_show
> (), 4);
>
>        D.1892 = create_show ();
>        (struct __vtype_show_producer_class_Integrand *) kernel2._vptr =
> (struct __vtype_show_producer_class_Integrand *) D.1892._vptr;
>        (void) __builtin_memcpy ((void *) kernel2._data, (void *)
> &create_show (), 4);
>
> Thus, one evaluates the function 4 times instead of only once. Additionally,
> MOLD= does not invoke the default initializer (as expected for MOLD=) but
> memcopy (as expected for SOURCE=).

I could fix MOLD but I was attempting to minimise the impact. I'll get on to it.

>
> The memcpy is also wrong. If CLASS(integrand) (of create_show) returned a
> derived type with allocatable components, one had to to a deep copy. As this
> is not known at compile time, a call to vtab->__copy is required.
>
> And a last issue: If one changes in
>   type(show_producer), allocatable :: executive_producer
> the TYPE to CLASS one gets still an ICE in conv_function_val.

As above - we are entering problems that I did not attempt to address.

>
> Tobias
>
> * Ditto for SOURCE=, though there one runs into PR51953 as F2003 only
> allowed one allocate-object.

Indeed.

Thanks for the thorough review.  I'll retire to lick my wounds and fix
MOLD and PR48705.

Paul

Re: [Patch, fortran] PR51870 - [OOP] ICE with ALLOCATE and SOURCE-expr function returning BT_CLASS

[Paul Richard Thomas]

Dear All,

After discussion off line with Tobias and a bit of tweaking, the patch
was committed as revision 183613.

2012-01-27  Paul Thomas  <pault@gcc.gnu.org>
	    Tobias Burnus <burnus@gcc.gnu.org>

	PR fortran/48705
	PR fortran/51870
	PR fortran/51943
	PR fortran/51946
	* trans-array.c (gfc_array_init_size): Add two extra arguments
	to convey the dynamic element size of a calls object and to
	return the number of elements that have been allocated.
	(gfc_array_allocate): Add the same arguments and use them to
	call gfc_array_init_size.  Before the allocation dereference
	the data pointer, if necessary. Set the allocated array to zero
	if the class element size or expr3 are non-null.
	* trans-expr.c (gfc_conv_class_to_class): Give this function
	global scope.
	(get_class_array_ref): New function.
	(gfc_copy_class_to_class): New function.
	* trans-array.h : Update prototype for gfc_array_allocate.
	* trans-stmt.c (gfc_trans_allocate): For non-variable class
	STATUS expressions extract the class object and the dynamic
	element size. Use the latter to call gfc_array_allocate and
	the former for setting the vptr and, via
	gfc_copy_class_to_clasfc_cs, to copy to the allocated data.
	* trans.h : Prototypes for gfc_get_class_array_ref,
	gfc_copy_class_to_class and gfc_conv_class_to_class.


2012-01-27  Paul Thomas  <pault@gcc.gnu.org>
	    Tobias Burnus <burnus@gcc.gnu.org>

	PR fortran/48705
	* gfortran.dg/class_allocate_11.f03: New.

	PR fortran/51870
	PR fortran/51943
	PR fortran/51946
	* gfortran.dg/class_allocate_7.f03: New.
	* gfortran.dg/class_allocate_8.f03: New.
	* gfortran.dg/class_allocate_9.f03: New.
	* gfortran.dg/class_allocate_10.f03: New.

Cheers

Paul