From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03 | 153 ++++++++++++++++++++++ 1 file changed, 153 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03 (limited to 'gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03') diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03 b/gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03 new file mode 100644 index 000000000..0564d0d50 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03 @@ -0,0 +1,153 @@ +! { dg-do run } +! { dg-skip-if "Too big for local store" { spu-*-* } { "*" } { "" } } +! Tests the patch that implements F2003 automatic allocation and +! reallocation of allocatable arrays on assignment. The tests +! below were generated in the final stages of the development of +! this patch. +! test1 has been corrected for PR47051 +! +! Contributed by Dominique Dhumieres +! and Tobias Burnus +! + integer :: nglobal + call test1 + call test2 + call test3 + call test4 + call test5 + call test6 + call test7 + call test8 +contains + subroutine test1 +! +! Check that the bounds are set correctly, when assigning +! to an array that already has the correct shape. +! + real :: a(10) = 1, b(51:60) = 2 + real, allocatable :: c(:), d(:) + c=a + if (lbound (c, 1) .ne. lbound(a, 1)) call abort + if (ubound (c, 1) .ne. ubound(a, 1)) call abort + c=b +! 7.4.1.3 "If variable is an allocated allocatable variable, it is +! deallocated if expr is an array of different shape or any of the +! corresponding length type parameter values of variable and expr +! differ." Here the shape is the same so the deallocation does not +! occur and the bounds are not recalculated. This was corrected +! for the fix of PR47051. + if (lbound (c, 1) .ne. lbound(a, 1)) call abort + if (ubound (c, 1) .ne. ubound(a, 1)) call abort + d=b + if (lbound (d, 1) .ne. lbound(b, 1)) call abort + if (ubound (d, 1) .ne. ubound(b, 1)) call abort + d=a +! The other PR47051 correction. + if (lbound (d, 1) .ne. lbound(b, 1)) call abort + if (ubound (d, 1) .ne. ubound(b, 1)) call abort + end subroutine + subroutine test2 +! +! Check that the bounds are set correctly, when making an +! assignment with an implicit conversion. First with a +! non-descriptor variable.... +! + integer(4), allocatable :: a(:) + integer(8) :: b(5:6) + a = b + if (lbound (a, 1) .ne. lbound(b, 1)) call abort + if (ubound (a, 1) .ne. ubound(b, 1)) call abort + end subroutine + subroutine test3 +! +! ...and now a descriptor variable. +! + integer(4), allocatable :: a(:) + integer(8), allocatable :: b(:) + allocate (b(7:11)) + a = b + if (lbound (a, 1) .ne. lbound(b, 1)) call abort + if (ubound (a, 1) .ne. ubound(b, 1)) call abort + end subroutine + subroutine test4 +! +! Check assignments of the kind a = f(...) +! + integer, allocatable :: a(:) + integer, allocatable :: c(:) + a = f() + if (any (a .ne. [1, 2, 3, 4])) call abort + c = a + 8 + a = f (c) + if (any ((a - 8) .ne. [1, 2, 3, 4])) call abort + deallocate (c) + a = f (c) + if (any ((a - 4) .ne. [1, 2, 3, 4])) call abort + end subroutine + function f(b) + integer, allocatable, optional :: b(:) + integer :: f(4) + if (.not.present (b)) then + f = [1,2,3,4] + elseif (.not.allocated (b)) then + f = [5,6,7,8] + else + f = b + end if + end function f + + subroutine test5 +! +! Extracted from rnflow.f90, Polyhedron benchmark suite, +! http://www.polyhedron.com +! + integer, parameter :: ncls = 233, ival = 16, ipic = 17 + real, allocatable, dimension (:,:) :: utrsft + real, allocatable, dimension (:,:) :: dtrsft + real, allocatable, dimension (:,:) :: xwrkt + allocate (utrsft(ncls, ncls), dtrsft(ncls, ncls)) + nglobal = 0 + xwrkt = trs2a2 (ival, ipic, ncls) + if (any (shape (xwrkt) .ne. [ncls, ncls])) call abort + xwrkt = invima (xwrkt, ival, ipic, ncls) + if (nglobal .ne. 1) call abort + if (sum(xwrkt) .ne. xwrkt(ival, ival)) call abort + end subroutine + function trs2a2 (j, k, m) + real, dimension (1:m,1:m) :: trs2a2 + integer, intent (in) :: j, k, m + nglobal = nglobal + 1 + trs2a2 = 0.0 + end function trs2a2 + function invima (a, j, k, m) + real, dimension (1:m,1:m) :: invima + real, dimension (1:m,1:m), intent (in) :: a + integer, intent (in) :: j, k + invima = 0.0 + invima (j, j) = 1.0 / (1.0 - a (j, j)) + end function invima + subroutine test6 + character(kind=1, len=100), allocatable, dimension(:) :: str + str = [ "abc" ] + if (TRIM(str(1)) .ne. "abc") call abort + if (len(str) .ne. 100) call abort + end subroutine + subroutine test7 + character(kind=4, len=100), allocatable, dimension(:) :: str + character(kind=4, len=3) :: test = "abc" + str = [ "abc" ] + if (TRIM(str(1)) .ne. test) call abort + if (len(str) .ne. 100) call abort + end subroutine + subroutine test8 + type t + integer, allocatable :: a(:) + end type t + type(t) :: x + x%a= [1,2,3] + if (any (x%a .ne. [1,2,3])) call abort + x%a = [4] + if (any (x%a .ne. [4])) call abort + end subroutine +end + -- cgit v1.2.3