Re: [Patch, fortran, pr65548, 2nd take, v3] [5/6 Regression] gfc_conv_procedure_call

[Andre Vehreschild <vehre@gmx.de>]

[-- Attachment #1: Type: text/plain, Size: 1502 bytes --]

Hi all,

this is just a service release. I encountered that the new testcase in the
previous release included the testcase of the initial patch, that is
already on trunk. I therefore replaced the testcase allocate_with_source_5.f90
by allocate_with_source_6.f90 (the extended testcase). Besides this there is no
difference inbetween this and the patch in:

https://gcc.gnu.org/ml/fortran/2015-04/msg00121.html

Sorry for the mess. For a description of the original patches scope see below.

Bootstraps and regtests ok on x86_64-linux-gnu/F21.

Ok for trunk?

Regards,
	Andre

On Wed, 29 Apr 2015 14:31:01 +0200
Andre Vehreschild <vehre@gmx.de> wrote:

> Hi all,
> 
> after the first patch to fix the issue reported in the pr, some more issues
> were reported, which are now fixed by this new patch, aka the 2nd take.
> 
> The patch modifies the gfc_trans_allocate() in order to pre-evaluate all
> source= expressions. It no longer rejects array valued source= expressions,
> but just uses gfc_conv_expr_descriptor () for most of them. Furthermore, is
> the allocate now again able to allocate arrays of strings. This feature
> previously slipped my attention.
> 
> Although the reporter has not yet reported, that the patch fixes his issue, I
> like to post it for review, because there are more patches in my pipeline,
> that depend on this one. 
> 
> Bootstraps and regtests ok on x86_64-linux-gnu/F21.
> 
> Ok, for trunk?
> 
> Regards,
> 	Andre


-- 
Andre Vehreschild * Email: vehre ad gmx dot de 

[-- Attachment #2: pr65548_3.clog --]
[-- Type: application/octet-stream, Size: 393 bytes --]

gcc/fortran/ChangeLog:

2015-04-28  Andre Vehreschild  <vehre@gmx.de>

	PR fortran/65548
	* trans-stmt.c (gfc_trans_allocate): Always retrieve the
	descriptor or a refrence to a source= expression now for
	arrays and non-arrays, respectively.

gcc/testsuite/ChangeLog:

2015-04-28  Andre Vehreschild  <vehre@gmx.de>

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



[-- Attachment #3: pr65548_3.patch --]
[-- Type: text/x-patch, Size: 14058 bytes --]

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 53e9bcc..1e435be 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5148,14 +5148,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 +5165,86 @@ 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);
+	  /* For more complicated expression, the decision when to get the
+	     descriptor and when to get a reference is depending on more
+	     conditions.  The descriptor is only retrieved for functions
+	     that are intrinsic, elemental user-defined and known, or neither
+	     of the two, or are a class or type, that has a not deferred type
+	     array_spec.  */
+	  if (code->expr3->rank != 0
+	      && (code->expr3->expr_type != EXPR_FUNCTION
+		  || code->expr3->value.function.isym
+		  || (code->expr3->value.function.esym &&
+		      code->expr3->value.function.esym->attr.elemental)
+		  || (!code->expr3->value.function.isym
+		      && !code->expr3->value.function.esym)
+		  || (code->expr3->ts.type == BT_DERIVED
+		      && code->expr3->ts.u.derived->as
+		      && code->expr3->ts.u.derived->as->type != AS_DEFERRED)
+		  || (code->expr3->ts.type == BT_CLASS
+		      && CLASS_DATA (code->expr3)->as
+		      && CLASS_DATA (code->expr3)->as->type != AS_DEFERRED)))
+	    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))
+	    {
+	      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);
 	}
 
       /* Figure how to get the _vtab entry.  This also obtains the tree
@@ -5246,11 +5254,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
 	    {
@@ -5634,7 +5646,7 @@ gfc_trans_allocate (gfc_code * code)
 	  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))
@@ -5646,14 +5658,50 @@ gfc_trans_allocate (gfc_code * code)
 	    }
 	  else if (code->expr3->ts.type == BT_CHARACTER)
 	    {
-	      tmp = INDIRECT_REF_P (se.expr) ?
+	      tree dst, src, dlen, slen;
+	      /* For arrays of char arrays, a ref to the data component still
+		 needs to be added, because se.expr upto now only contains the
+		 descritor.  */
+	      if (expr->ref && se.expr && TREE_TYPE (se.expr) != NULL_TREE
+		  && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
+		{
+		  dst = gfc_conv_array_data (se.expr);
+		  src = gfc_conv_array_data (expr3);
+		  /* For CHARACTER (len=string_length), dimension (nelems)
+		     compute the total length of the string to copy.  */
+		  if (nelems)
+		    {
+		      dlen = fold_build2_loc (input_location, MULT_EXPR,
+					      size_type_node,
+					      fold_convert (size_type_node,
+							    se.string_length),
+					      fold_convert (size_type_node,
+							    nelems));
+		      slen = fold_build2_loc (input_location, MULT_EXPR,
+					      size_type_node,
+					      fold_convert (size_type_node,
+							    expr3_len),
+					      fold_convert (size_type_node,
+							    nelems));
+		    }
+		  else
+		    {
+		      dlen = se.string_length;
+		      slen = expr3_len;
+		    }
+		}
+	      else
+		{
+		  dst = 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);
+		  src = expr3;
+		  dlen = al_len;
+		  slen = expr3_len;
+		}
+	      gfc_trans_string_copy (&block, dlen, dst, code->expr3->ts.kind,
+				     slen, src, code->expr3->ts.kind);
 	      tmp = NULL_TREE;
 	    }
 	  else if (al->expr->ts.type == BT_CLASS)
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90
index e934e08..500f0f0 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90
@@ -1,16 +1,16 @@
 ! { 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