gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03

   1 ! { dg-do run }
   2 ! { dg-skip-if "Too big for local store" { spu-*-* } { "*" } { "" } }
   3 ! Tests the patch that implements F2003 automatic allocation and
   4 ! reallocation of allocatable arrays on assignment.  The tests
   5 ! below were generated in the final stages of the development of
   6 ! this patch.
   7 ! test1 has been corrected for PR47051
   8 !
   9 ! Contributed by Dominique Dhumieres <dominiq@lps.ens.fr>
  10 !            and Tobias Burnus <burnus@gcc.gnu.org>
  11 !
  12   integer :: nglobal
  13   call test1
  14   call test2
  15   call test3
  16   call test4
  17   call test5
  18   call test6
  19   call test7
  20   call test8
  21 contains
  22   subroutine test1
  23 !
  24 ! Check that the bounds are set correctly, when assigning
  25 ! to an array that already has the correct shape.
  26 !
  27     real :: a(10) = 1, b(51:60) = 2
  28     real, allocatable :: c(:), d(:)
  29     c=a
  30     if (lbound (c, 1) .ne. lbound(a, 1)) call abort
  31     if (ubound (c, 1) .ne. ubound(a, 1)) call abort
  32     c=b
  33 ! 7.4.1.3 "If variable is an allocated allocatable variable, it is
  34 ! deallocated if expr is an array of different shape or any of the
  35 ! corresponding length type parameter values of variable and expr
  36 ! differ." Here the shape is the same so the deallocation does not
  37 ! occur and the bounds are not recalculated. This was corrected
  38 ! for the fix of PR47051.
  39     if (lbound (c, 1) .ne. lbound(a, 1)) call abort
  40     if (ubound (c, 1) .ne. ubound(a, 1)) call abort
  41     d=b
  42     if (lbound (d, 1) .ne. lbound(b, 1)) call abort
  43     if (ubound (d, 1) .ne. ubound(b, 1)) call abort
  44     d=a
  45 ! The other PR47051 correction.
  46     if (lbound (d, 1) .ne. lbound(b, 1)) call abort
  47     if (ubound (d, 1) .ne. ubound(b, 1)) call abort
  48   end subroutine
  49   subroutine test2
  50 !
  51 ! Check that the bounds are set correctly, when making an
  52 ! assignment with an implicit conversion.  First with a
  53 ! non-descriptor variable....
  54 !
  55     integer(4), allocatable :: a(:)
  56     integer(8) :: b(5:6)
  57     a = b
  58     if (lbound (a, 1) .ne. lbound(b, 1)) call abort
  59     if (ubound (a, 1) .ne. ubound(b, 1)) call abort
  60   end subroutine
  61   subroutine test3
  62 !
  63 ! ...and now a descriptor variable.
  64 !
  65     integer(4), allocatable :: a(:)
  66     integer(8), allocatable :: b(:)
  67     allocate (b(7:11))
  68     a = b
  69     if (lbound (a, 1) .ne. lbound(b, 1)) call abort
  70     if (ubound (a, 1) .ne. ubound(b, 1)) call abort
  71   end subroutine
  72   subroutine test4
  73 !
  74 ! Check assignments of the kind a = f(...)
  75 !
  76     integer, allocatable :: a(:)
  77     integer, allocatable :: c(:)
  78     a = f()
  79     if (any (a .ne. [1, 2, 3, 4])) call abort
  80     c = a + 8
  81     a = f (c)
  82     if (any ((a - 8) .ne. [1, 2, 3, 4])) call abort
  83     deallocate (c)
  84     a = f (c)
  85     if (any ((a - 4) .ne. [1, 2, 3, 4])) call abort
  86   end subroutine
  87   function f(b)
  88     integer, allocatable, optional :: b(:)
  89     integer :: f(4)
  90     if (.not.present (b)) then
  91       f = [1,2,3,4]
  92     elseif (.not.allocated (b)) then
  93       f = [5,6,7,8]
  94     else
  95       f = b
  96     end if
  97   end function f
  98
  99   subroutine test5
 100 !
 101 ! Extracted from rnflow.f90, Polyhedron benchmark suite,
 102 ! http://www.polyhedron.com
 103 !
 104     integer, parameter :: ncls = 233, ival = 16, ipic = 17
 105     real, allocatable, dimension (:,:) :: utrsft
 106     real, allocatable, dimension (:,:) :: dtrsft
 107     real, allocatable, dimension (:,:) :: xwrkt
 108     allocate (utrsft(ncls, ncls), dtrsft(ncls, ncls))
 109     nglobal = 0
 110     xwrkt = trs2a2 (ival, ipic, ncls)
 111     if (any (shape (xwrkt) .ne. [ncls, ncls])) call abort
 112     xwrkt = invima (xwrkt, ival, ipic, ncls)
 113     if (nglobal .ne. 1) call abort
 114     if (sum(xwrkt) .ne. xwrkt(ival, ival)) call abort
 115   end subroutine
 116   function trs2a2 (j, k, m)
 117     real, dimension (1:m,1:m) :: trs2a2
 118     integer, intent (in)      :: j, k, m
 119     nglobal = nglobal + 1
 120     trs2a2 = 0.0
 121   end function trs2a2
 122   function invima (a, j, k, m)
 123     real, dimension (1:m,1:m)              :: invima
 124     real, dimension (1:m,1:m), intent (in) :: a
 125     integer, intent (in)            :: j, k
 126     invima = 0.0
 127     invima (j, j) = 1.0 / (1.0 - a (j, j))
 128   end function invima
 129   subroutine test6
 130     character(kind=1, len=100), allocatable, dimension(:) :: str
 131     str = [ "abc" ]
 132     if (TRIM(str(1)) .ne. "abc") call abort
 133     if (len(str) .ne. 100) call abort
 134   end subroutine
 135   subroutine test7
 136     character(kind=4, len=100), allocatable, dimension(:) :: str
 137     character(kind=4, len=3) :: test = "abc"
 138     str = [ "abc" ]
 139     if (TRIM(str(1)) .ne. test) call abort
 140     if (len(str) .ne. 100) call abort
 141   end subroutine
 142   subroutine test8
 143     type t
 144       integer, allocatable :: a(:)
 145     end type t
 146     type(t) :: x
 147     x%a= [1,2,3]
 148     if (any (x%a .ne. [1,2,3])) call abort
 149     x%a = [4]
 150     if (any (x%a .ne. [4])) call abort
 151   end subroutine
 152 end
 153