|
111
|
1 ! { dg-do run }
|
|
|
2 !
|
|
|
3 ! Tests fix for PR77296 and other bugs found on the way.
|
|
|
4 !
|
|
|
5 ! Contributed by Matt Thompson <matthew.thompson@nasa.gov>
|
|
|
6 !
|
|
|
7 program test
|
|
|
8
|
|
|
9 implicit none
|
|
|
10 type :: str_type
|
|
|
11 character(len=:), allocatable :: str
|
|
|
12 end type
|
|
|
13
|
|
|
14 character(len=:), allocatable :: s, sd(:)
|
|
|
15 character(len=2), allocatable :: sf, sfd(:)
|
|
|
16 character(len=6) :: str
|
|
|
17 type(str_type) :: string
|
|
|
18
|
|
|
19 s = 'ab'
|
|
|
20 associate(ss => s)
|
|
131
|
21 if (ss .ne. 'ab') STOP 1! This is the original bug.
|
|
111
|
22 ss = 'c'
|
|
|
23 end associate
|
|
131
|
24 if (s .ne. 'c ') STOP 2! No reallocation within ASSOCIATE block!
|
|
111
|
25
|
|
|
26 sf = 'c'
|
|
|
27 associate(ss => sf)
|
|
131
|
28 if (ss .ne. 'c ') STOP 3! This the bug in comment #2 of the PR.
|
|
111
|
29 ss = 'cd'
|
|
|
30 end associate
|
|
|
31
|
|
|
32 sd = [s, sf]
|
|
|
33 associate(ss => sd)
|
|
131
|
34 if (any (ss .ne. ['c ','cd'])) STOP 4
|
|
111
|
35 end associate
|
|
|
36
|
|
|
37 sfd = [sd,'ef']
|
|
|
38 associate(ss => sfd)
|
|
131
|
39 if (any (ss .ne. ['c ','cd','ef'])) STOP 5
|
|
111
|
40 ss = ['gh']
|
|
|
41 end associate
|
|
131
|
42 if (any (sfd .ne. ['gh','cd','ef'])) STOP 6! No reallocation!
|
|
111
|
43
|
|
|
44 string%str = 'xyz'
|
|
|
45 associate(ss => string%str)
|
|
131
|
46 if (ss .ne. 'xyz') STOP 7
|
|
111
|
47 ss = 'c'
|
|
|
48 end associate
|
|
131
|
49 if (string%str .ne. 'c ') STOP 8! No reallocation!
|
|
111
|
50
|
|
|
51 str = "foobar"
|
|
|
52 call test_char (5 , str)
|
|
131
|
53 IF (str /= "abcder") STOP 9
|
|
111
|
54
|
|
|
55 associate(ss => foo())
|
|
131
|
56 if (ss .ne. 'pqrst') STOP 10
|
|
111
|
57 end associate
|
|
|
58
|
|
|
59 associate(ss => bar())
|
|
131
|
60 if (ss(2) .ne. 'uvwxy') STOP 11
|
|
111
|
61 end associate
|
|
|
62
|
|
|
63 ! The deallocation is not strictly necessary but it does allow
|
|
|
64 ! other memory leakage to be tested for.
|
|
|
65 deallocate (s, sd, sf, sfd, string%str)
|
|
|
66 contains
|
|
|
67
|
|
|
68 ! This is a modified version of the subroutine in associate_1.f03.
|
|
|
69 ! 'str' is now a dummy.
|
|
|
70 SUBROUTINE test_char (n, str)
|
|
|
71 INTEGER, INTENT(IN) :: n
|
|
|
72
|
|
|
73 CHARACTER(LEN=n) :: str
|
|
|
74
|
|
|
75 ASSOCIATE (my => str)
|
|
131
|
76 IF (LEN (my) /= n) STOP 12
|
|
|
77 IF (my /= "fooba") STOP 13
|
|
111
|
78 my = "abcde"
|
|
|
79 END ASSOCIATE
|
|
131
|
80 IF (str /= "abcde") STOP 14
|
|
111
|
81 END SUBROUTINE test_char
|
|
|
82
|
|
|
83 function foo() result(res)
|
|
|
84 character (len=:), pointer :: res
|
|
|
85 allocate (res, source = 'pqrst')
|
|
|
86 end function
|
|
|
87
|
|
|
88 function bar() result(res)
|
|
|
89 character (len=:), allocatable :: res(:)
|
|
|
90 allocate (res, source = ['pqrst','uvwxy'])
|
|
|
91 end function
|
|
|
92
|
|
|
93 end program test
|
