Dear Dominique,
Please find attached a revised patch that I believe fixes the problem
that you found. The changes are the additions in trans-decl.c.
OK for trunk and 7-branch?
Paul
2017-11-18 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/78990
* expr.c (gfc_is_class_array_function): Renamed from
'gfc_is_alloc_class_array_function' and modified to return true
for pointers as well as allocatable results.
* gfortran.h : Change of name for prototype of above function.
* trans-array.c (gfc_add_loop_ss_code): Force finalization of
class array results.
(build_class_array_ref): Change assertion into a condition.
(build_class_array_ref): Set the se class_vptr for class array
function results.
(gfc_walk_function_expr): Reference gfc_is_class_array_function
as above.
* trans-decl.c (get_proc_result): Move it up before
gfc_trans_deferred_vars.
(gfc_trans_deferred_vars): Nullify explicit return class arrays
on entry.
* trans-expr.c (gfc_conv_class_to_class): Allow conversion of
class array functions that have an se class_vptr and use it
for the result vptr.
(gfc_conv_subref_array_arg): Rename reference to the above
function.
(gfc_conv_procedure_call): Ditto. Add the se pre block to the
loop pre block before the function is evaluated. Do not
finalize class pointer results.
(arrayfunc_assign_needs_temporary, gfc_trans_assignment_1) More
renamed references.
* trans-intrinsic.c (gfc_conv_intrinsic_size): Ditto.
2017-11-18 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/78990
* gfortran.dg/class_67.f90: New test.
On 15 November 2017 at 11:40, Dominique d'Humières <domi...@lps.ens.fr> wrote:
> Hi Paul,
>
> Your patch fixes the ICE and pass the tests. However I see
>
> At line 22 of file pr78990.f90
> Fortran runtime error: Attempting to allocate already allocated variable
> ‘return_t1'
>
> for the original tests (with mold or source). This runtime error depends on
> the options:
>
> % gfc pr78990.f90
> % a.out
> At line 22 of file pr78990.f90
> Fortran runtime error: Attempting to allocate already allocated variable
> 'return_t1'
>
> Error termination. Backtrace:
> …
> % gfc pr78990.f90 -fno-backtrace
> % a.out
> 0 0 0
> % gfc pr78990.f90 -m32
> % a.out
> 0 0 0
> % gfc pr78990.f90 -O
> % a.out
> 0 0 0
>
> The problem seems related to the line
>
> print*,v2%i
>
> Cheers,
>
> Dominique
>
>
--
"If you can't explain it simply, you don't understand it well enough"
- Albert Einstein
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c (revision 254626)
--- gcc/fortran/expr.c (working copy)
*************** gfc_is_alloc_class_scalar_function (gfc_
*** 4822,4835 ****
/* Determine if an expression is a function with an allocatable class array
result. */
bool
! gfc_is_alloc_class_array_function (gfc_expr *expr)
{
if (expr->expr_type == EXPR_FUNCTION
&& expr->value.function.esym
&& expr->value.function.esym->result
&& expr->value.function.esym->result->ts.type == BT_CLASS
&& CLASS_DATA (expr->value.function.esym->result)->attr.dimension
! && CLASS_DATA (expr->value.function.esym->result)->attr.allocatable)
return true;
return false;
--- 4822,4836 ----
/* Determine if an expression is a function with an allocatable class array
result. */
bool
! gfc_is_class_array_function (gfc_expr *expr)
{
if (expr->expr_type == EXPR_FUNCTION
&& expr->value.function.esym
&& expr->value.function.esym->result
&& expr->value.function.esym->result->ts.type == BT_CLASS
&& CLASS_DATA (expr->value.function.esym->result)->attr.dimension
! && (CLASS_DATA (expr->value.function.esym->result)->attr.allocatable
! || CLASS_DATA (expr->value.function.esym->result)->attr.pointer))
return true;
return false;
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 254626)
--- gcc/fortran/gfortran.h (working copy)
*************** gfc_param_spec_type gfc_spec_list_type (
*** 3194,3200 ****
gfc_component * gfc_get_proc_ptr_comp (gfc_expr *);
bool gfc_is_proc_ptr_comp (gfc_expr *);
bool gfc_is_alloc_class_scalar_function (gfc_expr *);
! bool gfc_is_alloc_class_array_function (gfc_expr *);
bool gfc_ref_this_image (gfc_ref *ref);
bool gfc_is_coindexed (gfc_expr *);
--- 3194,3200 ----
gfc_component * gfc_get_proc_ptr_comp (gfc_expr *);
bool gfc_is_proc_ptr_comp (gfc_expr *);
bool gfc_is_alloc_class_scalar_function (gfc_expr *);
! bool gfc_is_class_array_function (gfc_expr *);
bool gfc_ref_this_image (gfc_ref *ref);
bool gfc_is_coindexed (gfc_expr *);
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 254626)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_select_type (gfc_code *code, gfc
*** 8738,8743 ****
--- 8738,8746 ----
code->expr1->symtree->n.sym->ts = code->expr2->ts;
selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
+ if (code->expr2->rank && CLASS_DATA (code->expr1)->as)
+ CLASS_DATA (code->expr1)->as->rank = code->expr2->rank;
+
/* F2008: C803 The selector expression must not be coindexed. */
if (gfc_is_coindexed (code->expr2))
{
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 254626)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_add_loop_ss_code (gfc_loopinfo * loo
*** 2791,2796 ****
--- 2791,2798 ----
gfc_init_se (&se, NULL);
se.loop = loop;
se.ss = ss;
+ if (gfc_is_class_array_function (expr))
+ expr->must_finalize = 1;
gfc_conv_expr (&se, expr);
gfc_add_block_to_block (&outer_loop->pre, &se.pre);
gfc_add_block_to_block (&outer_loop->post, &se.post);
*************** build_class_array_ref (gfc_se *se, tree
*** 3241,3247 ****
{
if (expr == NULL
|| (expr->ts.type != BT_CLASS
! && !gfc_is_alloc_class_array_function (expr)
&& !gfc_is_class_array_ref (expr, NULL)))
return false;
--- 3243,3249 ----
{
if (expr == NULL
|| (expr->ts.type != BT_CLASS
! && !gfc_is_class_array_function (expr)
&& !gfc_is_class_array_ref (expr, NULL)))
return false;
*************** build_class_array_ref (gfc_se *se, tree
*** 3271,3282 ****
}
if (class_ref == NULL && expr && expr->symtree->n.sym->attr.function
! && expr->symtree->n.sym == expr->symtree->n.sym->result)
{
- gcc_assert (expr->symtree->n.sym->backend_decl ==
current_function_decl);
decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0);
}
! else if (expr && gfc_is_alloc_class_array_function (expr))
{
size = NULL_TREE;
decl = NULL_TREE;
--- 3273,3284 ----
}
if (class_ref == NULL && expr && expr->symtree->n.sym->attr.function
! && expr->symtree->n.sym == expr->symtree->n.sym->result
! && expr->symtree->n.sym->backend_decl == current_function_decl)
{
decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0);
}
! else if (expr && gfc_is_class_array_function (expr))
{
size = NULL_TREE;
decl = NULL_TREE;
*************** build_class_array_ref (gfc_se *se, tree
*** 3299,3304 ****
--- 3301,3308 ----
if (decl == NULL_TREE)
return false;
+
+ se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
}
else if (class_ref == NULL)
{
*************** gfc_walk_function_expr (gfc_ss * ss, gfc
*** 10527,10533 ****
if (!sym)
sym = expr->symtree->n.sym;
! if (gfc_is_alloc_class_array_function (expr))
return gfc_get_array_ss (ss, expr,
CLASS_DATA
(expr->value.function.esym->result)->as->rank,
GFC_SS_FUNCTION);
--- 10531,10537 ----
if (!sym)
sym = expr->symtree->n.sym;
! if (gfc_is_class_array_function (expr))
return gfc_get_array_ss (ss, expr,
CLASS_DATA
(expr->value.function.esym->result)->as->rank,
GFC_SS_FUNCTION);
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 254626)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_null_and_pass_deferred_len (gfc_symb
*** 4161,4166 ****
--- 4161,4184 ----
return tmp;
}
+
+ /* Get the result expression for a procedure. */
+
+ static tree
+ get_proc_result (gfc_symbol* sym)
+ {
+ if (sym->attr.subroutine || sym == sym->result)
+ {
+ if (current_fake_result_decl != NULL)
+ return TREE_VALUE (current_fake_result_decl);
+
+ return NULL_TREE;
+ }
+
+ return sym->result->backend_decl;
+ }
+
+
/* Generate function entry and exit code, and add it to the function body.
This includes:
Allocation and initialization of array variables.
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4271,4276 ****
--- 4289,4309 ----
else
gcc_assert (flag_f2c && proc_sym->ts.type == BT_COMPLEX);
}
+ else if (proc_sym == proc_sym->result && IS_CLASS_ARRAY (proc_sym))
+ {
+ /* Nullify explicit return class arrays on entry. */
+ tree type;
+ tmp = get_proc_result (proc_sym);
+ if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+ {
+ gfc_start_block (&init);
+ tmp = gfc_class_data_get (tmp);
+ type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp));
+ gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0));
+ gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+ }
+ }
+
/* Initialize the INTENT(OUT) derived type dummy arguments. This
should be done here so that the offsets and lbounds of arrays
*************** create_main_function (tree fndecl)
*** 6067,6089 ****
}
- /* Get the result expression for a procedure. */
-
- static tree
- get_proc_result (gfc_symbol* sym)
- {
- if (sym->attr.subroutine || sym == sym->result)
- {
- if (current_fake_result_decl != NULL)
- return TREE_VALUE (current_fake_result_decl);
-
- return NULL_TREE;
- }
-
- return sym->result->backend_decl;
- }
-
-
/* Generate an appropriate return-statement for a procedure. */
tree
--- 6100,6105 ----
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 254626)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_conv_class_to_class (gfc_se *parmse,
*** 960,965 ****
--- 960,966 ----
}
if ((ref == NULL || class_ref == ref)
+ && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
&& (!class_ts.u.derived->components->as
|| class_ts.u.derived->components->as->rank != -1))
return;
*************** gfc_conv_class_to_class (gfc_se *parmse,
*** 1030,1037 ****
First we have to find the corresponding class reference. */
tmp = NULL_TREE;
! if (class_ref == NULL
! && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
{
tmp = e->symtree->n.sym->backend_decl;
--- 1031,1041 ----
First we have to find the corresponding class reference. */
tmp = NULL_TREE;
! if (gfc_is_class_array_function (e)
! && parmse->class_vptr != NULL_TREE)
! tmp = parmse->class_vptr;
! else if (class_ref == NULL
! && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
{
tmp = e->symtree->n.sym->backend_decl;
*************** gfc_conv_class_to_class (gfc_se *parmse,
*** 1063,1069 ****
if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
tmp = build_fold_indirect_ref_loc (input_location, tmp);
! vptr = gfc_class_vptr_get (tmp);
gfc_add_modify (&block, ctree,
fold_convert (TREE_TYPE (ctree), vptr));
--- 1067,1077 ----
if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
tmp = build_fold_indirect_ref_loc (input_location, tmp);
! if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
! vptr = gfc_class_vptr_get (tmp);
! else
! vptr = tmp;
!
gfc_add_modify (&block, ctree,
fold_convert (TREE_TYPE (ctree), vptr));
*************** gfc_conv_subref_array_arg (gfc_se * parm
*** 4435,4441 ****
/* Reset the offset for the function call since the loop
is zero based on the data pointer. Note that the temp
comes first in the loop chain since it is added second. */
! if (gfc_is_alloc_class_array_function (expr))
{
tmp = loop.ss->loop_chain->info->data.array.descriptor;
gfc_conv_descriptor_offset_set (&loop.pre, tmp,
--- 4443,4449 ----
/* Reset the offset for the function call since the loop
is zero based on the data pointer. Note that the temp
comes first in the loop chain since it is added second. */
! if (gfc_is_class_array_function (expr))
{
tmp = loop.ss->loop_chain->info->data.array.descriptor;
gfc_conv_descriptor_offset_set (&loop.pre, tmp,
*************** gfc_conv_subref_array_arg (gfc_se * parm
*** 4484,4490 ****
dimen = rse.ss->dimen;
/* Skip the write-out loop for this case. */
! if (gfc_is_alloc_class_array_function (expr))
goto class_array_fcn;
/* Calculate the bounds of the scalarization. */
--- 4492,4498 ----
dimen = rse.ss->dimen;
/* Skip the write-out loop for this case. */
! if (gfc_is_class_array_function (expr))
goto class_array_fcn;
/* Calculate the bounds of the scalarization. */
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 4778,4784 ****
gcc_assert ((!comp && gfc_return_by_reference (sym)
&& sym->result->attr.dimension)
|| (comp && comp->attr.dimension)
! || gfc_is_alloc_class_array_function (expr));
gcc_assert (se->loop != NULL);
/* Access the previously obtained result. */
gfc_conv_tmp_array_ref (se);
--- 4786,4792 ----
gcc_assert ((!comp && gfc_return_by_reference (sym)
&& sym->result->attr.dimension)
|| (comp && comp->attr.dimension)
! || gfc_is_class_array_function (expr));
gcc_assert (se->loop != NULL);
/* Access the previously obtained result. */
gfc_conv_tmp_array_ref (se);
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5462,5468 ****
fsym ? fsym->attr.intent : INTENT_INOUT,
fsym && fsym->attr.pointer);
! else if (gfc_is_alloc_class_array_function (e)
&& fsym && fsym->ts.type == BT_DERIVED)
/* See previous comment. For function actual argument,
the write out is not needed so the intent is set as
--- 5470,5476 ----
fsym ? fsym->attr.intent : INTENT_INOUT,
fsym && fsym->attr.pointer);
! else if (gfc_is_class_array_function (e)
&& fsym && fsym->ts.type == BT_DERIVED)
/* See previous comment. For function actual argument,
the write out is not needed so the intent is set as
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 6304,6310 ****
call the finalization function of the temporary. Note that the
nullification of allocatable components needed by the result
is done in gfc_trans_assignment_1. */
! if (expr && ((gfc_is_alloc_class_array_function (expr)
&& se->ss && se->ss->loop)
|| gfc_is_alloc_class_scalar_function (expr))
&& se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
--- 6312,6318 ----
call the finalization function of the temporary. Note that the
nullification of allocatable components needed by the result
is done in gfc_trans_assignment_1. */
! if (expr && ((gfc_is_class_array_function (expr)
&& se->ss && se->ss->loop)
|| gfc_is_alloc_class_scalar_function (expr))
&& se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 6315,6320 ****
--- 6323,6329 ----
int n;
if (se->ss && se->ss->loop)
{
+ gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
tmp = gfc_class_data_get (se->expr);
info->descriptor = tmp;
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 6337,6342 ****
--- 6346,6356 ----
CLASS_DATA (expr->value.function.esym->result)->attr);
}
+ if ((gfc_is_class_array_function (expr)
+ || gfc_is_alloc_class_scalar_function (expr))
+ && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
+ goto no_finalization;
+
final_fndecl = gfc_class_vtab_final_get (se->expr);
is_final = fold_build2_loc (input_location, NE_EXPR,
logical_type_node,
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 6367,6372 ****
--- 6381,6388 ----
tmp = gfc_call_free (tmp);
gfc_add_expr_to_block (&se->post, tmp);
}
+
+ no_finalization:
expr->must_finalize = 0;
}
*************** arrayfunc_assign_needs_temporary (gfc_ex
*** 8887,8893 ****
gfc_symbol *sym = expr1->symtree->n.sym;
/* Play it safe with class functions assigned to a derived type. */
! if (gfc_is_alloc_class_array_function (expr2)
&& expr1->ts.type == BT_DERIVED)
return true;
--- 8903,8909 ----
gfc_symbol *sym = expr1->symtree->n.sym;
/* Play it safe with class functions assigned to a derived type. */
! if (gfc_is_class_array_function (expr2)
&& expr1->ts.type == BT_DERIVED)
return true;
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 9894,9900 ****
rss = NULL;
if ((expr1->ts.type == BT_DERIVED)
! && (gfc_is_alloc_class_array_function (expr2)
|| gfc_is_alloc_class_scalar_function (expr2)))
expr2->must_finalize = 1;
--- 9910,9916 ----
rss = NULL;
if ((expr1->ts.type == BT_DERIVED)
! && (gfc_is_class_array_function (expr2)
|| gfc_is_alloc_class_scalar_function (expr2)))
expr2->must_finalize = 1;
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 10101,10107 ****
a scalar to array assignment, this is done in gfc_trans_scalar_assign
as part of the deep copy. */
if (!scalar_to_array && expr1->ts.type == BT_DERIVED
! && (gfc_is_alloc_class_array_function (expr2)
|| gfc_is_alloc_class_scalar_function (expr2)))
{
tmp = rse.expr;
--- 10117,10123 ----
a scalar to array assignment, this is done in gfc_trans_scalar_assign
as part of the deep copy. */
if (!scalar_to_array && expr1->ts.type == BT_DERIVED
! && (gfc_is_class_array_function (expr2)
|| gfc_is_alloc_class_scalar_function (expr2)))
{
tmp = rse.expr;
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c (revision 254626)
--- gcc/fortran/trans-intrinsic.c (working copy)
*************** gfc_conv_intrinsic_size (gfc_se * se, gf
*** 6603,6609 ****
gfc_add_class_array_ref (actual->expr);
argse.data_not_needed = 1;
! if (gfc_is_alloc_class_array_function (actual->expr))
{
/* For functions that return a class array conv_expr_descriptor is not
able to get the descriptor right. Therefore this special case. */
--- 6603,6609 ----
gfc_add_class_array_ref (actual->expr);
argse.data_not_needed = 1;
! if (gfc_is_class_array_function (actual->expr))
{
/* For functions that return a class array conv_expr_descriptor is not
able to get the descriptor right. Therefore this special case. */
Index: gcc/testsuite/gfortran.dg/class_67.f90
===================================================================
*** gcc/testsuite/gfortran.dg/class_67.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/class_67.f90 (working copy)
***************
*** 0 ****
--- 1,55 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR78990 in which the scalarization of the assignment
+ ! in the main program failed for two reasons: (i) The conversion of 'v1'
+ ! into a class actual was being done after the call to 'return_t1', giving
+ ! rise to the ICE reported in comment #1; and (ii) The 'info' descriptor,
+ ! required for scalarization was not set, which gave rise to the ICE noted
+ ! by the contributor.
+ !
+ ! Contributed by Chris Macmackin <cmacmac...@gmail.com>
+ !
+ module test_type
+ implicit none
+
+ type t1
+ integer :: i
+ contains
+ procedure :: assign
+ generic :: assignment(=) => assign
+ end type t1
+
+ contains
+
+ elemental subroutine assign(this,rhs)
+ class(t1), intent(inout) :: this
+ class(t1), intent(in) :: rhs
+ this%i = rhs%i
+ end subroutine assign
+
+ function return_t1(arg)
+ class(t1), dimension(:), intent(in) :: arg
+ class(t1), dimension(:), allocatable :: return_t1
+ allocate(return_t1(size(arg)), source=arg)
+ end function return_t1
+
+ function return_t1_p(arg)
+ class(t1), dimension(:), intent(in), target :: arg
+ class(t1), dimension(:), pointer :: return_t1_p
+ return_t1_p => arg
+ end function return_t1_p
+ end module test_type
+
+ program test
+ use test_type
+ implicit none
+
+ type(t1), dimension(3) :: v1, v2
+ v1%i = [1,2,3]
+ v2 = return_t1(v1)
+ if (any (v2%i .ne. v1%i)) call abort
+
+ v1%i = [4,5,6]
+ v2 = return_t1_p(v1)
+ if (any (v2%i .ne. v1%i)) call abort
+ end program test
