--- Begin Message ---
Re-sent as it didn't show up in the archive. (I wonder why this and
another email didn't made it, but the follow-up to that email did.)
Tobias Burnus wrote:
Hi Thomas, hello all,
As it turned out, my patch wasn't working for the real-world code. I
created a follow-up patch. See below.
* * *
Thomas Koenig wrote:
the patch is OK, also for 4.8. Thanks a lot for fixing this.
Thanks for the review!
Just a couple of nits:
- You may want to remove the output from the test case.
Done. (Well, I missed one print line.)
- The two consecutive ifs in
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;
are a little bit inelegant. It is not really important, because
they will be merged on optimization, but if you find an easy
way to do this in the FE code, you might want to consider doing
so. I would advise against spending a lot of work on this, though :-)
That's a bit difficult - part of the "if"s are generated at resolution
time (resolve.c, like my patch) others are generated in trans-expr.c
for realloc on assignment. I don't see a simple way to avoid the two
conditions, unfortunately.
Committed to the trunk as Rev. 202601. (By the way, the automatic
addition of the committal to the PR now works again :-)
* * *
As testing showed, it didn't fix the real-world code: ForTrilinos's
ForTrilinos_ADT_3D_Burgers_6th_Pade did still fail as it has:
*_F.DA65 = matrix_diff_x (&parm.621);
_F.DA66 = ax->epetra_rowmatrix.universal; // Deref of "ax"!
The reason for the failure is that ax == NULL but only "ax" is
allocatable while universal isn't. That's now fixed by the attached
patch. With that patch, ForTrilions's
ForTrilinos_ADT_3D_Burgers_6th_Pade and
ForTrilinos_concrete_burgers_solver now pass (instead of segfault).
Additionally, I changed ISYM_ASSOCIATED to ISYM_ALLOCATED which
matches the internal name and is a bit more consistent. As either one
boils down to a null-pointer check, it shouldn't lead to any code-gen
difference on tree level.
Build and regtested on x86-64-gnu-linux.
OK?
Tobias
2013-09-15 Tobias Burnus <bur...@net-b.de>
PR fortran/57697
* resolve.c (generate_component_assignments): Correctly handle the
case that the LHS is not allocated.
2013-09-15 Tobias Burnus <bur...@net-b.de>
PR fortran/57697
* gfortran.dg/defined_assignment_10.f90: Comment print statement.
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index f2892e2..fbd9a6a 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -9547,17 +9547,20 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
t1, (*code)->expr1,
NULL, NULL, (*code)->loc);
- /* For allocatable LHS, check whether it is allocated. */
- if (gfc_expr_attr((*code)->expr1).allocatable)
+ /* For allocatable LHS, check whether it is allocated. Note
+ that allocatable components with defined assignment are
+ not yet support. See PR 57696. */
+ if ((*code)->expr1->symtree->n.sym->attr.allocatable)
{
gfc_code *block;
+ gfc_expr *e =
+ gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym);
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);
+ GFC_ISYM_ALLOCATED, "allocated",
+ (*code)->loc, 1, e);
block->block->next = temp_code;
temp_code = block;
}
@@ -9570,9 +9573,11 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
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)
+ /* If the LHS variable is allocatable and wasn't allocated and
+ the temporary is allocatable, pointer assign the address of
+ the freshly allocated LHS to the temporary. */
+ if ((*code)->expr1->symtree->n.sym->attr.allocatable
+ && gfc_expr_attr ((*code)->expr1).allocatable)
{
gfc_code *block;
gfc_expr *cond;
@@ -9583,9 +9588,8 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
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);
+ GFC_ISYM_ALLOCATED, "allocated",
+ (*code)->loc, 1, gfc_copy_expr (t1));
block = gfc_get_code (EXEC_IF);
block->block = gfc_get_code (EXEC_IF);
block->block->expr1 = cond;
diff --git a/gcc/testsuite/gfortran.dg/defined_assignment_10.f90 b/gcc/testsuite/gfortran.dg/defined_assignment_10.f90
index 03f92c6..4385925 100644
--- a/gcc/testsuite/gfortran.dg/defined_assignment_10.f90
+++ b/gcc/testsuite/gfortran.dg/defined_assignment_10.f90
@@ -28,7 +28,7 @@ program main
implicit none
type(parent), allocatable :: left
type(parent) :: right
- print *, right%foo
+! print *, right%foo
left = right
! print *, left%foo
if (left%foo%i /= 20) call abort()
--- End Message ---
