From 1be1970f97d05a07851cd826132fcf466827ebe5 Mon Sep 17 00:00:00 2001 From: Andre Vehreschild Date: Fri, 14 Mar 2025 14:20:18 +0100 Subject: Fortran: Unify handling of STAT= and ERRMSG= optional arguments [PR87939] In preparing F2018 Teams handling improvements, unify handling of STAT= and ERRMSG= optional arguments. Handling of stat and errmsg in most teams statements is corrected in the next patch. Implement stat and errmsg for move_alloc () to comply with F2018. PR fortran/87939 gcc/fortran/ChangeLog: * check.cc (gfc_check_move_alloc): Add stat and errmsg to move_alloc. * dump-parse-tree.cc (show_sync_stat): New helper function. (show_code_node): Use show_sync_stat to print stat and errmsg. * gfortran.h (struct sync_stat): New struct to unify stat and errmsg handling. * intrinsic.cc (add_subroutines): Correct signature of move_alloc. * intrinsic.h (gfc_check_move_alloc): Correct signature of check_move_alloc. * match.cc (match_named_arg): Match an optional argument to a statement. (match_stat_errmsg): Match a stat= or errmsg= named argument. (gfc_match_critical): Use match_stat_errmsg to match the named arguments. (gfc_match_sync_team): Same. * resolve.cc (resolve_team_argument): Resolve an expr to have type TEAM_TYPE from iso_fortran_env. (resolve_scalar_variable_as_arg): Resolve an argument as a scalar type. (resolve_sync_stat): Resolve stat and errmsg expressions. (resolve_sync_team): Resolve a sync team statement using sync_stat helper. (resolve_end_team): Same. (resolve_critical): Same. * trans-decl.cc (gfc_build_builtin_function_decls): Correct sync_team signature. * trans-intrinsic.cc (conv_intrinsic_move_alloc): Store stat an errmsg optional arguments in helper struct and use helper to translate. * trans-stmt.cc (trans_exit): Implement DRY pattern for generating an _exit(). (gfc_trans_sync_stat): Translate stat and errmsg contents. (gfc_trans_end_team): Use helper to translate stat and errmsg. (gfc_trans_sync_team): Same. (gfc_trans_critical): Same. * trans-stmt.h (gfc_trans_sync_stat): New function. * trans.cc (gfc_deallocate_with_status): Parameterize check at runtime to allow unallocated (co-)array when freeing a structure. (gfc_deallocate_scalar_with_status): Same and also add errmsg. * trans.h (gfc_deallocate_with_status): Signature changes. (gfc_deallocate_scalar_with_status): Same. libgfortran/ChangeLog: * caf/single.c (_gfortran_caf_lock): Correct stat value, if lock is already locked by current image. (_gfortran_caf_unlock): Correct stat value, if lock is not locked. gcc/testsuite/ChangeLog: * gfortran.dg/coarray_critical_2.f90: New test. * gfortran.dg/coarray_critical_3.f90: New test. * gfortran.dg/team_sync_1.f90: New test. * gfortran.dg/move_alloc_11.f90: New test. --- gcc/fortran/resolve.cc | 52 +++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 51 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/resolve.cc') diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index f03708e..e9053b4 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -11484,6 +11484,53 @@ resolve_lock_unlock_event (gfc_code *code) } } +static void +resolve_team_argument (gfc_expr *team) +{ + gfc_resolve_expr (team); + 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 at %L must be a scalar expression " + "of type TEAM_TYPE from the intrinsic module ISO_FORTRAN_ENV", + &team->where); + } +} + +static void +resolve_scalar_variable_as_arg (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 + || e->expr_type != EXPR_VARIABLE)) + gfc_error ("%s argument at %L must be a scalar %s variable of at least " + "kind %d", name, &e->where, gfc_basic_typename (exp_type), + exp_kind); +} + +void +gfc_resolve_sync_stat (struct sync_stat *sync_stat) +{ + resolve_scalar_variable_as_arg ("STAT=", BT_INTEGER, 2, sync_stat->stat); + resolve_scalar_variable_as_arg ("ERRMSG=", BT_CHARACTER, + gfc_default_character_kind, + sync_stat->errmsg); +} +static void +resolve_sync_team (gfc_code *code) +{ + resolve_team_argument (code->expr1); + gfc_resolve_sync_stat (&code->ext.sync_stat); +} + +static void +resolve_end_team (gfc_code *code) +{ + gfc_resolve_sync_stat (&code->ext.sync_stat); +} static void resolve_critical (gfc_code *code) @@ -11493,6 +11540,8 @@ resolve_critical (gfc_code *code) char name[GFC_MAX_SYMBOL_LEN]; static int serial = 0; + gfc_resolve_sync_stat (&code->ext.sync_stat); + if (flag_coarray != GFC_FCOARRAY_LIB) return; @@ -13493,10 +13542,11 @@ start: break; case EXEC_END_TEAM: + resolve_end_team (code); break; case EXEC_SYNC_TEAM: - check_team (code->expr1, "SYNC TEAM"); + resolve_sync_team (code); break; case EXEC_ENTRY: -- cgit v1.1