re PR fortran/57697 ([OOP] Segfault with defined assignment for components during intrinsic assignment)
2013-09-15 Tobias Burnus <burnus@net-b.de> PR fortran/57697 * resolve.c (generate_component_assignments): Handle unallocated LHS with defined assignment of components. 2013-09-15 Tobias Burnus <burnus@net-b.de> PR fortran/57697 * gfortran.dg/defined_assignment_10.f90: New. From-SVN: r202601
This commit is contained in:
parent
97191ad093
commit
5ef7093dde
|
@ -1,3 +1,9 @@
|
|||
2013-09-15 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/57697
|
||||
* resolve.c (generate_component_assignments): Handle unallocated
|
||||
LHS with defined assignment of components.
|
||||
|
||||
2013-09-12 Brooks Moses <bmoses@google.com>
|
||||
|
||||
PR driver/42955
|
||||
|
|
|
@ -9546,6 +9546,21 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
|
|||
temp_code = build_assignment (EXEC_ASSIGN,
|
||||
t1, (*code)->expr1,
|
||||
NULL, NULL, (*code)->loc);
|
||||
|
||||
/* For allocatable LHS, check whether it is allocated. */
|
||||
if (gfc_expr_attr((*code)->expr1).allocatable)
|
||||
{
|
||||
gfc_code *block;
|
||||
block = gfc_get_code (EXEC_IF);
|
||||
block->block = gfc_get_code (EXEC_IF);
|
||||
block->block->expr1
|
||||
= gfc_build_intrinsic_call (ns,
|
||||
GFC_ISYM_ASSOCIATED, "allocated",
|
||||
(*code)->loc, 2,
|
||||
gfc_copy_expr ((*code)->expr1), NULL);
|
||||
block->block->next = temp_code;
|
||||
temp_code = block;
|
||||
}
|
||||
add_code_to_chain (&temp_code, &tmp_head, &tmp_tail);
|
||||
}
|
||||
|
||||
|
@ -9554,6 +9569,31 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
|
|||
gfc_free_expr (this_code->ext.actual->expr);
|
||||
this_code->ext.actual->expr = gfc_copy_expr (t1);
|
||||
add_comp_ref (this_code->ext.actual->expr, comp1);
|
||||
|
||||
/* If the LHS is not allocated, we pointer-assign the LHS address
|
||||
to the temporary - after the LHS has been allocated. */
|
||||
if (gfc_expr_attr((*code)->expr1).allocatable)
|
||||
{
|
||||
gfc_code *block;
|
||||
gfc_expr *cond;
|
||||
cond = gfc_get_expr ();
|
||||
cond->ts.type = BT_LOGICAL;
|
||||
cond->ts.kind = gfc_default_logical_kind;
|
||||
cond->expr_type = EXPR_OP;
|
||||
cond->where = (*code)->loc;
|
||||
cond->value.op.op = INTRINSIC_NOT;
|
||||
cond->value.op.op1 = gfc_build_intrinsic_call (ns,
|
||||
GFC_ISYM_ASSOCIATED, "allocated",
|
||||
(*code)->loc, 2,
|
||||
gfc_copy_expr (t1), NULL);
|
||||
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, (*code)->expr1,
|
||||
NULL, NULL, (*code)->loc);
|
||||
add_code_to_chain (&block, &head, &tail);
|
||||
}
|
||||
}
|
||||
}
|
||||
else if (this_code->op == EXEC_ASSIGN && !this_code->next)
|
||||
|
|
|
@ -1,7 +1,12 @@
|
|||
2013-09-15 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/57697
|
||||
* gfortran.dg/defined_assignment_10.f90: New.
|
||||
|
||||
2013-09-13 Evgeny Gavrin <e.gavrin@samsung.com>
|
||||
|
||||
* gcc.dg/debug/dwarf2/omp-fesdr.c: Add test.
|
||||
* g++.dg/debug/dwarf2/omp-fesdr.C: Add test.
|
||||
* gcc.dg/debug/dwarf2/omp-fesdr.c: Add test.
|
||||
* g++.dg/debug/dwarf2/omp-fesdr.C: Add test.
|
||||
|
||||
2013-09-13 Jacek Caban <jacek@codeweavers.com>
|
||||
|
||||
|
|
|
@ -0,0 +1,35 @@
|
|||
! { 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
|
||||
type(parent), allocatable :: left
|
||||
type(parent) :: right
|
||||
print *, right%foo
|
||||
left = right
|
||||
! print *, left%foo
|
||||
if (left%foo%i /= 20) call abort()
|
||||
end
|
Loading…
Reference in New Issue