gcc/testsuite/gfortran.dg/class_assign_4.f90

   1 ! { dg-do run }
   2 !
   3 ! In the course of fixing PR83118, lots of issues came up with class array
   4 ! assignment, where temporaries are generated. This testcase checks that
   5 ! it all works correctly.
   6 !
   7 ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
   8 !
   9 module m
  10   implicit none
  11   type :: t1
  12     integer :: i
  13   CONTAINS
  14   end type
  15   type, extends(t1) :: t2
  16     real :: r
  17   end type
  18
  19   interface operator(+)
  20     module procedure add_t1
  21   end interface
  22
  23 contains
  24   function add_t1 (a, b) result (c)
  25     class(t1), intent(in) :: a(:), b(:)
  26     class(t1), allocatable :: c(:)
  27     allocate (c, source = a)
  28     c%i = a%i + b%i
  29     select type (c)
  30       type is (t2)
  31       select type (b)
  32         type is (t2)
  33           c%r = c%r + b%r
  34       end select
  35     end select
  36   end function add_t1
  37
  38 end module m
  39
  40 subroutine test_t1
  41   use m
  42   implicit none
  43
  44   class(t1), dimension(:), allocatable :: x, y
  45
  46   x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)]
  47   if (.not.check_t1 (x, [1,2,3], 2, [10, 20, 30]) ) stop 1
  48
  49   y = x
  50   x = realloc_t1 (y)
  51   if (.not.check_t1 (x, [3,2,1], 1) ) stop 2
  52
  53   x = realloc_t1 (x)
  54   if (.not.check_t1 (x, [2,3,1], 1) ) stop 3
  55
  56   x = x([3,1,2])
  57   if (.not.check_t1 (x, [1,2,3], 1) ) stop 4
  58
  59   x = x(3:1:-1) + y
  60   if (.not.check_t1 (x, [4,4,4], 1) ) stop 5
  61
  62   x = y + x(3:1:-1)
  63   if (.not.check_t1 (x, [5,6,7], 2) ) stop 6
  64
  65 ! Now check that the dynamic type survives assignments.
  66   x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)]
  67   y = x
  68
  69   x = y(3:1:-1)
  70   if (.not.check_t1 (x, [3,2,1], 2, [30,20,10]) ) stop 7
  71
  72   x = x(3:1:-1) + y
  73   if (.not.check_t1 (x, [2,4,6], 2, [20,40,60]) ) stop 8
  74
  75   x = x(3:1:-1)
  76   if (.not.check_t1 (x, [6,4,2], 2, [60,40,20]) ) stop 9
  77
  78   x = x([3,2,1])
  79   if (.not.check_t1 (x, [2,4,6], 2, [20,40,60]) ) stop 10
  80
  81 contains
  82
  83   function realloc_t1 (arg) result (res)
  84     class(t1), dimension(:), allocatable :: arg
  85     class(t1), dimension(:), allocatable :: res
  86     select type (arg)
  87       type is (t2)
  88         allocate (res, source = [t1 (arg(3)%i), t1 (arg(2)%i), t1 (arg(1)%i)])
  89       type is (t1)
  90         allocate (res, source = [t1 (arg(2)%i), t1 (arg(1)%i), t1 (arg(3)%i)])
  91     end select
  92   end function realloc_t1
  93
  94   logical function check_t1 (arg, array, t, array2)
  95     class(t1) :: arg(:)
  96     integer :: array (:), t
  97     integer, optional :: array2(:)
  98     check_t1 = .true.
  99     select type (arg)
 100     type is (t1)
 101       if (any (arg%i .ne. array)) check_t1 = .false.
 102       if (t .eq. 2) check_t1 = .false.
 103     type is (t2)
 104       if (any (arg%i .ne. array)) check_t1 = .false.
 105       if (t .eq. 1) check_t1 = .false.
 106       if (present (array2)) then
 107         if (any(int (arg%r) .ne. array2)) check_t1 = .false.
 108       end if
 109     class default
 110       check_t1 = .false.
 111     end select
 112   end function check_t1
 113
 114 end subroutine test_t1
 115
 116 subroutine test_star
 117   use m
 118   implicit none
 119
 120   class(*), dimension(:), allocatable :: x, y
 121
 122   x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)]
 123   if (.not.check_star (x, [1,2,3], 2) ) stop 11
 124
 125   y = x
 126   x = realloc_star (y)
 127   if (.not.check_star (x, [3,2,1], 1) ) stop 12
 128
 129   x = realloc_star (x)
 130   if (.not.check_star (x, [2,3,1], 1) ) stop 13
 131
 132   x = x([3,1,2])
 133   if (.not.check_star (x, [1,2,3], 1) ) stop 14
 134
 135   x = x(3:1:-1)
 136   if (.not.check_star (x, [3,2,1], 1) ) stop 15
 137
 138 ! Make sure that all is similarly well with type t2.
 139   x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)]
 140
 141   x = x([3,1,2])
 142   if (.not.check_star (x, [3,1,2], 2, [30,10,20]) ) stop 16
 143
 144   x = x(3:1:-1)
 145   if (.not.check_star (x, [2,1,3], 2, [20,10,30]) ) stop 17
 146
 147 contains
 148
 149   function realloc_star (arg) result (res)
 150     class(*), dimension(:), allocatable :: arg
 151     class(*), dimension(:), allocatable :: res
 152     select type (arg)
 153       type is (t2)
 154          allocate (res, source = [t1 (arg(3)%i), t1 (arg(2)%i), t1 (arg(1)%i)])
 155       type is (t1)
 156          allocate (res, source = [t1 (arg(2)%i), t1 (arg(1)%i), t1 (arg(3)%i)])
 157     end select
 158   end function realloc_star
 159
 160   logical function check_star (arg, array, t, array2)
 161     class(*) :: arg(:)
 162     integer :: array (:), t
 163     integer, optional :: array2(:)
 164     check_star = .true.
 165     select type (arg)
 166       type is (t1)
 167         if (any (arg%i .ne. array)) check_star = .false.
 168         if (t .eq. 2) check_star = .false.
 169       type is (t2)
 170         if (any (arg%i .ne. array)) check_star = .false.
 171         if (t .eq. 1) check_star = .false.
 172         if (present (array2)) then
 173           if (any (int(arg%r) .ne. array2)) check_star = .false.
 174         endif
 175       class default
 176         check_star = .false.
 177     end select
 178   end function check_star
 179
 180 end subroutine test_star
 181
 182
 183   call test_t1
 184   call test_star
 185 end