* Re: [Patch, Fortran, 66927, v2] [6 Regression] ICE in gfc_conf_procedure_call
@ 2015-10-25 11:51 Paul Richard Thomas
2015-10-25 13:09 ` Andre Vehreschild
0 siblings, 1 reply; 7+ messages in thread
From: Paul Richard Thomas @ 2015-10-25 11:51 UTC (permalink / raw)
To: Dominique d'Humières, gcc-patches
Cc: Andre Vehreschild, Mikael Morin, GNU GFortran
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
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch, Fortran, 66927, v2] [6 Regression] ICE in gfc_conf_procedure_call
2015-10-25 11:51 [Patch, Fortran, 66927, v2] [6 Regression] ICE in gfc_conf_procedure_call Paul Richard Thomas
@ 2015-10-25 13:09 ` Andre Vehreschild
2015-10-26 10:05 ` [Patch, Fortran, 66927, v2.1] " Andre Vehreschild
0 siblings, 1 reply; 7+ messages in thread
From: Andre Vehreschild @ 2015-10-25 13:09 UTC (permalink / raw)
To: Paul Richard Thomas
Cc: Dominique d'Humières, gcc-patches, Mikael Morin, GNU GFortran
[-- 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
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch, Fortran, 66927, v2.1] [6 Regression] ICE in gfc_conf_procedure_call
2015-10-25 13:09 ` Andre Vehreschild
@ 2015-10-26 10:05 ` Andre Vehreschild
2015-10-26 12:06 ` Paul Richard Thomas
0 siblings, 1 reply; 7+ messages in thread
From: Andre Vehreschild @ 2015-10-26 10:05 UTC (permalink / raw)
To: Paul Richard Thomas
Cc: Dominique d'Humières, gcc-patches, Mikael Morin, GNU GFortran
[-- 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
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch, Fortran, 66927, v2.1] [6 Regression] ICE in gfc_conf_procedure_call
2015-10-26 10:05 ` [Patch, Fortran, 66927, v2.1] " Andre Vehreschild
@ 2015-10-26 12:06 ` Paul Richard Thomas
2015-10-26 13:07 ` Andre Vehreschild
0 siblings, 1 reply; 7+ messages in thread
From: Paul Richard Thomas @ 2015-10-26 12:06 UTC (permalink / raw)
To: Andre Vehreschild
Cc: Dominique d'Humières, gcc-patches, Mikael Morin, GNU GFortran
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
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch, Fortran, 66927, v2.1] [6 Regression] ICE in gfc_conf_procedure_call
2015-10-26 12:06 ` Paul Richard Thomas
@ 2015-10-26 13:07 ` Andre Vehreschild
0 siblings, 0 replies; 7+ messages in thread
From: Andre Vehreschild @ 2015-10-26 13:07 UTC (permalink / raw)
To: Paul Richard Thomas
Cc: Dominique d'Humières, gcc-patches, Mikael Morin, GNU GFortran
[-- 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
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch, Fortran, 66927, v2] [6 Regression] ICE in gfc_conf_procedure_call
@ 2015-10-07 17:51 Dominique d'Humières
0 siblings, 0 replies; 7+ messages in thread
From: Dominique d'Humières @ 2015-10-07 17:51 UTC (permalink / raw)
To: Andre Vehreschild
Cc: Mikael Morin, Paul Richard Thomas, GNU GFortran, GCC Patches
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
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: [Patch, Fortran, 66927, v2] [6 Regression] ICE in gfc_conf_procedure_call
2015-08-09 12:37 ` Mikael Morin
@ 2015-09-29 14:27 ` Andre Vehreschild
0 siblings, 0 replies; 7+ messages in thread
From: Andre Vehreschild @ 2015-09-29 14:27 UTC (permalink / raw)
To: Mikael Morin, GCC-Fortran-ML; +Cc: GCC-Patches-ML
[-- 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" } }
^ permalink raw reply [flat|nested] 7+ messages in thread
end of thread, other threads:[~2015-10-26 13:04 UTC | newest]
Thread overview: 7+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2015-10-25 11:51 [Patch, Fortran, 66927, v2] [6 Regression] ICE in gfc_conf_procedure_call Paul Richard Thomas
2015-10-25 13:09 ` Andre Vehreschild
2015-10-26 10:05 ` [Patch, Fortran, 66927, v2.1] " Andre Vehreschild
2015-10-26 12:06 ` Paul Richard Thomas
2015-10-26 13:07 ` Andre Vehreschild
-- strict thread matches above, loose matches on Subject: below --
2015-10-07 17:51 [Patch, Fortran, 66927, v2] " Dominique d'Humières
2015-08-06 10:53 [Patch, Fortran, 66927, v1] " Andre Vehreschild
2015-08-06 12:01 ` Mikael Morin
2015-08-09 12:37 ` Mikael Morin
2015-09-29 14:27 ` [Patch, Fortran, 66927, v2] " Andre Vehreschild
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).