+2011-12-03 Tobias Burnus <burnus@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-01 Janne Blomqvist <jb@gcc.gnu.org>
* module.c (dt_lower_string): Make static.
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 "
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);
{
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;
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);
}
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". */
+2011-12-03 Tobias Burnus <burnus@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
+
2011-12-02 Nathan Sidwell <nathan@acm.org>
* lib/gcov.exp (verify-lines): Allow = as a count char.
--- /dev/null
+! { 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" } }
-! { dg-do compile }
+! { dg-do run }
!
! PR 48699: [4.6/4.7 Regression] [OOP] MOVE_ALLOC inside SELECT TYPE
!
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()
--- /dev/null
+! { 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" } }
! 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
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
git://gcc.gnu.org / gcc.git / commitdiff