OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

check.c (gfc_check_present): Allow coarrays.

Browse Source 
2011-07-21  Tobias Burnus  <burnus@net-b.de>

        * check.c (gfc_check_present): Allow coarrays.
        * trans-array.c (gfc_conv_array_ref): Avoid casting
        when a pointer is wanted.
        * trans-decl.c (create_function_arglist): For -fcoarray=lib,
        handle hidden token and offset arguments for nondescriptor
        coarrays.
        * trans-expr.c (get_tree_for_caf_expr): New function.
        (gfc_conv_procedure_call): For -fcoarray=lib pass the
        token and offset for nondescriptor coarray dummies.
        * trans.h (lang_type): Add caf_offset tree.
        (GFC_TYPE_ARRAY_CAF_OFFSET): New macro.

2011-07-21  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/coarray_lib_token_1.f90: New.

From-SVN: r176562
This commit is contained in:
Tobias Burnus 2011-07-21 14:00:25 +02:00 committed by Tobias Burnus
parent 91bc61122f
commit 0c53708ead
8 changed files with 238 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
gcc/fortran/ChangeLog
View File

@ -1,3 +1,17 @@
2011-07-21 Tobias Burnus <burnus@net-b.de>
* check.c (gfc_check_present): Allow coarrays.
* trans-array.c (gfc_conv_array_ref): Avoid casting
when a pointer is wanted.
* trans-decl.c (create_function_arglist): For -fcoarray=lib,
handle hidden token and offset arguments for nondescriptor
coarrays.
* trans-expr.c (get_tree_for_caf_expr): New function.
(gfc_conv_procedure_call): For -fcoarray=lib pass the
token and offset for nondescriptor coarray dummies.
* trans.h (lang_type): Add caf_offset tree.
(GFC_TYPE_ARRAY_CAF_OFFSET): New macro.
2011-07-19 Tobias Burnus <burnus@net-b.de>
* expr.c (gfc_is_coarray): New function.

4
gcc/fortran/check.c
View File

@ -2895,7 +2895,9 @@ gfc_check_present (gfc_expr *a)
if (a->ref != NULL
&& !(a->ref->next == NULL && a->ref->type == REF_ARRAY
&& a->ref->u.ar.type == AR_FULL))
&& (a->ref->u.ar.type == AR_FULL
|| (a->ref->u.ar.type == AR_ELEMENT
&& a->ref->u.ar.as->rank == 0))))
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
"subobject of '%s'", gfc_current_intrinsic_arg[0]->name,

7
gcc/fortran/trans-array.c
View File

@ -2631,10 +2631,11 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
&& TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
/* Use the actual tree type and not the wrapped coarray. */
se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
se->expr);
if (!se->want_pointer)
se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
se->expr);
}
return;

42
gcc/fortran/trans-decl.c
View File

