Re: [Patch, Fortran, 66927, v2] [6 Regression] ICE in gfc_conf_procedure_call

Re: [Patch, Fortran, 66927, v2] [6 Regression] ICE in gfc_conf_procedure_call

[Paul Richard Thomas]

Dear Andre,

As far as I can see, the problems with PR57117 are specific to RESHAPE
and need not affect committing your patch. To my surprise, the
combination of your patch and mine for PR67171 fixes PR67044 in that
the ICE no longer occurs. I have to get my head around how to write a
testcase for it that tests the functionality though!

You can commit this patch to trunk. As I said elsewhere, I will rename
the testcase for PR67171.

Many thanks for the patch.

Paul

On 23 October 2015 at 09:44, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> Dear Andre,
>
> I will wait until you fix the problems that Dominique has pointed out.
> However, if by Sunday afternoon (rain forecast!) you haven't found the
> time, I will see if I can locate the source of these new problems.
>
> With best regards
>
> Paul
>
> On 7 October 2015 at 19:51, Dominique d'Humières <dominiq@lps.ens.fr> wrote:
>> This patch also fixes pr57117 comment 2, the original test and the test in comment 3 now give an ICE
>>
>> pr57117.f90:82:0:
>>
>>    allocate(z(9), source=reshape(x, (/ 9 /)))
>> 1
>> internal compiler error: Segmentation fault: 11
>>
>> and pr67044.
>>
>> Thanks,
>>
>> Dominique
>>
>
>
>
> --
> Outside of a dog, a book is a man's best friend. Inside of a dog it's
> too dark to read.
>
> Groucho Marx



-- 
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.

Groucho Marx

Re: [Patch, Fortran, 66927, v2] [6 Regression] ICE in gfc_conf_procedure_call

[Andre Vehreschild]

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

Hi Paul, hi all,

thanks for the review. Submitted as r229294.

Regards,
	Andre

On Sun, 25 Oct 2015 08:43:24 +0100
Paul Richard Thomas <paul.richard.thomas@gmail.com> wrote:

> Dear Andre,
> 
> As far as I can see, the problems with PR57117 are specific to RESHAPE
> and need not affect committing your patch. To my surprise, the
> combination of your patch and mine for PR67171 fixes PR67044 in that
> the ICE no longer occurs. I have to get my head around how to write a
> testcase for it that tests the functionality though!
> 
> You can commit this patch to trunk. As I said elsewhere, I will rename
> the testcase for PR67171.
> 
> Many thanks for the patch.
> 
> Paul
> 
> On 23 October 2015 at 09:44, Paul Richard Thomas
> <paul.richard.thomas@gmail.com> wrote:
> > Dear Andre,
> >
> > I will wait until you fix the problems that Dominique has pointed out.
> > However, if by Sunday afternoon (rain forecast!) you haven't found the
> > time, I will see if I can locate the source of these new problems.
> >
> > With best regards
> >
> > Paul
> >
> > On 7 October 2015 at 19:51, Dominique d'Humières <dominiq@lps.ens.fr> wrote:
> >> This patch also fixes pr57117 comment 2, the original test and the test in comment 3 now give an ICE
> >>
> >> pr57117.f90:82:0:
> >>
> >>    allocate(z(9), source=reshape(x, (/ 9 /)))
> >> 1
> >> internal compiler error: Segmentation fault: 11
> >>
> >> and pr67044.
> >>
> >> Thanks,
> >>
> >> Dominique
> >>
> >
> >
> >
> > --
> > Outside of a dog, a book is a man's best friend. Inside of a dog it's
> > too dark to read.
> >
> > Groucho Marx
> 
> 
> 


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

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

Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h	(Revision 229293)
+++ gcc/fortran/trans.h	(Arbeitskopie)
@@ -378,7 +378,7 @@
 void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
 void gfc_reset_len (stmtblock_t *, gfc_expr *);
 tree gfc_get_vptr_from_expr (tree);
-tree gfc_get_class_array_ref (tree, tree);
+tree gfc_get_class_array_ref (tree, tree, tree);
 tree gfc_copy_class_to_class (tree, tree, tree, bool);
 bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
 bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c	(Revision 229293)
+++ gcc/fortran/trans-array.c	(Arbeitskopie)
@@ -3250,7 +3250,7 @@
     {
       type = gfc_get_element_type (type);
       tmp = TREE_OPERAND (cdecl, 0);
-      tmp = gfc_get_class_array_ref (offset, tmp);
+      tmp = gfc_get_class_array_ref (offset, tmp, NULL_TREE);
       tmp = fold_convert (build_pointer_type (type), tmp);
       tmp = build_fold_indirect_ref_loc (input_location, tmp);
       return tmp;
@@ -7107,9 +7107,20 @@
 	    }
 	  else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)) || se->use_offset)
 	    {
+	      bool toonebased;
 	      tmp = gfc_conv_array_lbound (desc, n);
+	      toonebased = integer_onep (tmp);
+	      // lb(arr) - from (- start + 1)
 	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
 				     TREE_TYPE (base), tmp, from);
+	      if (onebased && toonebased)
+		{
+		  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+					 TREE_TYPE (base), tmp, start);
+		  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+					 TREE_TYPE (base), tmp,
+					 gfc_index_one_node);
+		}
 	      tmp = fold_build2_loc (input_location, MULT_EXPR,
 				     TREE_TYPE (base), tmp,
 				     gfc_conv_array_stride (desc, n));
@@ -7183,12 +7194,13 @@
   /* For class arrays add the class tree into the saved descriptor to
      enable getting of _vptr and the like.  */
   if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
