[Patch, fortran, pr65548, v1] [5 Regression] gfc_conv_procedure_call

[Patch, fortran, pr65548, v1] [5 Regression] gfc_conv_procedure_call

[Andre Vehreschild]

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

Hi all,

please find attached a fix for the recently introduced regression when
allocating arrays with an intrinsic function for source=. The patch addresses
this issue by using gfc_conv_expr_descriptor () for intrinsic functions.

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

Ok for trunk?

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

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

gcc/testsuite/ChangeLog:

2015-03-25  Andre Vehreschild  <vehre@gmx.de>

	* gfortran.dg/allocate_with_source_5.f90: New test.


gcc/fortran/ChangeLog:

2015-03-25  Andre Vehreschild  <vehre@gmx.de>

	* trans-stmt.c (gfc_trans_allocate): For intrinsic functions
	use conv_expr_descriptor() instead of conv_expr_reference().


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

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 6ffae6e79e..68b343b 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5075,12 +5075,17 @@ gfc_trans_allocate (gfc_code * code)
 	      /* In all other cases evaluate the expr3 and create a
 		 temporary.  */
 	      gfc_init_se (&se, NULL);
-	      gfc_conv_expr_reference (&se, code->expr3);
+	      if (code->expr3->rank != 0
+		  && code->expr3->expr_type == EXPR_FUNCTION
+		  && code->expr3->value.function.isym)
+		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);
+					 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
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90
new file mode 100644
index 0000000..e934e08
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90
@@ -0,0 +1,52 @@
+! { dg-do run }
+!
+! Check that pr65548 is fixed.
+! Contributed by Juergen Reuter  <juergen.reuter@desy.de>
+
+module allocate_with_source_5_module
+
+  type :: selector_t
+    integer, dimension(:), allocatable :: map
+    real, dimension(:), allocatable :: weight
+  contains
+    procedure :: init => selector_init
+  end type selector_t
+
+contains
+
+  subroutine selector_init (selector, weight)
+    class(selector_t), intent(out) :: selector
+    real, dimension(:), intent(in) :: weight
+    real :: s
+    integer :: n, i
+    logical, dimension(:), allocatable :: mask
+    s = sum (weight)
+    allocate (mask (size (weight)), source = weight /= 0)
+    n = count (mask)
+    if (n > 0) then
+       allocate (selector%map (n), &
+            source = pack ([(i, i = 1, size (weight))], mask))
+       allocate (selector%weight (n), &
+            source = pack (weight / s, mask))
+    else
+       allocate (selector%map (1), source = 1)
+       allocate (selector%weight (1), source = 0.)
+    end if
+  end subroutine selector_init
+
+end module allocate_with_source_5_module
+
+program allocate_with_source_5
+  use allocate_with_source_5_module
+
+  class(selector_t), allocatable :: sel;
+  real, dimension(5) :: w = [ 1, 0, 2, 0, 3];
+
+  allocate (sel)
+  call sel%init(w)
+
+  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" } }
+

Re: [Ping, Patch, fortran, pr65548, v1] [5 Regression] gfc_conv_procedure_call

[Andre Vehreschild]

Ping! 

This should be in 5.1. Dominique and I feel like this patch is nearly obvious.

Regards,
	Andre

On Wed, 25 Mar 2015 14:35:54 +0100
Andre Vehreschild <vehre@gmx.de> wrote:

> Hi all,
> 
> please find attached a fix for the recently introduced regression when
> allocating arrays with an intrinsic function for source=. The patch addresses
> this issue by using gfc_conv_expr_descriptor () for intrinsic functions.
> 
> Bootstraps and regtests ok on x86_64-linux-gnu/F20.
> 
> Ok for trunk?
> 
> Regards,
> 	Andre


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

Re: [Ping, Patch, fortran, pr65548, v1] [5 Regression] gfc_conv_procedure_call

[Jerry DeLisle]

On 04/02/2015 03:28 AM, Andre Vehreschild wrote:
> Ping!
>
> This should be in 5.1. Dominique and I feel like this patch is nearly obvious.
>
> Regards,
> 	Andre
>
> On Wed, 25 Mar 2015 14:35:54 +0100
> Andre Vehreschild <vehre@gmx.de> wrote:
>
>> Hi all,
>>
>> please find attached a fix for the recently introduced regression when
>> allocating arrays with an intrinsic function for source=. The patch addresses
>> this issue by using gfc_conv_expr_descriptor () for intrinsic functions.
>>
>> Bootstraps and regtests ok on x86_64-linux-gnu/F20.
>>
>> Ok for trunk?

