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.
This commit is contained in:
Tobias Burnus
parent
0d973c0a0d
commit
77167196fe
13 changed files with 465 additions and 25 deletions
|
|
@ -1908,6 +1908,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
|
||||
|
|
@ -1950,8 +1970,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;
|
||||
|
|
@ -2045,6 +2066,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:
|
||||
|
|
@ -2135,7 +2157,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)
|
||||
|
|
@ -3268,6 +3290,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:
|
||||
|
|
|
|||
|
|
@ -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
|
||||
{
|
||||
|
|
@ -1446,26 +1461,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;
|
||||
|
|
@ -1479,9 +1479,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;
|
||||
|
|
@ -2768,7 +2787,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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -28,6 +28,7 @@ along with GCC; see the file COPYING3. If not see
|
|||
#include "constructor.h"
|
||||
#include "diagnostic.h"
|
||||
#include "gomp-constants.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 '!'. */
|
||||
|
|
@ -848,6 +849,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
|
||||
|
|
@ -1293,6 +1297,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
|
||||
|
|
@ -1392,6 +1397,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)
|
||||
|
|
@ -1616,7 +1637,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;
|
||||
|
|
@ -2074,6 +2095,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)
|
||||
|
|
@ -2402,6 +2427,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)
|
||||
|
|
@ -2553,7 +2594,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");
|
||||
|
|
@ -2563,6 +2604,10 @@ end:
|
|||
|
||||
*cp = c;
|
||||
return MATCH_YES;
|
||||
|
||||
error:
|
||||
error = true;
|
||||
goto end;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -3208,6 +3253,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
|
||||
|
|
@ -3431,6 +3479,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)
|
||||
{
|
||||
|
|
@ -6463,6 +6571,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
|
||||
|
|
@ -7461,6 +7578,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:
|
||||
|
|
@ -7971,6 +8090,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:
|
||||
|
|
|
|||
|
|
@ -908,6 +908,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,
|
||||
|
|
@ -1183,6 +1184,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;
|
||||
}
|
||||
|
|
@ -1654,7 +1658,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: \
|
||||
|
|
@ -1716,7 +1720,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(). */
|
||||
|
||||
|
|
@ -2544,6 +2547,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;
|
||||
|
|
|
|||
|
|
@ -10817,6 +10817,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:
|
||||
|
|
@ -12254,6 +12255,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:
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -5368,6 +5368,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)
|
||||
{
|
||||
|
|
@ -7096,6 +7128,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:
|
||||
|
|
|
|||
|
|
@ -2155,6 +2155,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:
|
||||
|
|
|
|||
51
gcc/testsuite/gfortran.dg/gomp/error-1.f90
Normal file
51
gcc/testsuite/gfortran.dg/gomp/error-1.f90
Normal file
|
|
@ -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
|
||||
15
gcc/testsuite/gfortran.dg/gomp/error-2.f90
Normal file
15
gcc/testsuite/gfortran.dg/gomp/error-2.f90
Normal file
|
|
@ -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
|
||||
88
gcc/testsuite/gfortran.dg/gomp/error-3.f90
Normal file
88
gcc/testsuite/gfortran.dg/gomp/error-3.f90
Normal file
|
|
@ -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
|
||||
78
libgomp/testsuite/libgomp.fortran/error-1.f90
Normal file
78
libgomp/testsuite/libgomp.fortran/error-1.f90
Normal file
|
|
@ -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)" }
|
||||
Loading…
Add table
Reference in a new issue