blob: 27a94dca1ed551253b74971807797f7359881720 [file] [log] [blame]
! { dg-do run }
!
! class based quick sort program - starting point comment #0 of pr41539
!
! Note assignment with vector index reference fails because temporary
! allocation does not occur - also false dependency detected. Nullification
! of temp descriptor data causes a segfault.
!
module m_qsort
implicit none
type, abstract :: sort_t
contains
procedure(disp), deferred :: disp
procedure(lt_cmp), deferred :: lt_cmp
procedure(assign), deferred :: assign
generic :: operator(<) => lt_cmp
generic :: assignment(=) => assign
end type sort_t
interface
elemental integer function disp(a)
import
class(sort_t), intent(in) :: a
end function disp
end interface
interface
impure elemental logical function lt_cmp(a,b)
import
class(sort_t), intent(in) :: a, b
end function lt_cmp
end interface
interface
impure elemental subroutine assign(a,b)
import
class(sort_t), intent(out) :: a
class(sort_t), intent(in) :: b
end subroutine assign
end interface
contains
subroutine qsort(a)
class(sort_t), intent(inout),allocatable :: a(:)
class(sort_t), allocatable :: tmp (:)
integer, allocatable :: index_array (:)
integer :: i
allocate (tmp(size (a, 1)), source = a)
index_array = [(i, i = 1, size (a, 1))]
call internal_qsort (tmp, index_array) ! Do not move class elements around until end
a = tmp(index_array)
end subroutine qsort
recursive subroutine internal_qsort (x, iarray)
class(sort_t), intent(inout),allocatable :: x(:)
class(sort_t), allocatable :: ptr
integer, allocatable :: iarray(:), above(:), below(:), itmp(:)
integer :: pivot, nelem, i, iptr
if (.not.allocated (iarray)) return
nelem = size (iarray, 1)
if (nelem .le. 1) return
pivot = nelem / 2
allocate (ptr, source = x(iarray(pivot))) ! Pointer to the pivot element
do i = 1, nelem
iptr = iarray(i) ! Index for i'th element
if (ptr%lt_cmp (x(iptr))) then ! Compare pivot with i'th element
itmp = [iptr]
above = concat (itmp, above) ! Invert order to prevent infinite loops
else
itmp = [iptr]
below = concat (itmp, below) ! -ditto-
end if
end do
call internal_qsort (x, above) ! Recursive sort of 'above' and 'below'
call internal_qsort (x, below)
iarray = concat (below, above) ! Concatenate the result
end subroutine internal_qsort
function concat (ia, ib) result (ic)
integer, allocatable, dimension(:) :: ia, ib, ic
if (allocated (ia) .and. allocated (ib)) then
ic = [ia, ib]
else if (allocated (ia)) then
ic = ia
else if (allocated (ib)) then
ic = ib
end if
end function concat
end module m_qsort
module test
use m_qsort
implicit none
type, extends(sort_t) :: sort_int_t
integer :: i
contains
procedure :: disp => disp_int
procedure :: lt_cmp => lt_cmp_int
procedure :: assign => assign_int
end type
contains
elemental integer function disp_int(a)
class(sort_int_t), intent(in) :: a
disp_int = a%i
end function disp_int
impure elemental subroutine assign_int (a, b)
class(sort_int_t), intent(out) :: a
class(sort_t), intent(in) :: b ! TODO: gfortran does not throw 'class(sort_int_t)'
select type (b)
class is (sort_int_t)
a%i = b%i
class default
a%i = -1
end select
end subroutine assign_int
impure elemental logical function lt_cmp_int(a,b) result(cmp)
class(sort_int_t), intent(in) :: a
class(sort_t), intent(in) :: b
select type(b)
type is(sort_int_t)
if (a%i < b%i) then
cmp = .true.
else
cmp = .false.
end if
class default
ERROR STOP "Don't compare apples with oranges"
end select
end function lt_cmp_int
end module test
program main
use test
class(sort_t), allocatable :: A(:)
integer :: i, m(5)= [7 , 4, 5, 2, 3]
allocate (A(5), source = [(sort_int_t(m(i)), i=1,5)])
! print *, "Before qsort: ", A%disp()
call qsort(A)
! print *, "After qsort: ", A%disp()
if (any (A%disp() .ne. [2,3,4,5,7])) STOP 1
end program main