From dc9e0b66b22fa73f396645d7efd8b73649f2fe6b Mon Sep 17 00:00:00 2001 From: Andre Vehreschild Date: Wed, 16 Nov 2016 14:45:29 +0100 Subject: [PATCH] re PR fortran/78356 ([OOP] segfault allocating polymorphic variable with polymorphic component with allocatable component) gcc/fortran/ChangeLog: 2016-11-16 Andre Vehreschild PR fortran/78356 * class.c (gfc_is_class_scalar_expr): Prevent taking an array ref for a component ref. * trans-expr.c (gfc_trans_assignment_1): Ensure a reference to the object to copy is generated, when assigning class objects. gcc/testsuite/ChangeLog: 2016-11-16 Andre Vehreschild PR fortran/78356 * gfortran.dg/class_allocate_23.f08: New test. From-SVN: r242490 --- gcc/fortran/ChangeLog | 8 +++++ gcc/fortran/class.c | 6 ++-- gcc/fortran/trans-expr.c | 27 +++++++++++----- gcc/testsuite/ChangeLog | 5 +++ .../gfortran.dg/class_allocate_23.f08 | 31 +++++++++++++++++++ 5 files changed, 67 insertions(+), 10 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/class_allocate_23.f08 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index cf16e1a8754..4dad588c3d2 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2016-11-16 Andre Vehreschild + + PR fortran/78356 + * class.c (gfc_is_class_scalar_expr): Prevent taking an array ref for + a component ref. + * trans-expr.c (gfc_trans_assignment_1): Ensure a reference to the + object to copy is generated, when assigning class objects. + 2016-11-14 Thomas Koenig * dump-parse-tree.c (show_code): Add prototype. diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index b42ec40578f..9db86b409b5 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -378,7 +378,8 @@ gfc_is_class_scalar_expr (gfc_expr *e) && CLASS_DATA (e->symtree->n.sym) && !CLASS_DATA (e->symtree->n.sym)->attr.dimension && (e->ref == NULL - || (strcmp (e->ref->u.c.component->name, "_data") == 0 + || (e->ref->type == REF_COMPONENT + && strcmp (e->ref->u.c.component->name, "_data") == 0 && e->ref->next == NULL))) return true; @@ -390,7 +391,8 @@ gfc_is_class_scalar_expr (gfc_expr *e) && CLASS_DATA (ref->u.c.component) && !CLASS_DATA (ref->u.c.component)->attr.dimension && (ref->next == NULL - || (strcmp (ref->next->u.c.component->name, "_data") == 0 + || (ref->next->type == REF_COMPONENT + && strcmp (ref->next->u.c.component->name, "_data") == 0 && ref->next->next == NULL))) return true; } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 48296b8dbdb..1331b07a238 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -9628,6 +9628,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, int n; bool maybe_workshare = false; symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr; + bool is_poly_assign; /* Assignment of the form lhs = rhs. */ gfc_start_block (&block); @@ -9648,6 +9649,19 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, || gfc_is_alloc_class_scalar_function (expr2))) expr2->must_finalize = 1; + /* Checking whether a class assignment is desired is quite complicated and + needed at two locations, so do it once only before the information is + needed. */ + lhs_attr = gfc_expr_attr (expr1); + is_poly_assign = (use_vptr_copy || lhs_attr.pointer + || (lhs_attr.allocatable && !lhs_attr.dimension)) + && (expr1->ts.type == BT_CLASS + || gfc_is_class_array_ref (expr1, NULL) + || gfc_is_class_scalar_expr (expr1) + || gfc_is_class_array_ref (expr2, NULL) + || gfc_is_class_scalar_expr (expr2)); + + /* Only analyze the expressions for coarray properties, when in coarray-lib mode. */ if (flag_coarray == GFC_FCOARRAY_LIB) @@ -9676,6 +9690,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, if (rss == gfc_ss_terminator) /* The rhs is scalar. Add a ss for the expression. */ rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2); + /* When doing a class assign, then the handle to the rhs needs to be a + pointer to allow for polymorphism. */ + if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2)) + rss->info->type = GFC_SS_REFERENCE; /* Associate the SS with the loop. */ gfc_add_ss_to_loop (&loop, lss); @@ -9835,14 +9853,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, gfc_add_block_to_block (&loop.post, &rse.post); } - lhs_attr = gfc_expr_attr (expr1); - if ((use_vptr_copy || lhs_attr.pointer - || (lhs_attr.allocatable && !lhs_attr.dimension)) - && (expr1->ts.type == BT_CLASS - || (gfc_is_class_array_ref (expr1, NULL) - || gfc_is_class_scalar_expr (expr1)) - || (gfc_is_class_array_ref (expr2, NULL) - || gfc_is_class_scalar_expr (expr2)))) + if (is_poly_assign) { tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse, use_vptr_copy || (lhs_attr.allocatable diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 59a707f0dbc..4f6d853c468 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2016-11-16 Andre Vehreschild + + PR fortran/78356 + * gfortran.dg/class_allocate_23.f08: New test. + 2016-11-16 Richard Biener PR middle-end/78333 diff --git a/gcc/testsuite/gfortran.dg/class_allocate_23.f08 b/gcc/testsuite/gfortran.dg/class_allocate_23.f08 new file mode 100644 index 00000000000..5c83fbe9618 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_allocate_23.f08 @@ -0,0 +1,31 @@ +! { dg-do run } +! +! Test that pr78356 is fixed. +! Contributed by Janus Weil and Andrew Benson + +program p + implicit none + type ac + end type + type, extends(ac) :: a + integer, allocatable :: b + end type + type n + class(ac), allocatable :: acr(:) + end type + type(n) :: s,t + allocate(a :: s%acr(1)) + call nncp(s,t) + select type (cl => t%acr(1)) + class is (a) + if (allocated(cl%b)) error stop + class default + error stop + end select +contains + subroutine nncp(self,tg) + type(n) :: self, tg + allocate(tg%acr(1),source=self%acr(1)) + end +end + -- 2.30.2