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
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;
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:
|| 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)
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:
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
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
{
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;
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;
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
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);
#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 '!'. */
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
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
}
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)
else
gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for "
"category %s", pcategory);
- goto end;
+ goto error;
}
}
c->defaultmap[category] = behavior;
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)
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)
}
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");
*cp = c;
return MATCH_YES;
+
+error:
+ error = true;
+ goto end;
}
| 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
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)
{
gfc_omp_namelist *list = NULL;
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
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:
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:
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,
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;
}
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: \
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(). */
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;
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:
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:
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:
}
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)
{
tree call;
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:
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:
--- /dev/null
+! { 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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+! { 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)" }
projects / platform / upstream / gcc.git / commitdiff