re PR fortran/65548 (gfc_conv_procedure_call)

gcc/fortran/ChangeLog:

2015-05-19  Andre Vehreschild  <vehre@gmx.de>

	PR fortran/65548
	* trans-stmt.c (gfc_trans_allocate): Always retrieve the
	descriptor or a reference to a source= expression for
	arrays and non-arrays, respectively.  Use a temporary
	symbol and gfc_trans_assignment for all source=
	assignments to allocated objects besides for class and
	derived types.

gcc/testsuite/ChangeLog:

2015-05-19  Andre Vehreschild  <vehre@gmx.de>

	PR fortran/65548
	* gfortran.dg/allocate_with_source_5.f90: Extend test.

From-SVN: r223445

gcc/fortran/ChangeLog

+2015-05-20  Andre Vehreschild  <vehre@gmx.de>
+
+	PR fortran/65548
+	* trans-stmt.c (gfc_trans_allocate): Always retrieve the
+	descriptor or a reference to a source= expression for
+	arrays and non-arrays, respectively.  Use a temporary
+	symbol and gfc_trans_assignment for all source=
+	assignments to allocated objects besides for class and
+	derived types.
+
 2015-05-19  Jakub Jelinek  <jakub@redhat.com>
 
 	PR middle-end/66199

gcc/fortran/trans-stmt.c

@@ -5088,7 +5088,7 @@ tree
 gfc_trans_allocate (gfc_code * code)
 {
   gfc_alloc *al;
-  gfc_expr *expr;
+  gfc_expr *expr, *e3rhs = NULL;
   gfc_se se, se_sz;
   tree tmp;
   tree parm;
@@ -5109,6 +5109,7 @@ gfc_trans_allocate (gfc_code * code)
   stmtblock_t post;
   tree nelems;
   bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set;
+  gfc_symtree *newsym = NULL;
 
   if (!code->ext.alloc.list)
     return NULL_TREE;
@@ -5148,14 +5149,11 @@ gfc_trans_allocate (gfc_code * code)
       TREE_USED (label_finish) = 0;
     }
 
-  /* When an expr3 is present, try to evaluate it only once.  In most
-     cases expr3 is invariant for all elements of the allocation list.
-     Only exceptions are arrays.  Furthermore the standards prevent a
-     dependency of expr3 on the objects in the allocate list.  Therefore
-     it is safe to pre-evaluate expr3 for complicated expressions, i.e.
-     everything not a variable or constant.  When an array allocation
-     is wanted, then the following block nevertheless evaluates the
-     _vptr, _len and element_size for expr3.  */
+  /* When an expr3 is present evaluate it only once.  The standards prevent a
+     dependency of expr3 on the objects in the allocate list.  An expr3 can
+     be pre-evaluated in all cases.  One just has to make sure, to use the
+     correct way, i.e., to get the descriptor or to get a reference
+     expression.  */
   if (code->expr3)
     {
       bool vtab_needed = false;
@@ -5168,75 +5166,77 @@ gfc_trans_allocate (gfc_code * code)
 	   al = al->next)
 	vtab_needed = (al->expr->ts.type == BT_CLASS);
 
