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