2011-12-12 Basile Starynkevitch <basile@starynkevitch.net>

	MELT branch merged with trunk rev 182221 using svnmerge


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@182223 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 136 insertions, 62 deletions

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index b21be45a96d..9e903d81bea 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1093,14 +1093,19 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 {
   gfc_expr *e;
   tree tmp;
+  bool class_target;
 
   gcc_assert (sym->assoc);
   e = sym->assoc->target;
 
+  class_target = (e->expr_type == EXPR_VARIABLE)
+		    && (gfc_is_class_scalar_expr (e)
+			|| gfc_is_class_array_ref (e, NULL));
+
   /* Do a `pointer assignment' with updated descriptor (or assign descriptor
      to array temporary) for arrays with either unknown shape or if associating
      to a variable.  */
-  if (sym->attr.dimension
+  if (sym->attr.dimension && !class_target
       && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
     {
       gfc_se se;
@@ -1140,6 +1145,23 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 			    gfc_finish_block (&se.post));
     }
 
+  /* CLASS arrays just need the descriptor to be directly assigned.  */
+  else if (class_target && sym->attr.dimension)
+    {
+      gfc_se se;
+
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr (&se, e);
+
+      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)));
+      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)));
+
+      gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
+      
+      gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
+			    gfc_finish_block (&se.post));
+    }
+
   /* Do a scalar pointer assignment; this is for scalar variable targets.  */
   else if (gfc_is_associate_pointer (sym))
     {
@@ -4677,6 +4699,7 @@ tree
 gfc_trans_allocate (gfc_code * code)
 {
   gfc_alloc *al;
+  gfc_expr *e;
   gfc_expr *expr;
   gfc_se se;
   tree tmp;
@@ -4748,7 +4771,7 @@ gfc_trans_allocate (gfc_code * code)
       se.descriptor_only = 1;
       gfc_conv_expr (&se, expr);
 
-      if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
+      if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, code->expr3))
 	{
 	  /* A scalar or derived type.  */
 
@@ -4878,6 +4901,16 @@ gfc_trans_allocate (gfc_code * code)
 	      tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
 	      gfc_add_expr_to_block (&se.pre, tmp);
 	    }
+	  else if (al->expr->ts.type == BT_CLASS && code->expr3)
+	    {
+	      /* With class objects, it is best to play safe and null the 
+		 memory because we cannot know if dynamic types have allocatable
+		 components or not.  */
+	      tmp = build_call_expr_loc (input_location,
+					 builtin_decl_explicit (BUILT_IN_MEMSET),
+					 3, se.expr, integer_zero_node,  memsz);
+	      gfc_add_expr_to_block (&se.pre, tmp);
+	    }
 	}
 
       gfc_add_block_to_block (&block, &se.pre);
@@ -4901,6 +4934,60 @@ gfc_trans_allocate (gfc_code * code)
 	  gfc_add_expr_to_block (&block, tmp);
 	}
  
+      /* We need the vptr of CLASS objects to be initialized.  */ 
+      e = gfc_copy_expr (al->expr);
+      if (e->ts.type == BT_CLASS)
+	{
+	  gfc_expr *lhs,*rhs;
+	  gfc_se lse;
+
+	  lhs = gfc_expr_to_initialize (e);
+	  gfc_add_vptr_component (lhs);
+	  rhs = NULL;
+	  if (code->expr3 && code->expr3->ts.type == BT_CLASS)
+	    {
+	      /* Polymorphic SOURCE: VPTR must be determined at run time.  */
+	      rhs = gfc_copy_expr (code->expr3);
+	      gfc_add_vptr_component (rhs);
+	      tmp = gfc_trans_pointer_assignment (lhs, rhs);
+	      gfc_add_expr_to_block (&block, tmp);
+	      gfc_free_expr (rhs);
+	      rhs = gfc_expr_to_initialize (e);
+	    }
+	  else
+	    {
+	      /* VPTR is fixed at compile time.  */
+	      gfc_symbol *vtab;
+	      gfc_typespec *ts;
+	      if (code->expr3)
+		ts = &code->expr3->ts;
+	      else if (e->ts.type == BT_DERIVED)
+		ts = &e->ts;
+	      else if (code->ext.alloc.ts.type == BT_DERIVED)
+		ts = &code->ext.alloc.ts;
+	      else if (e->ts.type == BT_CLASS)
+		ts = &CLASS_DATA (e)->ts;
+	      else
+		ts = &e->ts;
+
+	      if (ts->type == BT_DERIVED)
+		{
+		  vtab = gfc_find_derived_vtab (ts->u.derived);
+		  gcc_assert (vtab);
+		  gfc_init_se (&lse, NULL);
+		  lse.want_pointer = 1;
+		  gfc_conv_expr (&lse, lhs);
+		  tmp = gfc_build_addr_expr (NULL_TREE,
+					     gfc_get_symbol_decl (vtab));
+		  gfc_add_modify (&block, lse.expr,
+			fold_convert (TREE_TYPE (lse.expr), tmp));
+		}
+	    }
+	  gfc_free_expr (lhs);
+	}
+
+      gfc_free_expr (e);
+
       if (code->expr3 && !code->expr3->mold)
 	{
 	  /* Initialization via SOURCE block
@@ -4908,10 +4995,11 @@ gfc_trans_allocate (gfc_code * code)
 	  gfc_expr *rhs = gfc_copy_expr (code->expr3);
 	  if (al->expr->ts.type == BT_CLASS)
 	    {
-	      gfc_se call;
 	      gfc_actual_arglist *actual;
 	      gfc_expr *ppc;
-	      gfc_init_se (&call, NULL);
+	      gfc_code *ppc_code;
+	      gfc_ref *dataref;
+
 	      /* Do a polymorphic deep copy.  */
 	      actual = gfc_get_actual_arglist ();
 	      actual->expr = gfc_copy_expr (rhs);
@@ -4919,20 +5007,58 @@ gfc_trans_allocate (gfc_code * code)
 		gfc_add_data_component (actual->expr);
 	      actual->next = gfc_get_actual_arglist ();
 	      actual->next->expr = gfc_copy_expr (al->expr);
+	      actual->next->expr->ts.type = BT_CLASS;
 	      gfc_add_data_component (actual->next->expr);
+	      dataref = actual->next->expr->ref;
+	      if (dataref->u.c.component->as)
+		{
+		  int dim;
+		  gfc_expr *temp;
+		  gfc_ref *ref = dataref->next;
+		  ref->u.ar.type = AR_SECTION;
+		  /* We have to set up the array reference to give ranges
+		    in all dimensions and ensure that the end and stride
+		    are set so that the copy can be scalarized.  */
+		  dim = 0;
+		  for (; dim < dataref->u.c.component->as->rank; dim++)
+		    {
+		      ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
+		      if (ref->u.ar.end[dim] == NULL)
+			{
+			  ref->u.ar.end[dim] = ref->u.ar.start[dim];
+			  temp = gfc_get_int_expr (gfc_default_integer_kind,
+						   &al->expr->where, 1);
+			  ref->u.ar.start[dim] = temp;
+			}
+		      temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]),
+					   gfc_copy_expr (ref->u.ar.start[dim]));
+		      temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind,
+							&al->expr->where, 1),
+				      temp);
+		    }
+		}
 	      if (rhs->ts.type == BT_CLASS)
 		{
 		  ppc = gfc_copy_expr (rhs);
 		  gfc_add_vptr_component (ppc);
 		}
 	      else