-      && IS_CLASS_ARRAY (expr->symtree->n.sym)
-      && DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl))
+      && IS_CLASS_ARRAY (expr->symtree->n.sym))
     {
       gfc_allocate_lang_decl (desc);
       GFC_DECL_SAVED_DESCRIPTOR (desc) =
-	  GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl);
+	  DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ?
+	    GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
+	  : expr->symtree->n.sym->backend_decl;
     }
   if (!se->direct_byref || se->byref_noassign)
     {
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(Revision 229293)
+++ gcc/fortran/trans-expr.c	(Arbeitskopie)
@@ -1039,9 +1039,10 @@
    of the referenced element.  */
 
 tree
-gfc_get_class_array_ref (tree index, tree class_decl)
+gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp)
 {
-  tree data = gfc_class_data_get (class_decl);
+  tree data = data_comp != NULL_TREE ? data_comp :
+				       gfc_class_data_get (class_decl);
   tree size = gfc_class_vtab_size_get (class_decl);
   tree offset = fold_build2_loc (input_location, MULT_EXPR,
 				 gfc_array_index_type,
@@ -1075,6 +1076,7 @@
   tree stdcopy;
   tree extcopy;
   tree index;
+  bool is_from_desc = false, is_to_class = false;
 
   args = NULL;
   /* To prevent warnings on uninitialized variables.  */
@@ -1088,7 +1090,19 @@
   fcn_type = TREE_TYPE (TREE_TYPE (fcn));
 
   if (from != NULL_TREE)
-    from_data = gfc_class_data_get (from);
+    {
+      is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
+      if (is_from_desc)
+	{
+	  from_data = from;
+	  from = GFC_DECL_SAVED_DESCRIPTOR (from);
+	}
+      else
+	{
+	  from_data = gfc_class_data_get (from);
+	  is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
+	}
+     }
   else
     from_data = gfc_class_vtab_def_init_get (to);
 
@@ -1100,9 +1114,16 @@
 	from_len = integer_zero_node;
     }
 
-  to_data = gfc_class_data_get (to);
-  if (unlimited)
-    to_len = gfc_class_len_get (to);
+  if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
+    {
+      is_to_class = true;
+      to_data = gfc_class_data_get (to);
+      if (unlimited)
+	to_len = gfc_class_len_get (to);
+    }
+  else
+    /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to.  */
+    to_data = to;
 
   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
     {
@@ -1118,15 +1139,23 @@
       nelems = gfc_evaluate_now (tmp, &body);
       index = gfc_create_var (gfc_array_index_type, "S");
 
-      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)))
+      if (is_from_desc)
 	{
-	  from_ref = gfc_get_class_array_ref (index, from);
+	  from_ref = gfc_get_class_array_ref (index, from, from_data);
 	  vec_safe_push (args, from_ref);
 	}
       else
         vec_safe_push (args, from_data);
 
-      to_ref = gfc_get_class_array_ref (index, to);
+      if (is_to_class)
+	to_ref = gfc_get_class_array_ref (index, to, to_data);
+      else
+	{
+	  tmp = gfc_conv_array_data (to);
+	  tmp = build_fold_indirect_ref_loc (input_location, tmp);
+	  to_ref = gfc_build_addr_expr (NULL_TREE,
+					gfc_build_array_ref (tmp, index, to));
+	}
       vec_safe_push (args, to_ref);
 
       tmp = build_call_vec (fcn_type, fcn, args);
@@ -1183,7 +1212,7 @@
     }
   else
     {
-      gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)));
+      gcc_assert (!is_from_desc);
       vec_safe_push (args, from_data);
       vec_safe_push (args, to_data);
       stdcopy = build_call_vec (fcn_type, fcn, args);
Index: gcc/fortran/ChangeLog
===================================================================
--- gcc/fortran/ChangeLog	(Revision 229293)
+++ gcc/fortran/ChangeLog	(Arbeitskopie)
@@ -1,3 +1,20 @@
+2015-10-25  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+	PR fortran/66927
+	PR fortran/67044	
+	* trans-array.c (build_array_ref): Modified call to 
+	gfc_get_class_array_ref to adhere to new interface.
+	(gfc_conv_expr_descriptor): For one-based arrays that
+	are filled by a loop starting at one the start index of the
+	source array has to be mangled into the offset.
+	* trans-expr.c (gfc_get_class_array_ref): When the tree to get
+	the _data component is present already, add a way to supply it.
+	(gfc_copy_class_to_class): Allow to copy to a derived type also.
+	* trans-stmt.c (gfc_trans_allocate): Do not conv_expr_descriptor
+	for functions returning	a class or derived object. Get the
+	reference instead.
+	* trans.h: Interface change of gfc_get_class_array_ref.
+
 2015-10-24  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/68055
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c	(Revision 229293)
+++ gcc/fortran/trans-stmt.c	(Arbeitskopie)
@@ -5186,9 +5186,16 @@
 	  /* In all other cases evaluate the expr3.  */
 	  symbol_attribute attr;
 	  /* Get the descriptor for all arrays, that are not allocatable or
-	     pointer, because the latter are descriptors already.  */
+	     pointer, because the latter are descriptors already.
+	     The exception are function calls returning a class object:
+	     The descriptor is stored in their results _data component, which
+	     is easier to access, when first a temporary variable for the
+	     result is created and the descriptor retrieved from there.  */
 	  attr = gfc_expr_attr (code->expr3);
-	  if (code->expr3->rank != 0 && !attr.allocatable && !attr.pointer)
+	  if (code->expr3->rank != 0
+	      && ((!attr.allocatable && !attr.pointer)
+		  || (code->expr3->expr_type == EXPR_FUNCTION
+		      && code->expr3->ts.type != BT_CLASS)))
 	    gfc_conv_expr_descriptor (&se, code->expr3);
 	  else
 	    gfc_conv_expr_reference (&se, code->expr3);
@@ -5205,17 +5212,40 @@
 	     variable declaration.  */
       if (se.expr != NULL_TREE && temp_var_needed)
 	{
-	  tree var;
+	  tree var, desc;
 	  tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) ?
 		se.expr
 	      : build_fold_indirect_ref_loc (input_location, se.expr);
+
+	  /* Get the array descriptor and prepare it to be assigned to the
+	     temporary variable var.  For classes the array descriptor is
+	     in the _data component and the object goes into the
+	     GFC_DECL_SAVED_DESCRIPTOR.  */
+	  if (code->expr3->ts.type == BT_CLASS
+	      && code->expr3->rank != 0)
+	    {
+	      /* When an array_ref was in expr3, then the descriptor is the
+		 first operand.  */
+	      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+		{
+		  desc = TREE_OPERAND (tmp, 0);
+		}
+	      else
+		{
+		  desc = tmp;
+		  tmp = gfc_class_data_get (tmp);
+		}
+	      e3_is = E3_DESC;
+	    }
+	  else
+	    desc = se.expr;
 	  /* We need a regular (non-UID) symbol here, therefore give a
 	     prefix.  */
 	  var = gfc_create_var (TREE_TYPE (tmp), "source");
-	  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
+	  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
 	    {
 	      gfc_allocate_lang_decl (var);
-	      GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr;
+	      GFC_DECL_SAVED_DESCRIPTOR (var) = desc;
 	    }
 	  gfc_add_modify_loc (input_location, &block, var, tmp);
 
@@ -5241,11 +5271,12 @@
 	  expr3_len = se.string_length;
 	}
       /* Store what the expr3 is to be used for.  */