Yes, ok for trunk.

Thanks,

Jerry

Re: [Ping, Patch, fortran, pr65548, v1] [5 Regression] gfc_conv_procedure_call

[Andre Vehreschild]

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

Hi Jerry, hi all,

thank you for the review. Commited as r221897.

Regards,
	Andre

On Thu, 02 Apr 2015 17:06:07 -0700
Jerry DeLisle <jvdelisle@charter.net> wrote:

> On 04/02/2015 03:28 AM, Andre Vehreschild wrote:
> > Ping!
> >
> > This should be in 5.1. Dominique and I feel like this patch is nearly
> > obvious.
> >
> > Regards,
> > 	Andre
> >
> > On Wed, 25 Mar 2015 14:35:54 +0100
> > Andre Vehreschild <vehre@gmx.de> wrote:
> >
> >> Hi all,
> >>
> >> please find attached a fix for the recently introduced regression when
> >> allocating arrays with an intrinsic function for source=. The patch
> >> addresses this issue by using gfc_conv_expr_descriptor () for intrinsic
> >> functions.
> >>
> >> Bootstraps and regtests ok on x86_64-linux-gnu/F20.
> >>
> >> Ok for trunk?
> 
> Yes, ok for trunk.
> 
> Thanks,
> 
> Jerry
> 


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

[-- Attachment #2: pr65548.patch --]
[-- Type: text/x-patch, Size: 3658 bytes --]

Index: gcc/fortran/ChangeLog
===================================================================
--- gcc/fortran/ChangeLog	(Revision 221896)
+++ gcc/fortran/ChangeLog	(Arbeitskopie)
@@ -1,3 +1,9 @@
+2015-04-07  Andre Vehreschild  <vehre@gmx.de>
+
+	PR fortran/65548
+	* trans-stmt.c (gfc_trans_allocate): For intrinsic functions
+	use conv_expr_descriptor() instead of conv_expr_reference().
+
 2015-03-30  Jakub Jelinek  <jakub@redhat.com>
 
 	PR fortran/65597
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c	(Revision 221896)
+++ gcc/fortran/trans-stmt.c	(Arbeitskopie)
@@ -5049,12 +5049,17 @@
 	      /* In all other cases evaluate the expr3 and create a
 		 temporary.  */
 	      gfc_init_se (&se, NULL);
-	      gfc_conv_expr_reference (&se, code->expr3);
+	      if (code->expr3->rank != 0
+		  && code->expr3->expr_type == EXPR_FUNCTION
+		  && code->expr3->value.function.isym)
+		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);
+					 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
Index: gcc/testsuite/ChangeLog
===================================================================
--- gcc/testsuite/ChangeLog	(Revision 221896)
+++ gcc/testsuite/ChangeLog	(Arbeitskopie)
@@ -1,3 +1,8 @@
+2015-04-07  Andre Vehreschild  <vehre@gmx.de>
+
+	PR fortran/65548
+	* gfortran.dg/allocate_with_source_5.f90: New test.
+
 2015-04-07  Ilya Enkovich  <ilya.enkovich@intel.com>
 
 	* gcc.target/i386/mpx/chkp-thunk-comdat-1.cc: New.
