gcc/testsuite/gfortran.dg/actual_array_offset_1.f90

   1 ! { dg-do run }
   2 !
   3 ! Check the fix for PR67779, in which array sections passed in the
   4 ! recursive calls to 'quicksort' had an incorrect offset.
   5 !
   6 ! Contributed by Arjen Markus  <arjen.markus895@gmail.com>
   7 !
   8 ! NOTE: This is the version of the testcase in comment #16 (from Thomas Koenig)
   9 !
  10 module myclass_def
  11     implicit none
  12
  13     type, abstract :: myclass
  14     contains
  15         procedure(assign_object), deferred        :: copy
  16         procedure(one_lower_than_two), deferred   :: lower
  17         procedure(print_object), deferred         :: print
  18         procedure, nopass                         :: quicksort  ! without nopass, it does not work
  19     end type myclass
  20
  21     abstract interface
  22         subroutine assign_object( left, right )
  23             import                        :: myclass
  24             class(myclass), intent(inout) :: left
  25             class(myclass), intent(in)    :: right
  26         end subroutine assign_object
  27     end interface
  28
  29     abstract interface
  30         logical function one_lower_than_two( op1, op2 )
  31             import                     :: myclass
  32             class(myclass), intent(in) :: op1, op2
  33         end function one_lower_than_two
  34     end interface
  35
  36     abstract interface
  37         subroutine print_object( obj )
  38             import                     :: myclass
  39             class(myclass), intent(in) :: obj
  40         end subroutine print_object
  41     end interface
  42
  43     !
  44     ! Type containing a real
  45     !
  46
  47     type, extends(myclass) :: mysortable
  48         integer :: value
  49     contains
  50         procedure :: copy    => copy_sortable
  51         procedure :: lower   => lower_sortable
  52         procedure :: print   => print_sortable
  53     end type mysortable
  54
  55 contains
  56 !
  57 ! Generic part
  58 !
  59 recursive subroutine quicksort( array )
  60     class(myclass), dimension(:) :: array
  61
  62     class(myclass), allocatable :: v, tmp
  63     integer                     :: i, j
  64
  65     integer :: k
  66
  67     i = 1
  68     j = size(array)
  69
  70     allocate( v,   source = array(1) )
  71     allocate( tmp, source = array(1) )
  72
  73     call v%copy( array((j+i)/2) ) ! Use the middle element
  74
  75     do
  76         do while ( array(i)%lower(v) )
  77             i = i + 1
  78         enddo
  79         do while ( v%lower(array(j)) )
  80             j = j - 1
  81         enddo
  82
  83         if ( i <= j ) then
  84             call tmp%copy( array(i) )
  85             call array(i)%copy( array(j) )
  86             call array(j)%copy( tmp )
  87             i        = i + 1
  88             j        = j - 1
  89         endif
  90
  91         if ( i > j ) then
  92             exit
  93         endif
  94     enddo
  95
  96     if ( 1 < j ) then
  97         call quicksort( array(1:j) ) ! Problem here
  98     endif
  99
 100     if ( i < size(array) ) then
 101         call quicksort( array(i:) )  ! ....and here
 102     endif
 103 end subroutine quicksort
 104
 105 !
 106 ! Specific part
 107 !
 108 subroutine copy_sortable( left, right )
 109     class(mysortable), intent(inout) :: left
 110     class(myclass), intent(in)       :: right
 111
 112     select type (right)
 113         type is (mysortable)
 114             select type (left)
 115                 type is (mysortable)
 116                     left = right
 117             end select
 118     end select
 119 end subroutine copy_sortable
 120
 121 logical function lower_sortable( op1, op2 )
 122     class(mysortable), intent(in) :: op1
 123     class(myclass),    intent(in) :: op2
 124
 125     select type (op2)
 126         type is (mysortable)
 127             lower_sortable = op1%value < op2%value
 128     end select
 129 end function lower_sortable
 130
 131 subroutine print_sortable( obj )
 132     class(mysortable), intent(in) :: obj
 133
 134     write(*,'(G0," ")', advance="no") obj%value
 135 end subroutine print_sortable
 136
 137 end module myclass_def
 138
 139
 140 ! test program
 141 program test_quicksort
 142     use myclass_def
 143
 144     implicit none
 145
 146     type(mysortable), dimension(20) :: array
 147     real, dimension(20) :: values
 148
 149     call random_number(values)
 150
 151     array%value = int (1000000 * values)
 152
 153 ! It would be pretty perverse if this failed!
 154     if (check (array)) call abort
 155
 156     call quicksort( array )
 157
 158 ! Check the the array is correctly ordered
 159     if (.not.check (array)) call abort
 160 contains
 161      logical function check (arg)
 162          type(mysortable), dimension(:) :: arg
 163          integer                        :: s
 164          s = size (arg, 1)
 165          check = all (arg(2 : s)%value .ge. arg(1 : s - 1)%value)
 166      end function check
 167 end program test_quicksort