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
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
|
! { dg-do run }
! Tests the patch to implement the array version of the TRANSFER
! intrinsic (PR17298).
! Contributed by Paul Thomas <pault@gcc.gnu.org>
! Bigendian test posted by Perseus in comp.lang.fortran on 4 July 2005.
! Original had parameter but this fails, at present, if is_gimple_var with -Ox, x>0
LOGICAL :: bigend
integer :: icheck = 1
character(8) :: ch(2) = (/"lmnoPQRS","LMNOpqrs"/)
bigend = IACHAR(TRANSFER(icheck,"a")) == 0
! tests numeric transfers other than original testscase.
call test1 ()
! tests numeric/character transfers.
call test2 ()
! Test dummies, automatic objects and assumed character length.
call test3 (ch, ch, ch, 8)
contains
subroutine test1 ()
real(4) :: a(4, 4)
integer(2) :: it(4, 2, 4), jt(32)
! Check multi-dimensional sources and that transfer works as an actual
! argument of reshape.
a = reshape ((/(rand (), i = 1, 16)/), (/4,4/))
jt = transfer (a, it)
it = reshape (jt, (/4, 2, 4/))
if (any (reshape (transfer (it, a), (/4,4/)) .ne. a)) call abort ()
end subroutine test1
subroutine test2 ()
integer(4) :: y(4), z(2)
character(4) :: ch(4)
! Allow for endian-ness
if (bigend) then
y = (/(i + 3 + ishft (i + 2, 8) + ishft (i + 1, 16) &
+ ishft (i, 24), i = 65, 80 , 4)/)
else
y = (/(i + ishft (i + 1, 8) + ishft (i + 2, 16) &
+ ishft (i + 3, 24), i = 65, 80 , 4)/)
end if
! Check source array sections in both directions.
ch = "wxyz"
ch(1:2) = transfer (y(2:4:2), ch)
if (any (ch(1:2) .ne. (/"EFGH","MNOP"/))) call abort ()
ch = "wxyz"
ch(1:2) = transfer (y(4:2:-2), ch)
if (any (ch(1:2) .ne. (/"MNOP","EFGH"/))) call abort ()
! Check that a complete array transfers with size absent.
ch = transfer (y, ch)
if (any (ch .ne. (/"ABCD","EFGH","IJKL","MNOP"/))) call abort ()
! Check that a character array section is OK
z = transfer (ch(2:3), y)
if (any (z .ne. y(2:3))) call abort ()
! Check dest array sections in both directions.
ch = "wxyz"
ch(3:4) = transfer (y, ch, 2)
if (any (ch(3:4) .ne. (/"ABCD","EFGH"/))) call abort ()
ch = "wxyz"
ch(3:2:-1) = transfer (y, ch, 2)
if (any (ch(2:3) .ne. (/"EFGH","ABCD"/))) call abort ()
! Make sure that character to numeric is OK.
ch = "wxyz"
ch(1:2) = transfer (y, ch, 2)
if (any (ch(1:2) .ne. (/"ABCD","EFGH"/))) call abort ()
z = transfer (ch, y)
if (any (y(1:2) .ne. z)) call abort ()
end subroutine test2
subroutine test3 (ch1, ch2, ch3, clen)
integer clen
character(8) :: ch1(:)
character(*) :: ch2(2)
character(clen) :: ch3(2)
character(8) :: cntrl(2) = (/"lmnoPQRS","LMNOpqrs"/)
integer(8) :: ic(2)
ic = transfer (cntrl, ic)
! Check assumed shape.
if (any (ic .ne. transfer (ch1, ic))) call abort ()
! Check assumed character length.
if (any (ic .ne. transfer (ch2, ic))) call abort ()
! Check automatic character length.
if (any (ic .ne. transfer (ch3, ic))) call abort ()
end subroutine test3
end
|