Index: gcc/testsuite/gfortran.dg/allocate_with_source_5.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_with_source_5.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/allocate_with_source_5.f90	(Arbeitskopie)
@@ -0,0 +1,52 @@
+! { dg-do run }
+!
+! Check that pr65548 is fixed.
+! Contributed by Juergen Reuter  <juergen.reuter@desy.de>
+
+module allocate_with_source_5_module
+
+  type :: selector_t
+    integer, dimension(:), allocatable :: map
+    real, dimension(:), allocatable :: weight
+  contains
+    procedure :: init => selector_init
+  end type selector_t
+
+contains
+
+  subroutine selector_init (selector, weight)
+    class(selector_t), intent(out) :: selector
+    real, dimension(:), intent(in) :: weight
+    real :: s
+    integer :: n, i
+    logical, dimension(:), allocatable :: mask
+    s = sum (weight)
+    allocate (mask (size (weight)), source = weight /= 0)
+    n = count (mask)
+    if (n > 0) then
+       allocate (selector%map (n), &
+            source = pack ([(i, i = 1, size (weight))], mask))
+       allocate (selector%weight (n), &
+            source = pack (weight / s, mask))
+    else
+       allocate (selector%map (1), source = 1)
+       allocate (selector%weight (1), source = 0.)
+    end if
+  end subroutine selector_init
+
+end module allocate_with_source_5_module
+
+program allocate_with_source_5
+  use allocate_with_source_5_module
+
+  class(selector_t), allocatable :: sel;
+  real, dimension(5) :: w = [ 1, 0, 2, 0, 3];
+
+  allocate (sel)
+  call sel%init(w)
+
+  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" } }
+

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

[Andre Vehreschild]

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

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_2.clog --]
[-- Type: application/octet-stream, Size: 354 bytes --]

gcc/fortran/ChangeLog:

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

	* 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>

	* gfortran.dg/allocate_with_source_6.f90: New test.



