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)) STOP 1
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"/))) STOP 2
62     ch = "wxyz"
63     ch(1:2) = transfer (y(4:2:-2), ch)
64     if (any (ch(1:2) .ne. (/"MNOP","EFGH"/))) STOP 3
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"/))) STOP 4
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))) STOP 5
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"/))) STOP 6
81     ch = "wxyz"
82     ch(3:2:-1) = transfer (y, ch, 2)
83     if (any (ch(2:3) .ne. (/"EFGH","ABCD"/))) STOP 7
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"/))) STOP 8
90
91     z = transfer (ch, y, 2)
92     if (any (y(1:2) .ne. z)) STOP 9
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))) STOP 10
108
109! Check assumed character length.
110
111     if (any (ic .ne. transfer (ch2, ic))) STOP 11
112
113! Check automatic character length.
114
115     if (any (ic .ne. transfer (ch3, ic))) STOP 12
116
117  end subroutine test3
118
119end
120