1! { dg-do run }
2!
3! Tests the fix for PR81758, in which the vpointer for 'ptr' in
4! function 'pointer_value' would be set to the vtable of the component
5! 'container' rather than that of the component 'vec_elem'. In this test
6! case it is ensured that there is a single typebound procedure for both
7! types, so that different values are returned. In the original problem
8! completely different procedures were involved so that a segfault resulted.
9!
10! Reduced from the original code of Dimitry Liakh  <liakhdi@ornl.gov> by
11!                                   Paul Thomas  <pault@gcc.gnu.org>
12!
13module types
14  type, public:: gfc_container_t
15  contains
16    procedure, public:: get_value => ContTypeGetValue
17  end type gfc_container_t
18
19  !Element of a container:
20  type, public:: gfc_cont_elem_t
21    integer :: value_p
22  contains
23    procedure, public:: get_value => ContElemGetValue
24  end type gfc_cont_elem_t
25
26  !Vector element:
27  type, extends(gfc_cont_elem_t), public:: vector_elem_t
28  end type vector_elem_t
29
30  !Vector:
31  type, extends(gfc_container_t), public:: vector_t
32    type(vector_elem_t), allocatable, private :: vec_elem
33  end type vector_t
34
35  type, public :: vector_iter_t
36    class(vector_t), pointer, private :: container => NULL()
37  contains
38    procedure, public:: get_vector_value => vector_Value
39    procedure, public:: get_pointer_value => pointer_value
40  end type
41
42contains
43  integer function ContElemGetValue (this)
44    class(gfc_cont_elem_t) :: this
45    ContElemGetValue = this%value_p
46  end function
47
48  integer function ContTypeGetValue (this)
49    class(gfc_container_t) :: this
50    ContTypeGetValue = 0
51  end function
52
53  integer function vector_Value (this)
54    class(vector_iter_t) :: this
55    vector_value = this%container%vec_elem%get_value()
56  end function
57
58  integer function pointer_value (this)
59    class(vector_iter_t), target :: this
60    class(gfc_cont_elem_t), pointer :: ptr
61    ptr => this%container%vec_elem
62    pointer_value = ptr%get_value()
63  end function
64
65  subroutine factory (arg)
66    class (vector_iter_t), pointer :: arg
67    allocate (vector_iter_t :: arg)
68    allocate (vector_t :: arg%container)
69    allocate (arg%container%vec_elem)
70    arg%container%vec_elem%value_p = 99
71  end subroutine
72end module
73
74  use types
75  class (vector_iter_t), pointer :: x
76
77  call factory (x)
78  if (x%get_vector_value() .ne. 99) STOP 1
79  if (x%get_pointer_value() .ne. 99) STOP 2
80end
81