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))
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. */
case EXEC_END_TEAM:
fputs ("END TEAM", dumpfile);
+ show_sync_stat (&c->ext.sync_stat);
break;
case EXEC_FORM_TEAM:
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:
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);
LOCALITY_NUM
};
+struct sync_stat
+{
+ gfc_expr *stat, *errmsg;
+};
+
typedef struct gfc_code
{
gfc_exec_op op;
gfc_omp_variant *omp_variants;
bool omp_bool;
int stop_code;
+ struct sync_stat sync_stat;
struct
{
unsigned arr_spec_from_expr3:1;
/* expr3 is not explicit */
unsigned expr3_not_explicit:1;
+ struct sync_stat sync_stat;
}
alloc;
gfc_namespace *ns;
gfc_association_list *assoc;
gfc_case *case_list;
+ struct sync_stat sync_stat;
}
block;
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 *);
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,
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 *);
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;
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");
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))
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. */
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;
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;
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;
}
}
}
+static void
+resolve_team_argument (gfc_expr *team)
+{
+ gfc_resolve_expr (team);
+ if (team->rank != 0 || team->ts.type != BT_DERIVED
+ || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
+ || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE)
+ {
+ gfc_error ("TEAM argument at %L must be a scalar expression "
+ "of type TEAM_TYPE from the intrinsic module ISO_FORTRAN_ENV",
+ &team->where);
+ }
+}
+
+static void
+resolve_scalar_variable_as_arg (const char *name, bt exp_type, int exp_kind,
+ gfc_expr *e)
+{
+ gfc_resolve_expr (e);
+ if (e
+ && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0
+ || e->expr_type != EXPR_VARIABLE))
+ gfc_error ("%s argument at %L must be a scalar %s variable of at least "
+ "kind %d", name, &e->where, gfc_basic_typename (exp_type),
+ exp_kind);
+}
+
+void
+gfc_resolve_sync_stat (struct sync_stat *sync_stat)
+{
+ resolve_scalar_variable_as_arg ("STAT=", BT_INTEGER, 2, sync_stat->stat);
+ resolve_scalar_variable_as_arg ("ERRMSG=", BT_CHARACTER,
+ gfc_default_character_kind,
+ sync_stat->errmsg);
+}
+static void
+resolve_sync_team (gfc_code *code)
+{
+ resolve_team_argument (code->expr1);
+ gfc_resolve_sync_stat (&code->ext.sync_stat);
+}
+
+static void
+resolve_end_team (gfc_code *code)
+{
+ gfc_resolve_sync_stat (&code->ext.sync_stat);
+}
static void
resolve_critical (gfc_code *code)
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;
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:
get_identifier (PREFIX("caf_get_team")),
void_type_node, 1, integer_type_node);
- 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 (
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)
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;
/* 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);
}
{
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);
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);
}
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)
{
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);
}
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
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);
}
}
/* 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. */
{
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
/* 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);
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 */
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);
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 *);
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;
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);
}
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);
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,
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;
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);
}
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);
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. */
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);
--- /dev/null
+!{ dg-do compile }
+!{ dg-additional-options "-fcoarray=lib" }
+
+! Test critical syntax errors with stat= and errmsg= specifiers
+
+ implicit none
+ integer :: istat
+ character(len=30) :: err
+ integer(kind=1) :: too_small_stat
+
+ critical (stat=err) !{ dg-error "must be a scalar INTEGER" }
+ continue
+ end critical
+
+ critical (stat=istat, stat=istat) !{ dg-error "Duplicate STAT" }
+ continue
+ end critical !{ dg-error "Expecting END PROGRAM" }
+
+ critical (stat=istat, errmsg=istat) !{ dg-error "must be a scalar CHARACTER variable" }
+ continue
+ end critical
+
+ critical (stat=istat, errmsg=err, errmsg=err) !{ dg-error "Duplicate ERRMSG" }
+ continue
+ end critical !{ dg-error "Expecting END PROGRAM" }
+
+ critical (stat=too_small_stat) !{ dg-error "scalar INTEGER variable of at least kind 2" }
+ continue
+ end critical
+end
--- /dev/null
+! { dg-do run }
+! { dg-options "-fcoarray=lib -fdump-tree-original -lcaf_single" }
+! { dg-additional-options "-latomic" { target libatomic_available } }
+
+! PR 87939
+! Test critical construct with stat= and errmsg= specifiers
+!
+ use, intrinsic :: iso_fortran_env, only: int16
+ implicit none
+ integer :: istat = 42
+ integer(kind=int16) :: istat16 = 42
+ character(len=30) :: err = 'unchanged'
+ integer :: fail = 0
+
+ critical (stat=istat, errmsg=err)
+ if (istat /= 0) fail = 1
+ if (trim(err) /= 'unchanged') fail = 2
+ end critical
+
+ if (fail /= 0) stop fail
+
+ critical (stat=istat16, errmsg=err)
+ if (istat16 /= 0) fail = 3
+ if (trim(err) /= 'unchanged') fail = 4
+ end critical
+
+ if (fail /= 0) stop fail
+end
+
+! { dg-final { scan-tree-dump "_gfortran_caf_lock \\(caf_token\\.\[0-9\]+, 0, 1, 0B, &istat, &err, 30\\);" "original" } }
+! { dg-final { scan-tree-dump "_gfortran_caf_lock \\(caf_token\\.\[0-9\]+, 0, 1, 0B, &stat\\.\[0-9\]+, &err, 30\\);" "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock \\(caf_token\\.\[0-9\]+, 0, 1, &stat\\.\[0-9\]+, 0B, 0\\);" 2 "original" } }
--- /dev/null
+!{ dg-do compile }
+
+! General error checking for move_alloc parameter list.
+
+integer, allocatable :: i, o
+integer :: st, s2
+character(30) :: e, e2
+
+ call move_alloc(i, o, STAT=st)
+ call move_alloc(i, o, STAT=st, STAT=s2) !{ dg-error "Keyword 'stat' at \\(1\\) has already appeared in the current argument list" }
+ call move_alloc(i, o, STAT=e) !{ dg-error "STAT= argument at \\(1\\) must be a scalar INTEGER variable of at least kind 2" }
+ call move_alloc(i, o, STAT=[st, s2]) !{ dg-error "STAT= argument at \\(1\\) must be a scalar INTEGER variable of at least kind 2" }
+ call move_alloc(i, o, STAT=.TRUE.) !{ dg-error "STAT= argument at \\(1\\) must be a scalar INTEGER variable of at least kind 2" }
+
+ call move_alloc(i, o, STAT=st, ERRMSG=e)
+ call move_alloc(i, o, ERRMSG=e)
+ call move_alloc(i, o, ERRMSG=e, ERRMSG=e2) !{ dg-error "Keyword 'errmsg' at \\(1\\) has already appeared in the current argument list" }
+ call move_alloc(i, o, ERRMSG=st) !{ dg-error "ERRMSG= argument at \\(1\\) must be a scalar CHARACTER variable of at least kind 1" }
+ call move_alloc(i, o, ERRMSG=.TRUE.) !{ dg-error "ERRMSG= argument at \\(1\\) must be a scalar CHARACTER variable of at least kind 1" }
+
+
+end
+
--- /dev/null
+!{ dg-do compile }
+!{ dg-additional-options "-fcoarray=lib" }
+
+! PR 87939
+! Test sync team syntax errors
+
+ use iso_fortran_env, only : team_type
+ implicit none
+ integer :: istat
+ character(len=30) :: err
+ type(team_type) :: team
+
+ form team (mod(this_image(),2)+1, team)
+
+ change team (team)
+ sync team ! { dg-error "Syntax error in SYNC TEAM statement" }
+ sync team (err) ! { dg-error "must be a scalar expression of type TEAM_TYPE" }
+ sync team (team, istat) ! { dg-error "Syntax error in SYNC TEAM statement" }
+ sync team (team, stat=err) ! { dg-error "must be a scalar INTEGER" }
+ sync team (team, stat=istat, stat=istat) ! { dg-error "Duplicate STAT" }
+ sync team (team, stat=istat, errmsg=istat) ! { dg-error "must be a scalar CHARACTER variable" }
+ sync team (team, stat=istat, errmsg=err, errmsg=err) ! { dg-error "Duplicate ERRMSG" }
+ end team
+end
{
*acquired_lock = (int) false;
if (stat)
- *stat = 0;
- return;
+ *stat = GFC_STAT_LOCKED;
+ return;
}
if (stat)
{
- *stat = 1;
+ *stat = GFC_STAT_LOCKED;
if (errmsg_len > 0)
{
size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len
if (stat)
{
- *stat = 1;
+ *stat = GFC_STAT_UNLOCKED;
if (errmsg_len > 0)
{
size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len
projects / thirdparty / gcc.git / commitdiff
