From: Tobias Burnus Date: Thu, 21 Jul 2011 12:00:25 +0000 (+0200) Subject: check.c (gfc_check_present): Allow coarrays. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=0c53708eadd727f4089028e09840865db25a3cd9;p=gcc.git check.c (gfc_check_present): Allow coarrays. 2011-07-21 Tobias Burnus * 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 * gfortran.dg/coarray_lib_token_1.f90: New. From-SVN: r176562 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index bf911123455..1e9bb56b4d6 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,17 @@ +2011-07-21 Tobias Burnus + + * 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 * expr.c (gfc_is_coarray): New function. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 79e1c95b9e1..a95865b9bc6 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -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, diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 4ec892b74c7..9caa17fad04 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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; diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 65a8efac6b3..12c5262218d 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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); } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 26d43980ff9..76229102436 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index c56aff8ddd0..48e054f2342 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -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) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a02aec8eaf1..d0df27b5413 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2011-07-21 Tobias Burnus + + * gfortran.dg/coarray_lib_token_1.f90: New. + 2011-07-21 Georg-Johann Lay * gcc.dg/pr32912-2.c: Skip for AVR. diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_token_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_token_1.f90 new file mode 100644 index 00000000000..648a6a337a9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_lib_token_1.f90 @@ -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_token.6, NON_LVALUE_EXPR ); +! +! { 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" } }