@ -2104,6 +2104,48 @@ create_function_arglist (gfc_symbol * sym)
f->sym->backend_decl = parm;
/* Coarrays which do not use a descriptor 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
&& f->sym->as->type != AS_ASSUMED_SHAPE)
{
tree caf_type;
tree token;
tree offset;
gcc_assert (f->sym->backend_decl != NULL_TREE
&& !sym->attr.is_bind_c);
caf_type = TREE_TYPE (f->sym->backend_decl);
gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE);
token = build_decl (input_location, PARM_DECL,
create_tmp_var_name ("caf_token"),
build_qualified_type (pvoid_type_node,
TYPE_QUAL_RESTRICT));
GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token;
DECL_CONTEXT (token) = fndecl;
DECL_ARTIFICIAL (token) = 1;
DECL_ARG_TYPE (token) = TREE_VALUE (typelist);
TREE_READONLY (token) = 1;
hidden_arglist = chainon (hidden_arglist, token);
gfc_finish_decl (token);
gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) == NULL_TREE);
offset = build_decl (input_location, PARM_DECL,
create_tmp_var_name ("caf_offset"),
gfc_array_index_type);
GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) = offset;
DECL_CONTEXT (offset) = fndecl;
DECL_ARTIFICIAL (offset) = 1;
DECL_ARG_TYPE (offset) = TREE_VALUE (typelist);
TREE_READONLY (offset) = 1;
hidden_arglist = chainon (hidden_arglist, offset);
gfc_finish_decl (offset);
}
arglist = chainon (arglist, parm);
typelist = TREE_CHAIN (typelist);
}

81
gcc/fortran/trans-expr.c
View File

@ -261,6 +261,33 @@ gfc_get_expr_charlen (gfc_expr *e)
}
/* Return for an expression the backend decl of the coarray. */
static tree
get_tree_for_caf_expr (gfc_expr *expr)
{
tree caf_decl = NULL_TREE;
gfc_ref *ref;
gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
if (expr->symtree->n.sym->attr.codimension)
caf_decl = expr->symtree->n.sym->backend_decl;
for (ref = expr->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT)
{
gfc_component *comp = ref->u.c.component;
if (comp->attr.pointer || comp->attr.allocatable)
caf_decl = NULL_TREE;
if (comp->attr.codimension)
caf_decl = comp->backend_decl;
}
gcc_assert (caf_decl != NULL_TREE);
return caf_decl;
}
/* For each character array constructor subexpression without a ts.u.cl->length,
replace it by its first element (if there aren't any elements, the length
should already be set to zero). */
@ -2814,6 +2841,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
return 0;
}
/* Generate code for a procedure call. Note can return se->post != NULL.
If se->direct_byref is set then se->expr contains the return parameter.
Return nonzero, if the call has alternate specifiers.
@ -3362,6 +3390,59 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
VEC_safe_push (tree, gc, stringargs, parmse.string_length);
/* For descriptorless coarrays, we pass the token and the offset
as additional arguments. */
if (fsym && fsym->attr.codimension
&& gfc_option.coarray == GFC_FCOARRAY_LIB
&& !fsym->attr.allocatable && fsym->as->type != AS_ASSUMED_SHAPE
&& (e == NULL
|| GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (get_tree_for_caf_expr (e)))))
/* FIXME: Remove the "||" condition when coarray descriptors have a
"token" component. This condition occurs when passing an alloc
coarray or assumed-shape dummy to an explict-shape dummy. */
{
/* Token and offset. */
VEC_safe_push (tree, gc, stringargs, null_pointer_node);
VEC_safe_push (tree, gc, stringargs,
build_int_cst (gfc_array_index_type, 0));
gcc_assert (fsym->attr.optional || e != NULL); /* FIXME: "||" cond. */
}
else if (fsym && fsym->attr.codimension
&& !fsym->attr.allocatable && fsym->as->type != AS_ASSUMED_SHAPE
&& gfc_option.coarray == GFC_FCOARRAY_LIB)
{
tree caf_decl, caf_type;
tree offset;
caf_decl = get_tree_for_caf_expr (e);
caf_type = TREE_TYPE (caf_decl);
gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
&& GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
VEC_safe_push (tree, gc, stringargs,
GFC_TYPE_ARRAY_CAF_TOKEN (caf_type));
if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
else
offset = build_int_cst (gfc_array_index_type, 0);
gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl))
&& POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
fold_convert (gfc_array_index_type,
parmse.expr),
fold_convert (gfc_array_index_type,
caf_decl));
offset = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, offset, tmp);
VEC_safe_push (tree, gc, stringargs, offset);
}
VEC_safe_push (tree, gc, arglist, parmse.expr);
}
gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);

2
gcc/fortran/trans.h
View File

