re PR fortran/57697 ([OOP] Segfault with defined assignment for components during intrinsic assignment)
2013-09-25 Tobias Burnus <burnus@net-b.de> 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 <burnus@net-b.de> PR fortran/57697 PR fortran/58469 * gfortran.dg/defined_assignment_8.f90: New. * gfortran.dg/defined_assignment_9.f90: New. From-SVN: r202922
This commit is contained in:
parent
2272ddac7e
commit
71e482dcc0
|
@ -1,3 +1,10 @@
|
|||
2013-09-25 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
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 <tromey@redhat.com>
|
||||
|
||||
* Make-lang.in (fortran_OBJS): Use fortran/gfortranspec.o.
|
||||
|
|
|
@ -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--;
|
||||
|
|
|
@ -1,3 +1,10 @@
|
|||
2013-09-25 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
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 <polacek@redhat.com>
|
||||
|
||||
PR sanitizer/58413
|
||||
|
|
|
@ -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
|
|
@ -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
|
Loading…
Reference in New Issue