gcc/testsuite/gfortran.dg/typebound_proc_20.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/47455
   4 !
   5 ! Based on an example by Thomas Henlich
   6 !
   7
   8 module class_t
   9     type :: tx
  10         integer, dimension(:), allocatable :: i
  11     end type tx
  12     type :: t
  13         type(tx), pointer :: x
  14         type(tx) :: y
  15     contains
  16         procedure :: calc
  17         procedure :: find_x
  18         procedure :: find_y
  19     end type t
  20 contains
  21     subroutine calc(this)
  22         class(t), target :: this
  23         type(tx), target :: that
  24         that%i = [1,2]
  25         this%x => this%find_x(that, .true.)
  26         if (associated (this%x)) call abort()
  27         this%x => this%find_x(that, .false.)
  28         if(any (this%x%i /= [5, 7])) call abort()
  29         if (.not.associated (this%x,that)) call abort()
  30         allocate(this%x)
  31         if (associated (this%x,that)) call abort()
  32         if (allocated(this%x%i)) call abort()
  33         this%x = this%find_x(that, .false.)
  34         that%i = [3,4]
  35         if(any (this%x%i /= [5, 7])) call abort() ! FAILS
  36
  37         if (allocated (this%y%i)) call abort()
  38         this%y = this%find_y()  ! FAILS
  39         if (.not.allocated (this%y%i)) call abort()
  40         if(any (this%y%i /= [6, 8])) call abort()
  41     end subroutine calc
  42     function find_x(this, that, l_null)
  43        class(t), intent(in) :: this
  44        type(tx), target  :: that
  45        type(tx), pointer :: find_x
  46        logical :: l_null
  47        if (l_null) then
  48          find_x => null()
  49        else
  50          find_x => that
  51          that%i = [5, 7]
  52        end if
  53     end function find_x
  54     function find_y(this) result(res)
  55         class(t), intent(in) :: this
  56         type(tx), allocatable :: res
  57         allocate(res)
  58         res%i = [6, 8]
  59    end function find_y
  60 end module class_t
  61
  62 use class_t
  63 type(t) :: x
  64 call x%calc()
  65 end