-      e3_is = expr3 != NULL_TREE ?
-	    (code->ext.alloc.arr_spec_from_expr3 ?
-	       E3_DESC
-	     : (code->expr3->mold ? E3_MOLD : E3_SOURCE))
-	  : E3_UNSET;
+      if (e3_is == E3_UNSET)
+	e3_is = expr3 != NULL_TREE ?
+	      (code->ext.alloc.arr_spec_from_expr3 ?
+		 E3_DESC
+	       : (code->expr3->mold ? E3_MOLD : E3_SOURCE))
+	    : E3_UNSET;
 
       /* Figure how to get the _vtab entry.  This also obtains the tree
 	 expression for accessing the _len component, because only
@@ -5254,11 +5285,17 @@
       if (code->expr3->ts.type == BT_CLASS)
 	{
 	  gfc_expr *rhs;
+	  tmp = expr3 != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (expr3)) ?
+		build_fold_indirect_ref (expr3): expr3;
 	  /* 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))
+	  if (tmp != NULL_TREE
+	      && TREE_CODE (tmp) != POINTER_PLUS_EXPR
+	      && (e3_is == E3_DESC
+		  || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
+		      && (VAR_P (tmp) || !code->expr3->ref))
+		  || (VAR_P (tmp) && DECL_LANG_SPECIFIC (tmp))))
 	    tmp = gfc_class_vptr_get (expr3);
 	  else
 	    {
@@ -5709,10 +5746,7 @@
 	  /* 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) && GFC_CLASS_TYPE_P (
-			TREE_TYPE (expr3))))
+	      && TREE_CODE (expr3) != POINTER_PLUS_EXPR
 	      && code->expr3->ts.type == BT_CLASS
 	      && (expr->ts.type == BT_CLASS
 		  || expr->ts.type == BT_DERIVED))
@@ -5731,7 +5765,7 @@
 	      gfc_expr *ppc;
 	      gfc_code *ppc_code;
 	      gfc_ref *ref, *dataref;
-	      gfc_expr *rhs = gfc_copy_expr (code->expr3);
+	      gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
 
 	      /* Do a polymorphic deep copy.  */
 	      actual = gfc_get_actual_arglist ();
@@ -5827,7 +5861,8 @@
 					 void_type_node, tmp, extcopy, stdcopy);
 		}
 	      gfc_free_statements (ppc_code);
-	      gfc_free_expr (rhs);
+	      if (rhs != e3rhs)
+		gfc_free_expr (rhs);
 	    }
 	  else
 	    {
Index: gcc/testsuite/gfortran.dg/class_array_15.f03
===================================================================
--- gcc/testsuite/gfortran.dg/class_array_15.f03	(Revision 229293)
+++ gcc/testsuite/gfortran.dg/class_array_15.f03	(Arbeitskopie)
@@ -115,4 +115,4 @@
   bh => bhGet(b,instance=2)
   if (loc (b) .ne. loc(bh%hostNode)) call abort
 end
-! { dg-final { scan-tree-dump-times "builtin_free" 12 "original" } }
+! { dg-final { scan-tree-dump-times "builtin_free" 11 "original" } }
Index: gcc/testsuite/ChangeLog
===================================================================
--- gcc/testsuite/ChangeLog	(Revision 229293)
+++ gcc/testsuite/ChangeLog	(Arbeitskopie)
@@ -1,3 +1,13 @@
+2015-10-25  Andre Vehreschild  <vehre@gmx.de>
+
+        PR fortran/66927
+        PR fortran/67044
+	* gfortran.dg/allocate_with_source_10.f08: New test.
+	* gfortran.dg/allocate_with_source_11.f08: New test.
+	* gfortran.dg/class_array_15.f03: Changed count of expected
+	_builtin_frees to 11. One step of temporaries is spared, therefore
+	the allocatable component of that temporary is not to be freeed.
+
 2015-10-24  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/68055

Re: [Patch, Fortran, 66927, v2.1] [6 Regression] ICE in gfc_conf_procedure_call

[Andre Vehreschild]

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

Hi all,

unfortunately did my last patch create a segfault on some 32-bit
system. This happens because in the scalarizer the lower bound of the
deferred length array of the source= expression was taken to be
constant zero instead of taking that information from the array
descriptor. This patch fixes the segfault by taking the lower -- and to
keep it in sync also the upper -- bound from the array descriptor when
doing the array assign in the allocate (). 

Bootstrapped and regtested on x86_64-linux-gnu/f21.

Ok for trunk?

Sorry for the regression.

Regards,
	Andre

On Sun, 25 Oct 2015 13:31:02 +0100
Andre Vehreschild <vehre@gmx.de> wrote:

> Hi Paul, hi all,
> 
> thanks for the review. Submitted as r229294.
> 
> Regards,
> 	Andre
> 
> On Sun, 25 Oct 2015 08:43:24 +0100
> Paul Richard Thomas <paul.richard.thomas@gmail.com> wrote:
> 
> > Dear Andre,
> > 
> > As far as I can see, the problems with PR57117 are specific to RESHAPE
> > and need not affect committing your patch. To my surprise, the
> > combination of your patch and mine for PR67171 fixes PR67044 in that
> > the ICE no longer occurs. I have to get my head around how to write a
> > testcase for it that tests the functionality though!
> > 
> > You can commit this patch to trunk. As I said elsewhere, I will rename
> > the testcase for PR67171.
> > 
> > Many thanks for the patch.
> > 
> > Paul
> > 
> > On 23 October 2015 at 09:44, Paul Richard Thomas
> > <paul.richard.thomas@gmail.com> wrote:
> > > Dear Andre,
> > >
> > > I will wait until you fix the problems that Dominique has pointed out.
> > > However, if by Sunday afternoon (rain forecast!) you haven't found the
> > > time, I will see if I can locate the source of these new problems.
> > >
> > > With best regards
> > >
> > > Paul
> > >
> > > On 7 October 2015 at 19:51, Dominique d'Humières <dominiq@lps.ens.fr> wrote:
> > >> This patch also fixes pr57117 comment 2, the original test and the test in comment 3 now give an ICE
> > >>
> > >> pr57117.f90:82:0:
> > >>
> > >>    allocate(z(9), source=reshape(x, (/ 9 /)))
> > >> 1
> > >> internal compiler error: Segmentation fault: 11
> > >>
> > >> and pr67044.
> > >>
> > >> Thanks,
> > >>
> > >> Dominique
> > >>
> > >
> > >
> > >
> > > --
> > > Outside of a dog, a book is a man's best friend. Inside of a dog it's
> > > too dark to read.
> > >
> > > Groucho Marx
> > 
> > 
> > 
> 
> 


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

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

gcc/fortran/ChangeLog:

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

	* trans-array.c (evaluate_bound): For deferred length arrays get the
	bounds directly from the descriptor, i.e., prevent using constant
	zero lower bound from the gfc_conv_array_lbound () routine.
	(gfc_conv_section_startstride): Hand deferred array status to
	evaluate_bound ().
	(gfc_conv_expr_descriptor): Same.



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

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index b726998..f6e980d 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -3809,7 +3809,7 @@ gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
 
 static void
 evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
-		tree desc, int dim, bool lbound)
+		tree desc, int dim, bool lbound, bool deferred)
 {
   gfc_se se;
   gfc_expr * input_val = values[dim];
@@ -3824,6 +3824,17 @@ evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
       gfc_add_block_to_block (block, &se.pre);
       *output = se.expr;
     }
