This adds support for parsing OpenMP metadirectives in the Fortran front end.
2022-01-25 Kwok Cheung Yeung <kcy@codesourcery.com>
gcc/
* omp-general.c (omp_check_context_selector): Revert string length
check.
(omp_context_name_list_prop): Likewise.
gcc/fortran/
* decl.c (gfc_match_end): Handle COMP_OMP_METADIRECTIVE and
COMP_OMP_BEGIN_METADIRECTIVE.
* dump-parse-tree.c (show_omp_node): Handle EXEC_OMP_METADIRECTIVE.
(show_code_node): Handle EXEC_OMP_METADIRECTIVE.
* gfortran.h (enum gfc_statement): Add ST_OMP_METADIRECTIVE,
ST_OMP_BEGIN_METADIRECTIVE and ST_OMP_END_METADIRECTIVE.
(struct gfc_omp_metadirective_clause): New structure.
(gfc_get_omp_metadirective_clause): New macro.
(struct gfc_st_label): Add omp_region field.
(enum gfc_exec_op): Add EXEC_OMP_METADIRECTIVE.
(struct gfc_code): Add omp_metadirective_clauses field.
(gfc_free_omp_metadirective_clauses): New prototype.
(match_omp_directive): New prototype.
* io.c (format_asterisk): Initialize omp_region field.
* match.h (gfc_match_omp_begin_metadirective): New prototype.
(gfc_match_omp_metadirective): New prototype.
* openmp.c (gfc_match_omp_eos): Match ')' in context selectors.
(gfc_free_omp_metadirective_clauses): New.
(gfc_match_omp_clauses): Remove context_selector argument. Rely on
gfc_match_omp_eos to match end of clauses.
(match_omp): Remove extra argument to gfc_match_omp_clauses.
(gfc_match_omp_context_selector): Remove extra argument to
gfc_match_omp_clauses. Set gfc_matching_omp_context_selector
before call to gfc_match_omp_clauses and reset after.
(gfc_match_omp_context_selector_specification): Modify to take a
gfc_omp_set_selector** argument.
(gfc_match_omp_declare_variant): Pass set_selectors to
gfc_match_omp_context_selector_specification.
(match_omp_metadirective): New.
(gfc_match_omp_begin_metadirective): New.
(gfc_match_omp_metadirective): New.
(resolve_omp_metadirective): New.
(gfc_resolve_omp_directive): Handle EXEC_OMP_METADIRECTIVE.
* parse.c (gfc_matching_omp_context_selector): New variable.
(gfc_in_metadirective_body): New variable.
(gfc_omp_region_count): New variable.
(decode_omp_directive): Match 'begin metadirective',
'end metadirective' and 'metadirective'.
(match_omp_directive): New.
(case_omp_structured_block): New.
(case_omp_do): New.
(gfc_ascii_statement): Handle metadirective statements.
(gfc_omp_end_stmt): New.
(parse_omp_do): Delegate to gfc_omp_end_stmt.
(parse_omp_structured_block): Delegate to gfc_omp_end_stmt. Handle
ST_OMP_END_METADIRECTIVE.
(parse_omp_metadirective_body): New.
(parse_executable): Delegate to case_omp_structured_block and
case_omp_do. Return after one statement if compiling regular
metadirective. Handle metadirective statements.
(gfc_parse_file): Reset gfc_omp_region_count,
gfc_in_metadirective_body and gfc_matching_omp_context_selector.
* parse.h (enum gfc_compile_state): Add COMP_OMP_METADIRECTIVE and
COMP_OMP_BEGIN_METADIRECTIVE.
(gfc_omp_end_stmt): New prototype.
(gfc_matching_omp_context_selector): New declaration.
(gfc_in_metadirective_body): New declaration.
(gfc_omp_region_count): New declaration.
* resolve.c (gfc_resolve_code): Handle EXEC_OMP_METADIRECTIVE.
* st.c (gfc_free_statement): Handle EXEC_OMP_METADIRECTIVE.
* symbol.c (compare_st_labels): Take omp_region into account.
(gfc_get_st_labels): Incorporate omp_region into label.
* trans-decl.c (gfc_get_label_decl): Add omp_region into translated
label name.
* trans-openmp.c (gfc_trans_omp_directive): Handle
EXEC_OMP_METADIRECTIVE.
(gfc_trans_omp_set_selector): Hoist code from...
(gfc_trans_omp_declare_variant): ...here.
(gfc_trans_omp_metadirective): New.
* trans-stmt.h (gfc_trans_omp_metadirective): New prototype.
* trans.c (trans_code): Handle EXEC_OMP_METADIRECTIVE.
+2022-01-25 Kwok Cheung Yeung <kcy@codesourcery.com>
+
+ * omp-general.c (omp_check_context_selector): Revert string length
+ check.
+ (omp_context_name_list_prop): Likewise.
+
2022-01-25 Kwok Cheung Yeung <kcy@codesourcery.com>
* Makefile.in (OBJS): Add omp-expand-metadirective.o.
+2022-01-25 Kwok Cheung Yeung <kcy@codesourcery.com>
+
+ * decl.c (gfc_match_end): Handle COMP_OMP_METADIRECTIVE and
+ COMP_OMP_BEGIN_METADIRECTIVE.
+ * dump-parse-tree.c (show_omp_node): Handle EXEC_OMP_METADIRECTIVE.
+ (show_code_node): Handle EXEC_OMP_METADIRECTIVE.
+ * gfortran.h (enum gfc_statement): Add ST_OMP_METADIRECTIVE,
+ ST_OMP_BEGIN_METADIRECTIVE and ST_OMP_END_METADIRECTIVE.
+ (struct gfc_omp_metadirective_clause): New structure.
+ (gfc_get_omp_metadirective_clause): New macro.
+ (struct gfc_st_label): Add omp_region field.
+ (enum gfc_exec_op): Add EXEC_OMP_METADIRECTIVE.
+ (struct gfc_code): Add omp_metadirective_clauses field.
+ (gfc_free_omp_metadirective_clauses): New prototype.
+ (match_omp_directive): New prototype.
+ * io.c (format_asterisk): Initialize omp_region field.
+ * match.h (gfc_match_omp_begin_metadirective): New prototype.
+ (gfc_match_omp_metadirective): New prototype.
+ * openmp.c (gfc_match_omp_eos): Match ')' in context selectors.
+ (gfc_free_omp_metadirective_clauses): New.
+ (gfc_match_omp_clauses): Remove context_selector argument. Rely on
+ gfc_match_omp_eos to match end of clauses.
+ (match_omp): Remove extra argument to gfc_match_omp_clauses.
+ (gfc_match_omp_context_selector): Remove extra argument to
+ gfc_match_omp_clauses. Set gfc_matching_omp_context_selector
+ before call to gfc_match_omp_clauses and reset after.
+ (gfc_match_omp_context_selector_specification): Modify to take a
+ gfc_omp_set_selector** argument.
+ (gfc_match_omp_declare_variant): Pass set_selectors to
+ gfc_match_omp_context_selector_specification.
+ (match_omp_metadirective): New.
+ (gfc_match_omp_begin_metadirective): New.
+ (gfc_match_omp_metadirective): New.
+ (resolve_omp_metadirective): New.
+ (gfc_resolve_omp_directive): Handle EXEC_OMP_METADIRECTIVE.
+ * parse.c (gfc_matching_omp_context_selector): New variable.
+ (gfc_in_metadirective_body): New variable.
+ (gfc_omp_region_count): New variable.
+ (decode_omp_directive): Match 'begin metadirective',
+ 'end metadirective' and 'metadirective'.
+ (match_omp_directive): New.
+ (case_omp_structured_block): New.
+ (case_omp_do): New.
+ (gfc_ascii_statement): Handle metadirective statements.
+ (gfc_omp_end_stmt): New.
+ (parse_omp_do): Delegate to gfc_omp_end_stmt.
+ (parse_omp_structured_block): Delegate to gfc_omp_end_stmt. Handle
+ ST_OMP_END_METADIRECTIVE.
+ (parse_omp_metadirective_body): New.
+ (parse_executable): Delegate to case_omp_structured_block and
+ case_omp_do. Return after one statement if compiling regular
+ metadirective. Handle metadirective statements.
+ (gfc_parse_file): Reset gfc_omp_region_count,
+ gfc_in_metadirective_body and gfc_matching_omp_context_selector.
+ * parse.h (enum gfc_compile_state): Add COMP_OMP_METADIRECTIVE and
+ COMP_OMP_BEGIN_METADIRECTIVE.
+ (gfc_omp_end_stmt): New prototype.
+ (gfc_matching_omp_context_selector): New declaration.
+ (gfc_in_metadirective_body): New declaration.
+ (gfc_omp_region_count): New declaration.
+ * resolve.c (gfc_resolve_code): Handle EXEC_OMP_METADIRECTIVE.
+ * st.c (gfc_free_statement): Handle EXEC_OMP_METADIRECTIVE.
+ * symbol.c (compare_st_labels): Take omp_region into account.
+ (gfc_get_st_labels): Incorporate omp_region into label.
+ * trans-decl.c (gfc_get_label_decl): Add omp_region into translated
+ label name.
+ * trans-openmp.c (gfc_trans_omp_directive): Handle
+ EXEC_OMP_METADIRECTIVE.
+ (gfc_trans_omp_set_selector): Hoist code from...
+ (gfc_trans_omp_declare_variant): ...here.
+ (gfc_trans_omp_metadirective): New.
+ * trans-stmt.h (gfc_trans_omp_metadirective): New prototype.
+ * trans.c (trans_code): Handle EXEC_OMP_METADIRECTIVE.
+
2022-01-23 Sandra Loosemore <sandra@codesourcery.com>
PR fortran/103695
case COMP_CONTAINS:
case COMP_DERIVED_CONTAINS:
+ case COMP_OMP_METADIRECTIVE:
+ case COMP_OMP_BEGIN_METADIRECTIVE:
state = gfc_state_stack->previous->state;
block_name = gfc_state_stack->previous->sym == NULL
? NULL : gfc_state_stack->previous->sym->name;
gfc_free_enum_history ();
break;
+ case COMP_OMP_BEGIN_METADIRECTIVE:
+ *st = ST_OMP_END_METADIRECTIVE;
+ target = " metadirective";
+ eos_ok = 0;
+ break;
+
default:
gfc_error ("Unexpected END statement at %C");
goto cleanup;
case EXEC_OMP_MASTER: name = "MASTER"; break;
case EXEC_OMP_MASTER_TASKLOOP: name = "MASTER TASKLOOP"; break;
case EXEC_OMP_MASTER_TASKLOOP_SIMD: name = "MASTER TASKLOOP SIMD"; break;
+ case EXEC_OMP_METADIRECTIVE: name = "METADIRECTIVE"; break;
case EXEC_OMP_ORDERED: name = "ORDERED"; break;
case EXEC_OMP_DEPOBJ: name = "DEPOBJ"; break;
case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
d = d->block;
}
}
+ else if (c->op == EXEC_OMP_METADIRECTIVE)
+ {
+ gfc_omp_metadirective_clause *clause = c->ext.omp_metadirective_clauses;
+
+ while (clause)
+ {
+ code_indent (level + 1, 0);
+ if (clause->selectors)
+ fputs ("WHEN ()\n", dumpfile);
+ else
+ fputs ("DEFAULT ()\n", dumpfile);
+ /* TODO: Print selector. */
+ show_code (level + 2, clause->code);
+ if (clause->next)
+ fputs ("\n", dumpfile);
+ clause = clause->next;
+ }
+ }
else
show_code (level + 1, c->block->next);
if (c->op == EXEC_OMP_ATOMIC)
case EXEC_OMP_MASTER:
case EXEC_OMP_MASTER_TASKLOOP:
case EXEC_OMP_MASTER_TASKLOOP_SIMD:
+ case EXEC_OMP_METADIRECTIVE:
case EXEC_OMP_ORDERED:
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD, ST_OMP_MASKED_TASKLOOP,
ST_OMP_END_MASKED_TASKLOOP, ST_OMP_MASKED_TASKLOOP_SIMD,
ST_OMP_END_MASKED_TASKLOOP_SIMD, ST_OMP_SCOPE, ST_OMP_END_SCOPE,
+ ST_OMP_METADIRECTIVE, ST_OMP_BEGIN_METADIRECTIVE, ST_OMP_END_METADIRECTIVE,
ST_OMP_ERROR, ST_NONE
};
gfc_omp_declare_variant;
#define gfc_get_omp_declare_variant() XCNEW (gfc_omp_declare_variant)
+typedef struct gfc_omp_metadirective_clause
+{
+ struct gfc_omp_metadirective_clause *next;
+ locus where; /* Where the metadirective clause occurred. */
+
+ gfc_omp_set_selector *selectors;
+ enum gfc_statement stmt;
+ struct gfc_code *code;
+
+} gfc_omp_metadirective_clause;
+#define gfc_get_omp_metadirective_clause() XCNEW (gfc_omp_metadirective_clause)
typedef struct gfc_omp_udr
{
locus where;
gfc_namespace *ns;
+ int omp_region;
}
gfc_st_label;
EXEC_OMP_TARGET_TEAMS_LOOP, EXEC_OMP_MASKED, EXEC_OMP_PARALLEL_MASKED,
EXEC_OMP_PARALLEL_MASKED_TASKLOOP, EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD,
EXEC_OMP_MASKED_TASKLOOP, EXEC_OMP_MASKED_TASKLOOP_SIMD, EXEC_OMP_SCOPE,
+ EXEC_OMP_METADIRECTIVE,
EXEC_OMP_ERROR
};
gfc_omp_clauses *omp_clauses;
const char *omp_name;
gfc_omp_namelist *omp_namelist;
+ gfc_omp_metadirective_clause *omp_metadirective_clauses;
bool omp_bool;
}
ext; /* Points to additional structures required by statement */
void gfc_free_omp_declare_simd (gfc_omp_declare_simd *);
void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *);
void gfc_free_omp_udr (gfc_omp_udr *);
+void gfc_free_omp_metadirective_clauses (gfc_omp_metadirective_clause *);
gfc_omp_udr *gfc_omp_udr_find (gfc_symtree *, gfc_typespec *);
void gfc_resolve_omp_directive (gfc_code *, gfc_namespace *);
void gfc_resolve_do_iterator (gfc_code *, gfc_symbol *, bool);
bool gfc_parse_file (void);
void gfc_global_used (gfc_gsymbol *, locus *);
gfc_namespace* gfc_build_block_ns (gfc_namespace *);
+gfc_statement match_omp_directive (void);
/* dependency.c */
int gfc_dep_compare_functions (gfc_expr *, gfc_expr *, bool);
gfc_st_label
format_asterisk = {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL,
- 0, {NULL, NULL}, NULL};
+ 0, {NULL, NULL}, NULL, 0};
typedef struct
{
match gfc_match_omp_eos_error (void);
match gfc_match_omp_atomic (void);
match gfc_match_omp_barrier (void);
+match gfc_match_omp_begin_metadirective (void);
match gfc_match_omp_cancel (void);
match gfc_match_omp_cancellation_point (void);
match gfc_match_omp_critical (void);
match gfc_match_omp_master (void);
match gfc_match_omp_master_taskloop (void);
match gfc_match_omp_master_taskloop_simd (void);
+match gfc_match_omp_metadirective (void);
match gfc_match_omp_nothing (void);
match gfc_match_omp_ordered (void);
match gfc_match_omp_ordered_depend (void);
#include "target-memory.h" /* For gfc_encode_character. */
/* Match an end of OpenMP directive. End of OpenMP directive is optional
- whitespace, followed by '\n' or comment '!'. */
+ whitespace, followed by '\n' or comment '!'. In the special case where a
+ context selector is being matched, match against ')' instead. */
static match
gfc_match_omp_eos (void)
old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
- c = gfc_next_ascii_char ();
- switch (c)
+ if (gfc_matching_omp_context_selector)
{
- case '!':
- do
- c = gfc_next_ascii_char ();
- while (c != '\n');
- /* Fall through */
-
- case '\n':
- return MATCH_YES;
+ if (gfc_peek_ascii_char () == ')')
+ return MATCH_YES;
+ }
+ else
+ {
+ c = gfc_next_ascii_char ();
+ switch (c)
+ {
+ case '!':
+ do
+ c = gfc_next_ascii_char ();
+ while (c != '\n');
+ /* Fall through */
+
+ case '\n':
+ return MATCH_YES;
+ }
}
gfc_current_locus = old_loc;
}
}
+/* Free clauses of an !$omp metadirective construct. */
+
+void
+gfc_free_omp_metadirective_clauses (gfc_omp_metadirective_clause *clause)
+{
+ while (clause)
+ {
+ gfc_omp_metadirective_clause *next_clause = clause->next;
+ gfc_free_omp_set_selector_list (clause->selectors);
+ free (clause);
+ clause = next_clause;
+ }
+}
static gfc_omp_udr *
gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
static match
gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
bool first = true, bool needs_space = true,
- bool openacc = false, bool context_selector = false,
- bool openmp_target = false)
+ bool openacc = false, bool openmp_target = false)
{
bool error = false;
gfc_omp_clauses *c = gfc_get_omp_clauses ();
}
end:
- if (error
- || (context_selector && gfc_peek_ascii_char () != ')')
- || (!context_selector && gfc_match_omp_eos () != MATCH_YES))
+ if (error || gfc_match_omp_eos () != MATCH_YES)
{
if (!gfc_error_flag_test ())
gfc_error ("Failed to match clause at %C");
match_omp (gfc_exec_op op, const omp_mask mask)
{
gfc_omp_clauses *c;
- if (gfc_match_omp_clauses (&c, mask, true, true, false, false,
+ if (gfc_match_omp_clauses (&c, mask, true, true, false,
op == EXEC_OMP_TARGET) != MATCH_YES)
return MATCH_ERROR;
new_st.op = op;
break;
case CTX_PROPERTY_SIMD:
{
+ gfc_matching_omp_context_selector = true;
if (gfc_match_omp_clauses (&otp->clauses,
OMP_DECLARE_SIMD_CLAUSES,
- true, false, false, true)
+ true, false, false)
!= MATCH_YES)
{
- gfc_error ("expected simd clause at %C");
+ gfc_matching_omp_context_selector = false;
+ gfc_error ("expected simd clause at %C");
return MATCH_ERROR;
}
+ gfc_matching_omp_context_selector = false;
break;
}
default:
user */
match
-gfc_match_omp_context_selector_specification (gfc_omp_declare_variant *odv)
+gfc_match_omp_context_selector_specification (gfc_omp_set_selector **oss_head)
{
do
{
}
gfc_omp_set_selector *oss = gfc_get_omp_set_selector ();
- oss->next = odv->set_selectors;
+ oss->next = *oss_head;
oss->trait_set_selector_name = selector_sets[i];
- odv->set_selectors = oss;
+ *oss_head = oss;
if (gfc_match_omp_context_selector (oss) != MATCH_YES)
return MATCH_ERROR;
return MATCH_ERROR;
}
- if (gfc_match_omp_context_selector_specification (odv) != MATCH_YES)
+ if (gfc_match_omp_context_selector_specification (&odv->set_selectors)
+ != MATCH_YES)
return MATCH_ERROR;
if (gfc_match (" )") != MATCH_YES)
}
+static match
+match_omp_metadirective (bool begin_p)
+{
+ locus old_loc = gfc_current_locus;
+ gfc_omp_metadirective_clause *clause_head;
+ gfc_omp_metadirective_clause **next_clause = &clause_head;
+ bool default_seen = false;
+
+ /* Parse the context selectors. */
+ for (;;)
+ {
+ bool default_p = false;
+ gfc_omp_set_selector *selectors = NULL;
+
+ if (gfc_match (" default ( ") == MATCH_YES)
+ default_p = true;
+ else if (gfc_match_eos () == MATCH_YES)
+ break;
+ else if (gfc_match (" when ( ") != MATCH_YES)
+ {
+ gfc_error ("expected 'default' or 'when' at %C");
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+ }
+
+ if (default_p && default_seen)
+ {
+ gfc_error ("there can only be one default clause in a "
+ "metadirective at %C");
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+ }
+
+ if (!default_p)
+ {
+ if (gfc_match_omp_context_selector_specification (&selectors)
+ != MATCH_YES)
+ return MATCH_ERROR;
+
+ if (gfc_match (" : ") != MATCH_YES)
+ {
+ gfc_error ("expected ':' at %C");
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+ }
+
+ gfc_commit_symbols ();
+ }
+
+ gfc_matching_omp_context_selector = true;
+ gfc_statement directive = match_omp_directive ();
+ gfc_matching_omp_context_selector = false;
+
+ if (gfc_error_flag_test ())
+ {
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match (" )") != MATCH_YES)
+ {
+ gfc_error ("Expected ')' at %C");
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+ }
+
+ gfc_commit_symbols ();
+
+ if (begin_p && directive != ST_NONE
+ && gfc_omp_end_stmt (directive) == ST_NONE)
+ {
+ gfc_error ("variant directive used in OMP BEGIN METADIRECTIVE "
+ "at %C must have a corresponding end directive");
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+ }
+
+ if (default_p)
+ default_seen = true;
+
+ gfc_omp_metadirective_clause *omc = gfc_get_omp_metadirective_clause ();
+ omc->selectors = selectors;
+ omc->stmt = directive;
+ if (directive == ST_NONE)
+ {
+ /* The directive was a 'nothing' directive. */
+ omc->code = gfc_get_code (EXEC_CONTINUE);
+ omc->code->ext.omp_clauses = NULL;
+ }
+ else
+ {
+ omc->code = gfc_get_code (new_st.op);
+ omc->code->ext.omp_clauses = new_st.ext.omp_clauses;
+ /* Prevent the OpenMP clauses from being freed via NEW_ST. */
+ new_st.ext.omp_clauses = NULL;
+ }
+
+ *next_clause = omc;
+ next_clause = &omc->next;
+ }
+
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after OMP METADIRECTIVE at %C");
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+ }
+
+ /* Add a 'default (nothing)' clause if no default is explicitly given. */
+ if (!default_seen)
+ {
+ gfc_omp_metadirective_clause *omc = gfc_get_omp_metadirective_clause ();
+ omc->stmt = ST_NONE;
+ omc->code = gfc_get_code (EXEC_CONTINUE);
+ omc->code->ext.omp_clauses = NULL;
+ omc->selectors = NULL;
+
+ *next_clause = omc;
+ next_clause = &omc->next;
+ }
+
+ new_st.op = EXEC_OMP_METADIRECTIVE;
+ new_st.ext.omp_metadirective_clauses = clause_head;
+
+ return MATCH_YES;
+}
+
+match
+gfc_match_omp_begin_metadirective (void)
+{
+ return match_omp_metadirective (true);
+}
+
+match
+gfc_match_omp_metadirective (void)
+{
+ return match_omp_metadirective (false);
+}
+
match
gfc_match_omp_threadprivate (void)
{
}
}
+static void
+resolve_omp_metadirective (gfc_code *code, gfc_namespace *ns)
+{
+ gfc_omp_metadirective_clause *clause = code->ext.omp_metadirective_clauses;
+
+ while (clause)
+ {
+ gfc_code *clause_code = clause->code;
+ gfc_resolve_code (clause_code, ns);
+ clause = clause->next;
+ }
+}
+
static void
resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
code->ext.omp_clauses->if_present = false;
resolve_omp_clauses (code, code->ext.omp_clauses, ns);
break;
+ case EXEC_OMP_METADIRECTIVE:
+ resolve_omp_metadirective (code, ns);
+ break;
default:
break;
}
gfc_state_data *gfc_state_stack;
static bool last_was_use_stmt = false;
+bool gfc_matching_omp_context_selector;
+bool gfc_in_metadirective_body;
+int gfc_omp_region_count;
+
/* TODO: Re-order functions to kill these forward decls. */
static void check_statement_label (gfc_statement);
static void undo_new_statement (void);
break;
case 'b':
matcho ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
+ matcho ("begin metadirective", gfc_match_omp_begin_metadirective,
+ ST_OMP_BEGIN_METADIRECTIVE);
break;
case 'c':
matcho ("cancellation% point", gfc_match_omp_cancellation_point,
matcho ("end master taskloop", gfc_match_omp_eos_error,
ST_OMP_END_MASTER_TASKLOOP);
matcho ("end master", gfc_match_omp_eos_error, ST_OMP_END_MASTER);
+ matcho ("end metadirective", gfc_match_omp_eos_error,
+ ST_OMP_END_METADIRECTIVE);
matchs ("end ordered", gfc_match_omp_eos_error, ST_OMP_END_ORDERED);
matchs ("end parallel do simd", gfc_match_omp_eos_error,
ST_OMP_END_PARALLEL_DO_SIMD);
matcho ("master taskloop", gfc_match_omp_master_taskloop,
ST_OMP_MASTER_TASKLOOP);
matcho ("master", gfc_match_omp_master, ST_OMP_MASTER);
+ matcho ("metadirective", gfc_match_omp_metadirective,
+ ST_OMP_METADIRECTIVE);
break;
case 'n':
matcho ("nothing", gfc_match_omp_nothing, ST_NONE);
gfc_error_now ("Unclassifiable OpenMP directive at %C");
}
+ /* If parsing a metadirective, let the caller deal with the cleanup. */
+ if (gfc_matching_omp_context_selector)
+ return ST_NONE;
+
reject_statement ();
gfc_error_recovery ();
return ST_GET_FCN_CHARACTERISTICS;
}
+gfc_statement
+match_omp_directive (void)
+{
+ return decode_omp_directive ();
+}
+
static gfc_statement
decode_gcc_attribute (void)
{
case ST_OMP_DECLARE_VARIANT: \
case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
+/* OpenMP statements that are followed by a structured block. */
+
+#define case_omp_structured_block case ST_OMP_PARALLEL: \
+ case ST_OMP_PARALLEL_MASKED: case ST_OMP_PARALLEL_MASTER: \
+ case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_ORDERED: \
+ case ST_OMP_CRITICAL: case ST_OMP_MASKED: case ST_OMP_MASTER: \
+ case ST_OMP_SCOPE: case ST_OMP_SECTIONS: case ST_OMP_SINGLE: \
+ case ST_OMP_TARGET: case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_PARALLEL: \
+ case ST_OMP_TARGET_TEAMS: case ST_OMP_TEAMS: case ST_OMP_TASK: \
+ case ST_OMP_TASKGROUP: \
+ case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE
+
+/* OpenMP statements that are followed by a do loop. */
+
+#define case_omp_do case ST_OMP_DISTRIBUTE: \
+ case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
+ case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE_SIMD: \
+ case ST_OMP_DO: case ST_OMP_DO_SIMD: case ST_OMP_LOOP: \
+ case ST_OMP_PARALLEL_DO: case ST_OMP_PARALLEL_DO_SIMD: \
+ case ST_OMP_PARALLEL_LOOP: case ST_OMP_PARALLEL_MASKED_TASKLOOP: \
+ case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: \
+ case ST_OMP_PARALLEL_MASTER_TASKLOOP: \
+ case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: \
+ case ST_OMP_MASKED_TASKLOOP: case ST_OMP_MASKED_TASKLOOP_SIMD: \
+ case ST_OMP_MASTER_TASKLOOP: case ST_OMP_MASTER_TASKLOOP_SIMD: \
+ case ST_OMP_SIMD: \
+ case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \
+ case ST_OMP_TARGET_PARALLEL_LOOP: case ST_OMP_TARGET_SIMD: \
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: case ST_OMP_TARGET_TEAMS_LOOP: \
+ case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \
+ case ST_OMP_TEAMS_DISTRIBUTE: case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
+ case ST_OMP_TEAMS_DISTRIBUTE_SIMD: case ST_OMP_TEAMS_LOOP
+
/* Block end statements. Errors associated with interchanging these
are detected in gfc_match_end(). */
case ST_OMP_BARRIER:
p = "!$OMP BARRIER";
break;
+ case ST_OMP_BEGIN_METADIRECTIVE:
+ p = "!$OMP BEGIN METADIRECTIVE";
+ break;
case ST_OMP_CANCEL:
p = "!$OMP CANCEL";
break;
case ST_OMP_END_MASTER_TASKLOOP_SIMD:
p = "!$OMP END MASTER TASKLOOP SIMD";
break;
+ case ST_OMP_END_METADIRECTIVE:
+ p = "!OMP END METADIRECTIVE";
+ break;
case ST_OMP_END_ORDERED:
p = "!$OMP END ORDERED";
break;
case ST_OMP_MASTER_TASKLOOP_SIMD:
p = "!$OMP MASTER TASKLOOP SIMD";
break;
+ case ST_OMP_METADIRECTIVE:
+ p = "!$OMP METADIRECTIVE";
+ break;
case ST_OMP_ORDERED:
case ST_OMP_ORDERED_DEPEND:
p = "!$OMP ORDERED";
break;
case ST_ENTRY:
+ case ST_OMP_METADIRECTIVE:
+ case ST_OMP_BEGIN_METADIRECTIVE:
case_executable:
case_exec_markers:
add_statement ();
accept_statement (st);
}
+/* Get the corresponding ending statement type for the OpenMP directive
+ OMP_ST. If it does not have one, return ST_NONE. */
+
+gfc_statement
+gfc_omp_end_stmt (gfc_statement omp_st,
+ bool omp_do_p, bool omp_structured_p)
+{
+ if (omp_do_p)
+ {
+ switch (omp_st)
+ {
+ case ST_OMP_DISTRIBUTE: return ST_OMP_END_DISTRIBUTE;
+ case ST_OMP_DISTRIBUTE_PARALLEL_DO:
+ return ST_OMP_END_DISTRIBUTE_PARALLEL_DO;
+ case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ return ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD;
+ case ST_OMP_DISTRIBUTE_SIMD:
+ return ST_OMP_END_DISTRIBUTE_SIMD;
+ case ST_OMP_DO: return ST_OMP_END_DO;
+ case ST_OMP_DO_SIMD: return ST_OMP_END_DO_SIMD;
+ case ST_OMP_LOOP: return ST_OMP_END_LOOP;
+ case ST_OMP_PARALLEL_DO: return ST_OMP_END_PARALLEL_DO;
+ case ST_OMP_PARALLEL_DO_SIMD:
+ return ST_OMP_END_PARALLEL_DO_SIMD;
+ case ST_OMP_PARALLEL_LOOP:
+ return ST_OMP_END_PARALLEL_LOOP;
+ case ST_OMP_SIMD: return ST_OMP_END_SIMD;
+ case ST_OMP_TARGET_PARALLEL_DO:
+ return ST_OMP_END_TARGET_PARALLEL_DO;
+ case ST_OMP_TARGET_PARALLEL_DO_SIMD:
+ return ST_OMP_END_TARGET_PARALLEL_DO_SIMD;
+ case ST_OMP_TARGET_PARALLEL_LOOP:
+ return ST_OMP_END_TARGET_PARALLEL_LOOP;
+ case ST_OMP_TARGET_SIMD: return ST_OMP_END_TARGET_SIMD;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
+ return ST_OMP_END_TARGET_TEAMS_DISTRIBUTE;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ return ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ return ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
+ return ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD;
+ case ST_OMP_TARGET_TEAMS_LOOP:
+ return ST_OMP_END_TARGET_TEAMS_LOOP;
+ case ST_OMP_TASKLOOP: return ST_OMP_END_TASKLOOP;
+ case ST_OMP_TASKLOOP_SIMD: return ST_OMP_END_TASKLOOP_SIMD;
+ case ST_OMP_MASKED_TASKLOOP: return ST_OMP_END_MASKED_TASKLOOP;
+ case ST_OMP_MASKED_TASKLOOP_SIMD:
+ return ST_OMP_END_MASKED_TASKLOOP_SIMD;
+ case ST_OMP_MASTER_TASKLOOP: return ST_OMP_END_MASTER_TASKLOOP;
+ case ST_OMP_MASTER_TASKLOOP_SIMD:
+ return ST_OMP_END_MASTER_TASKLOOP_SIMD;
+ case ST_OMP_PARALLEL_MASKED_TASKLOOP:
+ return ST_OMP_END_PARALLEL_MASKED_TASKLOOP;
+ case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
+ return ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD;
+ case ST_OMP_PARALLEL_MASTER_TASKLOOP:
+ return ST_OMP_END_PARALLEL_MASTER_TASKLOOP;
+ case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
+ return ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD;
+ case ST_OMP_TEAMS_DISTRIBUTE:
+ return ST_OMP_END_TEAMS_DISTRIBUTE;
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ return ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO;
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ return ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
+ case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
+ return ST_OMP_END_TEAMS_DISTRIBUTE_SIMD;
+ case ST_OMP_TEAMS_LOOP:
+ return ST_OMP_END_TEAMS_LOOP;
+ default:
+ break;
+ }
+ }
+
+ if (omp_structured_p)
+ {
+ switch (omp_st)
+ {
+ case ST_OMP_PARALLEL:
+ return ST_OMP_END_PARALLEL;
+ case ST_OMP_PARALLEL_MASKED:
+ return ST_OMP_END_PARALLEL_MASKED;
+ case ST_OMP_PARALLEL_MASTER:
+ return ST_OMP_END_PARALLEL_MASTER;
+ case ST_OMP_PARALLEL_SECTIONS:
+ return ST_OMP_END_PARALLEL_SECTIONS;
+ case ST_OMP_SCOPE:
+ return ST_OMP_END_SCOPE;
+ case ST_OMP_SECTIONS:
+ return ST_OMP_END_SECTIONS;
+ case ST_OMP_ORDERED:
+ return ST_OMP_END_ORDERED;
+ case ST_OMP_CRITICAL:
+ return ST_OMP_END_CRITICAL;
+ case ST_OMP_MASKED:
+ return ST_OMP_END_MASKED;
+ case ST_OMP_MASTER:
+ return ST_OMP_END_MASTER;
+ case ST_OMP_SINGLE:
+ return ST_OMP_END_SINGLE;
+ case ST_OMP_TARGET:
+ return ST_OMP_END_TARGET;
+ case ST_OMP_TARGET_DATA:
+ return ST_OMP_END_TARGET_DATA;
+ case ST_OMP_TARGET_PARALLEL:
+ return ST_OMP_END_TARGET_PARALLEL;
+ case ST_OMP_TARGET_TEAMS:
+ return ST_OMP_END_TARGET_TEAMS;
+ case ST_OMP_TASK:
+ return ST_OMP_END_TASK;
+ case ST_OMP_TASKGROUP:
+ return ST_OMP_END_TASKGROUP;
+ case ST_OMP_TEAMS:
+ return ST_OMP_END_TEAMS;
+ case ST_OMP_TEAMS_DISTRIBUTE:
+ return ST_OMP_END_TEAMS_DISTRIBUTE;
+ case ST_OMP_DISTRIBUTE:
+ return ST_OMP_END_DISTRIBUTE;
+ case ST_OMP_WORKSHARE:
+ return ST_OMP_END_WORKSHARE;
+ case ST_OMP_PARALLEL_WORKSHARE:
+ return ST_OMP_END_PARALLEL_WORKSHARE;
+ case ST_OMP_BEGIN_METADIRECTIVE:
+ return ST_OMP_END_METADIRECTIVE;
+ default:
+ break;
+ }
+ }
+
+ return ST_NONE;
+}
/* Parse the statements of OpenMP do/parallel do. */
pop_state ();
st = next_statement ();
- gfc_statement omp_end_st = ST_OMP_END_DO;
- switch (omp_st)
- {
- case ST_OMP_DISTRIBUTE: omp_end_st = ST_OMP_END_DISTRIBUTE; break;
- case ST_OMP_DISTRIBUTE_PARALLEL_DO:
- omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO;
- break;
- case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
- omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD;
- break;
- case ST_OMP_DISTRIBUTE_SIMD:
- omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD;
- break;
- case ST_OMP_DO: omp_end_st = ST_OMP_END_DO; break;
- case ST_OMP_DO_SIMD: omp_end_st = ST_OMP_END_DO_SIMD; break;
- case ST_OMP_LOOP: omp_end_st = ST_OMP_END_LOOP; break;
- case ST_OMP_PARALLEL_DO: omp_end_st = ST_OMP_END_PARALLEL_DO; break;
- case ST_OMP_PARALLEL_DO_SIMD:
- omp_end_st = ST_OMP_END_PARALLEL_DO_SIMD;
- break;
- case ST_OMP_PARALLEL_LOOP:
- omp_end_st = ST_OMP_END_PARALLEL_LOOP;
- break;
- case ST_OMP_SIMD: omp_end_st = ST_OMP_END_SIMD; break;
- case ST_OMP_TARGET_PARALLEL_DO:
- omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO;
- break;
- case ST_OMP_TARGET_PARALLEL_DO_SIMD:
- omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO_SIMD;
- break;
- case ST_OMP_TARGET_PARALLEL_LOOP:
- omp_end_st = ST_OMP_END_TARGET_PARALLEL_LOOP;
- break;
- case ST_OMP_TARGET_SIMD: omp_end_st = ST_OMP_END_TARGET_SIMD; break;
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
- omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE;
- break;
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
- omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
- break;
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
- omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
- break;
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
- omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD;
- break;
- case ST_OMP_TARGET_TEAMS_LOOP:
- omp_end_st = ST_OMP_END_TARGET_TEAMS_LOOP;
- break;
- case ST_OMP_TASKLOOP: omp_end_st = ST_OMP_END_TASKLOOP; break;
- case ST_OMP_TASKLOOP_SIMD: omp_end_st = ST_OMP_END_TASKLOOP_SIMD; break;
- case ST_OMP_MASKED_TASKLOOP: omp_end_st = ST_OMP_END_MASKED_TASKLOOP; break;
- case ST_OMP_MASKED_TASKLOOP_SIMD:
- omp_end_st = ST_OMP_END_MASKED_TASKLOOP_SIMD;
- break;
- case ST_OMP_MASTER_TASKLOOP: omp_end_st = ST_OMP_END_MASTER_TASKLOOP; break;
- case ST_OMP_MASTER_TASKLOOP_SIMD:
- omp_end_st = ST_OMP_END_MASTER_TASKLOOP_SIMD;
- break;
- case ST_OMP_PARALLEL_MASKED_TASKLOOP:
- omp_end_st = ST_OMP_END_PARALLEL_MASKED_TASKLOOP;
- break;
- case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
- omp_end_st = ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD;
- break;
- case ST_OMP_PARALLEL_MASTER_TASKLOOP:
- omp_end_st = ST_OMP_END_PARALLEL_MASTER_TASKLOOP;
- break;
- case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
- omp_end_st = ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD;
- break;
- case ST_OMP_TEAMS_DISTRIBUTE:
- omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
- break;
- case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
- omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO;
- break;
- case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
- omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
- break;
- case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
- omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD;
- break;
- case ST_OMP_TEAMS_LOOP:
- omp_end_st = ST_OMP_END_TEAMS_LOOP;
- break;
- default: gcc_unreachable ();
- }
+ gfc_statement omp_end_st = gfc_omp_end_stmt (omp_st, true, false);
+ if (omp_st == ST_NONE)
+ gcc_unreachable ();
+
+ /* If handling a metadirective variant, treat 'omp end metadirective'
+ as the expected end statement for the current construct. */
+ if (st == ST_OMP_END_METADIRECTIVE
+ && gfc_state_stack->state == COMP_OMP_BEGIN_METADIRECTIVE)
+ st = omp_end_st;
+
if (st == omp_end_st)
{
if (new_st.op == EXEC_OMP_END_NOWAIT)
np->op = cp->op;
np->block = NULL;
- switch (omp_st)
- {
- case ST_OMP_PARALLEL:
- omp_end_st = ST_OMP_END_PARALLEL;
- break;
- case ST_OMP_PARALLEL_MASKED:
- omp_end_st = ST_OMP_END_PARALLEL_MASKED;
- break;
- case ST_OMP_PARALLEL_MASTER:
- omp_end_st = ST_OMP_END_PARALLEL_MASTER;
- break;
- case ST_OMP_PARALLEL_SECTIONS:
- omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
- break;
- case ST_OMP_SCOPE:
- omp_end_st = ST_OMP_END_SCOPE;
- break;
- case ST_OMP_SECTIONS:
- omp_end_st = ST_OMP_END_SECTIONS;
- break;
- case ST_OMP_ORDERED:
- omp_end_st = ST_OMP_END_ORDERED;
- break;
- case ST_OMP_CRITICAL:
- omp_end_st = ST_OMP_END_CRITICAL;
- break;
- case ST_OMP_MASKED:
- omp_end_st = ST_OMP_END_MASKED;
- break;
- case ST_OMP_MASTER:
- omp_end_st = ST_OMP_END_MASTER;
- break;
- case ST_OMP_SINGLE:
- omp_end_st = ST_OMP_END_SINGLE;
- break;
- case ST_OMP_TARGET:
- omp_end_st = ST_OMP_END_TARGET;
- break;
- case ST_OMP_TARGET_DATA:
- omp_end_st = ST_OMP_END_TARGET_DATA;
- break;
- case ST_OMP_TARGET_PARALLEL:
- omp_end_st = ST_OMP_END_TARGET_PARALLEL;
- break;
- case ST_OMP_TARGET_TEAMS:
- omp_end_st = ST_OMP_END_TARGET_TEAMS;
- break;
- case ST_OMP_TASK:
- omp_end_st = ST_OMP_END_TASK;
- break;
- case ST_OMP_TASKGROUP:
- omp_end_st = ST_OMP_END_TASKGROUP;
- break;
- case ST_OMP_TEAMS:
- omp_end_st = ST_OMP_END_TEAMS;
- break;
- case ST_OMP_TEAMS_DISTRIBUTE:
- omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
- break;
- case ST_OMP_DISTRIBUTE:
- omp_end_st = ST_OMP_END_DISTRIBUTE;
- break;
- case ST_OMP_WORKSHARE:
- omp_end_st = ST_OMP_END_WORKSHARE;
- break;
- case ST_OMP_PARALLEL_WORKSHARE:
- omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
- break;
- default:
- gcc_unreachable ();
- }
+ omp_end_st = gfc_omp_end_stmt (omp_st, false, true);
+ if (omp_st == ST_NONE)
+ gcc_unreachable ();
bool block_construct = false;
gfc_namespace *my_ns = NULL;
}
else
st = parse_executable (st);
+
+ /* If handling a metadirective variant, treat 'omp end metadirective'
+ as the expected end statement for the current construct. */
+ if (st == ST_OMP_END_METADIRECTIVE
+ && gfc_state_stack->previous != NULL
+ && gfc_state_stack->previous->state == COMP_OMP_BEGIN_METADIRECTIVE)
+ st = omp_end_st;
+
if (st == ST_NONE)
unexpected_eof ();
else if (st == ST_OMP_SECTION
return st;
}
+static gfc_statement
+parse_omp_metadirective_body (gfc_statement omp_st)
+{
+ gfc_omp_metadirective_clause *clause = new_st.ext.omp_metadirective_clauses;
+ locus body_locus = gfc_current_locus;
+
+ accept_statement (omp_st);
+
+ gfc_statement next_st = ST_NONE;
+
+ while (clause)
+ {
+ gfc_current_locus = body_locus;
+ gfc_state_data s;
+ bool workshare_p = clause->stmt == ST_OMP_WORKSHARE
+ || clause->stmt == ST_OMP_PARALLEL_WORKSHARE;
+ enum gfc_compile_state new_state =
+ (omp_st == ST_OMP_METADIRECTIVE)
+ ? COMP_OMP_METADIRECTIVE : COMP_OMP_BEGIN_METADIRECTIVE;
+
+ new_st = *clause->code;
+ push_state (&s, new_state, NULL);
+
+ gfc_statement st;
+ bool old_in_metadirective_body = gfc_in_metadirective_body;
+ gfc_in_metadirective_body = true;
+
+ gfc_omp_region_count++;
+ switch (clause->stmt)
+ {
+ case_omp_structured_block:
+ st = parse_omp_structured_block (clause->stmt, workshare_p);
+ break;
+ case_omp_do:
+ st = parse_omp_do (clause->stmt);
+ /* TODO: Does st == ST_IMPLIED_ENDDO need special handling? */
+ break;
+ default:
+ accept_statement (clause->stmt);
+ st = parse_executable (next_statement ());
+ break;
+ }
+
+ gfc_in_metadirective_body = old_in_metadirective_body;
+
+ *clause->code = *gfc_state_stack->head;
+ pop_state ();
+
+ gfc_commit_symbols ();
+ gfc_warning_check ();
+ if (clause->next)
+ gfc_clear_new_st ();
+
+ /* Sanity-check that each clause finishes parsing at the same place. */
+ if (next_st == ST_NONE)
+ next_st = st;
+ else
+ gcc_assert (st == next_st);
+
+ clause = clause->next;
+ }
+
+ return next_st;
+}
/* Accept a series of executable statements. We return the first
statement that doesn't fit to the caller. Any block statements are
parse_executable (gfc_statement st)
{
int close_flag;
+ bool one_stmt_p = false;
if (st == ST_NONE)
st = next_statement ();
for (;;)
{
+ /* Only parse one statement for the form of metadirective without
+ an explicit begin..end. */
+ if (gfc_state_stack->state == COMP_OMP_METADIRECTIVE && one_stmt_p)
+ return st;
+ one_stmt_p = true;
+
close_flag = check_do_closure ();
if (close_flag)
switch (st)
parse_oacc_structured_block (st);
break;
- case ST_OMP_PARALLEL:
- case ST_OMP_PARALLEL_MASKED:
- case ST_OMP_PARALLEL_MASTER:
- case ST_OMP_PARALLEL_SECTIONS:
- case ST_OMP_ORDERED:
- case ST_OMP_CRITICAL:
- case ST_OMP_MASKED:
- case ST_OMP_MASTER:
- case ST_OMP_SCOPE:
- case ST_OMP_SECTIONS:
- case ST_OMP_SINGLE:
- case ST_OMP_TARGET:
- case ST_OMP_TARGET_DATA:
- case ST_OMP_TARGET_PARALLEL:
- case ST_OMP_TARGET_TEAMS:
- case ST_OMP_TEAMS:
- case ST_OMP_TASK:
- case ST_OMP_TASKGROUP:
- st = parse_omp_structured_block (st, false);
- continue;
-
- case ST_OMP_WORKSHARE:
- case ST_OMP_PARALLEL_WORKSHARE:
- st = parse_omp_structured_block (st, true);
+ case_omp_structured_block:
+ st = parse_omp_structured_block (st,
+ st == ST_OMP_WORKSHARE
+ || st == ST_OMP_PARALLEL_WORKSHARE);
continue;
- case ST_OMP_DISTRIBUTE:
- case ST_OMP_DISTRIBUTE_PARALLEL_DO:
- case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
- case ST_OMP_DISTRIBUTE_SIMD:
- case ST_OMP_DO:
- case ST_OMP_DO_SIMD:
- case ST_OMP_LOOP:
- case ST_OMP_PARALLEL_DO:
- case ST_OMP_PARALLEL_DO_SIMD:
- case ST_OMP_PARALLEL_LOOP:
- case ST_OMP_PARALLEL_MASKED_TASKLOOP:
- case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
- case ST_OMP_PARALLEL_MASTER_TASKLOOP:
- case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
- case ST_OMP_MASKED_TASKLOOP:
- case ST_OMP_MASKED_TASKLOOP_SIMD:
- case ST_OMP_MASTER_TASKLOOP:
- case ST_OMP_MASTER_TASKLOOP_SIMD:
- case ST_OMP_SIMD:
- case ST_OMP_TARGET_PARALLEL_DO:
- case ST_OMP_TARGET_PARALLEL_DO_SIMD:
- case ST_OMP_TARGET_PARALLEL_LOOP:
- case ST_OMP_TARGET_SIMD:
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
- case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
- case ST_OMP_TARGET_TEAMS_LOOP:
- case ST_OMP_TASKLOOP:
- case ST_OMP_TASKLOOP_SIMD:
- case ST_OMP_TEAMS_DISTRIBUTE:
- case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
- case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
- case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
- case ST_OMP_TEAMS_LOOP:
+ case_omp_do:
st = parse_omp_do (st);
if (st == ST_IMPLIED_ENDDO)
return st;
st = parse_omp_oacc_atomic (true);
continue;
+ case ST_OMP_METADIRECTIVE:
+ case ST_OMP_BEGIN_METADIRECTIVE:
+ st = parse_omp_metadirective_body (st);
+ continue;
+
+ case ST_OMP_END_METADIRECTIVE:
+ if (gfc_state_stack->state == COMP_OMP_BEGIN_METADIRECTIVE)
+ {
+ st = next_statement ();
+ return st;
+ }
+ /* FALLTHRU */
+
default:
return st;
}
gfc_statement_label = NULL;
+ gfc_omp_region_count = 0;
+ gfc_in_metadirective_body = false;
+ gfc_matching_omp_context_selector = false;
+
if (setjmp (eof_buf))
return false; /* Come here on unexpected EOF */
COMP_STRUCTURE, COMP_UNION, COMP_MAP,
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_DO_CONCURRENT, COMP_OMP_STRICTLY_STRUCTURED_BLOCK,
+ COMP_OMP_METADIRECTIVE, COMP_OMP_BEGIN_METADIRECTIVE
};
/* Stack element for the current compilation state. These structures
bool gfc_find_state (gfc_compile_state);
gfc_state_data *gfc_enclosing_unit (gfc_compile_state *);
const char *gfc_ascii_statement (gfc_statement);
+gfc_statement gfc_omp_end_stmt (gfc_statement, bool = true, bool = true);
match gfc_match_enum (void);
match gfc_match_enumerator_def (void);
void gfc_free_enum_history (void);
extern bool gfc_matching_function;
+extern bool gfc_matching_omp_context_selector;
+extern bool gfc_in_metadirective_body;
+extern int gfc_omp_region_count;
+
match gfc_match_prefix (gfc_typespec *);
bool is_oacc (gfc_state_data *);
#endif /* GFC_PARSE_H */
gfc_resolve_forall (code, ns, forall_save);
forall_flag = 2;
}
+ else if (code->op == EXEC_OMP_METADIRECTIVE)
+ {
+ gfc_omp_metadirective_clause *clause
+ = code->ext.omp_metadirective_clauses;
+
+ while (clause)
+ {
+ gfc_resolve_code (clause->code, ns);
+ clause = clause->next;
+ }
+ }
else if (code->block)
{
omp_workshare_save = -1;
case EXEC_OMP_MASKED:
case EXEC_OMP_MASKED_TASKLOOP:
case EXEC_OMP_MASKED_TASKLOOP_SIMD:
+ case EXEC_OMP_METADIRECTIVE:
case EXEC_OMP_ORDERED:
case EXEC_OMP_SCAN:
case EXEC_OMP_SCOPE:
case EXEC_OMP_TASKYIELD:
break;
+ case EXEC_OMP_METADIRECTIVE:
+ gfc_free_omp_metadirective_clauses (p->ext.omp_metadirective_clauses);
+ break;
+
default:
gfc_internal_error ("gfc_free_statement(): Bad statement");
}
static int
compare_st_labels (void *a1, void *b1)
{
- int a = ((gfc_st_label *) a1)->value;
- int b = ((gfc_st_label *) b1)->value;
+ gfc_st_label *a = (gfc_st_label *) a1;
+ gfc_st_label *b = (gfc_st_label *) b1;
- return (b - a);
+ int a_value = a->value + 10000 * a->omp_region;
+ int b_value = b->value + 10000 * b->omp_region;
+
+ return (b_value - a_value);
}
{
gfc_st_label *lp;
gfc_namespace *ns;
+ int omp_region = gfc_in_metadirective_body ? gfc_omp_region_count : 0;
if (gfc_current_state () == COMP_DERIVED)
ns = gfc_current_block ()->f2k_derived;
lp = ns->st_labels;
while (lp)
{
- if (lp->value == labelno)
+ int a = lp->value + 10000 * lp->omp_region;
+ int b = labelno + 10000 * omp_region;
+
+ if (a == b)
return lp;
- if (lp->value < labelno)
+ if (a < b)
lp = lp->left;
else
lp = lp->right;
lp->defined = ST_LABEL_UNKNOWN;
lp->referenced = ST_LABEL_UNKNOWN;
lp->ns = ns;
+ lp->omp_region = omp_region;
gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);
gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
/* Build a mangled name for the label. */
- sprintf (label_name, "__label_%.6d", lp->value);
+ if (lp->omp_region)
+ sprintf (label_name, "__label_%d_%.6d", lp->omp_region, lp->value);
+ else
+ sprintf (label_name, "__label_%.6d", lp->value);
/* Build the LABEL_DECL node. */
label_decl = gfc_build_label_decl (get_identifier (label_name));
case EXEC_OMP_MASTER_TASKLOOP:
case EXEC_OMP_MASTER_TASKLOOP_SIMD:
return gfc_trans_omp_master_masked_taskloop (code, code->op);
+ case EXEC_OMP_METADIRECTIVE:
+ return gfc_trans_omp_metadirective (code);
case EXEC_OMP_ORDERED:
return gfc_trans_omp_ordered (code);
case EXEC_OMP_PARALLEL:
}
}
+static tree
+gfc_trans_omp_set_selector (gfc_omp_set_selector *gfc_selectors, locus where)
+{
+ tree set_selectors = NULL_TREE;
+ gfc_omp_set_selector *oss;
+
+ for (oss = gfc_selectors; oss; oss = oss->next)
+ {
+ tree selectors = NULL_TREE;
+ gfc_omp_selector *os;
+ for (os = oss->trait_selectors; os; os = os->next)
+ {
+ tree properties = NULL_TREE;
+ gfc_omp_trait_property *otp;
+
+ for (otp = os->properties; otp; otp = otp->next)
+ {
+ switch (otp->property_kind)
+ {
+ case CTX_PROPERTY_USER:
+ case CTX_PROPERTY_EXPR:
+ {
+ gfc_se se;
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, otp->expr);
+ properties = tree_cons (NULL_TREE, se.expr,
+ properties);
+ }
+ break;
+ case CTX_PROPERTY_ID:
+ properties = tree_cons (get_identifier (otp->name),
+ NULL_TREE, properties);
+ break;
+ case CTX_PROPERTY_NAME_LIST:
+ {
+ tree prop = NULL_TREE, value = NULL_TREE;
+ if (otp->is_name)
+ prop = get_identifier (otp->name);
+ else
+ {
+ value = gfc_conv_constant_to_tree (otp->expr);
+
+ /* The string length is expected to include the null
+ terminator in context selectors. This is safe as
+ build_string always null-terminates strings. */
+ ++TREE_STRING_LENGTH (value);
+ }
+
+ properties = tree_cons (prop, value, properties);
+ }
+ break;
+ case CTX_PROPERTY_SIMD:
+ properties = gfc_trans_omp_clauses (NULL, otp->clauses,
+ where, true);
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ }
+
+ if (os->score)
+ {
+ gfc_se se;
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, os->score);
+ properties = tree_cons (get_identifier (" score"),
+ se.expr, properties);
+ }
+
+ selectors = tree_cons (get_identifier (os->trait_selector_name),
+ properties, selectors);
+ }
+
+ set_selectors
+ = tree_cons (get_identifier (oss->trait_set_selector_name),
+ selectors, set_selectors);
+ }
+
+ return set_selectors;
+}
+
void
gfc_trans_omp_declare_variant (gfc_namespace *ns)
{
&& strcmp (odv->base_proc_symtree->name, ns->proc_name->name)))
continue;
- tree set_selectors = NULL_TREE;
- gfc_omp_set_selector *oss;
-
- for (oss = odv->set_selectors; oss; oss = oss->next)
- {
- tree selectors = NULL_TREE;
- gfc_omp_selector *os;
- for (os = oss->trait_selectors; os; os = os->next)
- {
- tree properties = NULL_TREE;
- gfc_omp_trait_property *otp;
-
- for (otp = os->properties; otp; otp = otp->next)
- {
- switch (otp->property_kind)
- {
- case CTX_PROPERTY_USER:
- case CTX_PROPERTY_EXPR:
- {
- gfc_se se;
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, otp->expr);
- properties = tree_cons (NULL_TREE, se.expr,
- properties);
- }
- break;
- case CTX_PROPERTY_ID:
- properties = tree_cons (get_identifier (otp->name),
- NULL_TREE, properties);
- break;
- case CTX_PROPERTY_NAME_LIST:
- {
- tree prop = NULL_TREE, value = NULL_TREE;
- if (otp->is_name)
- prop = get_identifier (otp->name);
- else
- value = gfc_conv_constant_to_tree (otp->expr);
-
- properties = tree_cons (prop, value, properties);
- }
- break;
- case CTX_PROPERTY_SIMD:
- properties = gfc_trans_omp_clauses (NULL, otp->clauses,
- odv->where, true);
- break;
- default:
- gcc_unreachable ();
- }
- }
-
- if (os->score)
- {
- gfc_se se;
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, os->score);
- properties = tree_cons (get_identifier (" score"),
- se.expr, properties);
- }
-
- selectors = tree_cons (get_identifier (os->trait_selector_name),
- properties, selectors);
- }
-
- set_selectors
- = tree_cons (get_identifier (oss->trait_set_selector_name),
- selectors, set_selectors);
- }
+ tree set_selectors = gfc_trans_omp_set_selector (odv->set_selectors,
+ odv->where);
const char *variant_proc_name = odv->variant_proc_symtree->name;
gfc_symbol *variant_proc_sym = odv->variant_proc_symtree->n.sym;
}
}
}
+
+tree
+gfc_trans_omp_metadirective (gfc_code *code)
+{
+ gfc_omp_metadirective_clause *clause = code->ext.omp_metadirective_clauses;
+
+ tree metadirective_tree = make_node (OMP_METADIRECTIVE);
+ SET_EXPR_LOCATION (metadirective_tree, gfc_get_location (&code->loc));
+ TREE_TYPE (metadirective_tree) = void_type_node;
+ OMP_METADIRECTIVE_CLAUSES (metadirective_tree) = NULL_TREE;
+
+ tree tree_body = NULL_TREE;
+
+ while (clause)
+ {
+ tree selectors = gfc_trans_omp_set_selector (clause->selectors,
+ clause->where);
+ gfc_code *next_code = clause->code->next;
+ if (next_code && tree_body == NULL_TREE)
+ tree_body = gfc_trans_code (next_code);
+
+ if (next_code)
+ clause->code->next = NULL;
+ tree directive = gfc_trans_code (clause->code);
+ if (next_code)
+ clause->code->next = next_code;
+
+ tree body = next_code ? tree_body : NULL_TREE;
+ tree variant = build_tree_list (selectors, build_tree_list (directive, body));
+ OMP_METADIRECTIVE_CLAUSES (metadirective_tree)
+ = chainon (OMP_METADIRECTIVE_CLAUSES (metadirective_tree), variant);
+ clause = clause->next;
+ }
+
+ /* TODO: Resolve the metadirective here if possible. */
+
+ return metadirective_tree;
+}
tree gfc_trans_omp_directive (gfc_code *);
void gfc_trans_omp_declare_simd (gfc_namespace *);
void gfc_trans_omp_declare_variant (gfc_namespace *);
+tree gfc_trans_omp_metadirective (gfc_code *code);
tree gfc_trans_oacc_directive (gfc_code *);
tree gfc_trans_oacc_declare (gfc_namespace *);
case EXEC_OMP_MASTER:
case EXEC_OMP_MASTER_TASKLOOP:
case EXEC_OMP_MASTER_TASKLOOP_SIMD:
+ case EXEC_OMP_METADIRECTIVE:
case EXEC_OMP_ORDERED:
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
const char *str = TREE_STRING_POINTER (TREE_VALUE (t2));
if (!strcmp (str, props[i].props[j])
&& ((size_t) TREE_STRING_LENGTH (TREE_VALUE (t2))
- == strlen (str) + (lang_GNU_Fortran () ? 0 : 1)))
+ == strlen (str) + 1))
break;
}
else if (!strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t2)),
else
{
const char *ret = TREE_STRING_POINTER (TREE_VALUE (prop));
- if ((size_t) TREE_STRING_LENGTH (TREE_VALUE (prop))
- == strlen (ret) + (lang_GNU_Fortran () ? 0 : 1))
+ if ((size_t) TREE_STRING_LENGTH (TREE_VALUE (prop)) == strlen (ret) + 1)
return ret;
return NULL;
}
projects / thirdparty / gcc.git / commitdiff
