gcc/testsuite/gfortran.dg/class_array_3.f03

   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 !
   9 module 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
  38 contains
  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
  86 end module m_qsort
  87
  88 module 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
  98 contains
  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
 127 end module test
 128
 129 program 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])) call abort
 138 end program main