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!
7program 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)
21     if (ss .ne. 'ab') STOP 1! This is the original bug.
22     ss = 'c'
23   end associate
24   if (s .ne. 'c ') STOP 2! No reallocation within ASSOCIATE block!
25
26   sf = 'c'
27   associate(ss => sf)
28     if (ss .ne. 'c ') STOP 3! This the bug in comment #2 of the PR.
29     ss = 'cd'
30   end associate
31
32   sd = [s, sf]
33   associate(ss => sd)
34     if (any (ss .ne. ['c ','cd'])) STOP 4
35   end associate
36
37   sfd = [sd,'ef']
38   associate(ss => sfd)
39     if (any (ss .ne. ['c ','cd','ef'])) STOP 5
40     ss = ['gh']
41   end associate
42     if (any (sfd .ne. ['gh','cd','ef'])) STOP 6! No reallocation!
43
44   string%str = 'xyz'
45   associate(ss => string%str)
46     if (ss .ne. 'xyz') STOP 7
47     ss = 'c'
48   end associate
49   if (string%str .ne. 'c  ') STOP 8! No reallocation!
50
51   str = "foobar"
52   call test_char (5 , str)
53   IF (str /= "abcder") STOP 9
54
55   associate(ss => foo())
56     if (ss .ne. 'pqrst') STOP 10
57   end associate
58
59   associate(ss => bar())
60     if (ss(2) .ne. 'uvwxy') STOP 11
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)
66contains
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)
76      IF (LEN (my) /= n) STOP 12
77      IF (my /= "fooba") STOP 13
78      my = "abcde"
79    END ASSOCIATE
80    IF (str /= "abcde") STOP 14
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
93end program test
94