From e0516b0583fee75e60211cab19f6270eba510846 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Tue, 29 Nov 2011 10:57:40 +0100 Subject: [PATCH] re PR fortran/51306 (MOVE_ALLOC: Make more middle end friendlier) 2011-11-29 Tobias Burnus 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-29 Tobias Burnus 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. * gfortran.dg/move_alloc_7.f90: New. From-SVN: r181801 --- gcc/fortran/ChangeLog | 9 ++ gcc/fortran/check.c | 8 ++ gcc/fortran/trans-intrinsic.c | 143 ++++++++++++++++++++------- gcc/testsuite/ChangeLog | 9 ++ gcc/testsuite/gfortran.dg/move_alloc_5.f90 | 4 +- gcc/testsuite/gfortran.dg/move_alloc_6.f90 | 80 +++++++++++++++ gcc/testsuite/gfortran.dg/move_alloc_7.f90 | 15 +++ gcc/testsuite/gfortran.dg/select_type_23.f03 | 6 +- 8 files changed, 236 insertions(+), 38 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/move_alloc_6.f90 create mode 100644 gcc/testsuite/gfortran.dg/move_alloc_7.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 393f2a0..280c35e 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,12 @@ +2011-11-29 Tobias Burnus + + 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-28 Tobias Burnus Steven G. Kargl diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index d9b9a9c..832eb64 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2691,6 +2691,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..d055275 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -5892,7 +5892,7 @@ gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr) } -/* 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 +7182,123 @@ 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); + if (from_expr->rank == 0) + { + if (from_expr->ts.type != BT_CLASS) + { + from_expr2 = to_expr; + to_expr2 = to_expr; + } else - tmp = gfc_trans_pointer_assignment (to, from); - gfc_add_expr_to_block (&block, tmp); + { + 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); + } - if (from->ts.type == BT_CLASS) - tmp = gfc_trans_class_assign (from, gfc_get_null_expr (NULL), - EXEC_POINTER_ASSIGN); - else - tmp = gfc_trans_pointer_assignment (from, - gfc_get_null_expr (NULL)); + from_se.want_pointer = 1; + to_se.want_pointer = 1; + gfc_conv_expr (&from_se, from_expr2); + gfc_conv_expr (&to_se, to_expr2); + gfc_add_block_to_block (&block, &from_se.pre); + gfc_add_block_to_block (&block, &to_se.pre); + + /* Deallocate "to". */ + tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, true, + to_expr2, to_expr->ts); gfc_add_expr_to_block (&block, tmp); + /* Assign (_data) pointers. */ + gfc_add_modify_loc (input_location, &block, to_se.expr, + fold_convert (TREE_TYPE (to_se.expr), from_se.expr)); + + /* Set "from" to NULL. */ + 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); + + /* Set _vptr. */ + if (from_expr->ts.type == BT_CLASS) + { + gfc_free_expr (from_expr2); + gfc_free_expr (to_expr2); + + gfc_init_se (&from_se, NULL); + 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); + gfc_add_modify_loc (input_location, &block, to_se.expr, + fold_convert (TREE_TYPE (to_se.expr), from_se.expr)); + } + 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/ChangeLog b/gcc/testsuite/ChangeLog index f2e9236..246823c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2011-11-29 Tobias Burnus + + 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. + * gfortran.dg/move_alloc_7.f90: New. + 2011-11-29 Ira Rosen PR tree-optimization/51301 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() diff --git a/gcc/testsuite/gfortran.dg/move_alloc_6.f90 b/gcc/testsuite/gfortran.dg/move_alloc_6.f90 new file mode 100644 index 0000000..b62a023 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/move_alloc_6.f90 @@ -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/move_alloc_7.f90 b/gcc/testsuite/gfortran.dg/move_alloc_7.f90 new file mode 100644 index 0000000..d2bc82c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/move_alloc_7.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! Check that move alloc handles different, type compatible +! declared types +! +type t +end type t +type, extends(t) :: t2 +end type t2 + +class(t), allocatable :: x +class(t2), allocatable :: y +allocate(y) +call move_alloc (y, x) +end 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 +! +! 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 -- 2.7.4