Fixing the original problem in the module took a few minutes. Making
the module do something useful took rather longer! The testcase in the
patch compiles with 6-branch but segfaults in runtime.
Bootstrapped and regtested on FC30/x86_64 - OK to commit and go
steadily back through the branches over some weeks?
Regards
Paul
2019-09-22 Paul Thomas <[email protected]>
PR fortran/91726
* resolve.c (gfc_expr_to_initialize): Bail out with a copy of
the original expression if the array ref is a scalar and the
array_spec has corank.
* trans-array.c (gfc_conv_array_ref): Such expressions are OK
even if the array ref codimen is zero.
* trans-expr.c (gfc_get_class_from_expr): New function taken
from gfc_get_vptr_from_expr.
(gfc_get_vptr_from_expr): Call new function.
* trans-stmt.c (trans_associate_var): If one of these is a
target expression, extract the class expression from the target
and copy its fields to a new target variable.
* trans.h : Add prototype for gfc_get_class_from_expr.
2019-09-22 Paul Thomas <[email protected]>
PR fortran/91726
* gfortran.dg/coarray_poly_9.f90 : New test.
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 275799)
--- gcc/fortran/resolve.c (working copy)
*************** gfc_expr_to_initialize (gfc_expr *e)
*** 7433,7438 ****
--- 7433,7442 ----
for (ref = result->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->next == NULL)
{
+ if (ref->u.ar.dimen == 0
+ && ref->u.ar.as && ref->u.ar.as->corank)
+ return result;
+
ref->u.ar.type = AR_FULL;
for (i = 0; i < ref->u.ar.dimen; i++)
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 275799)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_conv_array_ref (gfc_se * se, gfc_arr
*** 3609,3615 ****
if (ar->dimen == 0)
{
! gcc_assert (ar->codimen || sym->attr.select_rank_temporary);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
--- 3609,3616 ----
if (ar->dimen == 0)
{
! gcc_assert (ar->codimen || sym->attr.select_rank_temporary
! || (ar->as && ar->as->corank));
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 275799)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_reset_len (stmtblock_t *block, gfc_e
*** 472,482 ****
}
! /* Obtain the vptr of the last class reference in an expression.
Return NULL_TREE if no class reference is found. */
tree
! gfc_get_vptr_from_expr (tree expr)
{
tree tmp;
tree type;
--- 472,482 ----
}
! /* Obtain the last class reference in an expression.
Return NULL_TREE if no class reference is found. */
tree
! gfc_get_class_from_expr (tree expr)
{
tree tmp;
tree type;
*************** gfc_get_vptr_from_expr (tree expr)
*** 487,493 ****
while (type)
{
if (GFC_CLASS_TYPE_P (type))
! return gfc_class_vptr_get (tmp);
if (type != TYPE_CANONICAL (type))
type = TYPE_CANONICAL (type);
else
--- 487,493 ----
while (type)
{
if (GFC_CLASS_TYPE_P (type))
! return tmp;
if (type != TYPE_CANONICAL (type))
type = TYPE_CANONICAL (type);
else
*************** gfc_get_vptr_from_expr (tree expr)
*** 501,506 ****
--- 501,523 ----
tmp = build_fold_indirect_ref_loc (input_location, tmp);
if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+ return tmp;
+
+ return NULL_TREE;
+ }
+
+
+ /* Obtain the vptr of the last class reference in an expression.
+ Return NULL_TREE if no class reference is found. */
+
+ tree
+ gfc_get_vptr_from_expr (tree expr)
+ {
+ tree tmp;
+
+ tmp = gfc_get_class_from_expr (expr);
+
+ if (tmp != NULL_TREE)
return gfc_class_vptr_get (tmp);
return NULL_TREE;
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 275799)
--- gcc/fortran/trans-stmt.c (working copy)
*************** trans_associate_var (gfc_symbol *sym, gf
*** 2099,2105 ****
--- 2099,2141 ----
}
else
{
+ tree ctree = gfc_get_class_from_expr (se.expr);
tmp = TREE_TYPE (sym->backend_decl);
+
+ /* Coarray scalar component expressions can emerge from
+ the front end as array elements of the _data field. */
+ if (sym->ts.type == BT_CLASS
+ && e->ts.type == BT_CLASS && e->rank == 0
+ && !GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)) && ctree)
+ {
+ tree stmp;
+ tree dtmp;
+
+ se.expr = ctree;
+ dtmp = TREE_TYPE (TREE_TYPE (sym->backend_decl));
+ ctree = gfc_create_var (dtmp, "class");
+
+ stmp = gfc_class_data_get (se.expr);
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp)));
+
+ /* Set the fields of the target class variable. */
+ stmp = gfc_conv_descriptor_data_get (stmp);
+ dtmp = gfc_class_data_get (ctree);
+ stmp = fold_convert (TREE_TYPE (dtmp), stmp);
+ gfc_add_modify (&se.pre, dtmp, stmp);
+ stmp = gfc_class_vptr_get (se.expr);
+ dtmp = gfc_class_vptr_get (ctree);
+ stmp = fold_convert (TREE_TYPE (dtmp), stmp);
+ gfc_add_modify (&se.pre, dtmp, stmp);
+ if (UNLIMITED_POLY (sym))
+ {
+ stmp = gfc_class_len_get (se.expr);
+ dtmp = gfc_class_len_get (ctree);
+ stmp = fold_convert (TREE_TYPE (dtmp), stmp);
+ gfc_add_modify (&se.pre, dtmp, stmp);
+ }
+ se.expr = ctree;
+ }
tmp = gfc_build_addr_expr (tmp, se.expr);
}
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h (revision 275799)
--- gcc/fortran/trans.h (working copy)
*************** tree gfc_vptr_final_get (tree);
*** 434,439 ****
--- 434,440 ----
tree gfc_vptr_deallocate_get (tree);
void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
void gfc_reset_len (stmtblock_t *, gfc_expr *);
+ tree gfc_get_class_from_expr (tree);
tree gfc_get_vptr_from_expr (tree);
tree gfc_get_class_array_ref (tree, tree, tree, bool);
tree gfc_copy_class_to_class (tree, tree, tree, bool);
Index: gcc/testsuite/gfortran.dg/coarray_poly_9.f90
===================================================================
*** gcc/testsuite/gfortran.dg/coarray_poly_9.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/coarray_poly_9.f90 (working copy)
***************
*** 0 ****
--- 1,38 ----
+ ! { dg-do run }
+ ! { dg-options "-fcoarray=single" }
+ !
+ ! Test the fix for PR91726.
+ !
+ ! Contributed by Gerhardt Steinmetz <[email protected]>
+ !
+ module m
+ type s
+ class(*), allocatable :: a[:] ! This ICEd
+ end type
+ type t
+ class(*), allocatable :: a(:)[:] ! This was OK
+ end type
+ end
+
+ use m
+ call foo
+ call bar
+ contains
+ subroutine foo
+ type (s) :: a
+ integer(4) :: i = 42_4
+ allocate (a%a[*], source = i) ! This caused runtime segfaults
+ select type (z => a%a) ! ditto
+ type is (integer(4))
+ if (z .ne. 42_4) stop 1
+ end select
+ end subroutine
+ subroutine bar ! Arrays always worked
+ type (t) :: a
+ allocate (a%a(3)[*], source = [1_4, 2_4, 3_4])
+ select type (z => a%a)
+ type is (integer(4))
+ if (any (z .ne. [1_4, 2_4, 3_4])) stop 2
+ end select
+ end subroutine
+ end
