Skip to content

Commit

Permalink
2012-12-28 Tobias Burnus <burnus@net-b.de>
Browse files Browse the repository at this point in the history 
        PR fortran/55763
        * check.c (gfc_check_move_alloc): Handle unlimited polymorphic.
        * trans-intrinsic.c (conv_intrinsic_move_alloc): Ditto.

2012-12-28  Tobias Burnus  <burnus@net-b.de>

        PR fortran/55763
        * gfortran.dg/unlimited_polymorphic_5.f90



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@194743 138bc75d-0d04-0410-961f-82ee72b054a4
  • Loading branch information
burnus committed Dec 28, 2012
1 parent cf94774 commit 7434f29
Show file tree
Hide file tree
Showing 5 changed files with 100 additions and 21 deletions.
6 changes: 6 additions & 0 deletions gcc/fortran/ChangeLog
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,9 @@
2012-12-28 Tobias Burnus <burnus@net-b.de>

PR fortran/55763
* check.c (gfc_check_move_alloc): Handle unlimited polymorphic.
* trans-intrinsic.c (conv_intrinsic_move_alloc): Ditto.

2012-12-27 Jerry DeLisle <jvdelisle@gcc.gnu.org>

PR fortran/48976
Expand Down
15 changes: 6 additions & 9 deletions gcc/fortran/check.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2791,18 +2791,15 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
return FAILURE;
}

if (to->ts.kind != from->ts.kind)
/* CLASS arguments: Make sure the vtab of from is present. */
if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from))
{
gfc_error ("The FROM and TO arguments of the MOVE_ALLOC intrinsic at %L"
" must be of the same kind %d/%d", &to->where, from->ts.kind,
to->ts.kind);
return FAILURE;
if (from->ts.type == BT_CLASS || from->ts.type == BT_DERIVED)
gfc_find_derived_vtab (from->ts.u.derived);
else
gfc_find_intrinsic_vtab (&from->ts);
}

/* CLASS arguments: Make sure the vtab of from is present. */
if (to->ts.type == BT_CLASS)
gfc_find_derived_vtab (from->ts.u.derived);

return SUCCESS;
}

Expand Down
54 changes: 42 additions & 12 deletions gcc/fortran/trans-intrinsic.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7373,8 +7373,13 @@ conv_intrinsic_move_alloc (gfc_code *code)

if (from_expr->ts.type == BT_CLASS)
{
vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
gcc_assert (vtab);
if (UNLIMITED_POLY (from_expr))
vtab = NULL;
else
{
vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
gcc_assert (vtab);
}

gfc_free_expr (from_expr2);
gfc_init_se (&from_se, NULL);
Expand All @@ -7386,13 +7391,23 @@ conv_intrinsic_move_alloc (gfc_code *code)
from_se.expr));

/* Reset _vptr component to declared type. */
tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
gfc_add_modify_loc (input_location, &block, from_se.expr,
fold_convert (TREE_TYPE (from_se.expr), tmp));
if (UNLIMITED_POLY (from_expr))
gfc_add_modify_loc (input_location, &block, from_se.expr,
fold_convert (TREE_TYPE (from_se.expr),
null_pointer_node));
else
{
tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
gfc_add_modify_loc (input_location, &block, from_se.expr,
fold_convert (TREE_TYPE (from_se.expr), tmp));
}
}
else
{
vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
if (from_expr->ts.type != BT_DERIVED)
vtab = gfc_find_intrinsic_vtab (&from_expr->ts);
else
vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
gcc_assert (vtab);
tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
gfc_add_modify_loc (input_location, &block, to_se.expr,
Expand All @@ -7415,8 +7430,13 @@ conv_intrinsic_move_alloc (gfc_code *code)

if (from_expr->ts.type == BT_CLASS)
{
vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
gcc_assert (vtab);
if (UNLIMITED_POLY (from_expr))
vtab = NULL;
else
{
vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
gcc_assert (vtab);
}

from_se.want_pointer = 1;
from_expr2 = gfc_copy_expr (from_expr);
Expand All @@ -7427,13 +7447,23 @@ conv_intrinsic_move_alloc (gfc_code *code)
from_se.expr));

/* Reset _vptr component to declared type. */
tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
gfc_add_modify_loc (input_location, &block, from_se.expr,
fold_convert (TREE_TYPE (from_se.expr), tmp));
if (UNLIMITED_POLY (from_expr))
gfc_add_modify_loc (input_location, &block, from_se.expr,
fold_convert (TREE_TYPE (from_se.expr),
null_pointer_node));
else
{
tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
gfc_add_modify_loc (input_location, &block, from_se.expr,
fold_convert (TREE_TYPE (from_se.expr), tmp));
}
}
else
{
vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
if (from_expr->ts.type != BT_DERIVED)
vtab = gfc_find_intrinsic_vtab (&from_expr->ts);
else
vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
gcc_assert (vtab);
tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
gfc_add_modify_loc (input_location, &block, to_se.expr,
Expand Down
5 changes: 5 additions & 0 deletions gcc/testsuite/ChangeLog
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,8 @@
2012-12-28 Tobias Burnus <burnus@net-b.de>

PR fortran/55763
* gfortran.dg/unlimited_polymorphic_5.f90

2012-12-27 Jerry DeLisle <jvdelisle@gcc.gnu.org>

PR fortran/48960
Expand Down
41 changes: 41 additions & 0 deletions gcc/testsuite/gfortran.dg/unlimited_polymorphic_5.f90
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,41 @@
! { dg-do run }
!
! PR fortran/55763
!
! Based on Reinhold Bader's test case
!

program mvall_03
implicit none
integer, parameter :: n1 = 100, n2 = 200
class(*), allocatable :: i1(:), i3(:)
integer, allocatable :: i2(:)

allocate(real :: i1(n1))
allocate(i2(n2))
i2 = 2
call move_alloc(i2, i1)
if (size(i1) /= n2 .or. allocated(i2)) then
call abort
! write(*,*) 'FAIL'
else
! write(*,*) 'OK'
end if

select type (i1)
type is (integer)
if (any (i1 /= 2)) call abort
class default
call abort()
end select
call move_alloc (i1, i3)
if (size(i3) /= n2 .or. allocated(i1)) then
call abort()
end if
select type (i3)
type is (integer)
if (any (i3 /= 2)) call abort
class default
call abort()
end select
end program

0 comments on commit 7434f29

Please sign in to comment.