1! { dg-do run } 2! 3! Check the fix for PR67779, in which array sections passed in the 4! recursive calls to 'quicksort' had an incorrect offset. 5! 6! Contributed by Arjen Markus <arjen.markus895@gmail.com> 7! 8! NOTE: This is the version of the testcase in comment #16 (from Thomas Koenig) 9! 10module myclass_def 11 implicit none 12 13 type, abstract :: myclass 14 contains 15 procedure(assign_object), deferred :: copy 16 procedure(one_lower_than_two), deferred :: lower 17 procedure(print_object), deferred :: print 18 procedure, nopass :: quicksort ! without nopass, it does not work 19 end type myclass 20 21 abstract interface 22 subroutine assign_object( left, right ) 23 import :: myclass 24 class(myclass), intent(inout) :: left 25 class(myclass), intent(in) :: right 26 end subroutine assign_object 27 end interface 28 29 abstract interface 30 logical function one_lower_than_two( op1, op2 ) 31 import :: myclass 32 class(myclass), intent(in) :: op1, op2 33 end function one_lower_than_two 34 end interface 35 36 abstract interface 37 subroutine print_object( obj ) 38 import :: myclass 39 class(myclass), intent(in) :: obj 40 end subroutine print_object 41 end interface 42 43 ! 44 ! Type containing a real 45 ! 46 47 type, extends(myclass) :: mysortable 48 integer :: value 49 contains 50 procedure :: copy => copy_sortable 51 procedure :: lower => lower_sortable 52 procedure :: print => print_sortable 53 end type mysortable 54 55contains 56! 57! Generic part 58! 59recursive subroutine quicksort( array ) 60 class(myclass), dimension(:) :: array 61 62 class(myclass), allocatable :: v, tmp 63 integer :: i, j 64 65 integer :: k 66 67 i = 1 68 j = size(array) 69 70 allocate( v, source = array(1) ) 71 allocate( tmp, source = array(1) ) 72 73 call v%copy( array((j+i)/2) ) ! Use the middle element 74 75 do 76 do while ( array(i)%lower(v) ) 77 i = i + 1 78 enddo 79 do while ( v%lower(array(j)) ) 80 j = j - 1 81 enddo 82 83 if ( i <= j ) then 84 call tmp%copy( array(i) ) 85 call array(i)%copy( array(j) ) 86 call array(j)%copy( tmp ) 87 i = i + 1 88 j = j - 1 89 endif 90 91 if ( i > j ) then 92 exit 93 endif 94 enddo 95 96 if ( 1 < j ) then 97 call quicksort( array(1:j) ) ! Problem here 98 endif 99 100 if ( i < size(array) ) then 101 call quicksort( array(i:) ) ! ....and here 102 endif 103end subroutine quicksort 104 105! 106! Specific part 107! 108subroutine copy_sortable( left, right ) 109 class(mysortable), intent(inout) :: left 110 class(myclass), intent(in) :: right 111 112 select type (right) 113 type is (mysortable) 114 select type (left) 115 type is (mysortable) 116 left = right 117 end select 118 end select 119end subroutine copy_sortable 120 121logical function lower_sortable( op1, op2 ) 122 class(mysortable), intent(in) :: op1 123 class(myclass), intent(in) :: op2 124 125 select type (op2) 126 type is (mysortable) 127 lower_sortable = op1%value < op2%value 128 end select 129end function lower_sortable 130 131subroutine print_sortable( obj ) 132 class(mysortable), intent(in) :: obj 133 134 write(*,'(G0," ")', advance="no") obj%value 135end subroutine print_sortable 136 137end module myclass_def 138 139 140! test program 141program test_quicksort 142 use myclass_def 143 144 implicit none 145 146 type(mysortable), dimension(20) :: array 147 real, dimension(20) :: values 148 149 call random_number(values) 150 151 array%value = int (1000000 * values) 152 153! It would be pretty perverse if this failed! 154 if (check (array)) call abort 155 156 call quicksort( array ) 157 158! Check the the array is correctly ordered 159 if (.not.check (array)) call abort 160contains 161 logical function check (arg) 162 type(mysortable), dimension(:) :: arg 163 integer :: s 164 s = size (arg, 1) 165 check = all (arg(2 : s)%value .ge. arg(1 : s - 1)%value) 166 end function check 167end program test_quicksort 168