2013-09-10 Tobias Burnus <burnus@net-b.de>
PR fortran/57697
* resolve.c (generate_component_assignments): Handle unallocated
LHS with defined assignment of components.
2013-09-10 Tobias Burnus <burnus@net-b.de>
PR fortran/57697
* gfortran.dg/defined_assignment_10.f90: New.
@@ -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)
new file mode 100644
@@ -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
Dear all, in Fortran 2003, it can happen that for an intrinisic assignment of a derived type, the component fits to a defined assignment; in that case, the latter is invoked. gfortran implements this since GCC 4.8 (December). However, it turned out that the current algorithm doesn't work if the LHS is allocatable and unallocated as it generated the following code: if (_F.DA0 != 0B) goto L.1; _F.DA0 = (struct parent *) __builtin_malloc (4); L.1:; *_F.DA0 = *left; if (left != 0B) goto L.3; left = (struct parent *) __builtin_malloc (4); L.3:; *left = right; The line "*_F.DA0 = *left;" will fail due to the NULL-pointer deref. With the attached patch, one generates the code: if (left != 0B) { if (_F.DA0 != 0B) goto L.2; _F.DA0 = (struct parent *) __builtin_malloc (4); L.2:; *_F.DA0 = *left; } L.1:; if (left != 0B) goto L.4; left = (struct parent *) __builtin_malloc (4); L.4:; *left = right; if (_F.DA0 == 0B) _F.DA0 = left; // Note: That's a pointer assignment Built and regtested on x86-64-gnu-linux. OK for the trunk? What about GCC 4.8? It's not a true regression (as defined assignments are new), but it causes segfaults with code which worked before GCC 4.8 [Dec 2012] (albeit with intrinsic instead of defined assignment). Tobias PS: One code which exposes the problem is a test case shipping with ForTrilinos.