commit 1db7977a0f867bbb3a1fe5db9a29311e5a8b77dc Author: Alessandro Fanfarillo Date: Mon Jun 13 11:03:15 2016 -0600 Working patch for stat= in get and send diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 1430e80..232bae7 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -156,6 +156,7 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init, { match m; bool matched_bracket = false; + gfc_expr *tmp; memset (ar, '\0', sizeof (*ar)); @@ -226,6 +227,11 @@ coarray: if (m == MATCH_ERROR) return MATCH_ERROR; + if(gfc_match(",stat=%e",&tmp) == MATCH_YES) + ar->stat = tmp; + else + ar->stat = NULL; + if (gfc_match_char (']') == MATCH_YES) { ar->codimen++; @@ -237,6 +243,11 @@ coarray: } if (ar->codimen > corank) { + if(ar->stat) + { + ar->codimen--; + return MATCH_YES; + } gfc_error ("Too many codimensions at %C, expected %d not %d", corank, ar->codimen); return MATCH_ERROR; diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index d1258cd..34a3557 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4428,6 +4428,16 @@ gfc_ref_this_image (gfc_ref *ref) return true; } +gfc_expr * +gfc_find_stat_co(gfc_expr *e) +{ + gfc_ref *ref; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + return ref->u.ar.stat; + return NULL; +} bool gfc_is_coindexed (gfc_expr *e) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 6d87632..2f22c32 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1816,6 +1816,7 @@ typedef struct gfc_array_ref int dimen; /* # of components in the reference */ int codimen; bool in_allocate; /* For coarray checks. */ + gfc_expr *stat; locus where; gfc_array_spec *as; @@ -3067,7 +3068,7 @@ bool gfc_is_coarray (gfc_expr *); int gfc_get_corank (gfc_expr *); bool gfc_has_ultimate_allocatable (gfc_expr *); bool gfc_has_ultimate_pointer (gfc_expr *); - +gfc_expr* gfc_find_stat_co (gfc_expr *); gfc_expr* gfc_build_intrinsic_call (gfc_namespace *, gfc_isym_id, const char*, locus, unsigned, ...); bool gfc_check_vardef_context (gfc_expr*, bool, bool, bool, const char*); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index f56bdf1..54be70e 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4169,7 +4169,7 @@ compare_spec_to_ref (gfc_array_ref *ar) } /* ar->codimen == 0 is a local array. */ - if (as->corank != ar->codimen && ar->codimen != 0) + if (as->corank != ar->codimen && ar->codimen != 0 && !ar->stat) { gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)", &ar->where, ar->codimen, as->corank); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 04339a6..1ee548a 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -3529,16 +3529,16 @@ gfc_build_builtin_function_decls (void) ppvoid_type_node, pint_type, pchar_type_node, integer_type_node); gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_get")), ".R.RRRW", void_type_node, 9, + get_identifier (PREFIX("caf_get")), ".R.RRRW", void_type_node, 10, pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node, pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node, - boolean_type_node); + integer_type_node, boolean_type_node); gfor_fndecl_caf_send = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_send")), ".R.RRRR", void_type_node, 9, + get_identifier (PREFIX("caf_send")), ".R.RRRR", void_type_node, 10, pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node, pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node, - boolean_type_node); + pint_type, boolean_type_node); gfor_fndecl_caf_sendget = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_sendget")), ".R.RRRR.RRR", void_type_node, diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index e5cc907..7d8123b 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1100,10 +1100,10 @@ static void gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, tree may_require_tmp) { - gfc_expr *array_expr; + gfc_expr *array_expr, *tmp_stat; gfc_se argse; tree caf_decl, token, offset, image_index, tmp; - tree res_var, dst_var, type, kind, vec; + tree res_var, dst_var, type, kind, vec, stat; gcc_assert (flag_coarray == GFC_FCOARRAY_LIB); @@ -1122,6 +1122,16 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, dst_var = lhs; vec = null_pointer_node; + tmp_stat = gfc_find_stat_co(expr); + + if(tmp_stat) + { + gfc_conv_expr_val (se, tmp_stat); + stat = se->expr; + stat = gfc_build_addr_expr (NULL, stat); + } + else + stat = null_pointer_node; gfc_init_se (&argse, NULL); if (array_expr->rank == 0) @@ -1219,9 +1229,9 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, ASM_VOLATILE_P (tmp) = 1; gfc_add_expr_to_block (&se->pre, tmp); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 9, + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 10, token, offset, image_index, argse.expr, vec, - dst_var, kind, lhs_kind, may_require_tmp); + dst_var, kind, lhs_kind, stat, may_require_tmp); gfc_add_expr_to_block (&se->pre, tmp); if (se->ss) @@ -1237,11 +1247,11 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, static tree conv_caf_send (gfc_code *code) { - gfc_expr *lhs_expr, *rhs_expr; + gfc_expr *lhs_expr, *rhs_expr, *tmp_stat; gfc_se lhs_se, rhs_se; stmtblock_t block; tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind; - tree may_require_tmp; + tree may_require_tmp, stat; tree lhs_type = NULL_TREE; tree vec = null_pointer_node, rhs_vec = null_pointer_node; @@ -1253,6 +1263,8 @@ conv_caf_send (gfc_code *code) { ? boolean_false_node : boolean_true_node; gfc_init_block (&block); + stat = null_pointer_node; + /* LHS. */ gfc_init_se (&lhs_se, NULL); if (lhs_expr->rank == 0) @@ -1375,10 +1387,24 @@ conv_caf_send (gfc_code *code) { rhs_kind = build_int_cst (integer_type_node, rhs_expr->ts.kind); + tmp_stat = gfc_find_stat_co(lhs_expr); + + if(tmp_stat) + { + gfc_se stat_se; + gfc_init_se (&stat_se, NULL); + gfc_conv_expr_val (&stat_se, tmp_stat); + stat = stat_se.expr; + stat = gfc_build_addr_expr (NULL, stat); + } + else + stat = null_pointer_node; + if (!gfc_is_coindexed (rhs_expr)) - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 9, token, - offset, image_index, lhs_se.expr, vec, - rhs_se.expr, lhs_kind, rhs_kind, may_require_tmp); + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 10, token, + offset, image_index, lhs_se.expr, vec, + rhs_se.expr, lhs_kind, rhs_kind, stat, + may_require_tmp); else { tree rhs_token, rhs_offset, rhs_image_index;