public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc/devel/omp/gcc-11] Fortran: Add OpenMP's error directive
@ 2021-08-20 13:32 Tobias Burnus
0 siblings, 0 replies; only message in thread
From: Tobias Burnus @ 2021-08-20 13:32 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:47f4a06652b942fc1db8f0e4a2590f9ee84b3621
commit 47f4a06652b942fc1db8f0e4a2590f9ee84b3621
Author: Tobias Burnus <tobias@codesourcery.com>
Date: Fri Aug 20 14:22:07 2021 +0200
Fortran: Add OpenMP's error directive
Fortran part to the C/C++ implementation of
commit r12-3040-g0d973c0a0d90a0a302e7eda1a4d9709be3c5b102
gcc/fortran/ChangeLog:
* dump-parse-tree.c (show_omp_clauses): Handle 'at', 'severity'
and 'message' clauses.
(show_omp_node, show_code_node): Handle EXEC_OMP_ERROR.
* gfortran.h (gfc_statement): Add ST_OMP_ERROR.
(gfc_omp_severity_type, gfc_omp_at_type): New.
(gfc_omp_clauses): Add 'at', 'severity' and 'message' clause;
use more bitfields + ENUM_BITFIELD.
(gfc_exec_op): Add EXEC_OMP_ERROR.
* match.h (gfc_match_omp_error): New.
* openmp.c (enum omp_mask1): Add OMP_CLAUSE_(AT,SEVERITY,MESSAGE).
(gfc_match_omp_clauses): Handle new clauses.
(OMP_ERROR_CLAUSES, gfc_match_omp_error): New.
(resolve_omp_clauses): Resolve new clauses.
(omp_code_to_statement, gfc_resolve_omp_directive): Handle
EXEC_OMP_ERROR.
* parse.c (decode_omp_directive, next_statement,
gfc_ascii_statement): Handle 'omp error'.
* resolve.c (gfc_resolve_blocks): Likewise.
* st.c (gfc_free_statement): Likewise.
* trans-openmp.c (gfc_trans_omp_error): Likewise.
(gfc_trans_omp_directive): Likewise.
* trans.c (trans_code): Likewise.
libgomp/ChangeLog:
* testsuite/libgomp.fortran/error-1.f90: New test.
gcc/testsuite/ChangeLog:
* gfortran.dg/gomp/error-1.f90: New test.
* gfortran.dg/gomp/error-2.f90: New test.
* gfortran.dg/gomp/error-3.f90: New test.
(cherry picked from commit 77167196fe8cf840a69913e7739d39ae0df2b074)
Diff:
---
gcc/fortran/ChangeLog.omp | 28 ++++++
gcc/fortran/dump-parse-tree.c | 27 +++++-
gcc/fortran/gfortran.h | 58 ++++++++----
gcc/fortran/match.h | 1 +
gcc/fortran/openmp.c | 124 +++++++++++++++++++++++++-
gcc/fortran/parse.c | 10 ++-
gcc/fortran/resolve.c | 2 +
gcc/fortran/st.c | 1 +
gcc/fortran/trans-openmp.c | 34 +++++++
gcc/fortran/trans.c | 1 +
gcc/testsuite/ChangeLog.omp | 9 ++
gcc/testsuite/gfortran.dg/gomp/error-1.f90 | 51 +++++++++++
gcc/testsuite/gfortran.dg/gomp/error-2.f90 | 15 ++++
gcc/testsuite/gfortran.dg/gomp/error-3.f90 | 88 ++++++++++++++++++
libgomp/ChangeLog.omp | 7 ++
libgomp/testsuite/libgomp.fortran/error-1.f90 | 78 ++++++++++++++++
16 files changed, 509 insertions(+), 25 deletions(-)
diff --git a/gcc/fortran/ChangeLog.omp b/gcc/fortran/ChangeLog.omp
index 1d5122525eb..6305842b266 100644
--- a/gcc/fortran/ChangeLog.omp
+++ b/gcc/fortran/ChangeLog.omp
@@ -1,3 +1,31 @@
+2021-08-20 Tobias Burnus <tobias@codesourcery.com>
+
+ Backported from master:
+ 2021-08-20 Tobias Burnus <tobias@codesourcery.com>
+
+ * dump-parse-tree.c (show_omp_clauses): Handle 'at', 'severity'
+ and 'message' clauses.
+ (show_omp_node, show_code_node): Handle EXEC_OMP_ERROR.
+ * gfortran.h (gfc_statement): Add ST_OMP_ERROR.
+ (gfc_omp_severity_type, gfc_omp_at_type): New.
+ (gfc_omp_clauses): Add 'at', 'severity' and 'message' clause;
+ use more bitfields + ENUM_BITFIELD.
+ (gfc_exec_op): Add EXEC_OMP_ERROR.
+ * match.h (gfc_match_omp_error): New.
+ * openmp.c (enum omp_mask1): Add OMP_CLAUSE_(AT,SEVERITY,MESSAGE).
+ (gfc_match_omp_clauses): Handle new clauses.
+ (OMP_ERROR_CLAUSES, gfc_match_omp_error): New.
+ (resolve_omp_clauses): Resolve new clauses.
+ (omp_code_to_statement, gfc_resolve_omp_directive): Handle
+ EXEC_OMP_ERROR.
+ * parse.c (decode_omp_directive, next_statement,
+ gfc_ascii_statement): Handle 'omp error'.
+ * resolve.c (gfc_resolve_blocks): Likewise.
+ * st.c (gfc_free_statement): Likewise.
+ * trans-openmp.c (gfc_trans_omp_error): Likewise.
+ (gfc_trans_omp_directive): Likewise.
+ * trans.c (trans_code): Likewise.
+
2021-08-20 Tobias Burnus <tobias@codesourcery.com>
Backported from master:
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 6a409efc027..afa734b2268 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -1906,6 +1906,26 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses)
fputc (' ', dumpfile);
fputs (memorder, dumpfile);
}
+ if (omp_clauses->at != OMP_AT_UNSET)
+ {
+ if (omp_clauses->at != OMP_AT_COMPILATION)
+ fputs (" AT (COMPILATION)", dumpfile);
+ else
+ fputs (" AT (EXECUTION)", dumpfile);
+ }
+ if (omp_clauses->severity != OMP_SEVERITY_UNSET)
+ {
+ if (omp_clauses->severity != OMP_SEVERITY_FATAL)
+ fputs (" SEVERITY (FATAL)", dumpfile);
+ else
+ fputs (" SEVERITY (WARNING)", dumpfile);
+ }
+ if (omp_clauses->message)
+ {
+ fputs (" ERROR (", dumpfile);
+ show_expr (omp_clauses->message);
+ fputc (')', dumpfile);
+ }
}
/* Show a single OpenMP or OpenACC directive node and everything underneath it
@@ -1948,8 +1968,9 @@ show_omp_node (int level, gfc_code *c)
case EXEC_OMP_DISTRIBUTE_SIMD: name = "DISTRIBUTE SIMD"; break;
case EXEC_OMP_DO: name = "DO"; break;
case EXEC_OMP_DO_SIMD: name = "DO SIMD"; break;
- case EXEC_OMP_LOOP: name = "LOOP"; break;
+ case EXEC_OMP_ERROR: name = "ERROR"; break;
case EXEC_OMP_FLUSH: name = "FLUSH"; break;
+ case EXEC_OMP_LOOP: name = "LOOP"; break;
case EXEC_OMP_MASKED: name = "MASKED"; break;
case EXEC_OMP_MASKED_TASKLOOP: name = "MASKED TASKLOOP"; break;
case EXEC_OMP_MASKED_TASKLOOP_SIMD: name = "MASKED TASKLOOP SIMD"; break;
@@ -2043,6 +2064,7 @@ show_omp_node (int level, gfc_code *c)
case EXEC_OMP_DISTRIBUTE_SIMD:
case EXEC_OMP_DO:
case EXEC_OMP_DO_SIMD:
+ case EXEC_OMP_ERROR:
case EXEC_OMP_LOOP:
case EXEC_OMP_ORDERED:
case EXEC_OMP_MASKED:
@@ -2133,7 +2155,7 @@ show_omp_node (int level, gfc_code *c)
|| c->op == EXEC_OACC_ENTER_DATA || c->op == EXEC_OACC_EXIT_DATA
|| c->op == EXEC_OMP_TARGET_UPDATE || c->op == EXEC_OMP_TARGET_ENTER_DATA
|| c->op == EXEC_OMP_TARGET_EXIT_DATA || c->op == EXEC_OMP_SCAN
- || c->op == EXEC_OMP_DEPOBJ
+ || c->op == EXEC_OMP_DEPOBJ || c->op == EXEC_OMP_ERROR
|| (c->op == EXEC_OMP_ORDERED && c->block == NULL))
return;
if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
@@ -3266,6 +3288,7 @@ show_code_node (int level, gfc_code *c)
case EXEC_OMP_DISTRIBUTE_SIMD:
case EXEC_OMP_DO:
case EXEC_OMP_DO_SIMD:
+ case EXEC_OMP_ERROR:
case EXEC_OMP_FLUSH:
case EXEC_OMP_LOOP:
case EXEC_OMP_MASKED:
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 418b0728c05..f20ca5edbc8 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -281,7 +281,8 @@ enum gfc_statement
ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD,
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_NONE
+ ST_OMP_END_MASKED_TASKLOOP_SIMD, ST_OMP_SCOPE, ST_OMP_END_SCOPE,
+ ST_OMP_ERROR, ST_NONE
};
/* Types of interfaces that we can have. Assignment interfaces are
@@ -776,6 +777,20 @@ enum gfc_omp_device_type
OMP_DEVICE_TYPE_ANY
};
+enum gfc_omp_severity_type
+{
+ OMP_SEVERITY_UNSET,
+ OMP_SEVERITY_WARNING,
+ OMP_SEVERITY_FATAL
+};
+
+enum gfc_omp_at_type
+{
+ OMP_AT_UNSET,
+ OMP_AT_COMPILATION,
+ OMP_AT_EXECUTION
+};
+
/* Structure and list of supported extension attributes. */
typedef enum
{
@@ -1448,26 +1463,11 @@ enum gfc_omp_bind_type
typedef struct gfc_omp_clauses
{
+ gfc_omp_namelist *lists[OMP_LIST_NUM];
struct gfc_expr *if_expr;
struct gfc_expr *final_expr;
struct gfc_expr *num_threads;
- gfc_omp_namelist *lists[OMP_LIST_NUM];
- enum gfc_omp_sched_kind sched_kind;
- enum gfc_omp_device_type device_type;
struct gfc_expr *chunk_size;
- enum gfc_omp_default_sharing default_sharing;
- enum gfc_omp_defaultmap defaultmap[OMP_DEFAULTMAP_CAT_NUM];
- int collapse, orderedc;
- bool nowait, ordered, untied, mergeable;
- bool inbranch, notinbranch, nogroup;
- bool sched_simd, sched_monotonic, sched_nonmonotonic;
- bool simd, threads, depend_source, destroy, order_concurrent, capture;
- enum gfc_omp_atomic_op atomic_op;
- enum gfc_omp_memorder memorder;
- enum gfc_omp_cancel_kind cancel;
- enum gfc_omp_proc_bind_kind proc_bind;
- enum gfc_omp_depend_op depobj_update;
- enum gfc_omp_bind_type bind;
struct gfc_expr *safelen_expr;
struct gfc_expr *simdlen_expr;
struct gfc_expr *num_teams;
@@ -1481,9 +1481,28 @@ typedef struct gfc_omp_clauses
struct gfc_expr *detach;
struct gfc_expr *depobj;
struct gfc_expr *if_exprs[OMP_IF_LAST];
- enum gfc_omp_sched_kind dist_sched_kind;
struct gfc_expr *dist_chunk_size;
+ struct gfc_expr *message;
const char *critical_name;
+ enum gfc_omp_default_sharing default_sharing;
+ enum gfc_omp_atomic_op atomic_op;
+ enum gfc_omp_defaultmap defaultmap[OMP_DEFAULTMAP_CAT_NUM];
+ int collapse, orderedc;
+ unsigned nowait:1, ordered:1, untied:1, mergeable:1;
+ unsigned inbranch:1, notinbranch:1, nogroup:1;
+ unsigned sched_simd:1, sched_monotonic:1, sched_nonmonotonic:1;
+ unsigned simd:1, threads:1, depend_source:1, destroy:1, order_concurrent:1;
+ unsigned capture:1;
+ ENUM_BITFIELD (gfc_omp_sched_kind) sched_kind:3;
+ ENUM_BITFIELD (gfc_omp_device_type) device_type:2;
+ ENUM_BITFIELD (gfc_omp_memorder) memorder:3;
+ ENUM_BITFIELD (gfc_omp_cancel_kind) cancel:3;
+ ENUM_BITFIELD (gfc_omp_proc_bind_kind) proc_bind:3;
+ ENUM_BITFIELD (gfc_omp_depend_op) depobj_update:3;
+ ENUM_BITFIELD (gfc_omp_bind_type) bind:2;
+ ENUM_BITFIELD (gfc_omp_at_type) at:2;
+ ENUM_BITFIELD (gfc_omp_severity_type) severity:2;
+ ENUM_BITFIELD (gfc_omp_sched_kind) dist_sched_kind:3;
/* OpenACC. */
struct gfc_expr *async_expr;
@@ -2769,7 +2788,8 @@ enum gfc_exec_op
EXEC_OMP_TEAMS_LOOP, EXEC_OMP_TARGET_PARALLEL_LOOP,
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_MASKED_TASKLOOP, EXEC_OMP_MASKED_TASKLOOP_SIMD, EXEC_OMP_SCOPE,
+ EXEC_OMP_ERROR
};
typedef struct gfc_code
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 5127b4b8ea3..92fd127a57f 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -168,6 +168,7 @@ match gfc_match_omp_distribute_simd (void);
match gfc_match_omp_do (void);
match gfc_match_omp_do_simd (void);
match gfc_match_omp_loop (void);
+match gfc_match_omp_error (void);
match gfc_match_omp_flush (void);
match gfc_match_omp_masked (void);
match gfc_match_omp_masked_taskloop (void);
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 420f4f16e13..ee7f31783c5 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -29,6 +29,7 @@ along with GCC; see the file COPYING3. If not see
#include "diagnostic.h"
#include "gomp-constants.h"
#include "options.h"
+#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 '!'. */
@@ -849,6 +850,9 @@ enum omp_mask1
OMP_CLAUSE_AFFINITY, /* OpenMP 5.0. */
OMP_CLAUSE_BIND, /* OpenMP 5.0. */
OMP_CLAUSE_FILTER, /* OpenMP 5.1. */
+ OMP_CLAUSE_AT, /* OpenMP 5.1. */
+ OMP_CLAUSE_MESSAGE, /* OpenMP 5.1. */
+ OMP_CLAUSE_SEVERITY, /* OpenMP 5.1. */
OMP_CLAUSE_NOWAIT,
/* This must come last. */
OMP_MASK1_LAST
@@ -1294,6 +1298,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
bool first = true, bool needs_space = true,
bool openacc = false)
{
+ bool error = false;
gfc_omp_clauses *c = gfc_get_omp_clauses ();
locus old_loc;
/* Determine whether we're dealing with an OpenACC directive that permits
@@ -1393,6 +1398,22 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
}
continue;
}
+ if ((mask & OMP_CLAUSE_AT)
+ && c->at == OMP_AT_UNSET
+ && gfc_match ("at ( ") == MATCH_YES)
+ {
+ if (gfc_match ("compilation )") == MATCH_YES)
+ c->at = OMP_AT_COMPILATION;
+ else if (gfc_match ("execution )") == MATCH_YES)
+ c->at = OMP_AT_EXECUTION;
+ else
+ {
+ gfc_error ("Expected COMPILATION or EXECUTION in AT clause "
+ "at %C");
+ goto error;
+ }
+ continue;
+ }
if ((mask & OMP_CLAUSE_ASYNC)
&& !c->async
&& gfc_match ("async") == MATCH_YES)
@@ -1617,7 +1638,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
else
gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for "
"category %s", pcategory);
- goto end;
+ goto error;
}
}
c->defaultmap[category] = behavior;
@@ -2075,6 +2096,10 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
c->mergeable = needs_space = true;
continue;
}
+ if ((mask & OMP_CLAUSE_MESSAGE)
+ && !c->message
+ && gfc_match ("message ( %e )", &c->message) == MATCH_YES)
+ continue;
break;
case 'n':
if ((mask & OMP_CLAUSE_NO_CREATE)
@@ -2403,6 +2428,22 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
c->simd = needs_space = true;
continue;
}
+ if ((mask & OMP_CLAUSE_SEVERITY)
+ && c->severity == OMP_SEVERITY_UNSET
+ && gfc_match ("severity ( ") == MATCH_YES)
+ {
+ if (gfc_match ("fatal )") == MATCH_YES)
+ c->severity = OMP_SEVERITY_FATAL;
+ else if (gfc_match ("warning )") == MATCH_YES)
+ c->severity = OMP_SEVERITY_WARNING;
+ else
+ {
+ gfc_error ("Expected FATAL or WARNING in SEVERITY clause "
+ "at %C");
+ goto error;
+ }
+ continue;
+ }
break;
case 't':
if ((mask & OMP_CLAUSE_TASK_REDUCTION)
@@ -2554,7 +2595,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
}
end:
- if (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");
@@ -2564,6 +2605,10 @@ end:
*cp = c;
return MATCH_YES;
+
+error:
+ error = true;
+ goto end;
}
@@ -3196,6 +3241,9 @@ cleanup:
| OMP_CLAUSE_MEMORDER)
#define OMP_MASKED_CLAUSES \
(omp_mask (OMP_CLAUSE_FILTER))
+#define OMP_ERROR_CLAUSES \
+ (omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
+
static match
@@ -3419,6 +3467,66 @@ gfc_match_omp_target_parallel_loop (void)
}
+match
+gfc_match_omp_error (void)
+{
+ locus loc = gfc_current_locus;
+ match m = match_omp (EXEC_OMP_ERROR, OMP_ERROR_CLAUSES);
+ if (m != MATCH_YES)
+ return m;
+
+ gfc_omp_clauses *c = new_st.ext.omp_clauses;
+ if (c->severity == OMP_SEVERITY_UNSET)
+ c->severity = OMP_SEVERITY_FATAL;
+ if (new_st.ext.omp_clauses->at == OMP_AT_EXECUTION)
+ return MATCH_YES;
+ if (c->message
+ && (!gfc_resolve_expr (c->message)
+ || c->message->ts.type != BT_CHARACTER
+ || c->message->ts.kind != gfc_default_character_kind
+ || c->message->rank != 0))
+ {
+ gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
+ "CHARACTER expression",
+ &new_st.ext.omp_clauses->message->where);
+ return MATCH_ERROR;
+ }
+ if (c->message && !gfc_is_constant_expr (c->message))
+ {
+ gfc_error ("Constant character expression required in MESSAGE clause "
+ "at %L", &new_st.ext.omp_clauses->message->where);
+ return MATCH_ERROR;
+ }
+ if (c->message)
+ {
+ const char *msg = G_("$OMP ERROR encountered at %L: %s");
+ gcc_assert (c->message->expr_type == EXPR_CONSTANT);
+ gfc_charlen_t slen = c->message->value.character.length;
+ int i = gfc_validate_kind (BT_CHARACTER, gfc_default_character_kind,
+ false);
+ size_t size = slen * gfc_character_kinds[i].bit_size / 8;
+ unsigned char *s = XCNEWVAR (unsigned char, size + 1);
+ gfc_encode_character (gfc_default_character_kind, slen,
+ c->message->value.character.string,
+ (unsigned char *) s, size);
+ s[size] = '\0';
+ if (c->severity == OMP_SEVERITY_WARNING)
+ gfc_warning_now (0, msg, &loc, s);
+ else
+ gfc_error_now (msg, &loc, s);
+ free (s);
+ }
+ else
+ {
+ const char *msg = G_("$OMP ERROR encountered at %L");
+ if (c->severity == OMP_SEVERITY_WARNING)
+ gfc_warning_now (0, msg, &loc);
+ else
+ gfc_error_now (msg, &loc);
+ }
+ return MATCH_YES;
+}
+
match
gfc_match_omp_flush (void)
{
@@ -6452,6 +6560,15 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
if (omp_clauses->depend_source && code->op != EXEC_OMP_ORDERED)
gfc_error ("SOURCE dependence type only allowed "
"on ORDERED directive at %L", &code->loc);
+ if (omp_clauses->message)
+ {
+ gfc_expr *expr = omp_clauses->message;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.kind != gfc_default_character_kind
+ || expr->ts.type != BT_CHARACTER || expr->rank != 0)
+ gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
+ "CHARACTER expression", &expr->where);
+ }
if (!openacc
&& code
&& omp_clauses->lists[OMP_LIST_MAP] == NULL
@@ -7474,6 +7591,8 @@ omp_code_to_statement (gfc_code *code)
return ST_OMP_CANCEL;
case EXEC_OMP_CANCELLATION_POINT:
return ST_OMP_CANCELLATION_POINT;
+ case EXEC_OMP_ERROR:
+ return ST_OMP_ERROR;
case EXEC_OMP_FLUSH:
return ST_OMP_FLUSH;
case EXEC_OMP_DISTRIBUTE:
@@ -7996,6 +8115,7 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
resolve_omp_do (code);
break;
case EXEC_OMP_CANCEL:
+ case EXEC_OMP_ERROR:
case EXEC_OMP_MASKED:
case EXEC_OMP_PARALLEL_WORKSHARE:
case EXEC_OMP_PARALLEL:
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 1f8bcc61678..4811e7585f7 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -910,6 +910,7 @@ decode_omp_directive (void)
matcho ("do", gfc_match_omp_do, ST_OMP_DO);
break;
case 'e':
+ matcho ("error", gfc_match_omp_error, ST_OMP_ERROR);
matcho ("end atomic", gfc_match_omp_eos_error, ST_OMP_END_ATOMIC);
matcho ("end critical", gfc_match_omp_end_critical, ST_OMP_END_CRITICAL);
matchs ("end distribute parallel do simd", gfc_match_omp_eos_error,
@@ -1185,6 +1186,9 @@ decode_omp_directive (void)
prog_unit->omp_target_seen = true;
break;
}
+ case ST_OMP_ERROR:
+ if (new_st.ext.omp_clauses->at != OMP_AT_EXECUTION)
+ return ST_NONE;
default:
break;
}
@@ -1656,7 +1660,7 @@ next_statement (void)
case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: case ST_OMP_DEPOBJ: \
case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \
- case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: \
+ case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: case ST_OMP_ERROR: \
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: \
@@ -1718,7 +1722,6 @@ next_statement (void)
case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \
case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
-
/* Block end statements. Errors associated with interchanging these
are detected in gfc_match_end(). */
@@ -2546,6 +2549,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_OMP_END_WORKSHARE:
p = "!$OMP END WORKSHARE";
break;
+ case ST_OMP_ERROR:
+ p = "!$OMP ERROR";
+ break;
case ST_OMP_FLUSH:
p = "!$OMP FLUSH";
break;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index ea781cf9ec4..d32f32259c3 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -10810,6 +10810,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
case EXEC_OMP_DISTRIBUTE_SIMD:
case EXEC_OMP_DO:
case EXEC_OMP_DO_SIMD:
+ case EXEC_OMP_ERROR:
case EXEC_OMP_LOOP:
case EXEC_OMP_MASKED:
case EXEC_OMP_MASKED_TASKLOOP:
@@ -12247,6 +12248,7 @@ start:
case EXEC_OMP_DISTRIBUTE_SIMD:
case EXEC_OMP_DO:
case EXEC_OMP_DO_SIMD:
+ case EXEC_OMP_ERROR:
case EXEC_OMP_LOOP:
case EXEC_OMP_MASTER:
case EXEC_OMP_MASTER_TASKLOOP:
diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c
index 7d87709d387..6bf730c9062 100644
--- a/gcc/fortran/st.c
+++ b/gcc/fortran/st.c
@@ -225,6 +225,7 @@ gfc_free_statement (gfc_code *p)
case EXEC_OMP_DISTRIBUTE_SIMD:
case EXEC_OMP_DO:
case EXEC_OMP_DO_SIMD:
+ case EXEC_OMP_ERROR:
case EXEC_OMP_LOOP:
case EXEC_OMP_END_SINGLE:
case EXEC_OMP_MASKED_TASKLOOP:
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index 21b8fd8c1f9..57228f1dde9 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -5405,6 +5405,38 @@ gfc_trans_omp_depobj (gfc_code *code)
return gfc_finish_block (&block);
}
+static tree
+gfc_trans_omp_error (gfc_code *code)
+{
+ stmtblock_t block;
+ gfc_se se;
+ tree len, message;
+ bool fatal = code->ext.omp_clauses->severity == OMP_SEVERITY_FATAL;
+ tree fndecl = builtin_decl_explicit (fatal ? BUILT_IN_GOMP_ERROR
+ : BUILT_IN_GOMP_WARNING);
+ gfc_start_block (&block);
+ gfc_init_se (&se, NULL );
+ if (!code->ext.omp_clauses->message)
+ {
+ message = null_pointer_node;
+ len = build_int_cst (size_type_node, 0);
+ }
+ else
+ {
+ gfc_conv_expr (&se, code->ext.omp_clauses->message);
+ message = se.expr;
+ if (!POINTER_TYPE_P (TREE_TYPE (message)))
+ /* To ensure an ARRAY_TYPE is not passed as such. */
+ message = gfc_build_addr_expr (NULL, message);
+ len = se.string_length;
+ }
+ gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_expr_to_block (&block, build_call_expr_loc (input_location, fndecl,
+ 2, message, len));
+ gfc_add_block_to_block (&block, &se.post);
+ return gfc_finish_block (&block);
+}
+
static tree
gfc_trans_omp_flush (gfc_code *code)
{
@@ -7171,6 +7203,8 @@ gfc_trans_omp_directive (gfc_code *code)
return gfc_trans_omp_distribute (code, NULL);
case EXEC_OMP_DO_SIMD:
return gfc_trans_omp_do_simd (code, NULL, NULL, NULL_TREE);
+ case EXEC_OMP_ERROR:
+ return gfc_trans_omp_error (code);
case EXEC_OMP_FLUSH:
return gfc_trans_omp_flush (code);
case EXEC_OMP_MASKED:
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 09b3dc45f1b..7943396c906 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -2169,6 +2169,7 @@ trans_code (gfc_code * code, tree cond)
case EXEC_OMP_DO:
case EXEC_OMP_DO_SIMD:
case EXEC_OMP_LOOP:
+ case EXEC_OMP_ERROR:
case EXEC_OMP_FLUSH:
case EXEC_OMP_MASKED:
case EXEC_OMP_MASKED_TASKLOOP:
diff --git a/gcc/testsuite/ChangeLog.omp b/gcc/testsuite/ChangeLog.omp
index 64c2b59e5ae..e9bdb60ac80 100644
--- a/gcc/testsuite/ChangeLog.omp
+++ b/gcc/testsuite/ChangeLog.omp
@@ -1,3 +1,12 @@
+2021-08-20 Tobias Burnus <tobias@codesourcery.com>
+
+ Backported from master:
+ 2021-08-20 Tobias Burnus <tobias@codesourcery.com>
+
+ * gfortran.dg/gomp/error-1.f90: New test.
+ * gfortran.dg/gomp/error-2.f90: New test.
+ * gfortran.dg/gomp/error-3.f90: New test.
+
2021-08-20 Tobias Burnus <tobias@codesourcery.com>
Backported from master:
diff --git a/gcc/testsuite/gfortran.dg/gomp/error-1.f90 b/gcc/testsuite/gfortran.dg/gomp/error-1.f90
new file mode 100644
index 00000000000..0ee0b4bfbcc
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/error-1.f90
@@ -0,0 +1,51 @@
+! { dg-additional-options "-ffree-line-length-none" }
+module m
+!$omp error ! { dg-error ".OMP ERROR encountered at .1." }
+!$omp error at(compilation) ! { dg-error ".OMP ERROR encountered at .1." }
+!$omp error severity(fatal) ! { dg-error ".OMP ERROR encountered at .1." }
+!$omp error message("my msg") ! { dg-error ".OMP ERROR encountered at .1.: my msg" }
+!$omp error severity(warning)message("another message")at(compilation) ! { dg-warning ".OMP ERROR encountered at .1.: another message" }
+
+type S
+ !$omp error ! { dg-error ".OMP ERROR encountered at .1." }
+ !$omp error at(compilation) ! { dg-error ".OMP ERROR encountered at .1." }
+ !$omp error severity(fatal) ! { dg-error ".OMP ERROR encountered at .1." }
+ !$omp error message("42") ! { dg-error ".OMP ERROR encountered at .1.: 42" }
+ !$omp error severity(warning), message("foo"), at(compilation) ! { dg-warning ".OMP ERROR encountered at .1.: foo" }
+ integer s
+end type S
+end module m
+
+integer function foo (i, x)
+ integer :: i
+ logical :: x
+ !$omp error ! { dg-error ".OMP ERROR encountered at .1." }
+ !$omp error at(compilation) ! { dg-error ".OMP ERROR encountered at .1." }
+ !$omp error severity(fatal) ! { dg-error ".OMP ERROR encountered at .1." }
+ !$omp error message("42 / 1") ! { dg-error ".OMP ERROR encountered at .1.: 42 / 1" }
+ !$omp error severity(warning) message("bar") at(compilation) ! { dg-warning ".OMP ERROR encountered at .1.: bar" }
+ if (x) then
+ !$omp error ! { dg-error ".OMP ERROR encountered at .1." }
+ i = i + 1
+ end if
+ if (x) then
+ ;
+ else
+ !$omp error at(compilation) ! { dg-error ".OMP ERROR encountered at .1." }
+ i = i + 1
+ end if
+ select case (.false.)
+ !$omp error severity(fatal) ! { dg-error ".OMP ERROR encountered at .1." }
+ case default
+ !
+ end select
+ do while (.false.)
+ !$omp error message("42 - 1") ! { dg-error ".OMP ERROR encountered at .1.: 42 - 1" }
+ i = i + 1
+ end do
+ lab:
+ !$omp error severity(warning) message("bar") at(compilation) ! { dg-warning ".OMP ERROR encountered at .1.: bar" }
+ i++;
+ foo = i
+ return
+end
diff --git a/gcc/testsuite/gfortran.dg/gomp/error-2.f90 b/gcc/testsuite/gfortran.dg/gomp/error-2.f90
new file mode 100644
index 00000000000..718e82cead9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/error-2.f90
@@ -0,0 +1,15 @@
+subroutine foo (x, msg1, msg2)
+ integer x
+ character(len=*) :: msg1, msg2
+ if (x == 0) then
+ !$omp error at(execution)
+ else if (x == 1) then
+ !$omp error severity (warning), at (execution)
+ else if (x == 2) then
+ !$omp error at ( execution ) severity (fatal) message ("baz")
+ else if (x == 3) then
+ !$omp error severity(warning) message (msg1) at(execution)
+ else
+ !$omp error message (msg2), at(execution), severity(fatal)
+ end if
+end
diff --git a/gcc/testsuite/gfortran.dg/gomp/error-3.f90 b/gcc/testsuite/gfortran.dg/gomp/error-3.f90
new file mode 100644
index 00000000000..67948cdc52a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/error-3.f90
@@ -0,0 +1,88 @@
+module m
+!$omp error asdf ! { dg-error "Failed to match clause" }
+!$omp error at ! { dg-error "Failed to match clause" }
+!$omp error at( ! { dg-error "Expected COMPILATION or EXECUTION in AT clause at" }
+!$omp error at(runtime) ! { dg-error "Expected COMPILATION or EXECUTION in AT clause at" }
+!$omp error at(+ ! { dg-error "Expected COMPILATION or EXECUTION in AT clause at" }
+!$omp error at(compilation ! { dg-error "Expected COMPILATION or EXECUTION in AT clause at" }
+!$omp error severity ! { dg-error "Failed to match clause" }
+!$omp error severity( ! { dg-error "Expected FATAL or WARNING in SEVERITY clause at" }
+!$omp error severity(error) ! { dg-error "Expected FATAL or WARNING in SEVERITY clause at" }
+!$omp error severity(- ! { dg-error "Expected FATAL or WARNING in SEVERITY clause at" }
+!$omp error severity(fatal ! { dg-error "Expected FATAL or WARNING in SEVERITY clause at" }
+!$omp error message ! { dg-error "Failed to match clause" }
+!$omp error message( ! { dg-error "Invalid character in name" }
+!$omp error message(0 ! { dg-error "Failed to match clause" }
+!$omp error message("foo" ! { dg-error "Failed to match clause" }
+
+!$omp error at(compilation) at(compilation) ! { dg-error "Failed to match clause at" }
+!$omp error severity(fatal) severity(warning) ! { dg-error "Failed to match clause at" }
+!$omp error message("foo") message("foo") ! { dg-error "Failed to match clause at" }
+!$omp error message("foo"),at(compilation),severity(fatal),asdf ! { dg-error "Failed to match clause" }
+
+!$omp error at(execution) ! { dg-error "Unexpected !.OMP ERROR statement in MODULE" }
+
+end module
+
+module m2
+character(len=10) :: msg
+!$omp error message(1) ! { dg-error "MESSAGE clause at .1. requires a scalar default-kind CHARACTER expression" }
+!$omp error message(1.2) ! { dg-error "MESSAGE clause at .1. requires a scalar default-kind CHARACTER expression" }
+!$omp error message(4_"foo") ! { dg-error "MESSAGE clause at .1. requires a scalar default-kind CHARACTER expression" }
+!$omp error message(["bar","bar"]) ! { dg-error "MESSAGE clause at .1. requires a scalar default-kind CHARACTER expression" }
+!$omp error message(msg) ! { dg-error "Constant character expression required in MESSAGE clause" }
+
+type S
+ !$omp error at(execution) message("foo")! { dg-error "Unexpected !.OMP ERROR statement at" }
+ integer s
+end type
+end module
+
+subroutine bar
+character(len=10) :: msg
+!$omp error at(execution) message(1) ! { dg-error "MESSAGE clause at .1. requires a scalar default-kind CHARACTER expression" }
+!$omp error at(execution) message(1.2) ! { dg-error "MESSAGE clause at .1. requires a scalar default-kind CHARACTER expression" }
+!$omp error at(execution) message(4_"foo") ! { dg-error "MESSAGE clause at .1. requires a scalar default-kind CHARACTER expression" }
+!$omp error at(execution) message(["bar","bar"]) ! { dg-error "MESSAGE clause at .1. requires a scalar default-kind CHARACTER expression" }
+!$omp error at(execution) message(msg) ! OK
+
+end
+
+integer function foo (i, x, msg)
+ integer :: i
+ logical :: x
+ character(len=*) :: msg
+ !$omp error message(msg) ! { dg-error "Constant character expression required in MESSAGE clause" }
+ if (x) then
+ !$omp error at(execution) ! OK
+ end if
+ i = i + 1
+ if (x) then
+ ;
+ else
+ !$omp error at(execution) severity(warning) ! OK
+ end if
+ i = i + 1
+ select case (.false.)
+ !$omp error severity(fatal) at(execution) ! { dg-error "Expected a CASE or END SELECT statement following SELECT CASE" }
+ end select
+ do while (.false.)
+ !$omp error at(execution)message("42 - 1") ! OK
+ i = i + 1
+ end do
+99 continue
+ !$omp error severity(warning) message("bar") at(execution) ! OK
+ i = i + 1
+ foo = i
+end
+
+
+subroutine foobar
+ if (.true.) & ! { dg-error "Syntax error in IF-clause after" }
+ !$omp error at(execution)
+
+ continue
+
+ if (.true.) & ! { dg-error "Syntax error in IF-clause after" }
+ !$omp error ! { dg-error ".OMP ERROR encountered at" }
+end
diff --git a/libgomp/ChangeLog.omp b/libgomp/ChangeLog.omp
index 33090eefb7d..0a4a181d5e2 100644
--- a/libgomp/ChangeLog.omp
+++ b/libgomp/ChangeLog.omp
@@ -1,3 +1,10 @@
+2021-08-20 Tobias Burnus <tobias@codesourcery.com>
+
+ Backported from master:
+ 2021-08-20 Tobias Burnus <tobias@codesourcery.com>
+
+ * testsuite/libgomp.fortran/error-1.f90: New test.
+
2021-08-20 Tobias Burnus <tobias@codesourcery.com>
Backported from master:
diff --git a/libgomp/testsuite/libgomp.fortran/error-1.f90 b/libgomp/testsuite/libgomp.fortran/error-1.f90
new file mode 100644
index 00000000000..92c246cfcaf
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/error-1.f90
@@ -0,0 +1,78 @@
+! { dg-shouldfail "error directive" }
+
+module m
+ implicit none (external, type)
+contains
+integer function foo (i, x)
+ integer, value :: i, x
+ if (x /= 0) then
+ !$omp error severity(warning) ! { dg-warning ".OMP ERROR encountered at .1." }
+ i = i + 1
+ end if
+ if (x /= 0) then
+ ! ...
+ else
+ !$omp error severity(warning) ! { dg-warning ".OMP ERROR encountered at .1." }
+ i = i + 2
+ end if
+ select case(0)
+ !$omp error severity(warning) ! { dg-warning ".OMP ERROR encountered at .1." }
+ case default
+ !
+ end select
+ do while (.false.)
+ !$omp error message("42 - 1") severity (warning) ! { dg-warning ".OMP ERROR encountered at .1.: 42 - 1" }
+ i = i + 4
+ end do
+99 continue
+ !$omp error severity(warning) message("bar") at(compilation) ! { dg-warning ".OMP ERROR encountered at .1.: bar" }
+ i = i + 8
+ foo = i
+end function
+end module
+
+program main
+ use m
+ implicit none (external, type)
+ character(len=13) :: msg
+ character(len=:), allocatable :: msg2, msg3
+
+ msg = "my message"
+ if (foo (5, 0) /= 15 .or. foo (7, 1) /= 16) &
+ stop 1
+ msg2 = "Paris"
+ msg3 = "To thine own self be true"
+ call bar ("Polonius", "Laertes", msg2, msg3)
+ msg2 = "Hello World"
+ !$omp error at (execution) severity (warning)
+ !$omp error at (execution) severity (warning) message(trim(msg(4:)))
+ !$omp error at (execution) severity (warning) message ("Farewell")
+ !$omp error at (execution) severity (warning) message (msg2)
+ !$omp error at (execution) severity (warning) message (msg(4:6))
+ !$omp error at (execution) severity (fatal) message (msg)
+ ! unreachable due to 'fatal'---------^
+ !$omp error at (execution) severity (warning) message ("foobar")
+contains
+ subroutine bar(x, y, a, b)
+ character(len=*) :: x, y
+ character(len=:), allocatable :: a, b
+ optional :: y, b
+ intent(in) :: x, y, a, b
+ !$omp error at (execution) severity (warning) message (x)
+ !$omp error at (execution) severity (warning) message (y)
+ !$omp error at (execution) severity (warning) message (a)
+ !$omp error at (execution) severity (warning) message (b)
+ end subroutine
+end
+
+! { dg-output "(\n|\r|\n\r)" }
+! { dg-output "libgomp: error directive encountered: Polonius(\n|\r|\n\r)(\n|\r|\n\r)" }
+! { dg-output "libgomp: error directive encountered: Laertes(\n|\r|\n\r)(\n|\r|\n\r)" }
+! { dg-output "libgomp: error directive encountered: Paris(\n|\r|\n\r)(\n|\r|\n\r)" }
+! { dg-output "libgomp: error directive encountered: To thine own self be true(\n|\r|\n\r)(\n|\r|\n\r)" }
+! { dg-output "libgomp: error directive encountered(\n|\r|\n\r)(\n|\r|\n\r)" }
+! { dg-output "libgomp: error directive encountered: message(\n|\r|\n\r)(\n|\r|\n\r)" }
+! { dg-output "libgomp: error directive encountered: Farewell(\n|\r|\n\r)(\n|\r|\n\r)" }
+! { dg-output "libgomp: error directive encountered: Hello World(\n|\r|\n\r)(\n|\r|\n\r)" }
+! { dg-output "libgomp: error directive encountered: mes(\n|\r|\n\r)(\n|\r|\n\r)" }
+! { dg-output "libgomp: fatal error: error directive encountered: my message (\n|\r|\n\r)" }
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2021-08-20 13:32 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-08-20 13:32 [gcc/devel/omp/gcc-11] Fortran: Add OpenMP's error directive Tobias Burnus
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).