re PR fortran/45004 ([OOP] Segfault with allocatable scalars and move_alloc)

2010-07-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/45004
	* trans-stmt.h (gfc_trans_class_init_assign): New prototype.
	(gfc_trans_class_assign): Modified prototype.
	* trans.h (gfc_conv_intrinsic_move_alloc): New prototype.
	* trans-expr.c (gfc_trans_class_init_assign): Split off from ...
	(gfc_trans_class_assign): ... here. Modified actual arguments.
	* trans-intrinsic.c (gfc_conv_intrinsic_move_alloc): New function to
	handle the MOVE_ALLOC intrinsic with scalar and class arguments.
	* trans.c (trans_code): Call 'gfc_conv_intrinsic_move_alloc'.


2010-07-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/45004
	* gfortran.dg/move_alloc_2.f90: New.

From-SVN: r162688

8 files changed, 136 insertions, 39 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 02263af..f22ed11 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,15 @@
+2010-07-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45004
+	* trans-stmt.h (gfc_trans_class_init_assign): New prototype.
+	(gfc_trans_class_assign): Modified prototype.
+	* trans.h (gfc_conv_intrinsic_move_alloc): New prototype.
+	* trans-expr.c (gfc_trans_class_init_assign): Split off from ...
+	(gfc_trans_class_assign): ... here. Modified actual arguments.
+	* trans-intrinsic.c (gfc_conv_intrinsic_move_alloc): New function to
+	handle the MOVE_ALLOC intrinsic with scalar and class arguments.
+	* trans.c (trans_code): Call 'gfc_conv_intrinsic_move_alloc'.
+
 2010-07-29  Mikael Morin  <mikael@gcc.gnu.org>
 
 	PR fortran/42051
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index a83d4b3..53df2ae 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5671,11 +5671,38 @@ void gfc_trans_assign_vtab_procs (stmtblock_t *block, gfc_symbol *dt,
 }
 
 
+/* Special case for initializing a CLASS variable on allocation.
+   A MEMCPY is needed to copy the full data of the dynamic type,
+   which may be different from the declared type.  */
+
+tree
+gfc_trans_class_init_assign (gfc_code *code)
+{
+  stmtblock_t block;
+  tree tmp, memsz;
+  gfc_se dst,src;
+  
+  gfc_start_block (&block);
+  
+  gfc_init_se (&dst, NULL);
+  gfc_init_se (&src, NULL);
+  gfc_add_component_ref (code->expr1, "$data");
+  gfc_conv_expr (&dst, code->expr1);
+  gfc_conv_expr (&src, code->expr2);
+  gfc_add_block_to_block (&block, &src.pre);
+  memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
+  tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
+  gfc_add_expr_to_block (&block, tmp);
+  
+  return gfc_finish_block (&block);
+}
+
+
 /* Translate an assignment to a CLASS object
    (pointer or ordinary assignment).  */
 
 tree