+  else if (deferred)
+    {
+      /* The gfc_conv_array_lbound () routine returns a constant zero for
+	 deferred length arrays, which in the scalarizer wrecks havoc, when
+	 copying to a (newly allocated) one-based array.
+	 Keep returning the actual result in sync for both bounds.  */
+      *output = lbound ? gfc_conv_descriptor_lbound_get (desc,
+							 gfc_rank_cst[dim]):
+			 gfc_conv_descriptor_ubound_get (desc,
+							 gfc_rank_cst[dim]);
+    }
   else
     {
       /* No specific bound specified so use the bound of the array.  */
@@ -3864,14 +3875,18 @@ gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
   desc = info->descriptor;
   stride = ar->stride[dim];
 
+
   /* Calculate the start of the range.  For vector subscripts this will
      be the range of the vector.  */
-  evaluate_bound (block, info->start, ar->start, desc, dim, true);
+  evaluate_bound (block, info->start, ar->start, desc, dim, true,
+		  ar->as->type == AS_DEFERRED);
 
   /* Similarly calculate the end.  Although this is not used in the
      scalarizer, it is needed when checking bounds and where the end
      is an expression with side-effects.  */
-  evaluate_bound (block, info->end, ar->end, desc, dim, false);
+  evaluate_bound (block, info->end, ar->end, desc, dim, false,
+		  ar->as->type == AS_DEFERRED);
+
 
   /* Calculate the stride.  */
   if (stride == NULL)
@@ -6965,7 +6980,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 
 	  gcc_assert (n == codim - 1);
 	  evaluate_bound (&loop.pre, info->start, ar->start,
-			  info->descriptor, n + ndim, true);
+			  info->descriptor, n + ndim, true,
+			  ar->as->type == AS_DEFERRED);
 	  loop.from[n + loop.dimen] = info->start[n + ndim];
 	}
       else

Re: [Patch, Fortran, 66927, v2.1] [6 Regression] ICE in gfc_conf_procedure_call

[Paul Richard Thomas]

Hi Andre,

Yes, that's good to fix the problem. OK to commit

Thanks for the rapid fix.

Paul

On 26 October 2015 at 11:03, Andre Vehreschild <vehre@gmx.de> wrote:
> Hi all,
>
> unfortunately did my last patch create a segfault on some 32-bit
> system. This happens because in the scalarizer the lower bound of the
> deferred length array of the source= expression was taken to be
> constant zero instead of taking that information from the array
> descriptor. This patch fixes the segfault by taking the lower -- and to
> keep it in sync also the upper -- bound from the array descriptor when
> doing the array assign in the allocate ().
>
> Bootstrapped and regtested on x86_64-linux-gnu/f21.
>
> Ok for trunk?
>
> Sorry for the regression.
>
> Regards,
>         Andre
>
> On Sun, 25 Oct 2015 13:31:02 +0100
> Andre Vehreschild <vehre@gmx.de> wrote:
>
>> Hi Paul, hi all,
>>
>> thanks for the review. Submitted as r229294.
>>
>> Regards,
>>       Andre
>>
>> On Sun, 25 Oct 2015 08:43:24 +0100
>> Paul Richard Thomas <paul.richard.thomas@gmail.com> wrote:
>>
>> > Dear Andre,
>> >
>> > As far as I can see, the problems with PR57117 are specific to RESHAPE
>> > and need not affect committing your patch. To my surprise, the
>> > combination of your patch and mine for PR67171 fixes PR67044 in that
>> > the ICE no longer occurs. I have to get my head around how to write a
>> > testcase for it that tests the functionality though!
>> >
>> > You can commit this patch to trunk. As I said elsewhere, I will rename
>> > the testcase for PR67171.
>> >
>> > Many thanks for the patch.
>> >
>> > Paul
>> >
>> > On 23 October 2015 at 09:44, Paul Richard Thomas
>> > <paul.richard.thomas@gmail.com> wrote:
>> > > Dear Andre,
>> > >
>> > > I will wait until you fix the problems that Dominique has pointed out.
>> > > However, if by Sunday afternoon (rain forecast!) you haven't found the
>> > > time, I will see if I can locate the source of these new problems.
>> > >
>> > > With best regards
>> > >
>> > > Paul
>> > >
>> > > On 7 October 2015 at 19:51, Dominique d'Humières <dominiq@lps.ens.fr> wrote:
>> > >> This patch also fixes pr57117 comment 2, the original test and the test in comment 3 now give an ICE
>> > >>
>> > >> pr57117.f90:82:0:
>> > >>
>> > >>    allocate(z(9), source=reshape(x, (/ 9 /)))
>> > >> 1
>> > >> internal compiler error: Segmentation fault: 11
>> > >>
>> > >> and pr67044.
>> > >>
>> > >> Thanks,
>> > >>
>> > >> Dominique
>> > >>
>> > >
>> > >
>> > >
>> > > --
>> > > Outside of a dog, a book is a man's best friend. Inside of a dog it's
>> > > too dark to read.
>> > >
>> > > Groucho Marx
>> >
>> >
>> >
>>
>>
>
>
> --
> Andre Vehreschild * Email: vehre ad gmx dot de



-- 
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.

Groucho Marx

Re: [Patch, Fortran, 66927, v2.1] [6 Regression] ICE in gfc_conf_procedure_call

[Andre Vehreschild]

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

Hi Paul,

thanks for the quick review. Submitted as r229353.

Many thanks and regards,
	Andre

On Mon, 26 Oct 2015 13:04:27 +0100
Paul Richard Thomas <paul.richard.thomas@gmail.com> wrote:

