gcc/testsuite/gfortran.dg/class_63.f90

   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 !
  13 module 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
  42 contains
  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
  72 end 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
  80 end