gcc/testsuite/gfortran.dg/typebound_proc_36.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR82312.f90
   4 !
   5 ! Posted on Stack Overflow:
   6 ! https://stackoverflow.com/questions/46369744
   7 ! /gfortran-associates-wrong-type-bound-procedure/46388339#46388339
   8 !
   9 module minimalisticcase
  10     implicit none
  11
  12     type, public :: DataStructure
  13         integer :: i
  14     contains
  15         procedure, pass :: init => init_data_structure
  16         procedure, pass :: a => beginning_of_alphabet
  17     end type
  18
  19     type, public :: DataLogger
  20         type(DataStructure), pointer :: data_structure
  21         contains
  22                 procedure, pass :: init => init_data_logger
  23                 procedure, pass :: do_something => do_something
  24     end type
  25
  26     integer :: ctr = 0
  27
  28 contains
  29     subroutine init_data_structure(self)
  30         implicit none
  31         class(DataStructure), intent(inout) :: self
  32         write(*,*) 'init_data_structure'
  33         ctr = ctr + 1
  34     end subroutine
  35
  36     subroutine beginning_of_alphabet(self)
  37         implicit none
  38         class(DataStructure), intent(inout) :: self
  39
  40         write(*,*) 'beginning_of_alphabet'
  41         ctr = ctr + 10
  42     end subroutine
  43
  44     subroutine init_data_logger(self, data_structure)
  45         implicit none
  46         class(DataLogger), intent(inout) :: self
  47         class(DataStructure), target :: data_structure
  48         write(*,*) 'init_data_logger'
  49         ctr = ctr + 100
  50
  51         self%data_structure => data_structure ! Invalid change of 'self' vptr
  52         call self%do_something()
  53     end subroutine
  54
  55     subroutine do_something(self)
  56         implicit none
  57         class(DataLogger), intent(inout) :: self
  58
  59         write(*,*) 'do_something'
  60         ctr = ctr + 1000
  61
  62     end subroutine
  63 end module
  64
  65 program main
  66     use minimalisticcase
  67     implicit none
  68
  69     type(DataStructure) :: data_structure
  70     type(DataLogger) :: data_logger
  71
  72     call data_structure%init()
  73     call data_structure%a()
  74     call data_logger%init(data_structure)
  75
  76     if (ctr .ne. 1111) STOP 1
  77 end program