gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90

! { dg-do run }
! Tests the patch to implement the array version of the TRANSFER
! intrinsic (PR17298).
! Contributed by Paul Thomas  <pault@gcc.gnu.org>

! Bigendian test posted by Perseus in comp.lang.fortran on 4 July 2005.
! Original had parameter but this fails, at present, if is_gimple_var with -Ox, x>0

   LOGICAL :: bigend
   integer :: icheck = 1

   character(8) :: ch(2) = (/"lmnoPQRS","LMNOpqrs"/)

   bigend = IACHAR(TRANSFER(icheck,"a")) == 0

! tests numeric transfers other than original testscase.

   call test1 ()

! tests numeric/character transfers.

   call test2 ()

! Test dummies, automatic objects and assumed character length.

   call test3 (ch, ch, ch, 8)

contains

   subroutine test1 ()
     real(4) :: a(4, 4)
     integer(2) :: it(4, 2, 4), jt(32)

! Check multi-dimensional sources and that transfer works as an actual
! argument of reshape.

     a = reshape ((/(rand (), i = 1, 16)/), (/4,4/))
     jt = transfer (a, it)
     it = reshape (jt, (/4, 2, 4/))
     if (any (reshape (transfer (it, a), (/4,4/)) .ne. a)) STOP 1

   end subroutine test1

   subroutine test2 ()
     integer(4) :: y(4), z(2)
     character(4) :: ch(4)

! Allow for endian-ness
     if (bigend) then
       y = (/(i + 3 + ishft (i + 2, 8) + ishft (i + 1, 16) &
                + ishft (i, 24), i = 65, 80 , 4)/)
     else 
       y = (/(i + ishft (i + 1, 8) + ishft (i + 2, 16) &
                + ishft (i + 3, 24), i = 65, 80 , 4)/)
     end if

! Check source array sections in both directions.

     ch = "wxyz"
     ch(1:2) = transfer (y(2:4:2), ch)
     if (any (ch(1:2) .ne. (/"EFGH","MNOP"/))) STOP 2
     ch = "wxyz"
     ch(1:2) = transfer (y(4:2:-2), ch)
     if (any (ch(1:2) .ne. (/"MNOP","EFGH"/))) STOP 3

! Check that a complete array transfers with size absent.

     ch = transfer (y, ch)
     if (any (ch .ne. (/"ABCD","EFGH","IJKL","MNOP"/))) STOP 4

! Check that a character array section is OK

     z = transfer (ch(2:3), y)
     if (any (z .ne. y(2:3))) STOP 5

! Check dest array sections in both directions.

     ch = "wxyz"
     ch(3:4) = transfer (y, ch, 2)
     if (any (ch(3:4) .ne. (/"ABCD","EFGH"/))) STOP 6
     ch = "wxyz"
     ch(3:2:-1) = transfer (y, ch, 2)
     if (any (ch(2:3) .ne. (/"EFGH","ABCD"/))) STOP 7

! Make sure that character to numeric is OK.

     ch = "wxyz"
     ch(1:2) = transfer (y, ch, 2)
     if (any (ch(1:2) .ne. (/"ABCD","EFGH"/))) STOP 8

     z = transfer (ch, y, 2)
     if (any (y(1:2) .ne. z)) STOP 9

   end subroutine test2

   subroutine test3 (ch1, ch2, ch3, clen)
     integer clen
     character(8) :: ch1(:)
     character(*) :: ch2(2)
     character(clen) :: ch3(2)
     character(8) :: cntrl(2) = (/"lmnoPQRS","LMNOpqrs"/)
     integer(8) :: ic(2)
     ic = transfer (cntrl, ic)

! Check assumed shape.

     if (any (ic .ne. transfer (ch1, ic))) STOP 10

! Check assumed character length.

     if (any (ic .ne. transfer (ch2, ic))) STOP 11

! Check automatic character length.

     if (any (ic .ne. transfer (ch3, ic))) STOP 12

  end subroutine test3

end