-      /* A array expr3 needs the scalarizer, therefore do not process it
-	 here.  */
-      if (code->expr3->expr_type != EXPR_ARRAY
-	  && (code->expr3->rank == 0
-	      || code->expr3->expr_type == EXPR_FUNCTION)
-	  && (!code->expr3->symtree
-	      || !code->expr3->symtree->n.sym->as)
-	  && !gfc_is_class_array_ref (code->expr3, NULL))
-	{
-	  /* When expr3 is a variable, i.e., a very simple expression,
+      /* When expr3 is a variable, i.e., a very simple expression,
 	     then convert it once here.  */
-	  if ((code->expr3->expr_type == EXPR_VARIABLE)
-	      || code->expr3->expr_type == EXPR_CONSTANT)
-	    {
-	      if (!code->expr3->mold
-		  || code->expr3->ts.type == BT_CHARACTER
-		  || vtab_needed)
-		{
-		  /* Convert expr3 to a tree.  */
-		  gfc_init_se (&se, NULL);
-		  se.want_pointer = 1;
-		  gfc_conv_expr (&se, code->expr3);
-		  if (!code->expr3->mold)
-		    expr3 = se.expr;
-		  else
-		    expr3_tmp = se.expr;
-		  expr3_len = se.string_length;
-		  gfc_add_block_to_block (&block, &se.pre);
-		  gfc_add_block_to_block (&post, &se.post);
-		}
-	      /* else expr3 = NULL_TREE set above.  */
-	    }
-	  else
+      if (code->expr3->expr_type == EXPR_VARIABLE
+	  || code->expr3->expr_type == EXPR_ARRAY
+	  || code->expr3->expr_type == EXPR_CONSTANT)
+	{
+	  if (!code->expr3->mold
+	      || code->expr3->ts.type == BT_CHARACTER
+	      || vtab_needed)
 	    {
-	      /* In all other cases evaluate the expr3 and create a
-		 temporary.  */
+	      /* Convert expr3 to a tree.  */
 	      gfc_init_se (&se, NULL);
-	      if (code->expr3->rank != 0
-		  && code->expr3->expr_type == EXPR_FUNCTION
-		  && code->expr3->value.function.isym)
+	      /* For all "simple" expression just get the descriptor or the
+		 reference, respectively, depending on the rank of the expr.  */
+	      if (code->expr3->rank != 0)
 		gfc_conv_expr_descriptor (&se, code->expr3);
 	      else
 		gfc_conv_expr_reference (&se, code->expr3);
-	      if (code->expr3->ts.type == BT_CLASS)
-		gfc_conv_class_to_class (&se, code->expr3,
-					 code->expr3->ts,
-					 false, true,
-					 false, false);
+	      if (!code->expr3->mold)
+		expr3 = se.expr;
+	      else
+		expr3_tmp = se.expr;
+	      expr3_len = se.string_length;
 	      gfc_add_block_to_block (&block, &se.pre);
 	      gfc_add_block_to_block (&post, &se.post);
-	      /* Prevent aliasing, i.e., se.expr may be already a
+	    }
+	  /* else expr3 = NULL_TREE set above.  */
+	}
+      else
+	{
+	  /* In all other cases evaluate the expr3 and create a
+		 temporary.  */
+	  gfc_init_se (&se, NULL);
+	  symbol_attribute attr;
+	  /* Get the descriptor for all arrays, that are not allocatable or
+	     pointer, because the latter are descriptors already.  */
+	  attr = gfc_expr_attr (code->expr3);
+	  if (code->expr3->rank != 0 && !attr.allocatable && !attr.pointer)
+	    gfc_conv_expr_descriptor (&se, code->expr3);
+	  else
+	    gfc_conv_expr_reference (&se, code->expr3);
+	  if (code->expr3->ts.type == BT_CLASS)
+	    gfc_conv_class_to_class (&se, code->expr3,
+				     code->expr3->ts,
+				     false, true,
+				     false, false);
+	  gfc_add_block_to_block (&block, &se.pre);
+	  gfc_add_block_to_block (&post, &se.post);
+	  /* Prevent aliasing, i.e., se.expr may be already a
 		 variable declaration.  */
-	      if (!VAR_P (se.expr))
-		{
-		  tmp = build_fold_indirect_ref_loc (input_location,
-						     se.expr);
-		  tmp = gfc_evaluate_now (tmp, &block);
-		}
-	      else
-		tmp = se.expr;
-	      if (!code->expr3->mold)
-		expr3 = tmp;
-	      else
-		expr3_tmp = tmp;
-	      /* When he length of a char array is easily available
-		 here, fix it for future use.  */
-	      if (se.string_length)
-		expr3_len = gfc_evaluate_now (se.string_length, &block);
+	  if (!VAR_P (se.expr))
+	    {
+	      tree var;
+	      tmp = build_fold_indirect_ref_loc (input_location,
+						 se.expr);
+	      /* We need a regular (non-UID) symbol here, therefore give a
+		 prefix.  */
+	      var = gfc_create_var (TREE_TYPE (tmp), "atmp");
+	      gfc_add_modify_loc (input_location, &block, var, tmp);
+	      tmp = var;
 	    }
+	  else
+	    tmp = se.expr;
+	  if (!code->expr3->mold)
+	    expr3 = tmp;
+	  else
+	    expr3_tmp = tmp;
+	  /* When he length of a char array is easily available
+		 here, fix it for future use.  */
+	  if (se.string_length)
+	    expr3_len = gfc_evaluate_now (se.string_length, &block);
 	}
 
       /* Figure how to get the _vtab entry.  This also obtains the tree
@@ -5246,11 +5246,15 @@ gfc_trans_allocate (gfc_code * code)
       if (code->expr3->ts.type == BT_CLASS)
 	{
 	  gfc_expr *rhs;
-	  /* Polymorphic SOURCE: VPTR must be determined at run time.  */
-	  if (expr3 != NULL_TREE && (VAR_P (expr3) || !code->expr3->ref))
+	  /* Polymorphic SOURCE: VPTR must be determined at run time.
+	     expr3 may be a temporary array declaration, therefore check for
+	     GFC_CLASS_TYPE_P before trying to get the _vptr component.  */
+	  if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3))
+	      && (VAR_P (expr3) || !code->expr3->ref))
 	    tmp = gfc_class_vptr_get (expr3);
 	  else if (expr3_tmp != NULL_TREE
-		   && (VAR_P (expr3_tmp) ||!code->expr3->ref))
+		   && GFC_CLASS_TYPE_P (TREE_TYPE (expr3_tmp))
+		   && (VAR_P (expr3_tmp) || !code->expr3->ref))
 	    tmp = gfc_class_vptr_get (expr3_tmp);
 	  else
 	    {
@@ -5325,6 +5329,64 @@ gfc_trans_allocate (gfc_code * code)
 	  else
 	    expr3_esize = TYPE_SIZE_UNIT (
 		  gfc_typenode_for_spec (&code->expr3->ts));
+
+	  /* The routine gfc_trans_assignment () already implements all
+	     techniques needed.  Unfortunately we may have a temporary
+	     variable for the source= expression here.  When that is the
+	     case convert this variable into a temporary gfc_expr of type
+	     EXPR_VARIABLE and used it as rhs for the assignment.  The
+	     advantage is, that we get scalarizer support for free,
+	     don't have to take care about scalar to array treatment and
+	     will benefit of every enhancements gfc_trans_assignment ()
+	     gets.  */
+	  if (expr3 != NULL_TREE && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
+	    {
+	      /* Build a temporary symtree and symbol.  Do not add it to
+		 the current namespace to prevent accidently modifying
+		 a colliding symbol's as.  */
+	      newsym = XCNEW (gfc_symtree);
+	      /* The name of the symtree should be unique, because
+		 gfc_create_var () took care about generating the
+		 identifier.  */
+	      newsym->name = gfc_get_string (IDENTIFIER_POINTER (
+					       DECL_NAME (expr3)));
+	      newsym->n.sym = gfc_new_symbol (newsym->name, NULL);
+	      /* The backend_decl is known.  It is expr3, which is inserted
+		 here.  */
+	      newsym->n.sym->backend_decl = expr3;
+	      e3rhs = gfc_get_expr ();
+	      e3rhs->ts = code->expr3->ts;
+	      e3rhs->rank = code->expr3->rank;
+	      e3rhs->symtree = newsym;
+	      /* Mark the symbol referenced or gfc_trans_assignment will
+		 bug.  */
+	      newsym->n.sym->attr.referenced = 1;
+	      e3rhs->expr_type = EXPR_VARIABLE;
+	      /* Set the symbols type, upto it was BT_UNKNOWN.  */
+	      newsym->n.sym->ts = e3rhs->ts;
+	      /* Check whether the expr3 is array valued.  */
+	      if (e3rhs->rank)
+		{
+		  gfc_array_spec *arr;
+		  arr = gfc_get_array_spec ();
+		  arr->rank = e3rhs->rank;
+		  arr->type = AS_DEFERRED;
+		  /* Set the dimension and pointer attribute for arrays
+		     to be on the safe side.  */
+		  newsym->n.sym->attr.dimension = 1;
+		  newsym->n.sym->attr.pointer = 1;
+		  newsym->n.sym->as = arr;
+		  gfc_add_full_array_ref (e3rhs, arr);
+		}
+	      else if (POINTER_TYPE_P (TREE_TYPE (expr3)))
+		newsym->n.sym->attr.pointer = 1;
+	      /* The string length is known to.  Set it for char arrays.  */
+	      if (e3rhs->ts.type == BT_CHARACTER)
+		newsym->n.sym->ts.u.cl->backend_decl = expr3_len;
+	      gfc_commit_symbol (newsym->n.sym);
+	    }
+	  else
+	    e3rhs = gfc_copy_expr (code->expr3);
 	}
       gcc_assert (expr3_esize);
       expr3_esize = fold_convert (sizetype, expr3_esize);
@@ -5628,13 +5690,12 @@ gfc_trans_allocate (gfc_code * code)
 	}
       if (code->expr3 && !code->expr3->mold)
 	{
-	  /* Initialization via SOURCE block
-	     (or static default initializer).  */
-	  gfc_expr *rhs = gfc_copy_expr (code->expr3);
+	  /* Initialization via SOURCE block (or static default initializer).
+	     Classes need some special handling, so catch them first.  */
 	  if (expr3 != NULL_TREE
 	      && ((POINTER_TYPE_P (TREE_TYPE (expr3))
 		   && TREE_CODE (expr3) != POINTER_PLUS_EXPR)
-		  || VAR_P (expr3))
+		  || (VAR_P (expr3) && GFC_CLASS_TYPE_P (TREE_TYPE (expr3))))
 	      && code->expr3->ts.type == BT_CLASS
 	      && (expr->ts.type == BT_CLASS
 		  || expr->ts.type == BT_DERIVED))
