diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/check.cc | 262 | ||||
| -rw-r--r-- | gcc/fortran/coarray.cc | 12 | ||||
| -rw-r--r-- | gcc/fortran/decl.cc | 20 | ||||
| -rw-r--r-- | gcc/fortran/dump-parse-tree.cc | 53 | ||||
| -rw-r--r-- | gcc/fortran/expr.cc | 8 | ||||
| -rw-r--r-- | gcc/fortran/frontend-passes.cc | 1 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 9 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.texi | 238 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.cc | 85 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.h | 17 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.texi | 191 | ||||
| -rw-r--r-- | gcc/fortran/iresolve.cc | 48 | ||||
| -rw-r--r-- | gcc/fortran/iso-fortran-env.def | 26 | ||||
| -rw-r--r-- | gcc/fortran/libgfortran.h | 10 | ||||
| -rw-r--r-- | gcc/fortran/match.cc | 405 | ||||
| -rw-r--r-- | gcc/fortran/parse.cc | 143 | ||||
| -rw-r--r-- | gcc/fortran/parse.h | 2 | ||||
| -rw-r--r-- | gcc/fortran/resolve.cc | 141 | ||||
| -rw-r--r-- | gcc/fortran/simplify.cc | 25 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.cc | 52 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.cc | 13 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.cc | 195 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.cc | 304 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.h | 1 | ||||
| -rw-r--r-- | gcc/fortran/trans.cc | 46 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 15 |
26 files changed, 1687 insertions, 635 deletions
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 9c66c25..356e0d7 100644 --- a/gcc/fortran/check.cc +++ b/gcc/fortran/check.cc @@ -1809,6 +1809,23 @@ gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom, gfc_expr *stat) return gfc_check_atomic (atom, 1, value, 0, stat, 2); } +bool +team_type_check (gfc_expr *e, int n) +{ + if (e->ts.type != BT_DERIVED || !e->ts.u.derived + || e->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV + || e->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE) + { + gfc_error ("%qs argument of %qs intrinsic at %L shall be of type " + "%<team_type%> from the intrinsic module " + "%<ISO_FORTRAN_ENV%>", + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &e->where); + return false; + } + + return true; +} bool gfc_check_image_status (gfc_expr *image, gfc_expr *team) @@ -1818,14 +1835,7 @@ gfc_check_image_status (gfc_expr *image, gfc_expr *team) || !positive_check (0, image)) return false; - if (team) - { - gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", - gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, - &team->where); - return false; - } - return true; + return !team || (scalar_check (team, 0) && team_type_check (team, 0)); } @@ -1905,10 +1915,25 @@ gfc_check_get_team (gfc_expr *level) { if (level) { - gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", - gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, - &level->where); - return false; + int l; + + if (!type_check (level, 0, BT_INTEGER) || !scalar_check (level, 0)) + return false; + + /* When level is a constant, try to extract it. If not, the runtime has + to check. */ + if (gfc_extract_int (level, &l, 0)) + return true; + + if (l < GFC_CAF_INITIAL_TEAM || l > GFC_CAF_CURRENT_TEAM) + { + gfc_error ("%qs argument of %qs intrinsic at %L shall specify one of " + "the INITIAL_TEAM, PARENT_TEAM or CURRENT_TEAM constants " + "from the intrinsic module ISO_FORTRAN_ENV", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &level->where); + return false; + } } return true; } @@ -4683,8 +4708,18 @@ gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask) bool -gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) +gfc_check_move_alloc (gfc_expr *from, gfc_expr *to, gfc_expr *stat, + gfc_expr *errmsg) { + struct sync_stat sync_stat = {stat, errmsg}; + + if ((stat || errmsg) + && !gfc_notify_std (GFC_STD_F2008, "STAT= or ERRMSG= at %L not supported", + &to->where)) + return false; + + gfc_resolve_sync_stat (&sync_stat); + if (!variable_check (from, 0, false)) return false; if (!allocatable_check (from, 0)) @@ -6530,7 +6565,8 @@ gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status) bool -gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub) +gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub, + gfc_expr *team_or_team_number) { mpz_t nelems; @@ -6550,12 +6586,8 @@ gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub) return false; } - if (sub->ts.type != BT_INTEGER) - { - gfc_error ("Type of %s argument of IMAGE_INDEX at %L shall be INTEGER", - gfc_current_intrinsic_arg[1]->name, &sub->where); - return false; - } + if (!type_check (sub, 1, BT_INTEGER)) + return false; if (gfc_array_size (sub, &nelems)) { @@ -6570,12 +6602,23 @@ gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub) mpz_clear (nelems); } + if (team_or_team_number) + { + if (!type_check2 (team_or_team_number, 2, BT_DERIVED, BT_INTEGER) + || !scalar_check (team_or_team_number, 2)) + return false; + + /* Check team is of team_type. */ + if (team_or_team_number->ts.type == BT_DERIVED + && !team_type_check (team_or_team_number, 2)) + return false; + } + return true; } - bool -gfc_check_num_images (gfc_expr *distance, gfc_expr *failed) +gfc_check_num_images (gfc_expr *team_or_team_number) { if (flag_coarray == GFC_FCOARRAY_NONE) { @@ -6583,34 +6626,21 @@ gfc_check_num_images (gfc_expr *distance, gfc_expr *failed) return false; } - if (distance) - { - if (!type_check (distance, 0, BT_INTEGER)) - return false; - - if (!nonnegative_check ("DISTANCE", distance)) - return false; - - if (!scalar_check (distance, 0)) - return false; - - if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to " - "NUM_IMAGES at %L", &distance->where)) - return false; - } + if (!team_or_team_number) + return true; - if (failed) - { - if (!type_check (failed, 1, BT_LOGICAL)) - return false; + if (!gfc_notify_std (GFC_STD_F2008, + "%<team%> or %<team_number%> argument to %qs at %L", + gfc_current_intrinsic, &team_or_team_number->where)) + return false; - if (!scalar_check (failed, 1)) - return false; + if (!type_check2 (team_or_team_number, 0, BT_DERIVED, BT_INTEGER) + || !scalar_check (team_or_team_number, 0)) + return false; - if (!gfc_notify_std (GFC_STD_F2018, "FAILED= argument to " - "NUM_IMAGES at %L", &failed->where)) - return false; - } + if (team_or_team_number->ts.type == BT_DERIVED + && !team_type_check (team_or_team_number, 0)) + return false; return true; } @@ -6625,94 +6655,120 @@ gfc_check_team_number (gfc_expr *team) return false; } - if (team) - { - if (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 to the intrinsic TEAM_NUMBER " - "shall be of type TEAM_TYPE", &team->where); - return false; - } - } - else - return true; - - return true; + return !team || (scalar_check (team, 0) && team_type_check (team, 0)); } bool -gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim, gfc_expr *distance) +gfc_check_this_image (gfc_actual_arglist *args) { + gfc_expr *coarray, *dim, *team, *cur; + + coarray = dim = team = NULL; + if (flag_coarray == GFC_FCOARRAY_NONE) { gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); return false; } - if (coarray == NULL && dim == NULL && distance == NULL) + /* Shortcut when no arguments are given. */ + if (!args->expr && !args->next->expr && !args->next->next->expr) return true; - if (dim != NULL && coarray == NULL) - { - gfc_error ("DIM argument without COARRAY argument not allowed for " - "THIS_IMAGE intrinsic at %L", &dim->where); - return false; - } + cur = args->expr; - if (distance && (coarray || dim)) + if (cur) { - gfc_error ("The DISTANCE argument may not be specified together with the " - "COARRAY or DIM argument in intrinsic at %L", - &distance->where); - return false; + gfc_push_suppress_errors (); + if (coarray_check (cur, 0)) + coarray = cur; + else if (scalar_check (cur, 2) && team_type_check (cur, 2)) + team = cur; + else + { + gfc_pop_suppress_errors (); + gfc_error ("First argument of %<this_image%> intrinsic at %L must be " + "a coarray " + "variable or an object of type %<team_type%> from the " + "intrinsic module " + "%<ISO_FORTRAN_ENV%>", + &cur->where); + return false; + } + gfc_pop_suppress_errors (); } - /* Assume that we have "this_image (distance)". */ - if (coarray && !gfc_is_coarray (coarray) && coarray->ts.type == BT_INTEGER) + cur = args->next->expr; + if (cur) { - if (dim) + gfc_push_suppress_errors (); + if (dim_check (cur, 1, true) && cur->corank == 0) + dim = cur; + else if (scalar_check (cur, 2) && team_type_check (cur, 2)) + { + if (team) + { + gfc_pop_suppress_errors (); + goto team_type_error; + } + team = cur; + } + else { - gfc_error ("Unexpected DIM argument with noncoarray argument at %L", - &coarray->where); + gfc_pop_suppress_errors (); + gfc_error ("Second argument of %<this_image%> intrinsic at %L must " + "be an %<INTEGER%> " + "typed scalar or an object of type %<team_type%> from the " + "intrinsic " + "module %<ISO_FORTRAN_ENV%>", + &cur->where); return false; } - distance = coarray; + gfc_pop_suppress_errors (); } - if (distance) + cur = args->next->next->expr; + if (cur) { - if (!type_check (distance, 2, BT_INTEGER)) - return false; - - if (!nonnegative_check ("DISTANCE", distance)) - return false; - - if (!scalar_check (distance, 2)) - return false; - - if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to " - "THIS_IMAGE at %L", &distance->where)) + if (team_type_check (cur, 2) && scalar_check (cur, 2)) + { + if (team) + goto team_type_error; + team = cur; + } + else return false; + } - return true; + if (dim != NULL && coarray == NULL) + { + gfc_error ("%<dim%> argument without %<coarray%> argument not allowed " + "for %<this_image%> intrinsic at %L", + &dim->where); + return false; } - if (!coarray_check (coarray, 0)) + if (dim && !dim_corank_check (dim, coarray)) return false; - if (dim != NULL) - { - if (!dim_check (dim, 1, false)) - return false; - - if (!dim_corank_check (dim, coarray)) - return false; - } + if (team + && !gfc_notify_std (GFC_STD_F2018, + "%<team%> argument to %<this_image%> at %L", + &team->where)) + return false; + args->expr = coarray; + args->next->expr = dim; + args->next->next->expr = team; return true; + +team_type_error: + gfc_error ( + "At most one argument of type %<team_type%> from the intrinsic module " + "%<ISO_FORTRAN_ENV%> to %<this_image%> at %L allowed", + &cur->where); + return false; } /* Calculate the sizes for transfer, used by gfc_check_transfer and also diff --git a/gcc/fortran/coarray.cc b/gcc/fortran/coarray.cc index 7058325..2f067f8 100644 --- a/gcc/fortran/coarray.cc +++ b/gcc/fortran/coarray.cc @@ -357,7 +357,9 @@ split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns, gcc_assert (expr->expr_type == EXPR_VARIABLE); caf_ts = &expr->symtree->n.sym->ts; - if (!expr->symtree->n.sym->attr.codimension) + if (!(expr->symtree->n.sym->ts.type == BT_CLASS + ? CLASS_DATA (expr->symtree->n.sym)->attr.codimension + : expr->symtree->n.sym->attr.codimension)) { /* The coarray is in some component. Find it. */ caf_ref = expr->ref; @@ -432,6 +434,9 @@ split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns, else if (base->ts.type == BT_CLASS) convert_coarray_class_to_derived_type (base, ns); + memset (&(*post_caf_ref_expr)->ts, 0, sizeof (gfc_typespec)); + gfc_resolve_expr (*post_caf_ref_expr); + (*post_caf_ref_expr)->corank = 0; gfc_expression_rank (*post_caf_ref_expr); if (for_send) gfc_expression_rank (expr); @@ -1130,8 +1135,8 @@ create_allocated_callback (gfc_expr *expr) // ADD_ARG (expr->symtree->name, base, BT_VOID, INTENT_IN); base = post_caf_ref_expr->symtree->n.sym; + base->attr.pointer = !base->attr.dimension; gfc_set_sym_referenced (base); - gfc_commit_symbol (base); *argptr = gfc_get_formal_arglist (); (*argptr)->sym = base; argptr = &(*argptr)->next; @@ -1420,7 +1425,8 @@ coindexed_expr_callback (gfc_expr **e, int *walk_subtrees, { case GFC_ISYM_ALLOCATED: if ((*e)->value.function.actual->expr - && gfc_is_coindexed ((*e)->value.function.actual->expr)) + && (gfc_is_coarray ((*e)->value.function.actual->expr) + || gfc_is_coindexed ((*e)->value.function.actual->expr))) { rewrite_caf_allocated (e); *walk_subtrees = 0; diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index feb454e..69acd2d 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -8459,6 +8459,7 @@ gfc_match_end (gfc_statement *st) { case COMP_ASSOCIATE: case COMP_BLOCK: + case COMP_CHANGE_TEAM: if (startswith (block_name, "block@")) block_name = NULL; break; @@ -8515,7 +8516,7 @@ gfc_match_end (gfc_statement *st) case COMP_SUBROUTINE: *st = ST_END_SUBROUTINE; if (!abbreviated_modproc_decl) - target = " subroutine"; + target = " subroutine"; else target = " procedure"; eos_ok = !contained_procedure (); @@ -8524,7 +8525,7 @@ gfc_match_end (gfc_statement *st) case COMP_FUNCTION: *st = ST_END_FUNCTION; if (!abbreviated_modproc_decl) - target = " function"; + target = " function"; else target = " procedure"; eos_ok = !contained_procedure (); @@ -8646,6 +8647,12 @@ gfc_match_end (gfc_statement *st) eos_ok = 0; break; + case COMP_CHANGE_TEAM: + *st = ST_END_TEAM; + target = " team"; + eos_ok = 0; + break; + default: gfc_error ("Unexpected END statement at %C"); goto cleanup; @@ -8683,14 +8690,19 @@ gfc_match_end (gfc_statement *st) else got_matching_end = true; + if (*st == ST_END_TEAM && gfc_match_end_team () == MATCH_ERROR) + /* Emit errors of stat and errmsg parsing now to finish the block and + continue analysis of compilation unit. */ + gfc_error_check (); + old_loc = gfc_current_locus; /* If we're at the end, make sure a block name wasn't required. */ if (gfc_match_eos () == MATCH_YES) { - if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK - && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL) + && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL + && *st != ST_END_TEAM) return MATCH_YES; if (!block_name) diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index 9501bcc..dd920f3 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -2607,6 +2607,20 @@ show_omp_node (int level, gfc_code *c) fprintf (dumpfile, " (%s)", c->ext.omp_clauses->critical_name); } +static void +show_sync_stat (struct sync_stat *sync_stat) +{ + if (sync_stat->stat) + { + fputs (" stat=", dumpfile); + show_expr (sync_stat->stat); + } + if (sync_stat->errmsg) + { + fputs (" errmsg=", dumpfile); + show_expr (sync_stat->errmsg); + } +} /* Show a single code node and everything underneath it if necessary. */ @@ -2755,20 +2769,27 @@ show_code_node (int level, gfc_code *c) fputs ("FAIL IMAGE ", dumpfile); break; - case EXEC_CHANGE_TEAM: - fputs ("CHANGE TEAM", dumpfile); - break; - case EXEC_END_TEAM: fputs ("END TEAM", dumpfile); + show_sync_stat (&c->ext.sync_stat); break; case EXEC_FORM_TEAM: - fputs ("FORM TEAM", dumpfile); + fputs ("FORM TEAM ", dumpfile); + show_expr (c->expr1); + show_expr (c->expr2); + if (c->expr3) + { + fputs (" NEW_INDEX", dumpfile); + show_expr (c->expr3); + } + show_sync_stat (&c->ext.sync_stat); break; case EXEC_SYNC_TEAM: - fputs ("SYNC TEAM", dumpfile); + fputs ("SYNC TEAM ", dumpfile); + show_expr (c->expr1); + show_sync_stat (&c->ext.sync_stat); break; case EXEC_SYNC_ALL: @@ -2913,6 +2934,7 @@ show_code_node (int level, gfc_code *c) fputs ("ENDIF", dumpfile); break; + case EXEC_CHANGE_TEAM: case EXEC_BLOCK: { const char *blocktype, *sname = NULL; @@ -2928,17 +2950,23 @@ show_code_node (int level, gfc_code *c) if (fcn && fcn->expr_type == EXPR_FUNCTION) sname = fcn->value.function.actual->expr->symtree->n.sym->name; } + else if (c->op == EXEC_CHANGE_TEAM) + blocktype = "CHANGE TEAM"; else if (c->ext.block.assoc) blocktype = "ASSOCIATE"; else blocktype = "BLOCK"; show_indent (); fprintf (dumpfile, "%s ", blocktype); + if (c->op == EXEC_CHANGE_TEAM) + show_expr (c->expr1); for (alist = c->ext.block.assoc; alist; alist = alist->next) { fprintf (dumpfile, " %s = ", sname ? sname : alist->name); show_expr (alist->target); } + if (c->op == EXEC_CHANGE_TEAM) + show_sync_stat (&c->ext.block.sync_stat); ++show_level; ns = c->ext.block.ns; @@ -2948,8 +2976,13 @@ show_code_node (int level, gfc_code *c) gfc_current_ns = saved_ns; show_code (show_level, ns->code); --show_level; - show_indent (); - fprintf (dumpfile, "END %s ", blocktype); + if (c->op != EXEC_CHANGE_TEAM) + { + /* A CHANGE_TEAM is terminated by a END_TEAM, which have its own + stat and errmsg. Therefore, let it print itself. */ + show_indent (); + fprintf (dumpfile, "END %s ", blocktype); + } break; } @@ -3048,7 +3081,9 @@ show_code_node (int level, gfc_code *c) break; case EXEC_CRITICAL: - fputs ("CRITICAL\n", dumpfile); + fputs ("CRITICAL", dumpfile); + show_sync_stat (&c->ext.sync_stat); + fputc ('\n', dumpfile); show_code (level + 1, c->block->next); code_indent (level, 0); fputs ("END CRITICAL", dumpfile); diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index 0753667..07e9bac 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -3836,7 +3836,13 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform, if (has_pointer && (ref == NULL || ref->next == NULL) && lvalue->symtree->n.sym->attr.data) return true; - else + /* Prevent the following error message for caf-single mode, because there + are no teams in single mode and the simplify returns a null then. */ + else if (!(flag_coarray == GFC_FCOARRAY_SINGLE + && rvalue->ts.type == BT_DERIVED + && rvalue->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && rvalue->ts.u.derived->intmod_sym_id + == ISOFORTRAN_TEAM_TYPE)) { gfc_error ("NULL appears on right-hand side in assignment at %L", &rvalue->where); diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc index ef9c801..02a0a23 100644 --- a/gcc/fortran/frontend-passes.cc +++ b/gcc/fortran/frontend-passes.cc @@ -5340,6 +5340,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, { case EXEC_BLOCK: + case EXEC_CHANGE_TEAM: WALK_SUBCODE (co->ext.block.ns->code); if (co->ext.block.assoc) { diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 5ef7037..46310a0 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3162,6 +3162,11 @@ enum locality_type LOCALITY_NUM }; +struct sync_stat +{ + gfc_expr *stat, *errmsg; +}; + typedef struct gfc_code { gfc_exec_op op; @@ -3197,6 +3202,7 @@ typedef struct gfc_code gfc_omp_variant *omp_variants; bool omp_bool; int stop_code; + struct sync_stat sync_stat; struct { @@ -3207,6 +3213,7 @@ typedef struct gfc_code unsigned arr_spec_from_expr3:1; /* expr3 is not explicit */ unsigned expr3_not_explicit:1; + struct sync_stat sync_stat; } alloc; @@ -3215,6 +3222,7 @@ typedef struct gfc_code gfc_namespace *ns; gfc_association_list *assoc; gfc_case *case_list; + struct sync_stat sync_stat; } block; @@ -3985,6 +3993,7 @@ bool gfc_resolve_index (gfc_expr *, int); bool gfc_resolve_dim_arg (gfc_expr *); bool gfc_resolve_substring (gfc_ref *, bool *); void gfc_resolve_substring_charlen (gfc_expr *); +void gfc_resolve_sync_stat (struct sync_stat *); gfc_expr *gfc_expr_to_initialize (gfc_expr *); bool gfc_type_is_extensible (gfc_symbol *); bool gfc_resolve_intrinsic (gfc_symbol *, locus *); diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 9632161..841f613 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -4230,6 +4230,12 @@ future implementation of teams. It is about to change without further notice. * _gfortran_caf_co_min:: Collective minimum reduction * _gfortran_caf_co_sum:: Collective summing reduction * _gfortran_caf_co_reduce:: Generic collective reduction +* _gfortran_caf_form_team:: Team creation function +* _gfortran_caf_change_team:: Team activation function +* _gfortran_caf_end_team:: Team termination function +* _gfortran_caf_sync_team:: Synchronize all images of a given team +* _gfortran_caf_get_team:: Get the opaque handle of the specified team +* _gfortran_caf_team_number:: Get the unique id of the given team @end menu @@ -4294,21 +4300,23 @@ using the STOP and ERROR STOP statements; those use different library calls. @table @asis @item @emph{Synopsis}: -@code{int _gfortran_caf_this_image (int distance)} +@code{int _gfortran_caf_this_image (caf_team_t team)} @item @emph{Description}: -This function returns the current image number, which is a positive number. +Return the current image number in the @var{team}, or in the current team, if +no @var{team} is given. @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{distance} @tab As specified for the @code{this_image} intrinsic -in TS18508. Shall be a nonnegative number. +@item @var{team} @tab intent(in), optional; The team this image's number is +requested for. If null, the image number in the current team is returned. @end multitable @item @emph{Notes}: -If the Fortran intrinsic @code{this_image} is invoked without an argument, which -is the only permitted form in Fortran 2008, GCC passes @code{0} as -first argument. +Available since Fortran 2008 without argument; Since Fortran 2018 with optional +team argument. Fortran 2008 uses 0 as argument for team, which is permissible, +because a team handle is always an opaque pointer, which as a special case can +be null here. @end table @@ -4318,25 +4326,29 @@ first argument. @table @asis @item @emph{Synopsis}: -@code{int _gfortran_caf_num_images(int distance, int failed)} +@code{int _gfortran_caf_num_images (caf_team_t team, int32_t *team_number)} @item @emph{Description}: -This function returns the number of images in the current team, if -@var{distance} is 0 or the number of images in the parent team at the specified -distance. If @var{failed} is -1, the function returns the number of all images at -the specified distance; if it is 0, the function returns the number of -nonfailed images, and if it is 1, it returns the number of failed images. +This function returns the number of images in the team given by @var{team} or +@var{team_number}, if either one is present. If both are null, then the number +of images in the current team is returned. @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{distance} @tab the distance from this image to the ancestor. -Shall be positive. -@item @var{failed} @tab shall be -1, 0, or 1 +@item @var{team} @tab intent(in), optional; The team the number of images is +requested for. If null, the number of images in the current team is returned. +@item @var{team_number} @tab intent(in), optional; The team id for which the +number of teams is requested; if unset, then number of images in the current +team is returned. @end multitable @item @emph{Notes}: -This function follows TS18508. If the num_image intrinsic has no arguments, -then the compiler passes @code{distance=0} and @code{failed=-1} to the function. +When both argument are given, then it is caf-library dependent which argument +is examined first. Current implementations prioritize the @var{team} argument, +because it is easier to retrive the number of images from it. + +Fortran 2008 or later, with no arguments; Fortran 2018 or later with two +arguments. @end table @@ -4705,9 +4717,9 @@ structure. operation, i.e., zero on success and non-zero on error. When @code{NULL} and an error occurs, then an error message is printed and the program is terminated. @item @var{team} @tab intent(in) The opaque team handle as returned by -@code{FORM TEAM}. Unused at the moment. +@code{FORM TEAM}. @item @var{team_number} @tab intent(in) The number of the team this access is -to be part of. Unused at the moment. +to be part of. @end multitable @item @emph{Notes}: @@ -4806,9 +4818,9 @@ structure. operation, i.e., zero on success and non-zero on error. When @code{NULL} and an error occurs, then an error message is printed and the program is terminated. @item @var{team} @tab intent(in) The opaque team handle as returned by -@code{FORM TEAM}. Unused at the moment. +@code{FORM TEAM}. @item @var{team_number} @tab intent(in) The number of the team this access is -to be part of. Unused at the moment. +to be part of. @end multitable @item @emph{Notes}: @@ -4906,13 +4918,13 @@ the operation on the sending side, i.e., zero on success and non-zero on error. When @code{NULL} and an error occurs, then an error message is printed and the program is terminated. @item @var{dst_team} @tab intent(in) The opaque team handle as returned by -@code{FORM TEAM}. Unused at the moment. +@code{FORM TEAM}. @item @var{dst_team_number} @tab intent(in) The number of the team this access -is to be part of. Unused at the moment. +is to be part of. @item @var{src_team} @tab intent(in) The opaque team handle as returned by -@code{FORM TEAM}. Unused at the moment. +@code{FORM TEAM}. @item @var{src_team_number} @tab intent(in) The number of the team this access -is to be part of. Unused at the moment. +is to be part of. @end multitable @item @emph{Notes}: @@ -5656,6 +5668,180 @@ or an array descriptor. @end table + +@node _gfortran_caf_form_team +@subsection @code{_gfortran_caf_form_team} --- Team creation function +@cindex Coarray, _gfortran_caf_form_team + +@table @asis +@item @emph{Synopsis}: +@code{void _gfortran_caf_form_team (int team_id, caf_team_t *team, +int *new_index, int *stat, char *errmsg, size_t errmsg_len)} + +@item @emph{Description}: +Create a team. All images giving the same @var{team_id} in a call to +@code{FORM TEAM} will form a new team addressable by the opaque handle +@var{team} which is of type @code{team_type} from the intrinsic module +@ref{ISO_FORTRAN_ENV}. In the team the image gets the image index given by +@var{new_index} if present. If @var{new_index} is absent, then an +implementation specific index is assigned. + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{team_id} @tab intent(in) A unique id for each team to form. Images +giving the same @var{team_id} in a call to @code{FORM TEAM} belong to the same +team. +@item @var{team} @tab intent(out) The opaque pointer to the newly formed team +@item @var{new_index} @tab intent(in) If non-null gives the unique index of +this image in the newly formed team. When no @var{new_index} is given, the +caf-library is free to choose a unique index. +@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL. +@item @var{errmsg} @tab intent(out) When an error occurs, this is set to +an error message; may be NULL. +@item @var{errmsg_len} @tab intent(in) the buffer size of errmsg +@end multitable + +@item @emph{Notes}: +The id given in @var{team_id} has to be unique in all subsequent calls to +@code{FORM TEAM} on the same image. That id is the same used in +@code{TEAM_NUMBER=} of coarray indexes, which motivates the uniqueness. + +The index given in @var{new_index} needs to be unique among all members of +team to create. Failing uniqueness may lead to misbehaviour, which depends +on the caf-library's implementation. The library is free to implement +checks for this, which imposes overhead and therefore may be avoided. +@end table + + + +@node _gfortran_caf_change_team +@subsection @code{_gfortran_caf_change_team} --- Team activation function +@cindex Coarray, _gfortran_caf_change_team + +@table @asis +@item @emph{Synopsis}: +@code{void _gfortran_caf_change_team (caf_team_t team, int *stat, char *errmsg, +size_t errmsg_len)} + +@item @emph{Description}: +Actives the team given by @var{team}, which must be formed but not active +yet. This routine starts a new epoch on the coarray memory pool. All +coarrays registered from now on, will be freeed once the team is terminated. + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{team} @tab intent(inout) The opaque pointer to an already formed +team +@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL. +@item @var{errmsg} @tab intent(out) When an error occurs, this is set to +an error message; may be NULL. +@item @var{errmsg_len} @tab intent(in) the buffer size of errmsg +@end multitable + +@item @emph{Notes}: +When an error occurs and @var{stat} is non-null, it will be set. Nevertheless +will the Fortran program continue with the first statement in the change team +block. +@end table + + + +@node _gfortran_caf_end_team +@subsection @code{_gfortran_caf_end_team} --- Team termination function +@cindex Coarray, _gfortran_caf_end_team + +@table @asis +@item @emph{Synopsis}: +@code{void _gfortran_caf_end_team (int *stat, char *errmsg, size_t errmsg_len)} + +@item @emph{Description}: +Terminates the last team changed to. The coarray memory epoch is +terminated and all coarrays allocated since the execution of @code{CHANGE TEAM} +are freeed. + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL. +@item @var{errmsg} @tab intent(out) When an error occurs, this is set to +an error message; may be NULL. +@item @var{errmsg_len} @tab intent(in) the buffer size of errmsg +@end multitable +@end table + + + +@node _gfortran_caf_sync_team +@subsection @code{_gfortran_caf_sync_team} --- Synchronize all images of a given team +@cindex Coarray, _gfortran_caf_sync_team + +@table @asis +@item @emph{Synopsis}: +@code{void _gfortran_caf_sync_team (caf_team_t team, int *stat, char *errmsg, +size_t errmsg_len)} + +@item @emph{Description}: +Blocks execution of the image calling @code{SYNC TEAM} until all images of the +team given by @var{team} have joined the synchronisation call. + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{team} @tab intent(in) The opaque pointer to an active team +@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL. +@item @var{errmsg} @tab intent(out) When an error occurs, this is set to +an error message; may be NULL. +@item @var{errmsg_len} @tab intent(in) the buffer size of errmsg +@end multitable +@end table + + + +@node _gfortran_caf_get_team +@subsection @code{_gfortran_caf_get_team} --- Get the opaque handle of the specified team +@cindex Coarray, _gfortran_caf_get_team + +@table @asis +@item @emph{Synopsis}: +@code{caf_team_t _gfortran_caf_get_team (int32_t *level)} + +@item @emph{Description}: +Get the current team, when @var{level} is null, or the team specified by +@var{level} set to @code{INITIAL_TEAM}, @code{PARENT_TEAM} or +@code{CURRENT_TEAM} from the @code{ISO_FORTRAN_ENV} intrinsic module. When +being on the @code{INITIAL_TEAM} and requesting its @code{PARENT_TEAM}, then +the initial team is returned. + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{level} @tab intent(in) If set to one of the levels specified in +the @code{ISO_FORTRAN_ENV} module, the function returns the handle of the given +team. Values different from the allowed ones lead to a runtime error. +@end multitable +@end table + + + +@node _gfortran_caf_team_number +@subsection @code{_gfortran_caf_team_number} --- Get the unique id of the given team +@cindex Coarray, _gfortran_caf_team_number + +@table @asis +@item @emph{Synopsis}: +@code{int _gfortran_caf_team_number (caf_team_t team)} + +@item @emph{Description}: +The team id given when forming the team @ref{_gfortran_caf_form_team} of the +team specified by @var{team}, if given, or of the current team, if @var{team} +is absent. It is a runtime error to specify a non-existing team. +The team has to be formed, i.e., it is not necessary that it is changed +into to get the team number. The initial team has the team number @code{-1}. + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{team} @tab intent(in) The team for which the team id is desired. +@end multitable +@end table + + @c Intrinsic Procedures @c --------------------------------------------------------------------- diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc index d2ce74f..2eba209 100644 --- a/gcc/fortran/intrinsic.cc +++ b/gcc/fortran/intrinsic.cc @@ -1395,26 +1395,24 @@ add_functions (void) { /* Argument names. These are used as argument keywords and so need to match the documentation. Please keep this list in sorted order. */ - const char - *a = "a", *a1 = "a1", *a2 = "a2", *ar = "array", *b = "b", - *bck = "back", *bd = "boundary", *c = "c", *c_ptr_1 = "c_ptr_1", - *c_ptr_2 = "c_ptr_2", *ca = "coarray", *com = "command", - *dist = "distance", *dm = "dim", *f = "field", *failed="failed", - *fs = "fsource", *han = "handler", *i = "i", - *idy = "identity", *image = "image", *j = "j", *kind = "kind", - *l = "l", *ln = "len", *level = "level", *m = "matrix", *ma = "matrix_a", - *mb = "matrix_b", *md = "mode", *mo = "mold", *msk = "mask", - *n = "n", *ncopies= "ncopies", *nm = "name", *num = "number", - *op = "operation", *ord = "order", *odd = "ordered", *p = "p", - *p1 = "path1", *p2 = "path2", *pad = "pad", *pid = "pid", *pos = "pos", - *pt = "pointer", *r = "r", *rd = "round", - *s = "s", *set = "set", *sh = "shift", *shp = "shape", - *sig = "sig", *src = "source", *ssg = "substring", - *sta = "string_a", *stb = "string_b", *stg = "string", - *sub = "sub", *sz = "size", *tg = "target", *team = "team", *tm = "time", - *ts = "tsource", *ut = "unit", *v = "vector", *va = "vector_a", - *vb = "vector_b", *vl = "values", *val = "value", *x = "x", *y = "y", - *z = "z"; + const char *a + = "a", + *a1 = "a1", *a2 = "a2", *ar = "array", *b = "b", *bck = "back", + *bd = "boundary", *c = "c", *c_ptr_1 = "c_ptr_1", *c_ptr_2 = "c_ptr_2", + *ca = "coarray", *com = "command", *dm = "dim", *f = "field", + *fs = "fsource", *han = "handler", *i = "i", *idy = "identity", + *image = "image", *j = "j", *kind = "kind", *l = "l", *ln = "len", + *level = "level", *m = "matrix", *ma = "matrix_a", *mb = "matrix_b", + *md = "mode", *mo = "mold", *msk = "mask", *n = "n", *ncopies = "ncopies", + *nm = "name", *num = "number", *op = "operation", *ord = "order", + *odd = "ordered", *p = "p", *p1 = "path1", *p2 = "path2", *pad = "pad", + *pid = "pid", *pos = "pos", *pt = "pointer", *r = "r", *rd = "round", + *s = "s", *set = "set", *sh = "shift", *shp = "shape", *sig = "sig", + *src = "source", *ssg = "substring", *sta = "string_a", *stb = "string_b", + *stg = "string", *sub = "sub", *sz = "size", *tg = "target", *team = "team", + *team_or_team_number = "team/team_number", *tm = "time", *ts = "tsource", + *ut = "unit", *v = "vector", *va = "vector_a", *vb = "vector_b", + *vl = "values", *val = "value", *x = "x", *y = "y", *z = "z"; int di, dr, dd, dl, dc, dz, ii; @@ -2112,10 +2110,10 @@ add_functions (void) make_generic ("getpid", GFC_ISYM_GETPID, GFC_STD_GNU); - add_sym_1 ("get_team", GFC_ISYM_GET_TEAM, CLASS_TRANSFORMATIONAL, - ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2018, - gfc_check_get_team, NULL, gfc_resolve_get_team, - level, BT_INTEGER, di, OPTIONAL); + add_sym_1 ("get_team", GFC_ISYM_GET_TEAM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, + BT_DERIVED, di, GFC_STD_F2018, gfc_check_get_team, + gfc_simplify_get_team, gfc_resolve_get_team, level, BT_INTEGER, di, + OPTIONAL); add_sym_0 ("getuid", GFC_ISYM_GETUID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getuid); @@ -2265,9 +2263,11 @@ add_functions (void) make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU); - add_sym_2 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, - gfc_check_image_index, gfc_simplify_image_index, gfc_resolve_image_index, - ca, BT_REAL, dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED); + add_sym_3 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_TRANSFORMATIONAL, + ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, gfc_check_image_index, + gfc_simplify_image_index, gfc_resolve_image_index, ca, BT_REAL, dr, + REQUIRED, sub, BT_INTEGER, ii, REQUIRED, team_or_team_number, + BT_VOID, di, OPTIONAL); add_sym_2 ("image_status", GFC_ISYM_IMAGE_STATUS, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2018, gfc_check_image_status, @@ -2848,11 +2848,10 @@ add_functions (void) make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95); - add_sym_2 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_TRANSFORMATIONAL, - ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, - gfc_check_num_images, gfc_simplify_num_images, NULL, - dist, BT_INTEGER, di, OPTIONAL, - failed, BT_LOGICAL, dl, OPTIONAL); + add_sym_1 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_TRANSFORMATIONAL, + ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, gfc_check_num_images, + gfc_simplify_num_images, NULL, team_or_team_number, BT_VOID, di, + OPTIONAL); add_sym_3 ("out_of_range", GFC_ISYM_OUT_OF_RANGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2018, @@ -3338,10 +3337,11 @@ add_functions (void) gfc_check_team_number, NULL, gfc_resolve_team_number, team, BT_DERIVED, di, OPTIONAL); - add_sym_3 ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, - gfc_check_this_image, gfc_simplify_this_image, gfc_resolve_this_image, - ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL, - dist, BT_INTEGER, di, OPTIONAL); + add_sym_3red ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, gfc_check_this_image, + gfc_simplify_this_image, gfc_resolve_this_image, ca, BT_REAL, + dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL, team, BT_DERIVED, + di, OPTIONAL); add_sym_0 ("time", GFC_ISYM_TIME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time); @@ -3835,11 +3835,11 @@ add_subroutines (void) st, BT_INTEGER, di, OPTIONAL, INTENT_OUT, trim_name, BT_LOGICAL, dl, OPTIONAL, INTENT_IN); - add_sym_2s ("move_alloc", GFC_ISYM_MOVE_ALLOC, CLASS_PURE, BT_UNKNOWN, 0, - GFC_STD_F2003, - gfc_check_move_alloc, NULL, NULL, - f, BT_UNKNOWN, 0, REQUIRED, INTENT_INOUT, - t, BT_UNKNOWN, 0, REQUIRED, INTENT_OUT); + add_sym_4s ("move_alloc", GFC_ISYM_MOVE_ALLOC, CLASS_PURE, BT_UNKNOWN, 0, + GFC_STD_F2003, gfc_check_move_alloc, NULL, NULL, f, BT_UNKNOWN, 0, + REQUIRED, INTENT_INOUT, t, BT_UNKNOWN, 0, REQUIRED, INTENT_OUT, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, errmsg, BT_CHARACTER, + dc, OPTIONAL, INTENT_INOUT); add_sym_5s ("mvbits", GFC_ISYM_MVBITS, CLASS_ELEMENTAL, BT_UNKNOWN, 0, GFC_STD_F95, gfc_check_mvbits, NULL, gfc_resolve_mvbits, @@ -4956,6 +4956,9 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag) else if (specific->check.f3red == gfc_check_transf_bit_intrins) /* Same as for PRODUCT and SUM, but different checks. */ t = gfc_check_transf_bit_intrins (*ap); + else if (specific->check.f3red == gfc_check_this_image) + /* May need to reassign arguments. */ + t = gfc_check_this_image (*ap); else { if (specific->check.f1 == NULL) diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index fec1c24..767792c 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -132,7 +132,7 @@ bool gfc_check_nearest (gfc_expr *, gfc_expr *); bool gfc_check_new_line (gfc_expr *); bool gfc_check_norm2 (gfc_expr *, gfc_expr *); bool gfc_check_null (gfc_expr *); -bool gfc_check_num_images (gfc_expr *, gfc_expr *); +bool gfc_check_num_images (gfc_expr *); bool gfc_check_out_of_range (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_pack (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_parity (gfc_expr *, gfc_expr *); @@ -208,7 +208,8 @@ bool gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_gerror (gfc_expr *); bool gfc_check_getarg (gfc_expr *, gfc_expr *); bool gfc_check_getlog (gfc_expr *); -bool gfc_check_move_alloc (gfc_expr *, gfc_expr *); +bool gfc_check_move_alloc (gfc_expr *, gfc_expr *, gfc_expr *stat, + gfc_expr *errmsg); bool gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_random_init (gfc_expr *, gfc_expr *); @@ -221,7 +222,7 @@ bool gfc_check_fseek_sub (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_ftell_sub (gfc_expr *, gfc_expr *); bool gfc_check_getcwd_sub (gfc_expr *, gfc_expr *); bool gfc_check_hostnm_sub (gfc_expr *, gfc_expr *); -bool gfc_check_image_index (gfc_expr *, gfc_expr *); +bool gfc_check_image_index (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_itime_idate (gfc_expr *); bool gfc_check_kill_sub (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_ltime_gmtime (gfc_expr *, gfc_expr *); @@ -233,7 +234,7 @@ bool gfc_check_signal_sub (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_sleep_sub (gfc_expr *); bool gfc_check_stat_sub (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_system_sub (gfc_expr *, gfc_expr *); -bool gfc_check_this_image (gfc_expr *, gfc_expr *, gfc_expr *); +bool gfc_check_this_image (gfc_actual_arglist *); bool gfc_check_ttynam_sub (gfc_expr *, gfc_expr *); bool gfc_check_umask_sub (gfc_expr *, gfc_expr *); bool gfc_check_unlink_sub (gfc_expr *, gfc_expr *); @@ -327,7 +328,7 @@ gfc_expr *gfc_simplify_ibits (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ibset (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ichar (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ieor (gfc_expr *, gfc_expr *); -gfc_expr *gfc_simplify_image_index (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_image_index (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_image_status (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_int (gfc_expr *, gfc_expr *); @@ -382,7 +383,7 @@ gfc_expr *gfc_simplify_new_line (gfc_expr *); gfc_expr *gfc_simplify_nint (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_norm2 (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_null (gfc_expr *); -gfc_expr *gfc_simplify_num_images (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_num_images (gfc_expr *); gfc_expr *gfc_simplify_idnint (gfc_expr *); gfc_expr *gfc_simplify_not (gfc_expr *); gfc_expr *gfc_simplify_or (gfc_expr *, gfc_expr *); @@ -478,6 +479,7 @@ void gfc_resolve_bessel_n2 (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *a); void gfc_resolve_btest (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_c_loc (gfc_expr *, gfc_expr *); void gfc_resolve_c_funloc (gfc_expr *, gfc_expr *); +void gfc_resolve_get_team (gfc_expr *, gfc_expr *); void gfc_resolve_ceiling (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_char (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_chdir (gfc_expr *, gfc_expr *); @@ -522,7 +524,6 @@ void gfc_resolve_gamma (gfc_expr *, gfc_expr *); void gfc_resolve_getcwd (gfc_expr *, gfc_expr *); void gfc_resolve_getgid (gfc_expr *); void gfc_resolve_getpid (gfc_expr *); -void gfc_resolve_get_team (gfc_expr *, gfc_expr *); void gfc_resolve_getuid (gfc_expr *); void gfc_resolve_hostnm (gfc_expr *, gfc_expr *); void gfc_resolve_hypot (gfc_expr *, gfc_expr *, gfc_expr *); @@ -530,7 +531,7 @@ void gfc_resolve_iand (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ibclr (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ibits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ibset (gfc_expr *, gfc_expr *, gfc_expr *); -void gfc_resolve_image_index (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_image_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_image_status (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_index_func (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 8c160e5..3a105bc 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -170,6 +170,7 @@ Some basic guidelines for editing this document: * @code{GETGID}: GETGID, Group ID function * @code{GETLOG}: GETLOG, Get login name * @code{GETPID}: GETPID, Process ID function +* @code{GET_TEAM}: GET_TEAM, Get the handle of a team * @code{GETUID}: GETUID, User ID function * @code{GMTIME}: GMTIME, Convert time to GMT info * @code{HOSTNM}: HOSTNM, Get system host name @@ -311,6 +312,7 @@ Some basic guidelines for editing this document: * @code{TAN}: TAN, Tangent function * @code{TAND}: TAND, Tangent function, degrees * @code{TANH}: TANH, Hyperbolic tangent function +* @code{TEAM_NUMBER}: TEAM_NUMBER, Retrieve team id of given team * @code{THIS_IMAGE}: THIS_IMAGE, Cosubscript index of this image * @code{TIME}: TIME, Time function * @code{TIME8}: TIME8, Time function (64-bit) @@ -7336,6 +7338,59 @@ GNU extension +@node GET_TEAM +@section @code{GET_TEAM} --- Get the handle of a team +@fnindex GET_TEAM +@cindex coarray, @code{GET_TEAM} +@cindex images, get a handle to a team + +@table @asis +@item @emph{Synopsis}: +@code{RESULT = GET_TEAM([LEVEL])} + +@item @emph{Description}: +Returns the handle of the current team, if @var{LEVEL} is not given. Or the +team specified by @var{LEVEL}, where @var{LEVEL} is one of the constants +@code{INITIAL_TEAM}, @code{PARENT_TEAM} or @code{CURRENT_TEAM} from the +intrinsic module @code{ISO_FORTRAN_ENV}. Calling the function with +@code{PARENT_TEAM} while being on the initial team, returns a handle to the +initial team. This ensures that always a valid team is returned, given that +team handles can neither be checked for validity nor compared with each other +or null. + +@item @emph{Class}: +Transformational function + +@item @emph{Return value}: +An opaque handle of @code{TEAM_TYPE} from the intrinsic module +@code{ISO_FORTRAN_ENV}. + +@item @emph{Example}: +@smallexample +program info + use, intrinsic :: iso_fortran_env + type(team_type) :: init, curr, par, nt + + init = get_team() + curr = get_team(current_team) ! init equals curr here + form team(1, nt) + change team(nt) + curr = get_team() ! or get_team(current_team) + par = get_team(parent_team) ! par equals init here + end team +end program info +@end smallexample + +@item @emph{Standard}: +Fortran 2018 or later + +@item @emph{See also}: +@ref{THIS_IMAGE}, @* +@ref{ISO_FORTRAN_ENV} +@end table + + + @node GETUID @section @code{GETUID} --- User ID function @fnindex GETUID @@ -11372,47 +11427,48 @@ Fortran 95 and later @table @asis @item @emph{Synopsis}: -@code{RESULT = NUM_IMAGES(DISTANCE, FAILED)} +@multitable @columnfractions .80 +@item @code{RESULT = NUM_IMAGES([TEAM])} +@item @code{RESULT = NUM_IMAGES(TEAM_NUMBER)} +@end multitable @item @emph{Description}: -Returns the number of images. +Returns the number of images in the current team or the given team. @item @emph{Class}: Transformational function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{DISTANCE} @tab (optional, intent(in)) Nonnegative scalar integer -@item @var{FAILED} @tab (optional, intent(in)) Scalar logical expression +@item @var{TEAM} @tab (optional, intent(in)) If present, return the number of +images in the given team; if absent, return the number of images in the +current team. +@item @var{TEAM_NUMBER} @tab (intent(in)) The number as given in the +@code{FORM TEAM} statement. @end multitable @item @emph{Return value}: -Scalar default-kind integer. If @var{DISTANCE} is not present or has value 0, -the number of images in the current team is returned. For values smaller or -equal distance to the initial team, it returns the number of images index -on the ancestor team that has a distance of @var{DISTANCE} from the invoking -team. If @var{DISTANCE} is larger than the distance to the initial team, the -number of images of the initial team is returned. If @var{FAILED} is not present -the total number of images is returned; if it has the value @code{.TRUE.}, -the number of failed images is returned, otherwise, the number of images that -do have not the failed status. +Scalar default-kind integer. Can be called without any arguments or a team +type argument or a team_number argument. @item @emph{Example}: @smallexample +use, intrinsic :: iso_fortran_env INTEGER :: value[*] INTEGER :: i -value = THIS_IMAGE() -SYNC ALL -IF (THIS_IMAGE() == 1) THEN - DO i = 1, NUM_IMAGES() - WRITE(*,'(2(a,i0))') 'value[', i, '] is ', value[i] - END DO -END IF +type(team_type) :: t + +! When running with 4 images +print *, num_images() ! 4 + +form team (mod(this_image(), 2), t) +print *, num_images(t) ! 2 +print *, num_images(-1) ! 4 @end smallexample @item @emph{Standard}: -Fortran 2008 and later. With @var{DISTANCE} or @var{FAILED} argument, -Technical Specification (TS) 18508 or later +Fortran 2008 and later. With @var{TEAM} or @var{TEAM_NUMBER} argument, +Fortran 2018 and later. @item @emph{See also}: @ref{THIS_IMAGE}, @* @@ -14467,6 +14523,54 @@ Fortran 77 and later, for a complex argument Fortran 2008 or later +@node TEAM_NUMBER +@section @code{TEAM_NUMBER} --- Retrieve team id of given team +@fnindex TEAM_NUMBER +@cindex coarray, @code{TEAM_NUMBER} +@cindex teams, index of given team + +@table @asis +@item @emph{Synopsis}: +@item @code{RESULT = TEAM_NUMBER([TEAM])} + +@item @emph{Description}: +Returns the team id for the given @var{TEAM} as assigned by @code{FORM TEAM}. +If @var{TEAM} is absent, returns the team number of the current team. + +@item @emph{Class}: +Transformational function + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{TEAM} @tab (optional, intent(in)) The handle of the team for which +the number, aka id, is desired. +@end multitable + +@item @emph{Return value}: +Default integer. The id as given in a call @code{FORM TEAM}. Applying +@code{TEAM_NUMBER} to the initial team will result in @code{-1} to be returned. +Returns the id of the current team, if @var{TEAM} is null. + +@item @emph{Example}: +@smallexample +use, intrinsic :: iso_fortran_env +type(team_type) :: t + +print *, team_number() ! -1 +form team (99, t) +print *, team_number(t) ! 99 +@end smallexample + +@item @emph{Standard}: +Fortran 2018 and later. + +@item @emph{See also}: +@ref{GET_TEAM}, @* +@ref{TEAM_NUMBER} +@end table + + + @node THIS_IMAGE @section @code{THIS_IMAGE} --- Function that returns the cosubscript index of this image @fnindex THIS_IMAGE @@ -14476,9 +14580,8 @@ Fortran 77 and later, for a complex argument Fortran 2008 or later @table @asis @item @emph{Synopsis}: @multitable @columnfractions .80 -@item @code{RESULT = THIS_IMAGE()} -@item @code{RESULT = THIS_IMAGE(DISTANCE)} -@item @code{RESULT = THIS_IMAGE(COARRAY [, DIM])} +@item @code{RESULT = THIS_IMAGE([TEAM])} +@item @code{RESULT = THIS_IMAGE(COARRAY [, DIM][, TEAM])} @end multitable @item @emph{Description}: @@ -14489,8 +14592,8 @@ Transformational function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{DISTANCE} @tab (optional, intent(in)) Nonnegative scalar integer -(not permitted together with @var{COARRAY}). +@item @var{TEAM} @tab (optional, intent(in)) The team for which the index of +this image is desired. The current team is used, when no team is given. @item @var{COARRAY} @tab Coarray of any type (optional; if @var{DIM} present, required). @item @var{DIM} @tab default integer scalar (optional). If present, @@ -14499,16 +14602,16 @@ present, required). @item @emph{Return value}: Default integer. If @var{COARRAY} is not present, it is scalar; if -@var{DISTANCE} is not present or has value 0, its value is the image index on -the invoking image for the current team, for values smaller or equal -distance to the initial team, it returns the image index on the ancestor team -that has a distance of @var{DISTANCE} from the invoking team. If -@var{DISTANCE} is larger than the distance to the initial team, the image -index of the initial team is returned. Otherwise when the @var{COARRAY} is +@var{TEAM} is not present, its value is the image index on the invoking image +for the current team; if @var{TEAM} is present, returns the image index of +the invoking image as given to the @code{FORM TEAM (..., NEW_INDEX=..)} call, +or a implementation specific unique number, when @code{NEW_INDEX=} was absent +from @code{FORM TEAM}. Otherwise when the @var{COARRAY} is present, if @var{DIM} is not present, a rank-1 array with corank elements is returned, containing the cosubscripts for @var{COARRAY} specifying the invoking -image. If @var{DIM} is present, a scalar is returned, with the value of -the @var{DIM} element of @code{THIS_IMAGE(COARRAY)}. +image (in the team when @var{TEAM} is present). If @var{DIM} is present, a +scalar is returned, with the value of the @var{DIM} element of +@code{THIS_IMAGE(COARRAY)}. @item @emph{Example}: @smallexample @@ -14523,13 +14626,12 @@ IF (THIS_IMAGE() == 1) THEN END IF ! Check whether the current image is the initial image -IF (THIS_IMAGE(HUGE(1)) /= THIS_IMAGE()) +IF (THIS_IMAGE(GET_TEAM(INITIAL_TEAM)) /= THIS_IMAGE()) error stop "something is rotten here" @end smallexample @item @emph{Standard}: -Fortran 2008 and later. With @var{DISTANCE} argument, -Technical Specification (TS) 18508 or later +Fortran 2008 and later. With @var{TEAM} argument, Fortran 2018 or later @item @emph{See also}: @ref{NUM_IMAGES}, @* @@ -15354,12 +15456,18 @@ parameters of the @code{CHARACTER} type. (Fortran 2008 or later.) @item @code{CHARACTER_STORAGE_SIZE}: Size in bits of the character storage unit. +@item @code{CURRENT_TEAM}: +The argument to @ref{GET_TEAM} to retrieve a handle of the current team. + @item @code{ERROR_UNIT}: Identifies the preconnected unit used for error reporting. @item @code{FILE_STORAGE_SIZE}: Size in bits of the file-storage unit. +@item @code{INTIAL_TEAM}: +Argument to @ref{GET_TEAM} to retrieve a handle of the initial team. + @item @code{INPUT_UNIT}: Identifies the preconnected unit identified by the asterisk (@code{*}) in @code{READ} statement. @@ -15397,6 +15505,9 @@ parameters of the @code{LOGICAL} type. (Fortran 2008 or later.) Identifies the preconnected unit identified by the asterisk (@code{*}) in @code{WRITE} statement. +@item @code{PARENT_TEAM}: +Argument to @ref{GET_TEAM} to retrieve a handle to the parent team. + @item @code{REAL32}, @code{REAL64}, @code{REAL128}: Kind type parameters to specify a REAL type with a storage size of 32, 64, and 128 bits. It is negative if a target platform @@ -15445,6 +15556,10 @@ Derived type with private components to be use with the @code{LOCK} and @code{UNLOCK} statement. A variable of its type has to be always declared as coarray and may not appear in a variable-definition context. (Fortran 2008 or later.) +@item @code{TEAM_TYPE}: +An opaque type for handling teams. Note that a variable of type +@code{TEAM_TYPE} is not comparable with other variables of the same or other +types nor with null. @end table The module also provides the following intrinsic procedures: diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc index 858ffb1..6930e2c 100644 --- a/gcc/fortran/iresolve.cc +++ b/gcc/fortran/iresolve.cc @@ -3209,17 +3209,28 @@ gfc_resolve_get_team (gfc_expr *f, gfc_expr *level ATTRIBUTE_UNUSED) { static char get_team[] = "_gfortran_caf_get_team"; f->rank = 0; - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; + f->ts.type = BT_DERIVED; + gfc_find_symbol ("team_type", gfc_current_ns, 1, &f->ts.u.derived); + if (!f->ts.u.derived + || f->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV) + { + gfc_error ( + "GET_TEAM at %L needs USE of the intrinsic module ISO_FORTRAN_ENV " + "to define its result type TEAM_TYPE", + &f->where); + f->ts.type = BT_UNKNOWN; + } f->value.function.name = get_team; -} + /* No requirements to resolve for level argument now. */ +} /* Resolve image_index (...). */ void gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, - gfc_expr *sub ATTRIBUTE_UNUSED) + gfc_expr *sub ATTRIBUTE_UNUSED, + gfc_expr *team_or_team_number ATTRIBUTE_UNUSED) { static char image_index[] = "__image_index"; f->ts.type = BT_INTEGER; @@ -3248,31 +3259,46 @@ gfc_resolve_stopped_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED, /* Resolve team_number (team). */ void -gfc_resolve_team_number (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED) +gfc_resolve_team_number (gfc_expr *f, gfc_expr *team) { static char team_number[] = "_gfortran_caf_team_number"; f->rank = 0; f->ts.type = BT_INTEGER; f->ts.kind = gfc_default_integer_kind; f->value.function.name = team_number; -} + if (team) + gfc_resolve_expr (team); +} void -gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim, - gfc_expr *distance ATTRIBUTE_UNUSED) +gfc_resolve_this_image (gfc_expr *f, gfc_expr *coarray, gfc_expr *dim, + gfc_expr *team) { static char this_image[] = "__this_image"; - if (array && gfc_is_coarray (array)) - resolve_bound (f, array, dim, NULL, "__this_image", true); + if (coarray && dim) + resolve_bound (f, coarray, dim, NULL, this_image, true); + else if (coarray) + { + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = this_image; + if (f->shape && f->rank != 1) + gfc_free_shape (&f->shape, f->rank); + f->rank = 1; + f->shape = gfc_get_shape (1); + mpz_init_set_ui (f->shape[0], coarray->corank); + } else { f->ts.type = BT_INTEGER; f->ts.kind = gfc_default_integer_kind; f->value.function.name = this_image; } -} + if (team) + gfc_resolve_expr (team); +} void gfc_resolve_time (gfc_expr *f) diff --git a/gcc/fortran/iso-fortran-env.def b/gcc/fortran/iso-fortran-env.def index b8926f4..250a730 100644 --- a/gcc/fortran/iso-fortran-env.def +++ b/gcc/fortran/iso-fortran-env.def @@ -83,17 +83,23 @@ NAMED_INTCST (ISOFORTRANENV_REAL64, "real64", \ gfc_get_real_kind_from_width_isofortranenv (64), GFC_STD_F2008) NAMED_INTCST (ISOFORTRANENV_REAL128, "real128", \ gfc_get_real_kind_from_width_isofortranenv (128), GFC_STD_F2008) -NAMED_INTCST (ISOFORTRANENV_FILE_STAT_LOCKED, "stat_locked", \ +NAMED_INTCST (ISOFORTRANENV_STAT_LOCKED, "stat_locked", \ GFC_STAT_LOCKED, GFC_STD_F2008) -NAMED_INTCST (ISOFORTRANENV_FILE_STAT_LOCKED_OTHER_IMAGE, \ +NAMED_INTCST (ISOFORTRANENV_STAT_LOCKED_OTHER_IMAGE, \ "stat_locked_other_image", \ GFC_STAT_LOCKED_OTHER_IMAGE, GFC_STD_F2008) -NAMED_INTCST (ISOFORTRANENV_FILE_STAT_STOPPED_IMAGE, "stat_stopped_image", \ - GFC_STAT_STOPPED_IMAGE, GFC_STD_F2008) -NAMED_INTCST (ISOFORTRANENV_FILE_STAT_FAILED_IMAGE, "stat_failed_image", \ - GFC_STAT_FAILED_IMAGE, GFC_STD_F2018) -NAMED_INTCST (ISOFORTRANENV_FILE_STAT_UNLOCKED, "stat_unlocked", \ - GFC_STAT_UNLOCKED, GFC_STD_F2008) +NAMED_INTCST (ISOFORTRANENV_STAT_STOPPED_IMAGE, "stat_stopped_image", \ + GFC_STAT_STOPPED_IMAGE, GFC_STD_F2008) +NAMED_INTCST (ISOFORTRANENV_STAT_FAILED_IMAGE, "stat_failed_image", \ + GFC_STAT_FAILED_IMAGE, GFC_STD_F2018) +NAMED_INTCST (ISOFORTRANENV_STAT_UNLOCKED, "stat_unlocked", \ + GFC_STAT_UNLOCKED, GFC_STD_F2008) +NAMED_INTCST (ISOFORTRANENV_INITIAL_TEAM, "initial_team", \ + GFC_CAF_INITIAL_TEAM, GFC_STD_F2018) +NAMED_INTCST (ISOFORTRANENV_PARENT_TEAM, "parent_team", \ + GFC_CAF_PARENT_TEAM, GFC_STD_F2018) +NAMED_INTCST (ISOFORTRANENV_CURRENT_TEAM, "current_team", \ + GFC_CAF_CURRENT_TEAM, GFC_STD_F2018) /* The arguments to NAMED_KINDARRAY are: @@ -134,9 +140,7 @@ NAMED_DERIVED_TYPE (ISOFORTRAN_EVENT_TYPE, "event_type", \ : gfc_default_integer_kind, GFC_STD_F2018) NAMED_DERIVED_TYPE (ISOFORTRAN_TEAM_TYPE, "team_type", \ - flag_coarray == GFC_FCOARRAY_LIB - ? get_int_kind_from_node (ptr_type_node) - : gfc_default_integer_kind, GFC_STD_F2018) + get_int_kind_from_node (ptr_type_node), GFC_STD_F2018) NAMED_INTCST (ISOFORTRANENV_LOGICAL8, "logical8", \ gfc_get_int_kind_from_width_isofortranenv (8), GFC_STD_F2023) diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index 9565365..9de5afb 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -154,12 +154,20 @@ typedef enum GFC_STAT_LOCKED, GFC_STAT_LOCKED_OTHER_IMAGE, GFC_STAT_STOPPED_IMAGE = 6000, /* See LIBERROR_INQUIRE_INTERNAL_UNIT above. */ - GFC_STAT_FAILED_IMAGE = 6001 + GFC_STAT_FAILED_IMAGE = 6001, + GFC_STAT_UNLOCKED_FAILED_IMAGE = 6002 } libgfortran_stat_codes; typedef enum { + GFC_CAF_INITIAL_TEAM = 0, + GFC_CAF_PARENT_TEAM, + GFC_CAF_CURRENT_TEAM +} libgfortran_team_levels; + +typedef enum +{ GFC_CAF_ATOMIC_ADD = 1, GFC_CAF_ATOMIC_AND, GFC_CAF_ATOMIC_OR, diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index ec9e587..474ba81 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -1814,12 +1814,53 @@ gfc_free_iterator (gfc_iterator *iter, int flag) free (iter); } +static match +match_named_arg (const char *pat, const char *name, gfc_expr **e, + gfc_statement st_code) +{ + match m; + gfc_expr *tmp; + + m = gfc_match (pat, &tmp); + if (m == MATCH_ERROR) + { + gfc_syntax_error (st_code); + return m; + } + if (m == MATCH_YES) + { + if (*e) + { + gfc_error ("Duplicate %s attribute in %C", name); + gfc_free_expr (tmp); + return MATCH_ERROR; + } + *e = tmp; + + return MATCH_YES; + } + return MATCH_NO; +} + +static match +match_stat_errmsg (struct sync_stat *sync_stat, gfc_statement st_code) +{ + match m; + + m = match_named_arg (" stat = %v", "STAT", &sync_stat->stat, st_code); + if (m != MATCH_NO) + return m; + + m = match_named_arg (" errmsg = %v", "ERRMSG", &sync_stat->errmsg, st_code); + return m; +} /* Match a CRITICAL statement. */ match gfc_match_critical (void) { gfc_st_label *label = NULL; + match m; if (gfc_match_label () == MATCH_ERROR) return MATCH_ERROR; @@ -1830,12 +1871,29 @@ gfc_match_critical (void) if (gfc_match_st_label (&label) == MATCH_ERROR) return MATCH_ERROR; - if (gfc_match_eos () != MATCH_YES) + if (gfc_match_eos () == MATCH_YES) + goto done; + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + for (;;) { - gfc_syntax_error (ST_CRITICAL); - return MATCH_ERROR; + m = match_stat_errmsg (&new_st.ext.sync_stat, ST_CRITICAL); + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + continue; + + break; } + if (gfc_match (" )%t") != MATCH_YES) + goto syntax; + +done: + if (gfc_pure (NULL)) { gfc_error ("Image control statement CRITICAL at %C in PURE procedure"); @@ -1856,9 +1914,9 @@ gfc_match_critical (void) if (flag_coarray == GFC_FCOARRAY_NONE) { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to " - "enable"); - return MATCH_ERROR; + gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to " + "enable"); + return MATCH_ERROR; } if (gfc_find_state (COMP_CRITICAL)) @@ -1869,13 +1927,21 @@ gfc_match_critical (void) new_st.op = EXEC_CRITICAL; - if (label != NULL - && !gfc_reference_st_label (label, ST_LABEL_TARGET)) - return MATCH_ERROR; + if (label != NULL && !gfc_reference_st_label (label, ST_LABEL_TARGET)) + goto cleanup; return MATCH_YES; -} +syntax: + gfc_syntax_error (ST_CRITICAL); + +cleanup: + gfc_free_expr (new_st.ext.sync_stat.stat); + gfc_free_expr (new_st.ext.sync_stat.errmsg); + new_st.ext.sync_stat = {NULL, NULL}; + + return MATCH_ERROR; +} /* Match a BLOCK statement. */ @@ -1900,29 +1966,29 @@ gfc_match_block (void) return MATCH_YES; } - -/* Match an ASSOCIATE statement. */ - -match -gfc_match_associate (void) +bool +check_coarray_assoc (const char *name, gfc_association_list *assoc) { - if (gfc_match_label () == MATCH_ERROR) - return MATCH_ERROR; - - if (gfc_match (" associate") != MATCH_YES) - return MATCH_NO; - - /* Match the association list. */ - if (gfc_match_char ('(') != MATCH_YES) + if (assoc->target->expr_type == EXPR_VARIABLE + && !strcmp (assoc->target->symtree->name, name)) { - gfc_error ("Expected association list at %C"); - return MATCH_ERROR; + gfc_error ("Codimension decl name %qs in association at %L " + "must not be the same as a selector", + name, &assoc->where); + return false; } + return true; +} + +match +match_association_list (bool for_change_team = false) +{ new_st.ext.block.assoc = NULL; while (true) { - gfc_association_list* newAssoc = gfc_get_association_list (); - gfc_association_list* a; + gfc_association_list *newAssoc = gfc_get_association_list (); + gfc_association_list *a; + locus pre_name = gfc_current_locus; /* Match the next association. */ if (gfc_match (" %n ", newAssoc->name) != MATCH_YES) @@ -1932,7 +1998,7 @@ gfc_match_associate (void) } /* Required for an assumed rank target. */ - if (gfc_peek_char () == '(') + if (!for_change_team && gfc_peek_char () == '(') { newAssoc->ar = gfc_get_array_ref (); if (gfc_match_array_ref (newAssoc->ar, NULL, 0, 0) != MATCH_YES) @@ -1946,26 +2012,53 @@ gfc_match_associate (void) gfc_error_now ("The bounds remapping list at %C is an experimental " "F202y feature. Use std=f202y to enable"); + if (for_change_team && gfc_peek_char () == '[') + { + if (!newAssoc->ar) + newAssoc->ar = gfc_get_array_ref (); + if (gfc_match_array_spec (&newAssoc->ar->as, false, true) + == MATCH_ERROR) + goto assocListError; + } + /* Match the next association. */ if (gfc_match (" =>", newAssoc->name) != MATCH_YES) { - gfc_error ("Expected association at %C"); - goto assocListError; + if (for_change_team) + gfc_current_locus = pre_name; + + free (newAssoc); + return MATCH_NO; } - if (gfc_match (" %e", &newAssoc->target) != MATCH_YES) + if (!for_change_team) { - /* Have another go, allowing for procedure pointer selectors. */ - gfc_matching_procptr_assignment = 1; if (gfc_match (" %e", &newAssoc->target) != MATCH_YES) { + /* Have another go, allowing for procedure pointer selectors. */ + gfc_matching_procptr_assignment = 1; + if (gfc_match (" %e", &newAssoc->target) != MATCH_YES) + { + gfc_matching_procptr_assignment = 0; + gfc_error ("Invalid association target at %C"); + goto assocListError; + } gfc_matching_procptr_assignment = 0; - gfc_error ("Invalid association target at %C"); + } + newAssoc->where = gfc_current_locus; + } + else + { + newAssoc->where = gfc_current_locus; + /* F2018, C1116: A selector in a coarray-association shall be a named + coarray. */ + if (gfc_match (" %v", &newAssoc->target) != MATCH_YES) + { + gfc_error ("Selector in coarray association as %C shall be a " + "named coarray"); goto assocListError; } - gfc_matching_procptr_assignment = 0; } - newAssoc->where = gfc_current_locus; /* Check that the current name is not yet in the list. */ for (a = new_st.ext.block.assoc; a; a = a->next) @@ -1976,6 +2069,35 @@ gfc_match_associate (void) goto assocListError; } + if (for_change_team) + { + /* F2018, C1113: In a change-team-stmt, a coarray-name in a + codimension-decl shall not be the same as a selector, or another + coarray-name, in that statement. + The latter is already checked for above. So check only the + former. + */ + if (!check_coarray_assoc (newAssoc->name, newAssoc)) + goto assocListError; + + for (a = new_st.ext.block.assoc; a; a = a->next) + { + if (!check_coarray_assoc (newAssoc->name, a) + || !check_coarray_assoc (a->name, newAssoc)) + goto assocListError; + + /* F2018, C1115: No selector shall appear more than once in a + * given change-team-stmt. */ + if (!strcmp (newAssoc->target->symtree->name, + a->target->symtree->name)) + { + gfc_error ("Selector at %L duplicates selector at %L", + &newAssoc->target->where, &a->target->where); + goto assocListError; + } + } + } + /* The target expression must not be coindexed. */ if (gfc_is_coindexed (newAssoc->target)) { @@ -2042,8 +2164,40 @@ gfc_match_associate (void) assocListError: free (newAssoc); + return MATCH_ERROR; + } + + return MATCH_YES; +} + +/* Match an ASSOCIATE statement. */ + +match +gfc_match_associate (void) +{ + match m; + if (gfc_match_label () == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match (" associate") != MATCH_YES) + return MATCH_NO; + + /* Match the association list. */ + if (gfc_match_char ('(') != MATCH_YES) + { + gfc_error ("Expected association list at %C"); + return MATCH_ERROR; + } + + m = match_association_list (); + if (m == MATCH_ERROR) + goto error; + else if (m == MATCH_NO) + { + gfc_error ("Expected association at %C"); goto error; } + if (gfc_match_char (')') != MATCH_YES) { /* This should never happen as we peek above. */ @@ -3171,6 +3325,7 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) case COMP_ASSOCIATE: case COMP_BLOCK: + case COMP_CHANGE_TEAM: case COMP_IF: case COMP_SELECT: case COMP_SELECT_TYPE: @@ -3848,7 +4003,9 @@ match gfc_match_form_team (void) { match m; - gfc_expr *teamid,*team; + gfc_expr *teamid, *team, *new_index; + + teamid = team = new_index = NULL; if (!gfc_notify_std (GFC_STD_F2018, "FORM TEAM statement at %C")) return MATCH_ERROR; @@ -3866,18 +4023,61 @@ gfc_match_form_team (void) if (gfc_match ("%e", &team) != MATCH_YES) goto syntax; - m = gfc_match_char (')'); + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; if (m == MATCH_NO) + { + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + goto syntax; + } + + for (;;) + { + m = match_stat_errmsg (&new_st.ext.sync_stat, ST_FORM_TEAM); + if (m == MATCH_ERROR) + goto cleanup; + + m = match_named_arg (" new_index = %e", "NEW_INDEX", &new_index, + ST_FORM_TEAM); + if (m == MATCH_ERROR) + goto cleanup; + + m = gfc_match_char (','); + if (m == MATCH_YES) + continue; + + break; + } + + if (m == MATCH_ERROR) + goto syntax; + + if (gfc_match (" )%t") != MATCH_YES) goto syntax; +done: + new_st.expr1 = teamid; new_st.expr2 = team; + new_st.expr3 = new_index; return MATCH_YES; syntax: gfc_syntax_error (ST_FORM_TEAM); +cleanup: + gfc_free_expr (new_index); + gfc_free_expr (new_st.ext.sync_stat.stat); + gfc_free_expr (new_st.ext.sync_stat.errmsg); + new_st.ext.sync_stat = {NULL, NULL}; + + gfc_free_expr (team); + gfc_free_expr (teamid); + return MATCH_ERROR; } @@ -3887,7 +4087,13 @@ match gfc_match_change_team (void) { match m; - gfc_expr *team; + gfc_expr *team = NULL; + + if (gfc_match_label () == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match (" change% team") != MATCH_YES) + return MATCH_NO; if (!gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM statement at %C")) return MATCH_ERROR; @@ -3895,15 +4101,41 @@ gfc_match_change_team (void) if (gfc_match_char ('(') == MATCH_NO) goto syntax; - new_st.op = EXEC_CHANGE_TEAM; - if (gfc_match ("%e", &team) != MATCH_YES) goto syntax; - m = gfc_match_char (')'); + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; if (m == MATCH_NO) + { + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + goto syntax; + } + + m = match_association_list (true); + if (m == MATCH_ERROR) + goto cleanup; + else if (m == MATCH_NO) + for (;;) + { + m = match_stat_errmsg (&new_st.ext.block.sync_stat, ST_CHANGE_TEAM); + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + continue; + + break; + } + + if (gfc_match (" )%t") != MATCH_YES) goto syntax; +done: + new_st.expr1 = team; return MATCH_YES; @@ -3911,20 +4143,49 @@ gfc_match_change_team (void) syntax: gfc_syntax_error (ST_CHANGE_TEAM); +cleanup: + gfc_free_expr (new_st.ext.block.sync_stat.stat); + gfc_free_expr (new_st.ext.block.sync_stat.errmsg); + new_st.ext.block.sync_stat = {NULL, NULL}; + gfc_free_association_list (new_st.ext.block.assoc); + new_st.ext.block.assoc = NULL; + gfc_free_expr (team); + return MATCH_ERROR; } -/* Match a END TEAM statement. */ +/* Match an END TEAM statement. */ match gfc_match_end_team (void) { - if (!gfc_notify_std (GFC_STD_F2018, "END TEAM statement at %C")) - return MATCH_ERROR; + if (gfc_match_eos () == MATCH_YES) + goto done; - if (gfc_match_char ('(') == MATCH_YES) + if (gfc_match_char ('(') != MATCH_YES) + { + /* There could be a team-construct-name following. Let caller decide + about error. */ + new_st.op = EXEC_END_TEAM; + return MATCH_NO; + } + + for (;;) + { + if (match_stat_errmsg (&new_st.ext.sync_stat, ST_END_TEAM) == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + continue; + + break; + } + + if (gfc_match_char (')') != MATCH_YES) goto syntax; +done: + new_st.op = EXEC_END_TEAM; return MATCH_YES; @@ -3932,6 +4193,14 @@ gfc_match_end_team (void) syntax: gfc_syntax_error (ST_END_TEAM); +cleanup: + gfc_free_expr (new_st.ext.sync_stat.stat); + gfc_free_expr (new_st.ext.sync_stat.errmsg); + new_st.ext.sync_stat = {NULL, NULL}; + + /* Try to match the closing bracket to allow error recovery. */ + gfc_match_char (')'); + return MATCH_ERROR; } @@ -3941,7 +4210,7 @@ match gfc_match_sync_team (void) { match m; - gfc_expr *team; + gfc_expr *team = NULL; if (!gfc_notify_std (GFC_STD_F2018, "SYNC TEAM statement at %C")) return MATCH_ERROR; @@ -3954,10 +4223,34 @@ gfc_match_sync_team (void) if (gfc_match ("%e", &team) != MATCH_YES) goto syntax; - m = gfc_match_char (')'); + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; if (m == MATCH_NO) + { + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + goto syntax; + } + + for (;;) + { + m = match_stat_errmsg (&new_st.ext.sync_stat, ST_SYNC_TEAM); + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + continue; + + break; + } + + if (gfc_match (" )%t") != MATCH_YES) goto syntax; +done: + new_st.expr1 = team; return MATCH_YES; @@ -3965,6 +4258,13 @@ gfc_match_sync_team (void) syntax: gfc_syntax_error (ST_SYNC_TEAM); +cleanup: + gfc_free_expr (new_st.ext.sync_stat.stat); + gfc_free_expr (new_st.ext.sync_stat.errmsg); + new_st.ext.sync_stat = {NULL, NULL}; + + gfc_free_expr (team); + return MATCH_ERROR; } @@ -5261,6 +5561,15 @@ gfc_match_return (void) return MATCH_ERROR; } + if (gfc_find_state (COMP_CHANGE_TEAM)) + { + /* F2018, C1111: A RETURN statement shall not appear within a CHANGE TEAM + construct. */ + gfc_error ( + "Image control statement RETURN at %C in CHANGE TEAM-END TEAM block"); + return MATCH_ERROR; + } + if (gfc_match_eos () == MATCH_YES) goto done; diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index a95bb62..538eb65 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -488,6 +488,7 @@ decode_statement (void) match (NULL, gfc_match_do, ST_DO); match (NULL, gfc_match_block, ST_BLOCK); match (NULL, gfc_match_associate, ST_ASSOCIATE); + match (NULL, gfc_match_change_team, ST_CHANGE_TEAM); match (NULL, gfc_match_critical, ST_CRITICAL); match (NULL, gfc_match_select, ST_SELECT_CASE); match (NULL, gfc_match_select_type, ST_SELECT_TYPE); @@ -517,7 +518,6 @@ decode_statement (void) case 'c': match ("call", gfc_match_call, ST_CALL); - match ("change% team", gfc_match_change_team, ST_CHANGE_TEAM); match ("close", gfc_match_close, ST_CLOSE); match ("continue", gfc_match_continue, ST_CONTINUE); match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL); @@ -537,7 +537,6 @@ decode_statement (void) case 'e': match ("end file", gfc_match_endfile, ST_END_FILE); - match ("end team", gfc_match_end_team, ST_END_TEAM); match ("exit", gfc_match_exit, ST_EXIT); match ("else", gfc_match_else, ST_ELSE); match ("else where", gfc_match_elsewhere, ST_ELSEWHERE); @@ -1927,8 +1926,7 @@ next_statement (void) case ST_OMP_INTEROP: \ case ST_ERROR_STOP: case ST_OMP_SCAN: case ST_SYNC_ALL: \ case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \ - case ST_FORM_TEAM: case ST_CHANGE_TEAM: \ - case ST_END_TEAM: case ST_SYNC_TEAM: \ + case ST_FORM_TEAM: case ST_SYNC_TEAM: \ case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \ case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \ case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA @@ -2032,7 +2030,8 @@ next_statement (void) #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \ case ST_END_PROGRAM: case ST_END_SUBROUTINE: \ - case ST_END_BLOCK: case ST_END_ASSOCIATE + case ST_END_BLOCK: case ST_END_ASSOCIATE: \ + case ST_END_TEAM /* Push a new state onto the stack. */ @@ -2164,6 +2163,7 @@ check_statement_label (gfc_statement st) case ST_END_CRITICAL: case ST_END_BLOCK: case ST_END_ASSOCIATE: + case ST_END_TEAM: case_executable: case_exec_markers: if (st == ST_ENDDO || st == ST_CONTINUE) @@ -3199,6 +3199,8 @@ accept_statement (gfc_statement st) case ST_ENTRY: case ST_OMP_METADIRECTIVE: case ST_OMP_BEGIN_METADIRECTIVE: + case ST_CHANGE_TEAM: + case ST_END_TEAM: case_executable: case_exec_markers: add_statement (); @@ -3383,6 +3385,8 @@ verify_st_order (st_state *p, gfc_statement st, bool silent) goto order; break; + case ST_CHANGE_TEAM: + case ST_END_TEAM: case_executable: case_exec_markers: if (p->state < ORDER_EXEC) @@ -5238,30 +5242,12 @@ parse_block_construct (void) pop_state (); } - -/* Parse an ASSOCIATE construct. This is essentially a BLOCK construct - behind the scenes with compiler-generated variables. */ - static void -parse_associate (void) +move_associates_to_block () { - gfc_namespace* my_ns; - gfc_state_data s; - gfc_statement st; - gfc_association_list* a; + gfc_association_list *a; gfc_array_spec *as; - gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C"); - - my_ns = gfc_build_block_ns (gfc_current_ns); - - new_st.op = EXEC_BLOCK; - new_st.ext.block.ns = my_ns; - gcc_assert (new_st.ext.block.assoc); - - /* Add all associate-names as BLOCK variables. Creating them is enough - for now, they'll get their values during trans-* phase. */ - gfc_current_ns = my_ns; for (a = new_st.ext.block.assoc; a; a = a->next) { gfc_symbol *sym, *tsym; @@ -5298,26 +5284,23 @@ parse_associate (void) /* Don’t share the character length information between associate variable and target if the length is not a compile-time constant, - as we don’t want to touch some other character length variable when - we try to initialize the associate variable’s character length - variable. - We do it here rather than later so that expressions referencing the - associate variable will automatically have the correctly setup length - information. If we did it at resolution stage the expressions would - use the original length information, and the variable a new different - one, but only the latter one would be correctly initialized at - translation stage, and the former one would need some additional setup - there. */ - if (sym->ts.type == BT_CHARACTER - && sym->ts.u.cl + as we don’t want to touch some other character length variable + when we try to initialize the associate variable’s character + length variable. We do it here rather than later so that expressions + referencing the associate variable will automatically have the + correctly setup length information. If we did it at resolution stage + the expressions would use the original length information, and the + variable a new different one, but only the latter one would be + correctly initialized at translation stage, and the former one would + need some additional setup there. */ + if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl && !(sym->ts.u.cl->length && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)) sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); /* If the function has been parsed, go straight to the result to obtain the expression rank. */ - if (target->expr_type == EXPR_FUNCTION - && target->symtree + if (target->expr_type == EXPR_FUNCTION && target->symtree && target->symtree->n.sym) { tsym = target->symtree->n.sym; @@ -5344,8 +5327,7 @@ parse_associate (void) by calling gfc_resolve_expr because the context is unavailable. However, the references can be resolved and the rank of the target expression set. */ - if (!sym->assoc->inferred_type - && target->ref && gfc_resolve_ref (target) + if (!sym->assoc->inferred_type && target->ref && gfc_resolve_ref (target) && target->expr_type != EXPR_ARRAY && target->expr_type != EXPR_COMPCALL) gfc_expression_rank (target); @@ -5353,13 +5335,12 @@ parse_associate (void) /* Determine whether or not function expressions with unknown type are structure constructors. If so, the function result can be converted to be a derived type. */ - if (target->expr_type == EXPR_FUNCTION - && target->ts.type == BT_UNKNOWN) + if (target->expr_type == EXPR_FUNCTION && target->ts.type == BT_UNKNOWN) { gfc_symbol *derived; /* The derived type has a leading uppercase character. */ gfc_find_symbol (gfc_dt_upper_string (target->symtree->name), - my_ns->parent, 1, &derived); + gfc_current_ns->parent, 1, &derived); if (derived && derived->attr.flavor == FL_DERIVED) { sym->ts.type = BT_DERIVED; @@ -5394,7 +5375,7 @@ parse_associate (void) attr.codimension = as->corank ? 1 : 0; sym->assoc->variable = true; } - else if (rank || corank) + else if (rank || corank) { as = gfc_get_array_spec (); as->type = AS_DEFERRED; @@ -5449,6 +5430,30 @@ parse_associate (void) } gfc_commit_symbols (); } +} + +/* Parse an ASSOCIATE construct. This is essentially a BLOCK construct + behind the scenes with compiler-generated variables. */ + +static void +parse_associate (void) +{ + gfc_namespace* my_ns; + gfc_state_data s; + gfc_statement st; + + gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C"); + + my_ns = gfc_build_block_ns (gfc_current_ns); + + new_st.op = EXEC_BLOCK; + new_st.ext.block.ns = my_ns; + gcc_assert (new_st.ext.block.assoc); + + /* Add all associate-names as BLOCK variables. Creating them is enough + for now, they'll get their values during trans-* phase. */ + gfc_current_ns = my_ns; + move_associates_to_block (); accept_statement (ST_ASSOCIATE); push_state (&s, COMP_ASSOCIATE, my_ns->proc_name); @@ -5474,6 +5479,49 @@ loop: pop_state (); } +static void +parse_change_team (void) +{ + gfc_namespace *my_ns; + gfc_state_data s; + gfc_statement st; + + gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM construct at %C"); + + my_ns = gfc_build_block_ns (gfc_current_ns); + + new_st.op = EXEC_CHANGE_TEAM; + new_st.ext.block.ns = my_ns; + + /* Add all associate-names as BLOCK variables. Creating them is enough + for now, they'll get their values during trans-* phase. */ + gfc_current_ns = my_ns; + if (new_st.ext.block.assoc) + move_associates_to_block (); + + accept_statement (ST_CHANGE_TEAM); + push_state (&s, COMP_CHANGE_TEAM, my_ns->proc_name); + +loop: + st = parse_executable (ST_NONE); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case_end: + accept_statement (st); + my_ns->code = gfc_state_stack->head; + break; + + default: + unexpected_statement (st); + goto loop; + } + + gfc_current_ns = gfc_current_ns->parent; + pop_state (); +} /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are handled inside of parse_executable(), because they aren't really @@ -6576,6 +6624,7 @@ parse_executable (gfc_statement st) case ST_STOP: case ST_ERROR_STOP: case ST_END_SUBROUTINE: + case ST_END_TEAM: case ST_DO: case ST_FORALL: @@ -6615,6 +6664,10 @@ parse_executable (gfc_statement st) parse_associate (); break; + case ST_CHANGE_TEAM: + parse_change_team (); + break; + case ST_IF_BLOCK: parse_if_block (); break; diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 722e94c..7bf0fa4 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -32,7 +32,7 @@ enum gfc_compile_state COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM, COMP_SELECT_TYPE, COMP_SELECT_RANK, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL, COMP_DO_CONCURRENT, COMP_OMP_STRICTLY_STRUCTURED_BLOCK, - COMP_OMP_METADIRECTIVE, COMP_OMP_BEGIN_METADIRECTIVE + COMP_OMP_METADIRECTIVE, COMP_OMP_BEGIN_METADIRECTIVE, COMP_CHANGE_TEAM }; /* Stack element for the current compilation state. These structures diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index f03708e..e51f83b 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -11484,6 +11484,109 @@ 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_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) +{ + 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 +11596,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; @@ -11616,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; } @@ -11640,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; @@ -13276,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. */ @@ -13481,22 +13573,19 @@ 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: + resolve_end_team (code); break; case EXEC_SYNC_TEAM: - check_team (code->expr1, "SYNC TEAM"); + resolve_sync_team (code); break; case EXEC_ENTRY: diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc index 92ab17b..208251b 100644 --- a/gcc/fortran/simplify.cc +++ b/gcc/fortran/simplify.cc @@ -3133,8 +3133,10 @@ gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED) if (flag_coarray == GFC_FCOARRAY_SINGLE) { gfc_expr *result; - result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus); - result->rank = 0; + result = gfc_get_null_expr (&gfc_current_locus); + result->ts.type = BT_DERIVED; + gfc_find_symbol ("team_type", gfc_current_ns, 1, &result->ts.u.derived); + return result; } @@ -6727,7 +6729,7 @@ gfc_simplify_null (gfc_expr *mold) gfc_expr * -gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed) +gfc_simplify_num_images (gfc_expr *team_or_team_number ATTRIBUTE_UNUSED) { gfc_expr *result; @@ -6740,16 +6742,9 @@ gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed) if (flag_coarray != GFC_FCOARRAY_SINGLE) return NULL; - if (failed && failed->expr_type != EXPR_CONSTANT) - return NULL; - /* FIXME: gfc_current_locus is wrong. */ result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus); - - if (failed && failed->value.logical != 0) - mpz_set_si (result->value.integer, 0); - else mpz_set_si (result->value.integer, 1); return result; @@ -8925,7 +8920,8 @@ gfc_simplify_trim (gfc_expr *e) gfc_expr * -gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub) +gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub, + gfc_expr *team_or_team_number ATTRIBUTE_UNUSED) { gfc_expr *result; gfc_ref *ref; @@ -9067,14 +9063,13 @@ gfc_simplify_image_status (gfc_expr *image, gfc_expr *team ATTRIBUTE_UNUSED) gfc_expr * gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim, - gfc_expr *distance ATTRIBUTE_UNUSED) + gfc_expr *team ATTRIBUTE_UNUSED) { if (flag_coarray != GFC_FCOARRAY_SINGLE) return NULL; - /* If no coarray argument has been passed or when the first argument - is actually a distance argument. */ - if (coarray == NULL || !gfc_is_coarray (coarray)) + /* If no coarray argument has been passed. */ + if (coarray == NULL) { gfc_expr *result; /* FIXME: gfc_current_locus is wrong. */ diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index ddc4960..ee48a82 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -4043,9 +4043,9 @@ gfc_build_builtin_function_decls (void) gfor_fndecl_caf_finalize = gfc_build_library_function_decl ( get_identifier (PREFIX("caf_finalize")), void_type_node, 0); - gfor_fndecl_caf_this_image = gfc_build_library_function_decl ( - get_identifier (PREFIX("caf_this_image")), integer_type_node, - 1, integer_type_node); + gfor_fndecl_caf_this_image = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("caf_this_image")), ". r ", integer_type_node, + 1, pvoid_type_node); gfor_fndecl_caf_num_images = gfc_build_library_function_decl ( get_identifier (PREFIX("caf_num_images")), integer_type_node, @@ -4201,42 +4201,36 @@ gfc_build_builtin_function_decls (void) void_type_node, 3, pvoid_type_node, ppvoid_type_node, integer_type_node); - gfor_fndecl_caf_form_team - = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_form_team")), ". . W . ", - void_type_node, 3, integer_type_node, ppvoid_type_node, - integer_type_node); + gfor_fndecl_caf_form_team = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("caf_form_team")), ". r w r w w w ", + void_type_node, 6, integer_type_node, ppvoid_type_node, pint_type, + pint_type, pchar_type_node, size_type_node); - gfor_fndecl_caf_change_team - = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_change_team")), ". w . ", - void_type_node, 2, ppvoid_type_node, - integer_type_node); + gfor_fndecl_caf_change_team = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("caf_change_team")), ". r w w w ", + void_type_node, 4, pvoid_type_node, pint_type, pchar_type_node, + size_type_node); - gfor_fndecl_caf_end_team - = gfc_build_library_function_decl ( - get_identifier (PREFIX("caf_end_team")), void_type_node, 0); + gfor_fndecl_caf_end_team = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("caf_end_team")), ". w w w ", void_type_node, 3, + pint_type, pchar_type_node, size_type_node); - gfor_fndecl_caf_get_team - = gfc_build_library_function_decl ( - get_identifier (PREFIX("caf_get_team")), - void_type_node, 1, integer_type_node); + gfor_fndecl_caf_get_team = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("caf_get_team")), ". r ", pvoid_type_node, 1, + pint_type); - gfor_fndecl_caf_sync_team - = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_sync_team")), ". r . ", - void_type_node, 2, ppvoid_type_node, - integer_type_node); + gfor_fndecl_caf_sync_team = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("caf_sync_team")), ". r w w w ", void_type_node, + 4, pvoid_type_node, pint_type, pchar_type_node, size_type_node); gfor_fndecl_caf_team_number = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_team_number")), ". r ", integer_type_node, 1, integer_type_node); - gfor_fndecl_caf_image_status - = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_image_status")), ". . r ", - integer_type_node, 2, integer_type_node, ppvoid_type_node); + gfor_fndecl_caf_image_status = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("caf_image_status")), ". r r ", + integer_type_node, 2, integer_type_node, ppvoid_type_node); gfor_fndecl_caf_stopped_images = gfc_build_library_function_decl_with_spec ( diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 62dd38d..19e5669b 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -2579,10 +2579,8 @@ gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc) gcc_assert (ref != NULL); if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE) - { - return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, - integer_zero_node); - } + return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, + null_pointer_node); img_idx = build_zero_cst (gfc_array_index_type); extent = build_one_cst (gfc_array_index_type); @@ -9836,7 +9834,12 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, && !cm->attr.proc_pointer) { if (cm->attr.allocatable && expr->expr_type == EXPR_NULL) - gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); + { + gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); + if (cm->attr.codimension && flag_coarray == GFC_FCOARRAY_LIB) + gfc_add_modify (&block, gfc_conv_descriptor_token (dest), + null_pointer_node); + } else if (cm->attr.allocatable || cm->attr.pdt_array) { tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr); diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 6ffc3e0..440cbdd 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -1183,8 +1183,10 @@ conv_stat_and_team (stmtblock_t *block, gfc_expr *expr, tree *stat, tree *team, { gfc_se team_se; gfc_init_se (&team_se, NULL); - gfc_conv_expr_reference (&team_se, team_e); - *team = team_se.expr; + gfc_conv_expr (&team_se, team_e); + *team + = gfc_build_addr_expr (NULL_TREE, gfc_trans_force_lval (&team_se.pre, + team_se.expr)); gfc_add_block_to_block (block, &team_se.pre); gfc_add_block_to_block (block, &team_se.post); } @@ -1196,8 +1198,11 @@ conv_stat_and_team (stmtblock_t *block, gfc_expr *expr, tree *stat, tree *team, { gfc_se team_se; gfc_init_se (&team_se, NULL); - gfc_conv_expr_reference (&team_se, team_e); - *team_no = team_se.expr; + gfc_conv_expr (&team_se, team_e); + *team_no = gfc_build_addr_expr ( + NULL_TREE, + gfc_trans_force_lval (&team_se.pre, + fold_convert (integer_type_node, team_se.expr))); gfc_add_block_to_block (block, &team_se.pre); gfc_add_block_to_block (block, &team_se.post); } @@ -1379,9 +1384,9 @@ gfc_conv_intrinsic_caf_is_present_remote (gfc_se *se, gfc_expr *e) present_fn = e->value.function.actual->next->next->expr; add_data_sym = present_fn->symtree->n.sym->formal->sym; - fn_index = conv_caf_func_index (&se->pre, gfc_current_ns, + fn_index = conv_caf_func_index (&se->pre, e->symtree->n.sym->ns, "__caf_present_on_remote_fn_index_%d", hash); - add_data_tree = conv_caf_add_call_data (&se->pre, gfc_current_ns, + add_data_tree = conv_caf_add_call_data (&se->pre, e->symtree->n.sym->ns, "__caf_present_on_remote_add_data_%d", add_data_sym, &add_data_size); ++caf_call_cnt; @@ -1790,13 +1795,13 @@ conv_caf_sendget (gfc_code *code) ++caf_call_cnt; tmp = build_call_expr_loc ( - input_location, gfor_fndecl_caf_transfer_between_remotes, 20, lhs_token, + input_location, gfor_fndecl_caf_transfer_between_remotes, 22, lhs_token, opt_lhs_desc, opt_lhs_charlen, lhs_image_index, receiver_fn_index_tree, lhs_add_data_tree, lhs_add_data_size, rhs_token, opt_rhs_desc, opt_rhs_charlen, rhs_image_index, sender_fn_index_tree, rhs_add_data_tree, rhs_add_data_size, rhs_size, transfer_rank == 0 ? boolean_true_node : boolean_false_node, lhs_stat, - lhs_team, lhs_team_no, rhs_stat, rhs_team, rhs_team_no); + rhs_stat, lhs_team, lhs_team_no, rhs_team, rhs_team_no); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&block, &lhs_se.post); @@ -1818,34 +1823,31 @@ static void trans_this_image (gfc_se * se, gfc_expr *expr) { stmtblock_t loop; - tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var, - lbound, ubound, extent, ml; + tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var, lbound, + ubound, extent, ml, team; gfc_se argse; int rank, corank; - gfc_expr *distance = expr->value.function.actual->next->next->expr; - - if (expr->value.function.actual->expr - && !gfc_is_coarray (expr->value.function.actual->expr)) - distance = expr->value.function.actual->expr; /* The case -fcoarray=single is handled elsewhere. */ gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE); + /* Translate team, if present. */ + if (expr->value.function.actual->next->next->expr) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, expr->value.function.actual->next->next->expr); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + team = fold_convert (pvoid_type_node, argse.expr); + } + else + team = null_pointer_node; + /* Argument-free version: THIS_IMAGE(). */ - if (distance || expr->value.function.actual->expr == NULL) + if (expr->value.function.actual->expr == NULL) { - if (distance) - { - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, distance); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - tmp = fold_convert (integer_type_node, argse.expr); - } - else - tmp = integer_zero_node; tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, - tmp); + team); se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp); return; @@ -1940,8 +1942,8 @@ trans_this_image (gfc_se * se, gfc_expr *expr) */ /* this_image () - 1. */ - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, - integer_zero_node); + tmp + = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, team); tmp = fold_build2_loc (input_location, MINUS_EXPR, type, fold_convert (type, tmp), build_int_cst (type, 1)); if (corank == 1) @@ -2072,7 +2074,8 @@ conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr) } else if (flag_coarray == GFC_FCOARRAY_LIB) tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2, - args[0], build_int_cst (integer_type_node, -1)); + args[0], + num_args < 2 ? null_pointer_node : args[1]); else gcc_unreachable (); @@ -2092,18 +2095,7 @@ conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr) if (flag_coarray == GFC_FCOARRAY_SINGLE && expr->value.function.actual->expr) - { - tree arg; - - arg = gfc_evaluate_now (args[0], &se->pre); - tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - fold_convert (integer_type_node, arg), - integer_one_node); - tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, - tmp, integer_zero_node, - build_int_cst (integer_type_node, - GFC_STAT_STOPPED_IMAGE)); - } + tmp = gfc_evaluate_now (args[0], &se->pre); else if (flag_coarray == GFC_FCOARRAY_SINGLE) { // the value -1 represents that no team has been created yet @@ -2111,10 +2103,10 @@ conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr) } else if (flag_coarray == GFC_FCOARRAY_LIB && expr->value.function.actual->expr) tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1, - args[0], build_int_cst (integer_type_node, -1)); + args[0]); else if (flag_coarray == GFC_FCOARRAY_LIB) tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1, - integer_zero_node, build_int_cst (integer_type_node, -1)); + null_pointer_node); else gcc_unreachable (); @@ -2125,8 +2117,8 @@ conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr) static void trans_image_index (gfc_se * se, gfc_expr *expr) { - tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc, - tmp, invalid_bound; + tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc, tmp, + invalid_bound, team = null_pointer_node, team_number = null_pointer_node; gfc_se argse, subse; int rank, corank, codim; @@ -2150,6 +2142,22 @@ trans_image_index (gfc_se * se, gfc_expr *expr) subdesc = build_fold_indirect_ref_loc (input_location, gfc_conv_descriptor_data_get (subse.expr)); + if (expr->value.function.actual->next->next->expr) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_descriptor (&argse, + expr->value.function.actual->next->next->expr); + if (expr->value.function.actual->next->next->expr->ts.type == BT_DERIVED) + team = argse.expr; + else + team_number = gfc_build_addr_expr ( + NULL_TREE, + gfc_trans_force_lval (&argse.pre, + fold_convert (integer_type_node, argse.expr))); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + } + /* Fortran 2008 does not require that the values remain in the cobounds, thus we need explicitly check this - and return 0 if they are exceeded. */ @@ -2225,8 +2233,7 @@ trans_image_index (gfc_se * se, gfc_expr *expr) else { tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2, - integer_zero_node, - build_int_cst (integer_type_node, -1)); + team, team_number); num_images = fold_convert (type, tmp); } @@ -2245,32 +2252,26 @@ trans_image_index (gfc_se * se, gfc_expr *expr) static void trans_num_images (gfc_se * se, gfc_expr *expr) { - tree tmp, distance, failed; + tree tmp, team = null_pointer_node, team_number = null_pointer_node; gfc_se argse; if (expr->value.function.actual->expr) { gfc_init_se (&argse, NULL); gfc_conv_expr_val (&argse, expr->value.function.actual->expr); + if (expr->value.function.actual->expr->ts.type == BT_DERIVED) + team = argse.expr; + else + team_number = gfc_build_addr_expr ( + NULL_TREE, + gfc_trans_force_lval (&se->pre, + fold_convert (integer_type_node, argse.expr))); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); - distance = fold_convert (integer_type_node, argse.expr); } - else - distance = integer_zero_node; - if (expr->value.function.actual->next->expr) - { - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, expr->value.function.actual->next->expr); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - failed = fold_convert (integer_type_node, argse.expr); - } - else - failed = build_int_cst (integer_type_node, -1); tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2, - distance, failed); + team, team_number); se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp); } @@ -2700,8 +2701,7 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank); tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, - 2, integer_zero_node, - build_int_cst (integer_type_node, -1)); + 2, null_pointer_node, null_pointer_node); tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, fold_convert (gfc_array_index_type, tmp), @@ -2716,8 +2716,7 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) { /* ubound = lbound + num_images() - 1. */ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, - 2, integer_zero_node, - build_int_cst (integer_type_node, -1)); + 2, null_pointer_node, null_pointer_node); tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, fold_convert (gfc_array_index_type, tmp), @@ -11475,6 +11474,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) case GFC_ISYM_GETGID: case GFC_ISYM_GETPID: case GFC_ISYM_GETUID: + case GFC_ISYM_GET_TEAM: case GFC_ISYM_HOSTNM: case GFC_ISYM_IERRNO: case GFC_ISYM_IRAND: @@ -12970,6 +12970,9 @@ gfc_conv_intrinsic_mvbits (gfc_se *se, gfc_actual_arglist *actual_args, void_type_node, to, se->expr); } +/* Comes from trans-stmt.cc, but we don't want the whole header included. */ +extern void gfc_trans_sync_stat (struct sync_stat *sync_stat, gfc_se *se, + tree *stat, tree *errmsg, tree *errmsg_len); static tree conv_intrinsic_move_alloc (gfc_code *code) @@ -12977,17 +12980,37 @@ conv_intrinsic_move_alloc (gfc_code *code) stmtblock_t block; gfc_expr *from_expr, *to_expr; gfc_se from_se, to_se; - tree tmp, to_tree, from_tree; + tree tmp, to_tree, from_tree, stat, errmsg, errmsg_len, fin_label = NULL_TREE; bool coarray, from_is_class, from_is_scalar; + gfc_actual_arglist *arg = code->ext.actual; + sync_stat tmp_sync_stat = {nullptr, nullptr}; gfc_start_block (&block); - from_expr = code->ext.actual->expr; - to_expr = code->ext.actual->next->expr; + from_expr = arg->expr; + arg = arg->next; + to_expr = arg->expr; + arg = arg->next; + + while (arg) + { + if (arg->expr) + { + if (!strcmp ("stat", arg->name)) + tmp_sync_stat.stat = arg->expr; + else if (!strcmp ("errmsg", arg->name)) + tmp_sync_stat.errmsg = arg->expr; + } + arg = arg->next; + } gfc_init_se (&from_se, NULL); gfc_init_se (&to_se, NULL); + gfc_trans_sync_stat (&tmp_sync_stat, &from_se, &stat, &errmsg, &errmsg_len); + if (stat != null_pointer_node) + fin_label = gfc_build_label_decl (NULL_TREE); + gcc_assert (from_expr->ts.type != BT_CLASS || to_expr->ts.type == BT_CLASS); coarray = from_expr->corank != 0; @@ -13030,9 +13053,10 @@ conv_intrinsic_move_alloc (gfc_code *code) /* Deallocate "to". */ if (to_expr->rank == 0) { - tmp - = gfc_deallocate_scalar_with_status (to_tree, NULL_TREE, NULL_TREE, - true, to_expr, to_expr->ts); + tmp = gfc_deallocate_scalar_with_status (to_tree, stat, fin_label, + true, to_expr, to_expr->ts, + NULL_TREE, false, true, + errmsg, errmsg_len); gfc_add_expr_to_block (&block, tmp); } @@ -13105,9 +13129,12 @@ conv_intrinsic_move_alloc (gfc_code *code) { tree cond; - tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE, - NULL_TREE, NULL_TREE, true, to_expr, - GFC_CAF_COARRAY_DEALLOCATE_ONLY); + tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len, + fin_label, true, to_expr, + GFC_CAF_COARRAY_DEALLOCATE_ONLY, + NULL_TREE, NULL_TREE, + gfc_conv_descriptor_token (to_se.expr), + true); gfc_add_expr_to_block (&block, tmp); tmp = gfc_conv_descriptor_data_get (to_se.expr); @@ -13133,9 +13160,10 @@ conv_intrinsic_move_alloc (gfc_code *code) gfc_add_expr_to_block (&block, tmp); } - tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE, - NULL_TREE, NULL_TREE, true, to_expr, - GFC_CAF_COARRAY_NOCOARRAY); + tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len, + fin_label, true, to_expr, + GFC_CAF_COARRAY_NOCOARRAY, NULL_TREE, + NULL_TREE, NULL_TREE, true); gfc_add_expr_to_block (&block, tmp); } @@ -13147,6 +13175,13 @@ conv_intrinsic_move_alloc (gfc_code *code) gfc_add_modify_loc (input_location, &block, tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node)); + if (coarray && flag_coarray == GFC_FCOARRAY_LIB) + { + /* Copy the array descriptor data has overwritten the to-token and cleared + from.data. Now also clear the from.token. */ + gfc_add_modify (&block, gfc_conv_descriptor_token (from_se.expr), + null_pointer_node); + } if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred) { @@ -13157,6 +13192,8 @@ conv_intrinsic_move_alloc (gfc_code *code) gfc_add_modify_loc (input_location, &block, from_se.string_length, build_int_cst (TREE_TYPE (from_se.string_length), 0)); } + if (fin_label) + gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, fin_label)); return gfc_finish_block (&block); } diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index 37f8aca..487b768 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -721,6 +721,15 @@ gfc_trans_stop (gfc_code *code, bool error_stop) return gfc_finish_block (&se.pre); } +tree +trans_exit () +{ + const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); + gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); + tree tmp = gfc_get_symbol_decl (exsym); + return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); +} + /* Translate the FAIL IMAGE statement. */ tree @@ -730,11 +739,49 @@ gfc_trans_fail_image (gfc_code *code ATTRIBUTE_UNUSED) return build_call_expr_loc (input_location, gfor_fndecl_caf_fail_image, 0); else + return trans_exit (); +} + +void +gfc_trans_sync_stat (struct sync_stat *sync_stat, gfc_se *se, tree *stat, + tree *errmsg, tree *errmsg_len) +{ + gfc_se argse; + + if (sync_stat->stat) { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, sync_stat->stat); + gfc_add_block_to_block (&se->pre, &argse.pre); + + if (TREE_TYPE (argse.expr) != integer_type_node) + { + tree tstat = gfc_create_var (integer_type_node, "stat"); + TREE_THIS_VOLATILE (tstat) = 1; + gfc_add_modify (&se->pre, tstat, + fold_convert (integer_type_node, argse.expr)); + gfc_add_modify (&se->post, argse.expr, + fold_convert (TREE_TYPE (argse.expr), tstat)); + *stat = build_fold_addr_expr (tstat); + } + else + *stat = build_fold_addr_expr (argse.expr); + } + else + *stat = null_pointer_node; + + if (sync_stat->errmsg) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_reference (&argse, sync_stat->errmsg); + gfc_add_block_to_block (&se->pre, &argse.pre); + *errmsg = argse.expr; + *errmsg_len = fold_convert (size_type_node, argse.string_length); + } + else + { + *errmsg = null_pointer_node; + *errmsg_len = build_zero_cst (size_type_node); } } @@ -745,38 +792,42 @@ gfc_trans_form_team (gfc_code *code) { if (flag_coarray == GFC_FCOARRAY_LIB) { - gfc_se se; - gfc_se argse1, argse2; - tree team_id, team_type, tmp; + gfc_se se, argse; + tree team_id, team_type, new_index, stat, errmsg, errmsg_len, tmp; gfc_init_se (&se, NULL); - gfc_init_se (&argse1, NULL); - gfc_init_se (&argse2, NULL); - gfc_start_block (&se.pre); + gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse1, code->expr1); - gfc_conv_expr_val (&argse2, code->expr2); - team_id = fold_convert (integer_type_node, argse1.expr); - team_type = gfc_build_addr_expr (ppvoid_type_node, argse2.expr); + gfc_conv_expr_val (&argse, code->expr1); + team_id = fold_convert (integer_type_node, argse.expr); + gfc_conv_expr_reference (&argse, code->expr2); + team_type = argse.expr; - gfc_add_block_to_block (&se.pre, &argse1.pre); - gfc_add_block_to_block (&se.pre, &argse2.pre); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_form_team, 3, - team_id, team_type, - integer_zero_node); + /* NEW_INDEX=. */ + if (code->expr3) + { + gfc_conv_expr_reference (&argse, code->expr3); + new_index = argse.expr; + } + else + new_index = null_pointer_node; + + gfc_add_block_to_block (&se.post, &argse.post); + + gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg, + &errmsg_len); + + gfc_add_block_to_block (&se.pre, &argse.pre); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_form_team, 6, + team_id, team_type, new_index, stat, errmsg, + errmsg_len); gfc_add_expr_to_block (&se.pre, tmp); - gfc_add_block_to_block (&se.pre, &argse1.post); - gfc_add_block_to_block (&se.pre, &argse2.post); + gfc_add_block_to_block (&se.pre, &se.post); return gfc_finish_block (&se.pre); - } + } else - { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); - } + return trans_exit (); } /* Translate the CHANGE TEAM statement. */ @@ -786,47 +837,56 @@ gfc_trans_change_team (gfc_code *code) { if (flag_coarray == GFC_FCOARRAY_LIB) { - gfc_se argse; - tree team_type, tmp; + stmtblock_t block; + gfc_se se; + tree team_type, stat, errmsg, errmsg_len, tmp; - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, code->expr1); - team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr); + gfc_init_se (&se, NULL); + gfc_start_block (&block); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_change_team, 2, team_type, - integer_zero_node); - gfc_add_expr_to_block (&argse.pre, tmp); - gfc_add_block_to_block (&argse.pre, &argse.post); - return gfc_finish_block (&argse.pre); + gfc_conv_expr_val (&se, code->expr1); + team_type = se.expr; + + gfc_trans_sync_stat (&code->ext.block.sync_stat, &se, &stat, &errmsg, + &errmsg_len); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_change_team, 4, + team_type, stat, errmsg, errmsg_len); + + gfc_add_expr_to_block (&se.pre, tmp); + gfc_add_block_to_block (&se.pre, &se.post); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_expr_to_block (&block, gfc_trans_block_construct (code)); + return gfc_finish_block (&block); } else - { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); - } + return trans_exit (); } /* Translate the END TEAM statement. */ tree -gfc_trans_end_team (gfc_code *code ATTRIBUTE_UNUSED) +gfc_trans_end_team (gfc_code *code) { if (flag_coarray == GFC_FCOARRAY_LIB) { - return build_call_expr_loc (input_location, - gfor_fndecl_caf_end_team, 1, - build_int_cst (pchar_type_node, 0)); + gfc_se se; + tree stat, errmsg, errmsg_len, tmp; + + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg, + &errmsg_len); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_end_team, 3, + stat, errmsg, errmsg_len); + gfc_add_expr_to_block (&se.pre, tmp); + gfc_add_block_to_block (&se.pre, &se.post); + return gfc_finish_block (&se.pre); } else - { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); - } + return trans_exit (); } /* Translate the SYNC TEAM statement. */ @@ -836,28 +896,25 @@ gfc_trans_sync_team (gfc_code *code) { if (flag_coarray == GFC_FCOARRAY_LIB) { - gfc_se argse; - tree team_type, tmp; + gfc_se se; + tree team_type, stat, errmsg, errmsg_len, tmp; - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, code->expr1); - team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr); + gfc_init_se (&se, NULL); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_sync_team, 2, - team_type, - integer_zero_node); - gfc_add_expr_to_block (&argse.pre, tmp); - gfc_add_block_to_block (&argse.pre, &argse.post); - return gfc_finish_block (&argse.pre); + gfc_conv_expr_val (&se, code->expr1); + team_type = se.expr; + + gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg, + &errmsg_len); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_team, 4, + team_type, stat, errmsg, errmsg_len); + gfc_add_expr_to_block (&se.pre, tmp); + gfc_add_block_to_block (&se.pre, &se.post); + return gfc_finish_block (&se.pre); } else - { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); - } + return trans_exit (); } tree @@ -1280,8 +1337,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) { tree cond2; tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, - 2, integer_zero_node, - build_int_cst (integer_type_node, -1)); + 2, null_pointer_node, null_pointer_node); cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, images2, tmp); cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, @@ -1609,35 +1665,41 @@ gfc_trans_arithmetic_if (gfc_code * code) /* Translate a CRITICAL block. */ + tree gfc_trans_critical (gfc_code *code) -{ - stmtblock_t block; - tree tmp, token = NULL_TREE; + { + stmtblock_t block; + tree tmp, token = NULL_TREE; + tree stat = NULL_TREE, errmsg, errmsg_len; - gfc_start_block (&block); + gfc_start_block (&block); - if (flag_coarray == GFC_FCOARRAY_LIB) - { - tree zero_size = build_zero_cst (size_type_node); - token = gfc_get_symbol_decl (code->resolved_sym); - token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token)); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7, - token, zero_size, integer_one_node, - null_pointer_node, null_pointer_node, - null_pointer_node, zero_size); - gfc_add_expr_to_block (&block, tmp); + if (flag_coarray == GFC_FCOARRAY_LIB) + { + gfc_se se; - /* It guarantees memory consistency within the same segment */ - tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), - tmp = build5_loc (input_location, ASM_EXPR, void_type_node, - gfc_build_string_const (1, ""), - NULL_TREE, NULL_TREE, - tree_cons (NULL_TREE, tmp, NULL_TREE), - NULL_TREE); - ASM_VOLATILE_P (tmp) = 1; + gfc_init_se (&se, NULL); + gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg, + &errmsg_len); + gfc_add_block_to_block (&block, &se.pre); - gfc_add_expr_to_block (&block, tmp); + token = gfc_get_symbol_decl (code->resolved_sym); + token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token)); + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7, + token, integer_zero_node, integer_one_node, + null_pointer_node, stat, errmsg, errmsg_len); + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&block, &se.post); + + /* It guarantees memory consistency within the same segment. */ + tmp = gfc_build_string_const (strlen ("memory") + 1, "memory"), + tmp = build5_loc (input_location, ASM_EXPR, void_type_node, + gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, + tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); + ASM_VOLATILE_P (tmp) = 1; + + gfc_add_expr_to_block (&block, tmp); } tmp = gfc_trans_code (code->block->next); @@ -1645,11 +1707,19 @@ gfc_trans_critical (gfc_code *code) if (flag_coarray == GFC_FCOARRAY_LIB) { - tree zero_size = build_zero_cst (size_type_node); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_unlock, 6, - token, zero_size, integer_one_node, - null_pointer_node, null_pointer_node, - zero_size); + /* END CRITICAL does not accept STAT or ERRMSG arguments. + * If STAT= is specified for CRITICAL, pass a stat argument to + * _gfortran_caf_lock_unlock to prevent termination in the event of an + * error, but ignore any value assigned to it. + */ + tmp = build_call_expr_loc ( + input_location, gfor_fndecl_caf_unlock, 6, token, integer_zero_node, + integer_one_node, + stat != NULL_TREE + ? gfc_build_addr_expr (NULL, + gfc_create_var (integer_type_node, "stat")) + : null_pointer_node, + null_pointer_node, integer_zero_node); gfc_add_expr_to_block (&block, tmp); /* It guarantees memory consistency within the same segment */ @@ -1981,11 +2051,35 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1; } - if (sym->attr.codimension && !sym->attr.dimension) + if (sym->attr.codimension) se.want_coarray = 1; gfc_conv_expr_descriptor (&se, e); + if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension) + { + tree token = gfc_conv_descriptor_token (se.expr), + size + = sym->attr.dimension + ? fold_build2 (MULT_EXPR, gfc_array_index_type, + gfc_conv_descriptor_size (se.expr, e->rank), + gfc_conv_descriptor_span_get (se.expr)) + : gfc_conv_descriptor_span_get (se.expr); + /* Create a new token, because in the token the modified descriptor + is stored. The modified descriptor is needed for accesses on the + remote image. In the scalar case, the base address needs to be + associated correctly, which also needs a new token. + The token is freed automatically be the end team statement. */ + gfc_add_expr_to_block ( + &se.pre, + build_call_expr_loc ( + input_location, gfor_fndecl_caf_register, 7, size, + build_int_cst (integer_type_node, GFC_CAF_COARRAY_MAP_EXISTING), + gfc_build_addr_expr (pvoid_type_node, token), + gfc_build_addr_expr (NULL_TREE, se.expr), null_pointer_node, + null_pointer_node, integer_zero_node)); + } + if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary && sym->ts.u.cl->backend_decl diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index 67b1970..8fbcdcb 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -58,6 +58,7 @@ tree gfc_trans_sync (gfc_code *, gfc_exec_op); tree gfc_trans_lock_unlock (gfc_code *, gfc_exec_op); tree gfc_trans_event_post_wait (gfc_code *, gfc_exec_op); tree gfc_trans_fail_image (gfc_code *); +void gfc_trans_sync_stat (struct sync_stat *, gfc_se *, tree *, tree *, tree *); tree gfc_trans_forall (gfc_code *); tree gfc_trans_form_team (gfc_code *); tree gfc_trans_change_team (gfc_code *); diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index b03dcc1..fdeb1e8 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -1795,11 +1795,11 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived, analyzed and set by this routine, and -2 to indicate that a non-coarray is to be deallocated. */ tree -gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, - tree errlen, tree label_finish, - bool can_fail, gfc_expr* expr, +gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tree errlen, + tree label_finish, bool can_fail, gfc_expr *expr, int coarray_dealloc_mode, tree class_container, - tree add_when_allocated, tree caf_token) + tree add_when_allocated, tree caf_token, + bool unalloc_ok) { stmtblock_t null, non_null; tree cond, tmp, error; @@ -1891,7 +1891,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, fold_build1_loc (input_location, INDIRECT_REF, status_type, status), - build_int_cst (status_type, 1)); + build_int_cst (status_type, unalloc_ok ? 0 : 1)); error = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2, tmp, error); } @@ -1975,10 +1975,10 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, token = gfc_build_addr_expr (NULL_TREE, token); gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_deregister, 5, - token, build_int_cst (integer_type_node, - caf_dereg_type), + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_deregister, 5, + token, + build_int_cst (integer_type_node, + caf_dereg_type), pstat, errmsg, errlen); gfc_add_expr_to_block (&non_null, tmp); @@ -1990,7 +1990,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, ASM_VOLATILE_P (tmp) = 1; gfc_add_expr_to_block (&non_null, tmp); - if (status != NULL_TREE) + if (status != NULL_TREE && !integer_zerop (status)) { tree stat = build_fold_indirect_ref_loc (input_location, status); tree nullify = fold_build2_loc (input_location, MODIFY_EXPR, @@ -2024,9 +2024,10 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tree gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, - bool can_fail, gfc_expr* expr, + bool can_fail, gfc_expr *expr, gfc_typespec ts, tree class_container, - bool coarray) + bool coarray, bool unalloc_ok, tree errmsg, + tree errmsg_len) { stmtblock_t null, non_null; tree cond, tmp, error; @@ -2069,7 +2070,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, fold_build1_loc (input_location, INDIRECT_REF, status_type, status), - build_int_cst (status_type, 1)); + build_int_cst (status_type, unalloc_ok ? 0 : 1)); error = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2, tmp, error); } @@ -2134,7 +2135,8 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, else { tree token; - tree pstat = null_pointer_node; + tree pstat = null_pointer_node, perrmsg = null_pointer_node, + perrlen = size_zero_node; gfc_se se; gfc_init_se (&se, NULL); @@ -2147,11 +2149,17 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, pstat = status; } - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_deregister, 5, - token, build_int_cst (integer_type_node, - caf_dereg_type), - pstat, null_pointer_node, integer_zero_node); + if (errmsg != NULL_TREE) + { + perrmsg = errmsg; + perrlen = errmsg_len; + } + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_deregister, 5, + token, + build_int_cst (integer_type_node, + caf_dereg_type), + pstat, perrmsg, perrlen); gfc_add_expr_to_block (&non_null, tmp); /* It guarantees memory consistency within the same segment. */ diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index ae7be9f..461b0cd 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -139,10 +139,10 @@ enum gfc_coarray_regtype GFC_CAF_EVENT_STATIC, GFC_CAF_EVENT_ALLOC, GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY, - GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY + GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY, + GFC_CAF_COARRAY_MAP_EXISTING }; - /* Describes the action to take on _caf_deregister. Keep in sync with gcc/fortran/trans.h. The negative values are not valid for the library and are used by the drivers for building the correct call. */ @@ -774,12 +774,13 @@ void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree, tree = NULL_TREE); /* Generate code to deallocate an array. */ -tree gfc_deallocate_with_status (tree, tree, tree, tree, tree, bool, - gfc_expr *, int, tree = NULL_TREE, - tree a = NULL_TREE, tree c = NULL_TREE); -tree gfc_deallocate_scalar_with_status (tree, tree, tree, bool, gfc_expr*, +tree gfc_deallocate_with_status (tree, tree, tree, tree, tree, bool, gfc_expr *, + int, tree = NULL_TREE, tree a = NULL_TREE, + tree c = NULL_TREE, bool u = false); +tree gfc_deallocate_scalar_with_status (tree, tree, tree, bool, gfc_expr *, gfc_typespec, tree = NULL_TREE, - bool c = false); + bool c = false, bool u = false, + tree = NULL_TREE, tree = NULL_TREE); /* Generate code to call realloc(). */ tree gfc_call_realloc (stmtblock_t *, tree, tree); |