! { dg-do run }
|
! { dg-do run }
|
! Test assignments of derived type with allocatable components (PR 20541).
|
! Test assignments of derived type with allocatable components (PR 20541).
|
!
|
!
|
! Contributed by Erik Edelmann
|
! Contributed by Erik Edelmann
|
! and Paul Thomas
|
! and Paul Thomas
|
!
|
!
|
type :: ivs
|
type :: ivs
|
character(1), allocatable :: chars(:)
|
character(1), allocatable :: chars(:)
|
end type ivs
|
end type ivs
|
|
|
type(ivs) :: a, b
|
type(ivs) :: a, b
|
type(ivs) :: x(3), y(3)
|
type(ivs) :: x(3), y(3)
|
|
|
allocate(a%chars(5))
|
allocate(a%chars(5))
|
a%chars = (/"h","e","l","l","o"/)
|
a%chars = (/"h","e","l","l","o"/)
|
|
|
! An intrinsic assignment must deallocate the l-value and copy across
|
! An intrinsic assignment must deallocate the l-value and copy across
|
! the array from the r-value.
|
! the array from the r-value.
|
b = a
|
b = a
|
if (any (b%chars .ne. (/"h","e","l","l","o"/))) call abort ()
|
if (any (b%chars .ne. (/"h","e","l","l","o"/))) call abort ()
|
if (allocated (a%chars) .eqv. .false.) call abort ()
|
if (allocated (a%chars) .eqv. .false.) call abort ()
|
|
|
! Scalar to array needs to copy the derived type, to its ultimate components,
|
! Scalar to array needs to copy the derived type, to its ultimate components,
|
! to each of the l-value elements. */
|
! to each of the l-value elements. */
|
x = b
|
x = b
|
x(2)%chars = (/"g","'","d","a","y"/)
|
x(2)%chars = (/"g","'","d","a","y"/)
|
if (any (x(1)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
|
if (any (x(1)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
|
if (any (x(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
|
if (any (x(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
|
if (allocated (b%chars) .eqv. .false.) call abort ()
|
if (allocated (b%chars) .eqv. .false.) call abort ()
|
deallocate (x(1)%chars, x(2)%chars, x(3)%chars)
|
deallocate (x(1)%chars, x(2)%chars, x(3)%chars)
|
|
|
! Array intrinsic assignments are like their scalar counterpart and
|
! Array intrinsic assignments are like their scalar counterpart and
|
! must deallocate each element of the l-value and copy across the
|
! must deallocate each element of the l-value and copy across the
|
! arrays from the r-value elements.
|
! arrays from the r-value elements.
|
allocate(x(1)%chars(5), x(2)%chars(5), x(3)%chars(5))
|
allocate(x(1)%chars(5), x(2)%chars(5), x(3)%chars(5))
|
x(1)%chars = (/"h","e","l","l","o"/)
|
x(1)%chars = (/"h","e","l","l","o"/)
|
x(2)%chars = (/"g","'","d","a","y"/)
|
x(2)%chars = (/"g","'","d","a","y"/)
|
x(3)%chars = (/"g","o","d","a","g"/)
|
x(3)%chars = (/"g","o","d","a","g"/)
|
y(2:1:-1) = x(1:2)
|
y(2:1:-1) = x(1:2)
|
if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
|
if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
|
if (any (y(2)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
|
if (any (y(2)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
|
if (any (x(3)%chars .ne. (/"g","o","d","a","g"/))) call abort ()
|
if (any (x(3)%chars .ne. (/"g","o","d","a","g"/))) call abort ()
|
|
|
! In the case of an assignment where there is a dependency, so that a
|
! In the case of an assignment where there is a dependency, so that a
|
! temporary is necessary, each element must be copied to its
|
! temporary is necessary, each element must be copied to its
|
! destination after it has been deallocated.
|
! destination after it has been deallocated.
|
y(2:3) = y(1:2)
|
y(2:3) = y(1:2)
|
if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
|
if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
|
if (any (y(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
|
if (any (y(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
|
if (any (y(3)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
|
if (any (y(3)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
|
|
|
! An identity assignment must not do any deallocation....!
|
! An identity assignment must not do any deallocation....!
|
y = y
|
y = y
|
if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
|
if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
|
if (any (y(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
|
if (any (y(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
|
if (any (y(3)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
|
if (any (y(3)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
|
end
|
end
|
|
|
