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

re PR fortran/51306 (MOVE_ALLOC: Make more middle end friendlier)

Browse Source 
2011-11-29  Tobias Burnus  <burnus@net-b.de>

        PR fortran/51306
        PR fortran/48700
        * check.c (gfc_check_move_alloc): Make sure that from/to
        are both polymorphic or neither.
        * trans-intrinsic.c (conv_intrinsic_move_alloc): Cleanup,
        generate inline code.

2011-11-29  Tobias Burnus  <burnus@net-b.de>

        PR fortran/51306
        PR fortran/48700
        * gfortran.dg/move_alloc_5.f90: Add dg-error.
        * gfortran.dg/select_type_23.f03: Add dg-error.
        * gfortran.dg/move_alloc_6.f90: New.
        * gfortran.dg/move_alloc_7.f90: New.

From-SVN: r181801
This commit is contained in:
Tobias Burnus 2011-11-29 10:57:40 +01:00 committed by Tobias Burnus
parent 825298c450
commit e0516b0583
8 changed files with 239 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
gcc/fortran/ChangeLog
View File

@ -1,3 +1,12 @@
2011-11-29 Tobias Burnus <burnus@net-b.de>
PR fortran/51306
PR fortran/48700
* check.c (gfc_check_move_alloc): Make sure that from/to
are both polymorphic or neither.
* trans-intrinsic.c (conv_intrinsic_move_alloc): Cleanup,
generate inline code.
2011-11-28 Tobias Burnus <burnus@net-b.de>
Steven G. Kargl <kargl@gcc.gnu.org>

8
gcc/fortran/check.c
View File

@ -2691,6 +2691,14 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
if (same_type_check (to, 1, from, 0) == FAILURE)
return FAILURE;
if (to->ts.type != from->ts.type)
{
gfc_error ("The FROM and TO arguments in MOVE_ALLOC call at %L must be "
"either both polymorphic or both nonpolymorphic",
&from->where);
return FAILURE;
}
if (to->rank != from->rank)
{
gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "

149
gcc/fortran/trans-intrinsic.c
View File

@ -5892,7 +5892,7 @@ gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
}
/* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
/* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
static void
gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
@ -7182,50 +7182,123 @@ conv_intrinsic_atomic_ref (gfc_code *code)
static tree
conv_intrinsic_move_alloc (gfc_code *code)
{
if (code->ext.actual->expr->rank == 0)
stmtblock_t block;
gfc_expr *from_expr, *to_expr;
gfc_expr *to_expr2, *from_expr2;
gfc_se from_se, to_se;
gfc_ss *from_ss, *to_ss;
tree tmp;
gfc_start_block (&block);
from_expr = code->ext.actual->expr;
to_expr = code->ext.actual->next->expr;
gfc_init_se (&from_se, NULL);
gfc_init_se (&to_se, NULL);
if (from_expr->rank == 0)
{
/* Scalar arguments: Generate pointer assignments. */
gfc_expr *from, *to, *deal;
stmtblock_t block;
tree tmp;
gfc_se se;
from = code->ext.actual->expr;
to = code->ext.actual->next->expr;
gfc_start_block (&block);
/* Deallocate 'TO' argument. */
gfc_init_se (&se, NULL);
se.want_pointer = 1;
deal = gfc_copy_expr (to);
if (deal->ts.type == BT_CLASS)
gfc_add_data_component (deal);
gfc_conv_expr (&se, deal);
tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
deal, deal->ts);
gfc_add_expr_to_block (&block, tmp);
gfc_free_expr (deal);
if (to->ts.type == BT_CLASS)
tmp = gfc_trans_class_assign (to, from, EXEC_POINTER_ASSIGN);
if (from_expr->ts.type != BT_CLASS)
{
from_expr2 = to_expr;
to_expr2 = to_expr;
}
else
tmp = gfc_trans_pointer_assignment (to, from);
{
to_expr2 = gfc_copy_expr (to_expr);
from_expr2 = gfc_copy_expr (from_expr);
gfc_add_data_component (from_expr2);
gfc_add_data_component (to_expr2);
}
from_se.want_pointer = 1;
to_se.want_pointer = 1;
gfc_conv_expr (&from_se, from_expr2);
gfc_conv_expr (&to_se, to_expr2);
gfc_add_block_to_block (&block, &from_se.pre);
gfc_add_block_to_block (&block, &to_se.pre);
/* Deallocate "to". */
tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, true,
to_expr2, to_expr->ts);
gfc_add_expr_to_block (&block, tmp);
if (from->ts.type == BT_CLASS)
tmp = gfc_trans_class_assign (from, gfc_get_null_expr (NULL),
EXEC_POINTER_ASSIGN);
else
tmp = gfc_trans_pointer_assignment (from,
gfc_get_null_expr (NULL));
gfc_add_expr_to_block (&block, tmp);
/* Assign (_data) pointers. */
gfc_add_modify_loc (input_location, &block, to_se.expr,
fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
/* Set "from" to NULL. */
gfc_add_modify_loc (input_location, &block, from_se.expr,
fold_convert (TREE_TYPE (from_se.expr), null_pointer_node));
gfc_add_block_to_block (&block, &from_se.post);
gfc_add_block_to_block (&block, &to_se.post);
/* Set _vptr. */
if (from_expr->ts.type == BT_CLASS)
{
gfc_free_expr (from_expr2);
gfc_free_expr (to_expr2);
gfc_init_se (&from_se, NULL);
gfc_init_se (&to_se, NULL);
from_se.want_pointer = 1;
to_se.want_pointer = 1;
gfc_add_vptr_component (from_expr);
gfc_add_vptr_component (to_expr);
gfc_conv_expr (&from_se, from_expr);
gfc_conv_expr (&to_se, to_expr);
gfc_add_modify_loc (input_location, &block, to_se.expr,
fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
}
return gfc_finish_block (&block);
}
else
/* Array arguments: Generate library code. */
return gfc_trans_call (code, false, NULL_TREE, NULL_TREE, false);
/* Update _vptr component. */
if (from_expr->ts.type == BT_CLASS)
{
from_se.want_pointer = 1;
to_se.want_pointer = 1;
from_expr2 = gfc_copy_expr (from_expr);
to_expr2 = gfc_copy_expr (to_expr);
gfc_add_vptr_component (from_expr2);
gfc_add_vptr_component (to_expr2);
gfc_conv_expr (&from_se, from_expr2);
gfc_conv_expr (&to_se, to_expr2);
gfc_add_modify_loc (input_location, &block, to_se.expr,
fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
gfc_free_expr (to_expr2);
gfc_free_expr (from_expr2);
gfc_init_se (&from_se, NULL);
gfc_init_se (&to_se, NULL);
}
/* Deallocate "to". */
to_ss = gfc_walk_expr (to_expr);
from_ss = gfc_walk_expr (from_expr);
gfc_conv_expr_descriptor (&to_se, to_expr, to_ss);
gfc_conv_expr_descriptor (&from_se, from_expr, from_ss);
tmp = gfc_conv_descriptor_data_get (to_se.expr);
tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, to_expr);
gfc_add_expr_to_block (&block, tmp);
/* Move the pointer and update the array descriptor data. */
gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
/* Set "to" to NULL. */
tmp = gfc_conv_descriptor_data_get (from_se.expr);
gfc_add_modify_loc (input_location, &block, tmp,
fold_convert (TREE_TYPE (tmp), null_pointer_node));
return gfc_finish_block (&block);
}

