+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-25 Tobias Burnus <burnus@net-b.de>
PR fortran/51995
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 expr3_elem_size, tree *nelems, gfc_expr *expr3)
{
tree type;
tree tmp;
/* 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_elem_size != NULL_TREE)
+ tmp = expr3_elem_size;
+ else if (expr3 != NULL)
{
if (expr3->ts.type == BT_CLASS)
{
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
bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
- tree errlen, tree label_finish, gfc_expr *expr3)
+ tree errlen, tree label_finish, tree expr3_elem_size,
+ tree *nelems, gfc_expr *expr3)
{
tree tmp;
tree pointer;
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);
+ expr3_elem_size, nelems, expr3);
if (dimension)
{
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_add_expr_to_block (&se->pre, tmp);
- if (expr->ts.type == BT_CLASS && expr3)
+ 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
/* 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 *);
+ 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 *,
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
+void
gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
gfc_typespec class_ts, bool elemental)
{
}
+/* Given a class array declaration and an index, returns the address
+ of the referenced element. */
+
+tree
+gfc_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. Should 'from' be
+ NULL_TREE, the inialization expression for 'to' is used, assuming
+ that the _vptr is set. */
+
+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;
+
+ if (from != NULL_TREE)
+ fcn = gfc_vtable_copy_get (from);
+ else
+ fcn = gfc_vtable_copy_get (to);
+
+ fcn_type = TREE_TYPE (TREE_TYPE (fcn));
+
+ if (from != NULL_TREE)
+ from_data = gfc_class_data_get (from);
+ else
+ from_data = gfc_vtable_def_init_get (to);
+
+ 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 = gfc_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 = gfc_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;
+}
+
static tree
gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
{
stmtblock_t post;
gfc_expr *sz;
gfc_se se_sz;
+ tree class_expr;
+ tree nelems;
+ tree memsize = NULL_TREE;
+ tree classexpr = NULL_TREE;
if (!code->ext.alloc.list)
return NULL_TREE;
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
+ /* Evaluate expr3 just once if not a variable. */
+ if (al == code->ext.alloc.list
+ && 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);
+ classexpr = build_fold_indirect_ref_loc (input_location,
+ se_sz.expr);
+ classexpr = gfc_evaluate_now (classexpr, &se.pre);
+ memsize = gfc_vtable_size_get (classexpr);
+ memsize = fold_convert (sizetype, memsize);
+ }
+
+ memsz = memsize;
+ class_expr = classexpr;
+
+ nelems = NULL_TREE;
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
- code->expr3))
+ memsz, &nelems, code->expr3))
{
/* A scalar or derived type. */
/* Determine allocate size. */
- if (al->expr->ts.type == BT_CLASS && code->expr3)
+ if (al->expr->ts.type == BT_CLASS
+ && code->expr3
+ && memsz == NULL_TREE)
{
if (code->expr3->ts.type == BT_CLASS)
{
}
else if (code->ext.alloc.ts.type != BT_UNKNOWN)
memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
- else
+ else if (memsz == NULL_TREE)
memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE)
e = gfc_copy_expr (al->expr);
if (e->ts.type == BT_CLASS)
{
- gfc_expr *lhs,*rhs;
+ 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)
+
+ 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);
/* Initialization via SOURCE block
(or static default initializer). */
gfc_expr *rhs = gfc_copy_expr (code->expr3);
- if (al->expr->ts.type == BT_CLASS)
+ 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;
gfc_free_expr (rhs);
gfc_add_expr_to_block (&block, tmp);
}
- else if (code->expr3 && code->expr3->mold
+ else if (code->expr3 && code->expr3->mold
&& code->expr3->ts.type == BT_CLASS)
{
- /* Default-initialization via MOLD (polymorphic). */
- gfc_expr *rhs = gfc_copy_expr (code->expr3);
- gfc_se dst,src;
- gfc_add_vptr_component (rhs);
- gfc_add_def_init_component (rhs);
- gfc_init_se (&dst, NULL);
- gfc_init_se (&src, NULL);
- gfc_conv_expr (&dst, expr);
- gfc_conv_expr (&src, rhs);
- gfc_add_block_to_block (&block, &src.pre);
- tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
+ /* Since the _vptr has already been assigned to the allocate
+ object, we can use gfc_copy_class_to_class in its
+ initialization mode. */
+ tmp = TREE_OPERAND (se.expr, 0);
+ tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems);
gfc_add_expr_to_block (&block, tmp);
- gfc_free_expr (rhs);
}
- gfc_free_expr (expr);
+ gfc_free_expr (expr);
}
/* STAT. */
tree gfc_vtable_extends_get (tree);
tree gfc_vtable_def_init_get (tree);
tree gfc_vtable_copy_get (tree);
+tree gfc_get_class_array_ref (tree, tree);
+tree gfc_copy_class_to_class (tree, tree, 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);
+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.
+
2012-01-27 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/discr34.adb: New test.
--- /dev/null
+! { dg-do run }
+! PR51870 - ALLOCATE with class function expression for SOURCE failed.
+! This version of the test allocates class arrays with MOLD.
+!
+! 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
+ 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 :: kernel1(:), kernel2(:)
+ type(show_producer) :: executive_producer
+
+ allocate(kernel1(5), kernel2(5),mold=executive_producer%create_show_array (5))
+ select type(kernel1)
+ type is (integrand); if (any (kernel1%variable .ne. 1)) call abort
+ end select
+
+ deallocate (kernel1)
+
+ allocate(kernel1(3),mold=executive_producer%create_show ())
+ select type(kernel1)
+ type is (integrand); if (any (kernel1%variable .ne. 1)) call abort
+ end select
+
+ deallocate (kernel1)
+
+ select type(kernel2)
+ type is (integrand); kernel2%variable = [1,2,3,4,5]
+ end select
+
+ allocate(kernel1(3),source = kernel2(3:5))
+ select type(kernel1)
+ type is (integrand); if (any (kernel1%variable .ne. [3,4,5])) call abort
+ end select
+end program
+! { dg-final { cleanup-modules "show_producer_class" } }
+
--- /dev/null
+! { dg-do run }
+! PR48705 - 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 generic_deferred
+ implicit none
+ type, abstract :: addable
+ contains
+ private
+ procedure(add), deferred :: a
+ generic, public :: operator(+) => a
+ end type addable
+ abstract interface
+ function add(x, y) result(res)
+ import :: addable
+ class(addable), intent(in) :: x, y
+ class(addable), allocatable :: res
+ end function add
+ end interface
+ type, extends(addable) :: vec
+ integer :: i(2)
+ contains
+ procedure :: a => a_vec
+ end type
+contains
+ function a_vec(x, y) result(res)
+ class(vec), intent(in) :: x
+ class(addable), intent(in) :: y
+ class(addable), allocatable :: res
+ integer :: ii(2)
+ select type(y)
+ class is (vec)
+ ii = y%i
+ end select
+ allocate(vec :: res)
+ select type(res)
+ type is (vec)
+ res%i = x%i + ii
+ end select
+ end function
+end module generic_deferred
+program prog
+ use generic_deferred
+ implicit none
+ type(vec) :: x, y
+ class(addable), allocatable :: z
+! x = vec( (/1,2/) ); y = vec( (/2,-2/) )
+ x%i = (/1,2/); y%i = (/2,-2/)
+ allocate(z, source= x + y)
+ select type(z)
+ type is(vec)
+ if (z%i(1) /= 3 .or. z%i(2) /= 0) then
+ write(*,*) 'FAIL'
+ else
+ write(*,*) 'OK'
+ end if
+ end select
+end program prog
+! { dg-final { cleanup-modules "generic_deferred" } }
+
--- /dev/null
+! { 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" } }
+
--- /dev/null
+! { 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" } }
+
--- /dev/null
+! { 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 :: kernel1, kernel2
+ type(show_producer) :: executive_producer
+
+ allocate(kernel1, kernel2,mold=executive_producer%create_show ())
+ if (kernel1%variable .ne. -1) call abort
+ if (kernel2%variable .ne. -1) call abort
+end program
+! { dg-final { cleanup-modules "show_producer_class" } }
+
projects / platform / upstream / linaro-gcc.git / commitdiff