gcc/testsuite/gfortran.dg/class_48.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/51972
   4 ! Also tests fixes for PR52102
   5 !
   6 ! Check whether DT assignment with polymorphic components works.
   7 !
   8
   9 subroutine test1 ()
  10   type t
  11     integer :: x
  12   end type t
  13
  14   type t2
  15     class(t), allocatable :: a
  16   end type t2
  17
  18   type(t2) :: one, two
  19
  20   one = two
  21   if (allocated (one%a)) call abort ()
  22
  23   allocate (two%a)
  24   two%a%x = 7890
  25   one = two
  26   if (one%a%x /= 7890) call abort ()
  27
  28   deallocate (two%a)
  29   one = two
  30   if (allocated (one%a)) call abort ()
  31 end subroutine test1
  32
  33 subroutine test2 ()
  34   type t
  35     integer, allocatable :: x(:)
  36   end type t
  37
  38   type t2
  39     class(t), allocatable :: a
  40   end type t2
  41
  42   type(t2) :: one, two
  43
  44   one = two
  45   if (allocated (one%a)) call abort ()
  46
  47   allocate (two%a)
  48   one = two
  49   if (.not.allocated (one%a)) call abort ()
  50   if (allocated (one%a%x)) call abort ()
  51
  52   allocate (two%a%x(2))
  53   two%a%x(:) = 7890
  54   one = two
  55   if (any (one%a%x /= 7890)) call abort ()
  56
  57   deallocate (two%a)
  58   one = two
  59   if (allocated (one%a)) call abort ()
  60 end subroutine test2
  61
  62
  63 subroutine test3 ()
  64   type t
  65     integer :: x
  66   end type t
  67
  68   type t2
  69     class(t), allocatable :: a(:)
  70   end type t2
  71
  72   type(t2) :: one, two
  73
  74 ! Test allocate with array source - PR52102
  75   allocate (two%a(2), source = [t(4), t(6)])
  76
  77   if (allocated (one%a)) call abort ()
  78
  79   one = two
  80   if (.not.allocated (one%a)) call abort ()
  81
  82   if ((one%a(1)%x /= 4)) call abort ()
  83   if ((one%a(2)%x /= 6)) call abort ()
  84
  85   deallocate (two%a)
  86   one = two
  87
  88   if (allocated (one%a)) call abort ()
  89
  90 ! Test allocate with no source followed by assignments.
  91   allocate (two%a(2))
  92   two%a(1)%x = 5
  93   two%a(2)%x = 7
  94
  95   if (allocated (one%a)) call abort ()
  96
  97   one = two
  98   if (.not.allocated (one%a)) call abort ()
  99
 100   if ((one%a(1)%x /= 5)) call abort ()
 101   if ((one%a(2)%x /= 7)) call abort ()
 102
 103   deallocate (two%a)
 104   one = two
 105   if (allocated (one%a)) call abort ()
 106 end subroutine test3
 107
 108 subroutine test4 ()
 109   type t
 110     integer, allocatable :: x(:)
 111   end type t
 112
 113   type t2
 114     class(t), allocatable :: a(:)
 115   end type t2
 116
 117   type(t2) :: one, two
 118
 119   if (allocated (one%a)) call abort ()
 120   if (allocated (two%a)) call abort ()
 121
 122   allocate (two%a(2))
 123
 124   if (allocated (two%a(1)%x)) call abort ()
 125   if (allocated (two%a(2)%x)) call abort ()
 126   allocate (two%a(1)%x(3), source=[1,2,3])
 127   allocate (two%a(2)%x(5), source=[5,6,7,8,9])
 128   one = two
 129   if (.not. allocated (one%a)) call abort ()
 130   if (.not. allocated (one%a(1)%x)) call abort ()
 131   if (.not. allocated (one%a(2)%x)) call abort ()
 132
 133   if (size(one%a) /= 2) call abort()
 134   if (size(one%a(1)%x) /= 3) call abort()
 135   if (size(one%a(2)%x) /= 5) call abort()
 136   if (any (one%a(1)%x /= [1,2,3])) call abort ()
 137   if (any (one%a(2)%x /= [5,6,7,8,9])) call abort ()
 138
 139   deallocate (two%a(1)%x)
 140   one = two
 141   if (.not. allocated (one%a)) call abort ()
 142   if (allocated (one%a(1)%x)) call abort ()
 143   if (.not. allocated (one%a(2)%x)) call abort ()
 144
 145   if (size(one%a) /= 2) call abort()
 146   if (size(one%a(2)%x) /= 5) call abort()
 147   if (any (one%a(2)%x /= [5,6,7,8,9])) call abort ()
 148
 149   deallocate (two%a)
 150   one = two
 151   if (allocated (one%a)) call abort ()
 152   if (allocated (two%a)) call abort ()
 153 end subroutine test4
 154
 155
 156 call test1 ()
 157 call test2 ()
 158 call test3 ()
 159 call test4 ()
 160 end
 161