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") STOP 1
  28             if (len(P1) .ne. 20) STOP 2
  29             if (len(P1) .eq. len("some test string")) STOP 3
  30         class default
  31             STOP 4
  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") STOP 5
  39             if (len(A1) .ne. 20) STOP 6
  40             if (len(A1) .eq. len("some test string")) STOP 7
  41         class default
  42             STOP 8
  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") STOP 9
  50             if (len(A2) .ne. 20) STOP 10
  51             if (len(A2) .eq. len("some test string")) STOP 11
  52         class default
  53             STOP 12
  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") STOP 13
  61             if (len(P2) .eq. 20) STOP 14
  62             if (len(P2) .ne. len("string for test")) STOP 15
  63         class default
  64             STOP 16
  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") STOP 17
  72             if (len(P3) .eq. 20) STOP 18
  73             if (len(P3) .ne. len("string for test")) STOP 19
  74         class default
  75             STOP 20
  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 ") STOP 21
  84             if (any(len(PA1(:)) .ne. [10,10,10])) STOP 22
  85         class default
  86             STOP 23
  87     end select
  88
  89     deallocate(PA1)
  90     deallocate(P3)
  91 !   if (len(P3) .ne. 0) STOP 24 ! 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") STOP 25
 106             if (len(P1) .ne. 20) STOP 26
 107             if (len(P1) .eq. len("some test string")) STOP 27
 108         type is (character(len=*,kind=1))
 109             STOP 28
 110         class default
 111             STOP 29
 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") STOP 30
 119             if (len(A1) .ne. 20) STOP 31
 120             if (len(A1) .eq. len("some test string")) STOP 32
 121         type is (character(len=*,kind=1))
 122             STOP 33
 123         class default
 124             STOP 34
 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") STOP 35
 132             if (len(A2) .ne. 20) STOP 36
 133             if (len(A2) .eq. len("some test string")) STOP 37
 134         class default
 135             STOP 38
 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") STOP 39
 143             if (len(P2) .eq. 20) STOP 40
 144             if (len(P2) .ne. len("string for test")) STOP 41
 145         class default
 146             STOP 42
 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") STOP 43
 154             if (len(P3) .eq. 20) STOP 44
 155             if (len(P3) .ne. len("string for test")) STOP 45
 156         class default
 157             STOP 46
 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 ") STOP 47
 166             if (any(len(PA1(:)) .ne. [10,10,10])) STOP 48
 167         class default
 168             STOP 49
 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') STOP 50
 183       class default
 184         STOP 51
 185     end select
 186     select type (d => o2%content)
 187       type is (character(*))
 188         if (d /= 'test string') STOP 52
 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') STOP 53
 210       class default
 211         STOP 54
 212     end select
 213   end subroutine
 214
 215 end program test