-gfc_trans_class_assign (gfc_code *code)
+gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
 {
   stmtblock_t block;
   tree tmp;
@@ -5683,45 +5710,26 @@ gfc_trans_class_assign (gfc_code *code)
   gfc_expr *rhs;
 
   gfc_start_block (&block);
-  
-  if (code->op == EXEC_INIT_ASSIGN)
-    {
-      /* Special case for initializing a CLASS variable on allocation.
-	 A MEMCPY is needed to copy the full data of the dynamic type,
-	 which may be different from the declared type.  */
-      gfc_se dst,src;
-      tree memsz;
-      gfc_init_se (&dst, NULL);
-      gfc_init_se (&src, NULL);
-      gfc_add_component_ref (code->expr1, "$data");
-      gfc_conv_expr (&dst, code->expr1);
-      gfc_conv_expr (&src, code->expr2);
-      gfc_add_block_to_block (&block, &src.pre);
-      memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
-      tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
-      gfc_add_expr_to_block (&block, tmp);
-      return gfc_finish_block (&block);
-    }
 
-  if (code->expr2->ts.type != BT_CLASS)
+  if (expr2->ts.type != BT_CLASS)
     {
       /* Insert an additional assignment which sets the '$vptr' field.  */
-      lhs = gfc_copy_expr (code->expr1);
+      lhs = gfc_copy_expr (expr1);
       gfc_add_component_ref (lhs, "$vptr");
-      if (code->expr2->ts.type == BT_DERIVED)
+      if (expr2->ts.type == BT_DERIVED)
 	{
 	  gfc_symbol *vtab;
 	  gfc_symtree *st;
-	  vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived);
+	  vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
 	  gcc_assert (vtab);
-	  gfc_trans_assign_vtab_procs (&block, code->expr2->ts.u.derived, vtab);
+	  gfc_trans_assign_vtab_procs (&block, expr2->ts.u.derived, vtab);
 	  rhs = gfc_get_expr ();
 	  rhs->expr_type = EXPR_VARIABLE;
 	  gfc_find_sym_tree (vtab->name, NULL, 1, &st);
 	  rhs->symtree = st;
 	  rhs->ts = vtab->ts;
 	}
-      else if (code->expr2->expr_type == EXPR_NULL)
+      else if (expr2->expr_type == EXPR_NULL)
 	rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
       else
 	gcc_unreachable ();
@@ -5734,15 +5742,15 @@ gfc_trans_class_assign (gfc_code *code)
     }
 
   /* Do the actual CLASS assignment.  */
-  if (code->expr2->ts.type == BT_CLASS)
-    code->op = EXEC_ASSIGN;
+  if (expr2->ts.type == BT_CLASS)
+    op = EXEC_ASSIGN;
   else
-    gfc_add_component_ref (code->expr1, "$data");
+    gfc_add_component_ref (expr1, "$data");
 
-  if (code->op == EXEC_ASSIGN)
-    tmp = gfc_trans_assign (code);
-  else if (code->op == EXEC_POINTER_ASSIGN)
-    tmp = gfc_trans_pointer_assign (code);
+  if (op == EXEC_ASSIGN)
+    tmp = gfc_trans_assignment (expr1, expr2, false, true);
+  else if (op == EXEC_POINTER_ASSIGN)
+    tmp = gfc_trans_pointer_assignment (expr1, expr2);
   else
     gcc_unreachable();
 
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index c277e8e..a576076 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -5559,4 +5559,42 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
     }
 }
 
+
+tree
+gfc_conv_intrinsic_move_alloc (gfc_code *code)
+{
+  if (code->ext.actual->expr->rank == 0)
+    {
+      /* Scalar arguments: Generate pointer assignments.  */
+      gfc_expr *from, *to;
+      stmtblock_t block;
+      tree tmp;
+
+      from = code->ext.actual->expr;
+      to = code->ext.actual->next->expr;
+
+      gfc_start_block (&block);
+
+      if (to->ts.type == BT_CLASS)
+	tmp = gfc_trans_class_assign (to, from, EXEC_POINTER_ASSIGN);
+      else
+	tmp = gfc_trans_pointer_assignment (to, from);
+      gfc_add_expr_to_block (&block, tmp);
+
+      if (from->ts.type == BT_CLASS)
+	tmp = gfc_trans_class_assign (from, gfc_get_null_expr (NULL),
+				      EXEC_POINTER_ASSIGN);
+      else
+	tmp = gfc_trans_pointer_assignment (from,
+					    gfc_get_null_expr (NULL));
+      gfc_add_expr_to_block (&block, tmp);
+
+      return gfc_finish_block (&block);
+    }
+  else
+    /* Array arguments: Generate library code.  */
+    return gfc_trans_call (code, false, NULL_TREE, NULL_TREE, false);
+}
+
+
 #include "gt-fortran-trans-intrinsic.h"
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index b349545..8b77750 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -32,7 +32,8 @@ tree gfc_trans_code_cond (gfc_code *, tree);
 tree gfc_trans_assign (gfc_code *);
 tree gfc_trans_pointer_assign (gfc_code *);
 tree gfc_trans_init_assign (gfc_code *);
