OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/48705 ([OOP] ALLOCATE with non-trivial SOURCE) 

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.


Co-Authored-By: Tobias Burnus <burnus@gcc.gnu.org>

From-SVN: r183613
This commit is contained in:
Paul Thomas 2012-01-27 10:05:56 +00:00
parent 46c91e4518
commit 4daa71b063
12 changed files with 473 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
gcc/fortran/ChangeLog
View File

@ -1,3 +1,30 @@
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

18
gcc/fortran/trans-array.c
View File

@ -4719,7 +4719,7 @@ static tree
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;
@ -4876,7 +4876,9 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* 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)
{
@ -4904,6 +4906,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
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
@ -4962,7 +4965,8 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
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;
@ -5047,7 +5051,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
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)
{
@ -5078,6 +5082,9 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
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);
@ -5104,7 +5111,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
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

2
gcc/fortran/trans-array.h
View File

@ -25,7 +25,7 @@ tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*);
/* 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 *,

105
gcc/fortran/trans-expr.c
View File

@ -215,7 +215,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
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)
{
@ -303,6 +303,109 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
}
/* 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)
{

82
gcc/fortran/trans-stmt.c
View File

@ -4740,6 +4740,10 @@ gfc_trans_allocate (gfc_code * code)
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;
@ -4794,13 +4798,39 @@ gfc_trans_allocate (gfc_code * code)
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)
{
@ -4897,7 +4927,7 @@ gfc_trans_allocate (gfc_code * code)
}
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)
@ -4956,13 +4986,23 @@ gfc_trans_allocate (gfc_code * code)
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);
@ -5011,7 +5051,14 @@ gfc_trans_allocate (gfc_code * code)
/* 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;
@ -5098,25 +5145,18 @@ gfc_trans_allocate (gfc_code * code)
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. */

3
gcc/fortran/trans.h
View File

@ -346,6 +346,9 @@ tree gfc_vtable_size_get (tree);
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);

14
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,17 @@
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.

64
gcc/testsuite/gfortran.dg/class_allocate_10.f03 Normal file
View File

@ -0,0 +1,64 @@
! { 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" } }

62
gcc/testsuite/gfortran.dg/class_allocate_11.f03 Normal file
View File

@ -0,0 +1,62 @@
! { 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" } }

35
gcc/testsuite/gfortran.dg/class_allocate_7.f03 Normal file
View File

@ -0,0 +1,35 @@
! { 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" } }

53
gcc/testsuite/gfortran.dg/class_allocate_8.f03 Normal file
View File

@ -0,0 +1,53 @@
! { 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" } }

36
gcc/testsuite/gfortran.dg/class_allocate_9.f03 Normal file
View File

@ -0,0 +1,36 @@
! { 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" } }