gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90

   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
  28 contains
  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
 119 end