@ -736,6 +736,7 @@ struct GTY((variable_size)) lang_type {
tree base_decl[2];
tree nonrestricted_type;
tree caf_token;
tree caf_offset;
};
struct GTY((variable_size)) lang_decl {
@ -781,6 +782,7 @@ struct GTY((variable_size)) lang_decl {
#define GFC_TYPE_ARRAY_RANK(node) (TYPE_LANG_SPECIFIC(node)->rank)
#define GFC_TYPE_ARRAY_CORANK(node) (TYPE_LANG_SPECIFIC(node)->corank)
#define GFC_TYPE_ARRAY_CAF_TOKEN(node) (TYPE_LANG_SPECIFIC(node)->caf_token)
#define GFC_TYPE_ARRAY_CAF_OFFSET(node) (TYPE_LANG_SPECIFIC(node)->caf_offset)
#define GFC_TYPE_ARRAY_SIZE(node) (TYPE_LANG_SPECIFIC(node)->size)
#define GFC_TYPE_ARRAY_OFFSET(node) (TYPE_LANG_SPECIFIC(node)->offset)
#define GFC_TYPE_ARRAY_AKIND(node) (TYPE_LANG_SPECIFIC(node)->akind)

4
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,7 @@
2011-07-21 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/coarray_lib_token_1.f90: New.
2011-07-21 Georg-Johann Lay <avr@gjlay.de>
* gcc.dg/pr32912-2.c: Skip for AVR.

88
gcc/testsuite/gfortran.dg/coarray_lib_token_1.f90 Normal file
View File

@ -0,0 +1,88 @@
! { dg-do compile }
! { dg-options "-fcoarray=lib -fdump-tree-original" }
!
! Check whether TOKEN and OFFSET are correctly propagated
!
program main
implicit none
type t
integer(4) :: a, b
end type t
integer :: caf[*]
type(t) :: caf_dt[*]
caf = 42
caf_dt = t (1,2)
call sub (caf, caf_dt%b)
print *,caf, caf_dt%b
if (caf /= -99 .or. caf_dt%b /= -101) call abort ()
call sub_opt ()
call sub_opt (caf)
if (caf /= 124) call abort ()
contains
subroutine sub (x1, x2)
integer :: x1[*], x2[*]
call sub2 (x1, x2)
end subroutine sub
subroutine sub2 (y1, y2)
integer :: y1[*], y2[*]
print *, y1, y2
if (y1 /= 42 .or. y2 /= 2) call abort ()
y1 = -99
y2 = -101
end subroutine sub2
subroutine sub_opt (z)
integer, optional :: z[*]
if (present (z)) then
if (z /= -99) call abort ()
z = 124
end if
end subroutine sub_opt
end program main
! SCAN TREE DUMP AND CLEANUP
!
! PROTOTYPE 1:
!
! sub (integer(kind=4) * restrict x1, integer(kind=4) * restrict x2,
! void * restrict caf_token.4, integer(kind=8) caf_offset.5,
! void * restrict caf_token.6, integer(kind=8) caf_offset.7)
!
! { dg-final { scan-tree-dump-times "sub \\(integer.kind=4. . restrict x1, integer.kind=4. . restrict x2, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+\\)" 1 "original"} }
!
! PROTOTYPE 2:
!
! sub2 (integer(kind=4) * restrict y1, integer(kind=4) * restrict y2,
! void * restrict caf_token.0, integer(kind=8) caf_offset.1,
! void * restrict caf_token.2, integer(kind=8) caf_offset.3)
!
! { dg-final { scan-tree-dump-times "sub2 \\(integer.kind=4. . restrict y1, integer.kind=4. . restrict y2, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+\\)" 1 "original"} }
!
! CALL 1
!
! sub ((integer(kind=4) *) caf, &caf_dt->b, caf_token.9, 0, caf_token.10, 4);
!
! { dg-final { scan-tree-dump-times "sub \\(\[^,\]*caf, &caf_dt->b, caf_token.\[0-9\]+, 0, caf_token.\[0-9\]+, 4\\)" 1 "original"} }
!
! sub2 ((integer(kind=4) *) x1, (integer(kind=4) *) x2,
! caf_token.4, NON_LVALUE_EXPR <caf_offset.5>,
! caf_token.6, NON_LVALUE_EXPR <caf_offset.7>);
!
! { dg-final { scan-tree-dump-times "sub2 \\(\[^,\]*x1, \[^,\]*x2, caf_token.\[0-9]+, \[^,\]*caf_offset\[^,\]*, caf_token.\[0-9\]+, \[^,\]*caf_offset\[^,\]*\\)" 1 "original"} }
!
! CALL 3
!
! { dg-final { scan-tree-dump-times "sub_opt \\(0B, 0B, 0\\)" 1 "original"} }
!
! CALL 4
!
! { dg-final { scan-tree-dump-times "sub_opt \\(.integer.kind=4. .. caf, caf_token.\[0-9\]+, 0\\)" 1 "original"} }
!
! { dg-final { cleanup-tree-dump "original" } }