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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 485a4ae5a1dee17df04c71891b70414391c54d1a..c38c28038d3aae1cac4e90274c79bac51fd45630 100644 (file)
--- 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 1c3768eaa6402dffb7a4633b0d23ee69073ead1f..a46f1034777975002d39edd35989f5515b0db122 100644 (file)
--- 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 f8c4ed5ccd758ac7b9e9c986624464b5405f63fa..6ab64f74cc354f58085d8a5e6a906b71f5957998 100644 (file)
--- 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 (file)
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