-		ppc = gfc_lval_expr_from_sym (gfc_find_derived_vtab (rhs->ts.u.derived));
+		ppc = gfc_lval_expr_from_sym
+				(gfc_find_derived_vtab (rhs->ts.u.derived));
 	      gfc_add_component_ref (ppc, "_copy");
-	      gfc_conv_procedure_call (&call, ppc->symtree->n.sym, actual,
-					ppc, NULL);
-	      gfc_add_expr_to_block (&call.pre, call.expr);
-	      gfc_add_block_to_block (&call.pre, &call.post);
-	      tmp = gfc_finish_block (&call.pre);
+
+	      ppc_code = gfc_get_code ();
+	      ppc_code->resolved_sym = ppc->symtree->n.sym;
+	      /* Although '_copy' is set to be elemental in class.c, it is
+		 not staying that way.  Find out why, sometime....  */
+	      ppc_code->resolved_sym->attr.elemental = 1;
+	      ppc_code->ext.actual = actual;
+	      ppc_code->expr1 = ppc;
+	      ppc_code->op = EXEC_CALL;
+	      /* Since '_copy' is elemental, the scalarizer will take care
+		 of arrays in gfc_trans_call.  */
+	      tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false);
+	      gfc_free_statements (ppc_code);
 	    }
 	  else if (expr3 != NULL_TREE)
 	    {
@@ -4972,59 +5098,7 @@ gfc_trans_allocate (gfc_code * code)
 	  gfc_free_expr (rhs);
 	}
 
-      /* Allocation of CLASS entities.  */
       gfc_free_expr (expr);
-      expr = al->expr;
-      if (expr->ts.type == BT_CLASS)
-	{
-	  gfc_expr *lhs,*rhs;
-	  gfc_se lse;
-
-	  /* Initialize VPTR for CLASS objects.  */
-	  lhs = gfc_expr_to_initialize (expr);
-	  gfc_add_vptr_component (lhs);
-	  rhs = NULL;
-	  if (code->expr3 && code->expr3->ts.type == BT_CLASS)
-	    {
-	      /* Polymorphic SOURCE: VPTR must be determined at run time.  */
-	      rhs = gfc_copy_expr (code->expr3);
-	      gfc_add_vptr_component (rhs);
-	      tmp = gfc_trans_pointer_assignment (lhs, rhs);
-	      gfc_add_expr_to_block (&block, tmp);
-	      gfc_free_expr (rhs);
-	    }
-	  else
-	    {
-	      /* VPTR is fixed at compile time.  */
-	      gfc_symbol *vtab;
-	      gfc_typespec *ts;
-	      if (code->expr3)
-		ts = &code->expr3->ts;
-	      else if (expr->ts.type == BT_DERIVED)
-		ts = &expr->ts;
-	      else if (code->ext.alloc.ts.type == BT_DERIVED)
-		ts = &code->ext.alloc.ts;
-	      else if (expr->ts.type == BT_CLASS)
-		ts = &CLASS_DATA (expr)->ts;
-	      else
-		ts = &expr->ts;
-
-	      if (ts->type == BT_DERIVED)
-		{
-		  vtab = gfc_find_derived_vtab (ts->u.derived);
-		  gcc_assert (vtab);
-		  gfc_init_se (&lse, NULL);
-		  lse.want_pointer = 1;
-		  gfc_conv_expr (&lse, lhs);
-		  tmp = gfc_build_addr_expr (NULL_TREE,
-					     gfc_get_symbol_decl (vtab));
-		  gfc_add_modify (&block, lse.expr,
-			fold_convert (TREE_TYPE (lse.expr), tmp));
-		}
-	    }
-	  gfc_free_expr (lhs);
-	}
-
     }
 
   /* STAT  (ERRMSG only makes sense with STAT).  */