> Hi Andre,
> 
> Yes, that's good to fix the problem. OK to commit
> 
> Thanks for the rapid fix.
> 
> Paul
> 
> On 26 October 2015 at 11:03, Andre Vehreschild <vehre@gmx.de> wrote:
> > Hi all,
> >
> > unfortunately did my last patch create a segfault on some 32-bit
> > system. This happens because in the scalarizer the lower bound of the
> > deferred length array of the source= expression was taken to be
> > constant zero instead of taking that information from the array
> > descriptor. This patch fixes the segfault by taking the lower -- and to
> > keep it in sync also the upper -- bound from the array descriptor when
> > doing the array assign in the allocate ().
> >
> > Bootstrapped and regtested on x86_64-linux-gnu/f21.
> >
> > Ok for trunk?
> >
> > Sorry for the regression.
> >
> > Regards,
> >         Andre
> >
> > On Sun, 25 Oct 2015 13:31:02 +0100
> > Andre Vehreschild <vehre@gmx.de> wrote:
> >
> >> Hi Paul, hi all,
> >>
> >> thanks for the review. Submitted as r229294.
> >>
> >> Regards,
> >>       Andre
> >>
> >> On Sun, 25 Oct 2015 08:43:24 +0100
> >> Paul Richard Thomas <paul.richard.thomas@gmail.com> wrote:
> >>
> >> > Dear Andre,
> >> >
> >> > As far as I can see, the problems with PR57117 are specific to RESHAPE
> >> > and need not affect committing your patch. To my surprise, the
> >> > combination of your patch and mine for PR67171 fixes PR67044 in that
> >> > the ICE no longer occurs. I have to get my head around how to write a
> >> > testcase for it that tests the functionality though!
> >> >
> >> > You can commit this patch to trunk. As I said elsewhere, I will rename
> >> > the testcase for PR67171.
> >> >
> >> > Many thanks for the patch.
> >> >
> >> > Paul
> >> >
> >> > On 23 October 2015 at 09:44, Paul Richard Thomas
> >> > <paul.richard.thomas@gmail.com> wrote:
> >> > > Dear Andre,
> >> > >
> >> > > I will wait until you fix the problems that Dominique has pointed out.
> >> > > However, if by Sunday afternoon (rain forecast!) you haven't found the
> >> > > time, I will see if I can locate the source of these new problems.
> >> > >
> >> > > With best regards
> >> > >
> >> > > Paul
> >> > >
> >> > > On 7 October 2015 at 19:51, Dominique d'Humières <dominiq@lps.ens.fr> wrote:
> >> > >> This patch also fixes pr57117 comment 2, the original test and the test in comment 3 now give an ICE
> >> > >>
> >> > >> pr57117.f90:82:0:
> >> > >>
> >> > >>    allocate(z(9), source=reshape(x, (/ 9 /)))
> >> > >> 1
> >> > >> internal compiler error: Segmentation fault: 11
> >> > >>
> >> > >> and pr67044.
> >> > >>
> >> > >> Thanks,
> >> > >>
> >> > >> Dominique
> >> > >>
> >> > >
> >> > >
> >> > >
> >> > > --
> >> > > Outside of a dog, a book is a man's best friend. Inside of a dog it's
> >> > > too dark to read.
> >> > >
> >> > > Groucho Marx
> >> >
> >> >
> >> >
> >>
> >>
> >
> >
> > --
> > Andre Vehreschild * Email: vehre ad gmx dot de
> 
> 
> 


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

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

Index: gcc/fortran/ChangeLog
===================================================================
--- gcc/fortran/ChangeLog	(Revision 229352)
+++ gcc/fortran/ChangeLog	(Arbeitskopie)
@@ -1,3 +1,13 @@
+2015-10-26  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+	PR fortran/66927
+	* trans-array.c (evaluate_bound): For deferred length arrays get the
+	bounds directly from the descriptor, i.e., prevent using constant
+	zero lower bound from the gfc_conv_array_lbound () routine.
+	(gfc_conv_section_startstride): Hand deferred array status to
+	evaluate_bound ().
+	(gfc_conv_expr_descriptor): Same.
+
 2015-01-25  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/67171
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c	(Revision 229352)
+++ gcc/fortran/trans-array.c	(Arbeitskopie)
@@ -3809,7 +3809,7 @@
 
 static void
 evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
-		tree desc, int dim, bool lbound)
+		tree desc, int dim, bool lbound, bool deferred)
 {
   gfc_se se;
   gfc_expr * input_val = values[dim];
@@ -3824,6 +3824,17 @@
       gfc_add_block_to_block (block, &se.pre);
       *output = se.expr;
     }
+  else if (deferred)
+    {
+      /* The gfc_conv_array_lbound () routine returns a constant zero for
+	 deferred length arrays, which in the scalarizer wrecks havoc, when
+	 copying to a (newly allocated) one-based array.
+	 Keep returning the actual result in sync for both bounds.  */
+      *output = lbound ? gfc_conv_descriptor_lbound_get (desc,
+							 gfc_rank_cst[dim]):
+			 gfc_conv_descriptor_ubound_get (desc,
+							 gfc_rank_cst[dim]);
+    }
   else
     {
       /* No specific bound specified so use the bound of the array.  */
@@ -3864,15 +3875,19 @@
   desc = info->descriptor;
   stride = ar->stride[dim];
 
+
   /* Calculate the start of the range.  For vector subscripts this will
      be the range of the vector.  */
-  evaluate_bound (block, info->start, ar->start, desc, dim, true);
+  evaluate_bound (block, info->start, ar->start, desc, dim, true,
+		  ar->as->type == AS_DEFERRED);
 
   /* Similarly calculate the end.  Although this is not used in the
      scalarizer, it is needed when checking bounds and where the end
      is an expression with side-effects.  */
-  evaluate_bound (block, info->end, ar->end, desc, dim, false);
+  evaluate_bound (block, info->end, ar->end, desc, dim, false,
+		  ar->as->type == AS_DEFERRED);
 
+
   /* Calculate the stride.  */
   if (stride == NULL)
     info->stride[dim] = gfc_index_one_node;
@@ -6965,7 +6980,8 @@
 
 	  gcc_assert (n == codim - 1);
 	  evaluate_bound (&loop.pre, info->start, ar->start,
-			  info->descriptor, n + ndim, true);
+			  info->descriptor, n + ndim, true,
+			  ar->as->type == AS_DEFERRED);
 	  loop.from[n + loop.dimen] = info->start[n + ndim];
 	}
       else

Re: [Patch, Fortran, 66927, v2] [6 Regression] ICE in gfc_conf_procedure_call

[Andre Vehreschild]

Hi Paul,

don't wait until Sunday. I will not have the time anytime soon to stick
my head into gfortran. Feel free to start anytime.

