gcc/testsuite/gfortran.dg/associate_60.f90

   1 ! { dg-do run }
   2 !
   3 ! Tests fixes for various pr87477 dependencies
   4 !
   5 ! Contributed by Gerhard Steinmetz  <gscfq@t-online.de> except for pr102106:
   6 ! which was contributed by Brad Richardson  <everythingfunctional@protonmail.com>
   7 !
   8 program associate_60
   9   implicit none
  10   character(20) :: buffer
  11
  12   call pr102106
  13   call pr100948
  14   call pr85686
  15   call pr88247
  16   call pr91941
  17   call pr92779
  18   call pr93339
  19   call pr93813
  20
  21 contains
  22
  23   subroutine pr102106
  24     type :: sub_class_t
  25         integer :: i
  26     end type
  27     type :: with_polymorphic_component_t
  28         class(sub_class_t), allocatable :: sub_obj_
  29     end type
  30     associate(obj => with_polymorphic_component_t(sub_class_t(42)))
  31         if (obj%sub_obj_%i .ne. 42) stop 1
  32     end associate
  33   end
  34
  35   subroutine pr100948
  36     type t
  37       character(:), allocatable :: c(:)
  38     end type
  39     type(t), allocatable :: x
  40 !
  41 ! Valid test in comment 1
  42 !
  43     x = t(['ab','cd'])
  44     associate (y => x%c(:))
  45       if (any (y .ne. x%c)) stop 2
  46       if (any (y .ne. ['ab','cd'])) stop 3
  47     end associate
  48     deallocate (x)
  49 !
  50 ! Allocation with source was found to only copy over one of the array elements
  51 !
  52     allocate (x, source = t(['ef','gh']))
  53     associate (y => x%c(:))
  54       if (any (y .ne. x%c)) stop 4
  55       if (any (y .ne. ['ef','gh'])) stop 5
  56     end associate
  57     deallocate (x)
  58   end
  59
  60   subroutine pr85686
  61     call s85686([" g'day "," bye!! "])
  62     if (trim (buffer) .ne. " a g'day a bye!!") stop 6
  63   end
  64
  65   subroutine s85686(x)
  66     character(*) :: x(:)
  67     associate (y => 'a'//x)
  68       write (buffer, *) y ! Used to segfault at the write statement.
  69     end associate
  70   end
  71
  72   subroutine pr88247
  73       type t
  74          character(:), dimension(:), allocatable :: d
  75       end type t
  76       type(t), allocatable :: x
  77       character(5) :: buffer(3)
  78       allocate (x, source = t (['ab','cd'])) ! Didn't work
  79       write(buffer(1), *) x%d(2:1:-1)        ! Was found to be broken
  80       write(buffer(2), *) [x%d(2:1:-1)]      ! Was OK
  81       associate (y => [x%d(2:1:-1)])
  82         write(buffer(3), *) y                ! Bug in comment 7
  83       end associate
  84       if (any (buffer .ne. " cdab")) stop 7
  85   end
  86
  87   subroutine pr91941
  88     character(:), allocatable :: x(:), z(:)
  89     x = [' abc', ' xyz']
  90     z = adjustl(x)
  91     associate (y => adjustl(x))              ! Wrong character length was passed
  92       if (any(y .ne. ['abc ', 'xyz '])) stop 8
  93     end associate
  94   end
  95
  96   subroutine pr92779
  97     character(3) :: a = 'abc'
  98     associate (y => spread(trim(a),1,2) // 'd')
  99       if (any (y .ne. ['abcd','abcd'])) stop 9
 100     end associate
 101   end
 102
 103   subroutine pr93339
 104     type t
 105       character(:), allocatable :: a(:)
 106     end type
 107     type(t) :: x
 108     x = t(["abc "])                    ! Didn't assign anything
 109 !   allocate (x%a(1), source = 'abc') ! Worked OK
 110     associate (y => x%a)
 111        if (any (y .ne. 'abc ')) stop 10
 112           associate (z => x%a)
 113             if (any (y .ne. z)) stop 11
 114           end associate
 115     end associate
 116   end
 117
 118   subroutine pr93813
 119     type t
 120     end type
 121     type, extends(t) :: t2
 122     end type
 123     class(t), allocatable :: x
 124     integer :: i = 0
 125     allocate (t :: x)
 126     associate (y => (x))  ! The parentheses triggered an ICE in select type
 127       select type (y)
 128       type is (t2)
 129           stop 12
 130       type is (t)
 131           i = 42
 132       class default
 133           stop 13
 134       end select
 135     end associate
 136     if (i .ne. 42) stop 14
 137   end
 138 end