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