First, I would be really delighted if someone could review my coarray
patches for the trunk as it makes simpler to develop patches on top of it:
* http://gcc.gnu.org/ml/fortran/2014-04/msg00087.html
* http://gcc.gnu.org/ml/fortran/2014-04/msg00091.html
* http://gcc.gnu.org/ml/fortran/2014-04/msg00092.html
Secondly, attached is a patch which fixes an ICE - and prepares for some
additional class-related coarray patches. In particular, the patch
ensures that for nonallocatable *polymorphic* coarrays, the coarray
token and offset are passed.
Build and regtested on x86-64-gnu-linux.
OK for the trunk?
Tobias
PS: There is still something wrong (for both -fcoarray=single and
-fcoarray=lib) with lcobound/ucobounds and polymorphic coarrays and with
using them with select type and associated. That's something I would
like to tackle next. If that's done, I probably should really
concentrate on reviewing a few patches and doing some other bug fixes
before continue working on coarrays.
2014-04-27 Tobias Burnus <bur...@net-b.de>
* trans-decl.c (create_function_arglist): Add hidden coarray arguments
also for polymorphic coarrays.
* trans-expr.c (gfc_conv_procedure_call): Pass hidden coarray arguments
also for polymorphic coarrays.
2014-04-27 Tobias Burnus <bur...@net-b.de>
* gfortran.dg/coarray_poly_7.f90
* gfortran.dg/coarray_poly_8.f90
* gfortran.dg/coarray_poly_9.f90
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index c835a3b..ee6c7e3 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -2234,9 +2234,12 @@ create_function_arglist (gfc_symbol * sym)
/* Coarrays which are descriptorless or assumed-shape pass with
-fcoarray=lib the token and the offset as hidden arguments. */
- if (f->sym->attr.codimension
- && gfc_option.coarray == GFC_FCOARRAY_LIB
- && !f->sym->attr.allocatable)
+ if (gfc_option.coarray == GFC_FCOARRAY_LIB
+ && ((f->sym->ts.type != BT_CLASS && f->sym->attr.codimension
+ && !f->sym->attr.allocatable)
+ || (f->sym->ts.type == BT_CLASS
+ && CLASS_DATA (f->sym)->attr.codimension
+ && !CLASS_DATA (f->sym)->attr.allocatable)))
{
tree caf_type;
tree token;
@@ -2244,13 +2247,18 @@ create_function_arglist (gfc_symbol * sym)
gcc_assert (f->sym->backend_decl != NULL_TREE
&& !sym->attr.is_bind_c);
- caf_type = TREE_TYPE (f->sym->backend_decl);
+ caf_type = f->sym->ts.type == BT_CLASS
+ ? TREE_TYPE (CLASS_DATA (f->sym)->backend_decl)
+ : TREE_TYPE (f->sym->backend_decl);
token = build_decl (input_location, PARM_DECL,
create_tmp_var_name ("caf_token"),
build_qualified_type (pvoid_type_node,
TYPE_QUAL_RESTRICT));
- if (f->sym->as->type == AS_ASSUMED_SHAPE)
+ if ((f->sym->ts.type != BT_CLASS
+ && f->sym->as->type != AS_DEFERRED)
+ || (f->sym->ts.type == BT_CLASS
+ && CLASS_DATA (f->sym)->as->type != AS_DEFERRED))
{
gcc_assert (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL
|| GFC_DECL_TOKEN (f->sym->backend_decl) == NULL_TREE);
@@ -2275,7 +2283,10 @@ create_function_arglist (gfc_symbol * sym)
create_tmp_var_name ("caf_offset"),
gfc_array_index_type);
- if (f->sym->as->type == AS_ASSUMED_SHAPE)
+ if ((f->sym->ts.type != BT_CLASS
+ && f->sym->as->type != AS_DEFERRED)
+ || (f->sym->ts.type == BT_CLASS
+ && CLASS_DATA (f->sym)->as->type != AS_DEFERRED))
{
gcc_assert (GFC_DECL_CAF_OFFSET (f->sym->backend_decl)
== NULL_TREE);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index f0e5b7d..6b93537 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4783,19 +4783,24 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* For descriptorless coarrays and assumed-shape coarray dummies, we
pass the token and the offset as additional arguments. */
- if (fsym && fsym->attr.codimension
- && gfc_option.coarray == GFC_FCOARRAY_LIB
- && !fsym->attr.allocatable
- && e == NULL)
+ if (fsym && e == NULL && gfc_option.coarray == GFC_FCOARRAY_LIB
+ && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
+ && !fsym->attr.allocatable)
+ || (fsym->ts.type == BT_CLASS
+ && CLASS_DATA (fsym)->attr.codimension
+ && !CLASS_DATA (fsym)->attr.allocatable)))
{
/* Token and offset. */
vec_safe_push (stringargs, null_pointer_node);
vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
gcc_assert (fsym->attr.optional);
}
- else if (fsym && fsym->attr.codimension
- && !fsym->attr.allocatable
- && gfc_option.coarray == GFC_FCOARRAY_LIB)
+ else if (fsym && gfc_option.coarray == GFC_FCOARRAY_LIB
+ && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
+ && !fsym->attr.allocatable)
+ || (fsym->ts.type == BT_CLASS
+ && CLASS_DATA (fsym)->attr.codimension
+ && !CLASS_DATA (fsym)->attr.allocatable)))
{
tree caf_decl, caf_type;
tree offset, tmp2;
@@ -4837,22 +4842,30 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
tmp = caf_decl;
}
- if (fsym->as->type == AS_ASSUMED_SHAPE
- || (fsym->as->type == AS_ASSUMED_RANK && !fsym->attr.pointer
- && !fsym->attr.allocatable))
+ tmp2 = fsym->ts.type == BT_CLASS
+ ? gfc_class_data_get (parmse.expr) : parmse.expr;
+ if ((fsym->ts.type != BT_CLASS
+ && (fsym->as->type == AS_ASSUMED_SHAPE
+ || fsym->as->type == AS_ASSUMED_RANK))
+ || (fsym->ts.type == BT_CLASS
+ && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
+ || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
{
- gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
- (TREE_TYPE (parmse.expr))));
- tmp2 = build_fold_indirect_ref_loc (input_location, parmse.expr);
+ if (fsym->ts.type == BT_CLASS)
+ gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
+ else
+ {
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
+ tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
+ }
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
tmp2 = gfc_conv_descriptor_data_get (tmp2);
}
- else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
- tmp2 = gfc_conv_descriptor_data_get (parmse.expr);
+ else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
+ tmp2 = gfc_conv_descriptor_data_get (tmp2);
else
{
- gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
- tmp2 = parmse.expr;
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
}
tmp = fold_build2_loc (input_location, MINUS_EXPR,
--- /dev/null 2014-04-23 17:58:54.386702372 +0200
+++ gcc/gcc/testsuite/gfortran.dg/coarray_poly_6.f90 2014-04-27 20:32:43.452474762 +0200
@@ -0,0 +1,22 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=lib -fdump-tree-original" }
+!
+ implicit none
+ type t
+ end type t
+ class(t), allocatable :: y[:]
+ call bar()
+ call foo(y)
+contains
+ subroutine bar(x)
+ class(t), optional :: x[*]
+ end subroutine bar
+ subroutine foo(x)
+ class(t) :: x[*]
+ end subroutine foo
+end
+! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_0_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=8\\) caf_offset..\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_0_1t \\* x, void \\* restrict caf_token.., integer\\(kind=8\\) caf_offset..\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data._data.token, \\(integer\\(kind=8\\)\\) class..._data.data - \\(integer\\(kind=8\\)\\) y._data._data.data\\);" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
--- /dev/null 2014-04-23 17:58:54.386702372 +0200
+++ gcc/gcc/testsuite/gfortran.dg/coarray_poly_7.f90 2014-04-27 20:33:37.856904369 +0200
@@ -0,0 +1,22 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=lib -fdump-tree-original" }
+!
+ implicit none
+ type t
+ end type t
+ class(t), allocatable :: y(:)[:]
+ call bar()
+ call foo(y)
+contains
+ subroutine bar(x)
+ class(t), optional :: x(:)[*]
+ end subroutine bar
+ subroutine foo(x)
+ class(t) :: x(:)[*]
+ end subroutine foo
+end
+! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_1_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=8\\) caf_offset..\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_1_1t \\* x, void \\* restrict caf_token.., integer\\(kind=8\\) caf_offset..\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data._data.token, \\(integer\\(kind=8\\)\\) class..._data.data - \\(integer\\(kind=8\\)\\) y._data._data.data\\);" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
--- /dev/null 2014-04-23 17:58:54.386702372 +0200
+++ gcc/gcc/testsuite/gfortran.dg/coarray_poly_8.f90 2014-04-27 20:33:46.073969253 +0200
@@ -0,0 +1,22 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=lib -fdump-tree-original" }
+!
+ implicit none
+ type t
+ end type t
+ class(t), allocatable :: y(:)[:]
+ call bar()
+ call foo(y)
+contains
+ subroutine bar(x)
+ class(t), optional :: x(2)[*]
+ end subroutine bar
+ subroutine foo(x)
+ class(t) :: x(2)[*]
+ end subroutine foo
+end
+! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_1_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=8\\) caf_offset..\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_1_1t \\* x, void \\* restrict caf_token.., integer\\(kind=8\\) caf_offset..\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data._data.token, \\(integer\\(kind=8\\)\\) class..._data.data - \\(integer\\(kind=8\\)\\) y._data._data.data\\);" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