[-- Attachment #3: pr65548_2.patch --]
[-- Type: text/x-patch, Size: 13906 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_6.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_6.f90
new file mode 100644
index 0000000..d7c9ca0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_6.f90
@@ -0,0 +1,159 @@
+! { dg-do run }
+!
+! Contributed by Juergen Reuter
+! Check that pr65548 is fixed.
+!
+
+module selectors
+  type :: selector_t
+     integer, dimension(:), allocatable :: map
+     real, dimension(:), allocatable :: weight
+   contains
+     procedure :: init => selector_init
+   end type selector_t
+
+contains
+
+  subroutine selector_init (selector, weight)
+    class(selector_t), intent(out) :: selector
+    real, dimension(:), intent(in) :: weight
+    real :: s
+    integer :: n, i
+    logical, dimension(:), allocatable :: mask
+    s = sum (weight)
+    allocate (mask (size (weight)), source = weight /= 0)
+    n = count (mask)
+    if (n > 0) then
+       allocate (selector%map (n), &
+            source = pack ([(i, i = 1, size (weight))], mask))
+       allocate (selector%weight (n), &
+            source = pack (weight / s, mask))
+    else
+       allocate (selector%map (1), source = 1)
+       allocate (selector%weight (1), source = 0.)
+    end if
+  end subroutine selector_init
+
+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(sel%weight /= [2./9., 3./9., 4./9.])) call abort()
+
+  phs_config%n_in = 2
+  allocate (phs_config%flv (phs_config%n_in, 1))
+  call phs_base_init (phs, phs_config)
+
+  if (any (phs%m_in /= [42.0, 42.0])) call abort()
+
+  o%n = 2
+  allocate (o%val(2,4))
+  call o%make()
+
+  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
+

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

[Andre Vehreschild]

[-- 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
 

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

[Mikael Morin]

Hello,

Le 30/04/2015 15:07, Andre Vehreschild a écrit :
> 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?
>>
questions below
> 
> 
> *** trans-stmt.c	2015-05-12 14:42:17.882108651 +0200
> --- trans-stmt.c.modif	2015-05-12 14:42:11.300108561 +0200
> ***************
> *** 5205,5213 ****
>   	      /* In all other cases evaluate the expr3 and create a
>   		 temporary.  */
>   	      gfc_init_se (&se, NULL);
>   	      if (code->expr3->rank != 0
> ! 		  && code->expr3->expr_type == EXPR_FUNCTION
> ! 		  && code->expr3->value.function.isym)
>   		gfc_conv_expr_descriptor (&se, code->expr3);
>   	      else
>   		gfc_conv_expr_reference (&se, code->expr3);
> --- 5198,5222 ----
>   	  /* 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);
What is the rationale for choosing between gfc_conv_expr_descriptor and
gfc_conv_expr_reference?
Is it contiguous array vs non-contiguous or needing an evaluation?
For example why not use gfc_conv_expr_descriptor for derived type arrays?

> ***************
> *** 5646,5659 ****
>   	    }
>   	  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)
> --- 5658,5707 ----
>   	    }
>   	  else if (code->expr3->ts.type == BT_CHARACTER)
>   	    {
> ! 	      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);
> ! 		  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)
This seems to assume that the array is contiguous.
Can't we just fall  back to the default case for characters?

The rest looks good.

Mikael

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

[Andre Vehreschild]

Hi Mikael,

<snip>
> > --- 5198,5222 ----
> >   	  /* 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);
> What is the rationale for choosing between gfc_conv_expr_descriptor and
> gfc_conv_expr_reference?

The rationale is to get the array descriptor for all arrays, but deferred type
ones. For deferred type ones gfc_conv_expr_descriptor either failed or the
result does not satisfy further processing needs.

> Is it contiguous array vs non-contiguous or needing an evaluation?

Neither. How the array is shaped is not of my concern.

> For example why not use gfc_conv_expr_descriptor for derived type arrays?

But it does use gfc_conv_expr_descriptor for derived type arrays! It is just
not used for deferred ones.

> > ***************
> > *** 5646,5659 ****
> >   	    }
> >   	  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)
> > --- 5658,5707 ----
> >   	    }
> >   	  else if (code->expr3->ts.type == BT_CHARACTER)
> >   	    {
> > ! 	      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);
> > ! 		  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)
> This seems to assume that the array is contiguous.
> Can't we just fall  back to the default case for characters?

What do you take as the default case for characters? You are right the above
code assumes the array of char arrays is contiguous, which I admit to fail when
the array isn't. Any experience of how to do this better? gfc_trans_string_copy
is not capable of copying multiple strings, so how to do it most future safe?
Any idea?

Regards,
	Andre

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

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

[Andre Vehreschild]

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

Hi Mikael, hi all,

please find  attached the new version of this patch, where most of the source=
expression assignment to the object to allocate is handled by
gfc_trans_assignment (). To use trans_assignment with temporaries introduced
during the preparation of the source= expression, a gfc_expr is created from
the temporary identifier in the tree of expr3. This creation is done only,
when the tree is an artificial declaration, i.e., a temporary. The gfx_expr is
created only once and only for non-class objects, because for the latter
gfc_trans_assignment can't cope with class arrays, for which the
gfc_trans_allocate () needs the array-descriptor, which is not as easy to
transfer to gfc_trans_assignment (). For class objects gfc_trans_allocate ()
therefore cares about the assignment/data copy itself.

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_4.clog --]
[-- Type: text/plain, Size: 494 bytes --]

gcc/fortran/ChangeLog:

2015-05-14  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 now for
	arrays and non-arrays, respectively.  Use a temporary
	symbol and gfc_trans_assignment for all source=
	assignments to allocated objects.

gcc/testsuite/ChangeLog:

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

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


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

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 814bdde..9688f71 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/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;
@@ -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,91 @@ 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))
+	    {
+	      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 +5259,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 +5342,62 @@ 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.  */
+	  e3rhs = gfc_copy_expr (code->expr3);
+	  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.  */
+	      gfc_symtree *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 temporary is likely to need no references, but a
+		 full array ref, therefore clear the chain of refs.  */
+	      gfc_free_ref_list (e3rhs->ref);
+	      e3rhs->ref = NULL;
+	      /* The backend_decl is known.  It is expr3, which is inserted
+		 here.  */
+	      newsym->n.sym->backend_decl = expr3;
+	      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);
+		}
+	      /* The string length is known to.  Set it for char arrays.  */
+	      if (code->expr3->ts.type == BT_CHARACTER)
+		newsym->n.sym->ts.u.cl->backend_decl = expr3_len;
+	      gfc_commit_symbol (newsym->n.sym);
+	    }
 	}
       gcc_assert (expr3_esize);
       expr3_esize = fold_convert (sizetype, expr3_esize);
@@ -5628,13 +5701,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 +5716,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 +5749,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 +5819,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 +5834,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 +5843,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
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
 

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

[Andre Vehreschild]

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

Hi all,

