I have committed the attached patch to the GCC 4.8 branch, backporting
some defined assignment patches. Committed as Rev. 203207/203208.
GCC 4.8 added defined assignment for components during intrinsic
assignment, which had some issues.
a) PR 57697/PR58469
Patch: http://gcc.gnu.org/ml/fortran/2013-09/msg00039.html
Approval: http://gcc.gnu.org/ml/fortran/2013-09/msg00056.html
b) http://gcc.gnu.org/ml/fortran/2013-09/msg00016.html
c) http://gcc.gnu.org/ml/fortran/2013-09/msg00026.html
d) http://gcc.gnu.org/ml/fortran/2013-09/msg00038.html
Tobias
Index: gcc/fortran/ChangeLog
===================================================================
--- gcc/fortran/ChangeLog (Revision 203206)
+++ gcc/fortran/ChangeLog (Arbeitskopie)
@@ -1,3 +1,13 @@
+2013-10-04 Tobias Burnus <bur...@net-b.de>
+
+ Backport from mainline
+ 2013-09-25 Tobias Burnus <bur...@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-08-24 Mikael Morin <mik...@gcc.gnu.org>
PR fortran/57798
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (Revision 203206)
+++ gcc/fortran/resolve.c (Arbeitskopie)
@@ -9997,6 +9997,26 @@
temp_code = build_assignment (EXEC_ASSIGN,
t1, (*code)->expr1,
NULL, NULL, (*code)->loc);
+
+ /* 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 ();
+ block->op = EXEC_IF;
+ block->block = gfc_get_code ();
+ block->block->op = EXEC_IF;
+ block->block->expr1
+ = gfc_build_intrinsic_call (ns,
+ GFC_ISYM_ALLOCATED, "allocated",
+ (*code)->loc, 1, e);
+ block->block->next = temp_code;
+ temp_code = block;
+ }
add_code_to_chain (&temp_code, &tmp_head, &tmp_tail);
}
@@ -10005,8 +10025,37 @@
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 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;
+
+ 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_ALLOCATED, "allocated",
+ (*code)->loc, 1, gfc_copy_expr (t1));
+ block = gfc_get_code ();
+ block->op = EXEC_IF;
+ block->block = gfc_get_code ();
+ block->block->op = 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)
{
/* Don't add intrinsic assignments since they are already
@@ -10028,13 +10077,6 @@
}
}
- /* 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)
{
@@ -10043,6 +10085,30 @@
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 ();
+ block->op = EXEC_IF;
+ block->block = gfc_get_code ();
+ block->block->op = 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);
@@ -10052,7 +10118,8 @@
gfc_free_expr ((*code)->expr1);
gfc_free_expr ((*code)->expr2);
**code = *head;
- free (head);
+ if (head != tail)
+ free (head);
*code = tail;
component_assignment_level--;
Index: gcc/testsuite/ChangeLog
===================================================================
--- gcc/testsuite/ChangeLog (Revision 203206)
+++ gcc/testsuite/ChangeLog (Arbeitskopie)
@@ -1,3 +1,13 @@
+2013-10-04 Tobias Burnus <bur...@net-b.de>
+
+ Backport from mainline
+ 2013-09-25 Tobias Burnus <bur...@net-b.de>
+
+ PR fortran/57697
+ PR fortran/58469
+ * gfortran.dg/defined_assignment_8.f90: New.
+ * gfortran.dg/defined_assignment_9.f90: New.
+
2013-10-04 Marcus Shawcroft <marcus.shawcr...@arm.com>
Backport from mainline.
Index: gcc/testsuite/gfortran.dg/defined_assignment_10.f90
===================================================================
--- gcc/testsuite/gfortran.dg/defined_assignment_10.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/defined_assignment_10.f90 (Arbeitskopie)
@@ -0,0 +1,37 @@
+! { 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
+end
Index: gcc/testsuite/gfortran.dg/defined_assignment_11.f90
===================================================================
--- gcc/testsuite/gfortran.dg/defined_assignment_11.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/defined_assignment_11.f90 (Arbeitskopie)
@@ -0,0 +1,43 @@
+! { dg-do run }
+!
+! PR fortran/57697
+!
+! Further test of typebound defined assignment
+!
+module m0
+ implicit none
+ type :: component
+ integer :: i = 42
+ integer, allocatable :: b
+ contains
+ procedure :: assign0
+ generic :: assignment(=) => assign0
+ end type
+ type, extends(component) :: comp2
+ real :: aa
+ end type comp2
+ type parent
+ type(component) :: foo
+ real :: cc
+ end type
+ type p2
+ type(parent) :: x
+ end type p2
+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(p2), allocatable :: left
+ type(p2) :: right
+! print *, right%x%foo%i
+ left = right
+! print *, left%x%foo%i
+ if (left%x%foo%i /= 20) call abort()
+end
Index: gcc/testsuite/gfortran.dg/defined_assignment_8.f90
===================================================================
--- gcc/testsuite/gfortran.dg/defined_assignment_8.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/defined_assignment_8.f90 (Arbeitskopie)
@@ -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
Index: gcc/testsuite/gfortran.dg/defined_assignment_9.f90
===================================================================
--- gcc/testsuite/gfortran.dg/defined_assignment_9.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/defined_assignment_9.f90 (Arbeitskopie)
@@ -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
Index: gcc/testsuite/ChangeLog
===================================================================
--- gcc/testsuite/ChangeLog (Revision 203207)
+++ gcc/testsuite/ChangeLog (Arbeitskopie)
@@ -1,12 +1,11 @@
2013-10-04 Tobias Burnus <bur...@net-b.de>
- Backport from mainline
- 2013-09-25 Tobias Burnus <bur...@net-b.de>
-
PR fortran/57697
PR fortran/58469
* gfortran.dg/defined_assignment_8.f90: New.
* gfortran.dg/defined_assignment_9.f90: New.
+ * gfortran.dg/defined_assignment_10.f90: New.
+ * gfortran.dg/defined_assignment_11.f90: New.
2013-10-04 Marcus Shawcroft <marcus.shawcr...@arm.com>
