gcc/testsuite/gfortran.dg/associate_28.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR81903
   4 !
   5 ! Contributed by Karl May  <karl.may0@freenet.de>
   6 !
   7 Module TestMod_A
   8   Type :: TestType_A
   9     Real, Allocatable :: a(:,:)
  10   End type TestType_A
  11 End Module TestMod_A
  12 Module TestMod_B
  13   Type :: TestType_B
  14    Real, Pointer, contiguous :: a(:,:)
  15   End type TestType_B
  16 End Module TestMod_B
  17 Module TestMod_C
  18   use TestMod_A
  19   use TestMod_B
  20   Implicit None
  21   Type :: TestType_C
  22     Class(TestType_A), Pointer :: TT_A(:)
  23     Type(TestType_B), Allocatable :: TT_B(:)
  24   contains
  25     Procedure, Pass :: SetPt => SubSetPt
  26   End type TestType_C
  27   Interface
  28     Module Subroutine SubSetPt(this)
  29       class(TestType_C), Intent(InOut), Target :: this
  30     End Subroutine
  31   End Interface
  32 End Module TestMod_C
  33 Submodule(TestMod_C) SetPt
  34 contains
  35   Module Procedure SubSetPt
  36     Implicit None
  37     integer :: i
  38     integer :: sum_a = 0
  39     outer:block
  40       associate(x=>this%TT_B,y=>this%TT_A)
  41         Do i=1,size(x)
  42           x(i)%a=>y(i)%a
  43           sum_a = sum_a + sum (int (x(i)%a))
  44         End Do
  45       end associate
  46     End block outer
  47     if (sum_a .ne. 30) STOP 1
  48   End Procedure
  49 End Submodule SetPt
  50 Program Test
  51   use TestMod_C
  52   use TestMod_A
  53   Implicit None
  54   Type(TestType_C) :: tb
  55   Type(TestType_A), allocatable, Target :: ta(:)
  56   integer :: i
  57   real :: src(2,2) = reshape ([(real(i), i = 1,4)],[2,2])
  58   allocate(ta(2),tb%tt_b(2))
  59   do i=1,size(ta)
  60     allocate(ta(i)%a(2,2), source = src*real(i))
  61   End do
  62   tb%TT_A=>ta
  63   call tb%setpt()
  64 End Program Test