Subversion Repositories openrisc

! { 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 <dominiq@lps.ens.fr>
!            and Tobias Burnus <burnus@gcc.gnu.org>
!
  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