This patches fixes my previous MOVE_ALLOC patch. The standard states for
TO: "It shall be polymorphic if FROM is polymorphic."
I somehow read this bijectively, but the it is actually allowed to have
a nonpolymorphic FROM with a polymorphic TO. Thanks for Damian for
finding this.
Build and regtested on x86-64-linux.
OK for the trunk?
Tobias
PS: Other pending patches:
- http://gcc.gnu.org/ml/fortran/2011-11/msg00249.html - Pointer
INTENT(IN) check for MOVE_ALLOC [4.6/4.7 rejects-valid regression]
- http://gcc.gnu.org/ml/fortran/2011-11/msg00250.html - no
-fcheck=bounds for character(LEN=:) to avoid ICE
- http://gcc.gnu.org/ml/fortran/2011-11/msg00253.html - (Re)enable
warning if a function result variable is not set [4.4-4.7 diagnostics
regression]
- http://gcc.gnu.org/ml/fortran/2011-11/msg00254.html - Thomas'
dependency-ICE patch [4.6/4.7 regression]
- http://gcc.gnu.org/ml/fortran/2011-12/msg00005.html - Fix
component-access check
Note: select_type_23.f03 is actually invalid as "sm2", i.e.
the associate-name in SELECT TYPE, is not allocatable. See
PR fortran/48887 for details
2011-12-02 Tobias Burnus <bur...@net-b.de>
* 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-02 Tobias Burnus <bur...@net-b.de>
* 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
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index c3f3cc2..94de31b 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -2702,17 +2702,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 "
@@ -2732,7 +2732,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 5da2c79..05bb095 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -7192,7 +7192,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;
@@ -7207,16 +7207,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);
}
@@ -7244,48 +7249,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);
+ 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_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));
gfc_free_expr (to_expr2);
- gfc_free_expr (from_expr2);
-
- gfc_init_se (&from_se, NULL);
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/gfortran.dg/move_alloc_5.f90 b/gcc/testsuite/gfortran.dg/move_alloc_5.f90
index 7663275..b2759de 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/select_type_23.f03 b/gcc/testsuite/gfortran.dg/select_type_23.f03
index 2479f1d..d7788d2 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 <sfilipp...@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
@@ -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
--- /dev/null 2011-12-02 08:02:36.367523993 +0100
+++ gcc/gcc/testsuite/gfortran.dg/move_alloc_9.f90 2011-12-02 11:46:23.000000000 +0100
@@ -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" } }
--- /dev/null 2011-12-02 08:02:36.367523993 +0100
+++ gcc/gcc/testsuite/gfortran.dg/move_alloc_10.f90 2011-12-02 15:17:07.000000000 +0100
@@ -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" } }
