2013-09-25 Tobias Burnus <burnus@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-09-25  Tobias Burnus  <burnus@net-b.de>

        PR fortran/57697
        PR fortran/58469
        * gfortran.dg/defined_assignment_8.f90: New.
        * gfortran.dg/defined_assignment_9.f90: New.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@202922 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f43196b..445dfae 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2013-09-25  Tobias Burnus  <burnus@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-09-25  Tom Tromey  <tromey@redhat.com>
 
        * Make-lang.in (fortran_OBJS): Use fortran/gfortranspec.o.

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index d33fe49..4befb9f 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -9602,8 +9602,9 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
                  && gfc_expr_attr ((*code)->expr1).allocatable)
                {
                  gfc_code *block;
-                  gfc_expr *cond;
-                  cond = gfc_get_expr ();
+                 gfc_expr *cond;
+
+                 cond = gfc_get_expr ();
                  cond->ts.type = BT_LOGICAL;
                  cond->ts.kind = gfc_default_logical_kind;
                  cond->expr_type = EXPR_OP;
@@ -9621,7 +9622,7 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
                  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
@@ -9643,13 +9644,6 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
        }
     }
 
-  /* 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)
     {
@@ -9658,6 +9652,28 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
       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 (EXEC_IF);
+      block->block = gfc_get_code (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);
@@ -9667,7 +9683,8 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
   gfc_free_expr ((*code)->expr1);
   gfc_free_expr ((*code)->expr2);
   **code = *head;
-  free (head);
+  if (head != tail)
+    free (head);
   *code = tail;
 
   component_assignment_level--;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 09644d2..cf19ecf 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2013-09-25  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/57697
+       PR fortran/58469
+       * gfortran.dg/defined_assignment_8.f90: New.
+       * gfortran.dg/defined_assignment_9.f90: New.
+
 2013-09-25  Marek Polacek  <polacek@redhat.com>
 
        PR sanitizer/58413

diff --git a/gcc/testsuite/gfortran.dg/defined_assignment_8.f90 b/gcc/testsuite/gfortran.dg/defined_assignment_8.f90
new file mode 100644 (file)
index 0000000..aab8085
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/defined_assignment_8.f90
@@ -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

diff --git a/gcc/testsuite/gfortran.dg/defined_assignment_9.f90 b/gcc/testsuite/gfortran.dg/defined_assignment_9.f90
new file mode 100644 (file)
index 0000000..50fa007
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/defined_assignment_9.f90
@@ -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