From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1534) id 771FC386FC10; Fri, 20 Aug 2021 13:32:04 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 771FC386FC10 Content-Type: text/plain; charset="us-ascii" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit From: Tobias Burnus To: gcc-cvs@gcc.gnu.org Subject: [gcc/devel/omp/gcc-11] Fortran: Add OpenMP's error directive X-Act-Checkin: gcc X-Git-Author: Tobias Burnus X-Git-Refname: refs/heads/devel/omp/gcc-11 X-Git-Oldrev: 8cb8bdfd5e702262a902891970fad7b1c40a8854 X-Git-Newrev: 47f4a06652b942fc1db8f0e4a2590f9ee84b3621 Message-Id: <20210820133204.771FC386FC10@sourceware.org> Date: Fri, 20 Aug 2021 13:32:04 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Fri, 20 Aug 2021 13:32:04 -0000 https://gcc.gnu.org/g:47f4a06652b942fc1db8f0e4a2590f9ee84b3621 commit 47f4a06652b942fc1db8f0e4a2590f9ee84b3621 Author: Tobias Burnus 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 + + Backported from master: + 2021-08-20 Tobias Burnus + + * 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 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 + + Backported from master: + 2021-08-20 Tobias Burnus + + * 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 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 + + Backported from master: + 2021-08-20 Tobias Burnus + + * testsuite/libgomp.fortran/error-1.f90: New test. + 2021-08-20 Tobias Burnus 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)" }