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 ()