gcc/testsuite/gfortran.dg/associate_47.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR88247 and more besides :-)
   4 !
   5 ! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
   6 !
   7 program p
   8    type t
   9       character(:), allocatable :: c
  10       character(:), dimension(:), allocatable :: d
  11    end type
  12    type(t), allocatable :: x
  13
  14    call foo ('abcdef','ghijkl')
  15    associate (y => [x%c(:)])
  16       if (y(1) .ne. 'abcdef') stop 1
  17    end associate
  18
  19    call foo ('ghi','ghi')
  20    associate (y => [x%c(2:)])
  21       if (y(1) .ne. 'hi') stop 2
  22    end associate
  23
  24    call foo ('lmnopq','ghijkl')
  25    associate (y => [x%c(:3)])
  26       if (y(1) .ne. 'lmn') stop 3
  27    end associate
  28
  29    call foo ('abcdef','ghijkl')
  30    associate (y => [x%c(2:4)])
  31       if (y(1) .ne. 'bcd') stop 4
  32    end associate
  33
  34    call foo ('lmnopqrst','ghijklmno')
  35    associate (y => x%d(:))
  36       if (len(y) .ne. 9) stop 5
  37       if (any (y .ne. ['lmnopqrst','ghijklmno'])) stop 5
  38       y(1) = 'zqrtyd'
  39    end associate
  40    if (x%d(1) .ne. 'zqrtyd') stop 5
  41
  42    call foo ('lmnopqrst','ghijklmno')
  43    associate (y => x%d(:)(2:4))
  44       if (any (y .ne. ['mno','hij'])) stop 6
  45    end associate
  46
  47    call foo ('abcdef','ghijkl')
  48    associate (y => [x%d(:)])
  49       if (len(y) .ne. 6) stop 7
  50       if (any (y .ne. ['abcdef','ghijkl'])) stop 7
  51    end associate
  52
  53    call foo ('lmnopqrst','ghijklmno')
  54    associate (y => [x%d(2:1:-1)])
  55       if (len(y) .ne. 9) stop 8
  56       if (any (y .ne. ['ghijklmno','lmnopqrst'])) stop 8
  57    end associate
  58
  59    deallocate (x)
  60 contains
  61    subroutine foo (c1, c2)
  62      character(*) :: c1, c2
  63      if (allocated (x)) deallocate (x)
  64      allocate (x)
  65      x%c = c1
  66      x%d = [c1, c2]
  67    end subroutine foo
  68 end