diff mbox

[Fortran] PR57697/58469 - Fix another defined-assignment issue

Message ID 523B4C60.5050607@net-b.de
State New
Headers show

Commit Message

Tobias Burnus Sept. 19, 2013, 7:11 p.m. UTC 
This patch fixes two issues:

a) It could happen that no code change has happened. In that case, the 
one freed an expression which still should be used.

b) In my previous patch, I used a pointer assignment to the temporary of 
the LHS (after its allocation) [only if the LHS was initially 
unassigned]. That lead to a problem with double deallocation (temporary 
+ LHS). In the previous test case, it didn't matter as the LHS wasn't 
freed (implicit SAVE of in the main program). That's now solved by a 
NULL-pointer assignment.

Finally, I corrected some indenting issues and removed unreachable code.

Build and regtested on x86-64-gnu-linux.
OK for the trunk and the 4.8 branch?

Tobias

PS: For the testcase of (a), I am not quite sure whether the intrinsic 
assignment should invoke the defined assignment. It currently doesn't 
for gfortran and crayftn. In any case, the invalid freeing is wrong.

Comments

Tobias Burnus Sept. 25, 2013, 6:58 p.m. UTC | #1 
* PING * http://gcc.gnu.org/ml/fortran/2013-09/msg00039.html

Additionally pinging for: 
http://gcc.gnu.org/ml/fortran/2013-09/msg00031.html


On September 19, 2013 21:11, Tobias Burnus wrote:
> This patch fixes two issues:
>
> a) It could happen that no code change has happened. In that case, the 
> one freed an expression which still should be used.
>
> b) In my previous patch, I used a pointer assignment to the temporary 
> of the LHS (after its allocation) [only if the LHS was initially 
> unassigned]. That lead to a problem with double deallocation 
> (temporary + LHS). In the previous test case, it didn't matter as the 
> LHS wasn't freed (implicit SAVE of in the main program). That's now 
> solved by a NULL-pointer assignment.
>
> Finally, I corrected some indenting issues and removed unreachable code.
>
> Build and regtested on x86-64-gnu-linux.
> OK for the trunk and the 4.8 branch?
>
> Tobias
>
> PS: For the testcase of (a), I am not quite sure whether the intrinsic 
> assignment should invoke the defined assignment. It currently doesn't 
> for gfortran and crayftn. In any case, the invalid freeing is wrong.
Thomas Koenig Sept. 25, 2013, 7:08 p.m. UTC | #2 
Hi Tobias,

> * PING * http://gcc.gnu.org/ml/fortran/2013-09/msg00039.html
> 
> Additionally pinging for:
> http://gcc.gnu.org/ml/fortran/2013-09/msg00031.html

Both are OK.

Thanks a lot for the patches!

	Thomas
diff mbox

Patch

2013-09-19  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-19  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.

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index d33fe49..4befb9fd 100644
--- 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/gfortran.dg/defined_assignment_8.f90 b/gcc/testsuite/gfortran.dg/defined_assignment_8.f90
new file mode 100644
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
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