- Andre

On Fri, 23 Oct 2015 09:44:56 +0200
Paul Richard Thomas <paul.richard.thomas@gmail.com> wrote:

> Dear Andre,
> 
> I will wait until you fix the problems that Dominique has pointed out.
> However, if by Sunday afternoon (rain forecast!) you haven't found the
> time, I will see if I can locate the source of these new problems.
> 
> With best regards
> 
> Paul
> 
> On 7 October 2015 at 19:51, Dominique d'Humières <dominiq@lps.ens.fr> wrote:
> > This patch also fixes pr57117 comment 2, the original test and the test in comment 3 now give an ICE
> >
> > pr57117.f90:82:0:
> >
> >    allocate(z(9), source=reshape(x, (/ 9 /)))
> > 1
> > internal compiler error: Segmentation fault: 11
> >
> > and pr67044.
> >
> > Thanks,
> >
> > Dominique
> >
> 
> 
> 


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

Re: [Patch, Fortran, 66927, v2] [6 Regression] ICE in gfc_conf_procedure_call

[Paul Richard Thomas]

Dear Andre,

I will wait until you fix the problems that Dominique has pointed out.
However, if by Sunday afternoon (rain forecast!) you haven't found the
time, I will see if I can locate the source of these new problems.

With best regards

Paul

On 7 October 2015 at 19:51, Dominique d'Humières <dominiq@lps.ens.fr> wrote:
> This patch also fixes pr57117 comment 2, the original test and the test in comment 3 now give an ICE
>
> pr57117.f90:82:0:
>
>    allocate(z(9), source=reshape(x, (/ 9 /)))
> 1
> internal compiler error: Segmentation fault: 11
>
> and pr67044.
>
> Thanks,
>
> Dominique
>



-- 
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.

Groucho Marx

Re: [Patch, Fortran, 66927, v2] [6 Regression] ICE in gfc_conf_procedure_call

[Dominique d'Humières]

This patch also fixes pr57117 comment 2, the original test and the test in comment 3 now give an ICE

pr57117.f90:82:0:

   allocate(z(9), source=reshape(x, (/ 9 /)))
1
internal compiler error: Segmentation fault: 11

and pr67044.

Thanks,

Dominique

Re: [Patch, Fortran, 66927, v2] [6 Regression] ICE in gfc_conf_procedure_call

[Andre Vehreschild]

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

Hi Mikael, hi all,

sorry for the late reply, but I was a bit busy lately and the patch was
not as easy as expected. 

Mikael, I addressed your question about clarifying the comment and while
doing so the question arose "what happens when the function returns a
class object?" You have one guess; correct: ICE! This extended patch
now addresses the ICE and furthermore more consequently makes use of
the temporary created for the source= expression. I.e., when the
temporary is a class-object, it's vtab is more often retrieved from the
temporary and no longer generated from the gfc_expr's typespec. 

To efficiently copy - in the class/derived cases - the data, I had to
drill open the gfc_copy_class_to_class() routine a little bit, in that
it accepts the destination object to be a BT_DERIVED, too. 

I provide two testcases now and had to fix class_array_15, which was
expecting one too many calls to __builtin_free. With this patch the
creation of an unnecessary temporary object is prevented, which in the
consequence leads to one less calls to __builtin_free to free the
allocatable component of the temporary object.

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

Ok, for trunk?

Regards,
	Andre

On Sun, 9 Aug 2015 14:37:03 +0200
Mikael Morin <mikael.morin@sfr.fr> wrote:

> Le 06/08/2015 14:00, Mikael Morin a écrit :
> > Let me have a look at it.
> >
> So, I've had a look at it.
> This is a pandora box that I don't want to open.
> So your change is OK.
> However, could you clarify the comment?
> Function calls returning a class object are either pointer or 
> allocatable, so they don't call gfc_conv_expr_descriptor already, they 
> aren't an exception...
> 
> Mikael


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

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

gcc/fortran/ChangeLog:

2015-09-29  Andre Vehreschild  <vehre@gcc.gnu.org>

	* trans-array.c (build_array_ref): Modified call to 
	gfc_get_class_array_ref to adhere to new interface.
	(gfc_conv_expr_descriptor): For one-based arrays that
	are filled by a loop starting at one the start index of the
	source array has to be mangled into the offset.
	* trans-expr.c (gfc_get_class_array_ref): When the tree to get
	the _data component is present already, add a way to supply it.
	(gfc_copy_class_to_class): Allow to copy to a derived type also.
	* trans-stmt.c (gfc_trans_allocate): Do not conv_expr_descriptor
	for functions returning	a class or derived object. Get the
	reference instead.
	* trans.h: Interface change of gfc_get_class_array_ref.

gcc/testsuite/ChangeLog:

2015-09-29  Andre Vehreschild  <vehre@gmx.de>

	* gfortran.dg/allocate_with_source_10.f08: New test.
	* gfortran.dg/allocate_with_source_11.f08: New test.
	* gfortran.dg/class_array_15.f03: Changed count of expected
	_builtin_frees to 11. One step of temporaries is spared, therefore
	the allocatable component of that temporary is not to be freeed.


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

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index a6b761b..504b08a 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -3222,7 +3222,7 @@ build_array_ref (tree desc, tree offset, tree decl, tree vptr)
     {
       type = gfc_get_element_type (type);
       tmp = TREE_OPERAND (cdecl, 0);
-      tmp = gfc_get_class_array_ref (offset, tmp);
+      tmp = gfc_get_class_array_ref (offset, tmp, NULL_TREE);
       tmp = fold_convert (build_pointer_type (type), tmp);
       tmp = build_fold_indirect_ref_loc (input_location, tmp);
       return tmp;
@@ -7079,9 +7079,20 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 	    }
 	  else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)) || se->use_offset)
 	    {
+	      bool toonebased;
 	      tmp = gfc_conv_array_lbound (desc, n);
+	      toonebased = integer_onep (tmp);
+	      // lb(arr) - from (- start + 1)
 	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
 				     TREE_TYPE (base), tmp, from);
+	      if (onebased && toonebased)
+		{
+		  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+					 TREE_TYPE (base), tmp, start);
+		  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+					 TREE_TYPE (base), tmp,
+					 gfc_index_one_node);
+		}
 	      tmp = fold_build2_loc (input_location, MULT_EXPR,
 				     TREE_TYPE (base), tmp,
 				     gfc_conv_array_stride (desc, n));
@@ -7155,12 +7166,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
   /* For class arrays add the class tree into the saved descriptor to
      enable getting of _vptr and the like.  */
   if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
