re PR fortran/57697 ([OOP] Segfault with defined assignment for components during intrinsic assignment)

2013-09-15  Tobias Burnus  <burnus@net-b.de>

        PR fortran/57697
        * resolve.c (generate_component_assignments): Handle unallocated
        LHS with defined assignment of components.

2013-09-15  Tobias Burnus  <burnus@net-b.de>

        PR fortran/57697
        * gfortran.dg/defined_assignment_10.f90: New.

From-SVN: r202601

gcc/fortran/ChangeLog

@@ -1,3 +1,9 @@
+2013-09-15  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57697
+	* resolve.c (generate_component_assignments): Handle unallocated
+	LHS with defined assignment of components.
+
 2013-09-12  Brooks Moses  <bmoses@google.com>
 
 	PR driver/42955

gcc/fortran/resolve.c

@@ -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)

gcc/testsuite/ChangeLog

@@ -1,3 +1,8 @@
+2013-09-15  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/57697
+	* gfortran.dg/defined_assignment_10.f90: New.
+
 2013-09-13  Evgeny Gavrin <e.gavrin@samsung.com>
 
 	* gcc.dg/debug/dwarf2/omp-fesdr.c: Add test.

gcc/testsuite/gfortran.dg/defined_assignment_10.f90

@@ -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