-tree gfc_trans_class_assign (gfc_code *code);
+tree gfc_trans_class_init_assign (gfc_code *);
+tree gfc_trans_class_assign (gfc_expr *, gfc_expr *, gfc_exec_op);
 
 /* trans-stmt.c */
 tree gfc_trans_cycle (gfc_code *);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 4bd4f3b..e266be8 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1093,7 +1093,7 @@ trans_code (gfc_code * code, tree cond)
 
 	case EXEC_ASSIGN:
 	  if (code->expr1->ts.type == BT_CLASS)
-	    res = gfc_trans_class_assign (code);
+	    res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
 	  else
 	    res = gfc_trans_assign (code);
 	  break;
@@ -1104,14 +1104,14 @@ trans_code (gfc_code * code, tree cond)
 
 	case EXEC_POINTER_ASSIGN:
 	  if (code->expr1->ts.type == BT_CLASS)
-	    res = gfc_trans_class_assign (code);
+	    res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
 	  else
 	    res = gfc_trans_pointer_assign (code);
 	  break;
 
 	case EXEC_INIT_ASSIGN:
 	  if (code->expr1->ts.type == BT_CLASS)
-	    res = gfc_trans_class_assign (code);
+	    res = gfc_trans_class_init_assign (code);
 	  else
 	    res = gfc_trans_init_assign (code);
 	  break;
@@ -1157,8 +1157,12 @@ trans_code (gfc_code * code, tree cond)
 	    if (code->resolved_isym
 		&& code->resolved_isym->id == GFC_ISYM_MVBITS)
 	      is_mvbits = true;
-	    res = gfc_trans_call (code, is_mvbits, NULL_TREE,
-				  NULL_TREE, false);
+	    if (code->resolved_isym
+		&& code->resolved_isym->id == GFC_ISYM_MOVE_ALLOC)
+	      res = gfc_conv_intrinsic_move_alloc (code);
+	    else
+	      res = gfc_trans_call (code, is_mvbits, NULL_TREE,
+				    NULL_TREE, false);
 	  }
 	  break;
 
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 99f0dc0..3c80ce7 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -338,6 +338,8 @@ void gfc_conv_intrinsic_function (gfc_se *, gfc_expr *);
 /* Does an intrinsic map directly to an external library call.  */
 int gfc_is_intrinsic_libcall (gfc_expr *);
 
+tree gfc_conv_intrinsic_move_alloc (gfc_code *);
+
 /* Used to call ordinary functions/subroutines
    and procedure pointer components.  */
 int gfc_conv_procedure_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 88092cf..060b879 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2010-07-29  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/45004
+	* gfortran.dg/move_alloc_2.f90: New.
+
 2010-07-29  Xinliang David Li  <davidxl@google.com>
 	PR tree-optimization/45121
 	* c-c++-common/uninit-17.c: Fix expected output.
diff --git a/gcc/testsuite/gfortran.dg/move_alloc_2.f90 b/gcc/testsuite/gfortran.dg/move_alloc_2.f90
new file mode 100644
index 0000000..5dabca8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/move_alloc_2.f90
@@ -0,0 +1,27 @@
+! { dg-do run }
+!
+! PR 45004: [OOP] Segfault with allocatable scalars and move_alloc
+!
+! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
+
+program bug18
+
+  type foo
+    integer :: i
+  end type foo
+
+  type bar
+    class(foo), allocatable :: bf
+  end type bar
+
+  class(foo), allocatable :: afab
+  type(bar) :: bb
+
+  allocate(foo :: afab)
+  afab%i = 8
+  call move_alloc(afab, bb%bf)
+  if (.not. allocated(bb%bf)) call abort()
+  if (allocated(afab)) call abort()
+  if (bb%bf%i/=8) call abort()
+
+end program bug18