re PR fortran/41714 ([OOP] ALLOCATE SOURCE= does not properly copy the value from SOURCE)

2009-10-26  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41714
	* gimple.h (tree_annotate_all_with_location): Remove prototype.
	* gimplify.c (tree_should_carry_location_p,
	tree_annotate_one_with_location,tree_annotate_all_with_location):
	Remove obsolete functions.


2009-10-26  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41714
	* trans.c (gfc_trans_code): Remove call to
	'tree_annotate_all_with_location'. Location should already be set.
	* trans-openmp.c (gfc_trans_omp_workshare): Ditto.
	* trans-stmt.c (gfc_trans_allocate): Do correct data initialization for
	CLASS variables with SOURCE tag, plus some cleanup.


2009-10-26  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41714
	* gfortran.dg/class_allocate_4.f03: New test.

From-SVN: r153547

gcc/ChangeLog

+2009-10-26  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41714
+	* gimple.h (tree_annotate_all_with_location): Remove prototype.
+	* gimplify.c (tree_should_carry_location_p,
+	tree_annotate_one_with_location,tree_annotate_all_with_location):
+	Remove obsolete functions.
+
 2009-10-25  Kaz Kojima  <kkojima@gcc.gnu.org>
 
 	PR target/41813

gcc/fortran/ChangeLog

+2009-10-26  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41714
+	* trans.c (gfc_trans_code): Remove call to
+	'tree_annotate_all_with_location'. Location should already be set.
+	* trans-openmp.c (gfc_trans_omp_workshare): Ditto.
+	* trans-stmt.c (gfc_trans_allocate): Do correct data initialization for
+	CLASS variables with SOURCE tag, plus some cleanup.
+
 2009-10-24  Janus Weil  <janus@gcc.gnu.org>
 	    Paul Thomas  <pault@gcc.gnu.org>
 

gcc/fortran/trans-openmp.c

@@ -1641,11 +1641,6 @@ gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses)
 
       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
 	{
-	  if (TREE_CODE (res) == STATEMENT_LIST)
-	    tree_annotate_all_with_location (&res, input_location);
-	  else
-	    SET_EXPR_LOCATION (res, input_location);
-
 	  if (prev_singleunit)
 	    {
 	      if (ompws_flags & OMPWS_CURR_SINGLEUNIT)

gcc/fortran/trans-stmt.c

@@ -3983,12 +3983,13 @@ gfc_trans_allocate (gfc_code * code)
   tree stat;
   tree pstat;
   tree error_label;
+  tree memsz;
   stmtblock_t block;
 
   if (!code->ext.alloc.list)
     return NULL_TREE;
 
-  pstat = stat = error_label = tmp = NULL_TREE;
+  pstat = stat = error_label = tmp = memsz = NULL_TREE;
 
   gfc_start_block (&block);
 
@@ -4032,19 +4033,19 @@ gfc_trans_allocate (gfc_code * code)
 	      gfc_init_se (&se_sz, NULL);
 	      gfc_conv_expr (&se_sz, sz);
 	      gfc_free_expr (sz);
-	      tmp = se_sz.expr;
+	      memsz = se_sz.expr;
 	    }
 	  else if (code->expr3 && code->expr3->ts.type != BT_CLASS)
-	    tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
+	    memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
 	  else if (code->ext.alloc.ts.type != BT_UNKNOWN)
-	    tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
+	    memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
 	  else
-	    tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
+	    memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
 
-	  if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE)
-	    tmp = se.string_length;
+	  if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE)
+	    memsz = se.string_length;
 
-	  tmp = gfc_allocate_with_status (&se.pre, tmp, pstat);
+	  tmp = gfc_allocate_with_status (&se.pre, memsz, pstat);
 	  tmp = fold_build2 (MODIFY_EXPR, void_type_node, se.expr,
 			     fold_convert (TREE_TYPE (se.expr), tmp));
 	  gfc_add_expr_to_block (&se.pre, tmp);
