1! { dg-do run }
2!
3! class based quick sort program - starting point comment #0 of pr41539
4!
5! Note assignment with vector index reference fails because temporary
6! allocation does not occur - also false dependency detected. Nullification
7! of temp descriptor data causes a segfault.
8!
9module m_qsort
10 implicit none
11 type, abstract :: sort_t
12 contains
13   procedure(disp), deferred :: disp
14   procedure(lt_cmp), deferred :: lt_cmp
15   procedure(assign), deferred :: assign
16   generic :: operator(<) => lt_cmp
17   generic :: assignment(=) => assign
18 end type sort_t
19 interface
20   elemental integer function disp(a)
21     import
22     class(sort_t), intent(in) :: a
23   end function disp
24 end interface
25 interface
26   impure elemental logical function lt_cmp(a,b)
27     import
28     class(sort_t), intent(in) :: a, b
29   end function lt_cmp
30 end interface
31 interface
32   impure elemental subroutine assign(a,b)
33     import
34     class(sort_t), intent(out) :: a
35     class(sort_t), intent(in) :: b
36   end subroutine assign
37 end interface
38contains
39
40 subroutine qsort(a)
41   class(sort_t), intent(inout),allocatable :: a(:)
42   class(sort_t), allocatable :: tmp (:)
43   integer, allocatable :: index_array (:)
44   integer :: i
45   allocate (tmp(size (a, 1)), source = a)
46   index_array = [(i, i = 1, size (a, 1))]
47   call internal_qsort (tmp, index_array)   ! Do not move class elements around until end
48   a = tmp(index_array)
49 end subroutine qsort
50
51 recursive subroutine internal_qsort (x, iarray)
52   class(sort_t), intent(inout),allocatable :: x(:)
53   class(sort_t), allocatable :: ptr
54   integer, allocatable :: iarray(:), above(:), below(:), itmp(:)
55   integer :: pivot, nelem, i, iptr
56   if (.not.allocated (iarray)) return
57   nelem = size (iarray, 1)
58   if (nelem .le. 1) return
59   pivot = nelem / 2
60   allocate (ptr, source = x(iarray(pivot))) ! Pointer to the pivot element
61   do i = 1, nelem
62     iptr = iarray(i)                  ! Index for i'th element
63     if (ptr%lt_cmp (x(iptr))) then    ! Compare pivot with i'th element
64       itmp = [iptr]
65       above = concat (itmp, above)    ! Invert order to prevent infinite loops
66     else
67       itmp = [iptr]
68       below = concat (itmp, below)    ! -ditto-
69     end if
70   end do
71   call internal_qsort (x, above)      ! Recursive sort of 'above' and 'below'
72   call internal_qsort (x, below)
73   iarray = concat (below, above)      ! Concatenate the result
74 end subroutine internal_qsort
75
76 function concat (ia, ib) result (ic)
77   integer, allocatable, dimension(:) :: ia, ib, ic
78   if (allocated (ia) .and. allocated (ib)) then
79     ic = [ia, ib]
80   else if (allocated (ia)) then
81     ic = ia
82   else if (allocated (ib)) then
83     ic = ib
84   end if
85 end function concat
86end module m_qsort
87
88module test
89 use m_qsort
90 implicit none
91 type, extends(sort_t) :: sort_int_t
92   integer :: i
93 contains
94   procedure :: disp => disp_int
95   procedure :: lt_cmp => lt_cmp_int
96   procedure :: assign => assign_int
97 end type
98contains
99 elemental integer function disp_int(a)
100     class(sort_int_t), intent(in) :: a
101     disp_int = a%i
102 end function disp_int
103 impure elemental subroutine assign_int (a, b)
104   class(sort_int_t), intent(out) :: a
105   class(sort_t), intent(in) :: b         ! TODO: gfortran does not throw 'class(sort_int_t)'
106   select type (b)
107     class is (sort_int_t)
108       a%i = b%i
109     class default
110       a%i = -1
111   end select
112 end subroutine assign_int
113 impure elemental logical function lt_cmp_int(a,b) result(cmp)
114   class(sort_int_t), intent(in) :: a
115   class(sort_t), intent(in) :: b
116   select type(b)
117     type is(sort_int_t)
118       if (a%i < b%i) then
119         cmp = .true.
120       else
121         cmp = .false.
122       end if
123     class default
124       ERROR STOP "Don't compare apples with oranges"
125   end select
126 end function lt_cmp_int
127end module test
128
129program main
130 use test
131 class(sort_t), allocatable :: A(:)
132 integer :: i, m(5)= [7 , 4, 5, 2, 3]
133 allocate (A(5), source = [(sort_int_t(m(i)), i=1,5)])
134!  print *, "Before qsort: ", A%disp()
135 call qsort(A)
136!  print *, "After qsort:  ", A%disp()
137 if (any (A%disp() .ne. [2,3,4,5,7])) STOP 1
138end program main
139