re PR fortran/41581 ([OOP] Allocation of a CLASS with SOURCE=<class> does not work)

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

	PR fortran/41581
	* decl.c (encapsulate_class_symbol): Add new component '$size'.
	* resolve.c (resolve_allocate_expr): Move CLASS handling to
	gfc_trans_allocate.
	(resolve_class_assign): Replaced by gfc_trans_class_assign.
	(resolve_code): Remove calls to resolve_class_assign.
	* trans.c (gfc_trans_code): Use new function gfc_trans_class_assign.
	* trans-expr.c (get_proc_ptr_comp): Fix a memory leak.
	(gfc_conv_procedure_call): For CLASS dummies, set the
	$size component.
	(gfc_trans_class_assign): New function, replacing resolve_class_assign.
	* trans-stmt.h (gfc_trans_class_assign): New prototype.
	* trans-stmt.c (gfc_trans_allocate): Use correct size when allocating
	CLASS variables. Do proper initialization. Move some code here from
	resolve_allocate_expr.


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

	PR fortran/41581
	* gfortran.dg/class_allocate_2.f03: Modified.
	* gfortran.dg/class_allocate_3.f03: New test case.

From-SVN: r152715

gcc/fortran/ChangeLog

+2009-10-13  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41581
+	* decl.c (encapsulate_class_symbol): Add new component '$size'.
+	* resolve.c (resolve_allocate_expr): Move CLASS handling to
+	gfc_trans_allocate.
+	(resolve_class_assign): Replaced by gfc_trans_class_assign.
+	(resolve_code): Remove calls to resolve_class_assign.
+	* trans.c (gfc_trans_code): Use new function gfc_trans_class_assign.
+	* trans-expr.c (get_proc_ptr_comp): Fix a memory leak.
+	(gfc_conv_procedure_call): For CLASS dummies, set the
+	$size component.
+	(gfc_trans_class_assign): New function, replacing resolve_class_assign.
+	* trans-stmt.h (gfc_trans_class_assign): New prototype.
+	* trans-stmt.c (gfc_trans_allocate): Use correct size when allocating
+	CLASS variables. Do proper initialization. Move some code here from
+	resolve_allocate_expr.
+
 2009-10-11 Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/38439

gcc/fortran/decl.c

@@ -1028,7 +1028,8 @@ verify_c_interop_param (gfc_symbol *sym)
 /* Build a polymorphic CLASS entity, using the symbol that comes from build_sym.
    A CLASS entity is represented by an encapsulating type, which contains the
    declared type as '$data' component, plus an integer component '$vindex'
-   which determines the dynamic type.  */
+   which determines the dynamic type, and another integer '$size', which
+   contains the size of the dynamic type structure.  */
 
 static gfc_try
 encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
@@ -1089,6 +1090,14 @@ encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       c->ts.kind = 4;
       c->attr.access = ACCESS_PRIVATE;
       c->initializer = gfc_int_expr (0);
+
+      /* Add component '$size'.  */
+      if (gfc_add_component (fclass, "$size", &c) == FAILURE)
+   	return FAILURE;
+      c->ts.type = BT_INTEGER;
+      c->ts.kind = 4;
+      c->attr.access = ACCESS_PRIVATE;
+      c->initializer = gfc_int_expr (0);
     }
 
   fclass->attr.extension = 1;

gcc/fortran/resolve.c

@@ -5844,7 +5844,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
   symbol_attribute attr;
   gfc_ref *ref, *ref2;
   gfc_array_ref *ar;
-  gfc_code *init_st;
   gfc_symbol *sym;
   gfc_alloc *a;
   gfc_component *c;
@@ -5948,41 +5947,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
       return FAILURE;
     }
 