@@ -4075,21 +4076,17 @@ gfc_trans_allocate (gfc_code * code)
       if (code->expr3)
 	{
 	  gfc_expr *rhs = gfc_copy_expr (code->expr3);
-	  if (rhs->ts.type == BT_CLASS)
+	  if (al->expr->ts.type == BT_CLASS)
 	    {
-	      gfc_se dst,src,len;
-	      gfc_expr *sz;
+	      gfc_se dst,src;
+	      if (rhs->ts.type == BT_CLASS)
 		gfc_add_component_ref (rhs, "$data");
-	      sz = gfc_copy_expr (code->expr3);
-	      gfc_add_component_ref (sz, "$size");
 	      gfc_init_se (&dst, NULL);
 	      gfc_init_se (&src, NULL);
-	      gfc_init_se (&len, NULL);
 	      gfc_conv_expr (&dst, expr);
 	      gfc_conv_expr (&src, rhs);
-	      gfc_conv_expr (&len, sz);
-	      gfc_free_expr (sz);
-	      tmp = gfc_build_memcpy_call (dst.expr, src.expr, len.expr);
+	      gfc_add_block_to_block (&block, &src.pre);
+	      tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
 	    }
 	  else
 	    tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
@@ -4108,8 +4105,7 @@ gfc_trans_allocate (gfc_code * code)
 	  gfc_conv_expr (&dst, expr);
 	  gfc_conv_expr (&src, init_e);
 	  gfc_add_block_to_block (&block, &src.pre);
-	  tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
-	  tmp = gfc_build_memcpy_call (dst.expr, src.expr, tmp);
+	  tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
 	  gfc_add_expr_to_block (&block, tmp);
 	}
       /* Add default initializer for those derived types that need them.  */
@@ -4127,6 +4123,7 @@ gfc_trans_allocate (gfc_code * code)
       if (expr->ts.type == BT_CLASS)
 	{
 	  gfc_expr *lhs,*rhs;
+	  gfc_se lse;
 	  /* Initialize VINDEX for CLASS objects.  */
 	  lhs = gfc_expr_to_initialize (expr);
 	  gfc_add_component_ref (lhs, "$vindex");
@@ -4158,36 +4155,11 @@ gfc_trans_allocate (gfc_code * code)
 	  /* Initialize SIZE for CLASS objects.  */
 	  lhs = gfc_expr_to_initialize (expr);
 	  gfc_add_component_ref (lhs, "$size");
-	  rhs = NULL;
-	  if (code->expr3 && code->expr3->ts.type == BT_CLASS)
-	    {
-	      /* Size must be determined at run time.  */
-	      rhs = gfc_copy_expr (code->expr3);
-	      gfc_add_component_ref (rhs, "$size");
-	      tmp = gfc_trans_assignment (lhs, rhs, false);
-	      gfc_add_expr_to_block (&block, tmp);
-	    }
-	  else
-	    {
-	      /* Size is fixed at compile time.  */
-	      gfc_typespec *ts;
-	      gfc_se lse;
 	  gfc_init_se (&lse, NULL);
 	  gfc_conv_expr (&lse, lhs);
-	      if (code->expr3)
-		ts = &code->expr3->ts;
-	      else if (code->ext.alloc.ts.type == BT_DERIVED)
-		ts = &code->ext.alloc.ts;
-	      else if (expr->ts.type == BT_CLASS)
-		ts = &expr->ts.u.derived->components->ts;
-	      else
-		ts = &expr->ts;
-	      tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts));
 	  gfc_add_modify (&block, lse.expr,
-			      fold_convert (TREE_TYPE (lse.expr), tmp));
-	    }
+			  fold_convert (TREE_TYPE (lse.expr), memsz));
 	  gfc_free_expr (lhs);
-	  gfc_free_expr (rhs);
 	}
 
     }

gcc/fortran/trans.c

