gcc/testsuite/gfortran.dg/associate_31.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR52832
   4 !
   5 ! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
   6 !
   7   subroutine testSub()
   8     interface
   9       integer function fcn1 (arg)
  10         integer :: arg
  11       end function
  12       integer function fcn2 (arg)
  13         integer :: arg
  14       end function
  15     end interface
  16
  17     procedure(fcn1), pointer :: r
  18     r => fcn2
  19     associate (k => r)
  20       if (r(42) .ne. 84) call abort
  21     end associate
  22     r => fcn1
  23     associate (k => r)
  24       if (r(42) .ne. 42) call abort
  25     end associate
  26   end subroutine testSub
  27
  28   integer function fcn1 (arg)
  29     integer :: arg;
  30     fcn2 = arg
  31   end function
  32
  33   integer function fcn2 (arg)
  34     integer :: arg;
  35     fcn2 = arg*2
  36   end function
  37
  38   call testSub
  39 end