2 ! Tests the patch to implement the array version of the TRANSFER
4 ! Contributed by Paul Thomas <pault@gcc.gnu.org>
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
12 character(8) :: ch(2) = (/"lmnoPQRS","LMNOpqrs"/)
14 bigend = IACHAR(TRANSFER(icheck,"a")) == 0
16 ! tests numeric transfers other than original testscase.
20 ! tests numeric/character transfers.
24 ! Test dummies, automatic objects and assumed character length.
26 call test3 (ch, ch, ch, 8)
32 integer(2) :: it(4, 2, 4), jt(32)
34 ! Check multi-dimensional sources and that transfer works as an actual
35 ! argument of reshape.
37 a = reshape ((/(rand (), i = 1, 16)/), (/4,4/))
39 it = reshape (jt, (/4, 2, 4/))
40 if (any (reshape (transfer (it, a), (/4,4/)) .ne. a)) call abort ()
45 integer(4) :: y(4), z(2)
48 ! Allow for endian-ness
50 y = (/(i + 3 + ishft (i + 2, 8) + ishft (i + 1, 16) &
51 + ishft (i, 24), i = 65, 80 , 4)/)
53 y = (/(i + ishft (i + 1, 8) + ishft (i + 2, 16) &
54 + ishft (i + 3, 24), i = 65, 80 , 4)/)
57 ! Check source array sections in both directions.
60 ch(1:2) = transfer (y(2:4:2), ch)
61 if (any (ch(1:2) .ne. (/"EFGH","MNOP"/))) call abort ()
63 ch(1:2) = transfer (y(4:2:-2), ch)
64 if (any (ch(1:2) .ne. (/"MNOP","EFGH"/))) call abort ()
66 ! Check that a complete array transfers with size absent.
69 if (any (ch .ne. (/"ABCD","EFGH","IJKL","MNOP"/))) call abort ()
71 ! Check that a character array section is OK
73 z = transfer (ch(2:3), y)
74 if (any (z .ne. y(2:3))) call abort ()
76 ! Check dest array sections in both directions.
79 ch(3:4) = transfer (y, ch, 2)
80 if (any (ch(3:4) .ne. (/"ABCD","EFGH"/))) call abort ()
82 ch(3:2:-1) = transfer (y, ch, 2)
83 if (any (ch(2:3) .ne. (/"EFGH","ABCD"/))) call abort ()
85 ! Make sure that character to numeric is OK.
88 ch(1:2) = transfer (y, ch, 2)
89 if (any (ch(1:2) .ne. (/"ABCD","EFGH"/))) call abort ()
92 if (any (y(1:2) .ne. z)) call abort ()
96 subroutine test3 (ch1, ch2, ch3, clen)
98 character(8) :: ch1(:)
99 character(*) :: ch2(2)
100 character(clen) :: ch3(2)
101 character(8) :: cntrl(2) = (/"lmnoPQRS","LMNOpqrs"/)
103 ic = transfer (cntrl, ic)
105 ! Check assumed shape.
107 if (any (ic .ne. transfer (ch1, ic))) call abort ()
109 ! Check assumed character length.
111 if (any (ic .ne. transfer (ch2, ic))) call abort ()
113 ! Check automatic character length.
115 if (any (ic .ne. transfer (ch3, ic))) call abort ()