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