9
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,12 @@
2011-11-29 Tobias Burnus <burnus@net-b.de>
PR fortran/51306
PR fortran/48700
* gfortran.dg/move_alloc_5.f90: Add dg-error.
* gfortran.dg/select_type_23.f03: Add dg-error.
* gfortran.dg/move_alloc_6.f90: New.
* gfortran.dg/move_alloc_7.f90: New.
2011-11-29 Ira Rosen <ira.rosen@linaro.org>
PR tree-optimization/51301

4
gcc/testsuite/gfortran.dg/move_alloc_5.f90
View File

@ -1,4 +1,4 @@
! { dg-do run }
! { dg-do compile }
!
! PR 48699: [4.6/4.7 Regression] [OOP] MOVE_ALLOC inside SELECT TYPE
!
@ -16,7 +16,7 @@ program testmv1
type(bar2), allocatable :: sm2
allocate (sm2)
call move_alloc (sm2,sm)
call move_alloc (sm2,sm) ! { dg-error "must be either both polymorphic or both nonpolymorphic" }
if (allocated(sm2)) call abort()
if (.not. allocated(sm)) call abort()

80
gcc/testsuite/gfortran.dg/move_alloc_6.f90 Normal file
View File

@ -0,0 +1,80 @@
! { dg-do run }
!
! Test move_alloc for polymorphic scalars
!
!
module myalloc
implicit none
type :: base_type
integer :: i =2
end type base_type
type, extends(base_type) :: extended_type
integer :: j = 77
end type extended_type
contains
subroutine myallocate (a)
class(base_type), allocatable, intent(inout) :: a
class(base_type), allocatable :: tmp
allocate (extended_type :: tmp)
select type(tmp)
type is(base_type)
call abort ()
type is(extended_type)
if (tmp%i /= 2 .or. tmp%j /= 77) call abort()
tmp%i = 5
tmp%j = 88
end select
select type(a)
type is(base_type)
if (a%i /= -44) call abort()
a%i = -99
class default
call abort ()
end select
call move_alloc (from=tmp, to=a)
select type(a)
type is(extended_type)
if (a%i /= 5) call abort()
if (a%j /= 88) call abort()
a%i = 123
a%j = 9498
class default
call abort ()
end select
if (allocated (tmp)) call abort()
end subroutine myallocate
end module myalloc
program main
use myalloc
implicit none
class(base_type), allocatable :: a
allocate (a)
select type(a)
type is(base_type)
if (a%i /= 2) call abort()
a%i = -44
class default
call abort ()
end select
call myallocate (a)
select type(a)
type is(extended_type)
if (a%i /= 123) call abort()
if (a%j /= 9498) call abort()
class default
call abort ()
end select
end program main

15
gcc/testsuite/gfortran.dg/move_alloc_7.f90 Normal file
View File

@ -0,0 +1,15 @@
! { dg-do compile }
!
! Check that move alloc handles different, type compatible
! declared types
!
type t
end type t
type, extends(t) :: t2
end type t2
class(t), allocatable :: x
class(t2), allocatable :: y
allocate(y)
call move_alloc (y, x)
end

6
gcc/testsuite/gfortran.dg/select_type_23.f03
View File

@ -3,6 +3,10 @@
! PR 48699: [OOP] MOVE_ALLOC inside SELECT TYPE
!
! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
!
! Note that per Fortran 2008, 8.1.9.2, "within the block following
! a TYPE IS type guard statement, the associating entity (16.5.5) is not polymorphic"
!
program testmv2
@ -16,7 +20,7 @@ program testmv2
select type(sm2)
type is (bar)
call move_alloc(sm2,sm)
call move_alloc(sm2,sm) ! { dg-error "must be either both polymorphic or both nonpolymorphic" }
end select
end program testmv2