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