From 71e482dcc0c583887cb5e9ea7b9590aac1335bfb Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Wed, 25 Sep 2013 21:54:12 +0200 Subject: [PATCH] re PR fortran/57697 ([OOP] Segfault with defined assignment for components during intrinsic assignment) 2013-09-25 Tobias Burnus PR fortran/57697 PR fortran/58469 * resolve.c (generate_component_assignments): Avoid double free at runtime and freeing a still-being used expr. 2013-09-25 Tobias Burnus PR fortran/57697 PR fortran/58469 * gfortran.dg/defined_assignment_8.f90: New. * gfortran.dg/defined_assignment_9.f90: New. From-SVN: r202922 --- gcc/fortran/ChangeLog | 7 +++ gcc/fortran/resolve.c | 39 +++++++++++----- gcc/testsuite/ChangeLog | 7 +++ .../gfortran.dg/defined_assignment_8.f90 | 40 +++++++++++++++++ .../gfortran.dg/defined_assignment_9.f90 | 45 +++++++++++++++++++ 5 files changed, 127 insertions(+), 11 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/defined_assignment_8.f90 create mode 100644 gcc/testsuite/gfortran.dg/defined_assignment_9.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f43196b669f..445dfaef176 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2013-09-25 Tobias Burnus + + PR fortran/57697 + PR fortran/58469 + * resolve.c (generate_component_assignments): Avoid double free + at runtime and freeing a still-being used expr. + 2013-09-25 Tom Tromey * Make-lang.in (fortran_OBJS): Use fortran/gfortranspec.o. diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index d33fe49b661..4befb9fdda4 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -9602,8 +9602,9 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) && gfc_expr_attr ((*code)->expr1).allocatable) { gfc_code *block; - gfc_expr *cond; - cond = gfc_get_expr (); + gfc_expr *cond; + + cond = gfc_get_expr (); cond->ts.type = BT_LOGICAL; cond->ts.kind = gfc_default_logical_kind; cond->expr_type = EXPR_OP; @@ -9621,7 +9622,7 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) add_code_to_chain (&block, &head, &tail); } } - } + } else if (this_code->op == EXEC_ASSIGN && !this_code->next) { /* Don't add intrinsic assignments since they are already @@ -9643,13 +9644,6 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) } } - /* This is probably not necessary. */ - if (this_code) - { - gfc_free_statements (this_code); - this_code = NULL; - } - /* Put the temporary assignments at the top of the generated code. */ if (tmp_head && component_assignment_level == 1) { @@ -9658,6 +9652,28 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) tmp_head = tmp_tail = NULL; } + // If we did a pointer assignment - thus, we need to ensure that the LHS is + // not accidentally deallocated. Hence, nullify t1. + if (t1 && (*code)->expr1->symtree->n.sym->attr.allocatable + && gfc_expr_attr ((*code)->expr1).allocatable) + { + gfc_code *block; + gfc_expr *cond; + gfc_expr *e; + + e = gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym); + cond = gfc_build_intrinsic_call (ns, GFC_ISYM_ASSOCIATED, "associated", + (*code)->loc, 2, gfc_copy_expr (t1), e); + block = gfc_get_code (EXEC_IF); + block->block = gfc_get_code (EXEC_IF); + block->block->expr1 = cond; + block->block->next = build_assignment (EXEC_POINTER_ASSIGN, + t1, gfc_get_null_expr (&(*code)->loc), + NULL, NULL, (*code)->loc); + gfc_append_code (tail, block); + tail = block; + } + /* Now attach the remaining code chain to the input code. Step on to the end of the new code since resolution is complete. */ gcc_assert ((*code)->op == EXEC_ASSIGN); @@ -9667,7 +9683,8 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) gfc_free_expr ((*code)->expr1); gfc_free_expr ((*code)->expr2); **code = *head; - free (head); + if (head != tail) + free (head); *code = tail; component_assignment_level--; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 09644d21037..cf19ecf33b0 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2013-09-25 Tobias Burnus + + PR fortran/57697 + PR fortran/58469 + * gfortran.dg/defined_assignment_8.f90: New. + * gfortran.dg/defined_assignment_9.f90: New. + 2013-09-25 Marek Polacek PR sanitizer/58413 diff --git a/gcc/testsuite/gfortran.dg/defined_assignment_8.f90 b/gcc/testsuite/gfortran.dg/defined_assignment_8.f90 new file mode 100644 index 00000000000..aab808583ad --- /dev/null +++ b/gcc/testsuite/gfortran.dg/defined_assignment_8.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! +! PR fortran/58469 +! +! Related: PR fortran/57697 +! +! Was ICEing before +! +module m0 + implicit none + type :: component + integer :: i = 42 + contains + procedure :: assign0 + generic :: assignment(=) => assign0 + end type + type, extends(component) :: comp2 + real :: aa + end type comp2 + type parent + type(comp2) :: foo + end type +contains + elemental subroutine assign0(lhs,rhs) + class(component), intent(INout) :: lhs + class(component), intent(in) :: rhs + lhs%i = 20 + end subroutine +end module + +program main + use m0 + implicit none + type(parent), allocatable :: left + type(parent) :: right + print *, right%foo + left = right + print *, left%foo + if (left%foo%i /= 42) call abort() +end diff --git a/gcc/testsuite/gfortran.dg/defined_assignment_9.f90 b/gcc/testsuite/gfortran.dg/defined_assignment_9.f90 new file mode 100644 index 00000000000..50fa0070f18 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/defined_assignment_9.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! +! PR fortran/57697 +! +! Further test of typebound defined assignment +! +module m0 + implicit none + type component + integer :: i = 42 + contains + procedure :: assign0 + generic :: assignment(=) => assign0 + end type + type parent + type(component) :: foo + end type +contains + elemental subroutine assign0(lhs,rhs) + class(component), intent(INout) :: lhs + class(component), intent(in) :: rhs + lhs%i = 20 + end subroutine +end module + +program main + use m0 + implicit none + block + type(parent), allocatable :: left + type(parent) :: right +! print *, right%foo + left = right +! print *, left%foo + if (left%foo%i /= 20) call abort() + end block + block + type(parent), allocatable :: left(:) + type(parent) :: right(5) +! print *, right%foo + left = right +! print *, left%foo + if (any (left%foo%i /= 20)) call abort() + end block +end