gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90

   1 ! { dg-do run }
   2 ! Testing fix for PR fortran/60289
   3 ! Contributed by: Andre Vehreschild <vehre@gmx.de>
   4 !
   5 program test
   6     implicit none
   7
   8     class(*), pointer :: P1, P2, P3
   9     class(*), pointer, dimension(:) :: PA1
  10     class(*), allocatable :: A1, A2
  11     integer :: string_len = 10 *2
  12     character(len=:), allocatable, target :: str
  13     character(len=:,kind=4), allocatable :: str4
  14     type T
  15         class(*), pointer :: content
  16     end type
  17     type(T) :: o1, o2
  18
  19     str = "string for test"
  20     str4 = 4_"string for test"
  21
  22     allocate(character(string_len)::P1)
  23
  24     select type(P1)
  25         type is (character(*))
  26             P1 ="some test string"
  27             if (P1 .ne. "some test string") call abort ()
  28             if (len(P1) .ne. 20) call abort ()
  29             if (len(P1) .eq. len("some test string")) call abort ()
  30         class default
  31             call abort ()
  32     end select
  33
  34     allocate(A1, source = P1)
  35
  36     select type(A1)
  37         type is (character(*))
  38             if (A1 .ne. "some test string") call abort ()
  39             if (len(A1) .ne. 20) call abort ()
  40             if (len(A1) .eq. len("some test string")) call abort ()
  41         class default
  42             call abort ()
  43     end select
  44
  45     allocate(A2, source = convertType(P1))
  46
  47     select type(A2)
  48         type is (character(*))
  49             if (A2 .ne. "some test string") call abort ()
  50             if (len(A2) .ne. 20) call abort ()
  51             if (len(A2) .eq. len("some test string")) call abort ()
  52         class default
  53             call abort ()
  54     end select
  55
  56     allocate(P2, source = str)
  57
  58     select type(P2)
  59         type is (character(*))
  60             if (P2 .ne. "string for test") call abort ()
  61             if (len(P2) .eq. 20) call abort ()
  62             if (len(P2) .ne. len("string for test")) call abort ()
  63         class default
  64             call abort ()
  65     end select
  66
  67     allocate(P3, source = "string for test")
  68
  69     select type(P3)
  70         type is (character(*))
  71             if (P3 .ne. "string for test") call abort ()
  72             if (len(P3) .eq. 20) call abort ()
  73             if (len(P3) .ne. len("string for test")) call abort ()
  74         class default
  75             call abort ()
  76     end select
  77
  78     allocate(character(len=10)::PA1(3))
  79
  80     select type(PA1)
  81         type is (character(*))
  82             PA1(1) = "string 10 "
  83             if (PA1(1) .ne. "string 10 ") call abort ()
  84             if (any(len(PA1(:)) .ne. [10,10,10])) call abort ()
  85         class default
  86             call abort ()
  87     end select
  88
  89     deallocate(PA1)
  90     deallocate(P3)
  91 !   if (len(P3) .ne. 0) call abort() ! Can't check, because select
  92 !     type would be needed, which needs the vptr, which is 0 now.
  93     deallocate(P2)
  94     deallocate(A2)
  95     deallocate(A1)
  96     deallocate(P1)
  97
  98     ! Now for kind=4 chars.
  99
 100     allocate(character(len=20,kind=4)::P1)
 101
 102     select type(P1)
 103         type is (character(len=*,kind=4))
 104             P1 ="some test string"
 105             if (P1 .ne. 4_"some test string") call abort ()
 106             if (len(P1) .ne. 20) call abort ()
 107             if (len(P1) .eq. len("some test string")) call abort ()
 108         type is (character(len=*,kind=1))
 109             call abort ()
 110         class default
 111             call abort ()
 112     end select
 113
 114     allocate(A1, source=P1)
 115
 116     select type(A1)
 117         type is (character(len=*,kind=4))
 118             if (A1 .ne. 4_"some test string") call abort ()
 119             if (len(A1) .ne. 20) call abort ()
 120             if (len(A1) .eq. len("some test string")) call abort ()
 121         type is (character(len=*,kind=1))
 122             call abort ()
 123         class default
 124             call abort ()
 125     end select
 126
 127     allocate(A2, source = convertType(P1))
 128
 129     select type(A2)
 130         type is (character(len=*, kind=4))
 131             if (A2 .ne. 4_"some test string") call abort ()
 132             if (len(A2) .ne. 20) call abort ()
 133             if (len(A2) .eq. len("some test string")) call abort ()
 134         class default
 135             call abort ()
 136     end select
 137
 138     allocate(P2, source = str4)
 139
 140     select type(P2)
 141         type is (character(len=*,kind=4))
 142             if (P2 .ne. 4_"string for test") call abort ()
 143             if (len(P2) .eq. 20) call abort ()
 144             if (len(P2) .ne. len("string for test")) call abort ()
 145         class default
 146             call abort ()
 147     end select
 148
 149     allocate(P3, source = convertType(P2))
 150
 151     select type(P3)
 152         type is (character(len=*, kind=4))
 153             if (P3 .ne. 4_"string for test") call abort ()
 154             if (len(P3) .eq. 20) call abort ()
 155             if (len(P3) .ne. len("string for test")) call abort ()
 156         class default
 157             call abort ()
 158     end select
 159
 160     allocate(character(kind=4, len=10)::PA1(3))
 161
 162     select type(PA1)
 163         type is (character(len=*, kind=4))
 164             PA1(1) = 4_"string 10 "
 165             if (PA1(1) .ne. 4_"string 10 ") call abort ()
 166             if (any(len(PA1(:)) .ne. [10,10,10])) call abort ()
 167         class default
 168             call abort ()
 169     end select
 170
 171     deallocate(PA1)
 172     deallocate(P3)
 173     deallocate(P2)
 174     deallocate(A2)
 175     deallocate(P1)
 176     deallocate(A1)
 177
 178     allocate(o1%content, source='test string')
 179     allocate(o2%content, source=o1%content)
 180     select type (c => o1%content)
 181       type is (character(*))
 182         if (c /= 'test string') call abort ()
 183       class default
 184         call abort()
 185     end select
 186     select type (d => o2%content)
 187       type is (character(*))
 188         if (d /= 'test string') call abort ()
 189       class default
 190     end select
 191
 192     call AddCopy ('test string')
 193
 194 contains
 195
 196   function convertType(in)
 197     class(*), pointer, intent(in) :: in
 198     class(*), pointer :: convertType
 199
 200     convertType => in
 201   end function
 202
 203   subroutine AddCopy(C)
 204     class(*), intent(in) :: C
 205     class(*), pointer :: P
 206     allocate(P, source=C)
 207     select type (P)
 208       type is (character(*))
 209         if (P /= 'test string') call abort()
 210       class default
 211         call abort()
 212     end select
 213   end subroutine
 214
 215 end program test