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