* [Patch] Fortran/OpenMP: Add parsing support for allocators directive
@ 2022-12-14 10:47 Tobias Burnus
2022-12-21 15:51 ` [Patch] Fortran/OpenMP: Add parsing support for allocators/allocate directive (was: [Patch] Fortran/OpenMP: Add parsing support for allocators directive) Tobias Burnus
0 siblings, 1 reply; 3+ messages in thread
From: Tobias Burnus @ 2022-12-14 10:47 UTC (permalink / raw)
To: gcc-patches, Jakub Jelinek, fortran
[-- Attachment #1: Type: text/plain, Size: 862 bytes --]
This patch adds parsing/argument-checking support for
'!$omp allocators allocate([align(int),allocator(a) :] list)'
This is kind of logical follow-up and prep patch for the
'!$omp allocate(list) [align(v) allocator(a)]'
support that was submitted as part of a larger patchset by Abid; cf.
review at
"[PATCH 1/5] [gfortran] Add parsing support for allocate directive (OpenMP 5.0)."
https://gcc.gnu.org/pipermail/gcc-patches/2022-October/603258.html
My follow-up patch will add parsing support for declarative/executable '!$omp allocate'.
OK for mainline?
Tobias
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
[-- Attachment #2: omp-allocators.diff --]
[-- Type: text/x-patch, Size: 13611 bytes --]
Fortran/OpenMP: Add parsing support for allocators directive
gcc/fortran/ChangeLog:
* gfortran.h (enum gfc_statement): Add ST_OMP_ALLOCATORS and
ST_OMP_END_ALLOCATORS.
(enum gfc_exec_op): Add EXEC_OMP_ALLOCATORS.
* dump-parse-tree.cc (show_omp_node, show_code_node): Handle
OpenMP's ALLOCATORS directive.
* match.h (gfc_match_omp_allocators): New prototype.
* openmp.cc (OMP_ALLOCATORS_CLAUSES): Define.
(gfc_match_omp_allocators): New.
(resolve_omp_clauses, omp_code_to_statement,
gfc_resolve_omp_directive): Handle EXEC_OMP_ALLOCATORS.
* parse.cc (parse_openmp_allocate_block): New.
(case_exec_markers): Add ST_OMP_ALLOCATORS.
(decode_omp_directive, gfc_ascii_statement,
parse_executable): Parse OpenMP allocators directive.
* resolve.cc (gfc_resolve_blocks): Handle EXEC_OMP_ALLOCATORS.
* st.cc (gfc_free_statement): Likewise.
* trans.cc (trans_code): Likewise.
* trans-openmp.cc (gfc_trans_omp_directive): Show 'sorry' for
EXEC_OMP_ALLOCATORS.
gcc/testsuite/ChangeLog:
* gfortran.dg/gomp/allocators-1.f90: New test.
* gfortran.dg/gomp/allocators-2.f90: New test.
gcc/fortran/dump-parse-tree.cc | 2 +
gcc/fortran/gfortran.h | 3 +-
gcc/fortran/match.h | 1 +
gcc/fortran/openmp.cc | 31 ++++++++++++++-
gcc/fortran/parse.cc | 50 ++++++++++++++++++++++++-
gcc/fortran/resolve.cc | 2 +
gcc/fortran/st.cc | 1 +
gcc/fortran/trans-openmp.cc | 3 ++
gcc/fortran/trans.cc | 1 +
gcc/testsuite/gfortran.dg/gomp/allocators-1.f90 | 28 ++++++++++++++
gcc/testsuite/gfortran.dg/gomp/allocators-2.f90 | 22 +++++++++++
11 files changed, 140 insertions(+), 4 deletions(-)
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 5ae72dc1cac..4565b71c758 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -2081,6 +2081,7 @@ show_omp_node (int level, gfc_code *c)
case EXEC_OACC_CACHE: name = "CACHE"; is_oacc = true; break;
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_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;
@@ -3409,6 +3410,7 @@ show_code_node (int level, gfc_code *c)
case EXEC_OACC_CACHE:
case EXEC_OACC_ENTER_DATA:
case EXEC_OACC_EXIT_DATA:
+ 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 5f8a81ae4a1..63f38d26666 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -318,6 +318,7 @@ enum gfc_statement
ST_OMP_END_MASKED_TASKLOOP, ST_OMP_MASKED_TASKLOOP_SIMD,
ST_OMP_END_MASKED_TASKLOOP_SIMD, ST_OMP_SCOPE, ST_OMP_END_SCOPE,
ST_OMP_ERROR, ST_OMP_ASSUME, ST_OMP_END_ASSUME, ST_OMP_ASSUMES,
+ ST_OMP_ALLOCATORS, ST_OMP_END_ALLOCATORS,
/* Note: gfc_match_omp_nothing returns ST_NONE. */
ST_OMP_NOTHING, ST_NONE
};
@@ -2959,7 +2960,7 @@ 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_ERROR
+ EXEC_OMP_ERROR, EXEC_OMP_ALLOCATORS
};
typedef struct gfc_code
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 2a805815d9c..b1f5db80125 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -149,6 +149,7 @@ match gfc_match_oacc_routine (void);
/* OpenMP directive matchers. */
match gfc_match_omp_eos_error (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 686f924b47a..e978f8774c4 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -55,7 +55,7 @@ struct gfc_omp_directive {
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}, */
+ {"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},
@@ -4270,6 +4270,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)
static match
@@ -4285,6 +4287,13 @@ match_omp (gfc_exec_op op, const omp_mask mask)
}
+match
+gfc_match_omp_allocators (void)
+{
+ return match_omp (EXEC_OMP_ALLOCATORS, OMP_ALLOCATORS_CLAUSES);
+}
+
+
match
gfc_match_omp_assume (void)
{
@@ -7382,6 +7391,23 @@ resolve_omp_clauses (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->block->next && code->block->next->op == EXEC_ALLOCATE)
+ {
+ gfc_alloc *a;
+ for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
+ {
+ 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%> clause at %L but not "
+ "in the associated ALLOCATE statement",
+ n->sym->name, &n->where);
+ }
+ }
+
}
/* OpenACC reductions. */
@@ -9551,6 +9577,8 @@ omp_code_to_statement (gfc_code *code)
return ST_OMP_DO;
case EXEC_OMP_LOOP:
return ST_OMP_LOOP;
+ case EXEC_OMP_ALLOCATORS:
+ return ST_OMP_ALLOCATORS;
case EXEC_OMP_ASSUME:
return ST_OMP_ASSUME;
case EXEC_OMP_ATOMIC:
@@ -10072,6 +10100,7 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
case EXEC_OMP_TEAMS_LOOP:
resolve_omp_do (code);
break;
+ case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_CANCEL:
case EXEC_OMP_ERROR:
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index bc2b2188eea..2ab5ed0d6aa 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -885,6 +885,7 @@ decode_omp_directive (void)
switch (c)
{
case 'a':
+ matcho ("allocators", gfc_match_omp_allocators, ST_OMP_ALLOCATORS);
matcho ("assumes", gfc_match_omp_assumes, ST_OMP_ASSUMES);
matchs ("assume", gfc_match_omp_assume, ST_OMP_ASSUME);
matcho ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
@@ -915,6 +916,7 @@ decode_omp_directive (void)
break;
case 'e':
matcho ("error", gfc_match_omp_error, ST_OMP_ERROR);
+ matcho ("end allocators", gfc_match_omp_eos_error, ST_OMP_END_ALLOCATORS);
matchs ("end assume", gfc_match_omp_eos_error, ST_OMP_END_ASSUME);
matcho ("end atomic", gfc_match_omp_eos_error, ST_OMP_END_ATOMIC);
matcho ("end critical", gfc_match_omp_end_critical, ST_OMP_END_CRITICAL);
@@ -1720,7 +1722,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_ALLOCATORS: case ST_OMP_ASSUME: \
case ST_CRITICAL: \
case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
@@ -2359,6 +2361,9 @@ gfc_ascii_statement (gfc_statement st, bool strip_sentinel)
case ST_OACC_END_ATOMIC:
p = "!$ACC END ATOMIC";
break;
+ case ST_OMP_ALLOCATORS:
+ p = "!$OMP ALLOCATORS";
+ break;
case ST_OMP_ASSUME:
p = "!$OMP ASSUME";
break;
@@ -2413,6 +2418,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;
case ST_NONE:
@@ -5525,6 +5532,41 @@ parse_oacc_loop (gfc_statement acc_st)
return 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;
+
+ 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 ();
+ 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 (st == ST_OMP_END_ALLOCATORS)
+ {
+ accept_statement (st);
+ st = next_statement ();
+ }
+ return st;
+}
/* Parse the statements of an OpenMP structured block. */
@@ -5923,6 +5965,10 @@ parse_executable (gfc_statement st)
parse_oacc_structured_block (st);
break;
+ case ST_OMP_ALLOCATORS:
+ st = parse_openmp_allocate_block (st);
+ continue;
+
case ST_OMP_ASSUME:
case ST_OMP_PARALLEL:
case ST_OMP_PARALLEL_MASKED:
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 0f5f1d277e4..0cb4ff76853 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -10909,6 +10909,7 @@ 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_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_DISTRIBUTE:
@@ -12384,6 +12385,7 @@ start:
gfc_resolve_oacc_directive (code, ns);
break;
+ case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
diff --git a/gcc/fortran/st.cc b/gcc/fortran/st.cc
index 8b4ca5ec2ea..ca852626432 100644
--- a/gcc/fortran/st.cc
+++ b/gcc/fortran/st.cc
@@ -214,6 +214,7 @@ gfc_free_statement (gfc_code *p)
case EXEC_OACC_ENTER_DATA:
case EXEC_OACC_EXIT_DATA:
case EXEC_OACC_ROUTINE:
+ case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_CANCEL:
diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index 7a4a3390b6d..f4ff891a4be 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -7536,6 +7536,9 @@ gfc_trans_omp_directive (gfc_code *code)
{
switch (code->op)
{
+ case EXEC_OMP_ALLOCATORS:
+ sorry ("%<!$OMP ALLOCATORS%> not yet supported");
+ return NULL_TREE;
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 8a64882ea9e..34b2a976da5 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -2174,6 +2174,7 @@ trans_code (gfc_code * code, tree cond)
res = gfc_trans_dt_end (code);
break;
+ case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
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 00000000000..b39f6d272c1
--- /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 00000000000..5dabce0f10a
--- /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' clause at \\(1\\) but not in the associated ALLOCATE statement" }
+ allocate(a)
+!$omp end allocators
+
+end
^ permalink raw reply [flat|nested] 3+ messages in thread
* [Patch] Fortran/OpenMP: Add parsing support for allocators/allocate directive (was: [Patch] Fortran/OpenMP: Add parsing support for allocators directive)
2022-12-14 10:47 [Patch] Fortran/OpenMP: Add parsing support for allocators directive Tobias Burnus
@ 2022-12-21 15:51 ` Tobias Burnus
2023-05-26 19:04 ` [committed][Patch] Fortran/OpenMP: Add parsing support for allocators/allocate directives Tobias Burnus
0 siblings, 1 reply; 3+ messages in thread
From: Tobias Burnus @ 2022-12-21 15:51 UTC (permalink / raw)
To: gcc-patches, Jakub Jelinek, fortran
[-- Attachment #1: Type: text/plain, Size: 2571 bytes --]
Related pending (simple) patches - aka *Patch Ping*:
* [Patch] Fortran: Extend align-clause checks of OpenMP's allocate clause
https://gcc.gnu.org/pipermail/gcc-patches/2022-December/608401.html
* [Patch] OpenMP: Parse align clause in allocate directive in C/C++
https://gcc.gnu.org/pipermail/gcc-patches/2022-December/608404.html
On 14.12.22 11:47, Tobias Burnus wrote:
> This patch adds parsing/argument-checking support for
> '!$omp allocators allocate([align(int),allocator(a) :] list)'
This follow-up patch additionally adds parsing support for both
declarative and allocate-stmt-associated '!$omp allocate' directives –
and replaces my previous patch.
OK for mainline?
* * *
The code requires in line with OpenMP 5.1 that an executable statement
comes before an '!$omp allocate' that is associated with a Fortran
ALLOCATE stmt, which is diagnosed.
Note: There is a spec change/regression related to permitting structure
elements; while OpenMP 5.0/5.1 did permit them in the
allocate-stmt-associated "!$omp allocate", OpenMP 5.2 stopped doing –
and '!$omp allocators' never permitted it. — For allocate that's seems
to be the accidental result from "permitted unless stated otherwise" to
"rejected unless stated otherwise". For 'allocators', it is the result
of the original 'allocate' clause which should have been extended for
'allocators' - or should not.
In any case, that's tracked now in OpenMP's spec issue #3437.
Thoughts? – The code rejects var%comp and var(1)%comp etc. for now –
besides the unclear spec status, I admittedly did this also to make
checking easier (like for duplicated entries, entry same as in ALLOCATE
except for tailing array spec etc.).
* * *
This patch replaced both my previous patch in this thread and also
Abid's patch
> "[PATCH 1/5] [gfortran] Add parsing support for allocate directive
> (OpenMP 5.0)."
> https://gcc.gnu.org/pipermail/gcc-patches/2022-October/603258.html
In his patch set, later patches actually add allocater support for
allocatables/pointers, only – but there issues with regards to the used
allocator (see patches + patch review).
As my attached patch raises a sorry, it neither addresses that issue nor
is it affected by that issue.
Tobias
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
[-- Attachment #2: allocate-allocators.diff --]
[-- Type: text/x-patch, Size: 64474 bytes --]
Fortran/OpenMP: Add parsing support for allocators/allocate directive
gcc/fortran/ChangeLog:
* dump-parse-tree.cc (show_omp_namelist): Update allocator, fix
align dump.
(show_omp_node, show_code_node): Handle EXEC_OMP_ALLOCATE.
* gfortran.h (enum gfc_statement): Add ST_OMP_ALLOCATE and ..._EXEC.
(enum gfc_exec_op): Add EXEC_OMP_ALLOCATE.
(struct gfc_omp_namelist): Add 'allocator' to 'u2' union.
(struct gfc_namespace): Add omp_allocate.
(gfc_resolve_omp_allocate): New.
* match.cc (gfc_free_omp_namelist): Free 'u2.allocator'.
* match.h (gfc_match_omp_allocate, gfc_match_omp_allocators): New.
* openmp.cc (gfc_omp_directives): Uncomment allocate/allocators.
(gfc_match_omp_variable_list): Add bool arg for
rejecting listening common-block vars separately.
(gfc_match_omp_clauses): Update for u2.allocators.
(OMP_ALLOCATORS_CLAUSES, gfc_match_omp_allocate,
gfc_match_omp_allocators, is_predefined_allocator,
gfc_resolve_omp_allocate): New.
(resolve_omp_clauses): Update 'allocate' clause checks.
(omp_code_to_statement, gfc_resolve_omp_directive): Handle
OMP ALLOCATE/ALLOCATORS.
* parse.cc (in_exec_part): New global var.
(check_omp_allocate_stmt, parse_openmp_allocate_block): New.
(decode_omp_directive, case_exec_markers, case_omp_decl,
gfc_ascii_statement, parse_omp_structured_block): Handle
OMP allocate/allocators.
(verify_st_order, parse_executable): Set in_exec_part.
* resolve.cc (gfc_resolve_blocks, resolve_codes): Handle
allocate/allocators.
* st.cc (gfc_free_statement): Likewise.
* trans.cc (trans_code):) Likewise.
* trans-openmp.cc (gfc_trans_omp_directive): Likewise.
(gfc_trans_omp_clauses, gfc_split_omp_clauses): Update for
u2.allocator, fix for u.align.
libgomp/ChangeLog:
* testsuite/libgomp.fortran/allocate-3.f90: Update dg-error.
gcc/testsuite/ChangeLog:
* gfortran.dg/gomp/allocate-2.f90: Update dg-error.
* gfortran.dg/gomp/allocate-4.f90: New test.
* gfortran.dg/gomp/allocate-5.f90: New test.
* gfortran.dg/gomp/allocate-6.f90: New test.
* gfortran.dg/gomp/allocate-7.f90: New test.
* gfortran.dg/gomp/allocators-1.f90: New test.
* gfortran.dg/gomp/allocators-2.f90: New test.
gcc/fortran/dump-parse-tree.cc | 8 +-
gcc/fortran/gfortran.h | 9 +-
gcc/fortran/match.cc | 7 +-
gcc/fortran/match.h | 2 +
gcc/fortran/openmp.cc | 328 +++++++++++++++++++++--
gcc/fortran/parse.cc | 184 ++++++++++++-
gcc/fortran/resolve.cc | 6 +
gcc/fortran/st.cc | 2 +
gcc/fortran/trans-openmp.cc | 14 +-
gcc/fortran/trans.cc | 2 +
gcc/testsuite/gfortran.dg/gomp/allocate-2.f90 | 4 +-
gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 | 54 ++++
gcc/testsuite/gfortran.dg/gomp/allocate-5.f90 | 93 +++++++
gcc/testsuite/gfortran.dg/gomp/allocate-6.f90 | 103 +++++++
gcc/testsuite/gfortran.dg/gomp/allocate-7.f90 | 230 ++++++++++++++++
gcc/testsuite/gfortran.dg/gomp/allocators-1.f90 | 28 ++
gcc/testsuite/gfortran.dg/gomp/allocators-2.f90 | 22 ++
libgomp/testsuite/libgomp.fortran/allocate-3.f90 | 2 +-
18 files changed, 1062 insertions(+), 36 deletions(-)
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 5ae72dc1cac..440fb461f46 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -1362,14 +1362,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);
}
@@ -2081,6 +2081,8 @@ show_omp_node (int level, gfc_code *c)
case EXEC_OACC_CACHE: name = "CACHE"; is_oacc = true; break;
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;
@@ -3409,6 +3411,8 @@ show_code_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_ATOMIC:
case EXEC_OMP_CANCEL:
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 219ef8c7612..490c977287e 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -318,6 +318,8 @@ enum gfc_statement
ST_OMP_END_MASKED_TASKLOOP, ST_OMP_MASKED_TASKLOOP_SIMD,
ST_OMP_END_MASKED_TASKLOOP_SIMD, ST_OMP_SCOPE, ST_OMP_END_SCOPE,
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
};
@@ -1362,6 +1364,7 @@ typedef struct gfc_omp_namelist
{
struct gfc_omp_namelist_udr *udr;
gfc_namespace *ns;
+ gfc_expr *allocator;
} u2;
struct gfc_omp_namelist *next;
locus where;
@@ -2174,8 +2177,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. */
@@ -2971,7 +2975,7 @@ 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_ERROR
+ EXEC_OMP_ERROR, EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS
};
typedef struct gfc_code
@@ -3607,6 +3611,7 @@ void gfc_free_omp_declare_simd (gfc_omp_declare_simd *);
void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *);
void gfc_free_omp_udr (gfc_omp_udr *);
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 *);
void gfc_resolve_omp_directive (gfc_code *, gfc_namespace *);
void gfc_resolve_do_iterator (gfc_code *, gfc_symbol *, bool);
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 89fb115c0f6..dce72c91bde 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -5524,17 +5524,20 @@ gfc_free_namelist (gfc_namelist *name)
/* Free an OpenMP namelist structure. */
void
-gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns, bool free_align)
+gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns,
+ bool free_align_allocator)
{
gfc_omp_namelist *n;
for (; name; name = n)
{
gfc_free_expr (name->expr);
- if (free_align)
+ if (free_align_allocator)
gfc_free_expr (name->u.align);
if (free_ns)
gfc_free_namespace (name->u2.ns);
+ else if (free_align_allocator)
+ gfc_free_expr (name->u2.allocator);
else if (name->u2.udr)
{
if (name->u2.udr->combiner)
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 2a805815d9c..488958b439c 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -149,6 +149,8 @@ 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 b71ee467c01..39f3d98caf8 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -54,8 +54,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},
@@ -394,7 +394,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;
@@ -482,6 +483,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;
@@ -1895,7 +1905,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);
@@ -4270,6 +4281,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)
static match
@@ -4284,6 +4297,112 @@ 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.
+ No namelist is denotes by a namelist with 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 (an accidental change). See also
+ the comment on the 'omp allocators' directive below.
+
+ FIXME: Structure elements are rejected for now to make resolving
+ OMP_LIST_ALLOCATE simpler (check for duplicates, same symbol in Fortran
+ allocate stmt) - depending also on the development of the OpenMP spec. */
+
+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, false, true);
+ 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;
+}
+
+/* Note that structure components are not permitted; but see note above for the
+ 'omp allocate' directive above. */
+
+match
+gfc_match_omp_allocators (void)
+{
+ return match_omp (EXEC_OMP_ALLOCATORS, OMP_ALLOCATORS_CLAUSES);
+}
+
match
gfc_match_omp_assume (void)
@@ -6903,6 +7022,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 mapping. */
+
+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. */
@@ -7374,25 +7615,28 @@ resolve_omp_clauses (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)
{
- gfc_error ("ALIGN modifier requires a scalar positive "
+ gfc_error ("ALIGN requires a scalar positive "
"constant integer alignment expression at %L",
&n->u.align->where);
break;
@@ -7404,15 +7648,21 @@ resolve_omp_clauses (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)
@@ -7457,6 +7707,28 @@ resolve_omp_clauses (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;
+ for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
+ {
+ if (n->sym == NULL)
+ 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);
+ }
+ }
+
}
/* OpenACC reductions. */
@@ -7560,15 +7832,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);
}
}
@@ -7932,6 +8202,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
@@ -9626,6 +9902,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:
@@ -10147,6 +10427,8 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
case EXEC_OMP_TEAMS_LOOP:
resolve_omp_do (code);
break;
+ case EXEC_OMP_ALLOCATE:
+ case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_CANCEL:
case EXEC_OMP_ERROR:
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index bc2b2188eea..f8e4c4bcf2b 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -39,6 +39,7 @@ static jmp_buf eof_buf;
gfc_state_data *gfc_state_stack;
static bool last_was_use_stmt = false;
+bool in_exec_part;
/* TODO: Re-order functions to kill these forward decls. */
static void check_statement_label (gfc_statement);
@@ -745,6 +746,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 woulc 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) \
@@ -885,6 +962,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);
matcho ("assumes", gfc_match_omp_assumes, ST_OMP_ASSUMES);
matchs ("assume", gfc_match_omp_assume, ST_OMP_ASSUME);
matcho ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
@@ -915,6 +997,7 @@ decode_omp_directive (void)
break;
case 'e':
matcho ("error", gfc_match_omp_error, ST_OMP_ERROR);
+ matcho ("end allocators", gfc_match_omp_eos_error, ST_OMP_END_ALLOCATORS);
matchs ("end assume", gfc_match_omp_eos_error, ST_OMP_END_ASSUME);
matcho ("end atomic", gfc_match_omp_eos_error, ST_OMP_END_ATOMIC);
matcho ("end critical", gfc_match_omp_end_critical, ST_OMP_END_CRITICAL);
@@ -1171,6 +1254,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.
@@ -1720,7 +1806,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_CRITICAL: \
case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
@@ -1738,7 +1824,7 @@ 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_REDUCTION: \
- case ST_OMP_DECLARE_VARIANT: case ST_OMP_ASSUMES: \
+ case ST_OMP_DECLARE_VARIANT: case ST_OMP_ALLOCATE: case ST_OMP_ASSUMES: \
case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
/* Block end statements. Errors associated with interchanging these
@@ -2359,6 +2445,13 @@ 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;
@@ -2413,6 +2506,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;
@@ -2980,6 +3076,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:
@@ -3053,6 +3150,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:
@@ -5526,6 +5624,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
@@ -5681,6 +5850,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:
@@ -5813,6 +5987,7 @@ static gfc_statement
parse_executable (gfc_statement st)
{
int close_flag;
+ in_exec_part = true;
if (st == ST_NONE)
st = next_statement ();
@@ -5923,6 +6098,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 ST_OMP_ASSUME:
case ST_OMP_PARALLEL:
case ST_OMP_PARALLEL_MASKED:
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 0f5f1d277e4..759fcacf7e8 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -10909,6 +10909,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:
@@ -12384,6 +12386,8 @@ start:
gfc_resolve_oacc_directive (code, ns);
break;
+ case EXEC_OMP_ALLOCATE:
+ case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
@@ -17626,6 +17630,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 8b4ca5ec2ea..978ac0569bb 100644
--- a/gcc/fortran/st.cc
+++ b/gcc/fortran/st.cc
@@ -214,6 +214,8 @@ gfc_free_statement (gfc_code *p)
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_ATOMIC:
case EXEC_OMP_CANCEL:
diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index 395bcc98e00..f9ee107bfcf 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -2716,11 +2716,11 @@ 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_;
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_;
}
@@ -6518,6 +6518,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)
{
@@ -7569,6 +7571,14 @@ gfc_trans_omp_directive (gfc_code *code)
{
switch (code->op)
{
+ case EXEC_OMP_ALLOCATE:
+ case EXEC_OMP_ALLOCATORS:
+ /* Note that the allocate-stmt associated OMP ALLOCATE (but not
+ OMP ALLOCATORS) permits structure elements; however, those are
+ currently rejected directly after parsing. */
+ sorry ("%<!$OMP %s%> not yet supported",
+ code->op == EXEC_OMP_ALLOCATE ? "ALLOCATE" : "ALLOCATORS");
+ return NULL_TREE;
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 8a64882ea9e..9b4fb575572 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -2174,6 +2174,8 @@ trans_code (gfc_code * code, tree cond)
res = gfc_trans_dt_end (code);
break;
+ case EXEC_OMP_ALLOCATE:
+ case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-2.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-2.f90
index 657ff44d023..cc83b5edbce 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 00000000000..a2dcf105ee1
--- /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-5.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-5.f90
new file mode 100644
index 00000000000..bf9c781dcc5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-5.f90
@@ -0,0 +1,93 @@
+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 :: a
+ end type t
+end module my_omp_lib
+
+subroutine zero()
+ !$omp assumes absent (allocators)
+
+ !$omp assume absent (allocators)
+ !$omp end assume
+end
+
+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 flush ! some executable statement
+ !$omp allocate(a) ! { dg-message "not yet supported" }
+ allocate(a,b(4),c(3,4))
+ deallocate(a,b,c)
+
+ !$omp allocate(x1,y1,x2,y2) ! { dg-message "not yet supported" }
+ allocate(x1,y1,x2(5),y2(5))
+ deallocate(x1,y1,x2,y2)
+
+ !$omp allocate(b,a) align ( 128 ) ! { dg-message "not yet supported" }
+ !$omp allocate align ( 64 )
+ allocate(a,b(4),c(3,4))
+ deallocate(a,b,c)
+end
+
+subroutine three(c)
+ use my_omp_lib
+ implicit none
+ integer :: q
+ integer, allocatable :: a, b(:), c(:,:)
+
+ call foo() ! executable stmt
+ !$omp allocate allocator( omp_large_cap_mem_alloc ) , align(64) ! { dg-message "not yet supported" }
+ !$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)
+
+ block
+ q = 5 ! executable stmt
+ !$omp allocate(a) align(64) ! { dg-message "not yet supported" }
+ !$omp allocate(b) allocator( omp_high_bw_mem_alloc ), align(32)
+ !$omp allocate(c) allocator( omp_thread_mem_alloc )
+ 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) ! { dg-message "not yet supported" }
+ !$omp allocate(b) allocator( omp_high_bw_mem_alloc ), align(32)
+ !$omp allocate(c) allocator( omp_thread_mem_alloc )
+ 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
new file mode 100644
index 00000000000..73e5bbcf71b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-6.f90
@@ -0,0 +1,103 @@
+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
+
+subroutine alloc(c,x2,y2)
+ use my_omp_lib
+ implicit none
+ 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
+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 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(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(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(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-7.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90
new file mode 100644
index 00000000000..c46899d8752
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90
@@ -0,0 +1,230 @@
+! { 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 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,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." }
+allocate(qq)
+!$omp allocate (rr) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1." }
+allocate(rr)
+!$omp allocate (ss) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1." }
+allocate(ss)
+!$omp allocate (tt) align(32.0) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1." }
+allocate(tt)
+
+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)
+
+ !$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/allocators-1.f90 b/gcc/testsuite/gfortran.dg/gomp/allocators-1.f90
new file mode 100644
index 00000000000..b39f6d272c1
--- /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 00000000000..6fb80879ef7
--- /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/libgomp/testsuite/libgomp.fortran/allocate-3.f90 b/libgomp/testsuite/libgomp.fortran/allocate-3.f90
index a39819164d6..2e2bc33a726 100644
--- a/libgomp/testsuite/libgomp.fortran/allocate-3.f90
+++ b/libgomp/testsuite/libgomp.fortran/allocate-3.f90
@@ -23,6 +23,6 @@ integer :: q, x,y,z
! { dg-error "Object 'omp_high_bw_mem_alloc' is not a variable" "" { target *-*-* } .-1 }
!$omp end parallel
-!$omp parallel allocate( align(q) : x) firstprivate(x) ! { dg-error "31:ALIGN modifier requires a scalar positive constant integer alignment expression at" }
+!$omp parallel allocate( align(q) : x) firstprivate(x) ! { dg-error "31:ALIGN requires a scalar positive constant integer alignment expression at" }
!$omp end parallel
end
^ permalink raw reply [flat|nested] 3+ messages in thread
* [committed][Patch] Fortran/OpenMP: Add parsing support for allocators/allocate directives
2022-12-21 15:51 ` [Patch] Fortran/OpenMP: Add parsing support for allocators/allocate directive (was: [Patch] Fortran/OpenMP: Add parsing support for allocators directive) Tobias Burnus
@ 2023-05-26 19:04 ` Tobias Burnus
0 siblings, 0 replies; 3+ messages in thread
From: Tobias Burnus @ 2023-05-26 19:04 UTC (permalink / raw)
To: gcc-patches, Jakub Jelinek, fortran
[-- Attachment #1: Type: text/plain, Size: 3596 bytes --]
I have now re-diffed the patch and cleaned up some comments, and spend
some time proof reading it myself. And have now committed it as
r14-1301-gd64e8e1224708e7f5b87c531aeb26f1ed07f91ff
As the subject line states, it adds parsing support for "!$omp allocate"
as declarative directive and (if preceded by an executable
statement/directive) as deprecated alias for '!$omp allocators', which
is also supported. — After successful checking, it fails with the usual
"sorry, not yet implemented".
Like always, comments and suggestions are welcome.
Tobias
PS: The real challenge will be to get 'allocators' working as gfortran
currently calls malloc/free/realloc directly and this will not work well
if memory is allocated differently, e.g., by omp_alloc and friends. But
that's a separate issue, unrelated this parsing + error-diagnostic patch.
Probably simpler, especially for stack variables, would be the support
for the declarative 'allocate' directive (in C/C++/Fortran. Except for
some C++ template-handling polishing, the parsing support is there, but
middle-end wiring is still required.)
PPS: I filed a PR regarding the handling of 'structure elements' with
allocators, https://gcc.gnu.org/PR109998
PPPS: I remarked before:
On 21.12.22 16:51, Tobias Burnus wrote:
> On 14.12.22 11:47, Tobias Burnus wrote:
>
>> This patch adds parsing/argument-checking support for
>> '!$omp allocators allocate([align(int),allocator(a) :] list)'
>
> This follow-up patch additionally adds parsing support for both
> declarative and allocate-stmt-associated '!$omp allocate' directives –
> and replaces my previous patch.
>
> OK for mainline?
>
> * * *
>
> The code requires in line with OpenMP 5.1 that an executable statement
> comes before an '!$omp allocate' that is associated with a Fortran
> ALLOCATE stmt, which is diagnosed.
>
> Note: There is a spec change/regression related to permitting structure
> elements; while OpenMP 5.0/5.1 did permit them in the
> allocate-stmt-associated "!$omp allocate", OpenMP 5.2 stopped doing –
> and '!$omp allocators' never permitted it. — For allocate that's seems
> to be the accidental result from "permitted unless stated otherwise" to
> "rejected unless stated otherwise". For 'allocators', it is the result
> of the original 'allocate' clause which should have been extended for
> 'allocators' - or should not.
>
> In any case, that's tracked now in OpenMP's spec issue #3437.
>
> Thoughts? – The code rejects var%comp and var(1)%comp etc. for now –
> besides the unclear spec status, I admittedly did this also to make
> checking easier (like for duplicated entries, entry same as in ALLOCATE
> except for tailing array spec etc.).
>
> * * *
>
> This patch replaced both my previous patch in this thread and also
> Abid's patch
>
>> "[PATCH 1/5] [gfortran] Add parsing support for allocate directive
>> (OpenMP 5.0)."
>> https://gcc.gnu.org/pipermail/gcc-patches/2022-October/603258.html
>
> In his patch set, later patches actually add allocater support for
> allocatables/pointers, only – but there issues with regards to the used
> allocator (see patches + patch review).
>
> As my attached patch raises a sorry, it neither addresses that issue nor
> is it affected by that issue.
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
[-- Attachment #2: committed.diff --]
[-- Type: text/x-patch, Size: 67750 bytes --]
commit d64e8e1224708e7f5b87c531aeb26f1ed07f91ff
Author: Tobias Burnus <tobias@codesourcery.com>
Date: Fri May 26 20:39:33 2023 +0200
Fortran/OpenMP: Add parsing support for allocators/allocate directives
gcc/fortran/ChangeLog:
* dump-parse-tree.cc (show_omp_namelist): Update allocator, fix
align dump.
(show_omp_node, show_code_node): Handle EXEC_OMP_ALLOCATE.
* gfortran.h (enum gfc_statement): Add ST_OMP_ALLOCATE and ..._EXEC.
(enum gfc_exec_op): Add EXEC_OMP_ALLOCATE.
(struct gfc_omp_namelist): Add 'allocator' to 'u2' union.
(struct gfc_namespace): Add omp_allocate.
(gfc_resolve_omp_allocate): New.
* match.cc (gfc_free_omp_namelist): Free 'u2.allocator'.
* match.h (gfc_match_omp_allocate, gfc_match_omp_allocators): New.
* openmp.cc (gfc_omp_directives): Uncomment allocate/allocators.
(gfc_match_omp_variable_list): Add bool arg for
rejecting listening common-block vars separately.
(gfc_match_omp_clauses): Update for u2.allocators.
(OMP_ALLOCATORS_CLAUSES, gfc_match_omp_allocate,
gfc_match_omp_allocators, is_predefined_allocator,
gfc_resolve_omp_allocate): New.
(resolve_omp_clauses): Update 'allocate' clause checks.
(omp_code_to_statement, gfc_resolve_omp_directive): Handle
OMP ALLOCATE/ALLOCATORS.
* parse.cc (in_exec_part): New global var.
(check_omp_allocate_stmt, parse_openmp_allocate_block): New.
(decode_omp_directive, case_exec_markers, case_omp_decl,
gfc_ascii_statement, parse_omp_structured_block): Handle
OMP allocate/allocators.
(verify_st_order, parse_executable): Set in_exec_part.
* resolve.cc (gfc_resolve_blocks, resolve_codes): Handle
allocate/allocators.
* st.cc (gfc_free_statement): Likewise.
* trans.cc (trans_code): Likewise.
* trans-openmp.cc (gfc_trans_omp_directive): Likewise.
(gfc_trans_omp_clauses, gfc_split_omp_clauses): Update for
u2.allocator, fix for u.align.
libgomp/ChangeLog:
* testsuite/libgomp.fortran/allocate-4.f90: Update dg-error.
gcc/testsuite/ChangeLog:
* gfortran.dg/gomp/allocate-2.f90: Update dg-error.
* gfortran.dg/gomp/allocate-4.f90: New test.
* gfortran.dg/gomp/allocate-5.f90: New test.
* gfortran.dg/gomp/allocate-6.f90: New test.
* gfortran.dg/gomp/allocate-7.f90: New test.
* gfortran.dg/gomp/allocators-1.f90: New test.
* gfortran.dg/gomp/allocators-2.f90: New test.
---
gcc/fortran/dump-parse-tree.cc | 8 +-
gcc/fortran/gfortran.h | 9 +-
gcc/fortran/match.cc | 7 +-
gcc/fortran/match.h | 2 +
gcc/fortran/openmp.cc | 333 +++++++++++++++++++++--
gcc/fortran/parse.cc | 184 ++++++++++++-
gcc/fortran/resolve.cc | 6 +
gcc/fortran/st.cc | 2 +
gcc/fortran/trans-openmp.cc | 11 +-
gcc/fortran/trans.cc | 2 +
gcc/testsuite/gfortran.dg/gomp/allocate-2.f90 | 4 +-
gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 | 54 ++++
gcc/testsuite/gfortran.dg/gomp/allocate-5.f90 | 93 +++++++
gcc/testsuite/gfortran.dg/gomp/allocate-6.f90 | 103 +++++++
gcc/testsuite/gfortran.dg/gomp/allocate-7.f90 | 231 ++++++++++++++++
gcc/testsuite/gfortran.dg/gomp/allocators-1.f90 | 28 ++
gcc/testsuite/gfortran.dg/gomp/allocators-2.f90 | 22 ++
libgomp/testsuite/libgomp.fortran/allocate-4.f90 | 12 +-
18 files changed, 1068 insertions(+), 43 deletions(-)
diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc
index 644f8f37d63..6d75cc29f60 100644
--- a/gcc/fortran/dump-parse-tree.cc
+++ b/gcc/fortran/dump-parse-tree.cc
@@ -1377,14 +1377,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);
}
@@ -2096,6 +2096,8 @@ show_omp_node (int level, gfc_code *c)
case EXEC_OACC_CACHE: name = "CACHE"; is_oacc = true; break;
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;
@@ -3424,6 +3426,8 @@ show_code_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_ATOMIC:
case EXEC_OMP_CANCEL:
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 8cfa8fd3afd..3e5f942d7fd 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -318,6 +318,8 @@ enum gfc_statement
ST_OMP_END_MASKED_TASKLOOP, ST_OMP_MASKED_TASKLOOP_SIMD,
ST_OMP_END_MASKED_TASKLOOP_SIMD, ST_OMP_SCOPE, ST_OMP_END_SCOPE,
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
};
@@ -1365,6 +1367,7 @@ typedef struct gfc_omp_namelist
{
struct gfc_omp_namelist_udr *udr;
gfc_namespace *ns;
+ gfc_expr *allocator;
} u2;
struct gfc_omp_namelist *next;
locus where;
@@ -2177,8 +2180,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. */
@@ -2974,7 +2978,7 @@ 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_ERROR
+ EXEC_OMP_ERROR, EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS
};
typedef struct gfc_code
@@ -3613,6 +3617,7 @@ void gfc_free_omp_declare_simd (gfc_omp_declare_simd *);
void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *);
void gfc_free_omp_udr (gfc_omp_udr *);
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 *);
void gfc_resolve_omp_directive (gfc_code *, gfc_namespace *);
void gfc_resolve_do_iterator (gfc_code *, gfc_symbol *, bool);
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index d59daf5a581..e7be7fddc64 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -5534,17 +5534,20 @@ gfc_free_namelist (gfc_namelist *name)
/* Free an OpenMP namelist structure. */
void
-gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns, bool free_align)
+gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns,
+ bool free_align_allocator)
{
gfc_omp_namelist *n;
for (; name; name = n)
{
gfc_free_expr (name->expr);
- if (free_align)
+ if (free_align_allocator)
gfc_free_expr (name->u.align);
if (free_ns)
gfc_free_namespace (name->u2.ns);
+ else if (free_align_allocator)
+ gfc_free_expr (name->u2.allocator);
else if (name->u2.udr)
{
if (name->u2.udr->combiner)
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 4430aff001c..7d72725ed3c 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -149,6 +149,8 @@ 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 81cdf1b42e5..4c30548567f 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -54,8 +54,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},
@@ -394,7 +394,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;
@@ -482,6 +483,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;
@@ -1895,7 +1905,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);
@@ -4270,6 +4281,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)
static match
@@ -4284,6 +4297,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, false, true);
+ 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)
@@ -6903,6 +7023,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. */
@@ -7376,28 +7618,31 @@ resolve_omp_clauses (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;
}
}
@@ -7407,15 +7652,21 @@ resolve_omp_clauses (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)
@@ -7460,6 +7711,28 @@ resolve_omp_clauses (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;
+ for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
+ {
+ if (n->sym == NULL)
+ 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);
+ }
+ }
+
}
/* OpenACC reductions. */
@@ -7563,15 +7836,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);
}
}
@@ -7951,6 +8222,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
@@ -9667,6 +9944,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:
@@ -10188,6 +10469,8 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
case EXEC_OMP_TEAMS_LOOP:
resolve_omp_do (code);
break;
+ case EXEC_OMP_ALLOCATE:
+ case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_CANCEL:
case EXEC_OMP_ERROR:
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 5e2a95688d2..9730ab095e2 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -39,6 +39,7 @@ static jmp_buf eof_buf;
gfc_state_data *gfc_state_stack;
static bool last_was_use_stmt = false;
+bool in_exec_part;
/* TODO: Re-order functions to kill these forward decls. */
static void check_statement_label (gfc_statement);
@@ -745,6 +746,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) \
@@ -885,6 +962,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;
@@ -918,6 +1000,7 @@ decode_omp_directive (void)
break;
case 'e':
matcho ("error", gfc_match_omp_error, ST_OMP_ERROR);
+ matcho ("end allocators", gfc_match_omp_eos_error, ST_OMP_END_ALLOCATORS);
matchs ("end assume", gfc_match_omp_eos_error, ST_OMP_END_ASSUME);
matcho ("end atomic", gfc_match_omp_eos_error, ST_OMP_END_ATOMIC);
matcho ("end critical", gfc_match_omp_end_critical, ST_OMP_END_CRITICAL);
@@ -1174,6 +1257,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.
@@ -1723,7 +1809,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_CRITICAL: \
case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
@@ -1741,7 +1827,7 @@ 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_REDUCTION: \
- case ST_OMP_DECLARE_VARIANT: case ST_OMP_ASSUMES: \
+ case ST_OMP_DECLARE_VARIANT: case ST_OMP_ALLOCATE: case ST_OMP_ASSUMES: \
case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
/* Block end statements. Errors associated with interchanging these
@@ -2362,6 +2448,13 @@ 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;
@@ -2416,6 +2509,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;
@@ -2983,6 +3079,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:
@@ -3056,6 +3153,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:
@@ -5532,6 +5630,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
@@ -5687,6 +5856,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:
@@ -5819,6 +5993,7 @@ static gfc_statement
parse_executable (gfc_statement st)
{
int close_flag;
+ in_exec_part = true;
if (st == ST_NONE)
st = next_statement ();
@@ -5929,6 +6104,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 ST_OMP_ASSUME:
case ST_OMP_PARALLEL:
case ST_OMP_PARALLEL_MASKED:
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 83e45f1b693..75d61a18856 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -11044,6 +11044,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:
@@ -12712,6 +12714,8 @@ start:
gfc_resolve_oacc_directive (code, ns);
break;
+ case EXEC_OMP_ALLOCATE:
+ case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
@@ -18007,6 +18011,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 657bc9deebf..55debca8e0b 100644
--- a/gcc/fortran/st.cc
+++ b/gcc/fortran/st.cc
@@ -214,6 +214,8 @@ gfc_free_statement (gfc_code *p)
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_ATOMIC:
case EXEC_OMP_CANCEL:
diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index c66bedd9f7a..42b608f3d36 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -2748,11 +2748,11 @@ 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_;
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_;
}
@@ -6861,6 +6861,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)
{
@@ -7912,6 +7914,11 @@ gfc_trans_omp_directive (gfc_code *code)
{
switch (code->op)
{
+ case EXEC_OMP_ALLOCATE:
+ case EXEC_OMP_ALLOCATORS:
+ sorry ("%<!$OMP %s%> not yet supported",
+ code->op == EXEC_OMP_ALLOCATE ? "ALLOCATE" : "ALLOCATORS");
+ return NULL_TREE;
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 0b32b6896cd..7ad85aee9e7 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -2453,6 +2453,8 @@ trans_code (gfc_code * code, tree cond)
res = gfc_trans_dt_end (code);
break;
+ case EXEC_OMP_ALLOCATE:
+ case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-2.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-2.f90
index 657ff44d023..cc83b5edbce 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 00000000000..a2dcf105ee1
--- /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-5.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-5.f90
new file mode 100644
index 00000000000..bf9c781dcc5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-5.f90
@@ -0,0 +1,93 @@
+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 :: a
+ end type t
+end module my_omp_lib
+
+subroutine zero()
+ !$omp assumes absent (allocators)
+
+ !$omp assume absent (allocators)
+ !$omp end assume
+end
+
+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 flush ! some executable statement
+ !$omp allocate(a) ! { dg-message "not yet supported" }
+ allocate(a,b(4),c(3,4))
+ deallocate(a,b,c)
+
+ !$omp allocate(x1,y1,x2,y2) ! { dg-message "not yet supported" }
+ allocate(x1,y1,x2(5),y2(5))
+ deallocate(x1,y1,x2,y2)
+
+ !$omp allocate(b,a) align ( 128 ) ! { dg-message "not yet supported" }
+ !$omp allocate align ( 64 )
+ allocate(a,b(4),c(3,4))
+ deallocate(a,b,c)
+end
+
+subroutine three(c)
+ use my_omp_lib
+ implicit none
+ integer :: q
+ integer, allocatable :: a, b(:), c(:,:)
+
+ call foo() ! executable stmt
+ !$omp allocate allocator( omp_large_cap_mem_alloc ) , align(64) ! { dg-message "not yet supported" }
+ !$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)
+
+ block
+ q = 5 ! executable stmt
+ !$omp allocate(a) align(64) ! { dg-message "not yet supported" }
+ !$omp allocate(b) allocator( omp_high_bw_mem_alloc ), align(32)
+ !$omp allocate(c) allocator( omp_thread_mem_alloc )
+ 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) ! { dg-message "not yet supported" }
+ !$omp allocate(b) allocator( omp_high_bw_mem_alloc ), align(32)
+ !$omp allocate(c) allocator( omp_thread_mem_alloc )
+ 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
new file mode 100644
index 00000000000..73e5bbcf71b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-6.f90
@@ -0,0 +1,103 @@
+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
+
+subroutine alloc(c,x2,y2)
+ use my_omp_lib
+ implicit none
+ 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
+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 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(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(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(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-7.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90
new file mode 100644
index 00000000000..b856204d48a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90
@@ -0,0 +1,231 @@
+! { 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 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,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)
+
+ !$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/allocators-1.f90 b/gcc/testsuite/gfortran.dg/gomp/allocators-1.f90
new file mode 100644
index 00000000000..b39f6d272c1
--- /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 00000000000..6fb80879ef7
--- /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/libgomp/testsuite/libgomp.fortran/allocate-4.f90 b/libgomp/testsuite/libgomp.fortran/allocate-4.f90
index ddb507ba8e4..1f833b6e70f 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
^ permalink raw reply [flat|nested] 3+ messages in thread
end of thread, other threads:[~2023-05-26 19:04 UTC | newest]
Thread overview: 3+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-12-14 10:47 [Patch] Fortran/OpenMP: Add parsing support for allocators directive Tobias Burnus
2022-12-21 15:51 ` [Patch] Fortran/OpenMP: Add parsing support for allocators/allocate directive (was: [Patch] Fortran/OpenMP: Add parsing support for allocators directive) Tobias Burnus
2023-05-26 19:04 ` [committed][Patch] Fortran/OpenMP: Add parsing support for allocators/allocate directives 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).