gcc/testsuite/gfortran.dg/allocate_deferred_char_scalar_1.f03

   1 ! { dg-do run }
   2 !
   3 ! Automatic reallocate on assignment, deferred length parameter for char
   4 !
   5 ! PR fortran/45170
   6 ! PR fortran/35810
   7 ! PR fortran/47350
   8 !
   9 ! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
  10 !
  11 program test
  12   implicit none
  13   call mold_check()
  14   call mold_check4()
  15   call source_check()
  16   call source_check4()
  17   call ftn_test()
  18   call ftn_test4()
  19   call source3()
  20 contains
  21   subroutine source_check()
  22     character(len=:), allocatable :: str, str2
  23     target :: str
  24     character(len=8) :: str3
  25     character(len=:), pointer :: str4, str5
  26     nullify(str4)
  27     str3 = 'AbCdEfGhIj'
  28     if(allocated(str)) call abort()
  29     allocate(str, source=str3)
  30     if(.not.allocated(str)) call abort()
  31     if(len(str) /= 8) call abort()
  32     if(str /= 'AbCdEfGh') call abort()
  33     if(associated(str4)) call abort()
  34     str4 => str
  35     if(str4 /= str .or. len(str4)/=8) call abort()
  36     if(.not.associated(str4, str)) call abort()
  37     str4 => null()
  38     str = '12a56b78'
  39     if(str4 == '12a56b78') call abort()
  40     str4 = 'ABCDEFGH'
  41     if(str == 'ABCDEFGH') call abort()
  42     allocate(str5, source=str)
  43     if(associated(str5, str)) call abort()
  44     if(str5 /= '12a56b78' .or. len(str5)/=8) call abort()
  45     str = 'abcdef'
  46     if(str5 == 'abcdef') call abort()
  47     str5 = 'ABCDEF'
  48     if(str == 'ABCDEF') call abort()
  49   end subroutine source_check
  50   subroutine source_check4()
  51     character(kind=4,len=:), allocatable :: str, str2
  52     target :: str
  53     character(kind=4,len=8) :: str3
  54     character(kind=4,len=:), pointer :: str4, str5
  55     nullify(str4)
  56     str3 = 4_'AbCdEfGhIj'
  57     if(allocated(str)) call abort()
  58     allocate(str, source=str3)
  59     if(.not.allocated(str)) call abort()
  60     if(len(str) /= 8) call abort()
  61     if(str /= 4_'AbCdEfGh') call abort()
  62     if(associated(str4)) call abort()
  63     str4 => str
  64     if(str4 /= str .or. len(str4)/=8) call abort()
  65     if(.not.associated(str4, str)) call abort()
  66     str4 => null()
  67     str = 4_'12a56b78'
  68     if(str4 == 4_'12a56b78') call abort()
  69     str4 = 4_'ABCDEFGH'
  70     if(str == 4_'ABCDEFGH') call abort()
  71     allocate(str5, source=str)
  72     if(associated(str5, str)) call abort()
  73     if(str5 /= 4_'12a56b78' .or. len(str5)/=8) call abort()
  74     str = 4_'abcdef'
  75     if(str5 == 4_'abcdef') call abort()
  76     str5 = 4_'ABCDEF'
  77     if(str == 4_'ABCDEF') call abort()
  78   end subroutine source_check4
  79   subroutine mold_check()
  80     character(len=:), allocatable :: str, str2
  81     character(len=8) :: str3
  82     character(len=:), pointer :: str4, str5
  83     nullify(str4)
  84     str2 = "ABCE"
  85     ALLOCATE( str, MOLD=str3)
  86     if (len(str) /= 8) call abort()
  87     DEALLOCATE(str)
  88     ALLOCATE( str, MOLD=str2)
  89     if (len(str) /= 4) call abort()
  90
  91     IF (associated(str4)) call abort()
  92     ALLOCATE( str4, MOLD=str3)
  93     IF (.not.associated(str4)) call abort()
  94     str4 = '12345678'
  95     if (len(str4) /= 8) call abort()
  96     if(str4 /= '12345678') call abort()
  97     DEALLOCATE(str4)
  98     ALLOCATE( str4, MOLD=str2)
  99     str4 = 'ABCD'
 100     if (len(str4) /= 4) call abort()
 101     if (str4 /= 'ABCD') call abort()
 102     str5 => str4
 103     if(.not.associated(str4,str5)) call abort()
 104     if(len(str5) /= 4 .or. len(str4) /= len(str5)) call abort()
 105     if(str5 /= str4) call abort()
 106     deallocate(str4)
 107   end subroutine mold_check
 108   subroutine mold_check4()
 109     character(len=:,kind=4), allocatable :: str, str2
 110     character(len=8,kind=4) :: str3
 111     character(len=:,kind=4), pointer :: str4, str5
 112     nullify(str4)
 113     str2 = 4_"ABCE"
 114     ALLOCATE( str, MOLD=str3)
 115     if (len(str) /= 8) call abort()
 116     DEALLOCATE(str)
 117     ALLOCATE( str, MOLD=str2)
 118     if (len(str) /= 4) call abort()
 119
 120     IF (associated(str4)) call abort()
 121     ALLOCATE( str4, MOLD=str3)
 122     IF (.not.associated(str4)) call abort()
 123     str4 = 4_'12345678'
 124     if (len(str4) /= 8) call abort()
 125     if(str4 /= 4_'12345678') call abort()
 126     DEALLOCATE(str4)
 127     ALLOCATE( str4, MOLD=str2)
 128     str4 = 4_'ABCD'
 129     if (len(str4) /= 4) call abort()
 130     if (str4 /= 4_'ABCD') call abort()
 131     str5 => str4
 132     if(.not.associated(str4,str5)) call abort()
 133     if(len(str5) /= 4 .or. len(str4) /= len(str5)) call abort()
 134     if(str5 /= str4) call abort()
 135     deallocate(str4)
 136   end subroutine mold_check4
 137   subroutine ftn_test()
 138     character(len=:), allocatable :: str_a
 139     character(len=:), pointer     :: str_p
 140     nullify(str_p)
 141     call proc_test(str_a, str_p, .false.)
 142     if (str_p /= '123457890abcdef') call abort()
 143     if (len(str_p) /= 50) call abort()
 144     if (str_a(1:5) /= 'ABCDE ') call abort()
 145     if (len(str_a) /= 50) call abort()
 146     deallocate(str_p)
 147     str_a = '1245'
 148     if(len(str_a) /= 4) call abort()
 149     if(str_a /= '1245') call abort()
 150     allocate(character(len=6) :: str_p)
 151     if(len(str_p) /= 6) call abort()
 152     str_p = 'AbCdEf'
 153     call proc_test(str_a, str_p, .true.)
 154     if (str_p /= '123457890abcdef') call abort()
 155     if (len(str_p) /= 50) call abort()
 156     if (str_a(1:5) /= 'ABCDE ') call abort()
 157     if (len(str_a) /= 50) call abort()
 158     deallocate(str_p)
 159   end subroutine ftn_test
 160   subroutine proc_test(a, p, alloc)
 161     character(len=:), allocatable :: a
 162     character(len=:), pointer     :: p
 163     character(len=5), target :: loc
 164     logical :: alloc
 165     if (.not.  alloc) then
 166       if(associated(p)) call abort()
 167       if(allocated(a)) call abort()
 168     else
 169       if(len(a) /= 4) call abort()
 170       if(a /= '1245') call abort()
 171       if(len(p) /= 6) call abort()
 172       if(p /= 'AbCdEf') call abort()
 173       deallocate(a)
 174       nullify(p)
 175     end if
 176     allocate(character(len=50) :: a)
 177     a(1:5) = 'ABCDE'
 178     if(len(a) /= 50) call abort()
 179     if(a(1:5) /= "ABCDE") call abort()
 180     loc = '12345'
 181     p => loc
 182     if (len(p) /= 5) call abort()
 183     if (p /= '12345') call abort()
 184     p = '12345679'
 185     if (len(p) /= 5) call abort()
 186     if (p /= '12345') call abort()
 187     p = 'ABC'
 188     if (loc /= 'ABC  ') call abort()
 189     allocate(p, mold=a)
 190     if (.not.associated(p)) call abort()
 191     p = '123457890abcdef'
 192     if (p /= '123457890abcdef') call abort()
 193     if (len(p) /= 50) call abort()
 194   end subroutine proc_test
 195   subroutine ftn_test4()
 196     character(len=:,kind=4), allocatable :: str_a
 197     character(len=:,kind=4), pointer     :: str_p
 198     nullify(str_p)
 199     call proc_test4(str_a, str_p, .false.)
 200     if (str_p /= 4_'123457890abcdef') call abort()
 201     if (len(str_p) /= 50) call abort()
 202     if (str_a(1:5) /= 4_'ABCDE ') call abort()
 203     if (len(str_a) /= 50) call abort()
 204     deallocate(str_p)
 205     str_a = 4_'1245'
 206     if(len(str_a) /= 4) call abort()
 207     if(str_a /= 4_'1245') call abort()
 208     allocate(character(len=6, kind = 4) :: str_p)
 209     if(len(str_p) /= 6) call abort()
 210     str_p = 4_'AbCdEf'
 211     call proc_test4(str_a, str_p, .true.)
 212     if (str_p /= 4_'123457890abcdef') call abort()
 213     if (len(str_p) /= 50) call abort()
 214     if (str_a(1:5) /= 4_'ABCDE ') call abort()
 215     if (len(str_a) /= 50) call abort()
 216     deallocate(str_p)
 217   end subroutine ftn_test4
 218   subroutine proc_test4(a, p, alloc)
 219     character(len=:,kind=4), allocatable :: a
 220     character(len=:,kind=4), pointer     :: p
 221     character(len=5,kind=4), target :: loc
 222     logical :: alloc
 223     if (.not.  alloc) then
 224       if(associated(p)) call abort()
 225       if(allocated(a)) call abort()
 226     else
 227       if(len(a) /= 4) call abort()
 228       if(a /= 4_'1245') call abort()
 229       if(len(p) /= 6) call abort()
 230       if(p /= 4_'AbCdEf') call abort()
 231       deallocate(a)
 232       nullify(p)
 233     end if
 234     allocate(character(len=50,kind=4) :: a)
 235     a(1:5) = 4_'ABCDE'
 236     if(len(a) /= 50) call abort()
 237     if(a(1:5) /= 4_"ABCDE") call abort()
 238     loc = '12345'
 239     p => loc
 240     if (len(p) /= 5) call abort()
 241     if (p /= 4_'12345') call abort()
 242     p = 4_'12345679'
 243     if (len(p) /= 5) call abort()
 244     if (p /= 4_'12345') call abort()
 245     p = 4_'ABC'
 246     if (loc /= 4_'ABC  ') call abort()
 247     allocate(p, mold=a)
 248     if (.not.associated(p)) call abort()
 249     p = 4_'123457890abcdef'
 250     if (p /= 4_'123457890abcdef') call abort()
 251     if (len(p) /= 50) call abort()
 252   end subroutine proc_test4
 253   subroutine source3()
 254      character(len=:, kind=1), allocatable :: a1
 255      character(len=:, kind=4), allocatable :: a4
 256      character(len=:, kind=1), pointer     :: p1
 257      character(len=:, kind=4), pointer     :: p4
 258      allocate(a1, source='ABC') ! << ICE
 259      if(len(a1) /= 3 .or. a1 /= 'ABC') call abort()
 260      allocate(a4, source=4_'12345') ! << ICE
 261      if(len(a4) /= 5 .or. a4 /= 4_'12345') call abort()
 262      allocate(p1, mold='AB') ! << ICE
 263      if(len(p1) /= 2) call abort()
 264      allocate(p4, mold=4_'145') ! << ICE
 265      if(len(p4) /= 3) call abort()
 266   end subroutine source3
 267 end program test