Dear all,
(First, this is *not* for the 4.6/4.7 rejects-valid regression, which is
related to intent(in) pointers with allocatable components.)
When debugging an issue with with polymorphic arrays and MOVE_ALLOC, I
got lost in the code generation of move_alloc - and didn't like the
generated code. Thus, I have rewritten the trans*.c part of it. (It
turned out that the issue, we had, was unrelated to move_alloc.)
Changes:
* Replace call to libgfortran by inline code (much faster and shorter code)
* For arrays: Deallocate "from" (deep freeing)
* For polymorphic arrays: set _vptr.
Actually, the required code is rather simple: For move_alloc(from, to),
one just needs to do:
a) Deallocate "to", taking allocatable components and the polymorphic
types into account (the latter is a to-do item, cf. PR 46174).
b) Do a simple assignment:
to = from
namely: If both are scalar variables, those are pointers and one does a
pointer assignment. If they are polymorphic and/or an array, one does a
(nonpointer) assignment to the class container or the array descriptor.
c) Setting "from = NULL" (nonpolymorphic scalars) or "from.data = NULL"
(nonpolymorphic arrays) or "from._data = NULL" (polymorphic scalars) or
"from._data.data = NULL" (polymorphic arrays).
For (b) the current expr-ref-walking function for polymorphic arrays
either give access to class._data or to class._vptr. It is extremly
difficult to access "class" itself. Thus, I now do two assignments: One
nonpointer one to array descriptor and one pointer assignment to the _vptr.
Build and regtested with the trunk with Paul's polymorphic array patch
applied. (I will do a bootstrap and regtest with a clean trunk before
committal.)
OK for the trunk?
Tobias
PS: I'll add _gfortran_move_alloc to the list of functions which can be
removed after the ABI breakage.
2011-11-26 Tobias Burnus <bur...@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-26 Tobias Burnus <bur...@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.
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index d9b9a9c..e2b0d66 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -2691,6 +2709,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 "
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 4244570..37a1ba6 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -5892,7 +5892,7 @@
}
-/* 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 +7190,122 @@ conv_intrinsic_atomic_ref (gfc_code *code)
static tree
conv_intrinsic_move_alloc (gfc_code *code)
{
- if (code->ext.actual->expr->rank == 0)
- {
- /* Scalar arguments: Generate pointer assignments. */
- gfc_expr *from, *to, *deal;
- stmtblock_t block;
- tree tmp;
- gfc_se se;
+ 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;
- from = code->ext.actual->expr;
- to = code->ext.actual->next->expr;
+ gfc_start_block (&block);
- gfc_start_block (&block);
+ from_expr = code->ext.actual->expr;
+ to_expr = code->ext.actual->next->expr;
- /* 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);
+ gfc_init_se (&from_se, NULL);
+ gfc_init_se (&to_se, NULL);
- if (to->ts.type == BT_CLASS)
- tmp = gfc_trans_class_assign (to, from, EXEC_POINTER_ASSIGN);
- else
- tmp = gfc_trans_pointer_assignment (to, from);
- gfc_add_expr_to_block (&block, tmp);
+ if (from_expr->rank == 0)
+ {
+ /* Deallocate "to". */
- if (from->ts.type == BT_CLASS)
- tmp = gfc_trans_class_assign (from, gfc_get_null_expr (NULL),
- EXEC_POINTER_ASSIGN);
+ if (from_expr->ts.type != BT_CLASS)
+ to_expr2 = to_expr;
else
- tmp = gfc_trans_pointer_assignment (from,
- gfc_get_null_expr (NULL));
+ {
+ to_expr2 = gfc_copy_expr (to_expr);
+ gfc_add_data_component (to_expr2);
+ }
+
+ to_se.want_pointer = 1;
+ gfc_conv_expr (&to_se, to_expr2);
+ tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, true,
+ to_expr2, to_expr->ts);
gfc_add_expr_to_block (&block, tmp);
+ /* Nonpolymophic - do a pointer assignment: to = from;
+ Polymophic - do an assignment to the class container: *to = *from. */
+
+ if (from_expr->ts.type != BT_CLASS)
+ from_se.want_pointer = 1;
+
+ gfc_conv_expr (&from_se, from_expr);
+
+ if (from_expr->ts.type == BT_CLASS)
+ {
+ gfc_init_se (&to_se, NULL);
+ gfc_conv_expr (&to_se, to_expr);
+ }
+
+ gfc_add_block_to_block (&block, &from_se.pre);
+ gfc_add_block_to_block (&block, &to_se.pre);
+
+ gfc_add_modify_loc (input_location, &block, to_se.expr,
+ fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
+
+ /* Set "from" to NULL. */
+
+ if (from_expr->ts.type == BT_CLASS)
+ {
+ gfc_init_se (&from_se, NULL);
+ from_se.want_pointer = 1;
+ from_expr = gfc_copy_expr (from_expr);
+ gfc_add_data_component (from_expr);
+ gfc_conv_expr (&from_se, from_expr);
+ gfc_free_expr (from_expr);
+ }
+
+ 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);
+
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);
}
diff --git a/gcc/testsuite/gfortran.dg/move_alloc_5.f90 b/gcc/testsuite/gfortran.dg/move_alloc_5.f90
index b2759de..7663275 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 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()
--- /dev/null 2011-11-22 07:52:35.375586753 +0100
+++ gcc/gcc/testsuite/gfortran.dg/move_alloc_6.f90 2011-11-26 14:14:27.000000000 +0100
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/select_type_23.f03 b/gcc/testsuite/gfortran.dg/select_type_23.f03
index d7788d2..2479f1d 100644
--- a/gcc/testsuite/gfortran.dg/select_type_23.f03
+++ b/gcc/testsuite/gfortran.dg/select_type_23.f03
@@ -3,6 +3,10 @@
! 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
@@ -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
