diff options
author | Paul Thomas <pault@gcc.gnu.org> | 2016-01-10 12:56:28 +0000 |
---|---|---|
committer | Paul Thomas <pault@gcc.gnu.org> | 2016-01-10 12:56:28 +0000 |
commit | 4f90ee6c7780cab416adee0830074c9a315206d0 (patch) | |
tree | 8db8d7d0db37f77d9cc1bcaaff023ba63e0748a2 | |
parent | 3907c6cf931af4e874cb217addd29b24063b6367 (diff) | |
download | gcc-4f90ee6c7780cab416adee0830074c9a315206d0.zip gcc-4f90ee6c7780cab416adee0830074c9a315206d0.tar.gz gcc-4f90ee6c7780cab416adee0830074c9a315206d0.tar.bz2 |
re PR fortran/67779 (Strange ordering with strings in extended object)
2016-01-10 Paul Thomas <pault@gcc.gnu.org>
PR fortran/67779
* trans_array.c (gfc_conv_scalarized_array_ref): Add missing
se->use_offset from condition for calculation of 'base'.
2016-01-10 Paul Thomas <pault@gcc.gnu.org>
PR fortran/67779
* gfortran.dg/actual_array_offset_1: New test.
From-SVN: r232200
-rw-r--r-- | gcc/fortran/ChangeLog | 6 | ||||
-rw-r--r-- | gcc/fortran/trans-array.c | 2 | ||||
-rw-r--r-- | gcc/testsuite/ChangeLog | 5 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/actual_array_offset_1.f90 | 167 |
4 files changed, 179 insertions, 1 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 485a4ae..c38c280 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2016-01-10 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/67779 + * trans_array.c (gfc_conv_scalarized_array_ref): Add missing + se->use_offset from condition for calculation of 'base'. + 2016-01-08 Jakub Jelinek <jakub@redhat.com> PR fortran/69128 diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 1c3768e..a46f103 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -7114,7 +7114,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) gfc_array_index_type, stride, info->stride[n]); - if (se->direct_byref + if ((se->direct_byref || se->use_offset) && ((info->ref && info->ref->u.ar.type != AR_FULL) || (expr->expr_type == EXPR_ARRAY && se->use_offset))) { diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index f8c4ed5..6ab64f7 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2016-01-10 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/67779 + * gfortran.dg/actual_array_offset_1: New test. + 2016-01-10 Tom de Vries <tom@codesourcery.com> PR tree-optimization/69062 diff --git a/gcc/testsuite/gfortran.dg/actual_array_offset_1.f90 b/gcc/testsuite/gfortran.dg/actual_array_offset_1.f90 new file mode 100644 index 0000000..f67bcfd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/actual_array_offset_1.f90 @@ -0,0 +1,167 @@ +! { dg-do run } +! +! Check the fix for PR67779, in which array sections passed in the +! recursive calls to 'quicksort' had an incorrect offset. +! +! Contributed by Arjen Markus <arjen.markus895@gmail.com> +! +! NOTE: This is the version of the testcase in comment #16 (from Thomas Koenig) +! +module myclass_def + implicit none + + type, abstract :: myclass + contains + procedure(assign_object), deferred :: copy + procedure(one_lower_than_two), deferred :: lower + procedure(print_object), deferred :: print + procedure, nopass :: quicksort ! without nopass, it does not work + end type myclass + + abstract interface + subroutine assign_object( left, right ) + import :: myclass + class(myclass), intent(inout) :: left + class(myclass), intent(in) :: right + end subroutine assign_object + end interface + + abstract interface + logical function one_lower_than_two( op1, op2 ) + import :: myclass + class(myclass), intent(in) :: op1, op2 + end function one_lower_than_two + end interface + + abstract interface + subroutine print_object( obj ) + import :: myclass + class(myclass), intent(in) :: obj + end subroutine print_object + end interface + + ! + ! Type containing a real + ! + + type, extends(myclass) :: mysortable + integer :: value + contains + procedure :: copy => copy_sortable + procedure :: lower => lower_sortable + procedure :: print => print_sortable + end type mysortable + +contains +! +! Generic part +! +recursive subroutine quicksort( array ) + class(myclass), dimension(:) :: array + + class(myclass), allocatable :: v, tmp + integer :: i, j + + integer :: k + + i = 1 + j = size(array) + + allocate( v, source = array(1) ) + allocate( tmp, source = array(1) ) + + call v%copy( array((j+i)/2) ) ! Use the middle element + + do + do while ( array(i)%lower(v) ) + i = i + 1 + enddo + do while ( v%lower(array(j)) ) + j = j - 1 + enddo + + if ( i <= j ) then + call tmp%copy( array(i) ) + call array(i)%copy( array(j) ) + call array(j)%copy( tmp ) + i = i + 1 + j = j - 1 + endif + + if ( i > j ) then + exit + endif + enddo + + if ( 1 < j ) then + call quicksort( array(1:j) ) ! Problem here + endif + + if ( i < size(array) ) then + call quicksort( array(i:) ) ! ....and here + endif +end subroutine quicksort + +! +! Specific part +! +subroutine copy_sortable( left, right ) + class(mysortable), intent(inout) :: left + class(myclass), intent(in) :: right + + select type (right) + type is (mysortable) + select type (left) + type is (mysortable) + left = right + end select + end select +end subroutine copy_sortable + +logical function lower_sortable( op1, op2 ) + class(mysortable), intent(in) :: op1 + class(myclass), intent(in) :: op2 + + select type (op2) + type is (mysortable) + lower_sortable = op1%value < op2%value + end select +end function lower_sortable + +subroutine print_sortable( obj ) + class(mysortable), intent(in) :: obj + + write(*,'(G0," ")', advance="no") obj%value +end subroutine print_sortable + +end module myclass_def + + +! test program +program test_quicksort + use myclass_def + + implicit none + + type(mysortable), dimension(20) :: array + real, dimension(20) :: values + + call random_number(values) + + array%value = int (1000000 * values) + +! It would be pretty perverse if this failed! + if (check (array)) call abort + + call quicksort( array ) + +! Check the the array is correctly ordered + if (.not.check (array)) call abort +contains + logical function check (arg) + type(mysortable), dimension(:) :: arg + integer :: s + s = size (arg, 1) + check = all (arg(2 : s)%value .ge. arg(1 : s - 1)%value) + end function check +end program test_quicksort |