gcc/testsuite/gfortran.dg/associate_32.f03

   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)
  21      if (ss .ne. 'ab') call abort ! This is the original bug.
  22      ss = 'c'
  23    end associate
  24    if (s .ne. 'c ') call abort ! No reallocation within ASSOCIATE block!
  25
  26    sf = 'c'
  27    associate(ss => sf)
  28      if (ss .ne. 'c ') call abort ! 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'])) call abort
  35    end associate
  36
  37    sfd = [sd,'ef']
  38    associate(ss => sfd)
  39      if (any (ss .ne. ['c ','cd','ef'])) call abort
  40      ss = ['gh']
  41    end associate
  42      if (any (sfd .ne. ['gh','cd','ef'])) call abort ! No reallocation!
  43
  44    string%str = 'xyz'
  45    associate(ss => string%str)
  46      if (ss .ne. 'xyz') call abort
  47      ss = 'c'
  48    end associate
  49    if (string%str .ne. 'c  ') call abort ! No reallocation!
  50
  51    str = "foobar"
  52    call test_char (5 , str)
  53    IF (str /= "abcder") call abort
  54
  55    associate(ss => foo())
  56      if (ss .ne. 'pqrst') call abort
  57    end associate
  58
  59    associate(ss => bar())
  60      if (ss(2) .ne. 'uvwxy') call abort
  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)
  76       IF (LEN (my) /= n) call abort
  77       IF (my /= "fooba") call abort
  78       my = "abcde"
  79     END ASSOCIATE
  80     IF (str /= "abcde") call abort
  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