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

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 9695e9b..fdbe4b3 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/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

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 2929679..f2892e2 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/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)

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index aeff6d0..d1469d7 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,7 +1,12 @@
+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.
-        * g++.dg/debug/dwarf2/omp-fesdr.C: Add test.
+       * gcc.dg/debug/dwarf2/omp-fesdr.c: Add test.
+       * g++.dg/debug/dwarf2/omp-fesdr.C: Add test.
 
 2013-09-13  Jacek Caban  <jacek@codeweavers.com>
 

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