diff options
Diffstat (limited to 'gcc/testsuite/gfortran.dg')
5 files changed, 195 insertions, 118 deletions
diff --git a/gcc/testsuite/gfortran.dg/compliant_elemental_intrinsics_1.f90 b/gcc/testsuite/gfortran.dg/compliant_elemental_intrinsics_1.f90 new file mode 100644 index 00000000000..7829d977eb2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/compliant_elemental_intrinsics_1.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! Tests the fix for PR26976, in which non-compliant elemental +! intrinsic function results were not detected. At the same +! time, the means to tests the compliance of TRANSFER with the +! optional SIZE parameter was added. +! +! Contributed by Dominique Dhumieres <dominiq@lps.ens.fr> +! +real(4) :: pi, a(2), b(3) +character(26) :: ch + +pi = acos(-1.0) +b = pi + +a = cos(b) ! { dg-error "different shape for Array assignment" } + +a = -pi +b = cos(a) ! { dg-error "different shape for Array assignment" } + +ch = "abcdefghijklmnopqrstuvwxyz" +a = transfer (ch, pi, 3) ! { dg-error "different shape for Array assignment" } + +! This already generated an error +b = reshape ((/1.0/),(/1/)) ! { dg-error "different shape for Array assignment" } + +end diff --git a/gcc/testsuite/gfortran.dg/initialization_1.f90 b/gcc/testsuite/gfortran.dg/initialization_1.f90 index b9199fe68fa..af7ccb0f782 100644 --- a/gcc/testsuite/gfortran.dg/initialization_1.f90 +++ b/gcc/testsuite/gfortran.dg/initialization_1.f90 @@ -21,6 +21,7 @@ contains real(8) :: x (1:2, *) real(8) :: y (0:,:) integer :: i + real :: z(2, 2) ! However, this gives a warning because it is an initialization expression. integer :: l1 = len (ch1) ! { dg-warning "assumed character length variable" } diff --git a/gcc/testsuite/gfortran.dg/missing_optional_dummy_1.f90 b/gcc/testsuite/gfortran.dg/missing_optional_dummy_1.f90 new file mode 100644 index 00000000000..29f08f9e0e8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/missing_optional_dummy_1.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! Test the fix for PR26891, in which an optional argument, whose actual +! is a missing dummy argument would cause a segfault. +! +! Contributed by Paul Thomas <pault@gcc.gnu.org> +! + logical :: back =.false. + +! This was the case that would fail - PR case was an intrinsic call. + if (scan ("A quick brown fox jumps over the lazy dog", "lazy", back) & + .ne. myscan ("A quick brown fox jumps over the lazy dog", "lazy")) & + call abort () + +! Check that the patch works with non-intrinsic functions. + if (myscan ("A quick brown fox jumps over the lazy dog", "fox", back) & + .ne. thyscan ("A quick brown fox jumps over the lazy dog", "fox")) & + call abort () + +! Check that missing, optional character actual arguments are OK. + if (scan ("A quick brown fox jumps over the lazy dog", "over", back) & + .ne. thyscan ("A quick brown fox jumps over the lazy dog")) & + call abort () + +contains + integer function myscan (str, substr, back) + character(*), intent(in) :: str, substr + logical, optional, intent(in) :: back + myscan = scan (str, substr, back) + end function myscan + + integer function thyscan (str, substr, back) + character(*), intent(in) :: str + character(*), optional, intent(in) :: substr + logical, optional, intent(in) :: back + thyscan = isscan (str, substr, back) + end function thyscan + + integer function isscan (str, substr, back) + character(*), intent(in) :: str + character(*), optional :: substr + logical, optional, intent(in) :: back + if (.not.present(substr)) then + isscan = myscan (str, "over", back) + else + isscan = myscan (str, substr, back) + end if + end function isscan + +end diff --git a/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90 b/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90 index 05b4717249c..0d828efa66b 100644 --- a/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90 +++ b/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_1.f90 @@ -1,22 +1,11 @@ -! { dg-do run { target i?86-*-* x86_64-*-* } } +! { dg-do run } ! Tests the patch to implement the array version of the TRANSFER ! intrinsic (PR17298). -! Contributed by Paul Thomas <pault@gcc.gnu.org> - character(8) :: ch(2) = (/"lmnoPQRS","LMNOpqrs"/) - -! tests numeric transfers(including PR testcase). +! test the PR is fixed. 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 () @@ -29,90 +18,6 @@ contains cmp = transfer (z, cmp) * 2.0 if (any (cmp .ne. (/2.0, 4.0/))) call abort () -! Check that size smaller than the source word length is OK. - - z = (-1.0, -2.0) - cmp = transfer (z, cmp, 1) * 8.0 - if (any (cmp .ne. (/-8.0, 4.0/))) call abort () - -! 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) - y = (/(i + ishft (i + 1, 8) + ishft (i + 2, 16) & - + ishft (i + 3, 24), i = 65, 80 , 4)/) - -! Check source array sections in both directions. - - ch = "wxyz" - ch = transfer (y(2:4:2), ch) - if (any (ch .ne. (/"EFGH","MNOP","wxyz","wxyz"/))) call abort () - ch = "wxyz" - ch = transfer (y(4:2:-2), ch) - if (any (ch .ne. (/"MNOP","EFGH","wxyz","wxyz"/))) 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 .ne. (/"wxyz","wxyz","ABCD","EFGH"/))) call abort () - ch = "wxyz" - ch(3:2:-1) = transfer (y, ch, 3) - if (any (ch .ne. (/"wxyz","EFGH","ABCD","wxyz"/))) call abort () - -! Check that too large a value of size is cut off. - - ch = "wxyz" - ch(1:2) = transfer (y, ch, 3) - if (any (ch .ne. (/"ABCD","EFGH","wxyz","wxyz"/))) call abort () - -! Make sure that character to numeric is OK. - - 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 diff --git a/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90 b/gcc/testsuite/gfortran.dg/transfer_array_intrinsic_2.f90 index a787440b682..aaa10f8a4f5 100644 --- 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 |