| ! { dg-do run } |
| ! |
| ! Fix TRANSFER intrinsic for unlimited polymorphic SOURCEs - PR98534 |
| ! Note that unlimited polymorphic MOLD is a TODO. |
| ! |
| ! Contributed by Paul Thomas <pault@gcc.gnu.org> |
| ! |
| use, intrinsic :: ISO_FORTRAN_ENV, only: real32 |
| implicit none |
| character(*), parameter :: string = "abcdefgh" |
| character(len=:), allocatable :: string_a(:) |
| class(*), allocatable :: star |
| class(*), allocatable :: star_a(:) |
| character(len=:), allocatable :: chr |
| character(len=:), allocatable :: chr_a(:) |
| integer :: sz, sum1, sum2, i |
| real(real32) :: r = 1.0 |
| |
| ! Part 1: worked correctly |
| star = r |
| sz = storage_size (star)/8 |
| allocate (character(len=sz) :: chr) |
| chr = transfer (star, chr) |
| sum1 = sum ([(ichar(chr(i:i)), i = 1, sz)]) |
| chr = transfer(1.0, chr) |
| sum2 = sum ([(ichar(chr(i:i)), i = 1, sz)]) |
| |
| if (sz /= storage_size (r)/8) stop 1 |
| if (sum1 /= sum2) stop 2 |
| |
| deallocate (star) ! The automatic reallocation causes invalid writes |
| ! and memory leaks. Even with this deallocation |
| ! The invalid writes still occur. |
| deallocate (chr) |
| |
| ! Part 2: Got everything wrong because '_len' field of unlimited polymorphic |
| ! expressions was not used. |
| star = string |
| sz = storage_size (star)/8 |
| if (sz /= len (string)) stop 3 ! storage_size failed |
| |
| sz = len (string) ! Ignore previous error in storage_size |
| allocate (character(len=sz) :: chr) |
| chr = transfer (star, chr) |
| sum1 = sum ([(ichar(chr(i:i)), i = 1, sz)]) |
| chr = transfer(string, chr) |
| sum2 = sum ([(ichar(chr(i:i)), i = 1, sz)]) |
| if (sum1 /= sum2) stop 4 ! transfer failed |
| |
| ! Check that arrays are OK for transfer |
| star_a = ['abcde','fghij'] |
| allocate (character (len = 5) :: chr_a(2)) |
| chr_a = transfer (star_a, chr_a) |
| if (any (chr_a .ne. ['abcde','fghij'])) stop 5 |
| |
| ! Check that string length and size are correctly handled |
| string_a = ["abcdefgh", "ijklmnop"] |
| star_a = string_a; |
| chr_a = transfer (star_a, chr_a) ! Old string length used for size |
| if (size(chr_a) .ne. 4) stop 6 |
| if (len(chr_a) .ne. 5) stop 7 |
| if (trim (chr_a(3)) .ne. "klmno") stop 8 |
| if (chr_a(4)(1:1) .ne. "p") stop 9 |
| |
| chr_a = transfer (star_a, string_a) ! Use correct string_length for payload |
| if (size(chr_a) .ne. 2) stop 10 |
| if (len(chr_a) .ne. 8) stop 11 |
| if (any (chr_a .ne. string_a)) stop 12 |
| |
| ! Check that an unlimited polymorphic function result is transferred OK |
| deallocate (chr_a) |
| string_a = ['abc', 'def', 'hij'] |
| chr_a = transfer (foo (string_a), string_a) |
| if (any (chr_a .ne. string_a)) stop 13 |
| |
| ! Finally, check that the SIZE gives correct results with unlimited sources. |
| chr_a = transfer (star_a, chr_a, 4) |
| if (chr_a (4) .ne. 'jkl') stop 14 |
| |
| deallocate (star, chr, star_a, chr_a, string_a) |
| contains |
| function foo (arg) result(res) |
| character(*), intent(in) :: arg(:) |
| class(*), allocatable :: res(:) |
| res = arg |
| end |
| end |