@@ -5644,24 +5705,13 @@ gfc_trans_allocate (gfc_code * code)
 	      tmp = gfc_copy_class_to_class (expr3, to,
 					     nelems, upoly_expr);
 	    }
-	  else if (code->expr3->ts.type == BT_CHARACTER)
-	    {
-	      tmp = INDIRECT_REF_P (se.expr) ?
-			se.expr :
-			build_fold_indirect_ref_loc (input_location,
-						     se.expr);
-	      gfc_trans_string_copy (&block, al_len, tmp,
-				     code->expr3->ts.kind,
-				     expr3_len, expr3,
-				     code->expr3->ts.kind);
-	      tmp = NULL_TREE;
-	    }
 	  else if (al->expr->ts.type == BT_CLASS)
 	    {
 	      gfc_actual_arglist *actual, *last_arg;
 	      gfc_expr *ppc;
 	      gfc_code *ppc_code;
 	      gfc_ref *ref, *dataref;
+	      gfc_expr *rhs = gfc_copy_expr (code->expr3);
 
 	      /* Do a polymorphic deep copy.  */
 	      actual = gfc_get_actual_arglist ();
@@ -5688,8 +5738,8 @@ gfc_trans_allocate (gfc_code * code)
 		  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.  */
+		     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++)
 		    {
@@ -5758,8 +5808,8 @@ gfc_trans_allocate (gfc_code * code)
 		      gfc_add_len_component (last_arg->expr);
 		    }
 		  else if (code->expr3->ts.type == BT_CHARACTER)
