gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90

   1 ! { dg-do run { target i?86-*-* x86_64-*-* } }
   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    character(8) :: ch(2) = (/"lmnoPQRS","LMNOpqrs"/)
   7
   8 ! tests numeric transfers(including PR testcase).
   9
  10    call test1 ()
  11
  12 ! tests numeric/character transfers.
  13
  14    call test2 ()
  15
  16 ! Test dummies, automatic objects and assumed character length.
  17
  18    call test3 (ch, ch, ch, 8)
  19
  20 contains
  21
  22    subroutine test1 ()
  23      complex(4) :: z = (1.0, 2.0)
  24      real(4) :: cmp(2), a(4, 4)
  25      integer(2) :: it(4, 2, 4), jt(32)
  26
  27 ! The PR testcase.
  28
  29      cmp = transfer (z, cmp) * 2.0
  30      if (any (cmp .ne. (/2.0, 4.0/))) call abort ()
  31
  32 ! Check that size smaller than the source word length is OK.
  33
  34      z = (-1.0, -2.0)
  35      cmp = transfer (z, cmp, 1) * 8.0
  36      if (any (cmp .ne. (/-8.0, 4.0/))) call abort ()
  37
  38 ! Check multi-dimensional sources and that transfer works as an actual
  39 ! argument of reshape.
  40
  41      a = reshape ((/(rand (), i = 1, 16)/), (/4,4/))
  42      jt = transfer (a, it)
  43      it = reshape (jt, (/4, 2, 4/))
  44      if (any (reshape (transfer (it, a), (/4,4/)) .ne. a)) call abort ()
  45
  46    end subroutine test1
  47
  48    subroutine test2 ()
  49      integer(4) :: y(4), z(2)
  50      character(4) :: ch(4)
  51      y = (/(i + ishft (i + 1, 8) + ishft (i + 2, 16) &
  52               + ishft (i + 3, 24), i = 65, 80 , 4)/)
  53
  54 ! Check source array sections in both directions.
  55
  56      ch = "wxyz"
  57      ch = transfer (y(2:4:2), ch)
  58      if (any (ch .ne. (/"EFGH","MNOP","wxyz","wxyz"/))) call abort ()
  59      ch = "wxyz"
  60      ch = transfer (y(4:2:-2), ch)
  61      if (any (ch .ne. (/"MNOP","EFGH","wxyz","wxyz"/))) call abort ()
  62
  63 ! Check that a complete array transfers with size absent.
  64
  65      ch = transfer (y, ch)
  66      if (any (ch .ne. (/"ABCD","EFGH","IJKL","MNOP"/))) call abort ()
  67
  68 ! Check that a character array section is OK
  69
  70      z = transfer (ch(2:3), y)
  71      if (any (z .ne. y(2:3))) call abort ()
  72
  73 ! Check dest array sections in both directions.
  74
  75      ch = "wxyz"
  76      ch(3:4) = transfer (y, ch, 2)
  77      if (any (ch .ne. (/"wxyz","wxyz","ABCD","EFGH"/))) call abort ()
  78      ch = "wxyz"
  79      ch(3:2:-1) = transfer (y, ch, 3)
  80      if (any (ch .ne. (/"wxyz","EFGH","ABCD","wxyz"/))) call abort ()
  81
  82 ! Check that too large a value of size is cut off.
  83
  84      ch = "wxyz"
  85      ch(1:2) = transfer (y, ch, 3)
  86      if (any (ch .ne. (/"ABCD","EFGH","wxyz","wxyz"/))) call abort ()
  87
  88 ! Make sure that character to numeric is OK.
  89
  90      z = transfer (ch, y)
  91      if (any (y(1:2) .ne. z)) call abort ()
  92
  93    end subroutine test2
  94
  95    subroutine test3 (ch1, ch2, ch3, clen)
  96      integer clen
  97      character(8) :: ch1(:)
  98      character(*) :: ch2(2)
  99      character(clen) :: ch3(2)
 100      character(8) :: cntrl(2) = (/"lmnoPQRS","LMNOpqrs"/)
 101      integer(8) :: ic(2)
 102      ic = transfer (cntrl, ic)
 103
 104 ! Check assumed shape.
 105
 106      if (any (ic .ne. transfer (ch1, ic))) call abort ()
 107
 108 ! Check assumed character length.
 109
 110      if (any (ic .ne. transfer (ch2, ic))) call abort ()
 111
 112 ! Check automatic character length.
 113
 114      if (any (ic .ne. transfer (ch3, ic))) call abort ()
 115
 116   end subroutine test3
 117
 118 end