gcc/testsuite/gfortran.dg/typebound_proc_20.f90

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