diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 9695e9bcf22..fdbe4b39c3e 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2013-09-15 Tobias Burnus + + PR fortran/57697 + * resolve.c (generate_component_assignments): Handle unallocated + LHS with defined assignment of components. + 2013-09-12 Brooks Moses PR driver/42955 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 2929679aecc..f2892e226ee 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index aeff6d08b8a..d1469d790be 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,7 +1,12 @@ +2013-09-15 Tobias Burnus + + PR fortran/57697 + * gfortran.dg/defined_assignment_10.f90: New. + 2013-09-13 Evgeny Gavrin - * 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 diff --git a/gcc/testsuite/gfortran.dg/defined_assignment_10.f90 b/gcc/testsuite/gfortran.dg/defined_assignment_10.f90 new file mode 100644 index 00000000000..03f92c6a47e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/defined_assignment_10.f90 @@ -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