1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
|
! { 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
|
