From: Tobias Burnus <tobias@codesourcery.com>
To: gcc-patches <gcc-patches@gcc.gnu.org>,
Jakub Jelinek <jakub@redhat.com>, fortran <fortran@gcc.gnu.org>
Subject: [committed][Patch] Fortran/OpenMP: Add parsing support for allocators/allocate directives
Date: Fri, 26 May 2023 21:04:15 +0200 [thread overview]
Message-ID: <62df6b76-56ad-4e8b-802f-5f70bba4f198@codesourcery.com> (raw)
In-Reply-To: <7839f6c0-2ea2-eab5-4660-111dec7cfcb2@codesourcery.com>
[-- 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
prev parent reply other threads:[~2023-05-26 19:04 UTC|newest]
Thread overview: 3+ messages / expand[flat|nested] mbox.gz Atom feed top
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 ` Tobias Burnus [this message]
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=62df6b76-56ad-4e8b-802f-5f70bba4f198@codesourcery.com \
--to=tobias@codesourcery.com \
--cc=fortran@gcc.gnu.org \
--cc=gcc-patches@gcc.gnu.org \
--cc=jakub@redhat.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
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).