public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc/devel/omp/gcc-13] OpenMP/Fortran: Merge upstream 'omp allocators' with OG13 'omp allocate'
@ 2023-10-26 14:14 Tobias Burnus
0 siblings, 0 replies; only message in thread
From: Tobias Burnus @ 2023-10-26 14:14 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:a8b1fb51ae55dcf8bf24fad1986e5280e362c873
commit a8b1fb51ae55dcf8bf24fad1986e5280e362c873
Author: Tobias Burnus <tobias@codesourcery.com>
Date: Thu Oct 26 11:17:40 2023 +0200
OpenMP/Fortran: Merge upstream 'omp allocators' with OG13 'omp allocate'
This merges mainline's
r14-1301-gd64e8e1224708e
Fortran/OpenMP: Add parsing support for allocators/allocate directives
into OG13.
In theory, that just replaces (reverts) the OG13-only commit
6ce5ee77f73 Add parsing support for allocate directive (OpenMP 5.0)
by Hafiz Abid Qadeer <abidh@codesourcery.com>
However, the replacement is not full - thus, this commit does much more:
While mainline support 'omp allocators' besides 'omp allocate' and
the latter also for stack and pointer variables,
the OG13 branch supports actual allocation with the directive version.
* Thus, this commit wires the mainline's executive allocate + new allocators
with the OG13 GOMP_alloc/GOMP_free handling.
* It also handles now the 'align' clause/modifier.
* By defaulting to 'omp allocators', it re-uses the ALLOCATE clause in the
ME instead of using the new ALLOCATOR clause, which has now been removed
from the ME code.
On the FE side, it also includes a modified version of:
https://gcc.gnu.org/pipermail/gcc-patches/2023-October/634096.html
[Patch] OpenMP/Fortran: Handle unlisted items in 'omp allocators' + exec. 'omp allocate'
The whole patch cannot be easily disentangled and parts of
6ce5ee77f73 remain in a revised form. For those bits, the
credits belong to Abid.
gcc/fortran/ChangeLog:
* dump-parse-tree.cc (show_omp_namelist, show_omp_node,
show_code_node): Dump EXEC_OMP_ALLOCATORS update for struct changes.
* gfortran.h (enum gfc_statement): Add ST_OMP_(END_)ALLOCATORS.
(gfc_omp_namelist): Add allocator to union u2.
(enum): Remove OMP_LIST_ALLOCATOR.
(gfc_namespace): Add omp_allocate.
(enum gfc_exec_op): Add EXEC_OMP_ALLOCATORS.
(gfc_resolve_omp_allocate): New prototype.
* match.cc (gfc_free_omp_namelist): Free u2.allocator.
* match.h (gfc_match_omp_allocators): New prototype.
* openmp.cc (gfc_omp_directives): Enable allocate/allocator.
(gfc_match_omp_variable_list): Add reject_common_vars Boolean arg.
(enum omp_mask2): Remove OMP_CLAUSE_ALLOCATOR.
(gfc_match_omp_clauses): Update for struct change.
(OMP_ALLOCATE_CLAUSES): Remove.
(OMP_ALLOCATORS_CLAUSES): Add.
(gfc_match_omp_allocate): Replace by upstream version.
(gfc_match_omp_allocators, is_predefined_allocator,
gfc_resolve_omp_allocate): New.
(verify_omp_clauses_symbol_dups): Update for allocate/allocator.
(resolve_omp_clauses): Update from mainline.
(omp_code_to_statement): Add EXEC_OMP_ALLOCATORS.
prepare_omp_allocated_var_list_for_cleanup,
check_allocate_directive_restrictions, EMPTY_VAR_LIST,
gfc_resolve_omp_allocate): Remove.
(gfc_resolve_omp_directive): Add EXEC_OMP_ALLOCATORS.
* parse.cc (check_omp_allocate_stmt, decode_omp_directive
next_statement, case_omp_decl, gfc_ascii_statement,
verify_st_order, parse_openmp_allocate_block,
parse_omp_structured_block, parse_executable): Update from mainline.
* resolve.cc (gfc_resolve_blocks, resolve_codes): Handle allocate
and allocator.
* st.cc (gfc_free_statement): And EXEC_OMP_ALLOCATORS.
* trans-decl.cc (gfc_trans_deferred_vars): Use OMP_LIST_ALLOCATE
instead of OMP_LIST_ALLOCATOR.
* trans-openmp.cc (gfc_trans_omp_clauses): Remove OMP_LIST_ALLOCATOR,
update allocate handling.
(gfc_trans_omp_allocate): Renamed to ...
(gfc_trans_omp_allocators): ... this.
(gfc_split_omp_clauses, gfc_trans_omp_directive): Update.
* trans.cc (trans_code): Handle EXEC_OMP_ALLOCATORS.
gcc/ChangeLog:
* omp-low.cc (scan_sharing_clauses): Update message for directive use.
(lower_omp_allocate, lower_omp_1): Update for clause changes; handle
alignment.
* tree-core.h (enum omp_clause_code): Remove OMP_CLAUSE_ALLOCATOR.
* tree-pretty-print.cc (dump_omp_clause): Likewise.
* tree.cc (omp_clause_num_ops): Likewise.
* tree.h (OMP_ALLOCATE_DECL, OMP_ALLOCATE_ALLOCATOR): Remove.
libgomp/ChangeLog:
* testsuite/libgomp.fortran/allocate-2a.f90: Add exec stmt.
* testsuite/libgomp.fortran/allocate-4.f90: Update dg-error
* testsuite/libgomp.fortran/allocate-5.f90: Likewise; add exec stmt.
gcc/testsuite/ChangeLog:
* gfortran.dg/gomp/allocate-2.f90: Update dg-warning.
* gfortran.dg/gomp/allocate-4.f90: New upstream test.
* gfortran.dg/gomp/allocate-5.f90: New upstream test.
* gfortran.dg/gomp/allocate-6.f90: New upstream test.
* gfortran.dg/gomp/allocate-7.f90: New upstream test.
* gfortran.dg/gomp/allocate-4a.f90: Renamed from allocate-4.f90
* gfortran.dg/gomp/allocate-6a.f90: Renamed from allocate-6.f90
* gfortran.dg/gomp/allocate-7a.f90: Renamed from allocate-7.f90
* gfortran.dg/gomp/allocate-9a.f90: New test.
* gfortran.dg/gomp/allocators-1.f90: New upstream test.
* gfortran.dg/gomp/allocators-2.f90: New upstream test.
Diff:
---
gcc/ChangeLog.omp | 11 +
gcc/fortran/ChangeLog.omp | 45 ++
gcc/fortran/dump-parse-tree.cc | 9 +-
gcc/fortran/gfortran.h | 14 +-
gcc/fortran/match.cc | 2 +
gcc/fortran/match.h | 1 +
gcc/fortran/openmp.cc | 704 +++++++++++++--------
gcc/fortran/parse.cc | 196 +++++-
gcc/fortran/resolve.cc | 5 +
gcc/fortran/st.cc | 1 +
gcc/fortran/trans-decl.cc | 2 +-
gcc/fortran/trans-openmp.cc | 54 +-
gcc/fortran/trans.cc | 3 +-
gcc/omp-low.cc | 45 +-
gcc/testsuite/ChangeLog.omp | 15 +
gcc/testsuite/gfortran.dg/gomp/allocate-2.f90 | 4 +-
gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 | 54 ++
gcc/testsuite/gfortran.dg/gomp/allocate-4a.f90 | 54 ++
gcc/testsuite/gfortran.dg/gomp/allocate-5.f90 | 148 +++--
gcc/testsuite/gfortran.dg/gomp/allocate-6.f90 | 171 ++---
gcc/testsuite/gfortran.dg/gomp/allocate-6a.f90 | 85 +++
gcc/testsuite/gfortran.dg/gomp/allocate-7.f90 | 236 ++++++-
gcc/testsuite/gfortran.dg/gomp/allocate-7a.f90 | 13 +
.../gomp/{allocate-8.f90 => allocate-8a.f90} | 0
gcc/testsuite/gfortran.dg/gomp/allocate-9a.f90 | 15 +
gcc/testsuite/gfortran.dg/gomp/allocators-1.f90 | 28 +
gcc/testsuite/gfortran.dg/gomp/allocators-2.f90 | 22 +
gcc/tree-core.h | 3 -
gcc/tree-pretty-print.cc | 14 -
gcc/tree.cc | 1 -
gcc/tree.h | 9 -
libgomp/ChangeLog.omp | 7 +
libgomp/testsuite/libgomp.fortran/allocate-2a.f90 | 1 +
libgomp/testsuite/libgomp.fortran/allocate-4.f90 | 12 +-
libgomp/testsuite/libgomp.fortran/allocate-5.f90 | 36 +-
35 files changed, 1492 insertions(+), 528 deletions(-)
diff --git a/gcc/ChangeLog.omp b/gcc/ChangeLog.omp
index 8205ecd05078..e8b23b90de12 100644
--- a/gcc/ChangeLog.omp
+++ b/gcc/ChangeLog.omp
@@ -1,3 +1,14 @@
+2023-10-26 Tobias Burnus <tobias@codesourcery.com>
+ Chung-Lin Tang <cltang@codesourcery.com>
+
+ * omp-low.cc (scan_sharing_clauses): Update message for directive use.
+ (lower_omp_allocate, lower_omp_1): Update for clause changes; handle
+ alignment.
+ * tree-core.h (enum omp_clause_code): Remove OMP_CLAUSE_ALLOCATOR.
+ * tree-pretty-print.cc (dump_omp_clause): Likewise.
+ * tree.cc (omp_clause_num_ops): Likewise.
+ * tree.h (OMP_ALLOCATE_DECL, OMP_ALLOCATE_ALLOCATOR): Remove.
+
2023-09-20 Tobias Burnus <tobias@codesourcery.com>
Backported from master:
diff --git a/gcc/fortran/ChangeLog.omp b/gcc/fortran/ChangeLog.omp
index bae90d1e5c1f..71098850548c 100644
--- a/gcc/fortran/ChangeLog.omp
+++ b/gcc/fortran/ChangeLog.omp
@@ -1,3 +1,48 @@
+2023-10-26 Tobias Burnus <tobias@codesourcery.com>
+ Chung-Lin Tang <cltang@codesourcery.com>
+
+ * dump-parse-tree.cc (show_omp_namelist, show_omp_node,
+ show_code_node): Dump EXEC_OMP_ALLOCATORS update for struct changes.
+ * gfortran.h (enum gfc_statement): Add ST_OMP_(END_)ALLOCATORS.
+ (gfc_omp_namelist): Add allocator to union u2.
+ (enum): Remove OMP_LIST_ALLOCATOR.
+ (gfc_namespace): Add omp_allocate.
+ (enum gfc_exec_op): Add EXEC_OMP_ALLOCATORS.
+ (gfc_resolve_omp_allocate): New prototype.
+ * match.cc (gfc_free_omp_namelist): Free u2.allocator.
+ * match.h (gfc_match_omp_allocators): New prototype.
+ * openmp.cc (gfc_omp_directives): Enable allocate/allocator.
+ (gfc_match_omp_variable_list): Add reject_common_vars Boolean arg.
+ (enum omp_mask2): Remove OMP_CLAUSE_ALLOCATOR.
+ (gfc_match_omp_clauses): Update for struct change.
+ (OMP_ALLOCATE_CLAUSES): Remove.
+ (OMP_ALLOCATORS_CLAUSES): Add.
+ (gfc_match_omp_allocate): Replace by upstream version.
+ (gfc_match_omp_allocators, is_predefined_allocator,
+ gfc_resolve_omp_allocate): New.
+ (verify_omp_clauses_symbol_dups): Update for allocate/allocator.
+ (resolve_omp_clauses): Update from mainline.
+ (omp_code_to_statement): Add EXEC_OMP_ALLOCATORS.
+ prepare_omp_allocated_var_list_for_cleanup,
+ check_allocate_directive_restrictions, EMPTY_VAR_LIST,
+ gfc_resolve_omp_allocate): Remove.
+ (gfc_resolve_omp_directive): Add EXEC_OMP_ALLOCATORS.
+ * parse.cc (check_omp_allocate_stmt, decode_omp_directive
+ next_statement, case_omp_decl, gfc_ascii_statement,
+ verify_st_order, parse_openmp_allocate_block,
+ parse_omp_structured_block, parse_executable): Update from mainline.
+ * resolve.cc (gfc_resolve_blocks, resolve_codes): Handle allocate
+ and allocator.
+ * st.cc (gfc_free_statement): And EXEC_OMP_ALLOCATORS.
+ * trans-decl.cc (gfc_trans_deferred_vars): Use OMP_LIST_ALLOCATE
+ instead of OMP_LIST_ALLOCATOR.
+ * trans-openmp.cc (gfc_trans_omp_clauses): Remove OMP_LIST_ALLOCATOR,
+ update allocate handling.
+ (gfc_trans_omp_allocate): Renamed to ...
+ (gfc_trans_omp_allocators): ... this.
+ (gfc_split_omp_clauses, gfc_trans_omp_directive): Update.
+ * trans.cc (trans_code): Handle EXEC_OMP_ALLOCATORS.
+
2023-10-16 Tobias Burnus <tobias@codesourcery.com>
Backported from master:
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 71d59118abfe..14d5ebdbb850 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -1364,14 +1364,14 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n)
if (n->expr)
{
fputs ("allocator(", dumpfile);
- show_expr (n->expr);
+ show_expr (n->u2.allocator);
fputc (')', dumpfile);
}
if (n->expr && n->u.align)
fputc (',', dumpfile);
if (n->u.align)
{
- fputs ("allocator(", dumpfile);
+ fputs ("align(", dumpfile);
show_expr (n->u.align);
fputc (')', dumpfile);
}
@@ -2137,6 +2137,7 @@ show_omp_node (int level, gfc_code *c)
case EXEC_OACC_ENTER_DATA: name = "ENTER DATA"; is_oacc = true; break;
case EXEC_OACC_EXIT_DATA: name = "EXIT DATA"; is_oacc = true; break;
case EXEC_OMP_ALLOCATE: name = "ALLOCATE"; break;
+ case EXEC_OMP_ALLOCATORS: name = "ALLOCATORS"; break;
case EXEC_OMP_ASSUME: name = "ASSUME"; break;
case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
case EXEC_OMP_BARRIER: name = "BARRIER"; break;
@@ -2242,6 +2243,8 @@ show_omp_node (int level, gfc_code *c)
case EXEC_OACC_CACHE:
case EXEC_OACC_ENTER_DATA:
case EXEC_OACC_EXIT_DATA:
+ case EXEC_OMP_ALLOCATE:
+ case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_CANCEL:
case EXEC_OMP_CANCELLATION_POINT:
@@ -2345,7 +2348,6 @@ show_omp_node (int level, gfc_code *c)
|| 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_ERROR
- || c->op == EXEC_OMP_ALLOCATE
|| (c->op == EXEC_OMP_ORDERED && c->block == NULL))
return;
if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
@@ -3492,6 +3494,7 @@ show_code_node (int level, gfc_code *c)
case EXEC_OACC_ENTER_DATA:
case EXEC_OACC_EXIT_DATA:
case EXEC_OMP_ALLOCATE:
+ case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_CANCEL:
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 2cb8257121fd..b93e17e98fff 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -260,7 +260,7 @@ enum gfc_statement
ST_OACC_CACHE, ST_OACC_KERNELS_LOOP, ST_OACC_END_KERNELS_LOOP,
ST_OACC_SERIAL_LOOP, ST_OACC_END_SERIAL_LOOP, ST_OACC_SERIAL,
ST_OACC_END_SERIAL, ST_OACC_ENTER_DATA, ST_OACC_EXIT_DATA, ST_OACC_ROUTINE,
- ST_OACC_ATOMIC, ST_OACC_END_ATOMIC, ST_OMP_ALLOCATE,
+ ST_OACC_ATOMIC, ST_OACC_END_ATOMIC,
ST_OMP_ATOMIC, ST_OMP_BARRIER, ST_OMP_CRITICAL, ST_OMP_END_ATOMIC,
ST_OMP_END_CRITICAL, ST_OMP_END_DO, ST_OMP_END_MASTER, ST_OMP_END_ORDERED,
ST_OMP_END_PARALLEL, ST_OMP_END_PARALLEL_DO, ST_OMP_END_PARALLEL_SECTIONS,
@@ -320,6 +320,8 @@ enum gfc_statement
ST_OMP_END_MASKED_TASKLOOP_SIMD, ST_OMP_SCOPE, ST_OMP_END_SCOPE,
ST_OMP_METADIRECTIVE, ST_OMP_BEGIN_METADIRECTIVE, ST_OMP_END_METADIRECTIVE,
ST_OMP_ERROR, ST_OMP_ASSUME, ST_OMP_END_ASSUME, ST_OMP_ASSUMES,
+ ST_OMP_ALLOCATE, ST_OMP_ALLOCATE_EXEC,
+ ST_OMP_ALLOCATORS, ST_OMP_END_ALLOCATORS,
/* Note: gfc_match_omp_nothing returns ST_NONE. */
ST_OMP_NOTHING, ST_NONE,
ST_OMP_UNROLL, ST_OMP_END_UNROLL,
@@ -1387,6 +1389,7 @@ typedef struct gfc_omp_namelist
struct gfc_omp_namelist_udr *udr;
struct gfc_omp_namelist_udm *udm;
gfc_namespace *ns;
+ gfc_expr *allocator;
struct gfc_omp_namelist *duplicate_of;
} u2;
struct gfc_symbol *memspace_sym;
@@ -1431,7 +1434,6 @@ enum
OMP_LIST_USE_DEVICE_ADDR,
OMP_LIST_NONTEMPORAL,
OMP_LIST_ALLOCATE,
- OMP_LIST_ALLOCATOR,
OMP_LIST_HAS_DEVICE_ADDR,
OMP_LIST_ENTER,
OMP_LIST_USES_ALLOCATORS,
@@ -2257,8 +2259,9 @@ typedef struct gfc_namespace
/* Linked list of !$omp declare variant constructs. */
struct gfc_omp_declare_variant *omp_declare_variant;
- /* OpenMP assumptions. */
+ /* OpenMP assumptions and allocate for static/stack vars. */
struct gfc_omp_assumptions *omp_assumes;
+ struct gfc_omp_namelist *omp_allocate;
/* A hash set for the gfc expressions that have already
been finalized in this namespace. */
@@ -3027,7 +3030,6 @@ enum gfc_exec_op
EXEC_OACC_DATA, EXEC_OACC_HOST_DATA, EXEC_OACC_LOOP, EXEC_OACC_UPDATE,
EXEC_OACC_WAIT, EXEC_OACC_CACHE, EXEC_OACC_ENTER_DATA, EXEC_OACC_EXIT_DATA,
EXEC_OACC_ATOMIC, EXEC_OACC_DECLARE,
- EXEC_OMP_ALLOCATE,
EXEC_OMP_CRITICAL, EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER,
EXEC_OMP_ORDERED, EXEC_OMP_PARALLEL, EXEC_OMP_PARALLEL_DO,
EXEC_OMP_PARALLEL_SECTIONS, EXEC_OMP_PARALLEL_WORKSHARE,
@@ -3058,7 +3060,8 @@ enum gfc_exec_op
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_METADIRECTIVE, EXEC_OMP_UNROLL, EXEC_OMP_TILE, EXEC_OMP_ERROR
+ EXEC_OMP_METADIRECTIVE, EXEC_OMP_UNROLL, EXEC_OMP_TILE, EXEC_OMP_ERROR,
+ EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS
};
typedef struct gfc_code
@@ -3712,6 +3715,7 @@ void gfc_free_omp_udr (gfc_omp_udr *);
void gfc_free_omp_metadirective_clauses (gfc_omp_metadirective_clause *);
void gfc_free_omp_udm (gfc_omp_udm *);
gfc_omp_udr *gfc_omp_udr_find (gfc_symtree *, gfc_typespec *);
+void gfc_resolve_omp_allocate (gfc_namespace *, gfc_omp_namelist *);
void gfc_resolve_omp_assumptions (gfc_omp_assumptions *);
gfc_omp_udm *gfc_omp_udm_find (gfc_symtree *, gfc_typespec *);
gfc_omp_udm *gfc_find_omp_udm (gfc_namespace *ns, const char *mapper_id,
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 38a0efed8acc..465036b77405 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -5554,6 +5554,8 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, int list)
gfc_free_namespace (name->u2.ns);
else if (free_mapper && name->u2.udm)
free (name->u2.udm);
+ else if (free_align)
+ gfc_free_expr (name->u2.allocator);
else if (!free_mapper && name->u2.udr)
{
if (name->u2.udr->combiner)
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 7d414e457b61..d15b06726f15 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -150,6 +150,7 @@ match gfc_match_oacc_routine (void);
/* OpenMP directive matchers. */
match gfc_match_omp_eos_error (void);
match gfc_match_omp_allocate (void);
+match gfc_match_omp_allocators (void);
match gfc_match_omp_assume (void);
match gfc_match_omp_assumes (void);
match gfc_match_omp_atomic (void);
diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index 53e705fff745..4707d1d5a1aa 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -56,8 +56,8 @@ struct gfc_omp_directive {
and "nothing". */
static const struct gfc_omp_directive gfc_omp_directives[] = {
- /* {"allocate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_ALLOCATE}, */
- /* {"allocators", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ALLOCATORS}, */
+ {"allocate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_ALLOCATE},
+ {"allocators", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ALLOCATORS},
{"assumes", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUMES},
{"assume", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUME},
{"atomic", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ATOMIC},
@@ -430,7 +430,8 @@ gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
gfc_omp_namelist ***headp = NULL,
bool allow_sections = false,
bool allow_derived = false,
- bool *has_all_memory = NULL)
+ bool *has_all_memory = NULL,
+ bool reject_common_vars = false)
{
gfc_omp_namelist *head, *tail, *p;
locus old_loc, cur_loc;
@@ -518,6 +519,15 @@ gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
tail->sym = sym;
tail->expr = expr;
tail->where = cur_loc;
+ if (reject_common_vars && sym->attr.in_common)
+ {
+ gcc_assert (allow_common);
+ gfc_error ("%qs at %L is part of the common block %</%s/%> and "
+ "may only be specificed implicitly via the named "
+ "common block", sym->name, &cur_loc,
+ sym->common_head->name);
+ goto cleanup;
+ }
goto next_item;
case MATCH_NO:
break;
@@ -1187,7 +1197,6 @@ enum omp_mask2
OMP_CLAUSE_FINALIZE,
OMP_CLAUSE_ATTACH,
OMP_CLAUSE_NOHOST,
- OMP_CLAUSE_ALLOCATOR,
OMP_CLAUSE_HAS_DEVICE_ADDR, /* OpenMP 5.1 */
OMP_CLAUSE_ENTER, /* OpenMP 5.2 */
OMP_CLAUSE_DOACROSS, /* OpenMP 5.2 */
@@ -2643,7 +2652,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
for (gfc_omp_namelist *n = *head; n; n = n->next)
{
- n->expr = (allocator) ? gfc_copy_expr (allocator) : NULL;
+ n->u2.allocator = ((allocator)
+ ? gfc_copy_expr (allocator) : NULL);
n->u.align = (align) ? gfc_copy_expr (align) : NULL;
}
gfc_free_expr (allocator);
@@ -5031,7 +5041,6 @@ cleanup:
}
-#define OMP_ALLOCATE_CLAUSES (omp_mask (OMP_CLAUSE_ALLOCATOR))
#define OMP_PARALLEL_CLAUSES \
(omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
| OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
@@ -5123,6 +5132,8 @@ cleanup:
(omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
#define OMP_WORKSHARE_CLAUSES \
omp_mask (OMP_CLAUSE_NOWAIT)
+#define OMP_ALLOCATORS_CLAUSES \
+ omp_mask (OMP_CLAUSE_ALLOCATE)
#define OMP_UNROLL_CLAUSES \
(omp_mask (OMP_CLAUSE_UNROLL_FULL) | OMP_CLAUSE_UNROLL_PARTIAL)
#define OMP_TILE_CLAUSES \
@@ -5140,6 +5151,113 @@ match_omp (gfc_exec_op op, const omp_mask mask)
return MATCH_YES;
}
+/* Handles both declarative and (deprecated) executable ALLOCATE directive;
+ accepts optional list (for executable) and common blocks.
+ If no variables have been provided, the single omp namelist has sym == NULL.
+
+ Note that the executable ALLOCATE directive permits structure elements only
+ in OpenMP 5.0 and 5.1 but not longer in 5.2. See also the comment on the
+ 'omp allocators' directive below. The accidental change was reverted for
+ OpenMP TR12, permitting them again. See also gfc_match_omp_allocators.
+
+ Hence, structure elements are rejected for now, also to make resolving
+ OMP_LIST_ALLOCATE simpler (check for duplicates, same symbol in
+ Fortran allocate stmt). TODO: Permit structure elements. */
+
+match
+gfc_match_omp_allocate (void)
+{
+ match m;
+ bool first = true;
+ gfc_omp_namelist *vars = NULL;
+ gfc_expr *align = NULL;
+ gfc_expr *allocator = NULL;
+ locus loc = gfc_current_locus;
+
+ m = gfc_match_omp_variable_list (" (", &vars, true, NULL, NULL, true, true,
+ NULL, true);
+
+ if (m == MATCH_ERROR)
+ return m;
+
+ while (true)
+ {
+ gfc_gobble_whitespace ();
+ if (gfc_match_omp_eos () == MATCH_YES)
+ break;
+ if (!first)
+ gfc_match (", ");
+ first = false;
+ if ((m = gfc_match_dupl_check (!align, "align", true, &align))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ continue;
+ }
+ if ((m = gfc_match_dupl_check (!allocator, "allocator",
+ true, &allocator)) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ continue;
+ }
+ gfc_error ("Expected ALIGN or ALLOCATOR clause at %C");
+ return MATCH_ERROR;
+ }
+ for (gfc_omp_namelist *n = vars; n; n = n->next)
+ if (n->expr)
+ {
+ if ((n->expr->ref && n->expr->ref->type == REF_COMPONENT)
+ || (n->expr->ref->next && n->expr->ref->type == REF_COMPONENT))
+ gfc_error ("Sorry, structure-element list item at %L in ALLOCATE "
+ "directive is not yet supported", &n->expr->where);
+ else
+ gfc_error ("Unexpected expression as list item at %L in ALLOCATE "
+ "directive", &n->expr->where);
+
+ gfc_free_omp_namelist (vars, OMP_LIST_ALLOCATE);
+ goto error;
+ }
+
+ new_st.op = EXEC_OMP_ALLOCATE;
+ new_st.ext.omp_clauses = gfc_get_omp_clauses ();
+ if (vars == NULL)
+ {
+ vars = gfc_get_omp_namelist ();
+ vars->where = loc;
+ vars->u.align = align;
+ vars->u2.allocator = allocator;
+ new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
+ }
+ else
+ {
+ new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
+ for (; vars; vars = vars->next)
+ {
+ vars->u.align = (align) ? gfc_copy_expr (align) : NULL;
+ vars->u2.allocator = ((allocator) ? gfc_copy_expr (allocator) : NULL);
+ }
+ gfc_free_expr (allocator);
+ gfc_free_expr (align);
+ }
+ return MATCH_YES;
+
+error:
+ gfc_free_expr (align);
+ gfc_free_expr (allocator);
+ return MATCH_ERROR;
+}
+
+/* In line with OpenMP 5.2 derived-type components are rejected.
+ See also comment before gfc_match_omp_allocate. */
+
+match
+gfc_match_omp_allocators (void)
+{
+ return match_omp (EXEC_OMP_ALLOCATORS, OMP_ALLOCATORS_CLAUSES);
+}
+
match
gfc_match_omp_assume (void)
@@ -7656,66 +7774,6 @@ gfc_match_omp_ordered_depend (void)
return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DOACROSS));
}
-/* omp allocate (list) [clause-list]
- - clause-list: allocator
-*/
-
-match
-gfc_match_omp_allocate (void)
-{
- gfc_omp_clauses *c = gfc_get_omp_clauses ();
- gfc_expr *allocator = NULL;
- match m;
-
- m = gfc_match (" (");
- if (m == MATCH_YES)
- {
- m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATOR],
- true, NULL);
-
- if (m != MATCH_YES)
- {
- /* If the list was empty, we must find closing ')'. */
- m = gfc_match (")");
- if (m != MATCH_YES)
- return m;
- }
- }
-
- if (gfc_match (" allocator ( ") == MATCH_YES)
- {
- m = gfc_match_expr (&allocator);
- if (m != MATCH_YES)
- {
- gfc_error ("Expected allocator at %C");
- return MATCH_ERROR;
- }
- if (gfc_match (" ) ") != MATCH_YES)
- {
- gfc_error ("Expected ')' at %C");
- gfc_free_expr (allocator);
- return MATCH_ERROR;
- }
- }
-
- if (gfc_match_omp_eos () != MATCH_YES)
- {
- gfc_free_expr (allocator);
- gfc_error ("Unexpected junk after $OMP allocate at %C");
- return MATCH_ERROR;
- }
- gfc_omp_namelist *n;
- for (n = c->lists[OMP_LIST_ALLOCATOR]; n; n = n->next)
- n->expr = gfc_copy_expr (allocator);
-
- new_st.op = EXEC_OMP_ALLOCATE;
- new_st.ext.omp_clauses = c;
- new_st.resolved_sym = NULL;
- gfc_free_expr (allocator);
- return MATCH_YES;
-}
-
-
/* omp atomic [clause-list]
- atomic-clause: read | write | update
- capture
@@ -8170,6 +8228,128 @@ resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
return copy;
}
+/* Assume that a constant expression in the range 1 (omp_default_mem_alloc)
+ to 8 (omp_thread_mem_alloc) range is fine. The original symbol name is
+ already lost during matching via gfc_match_expr. */
+bool
+is_predefined_allocator (gfc_expr *expr)
+{
+ return (gfc_resolve_expr (expr)
+ && expr->rank == 0
+ && expr->ts.type == BT_INTEGER
+ && expr->ts.kind == gfc_c_intptr_kind
+ && expr->expr_type == EXPR_CONSTANT
+ && mpz_sgn (expr->value.integer) > 0
+ && mpz_cmp_si (expr->value.integer, 8) <= 0);
+}
+
+/* Resolve declarative ALLOCATE statement. Note: Common block vars only appear
+ as /block/ not individual, which is ensured during parsing. */
+
+void
+gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
+{
+ for (gfc_omp_namelist *n = list; n; n = n->next)
+ n->sym->mark = 0;
+ for (gfc_omp_namelist *n = list; n; n = n->next)
+ {
+ if (n->sym->attr.flavor != FL_VARIABLE)
+ {
+ gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE "
+ "directive must be a variable", n->sym->name,
+ &n->where);
+ continue;
+ }
+ if (ns != n->sym->ns || n->sym->attr.use_assoc
+ || n->sym->attr.host_assoc || n->sym->attr.imported)
+ {
+ gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shall be"
+ " in the same scope as the variable declaration",
+ n->sym->name, &n->where);
+ continue;
+ }
+ if (n->sym->attr.dummy)
+ {
+ gfc_error ("Unexpected dummy argument %qs as argument at %L to "
+ "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
+ continue;
+ }
+ if (n->sym->mark)
+ {
+ if (n->sym->attr.in_common)
+ {
+ gfc_error ("Duplicated common block %</%s/%> in !$OMP ALLOCATE "
+ "at %L", n->sym->common_head->name, &n->where);
+ while (n->next && n->next->sym
+ && n->sym->common_head == n->next->sym->common_head)
+ n = n->next;
+ }
+ else
+ gfc_error ("Duplicated variable %qs in !$OMP ALLOCATE at %L",
+ n->sym->name, &n->where);
+ continue;
+ }
+ n->sym->mark = 1;
+ if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
+ && CLASS_DATA (n->sym)->attr.allocatable)
+ || (n->sym->ts.type != BT_CLASS && n->sym->attr.allocatable))
+ gfc_error ("Unexpected allocatable variable %qs at %L in declarative "
+ "!$OMP ALLOCATE directive", n->sym->name, &n->where);
+ else if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
+ && CLASS_DATA (n->sym)->attr.class_pointer)
+ || (n->sym->ts.type != BT_CLASS && n->sym->attr.pointer))
+ gfc_error ("Unexpected pointer variable %qs at %L in declarative "
+ "!$OMP ALLOCATE directive", n->sym->name, &n->where);
+ HOST_WIDE_INT alignment = 0;
+ if (n->u.align
+ && (!gfc_resolve_expr (n->u.align)
+ || n->u.align->ts.type != BT_INTEGER
+ || n->u.align->rank != 0
+ || n->u.align->expr_type != EXPR_CONSTANT
+ || gfc_extract_hwi (n->u.align, &alignment)
+ || !pow2p_hwi (alignment)))
+ {
+ gfc_error ("ALIGN requires a scalar positive constant integer "
+ "alignment expression at %L that is a power of two",
+ &n->u.align->where);
+ while (n->sym->attr.in_common && n->next && n->next->sym
+ && n->sym->common_head == n->next->sym->common_head)
+ n = n->next;
+ continue;
+ }
+ if (n->sym->attr.in_common || n->sym->attr.save || n->sym->ns->save_all
+ || (n->sym->ns->proc_name
+ && (n->sym->ns->proc_name->attr.flavor == FL_PROGRAM
+ || n->sym->ns->proc_name->attr.flavor == FL_MODULE)))
+ {
+ bool com = n->sym->attr.in_common;
+ if (!n->u2.allocator)
+ gfc_error ("An ALLOCATOR clause is required as the list item "
+ "%<%s%s%s%> at %L has the SAVE attribute", com ? "/" : "",
+ com ? n->sym->common_head->name : n->sym->name,
+ com ? "/" : "", &n->where);
+ else if (!is_predefined_allocator (n->u2.allocator))
+ gfc_error ("Predefined allocator required in ALLOCATOR clause at %L"
+ " as the list item %<%s%s%s%> at %L has the SAVE attribute",
+ &n->u2.allocator->where, com ? "/" : "",
+ com ? n->sym->common_head->name : n->sym->name,
+ com ? "/" : "", &n->where);
+ while (n->sym->attr.in_common && n->next && n->next->sym
+ && n->sym->common_head == n->next->sym->common_head)
+ n = n->next;
+ }
+ else if (n->u2.allocator
+ && (!gfc_resolve_expr (n->u2.allocator)
+ || n->u2.allocator->ts.type != BT_INTEGER
+ || n->u2.allocator->rank != 0
+ || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
+ gfc_error ("Expected integer expression of the "
+ "%<omp_allocator_handle_kind%> kind at %L",
+ &n->u2.allocator->where);
+ }
+ gfc_error ("Sorry, declarative !$OMP ALLOCATE at %L not yet supported",
+ &list->where);
+}
/* Resolve ASSUME's and ASSUMES' assumption clauses. Note that absent/contains
is handled during parse time in omp_verify_merge_absent_contains. */
@@ -8457,28 +8637,31 @@ verify_omp_clauses_symbol_dups (gfc_code *code, gfc_omp_clauses *omp_clauses,
{
for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
{
- if (n->expr && (!gfc_resolve_expr (n->expr)
- || n->expr->ts.type != BT_INTEGER
- || n->expr->ts.kind != gfc_c_intptr_kind))
+ if (n->u2.allocator
+ && (!gfc_resolve_expr (n->u2.allocator)
+ || n->u2.allocator->ts.type != BT_INTEGER
+ || n->u2.allocator->rank != 0
+ || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
{
gfc_error ("Expected integer expression of the "
"%<omp_allocator_handle_kind%> kind at %L",
- &n->expr->where);
+ &n->u2.allocator->where);
break;
}
if (!n->u.align)
continue;
- int alignment = 0;
+ HOST_WIDE_INT alignment = 0;
if (!gfc_resolve_expr (n->u.align)
|| n->u.align->ts.type != BT_INTEGER
|| n->u.align->rank != 0
- || gfc_extract_int (n->u.align, &alignment)
+ || n->u.align->expr_type != EXPR_CONSTANT
+ || gfc_extract_hwi (n->u.align, &alignment)
|| alignment <= 0
|| !pow2p_hwi (alignment))
{
- gfc_error ("ALIGN modifier requires at %L a scalar positive "
- "constant integer alignment expression that is a "
- "power of two", &n->u.align->where);
+ gfc_error ("ALIGN requires a scalar positive constant integer "
+ "alignment expression at %L that is a power of two",
+ &n->u.align->where);
break;
}
}
@@ -8488,15 +8671,21 @@ verify_omp_clauses_symbol_dups (gfc_code *code, gfc_omp_clauses *omp_clauses,
2. Variable in allocate clause are also present in some
privatization clase (non-composite case). */
for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
- n->sym->mark = 0;
+ if (n->sym)
+ n->sym->mark = 0;
gfc_omp_namelist *prev = NULL;
- for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n;)
+ for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; )
{
+ if (n->sym == NULL)
+ {
+ n = n->next;
+ continue;
+ }
if (n->sym->mark == 1)
{
gfc_warning (0, "%qs appears more than once in %<allocate%> "
- "clauses at %L" , n->sym->name, &n->where);
+ "at %L" , n->sym->name, &n->where);
/* We have already seen this variable so it is a duplicate.
Remove it. */
if (prev != NULL && prev->next == n)
@@ -8541,6 +8730,168 @@ verify_omp_clauses_symbol_dups (gfc_code *code, gfc_omp_clauses *omp_clauses,
"in an explicit privatization clause", n->sym->name,
&n->where);
}
+ if (code
+ && (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE)
+ && code->block
+ && code->block->next
+ && code->block->next->op == EXEC_ALLOCATE)
+ {
+ gfc_alloc *a;
+ gfc_omp_namelist *n_null = NULL;
+ for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
+ {
+ if (n->sym == NULL)
+ {
+ n_null = n;
+ continue;
+ }
+ for (a = code->block->next->ext.alloc.list; a; a = a->next)
+ if (a->expr->expr_type == EXPR_VARIABLE
+ && a->expr->symtree->n.sym == n->sym)
+ break;
+ if (a == NULL)
+ gfc_error ("%qs specified in %<allocate%> at %L but not "
+ "in the associated ALLOCATE statement",
+ n->sym->name, &n->where);
+ }
+ /* If there is an ALLOCATE directive without list argument, a
+ namelist with its allocator/align clauses and n->sym = NULL is
+ created during parsing; here, we add all not otherwise specified
+ items from the Fortran allocate to that list.
+ For an ALLOCATORS directive, not listed items use the normal
+ Fortran way.
+ The behavior of an ALLOCATE directive that does not list all
+ arguments but there is no directive without list argument is not
+ well specified. Thus, we reject such code below. In OpenMP 5.2
+ the executable ALLOCATE directive is deprecated and in 6.0
+ deleted such that no spec clarification is to be expected. */
+ gfc_alloc *a_prev = NULL;
+ gfc_alloc *extra_alloc = NULL, *extra_alloc_last = NULL;
+ for (a = code->block->next->ext.alloc.list; a; )
+ {
+ if (a->expr->expr_type == EXPR_VARIABLE)
+ {
+ for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
+ if (a->expr->symtree->n.sym == n->sym)
+ break;
+ if (n == NULL && n_null == NULL)
+ {
+ if (!extra_alloc)
+ extra_alloc = extra_alloc_last = a;
+ else
+ {
+ extra_alloc_last->next = a;
+ extra_alloc_last = a;
+ }
+ a = a->next;
+ if (code->block->next->ext.alloc.list == extra_alloc_last)
+ code->block->next->ext.alloc.list = a;
+ else
+ a_prev->next = a;
+ extra_alloc_last->next = NULL;
+ continue;
+ }
+ if (n == NULL)
+ {
+ if (a->expr->symtree->n.sym->attr.codimension)
+ gfc_error ("Unexpected coarray %qs in %<allocate%> at "
+ "%L, implicitly listed in %<!$OMP ALLOCATE%>"
+ " at %L", a->expr->symtree->n.sym->name,
+ &a->expr->where, &n_null->where);
+ if (n_null->sym == NULL)
+ n_null->sym = a->expr->symtree->n.sym;
+ else
+ {
+ n = n_null->next;
+ n_null->next = gfc_get_omp_namelist ();
+ n_null->next->next = n;
+ n_null->next->sym = a->expr->symtree->n.sym;
+ n_null->next->u2.allocator = n_null->u2.allocator;
+ n_null->next->u.align
+ = gfc_copy_expr (n_null->u.align);
+ n_null->next->where = n_null->where;
+ n_null = n_null->next;
+ }
+ }
+ }
+ a_prev = a;
+ a = a->next;
+ }
+ if (n_null && n_null->sym == NULL)
+ {
+ if (n_null == omp_clauses->lists[OMP_LIST_ALLOCATE])
+ omp_clauses->lists[OMP_LIST_ALLOCATE] = n_null->next;
+ else
+ {
+ for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n;
+ n = n->next)
+ if (n->next == n_null)
+ break;
+ n->next = n_null->next;
+ n_null->next = NULL;
+ gfc_free_omp_namelist (n_null, OMP_LIST_ALLOCATE);
+ }
+ }
+ if (extra_alloc)
+ {
+ /* Unspecified whether that should use the default allocator
+ of OpenMP or the Fortran allocator. Thus, just reject it. */
+ if (code->op == EXEC_OMP_ALLOCATE)
+ gfc_error ("%qs listed in %<allocate%> statement at %L but "
+ "it is neither explicitly in listed in the "
+ "%<!$OMP ALLOCATE%> directive nor exists a directive"
+ " without argument list",
+ extra_alloc->expr->symtree->n.sym->name,
+ &extra_alloc->expr->where);
+ gfc_code *c = code->block->next;
+ gcc_assert (c->op == EXEC_ALLOCATE && c->next == NULL);
+ gfc_code *cn = code->next;
+ code->next = gfc_get_code (c->op);
+ code->next->next = cn;
+ cn = code->next;
+ cn->loc = c->loc;
+ cn->expr1 = gfc_copy_expr (cn->expr1);
+ cn->expr2 = gfc_copy_expr (cn->expr2);
+ cn->expr3 = gfc_copy_expr (cn->expr3);
+ cn->ext.alloc.ts = cn->ext.alloc.ts;
+ cn->ext.alloc.list = extra_alloc;
+ cn->ext.alloc.arr_spec_from_expr3
+ = c->ext.alloc.arr_spec_from_expr3;
+ cn->ext.alloc.expr3_not_explicit
+ = c->ext.alloc.expr3_not_explicit;
+ }
+ /* The current implementation requires that an EXEC_OMP_ALLOCATE is
+ added with OMP_ALLOCATE_KIND_FREE set at the end of the scope;
+ cf. trans-decl.cc's gfc_trans_deferred_vars and
+ gfc_trans_omp_allocate. */
+ for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
+ if (n->sym
+ && n->sym->attr.allocatable
+ && !n->sym->attr.save
+ && !n->sym->attr.result
+ && !n->sym->ns->proc_name->attr.is_main_program)
+ {
+ if (ns != n->sym->ns)
+ gfc_error ("Sorry, allocation of allocatable %qs with "
+ "%<!$omp allocators%> or %<!$omp allocate%> at %L "
+ "is only suppored in the scope where it has been "
+ "declared, unless it has the SAVE attribute",
+ n->sym->name, &code->loc);
+ gfc_symbol *proc = n->sym->ns->proc_name;
+ gfc_omp_namelist *p = gfc_get_omp_namelist ();
+ p->sym = n->sym;
+ p->expr = gfc_copy_expr (n->expr);
+ p->where = code->loc;
+ p->next = NULL;
+ if (proc->omp_allocated == NULL)
+ proc->omp_allocated_end = proc->omp_allocated = p;
+ else
+ {
+ proc->omp_allocated_end->next = p;
+ proc->omp_allocated_end = p;
+ }
+ }
+ }
}
for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
n->sym->mark = 0;
@@ -8811,7 +9162,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
"IN_REDUCTION", "TASK_REDUCTION",
"DEVICE_RESIDENT", "LINK", "USE_DEVICE",
"CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
- "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER", "ALLOCATOR",
+ "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER",
"USES_ALLOCATORS" };
STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
@@ -9110,15 +9461,13 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
n->sym->name, &n->where);
else if (n->expr)
{
- gfc_expr *expr = n->expr;
- int alignment = 0;
- if (!gfc_resolve_expr (expr)
- || expr->ts.type != BT_INTEGER
- || expr->rank != 0
- || gfc_extract_int (expr, &alignment)
- || alignment <= 0)
- gfc_error ("%qs in ALIGNED clause at %L requires a scalar "
- "positive constant integer alignment "
+ if (!gfc_resolve_expr (n->expr)
+ || n->expr->ts.type != BT_INTEGER
+ || n->expr->rank != 0
+ || n->expr->expr_type != EXPR_CONSTANT
+ || mpz_sgn (n->expr->value.integer) <= 0)
+ gfc_error ("%qs in ALIGNED clause at %L requires a scalar"
+ " positive constant integer alignment "
"expression", n->sym->name, &n->where);
}
}
@@ -9318,6 +9667,12 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
default:
for (; n != NULL; n = n->next)
{
+ if (n->sym == NULL)
+ {
+ gcc_assert (code->op == EXEC_OMP_ALLOCATORS
+ || code->op == EXEC_OMP_ALLOCATE);
+ continue;
+ }
bool bad = false;
bool is_reduction = (list == OMP_LIST_REDUCTION
|| list == OMP_LIST_REDUCTION_INSCAN
@@ -11706,8 +12061,6 @@ omp_code_to_statement (gfc_code *code)
{
switch (code->op)
{
- case EXEC_OMP_ALLOCATE:
- return ST_OMP_ALLOCATE;
case EXEC_OMP_PARALLEL:
return ST_OMP_PARALLEL;
case EXEC_OMP_PARALLEL_MASKED:
@@ -11754,6 +12107,10 @@ omp_code_to_statement (gfc_code *code)
return ST_OMP_DO;
case EXEC_OMP_LOOP:
return ST_OMP_LOOP;
+ case EXEC_OMP_ALLOCATE:
+ return ST_OMP_ALLOCATE_EXEC;
+ case EXEC_OMP_ALLOCATORS:
+ return ST_OMP_ALLOCATORS;
case EXEC_OMP_ASSUME:
return ST_OMP_ASSUME;
case EXEC_OMP_ATOMIC:
@@ -12207,168 +12564,6 @@ gfc_resolve_oacc_routines (gfc_namespace *ns)
}
}
-static void
-prepare_omp_allocated_var_list_for_cleanup (gfc_omp_namelist *cn, locus loc)
-{
- gfc_symbol *proc = cn->sym->ns->proc_name;
- gfc_omp_namelist *p, *n;
-
- for (n = cn; n; n = n->next)
- {
- if (n->sym->attr.allocatable && !n->sym->attr.save
- && !n->sym->attr.result && !proc->attr.is_main_program)
- {
- p = gfc_get_omp_namelist ();
- p->sym = n->sym;
- p->expr = gfc_copy_expr (n->expr);
- p->where = loc;
- p->next = NULL;
- if (proc->omp_allocated == NULL)
- proc->omp_allocated_end = proc->omp_allocated = p;
- else
- {
- proc->omp_allocated_end->next = p;
- proc->omp_allocated_end = p;
- }
-
- }
- }
-}
-
-static void
-check_allocate_directive_restrictions (gfc_symbol *sym, gfc_expr *omp_al,
- gfc_namespace *ns, locus loc)
-{
- if (sym->attr.save != SAVE_NONE || sym->attr.in_common == 1
- || sym->module != NULL)
- {
- int tmp;
- /* Assumption here is that we can extract an integer then
- it is a predefined thing. */
- if (!omp_al || gfc_extract_int (omp_al, &tmp))
- gfc_error ("%qs should use predefined allocator at %L", sym->name,
- &loc);
- }
- if (ns != sym->ns)
- gfc_error ("%qs is not in the same scope as %<allocate%>"
- " directive at %L", sym->name, &loc);
-}
-
-#define EMPTY_VAR_LIST(node) \
- (node->ext.omp_clauses->lists[OMP_LIST_ALLOCATOR] == NULL)
-
-static void
-gfc_resolve_omp_allocate (gfc_code *code, gfc_namespace *ns)
-{
- gfc_alloc *al;
- gfc_omp_namelist *n = NULL;
- gfc_omp_namelist *cn = NULL;
- gfc_omp_namelist *p, *tail = NULL;
- gfc_code *cur;
- hash_set<gfc_symbol*> vars;
-
- gfc_omp_clauses *clauses = code->ext.omp_clauses;
- gcc_assert (clauses);
- cn = clauses->lists[OMP_LIST_ALLOCATOR];
- gfc_expr *omp_al = cn ? cn->expr : NULL;
-
- if (omp_al && (omp_al->ts.type != BT_INTEGER
- || omp_al->ts.kind != gfc_c_intptr_kind))
- gfc_error ("Expected integer expression of the "
- "%<omp_allocator_handle_kind%> kind at %L", &omp_al->where);
-
- /* Check that variables in this allocate directive are not duplicated
- in this directive or others coming directly after it. */
- for (cur = code; cur != NULL && cur->op == EXEC_OMP_ALLOCATE;
- cur = cur->next)
- {
- gfc_omp_clauses *c = cur->ext.omp_clauses;
- gcc_assert (c);
- for (n = c->lists[OMP_LIST_ALLOCATOR]; n; n = n->next)
- {
- if (vars.contains (n->sym))
- gfc_error ("%qs is used in multiple %<allocate%> "
- "directives at %L", n->sym->name, &cur->loc);
- /* This helps us avoid duplicate error messages. */
- if (cur == code)
- vars.add (n->sym);
- }
- }
-
- if (cur == NULL || cur->op != EXEC_ALLOCATE)
- {
- /* There is no allocate statement right after allocate directive.
- We don't support this case at the moment. */
- for (n = cn; n != NULL; n = n->next)
- {
- gfc_symbol *sym = n->sym;
- if (sym->attr.allocatable == 1)
- gfc_error ("%qs with ALLOCATABLE attribute is not allowed in "
- "%<allocate%> directive at %L as this directive is not"
- " associated with an %<allocate%> statement.",
- sym->name, &code->loc);
- }
- sorry_at (code->loc.lb->location, "%<allocate%> directive that is "
- "not associated with an %<allocate%> statement is not "
- "supported.");
- return;
- }
-
- /* If there is another allocate directive right after this one, check
- that none of them is empty. Doing it this way, we can check this
- thing even when multiple directives are together and generate
- error at right location. */
- if (code->next && code->next->op == EXEC_OMP_ALLOCATE
- && (EMPTY_VAR_LIST (code) || EMPTY_VAR_LIST (code->next)))
- gfc_error ("Empty variable list is not allowed at %L when multiple "
- "%<allocate%> directives are associated with an "
- "%<allocate%> statement.",
- EMPTY_VAR_LIST (code) ? &code->loc : &code->next->loc);
-
- if (EMPTY_VAR_LIST (code))
- {
- /* Empty namelist means allocate directive applies to all
- variables in allocate statement. 'cur' points to associated
- allocate statement. */
- for (al = cur->ext.alloc.list; al != NULL; al = al->next)
- if (al->expr && al->expr->symtree && al->expr->symtree->n.sym)
- {
- check_allocate_directive_restrictions (al->expr->symtree->n.sym,
- omp_al, ns, code->loc);
- p = gfc_get_omp_namelist ();
- p->sym = al->expr->symtree->n.sym;
- p->expr = omp_al;
- p->where = code->loc;
- if (cn == NULL)
- cn = tail = p;
- else
- {
- tail->next = p;
- tail = tail->next;
- }
- }
- clauses->lists[OMP_LIST_ALLOCATOR]= cn;
- }
- else
- {
- for (n = cn; n != NULL; n = n->next)
- {
- for (al = cur->ext.alloc.list; al != NULL; al = al->next)
- if (al->expr && al->expr->symtree && al->expr->symtree->n.sym
- && al->expr->symtree->n.sym == n->sym)
- break;
- if (al == NULL)
- gfc_error ("%qs in %<allocate%> directive at %L is not present "
- "in associated %<allocate%> statement.",
- n->sym->name, &code->loc);
- check_allocate_directive_restrictions (n->sym, omp_al, ns,
- code->loc);
- }
- }
- prepare_omp_allocated_var_list_for_cleanup (cn, code->loc);
-}
-
-
void
gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
{
@@ -12518,6 +12713,8 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
case EXEC_OMP_TARGET:
resolve_omp_target (code);
gcc_fallthrough ();
+ case EXEC_OMP_ALLOCATE:
+ case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_CANCEL:
case EXEC_OMP_ERROR:
@@ -12578,9 +12775,6 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
case EXEC_OMP_METADIRECTIVE:
resolve_omp_metadirective (code, ns);
break;
- case EXEC_OMP_ALLOCATE:
- gfc_resolve_omp_allocate (code, ns);
- break;
default:
break;
}
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index c4d3e0f9097e..feff05aa8680 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -42,6 +42,7 @@ static jmp_buf eof_buf;
gfc_state_data *gfc_state_stack;
static bool last_was_use_stmt = false;
+bool in_exec_part;
bool gfc_matching_omp_context_selector;
bool gfc_in_metadirective_body;
@@ -752,6 +753,82 @@ decode_oacc_directive (void)
return ST_GET_FCN_CHARACTERISTICS;
}
+/* Checks for the ST_OMP_ALLOCATE. First, check whether all list items
+ are allocatables/pointers - and if so, assume it is associated with a Fortran
+ ALLOCATE stmt. If not, do some initial parsing-related checks and append
+ namelist to namespace.
+ The check follows OpenMP 5.1 by requiring an executable stmt or OpenMP
+ construct before a directive associated with an allocate statement
+ (-> ST_OMP_ALLOCATE_EXEC); instead of showing an error, conversion of
+ ST_OMP_ALLOCATE -> ST_OMP_ALLOCATE_EXEC would be an alternative. */
+
+bool
+check_omp_allocate_stmt (locus *loc)
+{
+ gfc_omp_namelist *n;
+
+ if (new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym == NULL)
+ {
+ gfc_error ("%qs directive at %L must either have a variable argument or, "
+ "if associated with an ALLOCATE stmt, must be preceded by an "
+ "executable statement or OpenMP construct",
+ gfc_ascii_statement (ST_OMP_ALLOCATE), loc);
+ return false;
+ }
+ bool has_allocatable = false;
+ bool has_non_allocatable = false;
+ for (n = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
+ {
+ if (n->expr)
+ {
+ gfc_error ("Structure-component expression at %L in %qs directive not"
+ " permitted in declarative directive; as directive "
+ "associated with an ALLOCATE stmt it must be preceded by "
+ "an executable statement or OpenMP construct",
+ &n->expr->where, gfc_ascii_statement (ST_OMP_ALLOCATE));
+ return false;
+ }
+ bool alloc_ptr;
+ if (n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok)
+ alloc_ptr = (CLASS_DATA (n->sym)->attr.allocatable
+ || CLASS_DATA (n->sym)->attr.class_pointer);
+ else
+ alloc_ptr = (n->sym->attr.allocatable || n->sym->attr.pointer
+ || n->sym->attr.proc_pointer);
+ if (alloc_ptr
+ || (n->sym->ns && n->sym->ns->proc_name
+ && (n->sym->ns->proc_name->attr.allocatable
+ || n->sym->ns->proc_name->attr.pointer
+ || n->sym->ns->proc_name->attr.proc_pointer)))
+ has_allocatable = true;
+ else
+ has_non_allocatable = true;
+ }
+ /* All allocatables - assume it is allocated with an ALLOCATE stmt. */
+ if (has_allocatable && !has_non_allocatable)
+ {
+ gfc_error ("%qs directive at %L associated with an ALLOCATE stmt must be "
+ "preceded by an executable statement or OpenMP construct; "
+ "note the variables in the list all have the allocatable or "
+ "pointer attribute", gfc_ascii_statement (ST_OMP_ALLOCATE),
+ loc);
+ return false;
+ }
+ if (!gfc_current_ns->omp_allocate)
+ gfc_current_ns->omp_allocate
+ = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
+ else
+ {
+ for (n = gfc_current_ns->omp_allocate; n->next; n = n->next)
+ ;
+ n->next = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
+ }
+ new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = NULL;
+ gfc_free_omp_clauses (new_st.ext.omp_clauses);
+ return true;
+}
+
+
/* Like match, but set a flag simd_matched if keyword matched
and if spec_only, goto do_spec_only without actually matching. */
#define matchs(keyword, subr, st) \
@@ -865,6 +942,11 @@ decode_omp_directive (void)
switch (c)
{
case 'a':
+ if (in_exec_part)
+ matcho ("allocate", gfc_match_omp_allocate, ST_OMP_ALLOCATE_EXEC);
+ else
+ matcho ("allocate", gfc_match_omp_allocate, ST_OMP_ALLOCATE);
+ matcho ("allocators", gfc_match_omp_allocators, ST_OMP_ALLOCATORS);
/* For -fopenmp-simd, ignore 'assumes'; note no clause starts with 's'. */
if (!flag_openmp && gfc_match ("assumes") == MATCH_YES)
break;
@@ -887,6 +969,7 @@ decode_omp_directive (void)
break;
case 'e':
matchs ("end assume", gfc_match_omp_eos_error, ST_OMP_END_ASSUME);
+ matcho ("end allocators", gfc_match_omp_eos_error, ST_OMP_END_ALLOCATORS);
matcho ("end metadirective", gfc_match_omp_eos_error,
ST_OMP_END_METADIRECTIVE);
matchs ("end simd", gfc_match_omp_eos_error, ST_OMP_END_SIMD);
@@ -927,7 +1010,6 @@ decode_omp_directive (void)
{
case 'a':
matcho ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
- matcho ("allocate", gfc_match_omp_allocate, ST_OMP_ALLOCATE);
break;
case 'b':
matcho ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
@@ -1228,6 +1310,9 @@ decode_omp_directive (void)
return ST_NONE;
}
}
+ if (ret == ST_OMP_ALLOCATE && !check_omp_allocate_stmt (&old_locus))
+ goto error_handling;
+
switch (ret)
{
/* Set omp_target_seen; exclude ST_OMP_DECLARE_TARGET.
@@ -1769,9 +1854,9 @@ next_statement (void)
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_ERROR: \
- case ST_OMP_ALLOCATE: 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_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_END_TEAM: case ST_SYNC_TEAM: \
case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \
case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
@@ -1811,7 +1896,7 @@ next_statement (void)
case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \
case ST_OMP_LOOP: case ST_OMP_PARALLEL_LOOP: case ST_OMP_TEAMS_LOOP: \
case ST_OMP_TARGET_PARALLEL_LOOP: case ST_OMP_TARGET_TEAMS_LOOP: \
- case ST_OMP_ASSUME: \
+ case ST_OMP_ALLOCATE_EXEC: case ST_OMP_ALLOCATORS: case ST_OMP_ASSUME: \
case ST_OMP_UNROLL: \
case ST_OMP_TILE: \
case ST_CRITICAL: \
@@ -1832,8 +1917,8 @@ next_statement (void)
#define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_MAPPER: \
case ST_OMP_DECLARE_REDUCTION: case ST_OMP_DECLARE_VARIANT: \
- case ST_OMP_ASSUMES: case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: \
- case ST_OACC_DECLARE
+ case ST_OMP_ALLOCATE: case ST_OMP_ASSUMES: case ST_OMP_REQUIRES: \
+ case ST_OACC_ROUTINE: case ST_OACC_DECLARE
/* OpenMP statements that are followed by a structured block. */
@@ -2494,15 +2579,19 @@ gfc_ascii_statement (gfc_statement st, bool strip_sentinel)
case ST_OACC_END_ATOMIC:
p = "!$ACC END ATOMIC";
break;
+ case ST_OMP_ALLOCATE:
+ case ST_OMP_ALLOCATE_EXEC:
+ p = "!$OMP ALLOCATE";
+ break;
+ case ST_OMP_ALLOCATORS:
+ p = "!$OMP ALLOCATORS";
+ break;
case ST_OMP_ASSUME:
p = "!$OMP ASSUME";
break;
case ST_OMP_ASSUMES:
p = "!$OMP ASSUMES";
break;
- case ST_OMP_ALLOCATE:
- p = "!$OMP ALLOCATE";
- break;
case ST_OMP_ATOMIC:
p = "!$OMP ATOMIC";
break;
@@ -2557,6 +2646,9 @@ gfc_ascii_statement (gfc_statement st, bool strip_sentinel)
case ST_OMP_DO_SIMD:
p = "!$OMP DO SIMD";
break;
+ case ST_OMP_END_ALLOCATORS:
+ p = "!$OMP END ALLOCATORS";
+ break;
case ST_OMP_END_ASSUME:
p = "!$OMP END ASSUME";
break;
@@ -3138,6 +3230,7 @@ verify_st_order (st_state *p, gfc_statement st, bool silent)
{
case ST_NONE:
p->state = ORDER_START;
+ in_exec_part = false;
break;
case ST_USE:
@@ -3211,6 +3304,7 @@ verify_st_order (st_state *p, gfc_statement st, bool silent)
case_exec_markers:
if (p->state < ORDER_EXEC)
p->state = ORDER_EXEC;
+ in_exec_part = true;
break;
default:
@@ -5777,6 +5871,77 @@ parse_oacc_loop (gfc_statement acc_st)
}
+/* Parse an OpenMP allocate block, including optional ALLOCATORS
+ end directive. */
+
+static gfc_statement
+parse_openmp_allocate_block (gfc_statement omp_st)
+{
+ gfc_statement st;
+ gfc_code *cp, *np;
+ gfc_state_data s;
+ bool empty_list = false;
+ locus empty_list_loc;
+ gfc_omp_namelist *n_first = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
+
+ if (omp_st == ST_OMP_ALLOCATE_EXEC
+ && new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym == NULL)
+ {
+ empty_list = true;
+ empty_list_loc = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->where;
+ }
+
+ accept_statement (omp_st);
+
+ cp = gfc_state_stack->tail;
+ push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
+ np = new_level (cp);
+ np->op = cp->op;
+ np->block = NULL;
+
+ st = next_statement ();
+ while (omp_st == ST_OMP_ALLOCATE_EXEC && st == ST_OMP_ALLOCATE_EXEC)
+ {
+ if (empty_list && !new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym)
+ {
+ locus *loc = &new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->where;
+ gfc_error_now ("%s statements at %L and %L have both no list item but"
+ " only one may", gfc_ascii_statement (st),
+ &empty_list_loc, loc);
+ empty_list = false;
+ }
+ if (!new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym)
+ {
+ empty_list = true;
+ empty_list_loc = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->where;
+ }
+ for ( ; n_first->next; n_first = n_first->next)
+ ;
+ n_first->next = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
+ new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = NULL;
+ gfc_free_omp_clauses (new_st.ext.omp_clauses);
+
+ accept_statement (ST_NONE);
+ st = next_statement ();
+ }
+ if (st != ST_ALLOCATE && omp_st == ST_OMP_ALLOCATE_EXEC)
+ gfc_error_now ("Unexpected %s at %C; expected ALLOCATE or %s statement",
+ gfc_ascii_statement (st), gfc_ascii_statement (omp_st));
+ else if (st != ST_ALLOCATE)
+ gfc_error_now ("Unexpected %s at %C; expected ALLOCATE statement after %s",
+ gfc_ascii_statement (st), gfc_ascii_statement (omp_st));
+ accept_statement (st);
+ pop_state ();
+ st = next_statement ();
+ if (omp_st == ST_OMP_ALLOCATORS && st == ST_OMP_END_ALLOCATORS)
+ {
+ accept_statement (st);
+ st = next_statement ();
+ }
+ return st;
+}
+
+
/* Parse the statements of an OpenMP structured block. */
static gfc_statement
@@ -5898,6 +6063,11 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
parse_forall_block ();
break;
+ case ST_OMP_ALLOCATE_EXEC:
+ case ST_OMP_ALLOCATORS:
+ st = parse_openmp_allocate_block (st);
+ continue;
+
case ST_OMP_ASSUME:
case ST_OMP_PARALLEL:
case ST_OMP_PARALLEL_MASKED:
@@ -6114,6 +6284,7 @@ parse_executable (gfc_statement st)
{
int close_flag;
bool one_stmt_p = false;
+ in_exec_part = true;
if (st == ST_NONE)
st = next_statement ();
@@ -6230,6 +6401,11 @@ parse_executable (gfc_statement st)
parse_oacc_structured_block (st);
break;
+ case ST_OMP_ALLOCATE_EXEC:
+ case ST_OMP_ALLOCATORS:
+ st = parse_openmp_allocate_block (st);
+ continue;
+
case_omp_structured_block:
st = parse_omp_structured_block (st,
st == ST_OMP_WORKSHARE
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 9a19c19356a2..1129cb0ceb27 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -11040,6 +11040,8 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
case EXEC_OACC_ENTER_DATA:
case EXEC_OACC_EXIT_DATA:
case EXEC_OACC_ROUTINE:
+ case EXEC_OMP_ALLOCATE:
+ case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_DISTRIBUTE:
@@ -12713,6 +12715,7 @@ start:
break;
case EXEC_OMP_ALLOCATE:
+ case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
@@ -18031,6 +18034,8 @@ resolve_codes (gfc_namespace *ns)
gfc_resolve_oacc_declare (ns);
gfc_resolve_oacc_routines (ns);
gfc_resolve_omp_local_vars (ns);
+ if (ns->omp_allocate)
+ gfc_resolve_omp_allocate (ns, ns->omp_allocate);
gfc_resolve_code (ns->code, ns);
bitmap_obstack_release (&labels_obstack);
diff --git a/gcc/fortran/st.cc b/gcc/fortran/st.cc
index ebe588b9b91a..5017f4fbfabf 100644
--- a/gcc/fortran/st.cc
+++ b/gcc/fortran/st.cc
@@ -215,6 +215,7 @@ gfc_free_statement (gfc_code *p)
case EXEC_OACC_EXIT_DATA:
case EXEC_OACC_ROUTINE:
case EXEC_OMP_ALLOCATE:
+ case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_CANCEL:
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index a407524c6bbb..a12639529554 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -4654,7 +4654,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gfc_clear_new_st ();
new_st.op = EXEC_OMP_ALLOCATE;
gfc_omp_clauses *c = gfc_get_omp_clauses ();
- c->lists[OMP_LIST_ALLOCATOR] = proc_sym->omp_allocated;
+ c->lists[OMP_LIST_ALLOCATE] = proc_sym->omp_allocated;
new_st.ext.omp_clauses = c;
/* This is just a hacky way to convey to handler that we are
dealing with cleanup here. Saves us from using another field
diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index 199c71922606..c2e036e4a1e6 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -4719,17 +4719,24 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
tree node = build_omp_clause (input_location,
OMP_CLAUSE_ALLOCATE);
OMP_CLAUSE_DECL (node) = t;
- if (n->expr)
+ if (n->u2.allocator)
{
tree allocator_;
- if (n->expr->expr_type == EXPR_VARIABLE)
- allocator_
- = gfc_trans_omp_variable (n->expr->symtree->n.sym,
- false);
+ if (n->u2.allocator->expr_type == EXPR_VARIABLE)
+ {
+ allocator_
+ = gfc_trans_omp_variable (n->u2.allocator->symtree->n.sym,
+ false);
+ if (POINTER_TYPE_P (TREE_TYPE (allocator_)))
+ {
+ allocator_ = build_fold_indirect_ref (allocator_);
+ allocator_ = gfc_evaluate_now (allocator_, block);
+ }
+ }
else
{
gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, n->expr);
+ gfc_conv_expr (&se, n->u2.allocator);
allocator_ = gfc_evaluate_now (se.expr, block);
}
OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) = allocator_;
@@ -4746,28 +4753,6 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
}
}
break;
- case OMP_LIST_ALLOCATOR:
- for (; n != NULL; n = n->next)
- if (n->sym->attr.referenced)
- {
- tree t = gfc_trans_omp_variable (n->sym, false);
- if (t != error_mark_node)
- {
- tree node = build_omp_clause (input_location,
- OMP_CLAUSE_ALLOCATOR);
- OMP_ALLOCATE_DECL (node) = t;
- if (n->expr)
- {
- tree allocator_;
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, n->expr);
- allocator_ = gfc_evaluate_now (se.expr, block);
- OMP_ALLOCATE_ALLOCATOR (node) = allocator_;
- }
- omp_clauses = gfc_trans_add_clause (node, omp_clauses);
- }
- }
- break;
case OMP_LIST_LINEAR:
{
gfc_expr *last_step_expr = NULL;
@@ -7818,7 +7803,7 @@ gfc_trans_omp_atomic (gfc_code *code)
}
static tree
-gfc_trans_omp_allocate (gfc_code *code)
+gfc_trans_omp_allocators (gfc_code *code)
{
stmtblock_t block;
tree stmt;
@@ -7836,7 +7821,11 @@ gfc_trans_omp_allocate (gfc_code *code)
&& code->resolved_sym != NULL)
OMP_ALLOCATE_KIND_FREE (stmt) = 1;
else
- OMP_ALLOCATE_KIND_ALLOCATE (stmt) = 1;
+ {
+ OMP_ALLOCATE_KIND_ALLOCATE (stmt) = 1;
+ gfc_add_expr_to_block (&block, stmt);
+ stmt = gfc_trans_allocate (code->block->next);
+ }
gfc_add_expr_to_block (&block, stmt);
gfc_merge_block_scope (&block);
@@ -9590,6 +9579,8 @@ gfc_split_omp_clauses (gfc_code *code,
p = gfc_get_omp_namelist ();
p->sym = alloc_nl->sym;
p->expr = alloc_nl->expr;
+ p->u.align = alloc_nl->u.align;
+ p->u2.allocator = alloc_nl->u2.allocator;
p->where = alloc_nl->where;
if (clausesa[i].lists[OMP_LIST_ALLOCATE] == NULL)
{
@@ -10849,7 +10840,8 @@ gfc_trans_omp_directive (gfc_code *code)
switch (code->op)
{
case EXEC_OMP_ALLOCATE:
- return gfc_trans_omp_allocate (code);
+ case EXEC_OMP_ALLOCATORS:
+ return gfc_trans_omp_allocators (code);
case EXEC_OMP_ASSUME:
return gfc_trans_omp_assume (code);
case EXEC_OMP_ATOMIC:
diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index 9bec7ae6d425..146888ec803a 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -2454,7 +2454,8 @@ trans_code (gfc_code * code, tree cond)
break;
case EXEC_OMP_ALLOCATE:
- case EXEC_OMP_ASSUME:
+ case EXEC_OMP_ALLOCATORS:
+ case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
case EXEC_OMP_CANCEL:
diff --git a/gcc/omp-low.cc b/gcc/omp-low.cc
index fd0ea3dccc3c..77142589f273 100644
--- a/gcc/omp-low.cc
+++ b/gcc/omp-low.cc
@@ -60,6 +60,7 @@ along with GCC; see the file COPYING3. If not see
#include "stringpool.h"
#include "attribs.h"
#include "omp-offload.h"
+#include "intl.h"
/* Lowering of OMP parallel and workshare constructs proceeds in two
phases. The first phase scans the function looking for OMP statements
@@ -1468,8 +1469,11 @@ scan_sharing_clauses (tree clauses, omp_context *ctx,
if (OMP_CLAUSE_ALLOCATE_ALLOCATOR (c) == NULL_TREE
&& ((omp_requires_mask & OMP_REQUIRES_DYNAMIC_ALLOCATORS) == 0)
&& omp_maybe_offloaded_ctx (ctx))
- error_at (OMP_CLAUSE_LOCATION (c), "%<allocate%> clause must"
- " specify an allocator here");
+ error_at (OMP_CLAUSE_LOCATION (c),
+ gimple_code (ctx->stmt) == GIMPLE_OMP_ALLOCATE
+ ? G_("%<allocate%> directive must specify an allocator "
+ "here")
+ : G_("%<allocate%> clause must specify an allocator here"));
if (ctx->allocate_map == NULL)
ctx->allocate_map = new hash_map<tree, tree>;
tree val = integer_zero_node;
@@ -2168,7 +2172,6 @@ scan_sharing_clauses (tree clauses, omp_context *ctx,
case OMP_CLAUSE_FINALIZE:
case OMP_CLAUSE_TASK_REDUCTION:
case OMP_CLAUSE_ALLOCATE:
- case OMP_CLAUSE_ALLOCATOR:
case OMP_CLAUSE__OMPACC_:
break;
@@ -2398,7 +2401,6 @@ scan_sharing_clauses (tree clauses, omp_context *ctx,
case OMP_CLAUSE_FINALIZE:
case OMP_CLAUSE_FILTER:
case OMP_CLAUSE__CONDTEMP_:
- case OMP_CLAUSE_ALLOCATOR:
case OMP_CLAUSE__OMPACC_:
break;
@@ -9457,31 +9459,20 @@ lower_omp_single_simple (gomp_single *single_stmt, gimple_seq *pre_p)
}
static void
-lower_omp_allocate (gimple_stmt_iterator *gsi_p, omp_context *ctx)
+lower_omp_allocate (gimple_stmt_iterator *gsi_p)
{
gomp_allocate *st = as_a <gomp_allocate *> (gsi_stmt (*gsi_p));
tree clauses = gimple_omp_allocate_clauses (st);
int kind = gimple_omp_allocate_kind (st);
gcc_assert (kind == GF_OMP_ALLOCATE_KIND_ALLOCATE
|| kind == GF_OMP_ALLOCATE_KIND_FREE);
-
for (tree c = clauses; c; c = OMP_CLAUSE_CHAIN (c))
{
- if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_ALLOCATOR)
+ if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_ALLOCATE)
continue;
bool allocate = (kind == GF_OMP_ALLOCATE_KIND_ALLOCATE);
- /* The allocate directives that appear in a target region must specify
- an allocator clause unless a requires directive with the
- dynamic_allocators clause is present in the same compilation unit. */
- if (OMP_ALLOCATE_ALLOCATOR (c) == NULL_TREE
- && ((omp_requires_mask & OMP_REQUIRES_DYNAMIC_ALLOCATORS) == 0)
- && omp_maybe_offloaded_ctx (ctx))
- error_at (OMP_CLAUSE_LOCATION (c), "%<allocate%> directive must"
- " specify an allocator here");
-
- tree var = OMP_ALLOCATE_DECL (c);
-
+ tree var = OMP_CLAUSE_DECL (c);
gimple_stmt_iterator gsi = *gsi_p;
for (gsi_next (&gsi); !gsi_end_p (gsi); gsi_next (&gsi))
{
@@ -9493,10 +9484,11 @@ lower_omp_allocate (gimple_stmt_iterator *gsi_p, omp_context *ctx)
|| (!allocate && gimple_call_fndecl (stmt)
!= builtin_decl_explicit (BUILT_IN_FREE)))
continue;
+
const gcall *gs = as_a <const gcall *> (stmt);
- tree allocator = OMP_ALLOCATE_ALLOCATOR (c)
- ? OMP_ALLOCATE_ALLOCATOR (c)
- : integer_zero_node;
+ tree allocator = OMP_CLAUSE_ALLOCATE_ALLOCATOR (c)
+ ? OMP_CLAUSE_ALLOCATE_ALLOCATOR (c)
+ : build_zero_cst (ptr_type_node);
if (allocate)
{
tree lhs = gimple_call_lhs (gs);
@@ -9518,12 +9510,17 @@ lower_omp_allocate (gimple_stmt_iterator *gsi_p, omp_context *ctx)
if (lhs == var)
{
unsigned HOST_WIDE_INT ialign = 0;
- tree align;
+ tree align = OMP_CLAUSE_ALLOCATE_ALIGN (c);
if (TYPE_P (var))
ialign = TYPE_ALIGN_UNIT (var);
else
ialign = DECL_ALIGN_UNIT (var);
- align = build_int_cst (size_type_node, ialign);
+ if (align == NULL_TREE)
+ align = build_int_cst (size_type_node, ialign);
+ else
+ align = build_int_cst (size_type_node,
+ MAX (tree_to_uhwi (align),
+ ialign));
tree repl = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC);
tree size = gimple_call_arg (gs, 0);
gimple *g = gimple_build_call (repl, 3, align, size,
@@ -16135,7 +16132,7 @@ lower_omp_1 (gimple_stmt_iterator *gsi_p, omp_context *ctx)
case GIMPLE_OMP_ALLOCATE:
ctx = maybe_lookup_ctx (stmt);
gcc_assert (ctx);
- lower_omp_allocate (gsi_p, ctx);
+ lower_omp_allocate (gsi_p);
break;
case GIMPLE_OMP_SINGLE:
ctx = maybe_lookup_ctx (stmt);
diff --git a/gcc/testsuite/ChangeLog.omp b/gcc/testsuite/ChangeLog.omp
index e9f4d1c63e65..2d862b92797f 100644
--- a/gcc/testsuite/ChangeLog.omp
+++ b/gcc/testsuite/ChangeLog.omp
@@ -1,3 +1,18 @@
+2023-10-26 Tobias Burnus <tobias@codesourcery.com>
+ Chung-Lin Tang <cltang@codesourcery.com>
+
+ * gfortran.dg/gomp/allocate-2.f90: Update dg-warning.
+ * gfortran.dg/gomp/allocate-4.f90: New upstream test.
+ * gfortran.dg/gomp/allocate-5.f90: New upstream test.
+ * gfortran.dg/gomp/allocate-6.f90: New upstream test.
+ * gfortran.dg/gomp/allocate-7.f90: New upstream test.
+ * gfortran.dg/gomp/allocate-4a.f90: Renamed from allocate-4.f90
+ * gfortran.dg/gomp/allocate-6a.f90: Renamed from allocate-6.f90
+ * gfortran.dg/gomp/allocate-7a.f90: Renamed from allocate-7.f90
+ * gfortran.dg/gomp/allocate-9a.f90: New test.
+ * gfortran.dg/gomp/allocators-1.f90: New upstream test.
+ * gfortran.dg/gomp/allocators-2.f90: New upstream test.
+
2023-09-20 Tobias Burnus <tobias@codesourcery.com>
Backported from master:
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-2.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-2.f90
index 657ff44d0236..cc83b5edbce6 100644
--- a/gcc/testsuite/gfortran.dg/gomp/allocate-2.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-2.f90
@@ -25,11 +25,11 @@ subroutine foo(x)
x=3
!$omp end parallel
- !$omp parallel private (x) allocate (x) allocate (x) ! { dg-warning "'x' appears more than once in 'allocate' clauses at .1." }
+ !$omp parallel private (x) allocate (x) allocate (x) ! { dg-warning "'x' appears more than once in 'allocate' at .1." }
x=4
!$omp end parallel
- !$omp parallel private (x) allocate (x, x) ! { dg-warning "'x' appears more than once in 'allocate' clauses at .1." }
+ !$omp parallel private (x) allocate (x, x) ! { dg-warning "'x' appears more than once in 'allocate' at .1." }
x=5
!$omp end parallel
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90
new file mode 100644
index 000000000000..a2dcf105ee17
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90
@@ -0,0 +1,54 @@
+module my_omp_lib
+ use iso_c_binding, only: c_intptr_t
+ !use omp_lib
+ implicit none
+ integer, parameter :: omp_allocator_handle_kind = c_intptr_t
+
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_null_allocator = 0
+
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_default_mem_alloc = 1
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_large_cap_mem_alloc = 2
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_const_mem_alloc = 3
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_high_bw_mem_alloc = 4
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_low_lat_mem_alloc = 5
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_cgroup_mem_alloc = 6
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_pteam_mem_alloc = 7
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_thread_mem_alloc = 8
+end module my_omp_lib
+
+subroutine one(n, my_alloc)
+ use my_omp_lib
+ implicit none
+integer :: n
+integer(kind=omp_allocator_handle_kind), intent(in) :: my_alloc
+
+!stack variables:
+integer :: a,b,c(n),d(5),e(2)
+!$omp allocate(a) ! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" }
+!$omp allocate ( b , c ) align ( 32) allocator (my_alloc)
+!$omp allocate (d) align( 128 )
+!$omp allocate( e ) allocator( omp_high_bw_mem_alloc )
+
+!saved vars
+integer, save :: k,l,m(5),r(2)
+!$omp allocate(k) align(16) , allocator (omp_large_cap_mem_alloc)
+!$omp allocate ( l ) allocator (omp_large_cap_mem_alloc) , align ( 32)
+!$omp allocate (m) align( 128 ),allocator( omp_high_bw_mem_alloc )
+!$omp allocate( r ) allocator( omp_high_bw_mem_alloc )
+
+!common /block/
+integer :: q,x,y(2),z(5)
+common /com1/ q,x
+common /com2/ y,z
+!$omp allocate ( / com1/) align( 128 ) allocator( omp_high_bw_mem_alloc )
+!$omp allocate(/com2 / ) allocator( omp_high_bw_mem_alloc )
+end
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-4a.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-4a.f90
new file mode 100644
index 000000000000..a2dcf105ee17
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-4a.f90
@@ -0,0 +1,54 @@
+module my_omp_lib
+ use iso_c_binding, only: c_intptr_t
+ !use omp_lib
+ implicit none
+ integer, parameter :: omp_allocator_handle_kind = c_intptr_t
+
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_null_allocator = 0
+
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_default_mem_alloc = 1
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_large_cap_mem_alloc = 2
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_const_mem_alloc = 3
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_high_bw_mem_alloc = 4
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_low_lat_mem_alloc = 5
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_cgroup_mem_alloc = 6
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_pteam_mem_alloc = 7
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_thread_mem_alloc = 8
+end module my_omp_lib
+
+subroutine one(n, my_alloc)
+ use my_omp_lib
+ implicit none
+integer :: n
+integer(kind=omp_allocator_handle_kind), intent(in) :: my_alloc
+
+!stack variables:
+integer :: a,b,c(n),d(5),e(2)
+!$omp allocate(a) ! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" }
+!$omp allocate ( b , c ) align ( 32) allocator (my_alloc)
+!$omp allocate (d) align( 128 )
+!$omp allocate( e ) allocator( omp_high_bw_mem_alloc )
+
+!saved vars
+integer, save :: k,l,m(5),r(2)
+!$omp allocate(k) align(16) , allocator (omp_large_cap_mem_alloc)
+!$omp allocate ( l ) allocator (omp_large_cap_mem_alloc) , align ( 32)
+!$omp allocate (m) align( 128 ),allocator( omp_high_bw_mem_alloc )
+!$omp allocate( r ) allocator( omp_high_bw_mem_alloc )
+
+!common /block/
+integer :: q,x,y(2),z(5)
+common /com1/ q,x
+common /com2/ y,z
+!$omp allocate ( / com1/) align( 128 ) allocator( omp_high_bw_mem_alloc )
+!$omp allocate(/com2 / ) allocator( omp_high_bw_mem_alloc )
+end
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-5.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-5.f90
index 761b6dede28a..33805ec12d48 100644
--- a/gcc/testsuite/gfortran.dg/gomp/allocate-5.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-5.f90
@@ -1,73 +1,99 @@
-! { dg-do compile }
-
-module omp_lib_kinds
- use iso_c_binding, only: c_int, c_intptr_t
+module my_omp_lib
+ use iso_c_binding, only: c_intptr_t
+ !use omp_lib
implicit none
- private :: c_int, c_intptr_t
- integer, parameter :: omp_allocator_handle_kind = c_intptr_t
+ integer, parameter :: omp_allocator_handle_kind = c_intptr_t
- integer (kind=omp_allocator_handle_kind), &
- parameter :: omp_null_allocator = 0
- integer (kind=omp_allocator_handle_kind), &
- parameter :: omp_default_mem_alloc = 1
- integer (kind=omp_allocator_handle_kind), &
- parameter :: omp_large_cap_mem_alloc = 2
- integer (kind=omp_allocator_handle_kind), &
- parameter :: omp_const_mem_alloc = 3
- integer (kind=omp_allocator_handle_kind), &
- parameter :: omp_high_bw_mem_alloc = 4
- integer (kind=omp_allocator_handle_kind), &
- parameter :: omp_low_lat_mem_alloc = 5
- integer (kind=omp_allocator_handle_kind), &
- parameter :: omp_cgroup_mem_alloc = 6
- integer (kind=omp_allocator_handle_kind), &
- parameter :: omp_pteam_mem_alloc = 7
- integer (kind=omp_allocator_handle_kind), &
- parameter :: omp_thread_mem_alloc = 8
-end module
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_null_allocator = 0
-subroutine foo(x, y)
- use omp_lib_kinds
- implicit none
- integer :: x
- integer :: y
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_default_mem_alloc = 1
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_large_cap_mem_alloc = 2
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_const_mem_alloc = 3
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_high_bw_mem_alloc = 4
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_low_lat_mem_alloc = 5
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_cgroup_mem_alloc = 6
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_pteam_mem_alloc = 7
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_thread_mem_alloc = 8
+ type t
+ integer :: a
+ end type t
+end module my_omp_lib
- integer, allocatable :: var1(:)
- integer, allocatable :: var2(:)
- integer, allocatable :: var3(:)
- integer, allocatable :: var4(:,:)
- integer, allocatable :: var5(:)
- integer, allocatable :: var6(:)
- integer, allocatable :: var7(:)
- integer, allocatable :: var8(:)
- integer, allocatable :: var9(:)
- integer, allocatable :: var10(:)
- integer, allocatable :: var11(:)
- integer, allocatable :: var12(:)
+subroutine zero()
+ !$omp assumes absent (allocators)
- !$omp allocate (var1) allocator(omp_default_mem_alloc)
- allocate (var1(x))
-
- !$omp allocate (var2)
- allocate (var2(x))
+ !$omp assume absent (allocators)
+ !$omp end assume
+end
- !$omp allocate (var3, var4) allocator(omp_large_cap_mem_alloc)
- allocate (var3(x),var4(x,y))
+subroutine two(c,x2,y2)
+ use my_omp_lib
+ implicit none
+ integer, allocatable :: a, b(:), c(:,:)
+ type(t), allocatable :: x1
+ type(t), pointer :: x2(:)
+ class(t), allocatable :: y1
+ class(t), pointer :: y2(:)
- !$omp allocate()
- allocate (var5(x))
+ !$omp flush ! some executable statement
+ !$omp allocate(a)
+ allocate(a)
+ deallocate(a)
- !$omp allocate
- allocate (var6(x))
+ !$omp allocate(x1,y1,x2,y2)
+ allocate(x1,y1,x2(5),y2(5))
+ deallocate(x1,y1,x2,y2)
- !$omp allocate () allocator(omp_default_mem_alloc)
- allocate (var7(x))
+ !$omp allocate(b,a) align ( 128 )
+ !$omp allocate align ( 64 )
+ allocate(a,b(4),c(3,4))
+ deallocate(a,b,c)
+end
- !$omp allocate allocator(omp_default_mem_alloc)
- allocate (var8(x))
+subroutine three(c)
+ use my_omp_lib
+ implicit none
+ integer :: q
+ integer, allocatable :: a, b(:), c(:,:)
- !$omp allocate (var9) allocator(omp_default_mem_alloc)
- !$omp allocate (var10) allocator(omp_large_cap_mem_alloc)
- allocate (var9(x), var10(x))
+ call foo() ! executable stmt
+ !$omp allocate allocator( omp_large_cap_mem_alloc ) , align(64)
+ !$omp allocate(b) allocator( omp_high_bw_mem_alloc )
+ !$omp allocate(c) allocator( omp_high_bw_mem_alloc )
+ allocate(a,b(4),c(3,4))
+ deallocate(a,b,c)
-end subroutine
+ block
+ q = 5 ! executable stmt
+ !$omp allocate(a) align(64)
+ !$omp allocate(b) allocator( omp_high_bw_mem_alloc ), align(32)
+ !$omp allocate(c) allocator( omp_thread_mem_alloc )
+ ! { dg-error "Sorry, allocation of allocatable 'a' with '!.omp allocators' or '!.omp allocate' at .1. is only suppored in the scope where it has been declared, unless it has the SAVE attribute" "" { target *-*-* } .-3 }
+ ! { dg-error "Sorry, allocation of allocatable 'b' with '!.omp allocators' or '!.omp allocate' at .1. is only suppored in the scope where it has been declared, unless it has the SAVE attribute" "" { target *-*-* } .-4 }
+ ! { dg-error "Sorry, allocation of allocatable 'c' with '!.omp allocators' or '!.omp allocate' at .1. is only suppored in the scope where it has been declared, unless it has the SAVE attribute" "" { target *-*-* } .-5 }
+ allocate(a,b(4),c(3,4))
+ deallocate(a,b,c)
+ end block
+ call inner
+contains
+ subroutine inner
+ call foo() ! executable stmt
+ !$omp allocate(a) align(64)
+ !$omp allocate(b) allocator( omp_high_bw_mem_alloc ), align(32)
+ !$omp allocate(c) allocator( omp_thread_mem_alloc )
+ ! { dg-error "Sorry, allocation of allocatable 'a' with '!.omp allocators' or '!.omp allocate' at .1. is only suppored in the scope where it has been declared, unless it has the SAVE attribute" "" { target *-*-* } .-3 }
+ ! { dg-error "Sorry, allocation of allocatable 'b' with '!.omp allocators' or '!.omp allocate' at .1. is only suppored in the scope where it has been declared, unless it has the SAVE attribute" "" { target *-*-* } .-4 }
+ ! { dg-error "Sorry, allocation of allocatable 'c' with '!.omp allocators' or '!.omp allocate' at .1. is only suppored in the scope where it has been declared, unless it has the SAVE attribute" "" { target *-*-* } .-5 }
+ allocate(a,b(4),c(3,4))
+ deallocate(a,b,c)
+ end subroutine inner
+end
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-6.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-6.f90
index 738d9936f6ab..73e5bbcf71b0 100644
--- a/gcc/testsuite/gfortran.dg/gomp/allocate-6.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-6.f90
@@ -1,84 +1,103 @@
-! { dg-do compile }
-! { dg-additional-options "-fdump-tree-original -fdump-tree-gimple" }
-! { dg-additional-options "-fdump-tree-omplower" }
+module my_omp_lib
+ use iso_c_binding, only: c_intptr_t
+ !use omp_lib
+ implicit none
+ integer, parameter :: omp_allocator_handle_kind = c_intptr_t
+
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_null_allocator = 0
+
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_default_mem_alloc = 1
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_large_cap_mem_alloc = 2
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_const_mem_alloc = 3
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_high_bw_mem_alloc = 4
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_low_lat_mem_alloc = 5
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_cgroup_mem_alloc = 6
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_pteam_mem_alloc = 7
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_thread_mem_alloc = 8
+ type t
+ integer,allocatable :: a
+ integer,pointer :: b(:,:)
+ end type t
+end module my_omp_lib
+
+subroutine zero()
+ !$omp assumes absent (allocate) ! { dg-error "Invalid 'ALLOCATE' directive at .1. in ABSENT clause: declarative, informational and meta directives not permitted" }
+
+ !$omp assume absent (allocate) ! { dg-error "Invalid 'ALLOCATE' directive at .1. in ABSENT clause: declarative, informational and meta directives not permitted" }
+ !!$omp end assume
+end
-module omp_lib_kinds
- use iso_c_binding, only: c_int, c_intptr_t
+subroutine alloc(c,x2,y2)
+ use my_omp_lib
implicit none
- private :: c_int, c_intptr_t
- integer, parameter :: omp_allocator_handle_kind = c_intptr_t
-
- integer (kind=omp_allocator_handle_kind), &
- parameter :: omp_null_allocator = 0
- integer (kind=omp_allocator_handle_kind), &
- parameter :: omp_default_mem_alloc = 1
- integer (kind=omp_allocator_handle_kind), &
- parameter :: omp_large_cap_mem_alloc = 2
- integer (kind=omp_allocator_handle_kind), &
- parameter :: omp_const_mem_alloc = 3
- integer (kind=omp_allocator_handle_kind), &
- parameter :: omp_high_bw_mem_alloc = 4
- integer (kind=omp_allocator_handle_kind), &
- parameter :: omp_low_lat_mem_alloc = 5
- integer (kind=omp_allocator_handle_kind), &
- parameter :: omp_cgroup_mem_alloc = 6
- integer (kind=omp_allocator_handle_kind), &
- parameter :: omp_pteam_mem_alloc = 7
- integer (kind=omp_allocator_handle_kind), &
- parameter :: omp_thread_mem_alloc = 8
-end module
-
-
-subroutine foo(x, y, al)
- use omp_lib_kinds
+ integer, allocatable :: a, b(:), c(:,:)
+ type(t) :: x1,x2
+ class(t) :: y1,y2
+ allocatable :: x1, y1
+
+ !$omp flush ! some executable statement
+
+ !$omp allocate(x2%a,x2%b,y2%a,y2%b) allocator(omp_pteam_mem_alloc) align(64) ! { dg-error "Sorry, structure-element list item at .1. in ALLOCATE directive is not yet supported" }
+ allocate(x2%a,x2%b(3,4),y2%a,y2%b(3,4))
+
+ !$omp allocate(b(3)) align ( 64 ) ! { dg-error "Unexpected expression as list item at .1. in ALLOCATE directive" }
+ allocate(b(3))
+end
+
+subroutine one(n, my_alloc)
+ use my_omp_lib
implicit none
-
-type :: my_type
- integer :: i
- integer :: j
- real :: x
-end type
-
- integer :: x
- integer :: y
- integer (kind=omp_allocator_handle_kind) :: al
-
- integer, allocatable :: var1
- integer, allocatable :: var2
- real, allocatable :: var3(:,:)
- type (my_type), allocatable :: var4
- integer, pointer :: pii, parr(:)
- integer, allocatable :: var
-
- character, allocatable :: str1a, str1aarr(:)
- character(len=5), allocatable :: str5a, str5aarr(:)
-
- !$omp allocate
- allocate(str1a, str1aarr(10), str5a, str5aarr(10))
+integer :: n
+integer(kind=omp_allocator_handle_kind), intent(in) :: my_alloc
+
+integer :: a,b,c(n),d(5),e(2)
+integer, save :: k,l,m(5),r(2)
+integer :: q,x,y(2),z(5)
+common /com1/ q,x
+common /com2/ y,z
+integer, allocatable :: alloc
+integer, pointer :: ptr
+
+!$omp allocate(q) ! { dg-error "'q' at .1. is part of the common block '/com1/' and may only be specificed implicitly via the named common block" }
+
+!$omp allocate(d(:)) ! { dg-error "Unexpected expression as list item at .1. in ALLOCATE directive" }
+!$omp allocate(a) align(4), align(4) ! { dg-error "Duplicated 'align' clause" }
+!$omp allocate( e ) allocator( omp_high_bw_mem_alloc ), align(32),allocator( omp_high_bw_mem_alloc ) ! { dg-error "Duplicated 'allocator' clause" }
- !$omp allocate (var1) allocator(omp_default_mem_alloc)
- !$omp allocate (var2) allocator(omp_large_cap_mem_alloc)
- allocate (var1, var2)
+!$omp allocate align(32) ! { dg-error "'!.OMP ALLOCATE' directive at .1. must either have a variable argument or, if associated with an ALLOCATE stmt, must be preceded by an executable statement or OpenMP construct" }
- !$omp allocate (var4) allocator(omp_low_lat_mem_alloc)
- allocate (var4)
- var4%i = 5
+!$omp allocate(alloc) align(128) ! { dg-error "'!.OMP ALLOCATE' directive at .1. associated with an ALLOCATE stmt must be preceded by an executable statement or OpenMP construct; note the variables in the list all have the allocatable or pointer attribute" }
+!$omp allocate(ptr) align(128) ! { dg-error "'!.OMP ALLOCATE' directive at .1. associated with an ALLOCATE stmt must be preceded by an executable statement or OpenMP construct; note the variables in the list all have the allocatable or pointer attribute" }
- !$omp allocate (var3) allocator(omp_low_lat_mem_alloc)
- allocate (var3(x,y))
+!$omp allocate(e) allocate(omp_thread_mem_alloc) ! { dg-error "Expected ALIGN or ALLOCATOR clause" }
+end
+
+subroutine two()
+ integer, allocatable :: a,b,c
+
+ call foo()
+ !$omp allocate(a)
+ a = 5 ! { dg-error "Unexpected assignment at .1.; expected ALLOCATE or !.OMP ALLOCATE statement" }
+
+ !$omp allocate ! { dg-error "!.OMP ALLOCATE statements at .1. and .2. have both no list item but only one may" }
+ !$omp allocate(b)
+ !$omp allocate ! { dg-error "!.OMP ALLOCATE statements at .1. and .2. have both no list item but only one may" }
+ allocate(a,b,c)
!$omp allocate
- allocate(pii, parr(5))
-
- ! allocate statement not associated with an allocate directive
- allocate(var)
-end subroutine
-
-! { dg-final { scan-tree-dump-times "#pragma omp allocate \\(kind=allocate\\)" 6 "original" } }
-! { dg-final { scan-tree-dump "#pragma omp allocate \\(kind=free\\)" "original" } }
-! { dg-final { scan-tree-dump-times "#pragma omp allocate \\(kind=allocate\\)" 6 "gimple" } }
-! { dg-final { scan-tree-dump "#pragma omp allocate \\(kind=free\\)" "gimple" } }
-! { dg-final { scan-tree-dump-times "builtin_malloc" 11 "original" } }
-! { dg-final { scan-tree-dump-times "builtin_free" 9 "original" } }
-! { dg-final { scan-tree-dump-times "GOMP_alloc" 10 "omplower" } }
-! { dg-final { scan-tree-dump-times "GOMP_free" 8 "omplower" } }
+ allocate(a,b,c) ! allocate is no block construct, hence:
+ !$omp end allocate ! { dg-error "Unclassifiable OpenMP directive" }
+
+ !$omp allocators allocate(align(64) : a, b)
+ !$omp allocators allocate(align(128) : c) ! { dg-error "Unexpected !.OMP ALLOCATORS at .1.; expected ALLOCATE statement after !.OMP ALLOCATORS" }
+ allocate(a,b,c)
+end
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-6a.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-6a.f90
new file mode 100644
index 000000000000..559c610ae51c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-6a.f90
@@ -0,0 +1,85 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-original -fdump-tree-gimple" }
+! { dg-additional-options "-fdump-tree-omplower" }
+
+module omp_lib_kinds
+ use iso_c_binding, only: c_int, c_intptr_t
+ implicit none
+ private :: c_int, c_intptr_t
+ integer, parameter :: omp_allocator_handle_kind = c_intptr_t
+
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_null_allocator = 0
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_default_mem_alloc = 1
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_large_cap_mem_alloc = 2
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_const_mem_alloc = 3
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_high_bw_mem_alloc = 4
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_low_lat_mem_alloc = 5
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_cgroup_mem_alloc = 6
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_pteam_mem_alloc = 7
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_thread_mem_alloc = 8
+end module
+
+
+subroutine foo(x, y, al)
+ use omp_lib_kinds
+ implicit none
+
+type :: my_type
+ integer :: i
+ integer :: j
+ real :: x
+end type
+
+ integer :: x
+ integer :: y
+ integer (kind=omp_allocator_handle_kind) :: al
+
+ integer, allocatable :: var1
+ integer, allocatable :: var2
+ real, allocatable :: var3(:,:)
+ type (my_type), allocatable :: var4
+ integer, pointer :: pii, parr(:)
+ integer, allocatable :: var
+
+ character, allocatable :: str1a, str1aarr(:)
+ character(len=5), allocatable :: str5a, str5aarr(:)
+
+ x = 5 ! Some executable stmt
+ !$omp allocate
+ allocate(str1a, str1aarr(10), str5a, str5aarr(10))
+
+ !$omp allocate (var1) allocator(omp_default_mem_alloc)
+ !$omp allocate (var2) allocator(omp_large_cap_mem_alloc)
+ allocate (var1, var2)
+
+ !$omp allocate (var4) allocator(omp_low_lat_mem_alloc)
+ allocate (var4)
+ var4%i = 5
+
+ !$omp allocate (var3) allocator(omp_low_lat_mem_alloc)
+ allocate (var3(x,y))
+
+ !$omp allocate
+ allocate(pii, parr(5))
+
+ ! allocate statement not associated with an allocate directive
+ allocate(var)
+end subroutine
+
+! { dg-final { scan-tree-dump-times "#pragma omp allocate \\(kind=allocate\\)" 5 "original" } }
+! { dg-final { scan-tree-dump "#pragma omp allocate \\(kind=free\\)" "original" } }
+! { dg-final { scan-tree-dump-times "#pragma omp allocate \\(kind=allocate\\)" 5 "gimple" } }
+! { dg-final { scan-tree-dump "#pragma omp allocate \\(kind=free\\)" "gimple" } }
+! { dg-final { scan-tree-dump-times "builtin_malloc" 11 "original" } }
+! { dg-final { scan-tree-dump-times "builtin_free" 9 "original" } }
+! { dg-final { scan-tree-dump-times "GOMP_alloc" 10 "omplower" } }
+! { dg-final { scan-tree-dump-times "GOMP_free" 8 "omplower" } }
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90
index db76e901c085..b856204d48ae 100644
--- a/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90
@@ -1,13 +1,231 @@
-! { dg-do compile }
+! { dg-additional-options "-fmax-errors=1000" }
+module my_omp_lib
+ use iso_c_binding, only: c_intptr_t
+ !use omp_lib
+ implicit none
+ integer, parameter :: omp_allocator_handle_kind = c_intptr_t
+
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_null_allocator = 0
+
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_default_mem_alloc = 1
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_large_cap_mem_alloc = 2
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_const_mem_alloc = 3
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_high_bw_mem_alloc = 4
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_low_lat_mem_alloc = 5
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_cgroup_mem_alloc = 6
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_pteam_mem_alloc = 7
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_thread_mem_alloc = 8
+ type t
+ integer,allocatable :: a
+ integer,pointer :: b(:,:)
+ end type t
+ integer :: used
+end module my_omp_lib
+
+subroutine one(n, my_alloc)
+ use my_omp_lib
+ implicit none
+integer :: n
+integer(kind=omp_allocator_handle_kind), intent(in) :: my_alloc
+
+integer :: a,b,c(n),d(5),e(2)
+integer, save :: k,l,m(5),r(2)
+integer :: q,x,y(2),z(5)
+common /com1/ q,x
+common /com2/ y,z
+integer, allocatable :: alloc
+integer, pointer :: ptr
+integer, parameter :: prm=5
+
+!$omp allocate(prm) align(64) ! { dg-error "Argument 'prm' at .1. to declarative !.OMP ALLOCATE directive must be a variable" }
+! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
+
+!$omp allocate(used) allocator(omp_pteam_mem_alloc) ! { dg-error "Argument 'used' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" }
+!$omp allocate(n) allocator(omp_pteam_mem_alloc) ! { dg-error "Unexpected dummy argument 'n' as argument at .1. to declarative !.OMP ALLOCATE" }
+
+!$omp allocate (x) align(128) ! { dg-error "'x' at .1. is part of the common block '/com1/' and may only be specificed implicitly via the named common block" }
+
+!$omp allocate (a, b, a) allocator (omp_pteam_mem_alloc) ! { dg-error "Duplicated variable 'a' in !.OMP ALLOCATE" }
+contains
+
+ subroutine inner
+ !$omp allocate(a) allocator(omp_pteam_mem_alloc) ! { dg-error "Argument 'a' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" }
+! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
+ end
+end
+
+subroutine three(n)
+ use my_omp_lib
+ implicit none
+integer,value :: n
+integer :: a,b,c(n),d(5),e(2)
+integer, save :: k,l,m(5)
+integer :: q,x,y(2),z(5),r
+common /com4/ y,z
+allocatable :: q
+pointer :: b
+!$omp allocate (c, d) allocator (omp_pteam_mem_alloc)
+! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
+!$omp allocate (/com4/) allocator (omp_pteam_mem_alloc)
+!$omp allocate (c) allocator (omp_pteam_mem_alloc) ! { dg-error "Duplicated variable 'c' in !.OMP ALLOCATE" }
+!$omp allocate (/com4/) allocator (omp_pteam_mem_alloc) ! { dg-error "Duplicated common block '/com4/' in !.OMP ALLOCATE" }
+
+!$omp allocate(q,x) ! { dg-error "Unexpected allocatable variable 'q' at .1. in declarative !.OMP ALLOCATE directive" }
+!$omp allocate(b,e) ! { dg-error "Unexpected pointer variable 'b' at .1. in declarative !.OMP ALLOCATE directive" }
+end
+
+subroutine four(n)
+ integer :: qq, rr, ss, tt, uu, vv,n
+!$omp allocate (qq) align(3+n) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
+! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
+!$omp allocate (rr) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
+!$omp allocate (ss) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
+!$omp allocate (tt) align(32.0) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
+!$omp allocate (uu) align(31) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
+end
+
+subroutine five(n,my_alloc)
+ use my_omp_lib
+ implicit none
+ integer :: qq, rr, ss, tt, uu, vv,n
+ integer(omp_allocator_handle_kind) :: my_alloc
+!$omp allocate (qq) allocator(3.0) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
+! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
+!$omp allocate (rr) allocator(3_2) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
+!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
+!$omp allocate (tt) allocator(my_alloc) ! OK
+end
+
+
+subroutine five_SaveAll(n,my_alloc)
+ use my_omp_lib
+ implicit none
+ save
+ integer :: qq, rr, ss, tt, uu, vv,n
+ integer(omp_allocator_handle_kind) :: my_alloc
+!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" }
+! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
+!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" }
+!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" }
+!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" }
+end
-subroutine bar(a)
+
+subroutine five_Save(n,my_alloc)
+ use my_omp_lib
+ implicit none
+ integer :: n
+ integer, save :: qq, rr, ss, tt, uu, vv
+ integer(omp_allocator_handle_kind) :: my_alloc
+!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" }
+! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
+!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" }
+!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" }
+!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" }
+end
+
+module five_Module
+ use my_omp_lib
+ implicit none
+ integer, save :: qq, rr, ss, tt, uu, vv,n
+ integer(omp_allocator_handle_kind) :: my_alloc
+!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" }
+! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
+!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" }
+!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" }
+!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" }
+end module
+
+program five_program
+ use my_omp_lib
+ implicit none
+ integer, save :: qq, rr, ss, tt, uu, vv,n
+ integer(omp_allocator_handle_kind) :: my_alloc
+!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" }
+! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
+!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" }
+!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" }
+!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" }
+end program
+
+
+
+subroutine six(n,my_alloc)
+ use my_omp_lib
+ implicit none
+ integer :: qq, rr, ss, tt, uu, vv,n
+ common /com6qq/ qq
+ common /com6rr/ rr
+ common /com6ss/ ss
+ common /com6tt/ tt
+ integer(omp_allocator_handle_kind) :: my_alloc
+
+!$omp allocate (/com6qq/) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6qq/' at .2. has the SAVE attribute" }
+! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
+!$omp allocate (/com6rr/) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6rr/' at .2. has the SAVE attribute" }
+!$omp allocate (/com6ss/) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6ss/' at .2. has the SAVE attribute" }
+!$omp allocate (/com6tt/) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6tt/' at .2. has the SAVE attribute" }
+end
+
+
+subroutine two()
+ use my_omp_lib
+ implicit none
+ integer,allocatable :: qq, rr, ss, tt, uu, vv,n
+ integer(omp_allocator_handle_kind) :: my_alloc
+
+ call foo()
+!$omp allocate (qq) allocator(3.0) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
+allocate(qq)
+!$omp allocate (rr) allocator(3_2) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
+allocate(rr)
+!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
+allocate(ss)
+!$omp allocate (tt) allocator(my_alloc) ! OK
+allocate(tt)
+end
+
+subroutine two_ptr()
+ use my_omp_lib
implicit none
- integer :: a
- integer, allocatable :: var
-!$omp target
- !$omp allocate (var) ! { dg-error "'allocate' directive must specify an allocator here" }
- allocate (var)
-!$omp end target
+ integer,pointer :: qq, rr, ss, tt, uu, vv,n
+ integer(omp_allocator_handle_kind) :: my_alloc
+
+ call foo()
+!$omp allocate (qq) align(3+n) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
+allocate(qq)
+!$omp allocate (rr) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
+allocate(rr)
+!$omp allocate (ss) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
+allocate(ss)
+!$omp allocate (tt) align(32.0) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
+allocate(tt)
+!$omp allocate (uu) align(31) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
+allocate(uu)
+end
+
+subroutine next()
+ use my_omp_lib
+ implicit none
+ integer,allocatable :: qq, rr, ss, tt, uu, vv,n
+ integer(omp_allocator_handle_kind) :: my_alloc
+
+ !$omp allocate(qq) ! { dg-error "'!.OMP ALLOCATE' directive at .1. associated with an ALLOCATE stmt must be preceded by an executable statement or OpenMP construct; note the variables in the list all have the allocatable or pointer attribute" }
+ allocate(qq,rr)
-end subroutine
+ !$omp allocate(uu,tt)
+ !$omp allocate(tt) ! { dg-warning "'tt' appears more than once in 'allocate" }
+ allocate(uu,tt)
+ !$omp allocate(uu,vv) ! { dg-error "'uu' specified in 'allocate' at .1. but not in the associated ALLOCATE statement" }
+ allocate(vv)
+end
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-7a.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-7a.f90
new file mode 100644
index 000000000000..db76e901c085
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-7a.f90
@@ -0,0 +1,13 @@
+! { dg-do compile }
+
+subroutine bar(a)
+ implicit none
+ integer :: a
+ integer, allocatable :: var
+!$omp target
+ !$omp allocate (var) ! { dg-error "'allocate' directive must specify an allocator here" }
+ allocate (var)
+!$omp end target
+
+end subroutine
+
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-8.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-8a.f90
similarity index 100%
rename from gcc/testsuite/gfortran.dg/gomp/allocate-8.f90
rename to gcc/testsuite/gfortran.dg/gomp/allocate-8a.f90
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-9a.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-9a.f90
new file mode 100644
index 000000000000..39d94e304107
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-9a.f90
@@ -0,0 +1,15 @@
+! { dg-additional-options "-fdump-tree-omplower" }
+subroutine f()
+ integer, allocatable :: A, B
+
+ !$omp allocators allocate(align(128): A)
+ allocate(A)
+
+ !$omp allocate(B) align(256)
+ allocate(B)
+end
+
+! { dg-final { scan-tree-dump "a = __builtin_GOMP_alloc \\(128, 4, 0B\\);" "omplower" } }
+! { dg-final { scan-tree-dump "b = __builtin_GOMP_alloc \\(256, 4, 0B\\);" "omplower" } }
+! { dg-final { scan-tree-dump "__builtin_GOMP_free \\(b, 0B\\);" "omplower" } }
+! { dg-final { scan-tree-dump "__builtin_GOMP_free \\(a, 0B\\);" "omplower" } }
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocators-1.f90 b/gcc/testsuite/gfortran.dg/gomp/allocators-1.f90
new file mode 100644
index 000000000000..b39f6d272c1e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/allocators-1.f90
@@ -0,0 +1,28 @@
+implicit none
+integer, allocatable :: a, b
+integer :: q
+integer :: arr(2)
+
+!$omp allocators allocate(align(64): a)
+block ! { dg-error "expected ALLOCATE statement after !.OMP ALLOCATORS" }
+end block ! { dg-error "Expecting END PROGRAM statement" }
+
+
+!$omp allocators allocate(align(64): a)
+ allocate(a, b) ! OK
+!$omp end allocators
+
+!$omp allocators allocate(align(128): b)
+ allocate(a, b) ! OK (assuming not allocated)
+
+
+!$omp allocators allocate(align(64): a)
+ allocate(a, b, stat=arr) ! { dg-error "Stat-variable at .1. must be a scalar INTEGER variable" }
+!$omp end allocators
+
+
+!$omp allocators allocate(align(64): a)
+ allocate(q) ! { dg-error "is neither a data pointer nor an allocatable variable" }
+!$omp end allocators ! { dg-error "Unexpected !.OMP END ALLOCATORS" }
+
+end
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocators-2.f90 b/gcc/testsuite/gfortran.dg/gomp/allocators-2.f90
new file mode 100644
index 000000000000..6fb80879ef7e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/allocators-2.f90
@@ -0,0 +1,22 @@
+implicit none
+integer, allocatable :: a, b
+integer :: q
+integer :: arr(2)
+
+!$omp allocators allocate(align(64): a)
+ allocate(a, b) ! OK
+!$omp end allocators
+
+!$omp allocators allocate(align(128): b)
+ allocate(a, b) ! OK (assuming not allocated)
+
+
+!$omp allocators allocate(align(62.0): a) ! { dg-error "a scalar positive constant integer alignment expression" }
+ allocate(a)
+
+
+!$omp allocators allocate(align(64): a, b) ! { dg-error "'b' specified in 'allocate' at \\(1\\) but not in the associated ALLOCATE statement" }
+ allocate(a)
+!$omp end allocators
+
+end
diff --git a/gcc/tree-core.h b/gcc/tree-core.h
index 58cf3c5baf87..ebe8910d7cb2 100644
--- a/gcc/tree-core.h
+++ b/gcc/tree-core.h
@@ -536,9 +536,6 @@ enum omp_clause_code {
/* OpenACC clause: nohost. */
OMP_CLAUSE_NOHOST,
- /* OpenMP clause: allocator. */
- OMP_CLAUSE_ALLOCATOR,
-
/* OpenMP clause: uses_allocators. */
OMP_CLAUSE_USES_ALLOCATORS,
diff --git a/gcc/tree-pretty-print.cc b/gcc/tree-pretty-print.cc
index 2001a47bf897..77a58f98ed1a 100644
--- a/gcc/tree-pretty-print.cc
+++ b/gcc/tree-pretty-print.cc
@@ -815,20 +815,6 @@ dump_omp_clause (pretty_printer *pp, tree clause, int spc, dump_flags_t flags)
pp_right_paren (pp);
break;
- case OMP_CLAUSE_ALLOCATOR:
- pp_string (pp, "(");
- dump_generic_node (pp, OMP_ALLOCATE_DECL (clause),
- spc, flags, false);
- if (OMP_ALLOCATE_ALLOCATOR (clause))
- {
- pp_string (pp, ":allocator(");
- dump_generic_node (pp, OMP_ALLOCATE_ALLOCATOR (clause),
- spc, flags, false);
- pp_right_paren (pp);
- }
- pp_right_paren (pp);
- break;
-
case OMP_CLAUSE_ALLOCATE:
pp_string (pp, "allocate(");
if (OMP_CLAUSE_ALLOCATE_ALLOCATOR (clause))
diff --git a/gcc/tree.cc b/gcc/tree.cc
index d42af1df8bd7..fbad24935836 100644
--- a/gcc/tree.cc
+++ b/gcc/tree.cc
@@ -328,7 +328,6 @@ unsigned const char omp_clause_num_ops[] =
0, /* OMP_CLAUSE_IF_PRESENT */
0, /* OMP_CLAUSE_FINALIZE */
0, /* OMP_CLAUSE_NOHOST */
- 2, /* OMP_CLAUSE_ALLOCATOR */
3, /* OMP_CLAUSE_USES_ALLOCATORS */
1, /* OMP_CLAUSE_UNROLL_FULL */
1, /* OMP_CLAUSE_UNROLL_NONE */
diff --git a/gcc/tree.h b/gcc/tree.h
index 5f3bd82ab1e8..33fd48935cb1 100644
--- a/gcc/tree.h
+++ b/gcc/tree.h
@@ -1943,15 +1943,6 @@ class auto_suppress_location_wrappers
#define OMP_CLAUSE_ALLOCATE_ALIGN(NODE) \
OMP_CLAUSE_OPERAND (OMP_CLAUSE_SUBCODE_CHECK (NODE, OMP_CLAUSE_ALLOCATE), 2)
-/* May be we can use OMP_CLAUSE_DECL but the I am not sure where to place
- OMP_CLAUSE_ALLOCATOR in omp_clause_code. */
-
-#define OMP_ALLOCATE_DECL(NODE) \
- OMP_CLAUSE_OPERAND (OMP_CLAUSE_SUBCODE_CHECK (NODE, OMP_CLAUSE_ALLOCATOR), 0)
-
-#define OMP_ALLOCATE_ALLOCATOR(NODE) \
- OMP_CLAUSE_OPERAND (OMP_CLAUSE_SUBCODE_CHECK (NODE, OMP_CLAUSE_ALLOCATOR), 1)
-
/* True if an ALLOCATE clause was present on a combined or composite
construct and the code for splitting the clauses has already performed
checking if the listed variable has explicit privatization on the
diff --git a/libgomp/ChangeLog.omp b/libgomp/ChangeLog.omp
index 43ecbea06dd9..6df01bedf2e4 100644
--- a/libgomp/ChangeLog.omp
+++ b/libgomp/ChangeLog.omp
@@ -1,3 +1,10 @@
+2023-10-26 Tobias Burnus <tobias@codesourcery.com>
+ Chung-Lin Tang <cltang@codesourcery.com>
+
+ * testsuite/libgomp.fortran/allocate-2a.f90: Add exec stmt.
+ * testsuite/libgomp.fortran/allocate-4.f90: Update dg-error
+ * testsuite/libgomp.fortran/allocate-5.f90: Likewise; add exec stmt.
+
2023-09-20 Tobias Burnus <tobias@codesourcery.com>
Backported from master:
diff --git a/libgomp/testsuite/libgomp.fortran/allocate-2a.f90 b/libgomp/testsuite/libgomp.fortran/allocate-2a.f90
index 2219f107fe73..510a4f7023df 100644
--- a/libgomp/testsuite/libgomp.fortran/allocate-2a.f90
+++ b/libgomp/testsuite/libgomp.fortran/allocate-2a.f90
@@ -22,6 +22,7 @@ subroutine foo (x, y, h)
integer (kind=omp_allocator_handle_kind) :: h
integer, allocatable :: var1
+ !$omp flush ! executable statement before '!$omp allocate'
!$omp allocate (var1) allocator(h)
allocate (var1)
diff --git a/libgomp/testsuite/libgomp.fortran/allocate-4.f90 b/libgomp/testsuite/libgomp.fortran/allocate-4.f90
index ddb507ba8e40..1f833b6e70f2 100644
--- a/libgomp/testsuite/libgomp.fortran/allocate-4.f90
+++ b/libgomp/testsuite/libgomp.fortran/allocate-4.f90
@@ -16,27 +16,27 @@ integer, parameter :: cnst(2) = [64, 101]
!$omp parallel allocate( allocator (omp_high_bw_mem_alloc) : x) firstprivate(x) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
!$omp end parallel
-!$omp parallel allocate( align (q) : x) firstprivate(x) ! { dg-error "32:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
+!$omp parallel allocate( align (q) : x) firstprivate(x) ! { dg-error "32:ALIGN requires a scalar positive constant integer alignment expression at \\(1\\) that is a power of two" }
!$omp end parallel
!$omp parallel allocate( align (32) : x) firstprivate(x) ! OK
!$omp end parallel
-!$omp parallel allocate( align(q) : x) firstprivate(x) ! { dg-error "31:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
+!$omp parallel allocate( align(q) : x) firstprivate(x) ! { dg-error "31:ALIGN requires a scalar positive constant integer alignment expression at \\(1\\) that is a power of two" }
!$omp end parallel
!$omp parallel allocate( align(cnst(1)) : x ) firstprivate(x) ! OK
!$omp end parallel
-!$omp parallel allocate( align(cnst(2)) : x) firstprivate(x) ! { dg-error "31:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
+!$omp parallel allocate( align(cnst(2)) : x) firstprivate(x) ! { dg-error "31:ALIGN requires a scalar positive constant integer alignment expression at \\(1\\) that is a power of two" }
!$omp end parallel
-!$omp parallel allocate( align( 31) :x) firstprivate(x) ! { dg-error "32:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
+!$omp parallel allocate( align( 31) :x) firstprivate(x) ! { dg-error "32:ALIGN requires a scalar positive constant integer alignment expression at \\(1\\) that is a power of two" }
!$omp end parallel
-!$omp parallel allocate( align (32.0): x) firstprivate(x) ! { dg-error "32:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
+!$omp parallel allocate( align (32.0): x) firstprivate(x) ! { dg-error "32:ALIGN requires a scalar positive constant integer alignment expression at \\(1\\) that is a power of two" }
!$omp end parallel
-!$omp parallel allocate( align(cnst ) : x ) firstprivate(x) ! { dg-error "31:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
+!$omp parallel allocate( align(cnst ) : x ) firstprivate(x) ! { dg-error "31:ALIGN requires a scalar positive constant integer alignment expression at \\(1\\) that is a power of two" }
!$omp end parallel
end
diff --git a/libgomp/testsuite/libgomp.fortran/allocate-5.f90 b/libgomp/testsuite/libgomp.fortran/allocate-5.f90
index 0773e5c59e66..f85a7cab123f 100644
--- a/libgomp/testsuite/libgomp.fortran/allocate-5.f90
+++ b/libgomp/testsuite/libgomp.fortran/allocate-5.f90
@@ -22,6 +22,8 @@ subroutine foo(x, y)
integer, allocatable :: var8(:)
integer, allocatable :: var9(:)
+ x = 1 ! executable statement before '!$omp allocate'
+
! Don't use a hard-coded value (..., but it does pass the checks).
!$omp allocate (var1) allocator(10_omp_allocator_handle_kind) ! { dg-bogus "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
allocate (var1(x))
@@ -30,27 +32,26 @@ subroutine foo(x, y)
!$omp allocate (var1) allocator(10_1) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind at .1." }
allocate (var1(x))
- !$omp allocate (var2) ! { dg-error "'var2' in 'allocate' directive at .1. is not present in associated 'allocate' statement." }
- allocate (var3(x))
+ !$omp allocate (var2) ! { dg-error "'var2' specified in 'allocate' at .1. but not in the associated ALLOCATE statement" }
+ allocate (var3(x)) ! { dg-error "'var3' listed in 'allocate' statement at .1. but it is neither explicitly in listed in the '!.OMP ALLOCATE' directive nor exists a directive without argument list" }
- !$omp allocate (x) ! { dg-message "sorry, unimplemented: 'allocate' directive that is not associated with an 'allocate' statement is not supported." }
- x = 2
+ !$omp allocate (x)
+ x = 2 ! { dg-error "Unexpected assignment at .1.; expected ALLOCATE or !.OMP ALLOCATE statement" }
- !$omp allocate (var4) ! { dg-error "'var4' with ALLOCATABLE attribute is not allowed in 'allocate' directive at .1. as this directive is not associated with an 'allocate' statement." }
- ! { dg-message "sorry, unimplemented: 'allocate' directive that is not associated with an 'allocate' statement is not supported." "" { target *-*-* } .-1 }
- y = 2
+ !$omp allocate (var4)
+ y = 2 ! { dg-error "Unexpected assignment at .1.; expected ALLOCATE or !.OMP ALLOCATE statement" }
!$omp allocate (var5)
- !$omp allocate ! { dg-error "Empty variable list is not allowed at .1. when multiple 'allocate' directives are associated with an 'allocate' statement." }
+ !$omp allocate
allocate (var5(x))
!$omp allocate (var6)
- !$omp allocate (var7) ! { dg-error "'var7' in 'allocate' directive at .1. is not present in associated 'allocate' statement." }
- !$omp allocate (var8) ! { dg-error "'var8' in 'allocate' directive at .1. is not present in associated 'allocate' statement." }
+ !$omp allocate (var7) ! { dg-error "'var7' specified in 'allocate' at .1. but not in the associated ALLOCATE statement" }
+ !$omp allocate (var8) ! { dg-error "'var8' specified in 'allocate' at .1. but not in the associated ALLOCATE statement" }
allocate (var6(x))
!$omp allocate (var9)
- !$omp allocate (var9) ! { dg-error "'var9' is used in multiple 'allocate' directives at .1." }
+ !$omp allocate (var9) ! { dg-warning "var9' appears more than once in 'allocate'" }
allocate (var9(x))
end subroutine
@@ -70,7 +71,9 @@ function outer(a)
integer :: x
integer, allocatable :: var2
- !$omp allocate (var1, var2) ! { dg-error "'var1' is not in the same scope as 'allocate' directive at .1." }
+ x = 1 ! executable statement before '!$omp allocate'
+
+ !$omp allocate (var1, var2) ! { dg-error "Sorry, allocation of allocatable 'var1' with '!.omp allocators' or '!.omp allocate' at .1. is only suppored in the scope where it has been declared, unless it has the SAVE attribute" }
allocate (var1, var2)
inner = x + 10
@@ -96,22 +99,21 @@ subroutine bar(s)
a = omp_init_allocator (omp_default_mem_space, 3, traits)
if (a == omp_null_allocator) stop 1
- !$omp allocate (mvar1) allocator(a) ! { dg-error "'mvar1' should use predefined allocator at .1." }
+ !$omp allocate (mvar1) allocator(a)
allocate (mvar1)
- !$omp allocate (mvar2) ! { dg-error "'mvar2' should use predefined allocator at .1." }
+ !$omp allocate (mvar2)
allocate (mvar2)
!$omp allocate (mvar3) allocator(omp_low_lat_mem_alloc)
allocate (mvar3)
- !$omp allocate (svar1) allocator(a) ! { dg-error "'svar1' should use predefined allocator at .1." }
+ !$omp allocate (svar1) allocator(a)
allocate (svar1)
- !$omp allocate (svar2) ! { dg-error "'svar2' should use predefined allocator at .1." }
+ !$omp allocate (svar2)
allocate (svar2)
!$omp allocate (svar3) allocator(omp_low_lat_mem_alloc)
allocate (svar3)
end subroutine
-
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2023-10-26 14:14 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-10-26 14:14 [gcc/devel/omp/gcc-13] OpenMP/Fortran: Merge upstream 'omp allocators' with OG13 'omp allocate' Tobias Burnus
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).