Hi all, attached patch fixes the issue raised. The issue here was, that a copy of the base class was generated and its address passed to the _vptr->copy()-method, which then accessed memory, that was not present in the copy being an object of the base class. The patch fixes this by making sure the temporary handle is a pointer to the data to copy.
Sorry, when that is not clear. I am not feeling so well today. So here in terms of pseudo code. This code was formerly generated: struct ac {}; struct a : struct ac { integer *i; }; a src, dst; ac temp; temp = src; // temp is now only a copy of ac _vptr.copy(&temp, &dst); // temp does not denote memory having a pointer to i After the patch, this code is generated: // types as above a src, dst; ac *temp; // !!! Now a pointer temp = &src; _vptr.copy(temp, &dst); // temp now points to memory that has a pointer to i // and is valid for copying. Bootstraps and regtests ok on x86_64-linux/F23. Ok for trunk? Regards, Andre -- Andre Vehreschild * Email: vehre ad gmx dot de
gcc/fortran/ChangeLog: 2016-11-15 Andre Vehreschild <ve...@gcc.gnu.org> 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-15 Andre Vehreschild <ve...@gcc.gnu.org> PR fortran/78356 * gfortran.dg/class_allocate_23.f08: New test.
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index b42ec40..9db86b4 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 48296b8..1331b07 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/gfortran.dg/class_allocate_23.f08 b/gcc/testsuite/gfortran.dg/class_allocate_23.f08 new file mode 100644 index 0000000..5c83fbe --- /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 +