-  if (e->ts.type == BT_CLASS)
-    {
-      /* Initialize VINDEX for CLASS objects.  */
-      init_st = gfc_get_code ();
-      init_st->loc = code->loc;
-      init_st->expr1 = gfc_expr_to_initialize (e);
-      init_st->op = EXEC_ASSIGN;
-      gfc_add_component_ref (init_st->expr1, "$vindex");
-      if (code->expr3 && code->expr3->ts.type == BT_CLASS)
-	{
-	  /* vindex must be determined at run time.  */
-	  init_st->expr2 = gfc_copy_expr (code->expr3);
-	  gfc_add_component_ref (init_st->expr2, "$vindex");
-	}
-      else
-	{
-	  /* vindex is fixed at compile time.  */
-	  int vindex;
-	  if (code->expr3)
-	    vindex = code->expr3->ts.u.derived->vindex;
-	  else if (code->ext.alloc.ts.type == BT_DERIVED)
-	    vindex = code->ext.alloc.ts.u.derived->vindex;
-	  else if (e->ts.type == BT_CLASS)
-	    vindex = e->ts.u.derived->components->ts.u.derived->vindex;
-	  else
-	    vindex = e->ts.u.derived->vindex;
-	  init_st->expr2 = gfc_int_expr (vindex);
-	}
-      init_st->expr2->where = init_st->expr1->where = init_st->loc;
-      init_st->next = code->next;
-      code->next = init_st;
-      /* Only allocate the DATA component.  */
-      gfc_add_component_ref (e, "$data");
-    }
-
   if (pointer || dimension == 0)
     return SUCCESS;
 
@@ -7567,44 +7531,6 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
 }
 
 
-/* Check an assignment to a CLASS object (pointer or ordinary assignment).  */
-
-static void
-resolve_class_assign (gfc_code *code)
-{
-  gfc_code *assign_code = gfc_get_code ();
-
-  if (code->expr2->ts.type != BT_CLASS)
-    {
-      /* Insert an additional assignment which sets the vindex.  */
-      assign_code->next = code->next;
-      code->next = assign_code;
-      assign_code->op = EXEC_ASSIGN;
-      assign_code->expr1 = gfc_copy_expr (code->expr1);
-      gfc_add_component_ref (assign_code->expr1, "$vindex");
-      if (code->expr2->ts.type == BT_DERIVED)
-	/* vindex is constant, determined at compile time.  */
-	assign_code->expr2 = gfc_int_expr (code->expr2->ts.u.derived->vindex);
-      else if (code->expr2->ts.type == BT_CLASS)
-	{
-	  /* vindex must be determined at run time.  */
-	  assign_code->expr2 = gfc_copy_expr (code->expr2);
-	  gfc_add_component_ref (assign_code->expr2, "$vindex");
-	}
-      else if (code->expr2->expr_type == EXPR_NULL)
-	assign_code->expr2 = gfc_int_expr (0);
-      else
-	gcc_unreachable ();
-    }
-
-  /* Modify the actual pointer assignment.  */
-  if (code->expr2->ts.type == BT_CLASS)
-    code->op = EXEC_ASSIGN;
-  else
-    gfc_add_component_ref (code->expr1, "$data");
-}
-
-
 /* Given a block of code, recursively resolve everything pointed to by this
    code block.  */
 
@@ -7734,10 +7660,6 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	      else
 		goto call;
 	    }
-
-	  if (code->expr1->ts.type == BT_CLASS)
-	    resolve_class_assign (code);
-
 	  break;
 
 	case EXEC_LABEL_ASSIGN:
@@ -7759,10 +7681,6 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	    break;
 
 	  gfc_check_pointer_assign (code->expr1, code->expr2);
-
-	  if (code->expr1->ts.type == BT_CLASS)
-	    resolve_class_assign (code);
-
 	  break;
 
 	case EXEC_ARITHMETIC_IF:

gcc/fortran/trans-expr.c

@@ -1519,6 +1519,7 @@ get_proc_ptr_comp (gfc_expr *e)
   e2 = gfc_copy_expr (e);
   e2->expr_type = EXPR_VARIABLE;
   gfc_conv_expr (&comp_se, e2);
