summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03
blob: 0564d0d50647ddc7948be01bed94451dbd66a97b (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
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 <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