3 ! Tests fix for PR77296 and other bugs found on the way.
5 ! Contributed by Matt Thompson <matthew.thompson@nasa.gov>
11 character(len=:), allocatable :: str
14 character(len=:), allocatable :: s, sd(:)
15 character(len=2), allocatable :: sf, sfd(:)
16 character(len=6) :: str
17 type(str_type) :: string
21 if (ss .ne. 'ab') STOP 1! This is the original bug.
24 if (s .ne. 'c ') STOP 2! No reallocation within ASSOCIATE block!
28 if (ss .ne. 'c ') STOP 3! This the bug in comment #2 of the PR.
34 if (any (ss .ne. ['c ','cd'])) STOP 4
39 if (any (ss .ne. ['c ','cd','ef'])) STOP 5
42 if (any (sfd .ne. ['gh','cd','ef'])) STOP 6! No reallocation!
45 associate(ss => string%str)
46 if (ss .ne. 'xyz') STOP 7
49 if (string%str .ne. 'c ') STOP 8! No reallocation!
52 call test_char (5 , str)
53 IF (str /= "abcder") STOP 9
55 associate(ss => foo())
56 if (ss .ne. 'pqrst') STOP 10
59 associate(ss => bar())
60 if (ss(2) .ne. 'uvwxy') STOP 11
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)
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
73 CHARACTER(LEN=n) :: str
76 IF (LEN (my) /= n) STOP 12
77 IF (my /= "fooba") STOP 13
80 IF (str /= "abcde") STOP 14
81 END SUBROUTINE test_char
83 function foo() result(res)
84 character (len=:), pointer :: res
85 allocate (res, source = 'pqrst')
88 function bar() result(res)
89 character (len=:), allocatable :: res(:)
90 allocate (res, source = ['pqrst','uvwxy'])