+  gfc_free_expr (e2);
   return build_fold_addr_expr_loc (input_location, comp_se.expr);
 }
 
@@ -2775,6 +2776,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	{
 	  tree data;
 	  tree vindex;
+	  tree size;
 
 	  /* The derived type needs to be converted to a temporary
 	     CLASS object.  */
@@ -2789,12 +2791,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  tmp = fsym->ts.u.derived->components->next->backend_decl;
 	  vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
 				var, tmp, NULL_TREE);
+	  tmp = fsym->ts.u.derived->components->next->next->backend_decl;
+	  size = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
+			      var, tmp, NULL_TREE);
 
 	  /* Set the vindex.  */
-	  tmp = build_int_cst (TREE_TYPE (vindex),
-			       e->ts.u.derived->vindex);
+	  tmp = build_int_cst (TREE_TYPE (vindex), e->ts.u.derived->vindex);
 	  gfc_add_modify (&parmse.pre, vindex, tmp);
 
+	  /* Set the size.  */
+	  tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&e->ts));
+	  gfc_add_modify (&parmse.pre, size,
+			  fold_convert (TREE_TYPE (size), tmp));
+
 	  /* Now set the data field.  */
 	  argss = gfc_walk_expr (e);
 	  if (argss == gfc_ss_terminator)
@@ -5261,3 +5270,75 @@ gfc_trans_assign (gfc_code * code)
 {
   return gfc_trans_assignment (code->expr1, code->expr2, false);
 }