-      && IS_CLASS_ARRAY (expr->symtree->n.sym)
-      && DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl))
+      && IS_CLASS_ARRAY (expr->symtree->n.sym))
     {
       gfc_allocate_lang_decl (desc);
       GFC_DECL_SAVED_DESCRIPTOR (desc) =
-	  GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl);
+	  DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ?
+	    GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
+	  : expr->symtree->n.sym->backend_decl;
     }
   if (!se->direct_byref || se->byref_noassign)
     {
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e086fe3..90b5140 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1039,9 +1039,10 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
    of the referenced element.  */
 
 tree
-gfc_get_class_array_ref (tree index, tree class_decl)
+gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp)
 {
-  tree data = gfc_class_data_get (class_decl);
+  tree data = data_comp != NULL_TREE ? data_comp :
+				       gfc_class_data_get (class_decl);
   tree size = gfc_class_vtab_size_get (class_decl);
   tree offset = fold_build2_loc (input_location, MULT_EXPR,
 				 gfc_array_index_type,
@@ -1075,6 +1076,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
   tree stdcopy;
   tree extcopy;
   tree index;
+  bool is_from_desc = false, is_to_class = false;
 
   args = NULL;
   /* To prevent warnings on uninitialized variables.  */
@@ -1088,7 +1090,19 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
   fcn_type = TREE_TYPE (TREE_TYPE (fcn));
 
   if (from != NULL_TREE)
-    from_data = gfc_class_data_get (from);
+    {
+      is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
+      if (is_from_desc)
+	{
+	  from_data = from;
+	  from = GFC_DECL_SAVED_DESCRIPTOR (from);
+	}
+      else
+	{
+	  from_data = gfc_class_data_get (from);
+	  is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
+	}
+     }
   else
     from_data = gfc_class_vtab_def_init_get (to);
 
@@ -1100,9 +1114,16 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
 	from_len = integer_zero_node;
     }
 
-  to_data = gfc_class_data_get (to);
-  if (unlimited)
-    to_len = gfc_class_len_get (to);
+  if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
+    {
+      is_to_class = true;
+      to_data = gfc_class_data_get (to);
+      if (unlimited)
+	to_len = gfc_class_len_get (to);
+    }
+  else
+    /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to.  */
+    to_data = to;
 
   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
     {
@@ -1118,15 +1139,23 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
       nelems = gfc_evaluate_now (tmp, &body);
       index = gfc_create_var (gfc_array_index_type, "S");
 
-      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)))
+      if (is_from_desc)
 	{
-	  from_ref = gfc_get_class_array_ref (index, from);
+	  from_ref = gfc_get_class_array_ref (index, from, from_data);
 	  vec_safe_push (args, from_ref);
 	}
       else
         vec_safe_push (args, from_data);
 
-      to_ref = gfc_get_class_array_ref (index, to);
+      if (is_to_class)
+	to_ref = gfc_get_class_array_ref (index, to, to_data);
+      else
+	{
+	  tmp = gfc_conv_array_data (to);
+	  tmp = build_fold_indirect_ref_loc (input_location, tmp);
+	  to_ref = gfc_build_addr_expr (NULL_TREE,
+					gfc_build_array_ref (tmp, index, to));
+	}
       vec_safe_push (args, to_ref);
 
       tmp = build_call_vec (fcn_type, fcn, args);
@@ -1183,7 +1212,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
     }
   else
     {
-      gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)));
+      gcc_assert (!is_from_desc);
       vec_safe_push (args, from_data);
       vec_safe_push (args, to_data);
       stdcopy = build_call_vec (fcn_type, fcn, args);
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index a8536fd..1bd131e 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5186,9 +5186,16 @@ gfc_trans_allocate (gfc_code * code)
 	  /* In all other cases evaluate the expr3.  */
 	  symbol_attribute attr;
 	  /* Get the descriptor for all arrays, that are not allocatable or
-	     pointer, because the latter are descriptors already.  */
+	     pointer, because the latter are descriptors already.
+	     The exception are function calls returning a class object:
+	     The descriptor is stored in their results _data component, which
+	     is easier to access, when first a temporary variable for the
+	     result is created and the descriptor retrieved from there.  */
 	  attr = gfc_expr_attr (code->expr3);
-	  if (code->expr3->rank != 0 && !attr.allocatable && !attr.pointer)
+	  if (code->expr3->rank != 0
+	      && ((!attr.allocatable && !attr.pointer)
+		  || (code->expr3->expr_type == EXPR_FUNCTION
+		      && code->expr3->ts.type != BT_CLASS)))
 	    gfc_conv_expr_descriptor (&se, code->expr3);
 	  else
 	    gfc_conv_expr_reference (&se, code->expr3);
@@ -5205,17 +5212,40 @@ gfc_trans_allocate (gfc_code * code)
 	     variable declaration.  */
       if (se.expr != NULL_TREE && temp_var_needed)
 	{
-	  tree var;
+	  tree var, desc;
 	  tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) ?
 		se.expr
 	      : build_fold_indirect_ref_loc (input_location, se.expr);
+
+	  /* Get the array descriptor and prepare it to be assigned to the
+	     temporary variable var.  For classes the array descriptor is
+	     in the _data component and the object goes into the
+	     GFC_DECL_SAVED_DESCRIPTOR.  */
+	  if (code->expr3->ts.type == BT_CLASS
+	      && code->expr3->rank != 0)
+	    {
+	      /* When an array_ref was in expr3, then the descriptor is the
+		 first operand.  */
+	      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+		{
+		  desc = TREE_OPERAND (tmp, 0);
+		}
+	      else
+		{
+		  desc = tmp;
+		  tmp = gfc_class_data_get (tmp);
+		}
+	      e3_is = E3_DESC;
+	    }
+	  else
+	    desc = se.expr;
 	  /* We need a regular (non-UID) symbol here, therefore give a
 	     prefix.  */
 	  var = gfc_create_var (TREE_TYPE (tmp), "source");
-	  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
+	  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
 	    {
 	      gfc_allocate_lang_decl (var);
-	      GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr;
+	      GFC_DECL_SAVED_DESCRIPTOR (var) = desc;
 	    }
 	  gfc_add_modify_loc (input_location, &block, var, tmp);
 
@@ -5241,11 +5271,12 @@ gfc_trans_allocate (gfc_code * code)
 	  expr3_len = se.string_length;
 	}
       /* Store what the expr3 is to be used for.  */
