diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/dump-parse-tree.c | 27 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 58 | ||||
| -rw-r--r-- | gcc/fortran/match.h | 1 | ||||
| -rw-r--r-- | gcc/fortran/openmp.c | 124 | ||||
| -rw-r--r-- | gcc/fortran/parse.c | 10 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 2 | ||||
| -rw-r--r-- | gcc/fortran/st.c | 1 | ||||
| -rw-r--r-- | gcc/fortran/trans-openmp.c | 34 | ||||
| -rw-r--r-- | gcc/fortran/trans.c | 1 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/gomp/error-1.f90 | 51 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/gomp/error-2.f90 | 15 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/gomp/error-3.f90 | 88 |
12 files changed, 387 insertions, 25 deletions
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 92d9f9e..c75a0a9 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -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: diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index a7d82ae..4b26cb4 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 { @@ -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 diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 5127b4b..92fd127 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 fd219dc..2380866 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -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 @@ -3432,6 +3480,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) { gfc_omp_namelist *list = NULL; @@ -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: diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index d004732..d37a0b5 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -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; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 117062b..5b9ba43 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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: diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index 7d87709..6bf730c 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 e0a0014..91888f3 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -5369,6 +5369,38 @@ gfc_trans_omp_depobj (gfc_code *code) } 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; @@ -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: diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 80b724d0..eb5682a 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -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: 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 0000000..0ee0b4b --- /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 0000000..718e82c --- /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 0000000..67948cd --- /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 |