From 8f4ee36bd5248cd244f65282167e3a13a3c98bc2 Mon Sep 17 00:00:00 2001 From: Andre Vehreschild Date: Mon, 7 Apr 2025 09:36:24 +0200 Subject: Fortran: Improve F2018 TEAM handling [PR87326, PR87556, PR88254, PR103896] Improve the implementation of F2018 TEAM handling routines. Add runtime-functions to caf_single to allow testing. PR fortran/87326 PR fortran/87556 PR fortran/88254 PR fortran/103796 gcc/fortran/ChangeLog: * coarray.cc (split_expr_at_caf_ref): Treat polymorphic types correctly. Ensure resolve of expression after coindex. (create_allocated_callback): Fix parameter of allocated function for coarrays. (coindexed_expr_callback): Improve detection of coarrays in allocated function. * decl.cc (gfc_match_end): Add team block matching. * dump-parse-tree.cc (show_code_node): Dump change team block as such. * frontend-passes.cc (gfc_code_walker): Recognice team block. * gfortran.texi: Add documentation for team api functions. * intrinsic.texi: Add documentation about team_type in iso_fortran_env module. * iso-fortran-env.def (team_type): Use helper to get pointer kind. * match.cc (gfc_match_associate): Factor out matching of association list, because it is used in change team as well. (check_coarray_assoc): Ensure, that the association is to a coarray. (match_association_list): Match a list of association either in associate or in change team. (gfc_match_form_team): Match form team correctly include new_index. (gfc_match_change_team): Match change team with association list. (gfc_match_end_team): Match end team including stat and errmsg. (gfc_match_return): Prevent return from team block. * parse.cc (decode_statement): Sort team block. (next_statement): Same. (check_statement_label): Same. (accept_statement): Same. (verify_st_order): Same. (parse_associate): Renamed to move_associates_to_block... (move_associates_to_block): ... to enable reuse for change team. (parse_change_team): Parse it as block. (parse_executable): Same. * parse.h (enum gfc_compile_state): Add team block as compiler state. * resolve.cc (resolve_scalar_argument): New function to resolve an argument to a statement as a scalar. (resolve_form_team): Resolve its members. (resolve_change_team): Same. (resolve_branch): Prevent branch from jumping out of team block. (check_team): Removed. * trans-decl.cc (gfc_build_builtin_function_decls): Add stat and errmsg to team API functions and update their arguments. * trans-expr.cc (gfc_trans_subcomponent_assign): Also null the token when moving memory or an allocated() will not detect a free. * trans-intrinsic.cc (gfc_conv_intrinsic_caf_is_present_remote): Adapt to signature change no longer a pointer-pointer. * trans-stmt.cc (gfc_trans_form_team): Translate a form team including new_index. (gfc_trans_change_team): Translate a change team as a block. libgfortran/ChangeLog: * caf/libcaf.h: Remove commented block. (_gfortran_caf_form_team): Allow for all relevant arguments. (_gfortran_caf_change_team): Same. (_gfortran_caf_end_team): Same. (_gfortran_caf_sync_team): Same. * caf/single.c (struct caf_single_team): Team handling structures. (_gfortran_caf_init): Initialize initial team. (free_team_list): Free all teams and the memory they hold. (_gfortran_caf_finalize): Free initial and sibling teams. (_gfortran_caf_register): Add memory registered to current team. (_gfortran_caf_deregister): Unregister memory from current team. (_gfortran_caf_is_present_on_remote): Check token's memptr for llocation. May have been deallocated by an end team. (_gfortran_caf_form_team): Push a new team stub to the list. (_gfortran_caf_change_team): Push a formed team on top of the ctive teams stack. (_gfortran_caf_end_team): End the active team, free all memory allocated during its livespan. (_gfortran_caf_sync_team): Take stat and errmsg into account. gcc/testsuite/ChangeLog: * gfortran.dg/team_change_2.f90: New test. * gfortran.dg/team_change_3.f90: New test. * gfortran.dg/team_end_2.f90: New test. * gfortran.dg/team_end_3.f90: New test. * gfortran.dg/team_form_2.f90: New test. * gfortran.dg/team_form_3.f90: New test. * gfortran.dg/team_sync_2.f90: New test. --- gcc/fortran/resolve.cc | 89 ++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 64 insertions(+), 25 deletions(-) (limited to 'gcc/fortran/resolve.cc') diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index e9053b4..e51f83b 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -11519,6 +11519,62 @@ gfc_resolve_sync_stat (struct sync_stat *sync_stat) gfc_default_character_kind, sync_stat->errmsg); } + +static void +resolve_scalar_argument (const char *name, bt exp_type, int exp_kind, + gfc_expr *e) +{ + gfc_resolve_expr (e); + if (e + && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0)) + gfc_error ("%s argument at %L must be a scalar %s of at least kind %d", + name, &e->where, gfc_basic_typename (exp_type), exp_kind); +} + +static void +resolve_form_team (gfc_code *code) +{ + resolve_scalar_argument ("TEAM NUMBER", BT_INTEGER, gfc_default_integer_kind, + code->expr1); + resolve_team_argument (code->expr2); + resolve_scalar_argument ("NEW_INDEX=", BT_INTEGER, gfc_default_integer_kind, + code->expr3); + gfc_resolve_sync_stat (&code->ext.sync_stat); +} + +static void resolve_block_construct (gfc_code *); + +static void +resolve_change_team (gfc_code *code) +{ + resolve_team_argument (code->expr1); + gfc_resolve_sync_stat (&code->ext.block.sync_stat); + resolve_block_construct (code); + /* Map the coarray bounds as selected. */ + for (gfc_association_list *a = code->ext.block.assoc; a; a = a->next) + if (a->ar) + { + gfc_array_spec *src = a->ar->as, *dst; + if (a->st->n.sym->ts.type == BT_CLASS) + dst = CLASS_DATA (a->st->n.sym)->as; + else + dst = a->st->n.sym->as; + dst->corank = src->corank; + dst->cotype = src->cotype; + for (int i = 0; i < src->corank; ++i) + { + dst->lower[dst->rank + i] = src->lower[i]; + dst->upper[dst->rank + i] = src->upper[i]; + src->lower[i] = src->upper[i] = nullptr; + } + gfc_free_array_spec (src); + free (a->ar); + a->ar = nullptr; + dst->resolved = false; + gfc_resolve_array_spec (dst, 0); + } +} + static void resolve_sync_team (gfc_code *code) { @@ -11665,8 +11721,8 @@ resolve_branch (gfc_st_label *label, gfc_code *code) if (code->here == label) { - gfc_warning (0, - "Branch at %L may result in an infinite loop", &code->loc); + gfc_warning (0, "Branch at %L may result in an infinite loop", + &code->loc); return; } @@ -11689,6 +11745,10 @@ resolve_branch (gfc_st_label *label, gfc_code *code) && bitmap_bit_p (stack->reachable_labels, label->value)) gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct " "for label at %L", &code->loc, &label->where); + else if (stack->current->op == EXEC_CHANGE_TEAM + && bitmap_bit_p (stack->reachable_labels, label->value)) + gfc_error ("GOTO statement at %L leaves CHANGE TEAM construct " + "for label at %L", &code->loc, &label->where); } return; @@ -13325,23 +13385,6 @@ deferred_op_assign (gfc_code **code, gfc_namespace *ns) } -static bool -check_team (gfc_expr *team, const char *intrinsic) -{ - if (team->rank != 0 - || team->ts.type != BT_DERIVED - || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV - || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE) - { - gfc_error ("TEAM argument to %qs at %L must be a scalar expression " - "of type TEAM_TYPE", intrinsic, &team->where); - return false; - } - - return true; -} - - /* Given a block of code, recursively resolve everything pointed to by this code block. */ @@ -13530,15 +13573,11 @@ start: break; case EXEC_FORM_TEAM: - if (code->expr1 != NULL - && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank)) - gfc_error ("TEAM NUMBER argument to FORM TEAM at %L must be " - "a scalar INTEGER", &code->expr1->where); - check_team (code->expr2, "FORM TEAM"); + resolve_form_team (code); break; case EXEC_CHANGE_TEAM: - check_team (code->expr1, "CHANGE TEAM"); + resolve_change_team (code); break; case EXEC_END_TEAM: -- cgit v1.1