1! { dg-do run }
2! Tests the patch to implement the array version of the TRANSFER
3! intrinsic (PR17298).
4! Contributed by Paul Thomas  <pault@gcc.gnu.org>
5
6! Bigendian test posted by Perseus in comp.lang.fortran on 4 July 2005.
7! Original had parameter but this fails, at present, if is_gimple_var with -Ox, x>0
8
9   LOGICAL :: bigend
10   integer :: icheck = 1
11
12   character(8) :: ch(2) = (/"lmnoPQRS","LMNOpqrs"/)
13
14   bigend = IACHAR(TRANSFER(icheck,"a")) == 0
15
16! tests numeric transfers other than original testscase.
17
18   call test1 ()
19
20! tests numeric/character transfers.
21
22   call test2 ()
23
24! Test dummies, automatic objects and assumed character length.
25
26   call test3 (ch, ch, ch, 8)
27
28contains
29
30   subroutine test1 ()
31     real(4) :: a(4, 4)
32     integer(2) :: it(4, 2, 4), jt(32)
33
34! Check multi-dimensional sources and that transfer works as an actual
35! argument of reshape.
36
37     a = reshape ((/(rand (), i = 1, 16)/), (/4,4/))
38     jt = transfer (a, it)
39     it = reshape (jt, (/4, 2, 4/))
40     if (any (reshape (transfer (it, a), (/4,4/)) .ne. a)) call abort ()
41
42   end subroutine test1
43
44   subroutine test2 ()
45     integer(4) :: y(4), z(2)
46     character(4) :: ch(4)
47
48! Allow for endian-ness
49     if (bigend) then
50       y = (/(i + 3 + ishft (i + 2, 8) + ishft (i + 1, 16) &
51                + ishft (i, 24), i = 65, 80 , 4)/)
52     else
53       y = (/(i + ishft (i + 1, 8) + ishft (i + 2, 16) &
54                + ishft (i + 3, 24), i = 65, 80 , 4)/)
55     end if
56
57! Check source array sections in both directions.
58
59     ch = "wxyz"
60     ch(1:2) = transfer (y(2:4:2), ch)
61     if (any (ch(1:2) .ne. (/"EFGH","MNOP"/))) call abort ()
62     ch = "wxyz"
63     ch(1:2) = transfer (y(4:2:-2), ch)
64     if (any (ch(1:2) .ne. (/"MNOP","EFGH"/))) call abort ()
65
66! Check that a complete array transfers with size absent.
67
68     ch = transfer (y, ch)
69     if (any (ch .ne. (/"ABCD","EFGH","IJKL","MNOP"/))) call abort ()
70
71! Check that a character array section is OK
72
73     z = transfer (ch(2:3), y)
74     if (any (z .ne. y(2:3))) call abort ()
75
76! Check dest array sections in both directions.
77
78     ch = "wxyz"
79     ch(3:4) = transfer (y, ch, 2)
80     if (any (ch(3:4) .ne. (/"ABCD","EFGH"/))) call abort ()
81     ch = "wxyz"
82     ch(3:2:-1) = transfer (y, ch, 2)
83     if (any (ch(2:3) .ne. (/"EFGH","ABCD"/))) call abort ()
84
85! Make sure that character to numeric is OK.
86
87     ch = "wxyz"
88     ch(1:2) = transfer (y, ch, 2)
89     if (any (ch(1:2) .ne. (/"ABCD","EFGH"/))) call abort ()
90
91     z = transfer (ch, y)
92     if (any (y(1:2) .ne. z)) call abort ()
93
94   end subroutine test2
95
96   subroutine test3 (ch1, ch2, ch3, clen)
97     integer clen
98     character(8) :: ch1(:)
99     character(*) :: ch2(2)
100     character(clen) :: ch3(2)
101     character(8) :: cntrl(2) = (/"lmnoPQRS","LMNOpqrs"/)
102     integer(8) :: ic(2)
103     ic = transfer (cntrl, ic)
104
105! Check assumed shape.
106
107     if (any (ic .ne. transfer (ch1, ic))) call abort ()
108
109! Check assumed character length.
110
111     if (any (ic .ne. transfer (ch2, ic))) call abort ()
112
113! Check automatic character length.
114
115     if (any (ic .ne. transfer (ch3, ic))) call abort ()
116
117  end subroutine test3
118
119end
120