+
+
+/* Translate an assignment to a CLASS object
+   (pointer or ordinary assignment).  */
+
+tree
+gfc_trans_class_assign (gfc_code *code)
+{
+  stmtblock_t block;
+  tree tmp;
+
+  gfc_start_block (&block);
+
+  if (code->expr2->ts.type != BT_CLASS)
+    {
+      /* Insert an additional assignment which sets the '$vindex' field.  */
+      gfc_expr *lhs,*rhs;
+      lhs = gfc_copy_expr (code->expr1);
+      gfc_add_component_ref (lhs, "$vindex");
+      if (code->expr2->ts.type == BT_DERIVED)
+	/* vindex is constant, determined at compile time.  */
+	rhs = gfc_int_expr (code->expr2->ts.u.derived->vindex);
+      else if (code->expr2->expr_type == EXPR_NULL)
+	rhs = gfc_int_expr (0);
+      else
+	gcc_unreachable ();
+      tmp = gfc_trans_assignment (lhs, rhs, false);
+      gfc_add_expr_to_block (&block, tmp);
+
+      /* Insert another assignment which sets the '$size' field.  */
+      lhs = gfc_copy_expr (code->expr1);
+      gfc_add_component_ref (lhs, "$size");
+      if (code->expr2->ts.type == BT_DERIVED)
+	{
+	  /* Size is fixed at compile time.  */
+	  gfc_se lse;
+	  gfc_init_se (&lse, NULL);
+	  gfc_conv_expr (&lse, lhs);
+	  tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
+	  gfc_add_modify (&block, lse.expr,
+			  fold_convert (TREE_TYPE (lse.expr), tmp));
+	}
+      else if (code->expr2->expr_type == EXPR_NULL)
+	{
+	  rhs = gfc_int_expr (0);
+	  tmp = gfc_trans_assignment (lhs, rhs, false);
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+      else
+	gcc_unreachable ();
+
+      gfc_free_expr (lhs);
+      gfc_free_expr (rhs);
+    }
+
+  /* Do the actual CLASS assignment.  */
+  if (code->expr2->ts.type == BT_CLASS)
+    code->op = EXEC_ASSIGN;
+  else
+    gfc_add_component_ref (code->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);
+  else
+    gcc_unreachable();
+
+  gfc_add_expr_to_block (&block, tmp);
+
+  return gfc_finish_block (&block);
+}

gcc/fortran/trans-stmt.c

@@ -3976,7 +3976,7 @@ tree
 gfc_trans_allocate (gfc_code * code)
 {
   gfc_alloc *al;
-  gfc_expr *expr, *init_e, *rhs;
+  gfc_expr *expr, *init_e;
   gfc_se se;
   tree tmp;
   tree parm;
@@ -4006,7 +4006,10 @@ gfc_trans_allocate (gfc_code * code)
 
   for (al = code->ext.alloc.list; al != NULL; al = al->next)
     {
-      expr = al->expr;
+      expr = gfc_copy_expr (al->expr);
+
+      if (expr->ts.type == BT_CLASS)
+	gfc_add_component_ref (expr, "$data");
 
       gfc_init_se (&se, NULL);
       gfc_start_block (&se.pre);
@@ -4022,13 +4025,14 @@ gfc_trans_allocate (gfc_code * code)
 	  /* Determine allocate size.  */
 	  if (code->expr3 && code->expr3->ts.type == BT_CLASS)
 	    {
-	      gfc_typespec *ts;
-	      /* TODO: Size must be determined at run time, since it must equal
-		 the size of the dynamic type of SOURCE, not the declared type.  */
-	      gfc_error ("Using SOURCE= with a class variable at %L not "
-			 "supported yet", &code->loc);
-	      ts = &code->expr3->ts.u.derived->components->ts;
-	      tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts));
+	      gfc_expr *sz;
+	      gfc_se se_sz;
+	      sz = gfc_copy_expr (code->expr3);
+	      gfc_add_component_ref (sz, "$size");
+	      gfc_init_se (&se_sz, NULL);
+	      gfc_conv_expr (&se_sz, sz);
+	      gfc_free_expr (sz);
+	      tmp = se_sz.expr;
 	    }
 	  else if (code->expr3 && code->expr3->ts.type != BT_CLASS)
 	    tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
@@ -4070,18 +4074,121 @@ gfc_trans_allocate (gfc_code * code)
       /* Initialization via SOURCE block.  */
       if (code->expr3)
 	{
-	  rhs = gfc_copy_expr (code->expr3);
+	  gfc_expr *rhs = gfc_copy_expr (code->expr3);
 	  if (rhs->ts.type == BT_CLASS)
+	    {
+	      gfc_se dst,src,len;
+	      gfc_expr *sz;
 	      gfc_add_component_ref (rhs, "$data");
-	  tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), rhs, false);
+	      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);
+	    }
+	  else
+	    tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
+					rhs, false);
+	  gfc_free_expr (rhs);
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+      /* Default initializer for CLASS variables.  */
+      else if (al->expr->ts.type == BT_CLASS
+	       && code->ext.alloc.ts.type == BT_DERIVED
+	       && (init_e = gfc_default_initializer (&code->ext.alloc.ts)))
+	{
+	  gfc_se dst,src;
+	  gfc_init_se (&dst, NULL);
+	  gfc_init_se (&src, NULL);
+	  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);
 	  gfc_add_expr_to_block (&block, tmp);
 	}
       /* Add default initializer for those derived types that need them.  */
