Skip to content

R
riscv-gcc-1
Commit 598cc4fa by Tobias Burnus Committed by Tobias Burnus
Options

trans-decl.c (create_function_arglist): Add hidden coarray 

2014-04-30  Tobias Burnus  <burnus@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-30  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/coarray_poly_7.f90
        * gfortran.dg/coarray_poly_8.f90
        * gfortran.dg/coarray_poly_9.f90

From-SVN: r209953
parent 2c060879
Showing with 127 additions and 24 deletions
gcc/fortran/ChangeLog
2014-04-30 Tobias Burnus <burnus@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-30 Tobias Burnus <burnus@net-b.de>
* resolve.c (resolve_function): Don't do
assumed-size check for lcobound/ucobound.
* trans-types.c (gfc_build_array_type): Only build an array
......
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);
......
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,
......
gcc/testsuite/ChangeLog
2014-04-30 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/coarray_poly_7.f90
* gfortran.dg/coarray_poly_8.f90
* gfortran.dg/coarray_poly_9.f90
2014-04-30 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/coarray_lib_this_image_2.f90: Update dump.
* gfortran.dg/coarray_lib_token_4.f90: Ditto.
* gfortran.dg/coarray/codimension.f90: New.
......
gcc/testsuite/gfortran.dg/coarray_poly_6.f90 0 → 100644
! { 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" } }
gcc/testsuite/gfortran.dg/coarray_poly_7.f90 0 → 100644
! { 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" } }
gcc/testsuite/gfortran.dg/coarray_poly_8.f90 0 → 100644
! { 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" } }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment