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 <pa...@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 <pa...@gcc.gnu.org>
PR fortran/51870
* gfortran.dg/class_allocate_7.f03: New.
* gfortran.dg/class_allocate_8.f03: New.
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 <bur...@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 <bur...@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" } }
