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