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