From dce9a92ec04ce9a6a99e6338a8d6068531925d34 Mon Sep 17 00:00:00 2001 From: pault Date: Sat, 28 Oct 2017 08:53:19 +0000 Subject: 2017-10-28 Paul Thomas PR fortran/81758 * trans-expr.c (trans_class_vptr_len_assignment): 'vptr_expr' must only be set if the right hand side expression is of type class. 2017-10-28 Paul Thomas PR fortran/81758 * gfortran.dg/class_63.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/gcc-7-branch@254196 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 8 ++++ gcc/fortran/trans-expr.c | 2 +- gcc/testsuite/ChangeLog | 6 +++ gcc/testsuite/gfortran.dg/class_63.f90 | 80 ++++++++++++++++++++++++++++++++++ 4 files changed, 95 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/class_63.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 8caea71f5b9..9f1e011445b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2017-10-28 Paul Thomas + + Backported from trunk + PR fortran/81758 + * trans-expr.c (trans_class_vptr_len_assignment): 'vptr_expr' + must only be set if the right hand side expression is of type + class. + 2017-10-21 Paul Thomas Backport from trunk diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 1f8c1d30d79..36046deb010 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -8051,7 +8051,7 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le, { /* Get the vptr from the rhs expression only, when it is variable. Functions are expected to be assigned to a temporary beforehand. */ - vptr_expr = re->expr_type == EXPR_VARIABLE + vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS) ? gfc_find_and_cut_at_last_class_ref (re) : NULL; if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 489df4b6db2..c75839a9798 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2017-10-28 Paul Thomas + + Backported from trunk + PR fortran/81758 + * gfortran.dg/class_63.f90: New test. + 2017-10-27 Jakub Jelinek Backported from mainline diff --git a/gcc/testsuite/gfortran.dg/class_63.f90 b/gcc/testsuite/gfortran.dg/class_63.f90 new file mode 100644 index 00000000000..cf99bcf9cb2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_63.f90 @@ -0,0 +1,80 @@ +! { dg-do run } +! +! Tests the fix for PR81758, in which the vpointer for 'ptr' in +! function 'pointer_value' would be set to the vtable of the component +! 'container' rather than that of the component 'vec_elem'. In this test +! case it is ensured that there is a single typebound procedure for both +! types, so that different values are returned. In the original problem +! completely different procedures were involved so that a segfault resulted. +! +! Reduced from the original code of Dimitry Liakh by +! Paul Thomas +! +module types + type, public:: gfc_container_t + contains + procedure, public:: get_value => ContTypeGetValue + end type gfc_container_t + + !Element of a container: + type, public:: gfc_cont_elem_t + integer :: value_p + contains + procedure, public:: get_value => ContElemGetValue + end type gfc_cont_elem_t + + !Vector element: + type, extends(gfc_cont_elem_t), public:: vector_elem_t + end type vector_elem_t + + !Vector: + type, extends(gfc_container_t), public:: vector_t + type(vector_elem_t), allocatable, private :: vec_elem + end type vector_t + + type, public :: vector_iter_t + class(vector_t), pointer, private :: container => NULL() + contains + procedure, public:: get_vector_value => vector_Value + procedure, public:: get_pointer_value => pointer_value + end type + +contains + integer function ContElemGetValue (this) + class(gfc_cont_elem_t) :: this + ContElemGetValue = this%value_p + end function + + integer function ContTypeGetValue (this) + class(gfc_container_t) :: this + ContTypeGetValue = 0 + end function + + integer function vector_Value (this) + class(vector_iter_t) :: this + vector_value = this%container%vec_elem%get_value() + end function + + integer function pointer_value (this) + class(vector_iter_t), target :: this + class(gfc_cont_elem_t), pointer :: ptr + ptr => this%container%vec_elem + pointer_value = ptr%get_value() + end function + + subroutine factory (arg) + class (vector_iter_t), pointer :: arg + allocate (vector_iter_t :: arg) + allocate (vector_t :: arg%container) + allocate (arg%container%vec_elem) + arg%container%vec_elem%value_p = 99 + end subroutine +end module + + use types + class (vector_iter_t), pointer :: x + + call factory (x) + if (x%get_vector_value() .ne. 99) call abort + if (x%get_pointer_value() .ne. 99) call abort +end -- cgit v1.2.1