-      else if (expr->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&expr->ts)))
+      else if (expr->ts.type == BT_DERIVED
+	       && (init_e = gfc_default_initializer (&expr->ts)))
+	{
+	  tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
+				      init_e, true);
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+
+      /* Allocation of CLASS entities.  */
+      gfc_free_expr (expr);
+      expr = al->expr;
+      if (expr->ts.type == BT_CLASS)
+	{
+	  gfc_expr *lhs,*rhs;
+	  /* Initialize VINDEX for CLASS objects.  */
+	  lhs = gfc_expr_to_initialize (expr);
+	  gfc_add_component_ref (lhs, "$vindex");
+	  if (code->expr3 && code->expr3->ts.type == BT_CLASS)
+	    {
+	      /* vindex must be determined at run time.  */
+	      rhs = gfc_copy_expr (code->expr3);
+	      gfc_add_component_ref (rhs, "$vindex");
+	    }
+	  else
+	    {
+	      /* vindex is fixed at compile time.  */
+	      int vindex;
+	      if (code->expr3)
+		vindex = code->expr3->ts.u.derived->vindex;
+	      else if (code->ext.alloc.ts.type == BT_DERIVED)
+		vindex = code->ext.alloc.ts.u.derived->vindex;
+	      else if (expr->ts.type == BT_CLASS)
+		vindex = expr->ts.u.derived->components->ts.u.derived->vindex;
+	      else
+		vindex = expr->ts.u.derived->vindex;
+	      rhs = gfc_int_expr (vindex);
+	    }
+	  tmp = gfc_trans_assignment (lhs, rhs, false);
+	  gfc_free_expr (lhs);
+	  gfc_free_expr (rhs);
+	  gfc_add_expr_to_block (&block, tmp);
+
+	  /* 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)
 	    {
-	  tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), init_e, true);
+	      /* 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));
+	    }
+	  gfc_free_expr (lhs);
+	  gfc_free_expr (rhs);
+	}
 
     }
 

gcc/fortran/trans-stmt.h

@@ -29,6 +29,7 @@ tree gfc_trans_code (gfc_code *);
 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);
 
 /* trans-stmt.c */
 tree gfc_trans_cycle (gfc_code *);

gcc/fortran/trans.c

@@ -1079,6 +1079,9 @@ gfc_trans_code (gfc_code * code)
 	  break;
 
 	case EXEC_ASSIGN:
+	  if (code->expr1->ts.type == BT_CLASS)
+	    res = gfc_trans_class_assign (code);
+	  else
 	    res = gfc_trans_assign (code);
 	  break;
 
@@ -1087,6 +1090,9 @@ gfc_trans_code (gfc_code * code)
           break;
 
 	case EXEC_POINTER_ASSIGN:
+	  if (code->expr1->ts.type == BT_CLASS)
+	    res = gfc_trans_class_assign (code);
+	  else
 	    res = gfc_trans_pointer_assign (code);
 	  break;
 

gcc/testsuite/ChangeLog

+2009-10-13  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41581
+	* gfortran.dg/class_allocate_2.f03: Modified.
+	* gfortran.dg/class_allocate_3.f03: New test case.
+
 2009-10-13  Richard Guenther  <rguenther@suse.de>
 
 	PR lto/41668

gcc/testsuite/gfortran.dg/class_allocate_2.f03

@@ -7,7 +7,7 @@ type :: t
 end type t
 class(t), allocatable :: c,d
 allocate(t :: d)
-allocate(c,source=d) ! { dg-error "not supported yet" }
+allocate(c,source=d)
 end
 
 type, abstract :: t

gcc/testsuite/gfortran.dg/class_allocate_3.f03

+! { dg-do run }
+!
+! PR 41581: [OOP] Allocation of a CLASS with SOURCE=<class> does not work
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+ type t
+ end type t
+
+ type,extends(t) :: t2
+   integer :: i = 54
+   real :: r = 384.02
+ end type t2
+
+ class(t), allocatable :: m1, m2
+
+ allocate(t2 :: m2)
+ select type(m2)
+ type is (t2)
+   print *, m2%i, m2%r
+   if (m2%i/=54) call abort()
+   if (abs(m2%r-384.02)>1E-3) call abort()
+   m2%i = 42
+   m2%r = -4.0
+ class default
+   call abort()
+ end select
+
+ allocate(m1, source=m2)
+ select type(m1)
+ type is (t2)
+   print *, m1%i, m1%r
+   if (m1%i/=42) call abort()
+   if (abs(m1%r+4.0)>1E-3) call abort()
+ class default
+   call abort()
+ end select
+
+end