gcc/testsuite/gfortran.dg/alloc_comp_assign_1.f90

   1 ! { dg-do run }
   2 ! Test assignments of derived type with allocatable components (PR 20541).
   3 !
   4 ! Contributed by Erik Edelmann  <eedelmann@gcc.gnu.org>
   5 !            and Paul Thomas  <pault@gcc.gnu.org>
   6 !
   7   type :: ivs
   8     character(1), allocatable :: chars(:)
   9   end type ivs
  10
  11   type(ivs) :: a, b
  12   type(ivs) :: x(3), y(3)
  13
  14   allocate(a%chars(5))
  15   a%chars = (/"h","e","l","l","o"/)
  16
  17 ! An intrinsic assignment must deallocate the l-value and copy across
  18 ! the array from the r-value.
  19   b = a
  20   if (any (b%chars .ne. (/"h","e","l","l","o"/))) call abort ()
  21   if (allocated (a%chars) .eqv. .false.) call abort ()
  22
  23 ! Scalar to array needs to copy the derived type, to its ultimate components,
  24 ! to each of the l-value elements.  */
  25   x = b
  26   x(2)%chars = (/"g","'","d","a","y"/)
  27   if (any (x(1)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
  28   if (any (x(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
  29   if (allocated (b%chars) .eqv. .false.) call abort ()
  30   deallocate (x(1)%chars, x(2)%chars, x(3)%chars)
  31
  32 ! Array intrinsic assignments are like their scalar counterpart and
  33 ! must deallocate each element of the l-value and copy across the
  34 ! arrays from the r-value elements.
  35   allocate(x(1)%chars(5), x(2)%chars(5), x(3)%chars(5))
  36   x(1)%chars = (/"h","e","l","l","o"/)
  37   x(2)%chars = (/"g","'","d","a","y"/)
  38   x(3)%chars = (/"g","o","d","a","g"/)
  39   y(2:1:-1) = x(1:2)
  40   if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
  41   if (any (y(2)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
  42   if (any (x(3)%chars .ne. (/"g","o","d","a","g"/))) call abort ()
  43
  44 ! In the case of an assignment where there is a dependency, so that a
  45 ! temporary is necessary, each element must be copied to its
  46 ! destination after it has been deallocated.
  47   y(2:3) = y(1:2)
  48   if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
  49   if (any (y(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
  50   if (any (y(3)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
  51
  52 ! An identity assignment must not do any deallocation....!
  53   y = y
  54   if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
  55   if (any (y(2)%chars .ne. (/"g","'","d","a","y"/))) call abort ()
  56   if (any (y(3)%chars .ne. (/"h","e","l","l","o"/))) call abort ()
  57 end