-		      last_arg->expr =
-			  gfc_copy_expr (code->expr3->ts.u.cl->length);
+		    last_arg->expr =
+			gfc_copy_expr (code->expr3->ts.u.cl->length);
 		  else
 		    gcc_unreachable ();
 
@@ -5773,6 +5823,7 @@ gfc_trans_allocate (gfc_code * code)
 					 void_type_node, tmp, extcopy, stdcopy);
 		}
 	      gfc_free_statements (ppc_code);
+	      gfc_free_expr (rhs);
 	    }
 	  else
 	    {
@@ -5781,10 +5832,9 @@ gfc_trans_allocate (gfc_code * code)
 	      int realloc_lhs = flag_realloc_lhs;
 	      flag_realloc_lhs = 0;
 	      tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
-					  rhs, false, false);
+					  e3rhs, false, false);
 	      flag_realloc_lhs = realloc_lhs;
 	    }
-	  gfc_free_expr (rhs);
 	  gfc_add_expr_to_block (&block, tmp);
 	}
      else if (code->expr3 && code->expr3->mold
@@ -5802,6 +5852,15 @@ gfc_trans_allocate (gfc_code * code)
        gfc_free_expr (expr);
     } // for-loop
 
+  if (e3rhs)
+    {
+      if (newsym)
+	{
+	  gfc_free_symbol (newsym->n.sym);
+	  XDELETE (newsym);
+	}
+      gfc_free_expr (e3rhs);
+    }
   /* STAT.  */
   if (code->expr1)
     {

gcc/testsuite/ChangeLog

+2015-05-20  Andre Vehreschild  <vehre@gmx.de>
+
+	PR fortran/65548
+	* gfortran.dg/allocate_with_source_5.f90: Extend test.
+
 2015-05-20  Bin Cheng  <bin.cheng@arm.com>
 
 	PR tree-optimization/65447

gcc/testsuite/gfortran.dg/allocate_with_source_5.f90

 ! { dg-do run }
 !
+! Contributed by Juergen Reuter
 ! Check that pr65548 is fixed.
-! Contributed by Juergen Reuter  <juergen.reuter@desy.de>
-
-module allocate_with_source_5_module
+!
 
+module selectors
   type :: selector_t
-    integer, dimension(:), allocatable :: map
-    real, dimension(:), allocatable :: weight
-  contains
-    procedure :: init => selector_init
-  end type selector_t
+     integer, dimension(:), allocatable :: map
+     real, dimension(:), allocatable :: weight
+   contains
+     procedure :: init => selector_init
+   end type selector_t
 
 contains
 
@@ -34,19 +34,126 @@ contains
     end if
   end subroutine selector_init
 
-end module allocate_with_source_5_module
+end module selectors
+
+module phs_base
+  type :: flavor_t
+  contains
+     procedure :: get_mass => flavor_get_mass
+  end type flavor_t
+
+  type :: phs_config_t
+     integer :: n_in = 0
+     type(flavor_t), dimension(:,:), allocatable :: flv
+  end type phs_config_t
+
+  type :: phs_t
+     class(phs_config_t), pointer :: config => null ()
+     real, dimension(:), allocatable :: m_in
+  end type phs_t
+
+contains
+
+  elemental function flavor_get_mass (flv) result (mass)
+    real :: mass
+    class(flavor_t), intent(in) :: flv
+    mass = 42.0
+  end function flavor_get_mass
+
+  subroutine phs_base_init (phs, phs_config)
+    class(phs_t), intent(out) :: phs
+    class(phs_config_t), intent(in), target :: phs_config
+    phs%config => phs_config
+    allocate (phs%m_in  (phs%config%n_in), &
+         source = phs_config%flv(:phs_config%n_in, 1)%get_mass ())
+  end subroutine phs_base_init
+
+end module phs_base
+
+module foo
+  type :: t
+     integer :: n
+     real, dimension(:,:), allocatable :: val
+   contains
+     procedure :: make => t_make
+     generic :: get_int => get_int_array, get_int_element
+     procedure :: get_int_array => t_get_int_array
+     procedure :: get_int_element => t_get_int_element
+  end type t
+
+contains
+
+  subroutine t_make (this)
+    class(t), intent(inout) :: this
+    real, dimension(:), allocatable :: int
+    allocate (int (0:this%n-1), source=this%get_int())
+  end subroutine t_make
+
+  pure function t_get_int_array (this) result (array)
+    class(t), intent(in) :: this
+    real, dimension(this%n) :: array
+    array = this%val (0:this%n-1, 4)
+  end function t_get_int_array
+
+  pure function t_get_int_element (this, set) result (element)
+    class(t), intent(in) :: this
+    integer, intent(in) :: set
+    real :: element
+    element = this%val (set, 4)
+  end function t_get_int_element
+end module foo
+module foo2
+  type :: t2
+     integer :: n
+     character(32), dimension(:), allocatable :: md5
+   contains
+     procedure :: init => t2_init
+  end type t2
+
+contains
+
+  subroutine t2_init (this)
+    class(t2), intent(inout) :: this
+    character(32), dimension(:), allocatable :: md5
+    allocate (md5 (this%n), source=this%md5)
+    if (md5(1) /= "tst                             ") call abort()
+    if (md5(2) /= "                                ") call abort()
+    if (md5(3) /= "fooblabar                       ") call abort()
+  end subroutine t2_init
+end module foo2
+
+program test
+  use selectors
+  use phs_base
+  use foo
+  use foo2
+
+  type(selector_t) :: sel
+  type(phs_t) :: phs
+  type(phs_config_t) :: phs_config
+  type(t) :: o
+  type(t2) :: o2
+
+  call sel%init([2., 0., 3., 0., 4.])
+
+  if (any(sel%map /= [1, 3, 5])) call abort()
+  if (any(abs(sel%weight - [2., 3., 4.] / 9.) > 1E-6)) call abort()
 
-program allocate_with_source_5
-  use allocate_with_source_5_module
+  phs_config%n_in = 2
+  allocate (phs_config%flv (phs_config%n_in, 1))
+  call phs_base_init (phs, phs_config)
 
-  class(selector_t), allocatable :: sel;
-  real, dimension(5) :: w = [ 1, 0, 2, 0, 3];
+  if (any(abs(phs%m_in - [42.0, 42.0]) > 1E-6)) call abort()
 
-  allocate (sel)
-  call sel%init(w)
+  o%n = 2
+  allocate (o%val(2,4))
+  call o%make()
 
-  if (any(sel%map /= [ 1, 3, 5])) call abort()
-  if (any(abs(sel%weight - [1, 2, 3] / 6) < 1E-6)) call abort()
-end program allocate_with_source_5
-! { dg-final { cleanup-modules "allocate_with_source_5_module" } }
+  o2%n = 3
+  allocate(o2%md5(o2%n))
+  o2%md5(1) = "tst"
+  o2%md5(2) = ""
+  o2%md5(3) = "fooblabar"
+  call o2%init()
+end program test