-      e3_is = expr3 != NULL_TREE ?
-	    (code->ext.alloc.arr_spec_from_expr3 ?
-	       E3_DESC
-	     : (code->expr3->mold ? E3_MOLD : E3_SOURCE))
-	  : E3_UNSET;
+      if (e3_is == E3_UNSET)
+	e3_is = expr3 != NULL_TREE ?
+	      (code->ext.alloc.arr_spec_from_expr3 ?
+		 E3_DESC
+	       : (code->expr3->mold ? E3_MOLD : E3_SOURCE))
+	    : E3_UNSET;
 
       /* Figure how to get the _vtab entry.  This also obtains the tree
 	 expression for accessing the _len component, because only
@@ -5254,11 +5285,17 @@ gfc_trans_allocate (gfc_code * code)
       if (code->expr3->ts.type == BT_CLASS)
 	{
 	  gfc_expr *rhs;
+	  tmp = expr3 != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (expr3)) ?
+		build_fold_indirect_ref (expr3): expr3;
 	  /* 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))
+	  if (tmp != NULL_TREE
+	      && TREE_CODE (tmp) != POINTER_PLUS_EXPR
+	      && (e3_is == E3_DESC
+		  || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
+		      && (VAR_P (tmp) || !code->expr3->ref))
+		  || (VAR_P (tmp) && DECL_LANG_SPECIFIC (tmp))))
 	    tmp = gfc_class_vptr_get (expr3);
 	  else
 	    {
@@ -5709,10 +5746,7 @@ gfc_trans_allocate (gfc_code * code)
 	  /* 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) && GFC_CLASS_TYPE_P (
-			TREE_TYPE (expr3))))
+	      && TREE_CODE (expr3) != POINTER_PLUS_EXPR
 	      && code->expr3->ts.type == BT_CLASS
 	      && (expr->ts.type == BT_CLASS
 		  || expr->ts.type == BT_DERIVED))
@@ -5731,7 +5765,7 @@ gfc_trans_allocate (gfc_code * code)
 	      gfc_expr *ppc;
 	      gfc_code *ppc_code;
 	      gfc_ref *ref, *dataref;
-	      gfc_expr *rhs = gfc_copy_expr (code->expr3);
+	      gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
 
 	      /* Do a polymorphic deep copy.  */
 	      actual = gfc_get_actual_arglist ();
@@ -5827,7 +5861,8 @@ gfc_trans_allocate (gfc_code * code)
 					 void_type_node, tmp, extcopy, stdcopy);
 		}
 	      gfc_free_statements (ppc_code);
-	      gfc_free_expr (rhs);
+	      if (rhs != e3rhs)
+		gfc_free_expr (rhs);
 	    }
 	  else
 	    {
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 2501403..3a23a3c 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -378,7 +378,7 @@ tree gfc_vptr_final_get (tree);
 void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
 void gfc_reset_len (stmtblock_t *, gfc_expr *);
 tree gfc_get_vptr_from_expr (tree);
-tree gfc_get_class_array_ref (tree, tree);
+tree gfc_get_class_array_ref (tree, tree, tree);
 tree gfc_copy_class_to_class (tree, tree, tree, bool);
 bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
 bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_10.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_10.f08
new file mode 100644
index 0000000..b9c68b4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_10.f08
@@ -0,0 +1,51 @@
+!{ dg-do run }
+!
+! Testcase for pr66927
+! Contributed by Juergen Reuter <juergen.reuter@desy.de>
+
+module processes
+  implicit none
+  private
+
+  type :: t1_t
+     real :: p = 0.0
+  end type t1_t
+
+  type :: t2_t
+     private
+     type(t1_t), dimension(:), allocatable :: p
+   contains
+     procedure :: func => t2_func
+  end type t2_t
+
+  type, public :: t3_t
+    type(t2_t), public :: int_born
+  end type t3_t
+
+  public :: evaluate
+
+contains
+
+  function t2_func (int) result (p)
+    class(t2_t), intent(in) :: int
+    type(t1_t), dimension(:), allocatable :: p
+    allocate(p(5))
+  end function t2_func
+
+  subroutine evaluate (t3)
+    class(t3_t), intent(inout) :: t3
+    type(t1_t), dimension(:), allocatable :: p_born
+    allocate (p_born(1:size(t3%int_born%func ())), &
+         source = t3%int_born%func ())
+    if (.not. allocated(p_born)) call abort()
+    if (size(p_born) /= 5) call abort()
+  end subroutine evaluate
+
+end module processes
+
+program pr66927
+use processes
+type(t3_t) :: o
+call evaluate(o)
+end
+
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_11.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_11.f08
new file mode 100644
index 0000000..5491b49
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_11.f08
@@ -0,0 +1,51 @@
+!{ dg-do run }
+!
+! Testcase for pr66927, pr67123
+! Contributed by Juergen Reuter <juergen.reuter@desy.de>
+
+module processes
+  implicit none
+  private
+
+  type :: t1_t
+     real :: p = 0.0
+  end type t1_t
+
+  type :: t2_t
+     private
+     type(t1_t), dimension(:), allocatable :: p
+   contains
+     procedure :: func => t2_func
+  end type t2_t
+
+  type, public :: t3_t
+    type(t2_t), public :: int_born
+  end type t3_t
+
+  public :: evaluate
+
+contains
+
+  function t2_func (int) result (p)
+    class(t2_t), intent(in) :: int
+    class(t1_t), dimension(:), allocatable :: p
+    allocate(p(5))
+  end function t2_func
+
+  subroutine evaluate (t3)
+    class(t3_t), intent(inout) :: t3
+    type(t1_t), dimension(:), allocatable :: p_born
+    allocate (p_born(1:size(t3%int_born%func ())), &
+         source = t3%int_born%func ())
+    if (.not. allocated(p_born)) call abort()
+    if (size(p_born) /= 5) call abort()
+  end subroutine evaluate
+
+end module processes
+
+program pr66927
+use processes
+type(t3_t) :: o
+call evaluate(o)
+end
+
diff --git a/gcc/testsuite/gfortran.dg/class_array_15.f03 b/gcc/testsuite/gfortran.dg/class_array_15.f03
index fd9e04c..85716f9 100644
--- a/gcc/testsuite/gfortran.dg/class_array_15.f03
+++ b/gcc/testsuite/gfortran.dg/class_array_15.f03
@@ -115,4 +115,4 @@ subroutine pr54992  ! This test remains as the original.
   bh => bhGet(b,instance=2)
   if (loc (b) .ne. loc(bh%hostNode)) call abort
 end
-! { dg-final { scan-tree-dump-times "builtin_free" 12 "original" } }
+! { dg-final { scan-tree-dump-times "builtin_free" 11 "original" } }