blob: 2a77d8111b57f8adc698f8bf337119eda22bb5cf [file] [log] [blame]
! { dg-do run }
!
! In the course of fixing PR83118, lots of issues came up with class array
! assignment, where temporaries are generated. This testcase checks that
! it all works correctly.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
module m
implicit none
type :: t1
integer :: i
CONTAINS
end type
type, extends(t1) :: t2
real :: r
end type
interface operator(+)
module procedure add_t1
end interface
contains
function add_t1 (a, b) result (c)
class(t1), intent(in) :: a(:), b(:)
class(t1), allocatable :: c(:)
allocate (c, source = a)
c%i = a%i + b%i
select type (c)
type is (t2)
select type (b)
type is (t2)
c%r = c%r + b%r
end select
end select
end function add_t1
end module m
subroutine test_t1
use m
implicit none
class(t1), dimension(:), allocatable :: x, y
x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)]
if (.not.check_t1 (x, [1,2,3], 2, [10, 20, 30]) ) stop 1
y = x
x = realloc_t1 (y)
if (.not.check_t1 (x, [3,2,1], 1) ) stop 2
x = realloc_t1 (x)
if (.not.check_t1 (x, [2,3,1], 1) ) stop 3
x = x([3,1,2])
if (.not.check_t1 (x, [1,2,3], 1) ) stop 4
x = x(3:1:-1) + y
if (.not.check_t1 (x, [4,4,4], 1) ) stop 5
x = y + x(3:1:-1)
if (.not.check_t1 (x, [5,6,7], 2) ) stop 6
! Now check that the dynamic type survives assignments.
x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)]
y = x
x = y(3:1:-1)
if (.not.check_t1 (x, [3,2,1], 2, [30,20,10]) ) stop 7
x = x(3:1:-1) + y
if (.not.check_t1 (x, [2,4,6], 2, [20,40,60]) ) stop 8
x = x(3:1:-1)
if (.not.check_t1 (x, [6,4,2], 2, [60,40,20]) ) stop 9
x = x([3,2,1])
if (.not.check_t1 (x, [2,4,6], 2, [20,40,60]) ) stop 10
contains
function realloc_t1 (arg) result (res)
class(t1), dimension(:), allocatable :: arg
class(t1), dimension(:), allocatable :: res
select type (arg)
type is (t2)
allocate (res, source = [t1 (arg(3)%i), t1 (arg(2)%i), t1 (arg(1)%i)])
type is (t1)
allocate (res, source = [t1 (arg(2)%i), t1 (arg(1)%i), t1 (arg(3)%i)])
end select
end function realloc_t1
logical function check_t1 (arg, array, t, array2)
class(t1) :: arg(:)
integer :: array (:), t
integer, optional :: array2(:)
check_t1 = .true.
select type (arg)
type is (t1)
if (any (arg%i .ne. array)) check_t1 = .false.
if (t .eq. 2) check_t1 = .false.
type is (t2)
if (any (arg%i .ne. array)) check_t1 = .false.
if (t .eq. 1) check_t1 = .false.
if (present (array2)) then
if (any(int (arg%r) .ne. array2)) check_t1 = .false.
end if
class default
check_t1 = .false.
end select
end function check_t1
end subroutine test_t1
subroutine test_star
use m
implicit none
class(*), dimension(:), allocatable :: x, y
x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)]
if (.not.check_star (x, [1,2,3], 2) ) stop 11
y = x
x = realloc_star (y)
if (.not.check_star (x, [3,2,1], 1) ) stop 12
x = realloc_star (x)
if (.not.check_star (x, [2,3,1], 1) ) stop 13
x = x([3,1,2])
if (.not.check_star (x, [1,2,3], 1) ) stop 14
x = x(3:1:-1)
if (.not.check_star (x, [3,2,1], 1) ) stop 15
! Make sure that all is similarly well with type t2.
x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)]
x = x([3,1,2])
if (.not.check_star (x, [3,1,2], 2, [30,10,20]) ) stop 16
x = x(3:1:-1)
if (.not.check_star (x, [2,1,3], 2, [20,10,30]) ) stop 17
contains
function realloc_star (arg) result (res)
class(*), dimension(:), allocatable :: arg
class(*), dimension(:), allocatable :: res
select type (arg)
type is (t2)
allocate (res, source = [t1 (arg(3)%i), t1 (arg(2)%i), t1 (arg(1)%i)])
type is (t1)
allocate (res, source = [t1 (arg(2)%i), t1 (arg(1)%i), t1 (arg(3)%i)])
end select
end function realloc_star
logical function check_star (arg, array, t, array2)
class(*) :: arg(:)
integer :: array (:), t
integer, optional :: array2(:)
check_star = .true.
select type (arg)
type is (t1)
if (any (arg%i .ne. array)) check_star = .false.
if (t .eq. 2) check_star = .false.
type is (t2)
if (any (arg%i .ne. array)) check_star = .false.
if (t .eq. 1) check_star = .false.
if (present (array2)) then
if (any (int(arg%r) .ne. array2)) check_star = .false.
endif
class default
check_star = .false.
end select
end function check_star
end subroutine test_star
call test_t1
call test_star
end