aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.9/gcc/testsuite/gfortran.dg/class_array_3.f03
blob: 6db375c9425bd82e927204b2ab778f2201ec191f (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
! { 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
   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
 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])) call abort
end program main