find attached latest version to fix 65548.

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

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

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

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.


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

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 814bdde..6d565ae 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/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,62 @@ 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);
+		}
+	      /* 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 +5688,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 +5703,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 +5736,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 +5806,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 +5821,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 +5830,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 +5850,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)
     {
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
 

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

[Mikael Morin]

Le 19/05/2015 10:50, Andre Vehreschild a écrit :
> Hi all,
> 
> find attached latest version to fix 65548.
> 
> Bootstraps and regtests ok on x86_64-linux-gnu/f21.
> 
OK. Thanks.

Mikael

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

[Andre Vehreschild]

Hi Mikael,

when I got you right on IRC, then you proposed this change about the pointer
attribute:

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 6d565ae..545f778 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5361,6 +5361,7 @@ gfc_trans_allocate (gfc_code * code)
              /* Mark the symbol referenced or gfc_trans_assignment will
                 bug.  */
              newsym->n.sym->attr.referenced = 1;
+             newsym->n.sym->attr.pointer = 1;
              e3rhs->expr_type = EXPR_VARIABLE;
              /* Set the symbols type, upto it was BT_UNKNOWN.  */
              newsym->n.sym->ts = e3rhs->ts;
@@ -5374,7 +5375,6 @@ gfc_trans_allocate (gfc_code * code)
                  /* 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);
                }

Unfortunately does this lead to numerous regressions in the testsuite. For
example:

./gfortran.sh -g allocate_alloc_opt_6.f90 -o allocate_alloc_opt_6
Fortraning using ***DEVelopment*** version...
allocate_alloc_opt_6.f90:26:0:

   allocate(t, source=mytype(1.0,2))
 ^
internal compiler error: Segmentation fault
0xe09a08 crash_signal
	/home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/toplev.c:380
0xa9cbe1 useless_type_conversion_p(tree_node*, tree_node*)
	/home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/gimple-expr.c:83
0x10622ae tree_ssa_useless_type_conversion(tree_node*)
	/home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/tree-ssa.c:1178
0x10622fe tree_ssa_strip_useless_type_conversions(tree_node*)
	/home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/tree-ssa.c:1190
0xb6c4ae gimplify_expr(tree_node**, gimple_statement_base**,
   gimple_statement_base**, bool (*)(tree_node*), int)
	/home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/gimplify.c:7815
0xb5e883 gimplify_modify_expr
	/home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/gimplify.c:4644

I therefore came to a more elaborate change (revert the above one before
testing this):

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 6d565ae..7b466de 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5378,6 +5378,10 @@ gfc_trans_allocate (gfc_code * code)
                  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;
+             else
+               newsym->n.sym->attr.value = 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;

This patch bootstraps and regtests fine again. Ok to commit?

Regards,
	Andre

On Tue, 19 May 2015 16:02:18 +0200
Mikael Morin <mikael.morin@sfr.fr> wrote:

> Le 19/05/2015 10:50, Andre Vehreschild a écrit :
> > Hi all,
> > 
> > find attached latest version to fix 65548.
> > 
> > Bootstraps and regtests ok on x86_64-linux-gnu/f21.
> > 
> OK. Thanks.
> 
> Mikael


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

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

[Mikael Morin]

Le 20/05/2015 10:24, Andre Vehreschild a écrit :
> Hi Mikael,
> 
> when I got you right on IRC, then you proposed this change about the pointer
> attribute:
> 
> diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
> index 6d565ae..545f778 100644
> --- a/gcc/fortran/trans-stmt.c
> +++ b/gcc/fortran/trans-stmt.c
> @@ -5361,6 +5361,7 @@ gfc_trans_allocate (gfc_code * code)
>               /* Mark the symbol referenced or gfc_trans_assignment will
>                  bug.  */
>               newsym->n.sym->attr.referenced = 1;
> +             newsym->n.sym->attr.pointer = 1;
>               e3rhs->expr_type = EXPR_VARIABLE;
>               /* Set the symbols type, upto it was BT_UNKNOWN.  */
>               newsym->n.sym->ts = e3rhs->ts;
> @@ -5374,7 +5375,6 @@ gfc_trans_allocate (gfc_code * code)
>                   /* 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);
>                 }
> 
> Unfortunately does this lead to numerous regressions in the testsuite. For
> example:
> 
> ./gfortran.sh -g allocate_alloc_opt_6.f90 -o allocate_alloc_opt_6
> Fortraning using ***DEVelopment*** version...
> allocate_alloc_opt_6.f90:26:0:
> 
>    allocate(t, source=mytype(1.0,2))
>  ^
> internal compiler error: Segmentation fault
> 0xe09a08 crash_signal
> 	/home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/toplev.c:380
> 0xa9cbe1 useless_type_conversion_p(tree_node*, tree_node*)
> 	/home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/gimple-expr.c:83
> 0x10622ae tree_ssa_useless_type_conversion(tree_node*)
> 	/home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/tree-ssa.c:1178
> 0x10622fe tree_ssa_strip_useless_type_conversions(tree_node*)
> 	/home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/tree-ssa.c:1190
> 0xb6c4ae gimplify_expr(tree_node**, gimple_statement_base**,
>    gimple_statement_base**, bool (*)(tree_node*), int)
> 	/home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/gimplify.c:7815
> 0xb5e883 gimplify_modify_expr
> 	/home/vehre/Projekte/c_gcc_fortran2003_enhancements_cmbant_freelancer//gcc/gcc/gimplify.c:4644
> 
> I therefore came to a more elaborate change (revert the above one before
> testing this):
> 
> diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
> index 6d565ae..7b466de 100644
> --- a/gcc/fortran/trans-stmt.c
> +++ b/gcc/fortran/trans-stmt.c
> @@ -5378,6 +5378,10 @@ gfc_trans_allocate (gfc_code * code)
>                   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;
> +             else
> +               newsym->n.sym->attr.value = 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;
> 
> This patch bootstraps and regtests fine again. Ok to commit?
> 
You can drop the else branch.  OK to commit with that change.
Thanks.

Mikael

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

[Andre Vehreschild]

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

Hi all,

Mikael, thanks for the review. Committed as r223445 (without the else-branch).

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

[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 18486 bytes --]

Index: gcc/fortran/ChangeLog
===================================================================
--- gcc/fortran/ChangeLog	(Revision 223444)
+++ gcc/fortran/ChangeLog	(Arbeitskopie)
@@ -1,3 +1,13 @@
+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
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c	(Revision 223444)
+++ gcc/fortran/trans-stmt.c	(Arbeitskopie)
@@ -5088,7 +5088,7 @@
 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 @@
   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 @@
       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 @@
 	   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,
+	     then convert it once here.  */
+      if (code->expr3->expr_type == EXPR_VARIABLE
+	  || code->expr3->expr_type == EXPR_ARRAY
+	  || code->expr3->expr_type == EXPR_CONSTANT)
 	{
-	  /* 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)
 	    {
-	      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
-	    {
-	      /* 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
+	  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);
-	    }
+	  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 @@
       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 @@
 	  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 @@
 	}
       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,18 +5705,6 @@
 	      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;
@@ -5662,6 +5711,7 @@
 	      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_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_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 @@
 					 void_type_node, tmp, extcopy, stdcopy);
 		}
 	      gfc_free_statements (ppc_code);
+	      gfc_free_expr (rhs);
 	    }
 	  else
 	    {
@@ -5781,10 +5832,9 @@
 	      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_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)
     {
Index: gcc/testsuite/ChangeLog
===================================================================
--- gcc/testsuite/ChangeLog	(Revision 223444)
+++ gcc/testsuite/ChangeLog	(Arbeitskopie)
@@ -1,3 +1,8 @@
+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
Index: gcc/testsuite/gfortran.dg/allocate_with_source_5.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_with_source_5.f90	(Revision 223444)
+++ gcc/testsuite/gfortran.dg/allocate_with_source_5.f90	(Arbeitskopie)
@@ -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 @@
     end if
   end subroutine selector_init
 
-end module allocate_with_source_5_module
+end module selectors
 
-program allocate_with_source_5
-  use allocate_with_source_5_module
+module phs_base
+  type :: flavor_t
+  contains
+     procedure :: get_mass => flavor_get_mass
+  end type flavor_t
 
-  class(selector_t), allocatable :: sel;
-  real, dimension(5) :: w = [ 1, 0, 2, 0, 3];
+  type :: phs_config_t
+     integer :: n_in = 0
+     type(flavor_t), dimension(:,:), allocatable :: flv
+  end type phs_config_t
 
-  allocate (sel)
-  call sel%init(w)
+  type :: phs_t
+     class(phs_config_t), pointer :: config => null ()
+     real, dimension(:), allocatable :: m_in
+  end type phs_t
 
-  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" } }
+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()
+
+  phs_config%n_in = 2
+  allocate (phs_config%flv (phs_config%n_in, 1))
+  call phs_base_init (phs, phs_config)
+
+  if (any(abs(phs%m_in - [42.0, 42.0]) > 1E-6)) call abort()
+
+  o%n = 2
+  allocate (o%val(2,4))
+  call o%make()
+
+  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
+

Re: [Patch, fortran, pr65548, addendum] [5/6 Regression] gfc_conv_procedure_call

[Andre Vehreschild]

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

Hi all,

unfortunately introduced the latest optimization for this patch an ICE in
pFUnit again. The issue occurs when the -fbounds-check is used while
allocating an array of non-polymorphic or intrinsic type. It is caused by the
location of the gfc_expr of e3rhs not set which is needed to generate the
runtime error messages of the bounds check. 

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

Because this patch is obvious I plan to commit it tomorrow if no one objects?!

Regards,
	Andre

On Wed, 20 May 2015 16:58:19 +0200
Andre Vehreschild <vehre@gmx.de> wrote:

> Hi all,
> 
> Mikael, thanks for the review. Committed as r223445 (without the else-branch).
> 
> Regards,
> 	Andre


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

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

gcc/fortran/ChangeLog:

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

	* trans-stmt.c (gfc_trans_allocate): Add missing location
	information for e3rhs.

gcc/testsuite/ChangeLog:

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

	* gfortran.dg/allocate_with_source_5.f90: Add switch to test
	for correctly set location information.


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

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 2c0304b..81943b0 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5362,6 +5362,7 @@ gfc_trans_allocate (gfc_code * code)
 		 bug.  */
 	      newsym->n.sym->attr.referenced = 1;
 	      e3rhs->expr_type = EXPR_VARIABLE;
+	      e3rhs->where = code->expr3->where;
 	      /* Set the symbols type, upto it was BT_UNKNOWN.  */
 	      newsym->n.sym->ts = e3rhs->ts;
 	      /* Check whether the expr3 is array valued.  */
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90
index 500f0f0..06dfcad 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_5.f90
@@ -1,4 +1,5 @@
 ! { dg-do run }
+! { dg-options "-fbounds-check" }
 !
 ! Contributed by Juergen Reuter
 ! Check that pr65548 is fixed.
@@ -146,7 +147,7 @@ program test
   if (any(abs(phs%m_in - [42.0, 42.0]) > 1E-6)) call abort()
 
   o%n = 2
-  allocate (o%val(2,4))
+  allocate (o%val(0:1,4))
   call o%make()
 
   o2%n = 3

Re: [Patch, fortran, pr65548, addendum] [5/6 Regression] gfc_conv_procedure_call

[Thomas Koenig]

Hi Andre,

> Because this patch is obvious I plan to commit it tomorrow if no one objects?!

The patch itself is obviously OK.

About the test case:  In general, it is better not to change existing
test cases unless absolutely necessary (e.g. adjust an error message).
This makes it easier to track regressions.

I would prefer if you made a new test case from your existing one,
with the changes you did and a small explanation of what was
tested in the comments.

If you are worried about runtime for an additonal test, you can use the

! { dg-do  run }

hack (notice the two spaces between the dg-do and the run) to have the
test case execute only once.

OK with that change.

Regards

	Thomas

Re: [Patch, fortran, pr65548, addendum] [5/6 Regression] gfc_conv_procedure_call

[Andre Vehreschild]

Hi Thomas,

thanks for the review. Commited as r223738 with the changes (new testcase,
double space in dg-do).

Regards,
	Andre

On Wed, 27 May 2015 08:38:07 +0200
Thomas Koenig <tkoenig@netcologne.de> wrote:

> Hi Andre,
> 
> > Because this patch is obvious I plan to commit it tomorrow if no one
> > objects?!
> 
> The patch itself is obviously OK.
> 
> About the test case:  In general, it is better not to change existing
> test cases unless absolutely necessary (e.g. adjust an error message).
> This makes it easier to track regressions.
> 
> I would prefer if you made a new test case from your existing one,
> with the changes you did and a small explanation of what was
> tested in the comments.
> 
> If you are worried about runtime for an additonal test, you can use the
> 
> ! { dg-do  run }
> 
> hack (notice the two spaces between the dg-do and the run) to have the
> test case execute only once.
> 
> OK with that change.
> 
> Regards
> 
> 	Thomas
> 


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