diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 3fee56d891f6..72a7f746e9ce 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2011-12-03 Tobias Burnus + + * check.c (gfc_check_move_alloc): Allow nonpolymorphic + FROM with polymorphic TO. + * trans-intrinsic.c (conv_intrinsic_move_alloc): Handle + nonpolymorphic FROM with polymorphic TO. + 2011-12-01 Janne Blomqvist * module.c (dt_lower_string): Make static. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 832eb6486ec1..605c77d2b48c 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2688,17 +2688,17 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) if (allocatable_check (to, 1) == FAILURE) return FAILURE; - if (same_type_check (to, 1, from, 0) == FAILURE) - return FAILURE; - - if (to->ts.type != from->ts.type) + if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED) { - gfc_error ("The FROM and TO arguments in MOVE_ALLOC call at %L must be " - "either both polymorphic or both nonpolymorphic", + gfc_error ("The TO arguments in MOVE_ALLOC at %L must be " + "polymorphic if FROM is polymorphic", &from->where); return FAILURE; } + if (same_type_check (to, 1, from, 0) == FAILURE) + return FAILURE; + if (to->rank != from->rank) { gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must " @@ -2718,7 +2718,7 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) return FAILURE; } - /* CLASS arguments: Make sure the vtab is present. */ + /* CLASS arguments: Make sure the vtab of from is present. */ if (to->ts.type == BT_CLASS) gfc_find_derived_vtab (from->ts.u.derived); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index d055275614ba..855db306a7af 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -7184,7 +7184,7 @@ conv_intrinsic_move_alloc (gfc_code *code) { stmtblock_t block; gfc_expr *from_expr, *to_expr; - gfc_expr *to_expr2, *from_expr2; + gfc_expr *to_expr2, *from_expr2 = NULL; gfc_se from_se, to_se; gfc_ss *from_ss, *to_ss; tree tmp; @@ -7199,16 +7199,21 @@ conv_intrinsic_move_alloc (gfc_code *code) if (from_expr->rank == 0) { + gcc_assert (from_expr->ts.type != BT_CLASS + || to_expr->ts.type == BT_CLASS); if (from_expr->ts.type != BT_CLASS) + from_expr2 = from_expr; + else { - from_expr2 = to_expr; - to_expr2 = to_expr; + from_expr2 = gfc_copy_expr (from_expr); + gfc_add_data_component (from_expr2); } + + if (to_expr->ts.type != BT_CLASS) + to_expr2 = to_expr; else { 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); } @@ -7236,48 +7241,72 @@ conv_intrinsic_move_alloc (gfc_code *code) gfc_add_block_to_block (&block, &to_se.post); /* Set _vptr. */ - if (from_expr->ts.type == BT_CLASS) + if (to_expr->ts.type == BT_CLASS) { - gfc_free_expr (from_expr2); - gfc_free_expr (to_expr2); - - gfc_init_se (&from_se, NULL); + gfc_free_expr (to_expr2); 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); + + if (from_expr->ts.type == BT_CLASS) + { + gfc_free_expr (from_expr2); + gfc_init_se (&from_se, NULL); + from_se.want_pointer = 1; + gfc_add_vptr_component (from_expr); + gfc_conv_expr (&from_se, from_expr); + tmp = from_se.expr; + } + else + { + gfc_symbol *vtab; + 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, - fold_convert (TREE_TYPE (to_se.expr), from_se.expr)); + fold_convert (TREE_TYPE (to_se.expr), tmp)); } return gfc_finish_block (&block); } /* Update _vptr component. */ - if (from_expr->ts.type == BT_CLASS) + if (to_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); + if (from_expr->ts.type == BT_CLASS) + { + from_se.want_pointer = 1; + from_expr2 = gfc_copy_expr (from_expr); + gfc_add_vptr_component (from_expr2); + gfc_conv_expr (&from_se, from_expr2); + tmp = from_se.expr; + } + else + { + gfc_symbol *vtab; + 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_init_se (&from_se, NULL); + gfc_add_modify_loc (input_location, &block, to_se.expr, + fold_convert (TREE_TYPE (to_se.expr), tmp)); + gfc_free_expr (to_expr2); gfc_init_se (&to_se, NULL); + + if (from_expr->ts.type == BT_CLASS) + { + gfc_free_expr (from_expr2); + gfc_init_se (&from_se, NULL); + } } /* Deallocate "to". */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index d09f65229d76..75cf459710e8 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2011-12-03 Tobias Burnus + + * gfortran.dg/select_type_23.f03: Revert Rev. 181801, + i.e. remove the dg-error line. + * gfortran.dg/move_alloc_5.f90: Ditto and change back + to dg-do run. + * gfortran.dg/move_alloc_9.f90: New. + * gfortran.dg/move_alloc_10.f90: New + 2011-12-02 Nathan Sidwell * lib/gcov.exp (verify-lines): Allow = as a count char. diff --git a/gcc/testsuite/gfortran.dg/move_alloc_10.f90 b/gcc/testsuite/gfortran.dg/move_alloc_10.f90 new file mode 100644 index 000000000000..3a538be456cf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/move_alloc_10.f90 @@ -0,0 +1,79 @@ +! { dg-do run } +! +! Test move_alloc for polymorphic scalars +! +! The following checks that a move_alloc from +! a TYPE to a CLASS works +! +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 + type(extended_type), allocatable :: tmp + + allocate (tmp) + + if (tmp%i /= 2 .or. tmp%j /= 77) call abort() + tmp%i = 5 + tmp%j = 88 + + 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 + +! { dg-final { cleanup-modules "myalloc" } } diff --git a/gcc/testsuite/gfortran.dg/move_alloc_5.f90 b/gcc/testsuite/gfortran.dg/move_alloc_5.f90 index 7663275263ef..b2759de2c1dd 100644 --- a/gcc/testsuite/gfortran.dg/move_alloc_5.f90 +++ b/gcc/testsuite/gfortran.dg/move_alloc_5.f90 @@ -1,4 +1,4 @@ -! { dg-do compile } +! { dg-do run } ! ! 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) ! { dg-error "must be either both polymorphic or both nonpolymorphic" } + call move_alloc (sm2,sm) if (allocated(sm2)) call abort() if (.not. allocated(sm)) call abort() diff --git a/gcc/testsuite/gfortran.dg/move_alloc_9.f90 b/gcc/testsuite/gfortran.dg/move_alloc_9.f90 new file mode 100644 index 000000000000..60d6f1496e2a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/move_alloc_9.f90 @@ -0,0 +1,57 @@ +! { dg-do compile } +! +! Test diagnostic for MOVE_ALLOC: +! FROM=type, TO=class is OK +! FROM=class, TO=type is INVALID +! +module m2 + type, abstract :: t2 + contains + procedure(intf), deferred, nopass :: f + end type t2 + + interface + function intf() + import + class(t2), allocatable :: intf + end function intf + end interface +end module m2 + +module m3 + use m2 + type, extends(t2) :: t3 + contains + procedure,nopass :: f => my_f + end type t3 +contains + function my_f() + class(t2), allocatable :: my_f + end function my_f +end module m3 + +subroutine my_test +use m3 +type(t3), allocatable :: x +class(t2), allocatable :: y +call move_alloc (x, y) +end subroutine my_test + +program testmv1 + type bar + end type + + type, extends(bar) :: bar2 + end type + + class(bar), allocatable :: sm + type(bar2), allocatable :: sm2 + + allocate (sm2) + call move_alloc (sm,sm2) ! { dg-error "must be polymorphic if FROM is polymorphic" } + + if (allocated(sm2)) call abort() + if (.not. allocated(sm)) call abort() +end program + +! { dg-final { cleanup-modules "m2 m3" } } diff --git a/gcc/testsuite/gfortran.dg/select_type_23.f03 b/gcc/testsuite/gfortran.dg/select_type_23.f03 index 2479f1d144d2..d7788d2f4945 100644 --- a/gcc/testsuite/gfortran.dg/select_type_23.f03 +++ b/gcc/testsuite/gfortran.dg/select_type_23.f03 @@ -3,10 +3,6 @@ ! PR 48699: [OOP] MOVE_ALLOC inside SELECT TYPE ! ! Contributed by Salvatore Filippone -! -! 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 @@ -20,7 +16,7 @@ program testmv2 select type(sm2) type is (bar) - call move_alloc(sm2,sm) ! { dg-error "must be either both polymorphic or both nonpolymorphic" } + call move_alloc(sm2,sm) end select end program testmv2