gcc/fortran:

[pf3gnuchains/gcc-fork.git] / gcc / testsuite / gfortran.dg / transfer_array_intrinsic_2.f90

diff --git a/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90 b/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90
index a787440..aaa10f8 100644 (file)
--- a/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90
+++ b/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90
@@ -1,23 +1,119 @@
-! { dg-do run { target i?86-*-* x86_64-*-* } }
-! { dg-options "-fpack-derived" }
-   call test3()
+! { 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 test3 ()
-     type mytype
-       sequence
-       real(8) :: x = 3.14159
-       character(4) :: ch = "wxyz"
-       integer(2) :: i = 77
-     end type mytype
-     type(mytype) :: z(2)
-     character(1) :: c(32)
-     character(4) :: chr
-     real(8) :: a
-     integer(2) :: l
-     equivalence (a, c(15)), (chr, c(23)), (l, c(27))
-     c = transfer(z, c)
-     if (a .ne. z(1)%x) call abort ()
-     if (chr .ne. z(1)%ch) call abort ()
-     if (l .ne. z(1)%i) call abort ()
-   end subroutine test3
+
+   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)) call abort ()
+
+   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"/))) call abort ()
+     ch = "wxyz"
+     ch(1:2) = transfer (y(4:2:-2), ch)
+     if (any (ch(1:2) .ne. (/"MNOP","EFGH"/))) call abort ()
+
+! Check that a complete array transfers with size absent.
+
+     ch = transfer (y, ch)
+     if (any (ch .ne. (/"ABCD","EFGH","IJKL","MNOP"/))) call abort ()
+
+! Check that a character array section is OK
+
+     z = transfer (ch(2:3), y)
+     if (any (z .ne. y(2:3))) call abort ()
+
+! Check dest array sections in both directions.
+
+     ch = "wxyz"
+     ch(3:4) = transfer (y, ch, 2)
+     if (any (ch(3:4) .ne. (/"ABCD","EFGH"/))) call abort ()
+     ch = "wxyz"
+     ch(3:2:-1) = transfer (y, ch, 2)
+     if (any (ch(2:3) .ne. (/"EFGH","ABCD"/))) call abort ()
+
+! 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"/))) call abort ()
+
+     z = transfer (ch, y)
+     if (any (y(1:2) .ne. z)) call abort ()
+
+   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))) call abort ()
+
+! Check assumed character length.
+
+     if (any (ic .ne. transfer (ch2, ic))) call abort ()
+
+! Check automatic character length.
+
+     if (any (ic .ne. transfer (ch3, ic))) call abort ()
+
+  end subroutine test3
+
 end