@@ -1281,9 +1281,7 @@ gfc_trans_code (gfc_code * code)
 
       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
 	{
-	  if (TREE_CODE (res) == STATEMENT_LIST)
-	    tree_annotate_all_with_location (&res, input_location);
-	  else
+	  if (TREE_CODE (res) != STATEMENT_LIST)
 	    SET_EXPR_LOCATION (res, input_location);
 	    
 	  /* Add the new statement to the block.  */

gcc/gimple.h

@@ -939,7 +939,6 @@ extern tree create_tmp_var (tree, const char *);
 extern tree get_initialized_tmp_var (tree, gimple_seq *, gimple_seq *);
 extern tree get_formal_tmp_var (tree, gimple_seq *);
 extern void declare_vars (tree, gimple, bool);
-extern void tree_annotate_all_with_location (tree *, location_t);
 extern void annotate_all_with_location (gimple_seq, location_t);
 
 /* Validation of GIMPLE expressions.  Note that these predicates only check

gcc/gimplify.c

@@ -777,23 +777,6 @@ should_carry_location_p (gimple gs)
   return true;
 }
 
-/* Same, but for a tree.  */
-
-static bool
-tree_should_carry_location_p (const_tree stmt)
-{
-  /* Don't emit a line note for a label.  We particularly don't want to
-     emit one for the break label, since it doesn't actually correspond
-     to the beginning of the loop/switch.  */
-  if (TREE_CODE (stmt) == LABEL_EXPR)
-    return false;
-
-  /* Do not annotate empty statements, since it confuses gcov.  */
-  if (!TREE_SIDE_EFFECTS (stmt))
-    return false;
-
-  return true;
-}
 
 /* Return true if a location should not be emitted for this statement
    by annotate_one_with_location.  */
@@ -826,16 +809,6 @@ annotate_one_with_location (gimple gs, location_t location)
     gimple_set_location (gs, location);
 }
 
-/* Same, but for tree T.  */
-
-static void
-tree_annotate_one_with_location (tree t, location_t location)
-{
-  if (CAN_HAVE_LOCATION_P (t)
-      && ! EXPR_HAS_LOCATION (t) && tree_should_carry_location_p (t))
-    SET_EXPR_LOCATION (t, location);
-}
-
 
 /* Set LOCATION for all the statements after iterator GSI in sequence
    SEQ.  If GSI is pointing to the end of the sequence, start with the
@@ -872,29 +845,6 @@ annotate_all_with_location (gimple_seq stmt_p, location_t location)
     }
 }
 
-/* Same, but for statement or statement list in *STMT_P.  */
-
-void
-tree_annotate_all_with_location (tree *stmt_p, location_t location)
-{
-  tree_stmt_iterator i;
-
-  if (!*stmt_p)
-    return;
-
-  for (i = tsi_start (*stmt_p); !tsi_end_p (i); tsi_next (&i))
-    {
-      tree t = tsi_stmt (i);
-
-      /* Assuming we've already been gimplified, we shouldn't
-	  see nested chaining constructs anymore.  */
-      gcc_assert (TREE_CODE (t) != STATEMENT_LIST
-		  && TREE_CODE (t) != COMPOUND_EXPR);
-
-      tree_annotate_one_with_location (t, location);
-    }
-}
-
 
 /* Similar to copy_tree_r() but do not copy SAVE_EXPR or TARGET_EXPR nodes.
    These nodes model computations that should only be done once.  If we

gcc/testsuite/ChangeLog

+2009-10-26  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41714
+	* gfortran.dg/class_allocate_4.f03: New test.
+
 2009-10-24  Adam Nemet  <anemet@caviumnetworks.com>
 
 	* gcc.target/mips/mult-1.c: New test.

gcc/testsuite/gfortran.dg/class_allocate_4.f03

+! { dg-do run }
+!
+! PR 41714: [OOP] ALLOCATE SOURCE= does not properly copy the value from SOURCE
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+type t
+  integer :: i
+end type t
+type, extends(t) :: t2
+  integer :: j
+end type t2
+
+class(t), allocatable :: a
+allocate(a, source=t2(1,2))
+print *,a%i
+if(a%i /= 1) call abort()
+select type (a)
+  type is (t2)
+     print *,a%j
+     if(a%j /= 2) call abort()
+end select
+end