gcc/testsuite/gfortran.dg/associated_target_6.f03

   1 ! { dg-do run }
   2 ! Tests the fix for PR67091 in which the first call to associated
   3 ! gave a bad result because the 'target' argument was not being
   4 ! correctly handled.
   5 !
   6 ! Contributed by 'FortranFan' on clf.
   7 ! https://groups.google.com/forum/#!topic/comp.lang.fortran/dN_tQA1Mu-I
   8 !
   9 module m
  10    implicit none
  11    private
  12    type, public :: t
  13       private
  14       integer, pointer :: m_i
  15    contains
  16       private
  17       procedure, pass(this), public :: iptr => getptr
  18       procedure, pass(this), public :: setptr
  19    end type t
  20 contains
  21    subroutine setptr( this, iptr )
  22       !.. Argument list
  23       class(t), intent(inout)         :: this
  24       integer, pointer, intent(inout) :: iptr
  25       this%m_i => iptr
  26       return
  27    end subroutine setptr
  28    function getptr( this ) result( iptr )
  29       !.. Argument list
  30       class(t), intent(in) :: this
  31       !.. Function result
  32       integer, pointer :: iptr
  33       iptr => this%m_i
  34    end function getptr
  35 end module m
  36
  37 program p
  38    use m, only : t
  39    integer, pointer :: i
  40    integer, pointer :: j
  41    type(t) :: foo
  42    !.. create i with some value
  43    allocate (i, source=42)
  44    call foo%setptr (i)
  45    if (.not.associated (i, foo%iptr())) STOP 1 ! Gave bad result.
  46    if (.not.associated (foo%iptr(), i)) STOP 2 ! Was OK.
  47    j => foo%iptr()
  48    if (.not.associated (i, j)) STOP 1! Was OK.
  49 end program p