From: Thomas Schwinge <thomas@codesourcery.com>
To: Tobias Burnus <tobias@codesourcery.com>
Cc: Jakub Jelinek <jakub@redhat.com>, <gcc-patches@gcc.gnu.org>,
<fortran@gcc.gnu.org>
Subject: Re: [Patch] Fortran: Support OpenMP's 'allocate' directive for stack vars
Date: Wed, 18 Oct 2023 11:12:44 +0200 [thread overview]
Message-ID: <87wmvkuwdv.fsf@euler.schwinge.homeip.net> (raw)
In-Reply-To: <7f16971c-ff06-4e48-85e2-5b38828b7bc2@codesourcery.com>
Hi Tobias!
On 2023-10-13T15:29:52+0200, Tobias Burnus <tobias@codesourcery.com> wrote:
> => Updated patch attached
When cherry-picking this commit cccc2d3dbf0eff668bed5f5f168b3cafd8590c54
"Fortran: Support OpenMP's 'allocate' directive for stack vars" on top of
slightly older GCC sources (mentioning that just in case that's
relevant), in a configuration with offloading enabled (only), I see:
+FAIL: gfortran.dg/gomp/allocate-13.f90 -O (internal compiler error: tree code 'statement_list' is not supported in LTO streams)
+FAIL: gfortran.dg/gomp/allocate-13.f90 -O (test for excess errors)
during IPA pass: modref
[...]/gcc/testsuite/gfortran.dg/gomp/allocate-13.f90:10:3: internal compiler error: tree code 'statement_list' is not supported in LTO streams
0x13374fd lto_write_tree
[...]/gcc/lto-streamer-out.cc:561
0x13374fd lto_output_tree_1
[...]/gcc/lto-streamer-out.cc:599
0x133f55b DFS::DFS(output_block*, tree_node*, bool, bool, bool)
[...]/gcc/lto-streamer-out.cc:899
0x1340287 lto_output_tree(output_block*, tree_node*, bool, bool)
[...]/gcc/lto-streamer-out.cc:1865
0x134197a output_function
[...]/gcc/lto-streamer-out.cc:2436
0x134197a lto_output()
[...]/gcc/lto-streamer-out.cc:2807
0x13d0551 write_lto
[...]/gcc/passes.cc:2774
0x13d0551 ipa_write_summaries_1
[...]/gcc/passes.cc:2838
0x13d0551 ipa_write_summaries()
[...]/gcc/passes.cc:2894
0x1002f2c ipa_passes
[...]/gcc/cgraphunit.cc:2251
0x1002f2c symbol_table::compile()
[...]/gcc/cgraphunit.cc:2331
0x10056b7 symbol_table::compile()
[...]/gcc/cgraphunit.cc:2311
0x10056b7 symbol_table::finalize_compilation_unit()
[...]/gcc/cgraphunit.cc:2583
Similarly:
+FAIL: libgomp.fortran/allocate-6.f90 -O (internal compiler error: tree code 'statement_list' is not supported in LTO streams)
+FAIL: libgomp.fortran/allocate-7.f90 -O (internal compiler error: tree code 'statement_list' is not supported in LTO streams)
Grüße
Thomas
> Fortran: Support OpenMP's 'allocate' directive for stack vars
>
> gcc/fortran/ChangeLog:
>
> * gfortran.h (ext_attr_t): Add omp_allocate flag.
> * match.cc (gfc_free_omp_namelist): Void deleting same
> u2.allocator multiple times now that a sequence can use
> the same one.
> * openmp.cc (gfc_match_omp_clauses, gfc_match_omp_allocate): Use
> same allocator expr multiple times.
> (is_predefined_allocator): Make static.
> (gfc_resolve_omp_allocate): Update/extend restriction checks;
> remove sorry message.
> (resolve_omp_clauses): Reject corarrays in allocate/allocators
> directive.
> * parse.cc (check_omp_allocate_stmt): Permit procedure pointers
> here (rejected later) for less misleading diagnostic.
> * trans-array.cc (gfc_trans_auto_array_allocation): Propagate
> size for GOMP_alloc and location to which it should be added to.
> * trans-decl.cc (gfc_trans_deferred_vars): Handle 'omp allocate'
> for stack variables; sorry for static variables/common blocks.
> * trans-openmp.cc (gfc_trans_omp_clauses): Evaluate 'allocate'
> clause's allocator only once; fix adding expressions to the
> block.
> (gfc_trans_omp_single): Pass a block to gfc_trans_omp_clauses.
>
> gcc/ChangeLog:
>
> * gimplify.cc (gimplify_bind_expr): Handle Fortran's
> 'omp allocate' for stack variables.
>
> libgomp/ChangeLog:
>
> * libgomp.texi (OpenMP Impl. Status): Mention that Fortran now
> supports the allocate directive for stack variables.
> * testsuite/libgomp.fortran/allocate-5.f90: New test.
> * testsuite/libgomp.fortran/allocate-6.f90: New test.
> * testsuite/libgomp.fortran/allocate-7.f90: New test.
> * testsuite/libgomp.fortran/allocate-8.f90: New test.
>
> gcc/testsuite/ChangeLog:
>
> * c-c++-common/gomp/allocate-14.c: Fix directive name.
> * c-c++-common/gomp/allocate-15.c: Likewise.
> * c-c++-common/gomp/allocate-9.c: Fix comment typo.
> * gfortran.dg/gomp/allocate-4.f90: Remove sorry dg-error.
> * gfortran.dg/gomp/allocate-7.f90: Likewise.
> * gfortran.dg/gomp/allocate-10.f90: New test.
> * gfortran.dg/gomp/allocate-11.f90: New test.
> * gfortran.dg/gomp/allocate-12.f90: New test.
> * gfortran.dg/gomp/allocate-13.f90: New test.
> * gfortran.dg/gomp/allocate-14.f90: New test.
> * gfortran.dg/gomp/allocate-15.f90: New test.
> * gfortran.dg/gomp/allocate-8.f90: New test.
> * gfortran.dg/gomp/allocate-9.f90: New test.
>
> gcc/fortran/gfortran.h | 1 +
> gcc/fortran/match.cc | 9 +-
> gcc/fortran/openmp.cc | 62 +++-
> gcc/fortran/parse.cc | 8 +-
> gcc/fortran/trans-array.cc | 28 +-
> gcc/fortran/trans-decl.cc | 126 +++++++++
> gcc/fortran/trans-openmp.cc | 77 +++--
> gcc/gimplify.cc | 166 ++++++++---
> gcc/testsuite/c-c++-common/gomp/allocate-14.c | 2 +-
> gcc/testsuite/c-c++-common/gomp/allocate-15.c | 2 +-
> gcc/testsuite/c-c++-common/gomp/allocate-9.c | 2 +-
> gcc/testsuite/gfortran.dg/gomp/allocate-10.f90 | 75 +++++
> gcc/testsuite/gfortran.dg/gomp/allocate-11.f90 | 33 +++
> gcc/testsuite/gfortran.dg/gomp/allocate-12.f90 | 24 ++
> gcc/testsuite/gfortran.dg/gomp/allocate-13.f90 | 25 ++
> gcc/testsuite/gfortran.dg/gomp/allocate-14.f90 | 95 +++++++
> gcc/testsuite/gfortran.dg/gomp/allocate-15.f90 | 38 +++
> gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 | 4 +-
> gcc/testsuite/gfortran.dg/gomp/allocate-7.f90 | 10 -
> gcc/testsuite/gfortran.dg/gomp/allocate-8.f90 | 29 ++
> gcc/testsuite/gfortran.dg/gomp/allocate-9.f90 | 112 ++++++++
> libgomp/libgomp.texi | 4 +-
> libgomp/testsuite/libgomp.fortran/allocate-5.f90 | 87 ++++++
> libgomp/testsuite/libgomp.fortran/allocate-6.f90 | 123 ++++++++
> libgomp/testsuite/libgomp.fortran/allocate-7.f90 | 342 +++++++++++++++++++++++
> libgomp/testsuite/libgomp.fortran/allocate-8.f90 | 99 +++++++
> 26 files changed, 1484 insertions(+), 99 deletions(-)
>
> diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
> index 6caf7765ac6..88f33b0957e 100644
> --- a/gcc/fortran/gfortran.h
> +++ b/gcc/fortran/gfortran.h
> @@ -1000,6 +1000,7 @@ typedef struct
> unsigned omp_declare_target:1;
> unsigned omp_declare_target_link:1;
> ENUM_BITFIELD (gfc_omp_device_type) omp_device_type:2;
> + unsigned omp_allocate:1;
>
> /* Mentioned in OACC DECLARE. */
> unsigned oacc_declare_create:1;
> diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
> index c926f38058f..148a86bb436 100644
> --- a/gcc/fortran/match.cc
> +++ b/gcc/fortran/match.cc
> @@ -5541,6 +5541,7 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns,
> bool free_mem_traits_space)
> {
> gfc_omp_namelist *n;
> + gfc_expr *last_allocator = NULL;
>
> for (; name; name = n)
> {
> @@ -5552,7 +5553,13 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns,
> if (free_ns)
> gfc_free_namespace (name->u2.ns);
> else if (free_align_allocator)
> - gfc_free_expr (name->u2.allocator);
> + {
> + if (last_allocator != name->u2.allocator)
> + {
> + last_allocator = name->u2.allocator;
> + gfc_free_expr (name->u2.allocator);
> + }
> + }
> else if (free_mem_traits_space)
> { } /* name->u2.traits_sym: shall not call gfc_free_symbol here. */
> else if (name->u2.udr)
> diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
> index 79b5ae0e4bd..1cc65d7fa49 100644
> --- a/gcc/fortran/openmp.cc
> +++ b/gcc/fortran/openmp.cc
> @@ -2032,11 +2032,9 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
>
> for (gfc_omp_namelist *n = *head; n; n = n->next)
> {
> - n->u2.allocator = ((allocator)
> - ? gfc_copy_expr (allocator) : NULL);
> + n->u2.allocator = allocator;
> n->u.align = (align) ? gfc_copy_expr (align) : NULL;
> }
> - gfc_free_expr (allocator);
> gfc_free_expr (align);
> continue;
> }
> @@ -4547,9 +4545,8 @@ gfc_match_omp_allocate (void)
> for (; vars; vars = vars->next)
> {
> vars->u.align = (align) ? gfc_copy_expr (align) : NULL;
> - vars->u2.allocator = ((allocator) ? gfc_copy_expr (allocator) : NULL);
> + vars->u2.allocator = allocator;
> }
> - gfc_free_expr (allocator);
> gfc_free_expr (align);
> }
> return MATCH_YES;
> @@ -7191,7 +7188,7 @@ resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
> /* 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
> +static bool
> is_predefined_allocator (gfc_expr *expr)
> {
> return (gfc_resolve_expr (expr)
> @@ -7209,10 +7206,20 @@ is_predefined_allocator (gfc_expr *expr)
> 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.result || n->sym->result == n->sym)
> + {
> + gfc_error ("Unexpected function-result variable %qs at %L in "
> + "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
> + continue;
> + }
> + if (ns->omp_allocate->sym->attr.proc_pointer)
> + {
> + gfc_error ("Procedure pointer %qs not supported with !$OMP "
> + "ALLOCATE at %L", n->sym->name, &n->where);
> + continue;
> + }
> if (n->sym->attr.flavor != FL_VARIABLE)
> {
> gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE "
> @@ -7220,8 +7227,7 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
> &n->where);
> continue;
> }
> - if (ns != n->sym->ns || n->sym->attr.use_assoc
> - || n->sym->attr.host_assoc || n->sym->attr.imported)
> + if (ns != n->sym->ns || n->sym->attr.use_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",
> @@ -7234,7 +7240,13 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
> "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
> continue;
> }
> - if (n->sym->mark)
> + if (n->sym->attr.codimension)
> + {
> + gfc_error ("Unexpected coarray argument %qs as argument at %L to "
> + "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
> + continue;
> + }
> + if (n->sym->attr.omp_allocate)
> {
> if (n->sym->attr.in_common)
> {
> @@ -7249,7 +7261,28 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
> n->sym->name, &n->where);
> continue;
> }
> - n->sym->mark = 1;
> + /* For 'equivalence(a,b)', a 'union_type {<type> a,b} equiv.0' is created
> + with a value expression for 'a' as 'equiv.0.a' (likewise for b); while
> + this can be handled, EQUIVALENCE is marked as obsolescent since Fortran
> + 2018 and also not widely used. However, it could be supported,
> + if needed. */
> + if (n->sym->attr.in_equivalence)
> + {
> + gfc_error ("Sorry, EQUIVALENCE object %qs not supported with !$OMP "
> + "ALLOCATE at %L", n->sym->name, &n->where);
> + continue;
> + }
> + /* Similar for Cray pointer/pointee - they could be implemented but as
> + common vendor extension but nowadays rarely used and requiring
> + -fcray-pointer, there is no need to support them. */
> + if (n->sym->attr.cray_pointer || n->sym->attr.cray_pointee)
> + {
> + gfc_error ("Sorry, Cray pointers and pointees such as %qs are not "
> + "supported with !$OMP ALLOCATE at %L",
> + n->sym->name, &n->where);
> + continue;
> + }
> + n->sym->attr.omp_allocate = 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))
> @@ -7307,8 +7340,6 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
> "%<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
> @@ -7897,6 +7928,9 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
> {
> if (n->sym == NULL)
> continue;
> + if (n->sym->attr.codimension)
> + gfc_error ("Unexpected coarray %qs in %<allocate%> at %L",
> + n->sym->name, &n->where);
> 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)
> diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
> index 444baf42cbd..e103ebee557 100644
> --- a/gcc/fortran/parse.cc
> +++ b/gcc/fortran/parse.cc
> @@ -833,18 +833,18 @@ check_omp_allocate_stmt (locus *loc)
> &n->expr->where, gfc_ascii_statement (ST_OMP_ALLOCATE));
> return false;
> }
> + /* Procedure pointers are not allocatable; hence, we do not regard them as
> + pointers here - and reject them later in gfc_resolve_omp_allocate. */
> 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);
> + alloc_ptr = n->sym->attr.allocatable || n->sym->attr.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)))
> + || n->sym->ns->proc_name->attr.pointer)))
> has_allocatable = true;
> else
> has_non_allocatable = true;
> diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
> index 8e94a9a469f..bbb81f40aa9 100644
> --- a/gcc/fortran/trans-array.cc
> +++ b/gcc/fortran/trans-array.cc
> @@ -82,6 +82,9 @@ along with GCC; see the file COPYING3. If not see
> #include "tree.h"
> #include "gfortran.h"
> #include "gimple-expr.h"
> +#include "tree-iterator.h"
> +#include "stringpool.h" /* Required by "attribs.h". */
> +#include "attribs.h" /* For lookup_attribute. */
> #include "trans.h"
> #include "fold-const.h"
> #include "constructor.h"
> @@ -6770,6 +6773,15 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
> gimplifier to allocate storage, and all that good stuff. */
> tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
> gfc_add_expr_to_block (&init, tmp);
> + if (sym->attr.omp_allocate)
> + {
> + /* Save location of size calculation to ensure GOMP_alloc is placed
> + after it. */
> + tree omp_alloc = lookup_attribute ("omp allocate",
> + DECL_ATTRIBUTES (decl));
> + TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
> + = build_tree_list (NULL_TREE, tsi_stmt (tsi_last (init.head)));
> + }
> }
>
> if (onstack)
> @@ -6798,8 +6810,22 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
> gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
> return;
> }
> + if (sym->attr.omp_allocate)
> + {
> + /* The size is the number of elements in the array, so multiply by the
> + size of an element to get the total size. */
> + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
> + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
> + size, fold_convert (gfc_array_index_type, tmp));
> + size = gfc_evaluate_now (size, &init);
>
> - if (flag_stack_arrays)
> + tree omp_alloc = lookup_attribute ("omp allocate",
> + DECL_ATTRIBUTES (decl));
> + TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
> + = build_tree_list (size, NULL_TREE);
> + space = NULL_TREE;
> + }
> + else if (flag_stack_arrays)
> {
> gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
> space = build_decl (gfc_get_location (&sym->declared_at),
> diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
> index b0fd25e92a3..a3f037bd07b 100644
> --- a/gcc/fortran/trans-decl.cc
> +++ b/gcc/fortran/trans-decl.cc
> @@ -48,6 +48,7 @@ along with GCC; see the file COPYING3. If not see
> #include "gimplify.h"
> #include "omp-general.h"
> #include "attr-fnspec.h"
> +#include "tree-iterator.h"
>
> #define MAX_LABEL_VALUE 99999
>
> @@ -4652,6 +4653,36 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
> init_intent_out_dt (proc_sym, block);
> gfc_restore_backend_locus (&loc);
>
> + /* For some reasons, internal procedures point to the parent's
> + namespace. Top-level procedure and variables inside BLOCK are fine. */
> + gfc_namespace *omp_ns = proc_sym->ns;
> + if (proc_sym->ns->proc_name != proc_sym)
> + for (omp_ns = proc_sym->ns->contained; omp_ns;
> + omp_ns = omp_ns->sibling)
> + if (omp_ns->proc_name == proc_sym)
> + break;
> +
> + /* Add 'omp allocate' attribute for gfc_trans_auto_array_allocation and
> + unset attr.omp_allocate for 'omp allocate allocator(omp_default_mem_alloc),
> + which has the normal codepath except for an invalid-use check in the ME.
> + The main processing happens later in this function. */
> + for (struct gfc_omp_namelist *n = omp_ns ? omp_ns->omp_allocate : NULL;
> + n; n = n->next)
> + if (!TREE_STATIC (n->sym->backend_decl))
> + {
> + /* Add empty entries - described and to be filled below. */
> + tree tmp = build_tree_list (NULL_TREE, NULL_TREE);
> + TREE_CHAIN (tmp) = build_tree_list (NULL_TREE, NULL_TREE);
> + DECL_ATTRIBUTES (n->sym->backend_decl)
> + = tree_cons (get_identifier ("omp allocate"), tmp,
> + DECL_ATTRIBUTES (n->sym->backend_decl));
> + if (n->u.align == NULL
> + && n->u2.allocator != NULL
> + && n->u2.allocator->expr_type == EXPR_CONSTANT
> + && mpz_cmp_si (n->u2.allocator->value.integer, 1) == 0)
> + n->sym->attr.omp_allocate = 0;
> + }
> +
> for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
> {
> bool alloc_comp_or_fini = (sym->ts.type == BT_DERIVED)
> @@ -5105,6 +5136,101 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
> gcc_unreachable ();
> }
>
> + /* Handle 'omp allocate'. This has to be after the block above as
> + gfc_add_init_cleanup (..., init, ...) puts 'init' of later calls
> + before earlier calls. The code is a bit more complex as gfortran does
> + not really work with bind expressions / BIND_EXPR_VARS properly, i.e.
> + gimplify_bind_expr needs some help for placing the GOMP_alloc. Thus,
> + we pass on the location of the allocate-assignment expression and,
> + if the size is not constant, the size variable if Fortran computes this
> + differently. We also might add an expression location after which the
> + code has to be added, e.g. for character len expressions, which affect
> + the UNIT_SIZE. */
> + gfc_expr *last_allocator = NULL;
> + if (omp_ns && omp_ns->omp_allocate)
> + {
> + if (!block->init || TREE_CODE (block->init) != STATEMENT_LIST)
> + {
> + tree tmp = build1_v (LABEL_EXPR, gfc_build_label_decl (NULL_TREE));
> + append_to_statement_list (tmp, &block->init);
> + }
> + if (!block->cleanup || TREE_CODE (block->cleanup) != STATEMENT_LIST)
> + {
> + tree tmp = build1_v (LABEL_EXPR, gfc_build_label_decl (NULL_TREE));
> + append_to_statement_list (tmp, &block->cleanup);
> + }
> + }
> + tree init_stmtlist = block->init;
> + tree cleanup_stmtlist = block->cleanup;
> + se.expr = NULL_TREE;
> + for (struct gfc_omp_namelist *n = omp_ns ? omp_ns->omp_allocate : NULL;
> + n; n = n->next)
> + if (!TREE_STATIC (n->sym->backend_decl))
> + {
> + tree align = (n->u.align ? gfc_conv_constant_to_tree (n->u.align)
> + : NULL_TREE);
> + if (last_allocator != n->u2.allocator)
> + {
> + location_t loc = input_location;
> + gfc_init_se (&se, NULL);
> + if (n->u2.allocator)
> + {
> + input_location = gfc_get_location (&n->u2.allocator->where);
> + gfc_conv_expr (&se, n->u2.allocator);
> + }
> + /* We need to evalulate non-constants - also to find the location
> + after which the GOMP_alloc has to be added to - also as BLOCK
> + does not yield a new BIND_EXPR_BODY. */
> + if (n->u2.allocator
> + && (!(CONSTANT_CLASS_P (se.expr) && DECL_P (se.expr))
> + || se.pre.head || se.post.head))
> + {
> + stmtblock_t tmpblock;
> + gfc_init_block (&tmpblock);
> + se.expr = gfc_evaluate_now (se.expr, &tmpblock);
> + /* First post then pre because the new code is inserted
> + at the top. */
> + gfc_add_init_cleanup (block, gfc_finish_block (&se.post), NULL);
> + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
> + NULL);
> + gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), NULL);
> + }
> + last_allocator = n->u2.allocator;
> + input_location = loc;
> + }
> +
> + /* 'omp allocate( {purpose: allocator, value: align},
> + {purpose: init-stmtlist, value: cleanup-stmtlist},
> + {purpose: size-var, value: last-size-expr}}
> + where init-stmt/cleanup-stmt is the STATEMENT list to find the
> + try-final block; last-size-expr is to find the location after
> + which to add the code and 'size-var' is for the proper size, cf.
> + gfc_trans_auto_array_allocation - either or both of the latter
> + can be NULL. */
> + tree tmp = lookup_attribute ("omp allocate",
> + DECL_ATTRIBUTES (n->sym->backend_decl));
> + tmp = TREE_VALUE (tmp);
> + TREE_PURPOSE (tmp) = se.expr;
> + TREE_VALUE (tmp) = align;
> + TREE_PURPOSE (TREE_CHAIN (tmp)) = init_stmtlist;
> + TREE_VALUE (TREE_CHAIN (tmp)) = cleanup_stmtlist;
> + }
> + else if (n->sym->attr.in_common)
> + {
> + gfc_error ("Sorry, !$OMP allocate for COMMON block variable %qs at %L "
> + "not supported", n->sym->common_block->name,
> + &n->sym->common_block->where);
> + break;
> + }
> + else
> + {
> + gfc_error ("Sorry, !$OMP allocate for variable %qs at %L with SAVE "
> + "attribute not yet implemented", n->sym->name,
> + &n->sym->declared_at);
> + /* FIXME: Remember to handle last_allocator. */
> + break;
> + }
> +
> gfc_init_block (&tmpblock);
>
> for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
> diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
> index 2f116fd6738..7930f2fd5d1 100644
> --- a/gcc/fortran/trans-openmp.cc
> +++ b/gcc/fortran/trans-openmp.cc
> @@ -2739,34 +2739,48 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
> }
> break;
> case OMP_LIST_ALLOCATE:
> - for (; n != NULL; n = n->next)
> - if (n->sym->attr.referenced)
> - {
> - tree t = gfc_trans_omp_variable (n->sym, false);
> - if (t != error_mark_node)
> - {
> - tree node = build_omp_clause (input_location,
> - OMP_CLAUSE_ALLOCATE);
> - OMP_CLAUSE_DECL (node) = t;
> - if (n->u2.allocator)
> - {
> - tree allocator_;
> - gfc_init_se (&se, NULL);
> - gfc_conv_expr (&se, n->u2.allocator);
> - allocator_ = gfc_evaluate_now (se.expr, block);
> - OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) = allocator_;
> - }
> - if (n->u.align)
> - {
> - tree align_;
> - gfc_init_se (&se, NULL);
> - gfc_conv_expr (&se, n->u.align);
> - align_ = gfc_evaluate_now (se.expr, block);
> - OMP_CLAUSE_ALLOCATE_ALIGN (node) = align_;
> - }
> - omp_clauses = gfc_trans_add_clause (node, omp_clauses);
> - }
> - }
> + {
> + tree allocator_ = NULL_TREE;
> + gfc_expr *alloc_expr = NULL;
> + for (; n != NULL; n = n->next)
> + if (n->sym->attr.referenced)
> + {
> + tree t = gfc_trans_omp_variable (n->sym, false);
> + if (t != error_mark_node)
> + {
> + tree node = build_omp_clause (input_location,
> + OMP_CLAUSE_ALLOCATE);
> + OMP_CLAUSE_DECL (node) = t;
> + if (n->u2.allocator)
> + {
> + if (alloc_expr != n->u2.allocator)
> + {
> + gfc_init_se (&se, NULL);
> + gfc_conv_expr (&se, n->u2.allocator);
> + gfc_add_block_to_block (block, &se.pre);
> + allocator_ = gfc_evaluate_now (se.expr, block);
> + gfc_add_block_to_block (block, &se.post);
> + }
> + OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) = allocator_;
> + }
> + alloc_expr = n->u2.allocator;
> + if (n->u.align)
> + {
> + tree align_;
> + gfc_init_se (&se, NULL);
> + gfc_conv_expr (&se, n->u.align);
> + gcc_assert (CONSTANT_CLASS_P (se.expr)
> + && se.pre.head == NULL
> + && se.post.head == NULL);
> + align_ = se.expr;
> + OMP_CLAUSE_ALLOCATE_ALIGN (node) = align_;
> + }
> + omp_clauses = gfc_trans_add_clause (node, omp_clauses);
> + }
> + }
> + else
> + alloc_expr = n->u2.allocator;
> + }
> break;
> case OMP_LIST_LINEAR:
> {
> @@ -7184,11 +7198,14 @@ gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
> static tree
> gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
> {
> - tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc);
> + stmtblock_t block;
> + gfc_start_block (&block);
> + tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
> tree stmt = gfc_trans_omp_code (code->block->next, true);
> stmt = build2_loc (gfc_get_location (&code->loc), OMP_SINGLE, void_type_node,
> stmt, omp_clauses);
> - return stmt;
> + gfc_add_expr_to_block (&block, stmt);
> + return gfc_finish_block (&block);
> }
>
> static tree
> diff --git a/gcc/gimplify.cc b/gcc/gimplify.cc
> index 9f4722f7458..9c617c21381 100644
> --- a/gcc/gimplify.cc
> +++ b/gcc/gimplify.cc
> @@ -1405,18 +1405,45 @@ gimplify_bind_expr (tree *expr_p, gimple_seq *pre_p)
> || alloc == NULL_TREE
> || !integer_onep (alloc)))
> {
> - tree tmp = build_pointer_type (TREE_TYPE (t));
> - tree v = create_tmp_var (tmp, get_name (t));
> - DECL_IGNORED_P (v) = 0;
> - tmp = remove_attribute ("omp allocate", DECL_ATTRIBUTES (t));
> - DECL_ATTRIBUTES (v)
> - = tree_cons (get_identifier ("omp allocate var"),
> - build_tree_list (NULL_TREE, t), tmp);
> - tmp = build_fold_indirect_ref (v);
> - TREE_THIS_NOTRAP (tmp) = 1;
> - SET_DECL_VALUE_EXPR (t, tmp);
> - DECL_HAS_VALUE_EXPR_P (t) = 1;
> - tree sz = TYPE_SIZE_UNIT (TREE_TYPE (t));
> + /* Fortran might already use a pointer type internally;
> + use that pointer except for type(C_ptr) and type(C_funptr);
> + note that normal proc pointers are rejected. */
> + tree type = TREE_TYPE (t);
> + tree tmp, v;
> + if (lang_GNU_Fortran ()
> + && POINTER_TYPE_P (type)
> + && TREE_TYPE (type) != void_type_node
> + && TREE_CODE (TREE_TYPE (type)) != FUNCTION_TYPE)
> + {
> + type = TREE_TYPE (type);
> + v = t;
> + }
> + else
> + {
> + tmp = build_pointer_type (type);
> + v = create_tmp_var (tmp, get_name (t));
> + DECL_IGNORED_P (v) = 0;
> + DECL_ATTRIBUTES (v)
> + = tree_cons (get_identifier ("omp allocate var"),
> + build_tree_list (NULL_TREE, t),
> + DECL_ATTRIBUTES (t));
> + tmp = build_fold_indirect_ref (v);
> + TREE_THIS_NOTRAP (tmp) = 1;
> + SET_DECL_VALUE_EXPR (t, tmp);
> + DECL_HAS_VALUE_EXPR_P (t) = 1;
> + }
> + tree sz = TYPE_SIZE_UNIT (type);
> + /* The size to use in Fortran might not match TYPE_SIZE_UNIT;
> + hence, for some decls, a size variable is saved in the
> + attributes; use it, if available. */
> + if (TREE_CHAIN (TREE_VALUE (attr))
> + && TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr)))
> + && TREE_PURPOSE (
> + TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr)))))
> + {
> + sz = TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr)));
> + sz = TREE_PURPOSE (sz);
> + }
> if (alloc == NULL_TREE)
> alloc = build_zero_cst (ptr_type_node);
> if (align == NULL_TREE)
> @@ -1425,28 +1452,93 @@ gimplify_bind_expr (tree *expr_p, gimple_seq *pre_p)
> align = build_int_cst (size_type_node,
> MAX (tree_to_uhwi (align),
> DECL_ALIGN_UNIT (t)));
> + location_t loc = DECL_SOURCE_LOCATION (t);
> tmp = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC);
> - tmp = build_call_expr_loc (DECL_SOURCE_LOCATION (t), tmp,
> - 3, align, sz, alloc);
> - tmp = fold_build2_loc (DECL_SOURCE_LOCATION (t), MODIFY_EXPR,
> - TREE_TYPE (v), v,
> + tmp = build_call_expr_loc (loc, tmp, 3, align, sz, alloc);
> + tmp = fold_build2_loc (loc, MODIFY_EXPR, TREE_TYPE (v), v,
> fold_convert (TREE_TYPE (v), tmp));
> - gcc_assert (BIND_EXPR_BODY (bind_expr) != NULL_TREE
> - && (TREE_CODE (BIND_EXPR_BODY (bind_expr))
> - == STATEMENT_LIST));
> - tree_stmt_iterator e = tsi_start (BIND_EXPR_BODY (bind_expr));
> - while (!tsi_end_p (e))
> + gcc_assert (BIND_EXPR_BODY (bind_expr) != NULL_TREE);
> + /* Ensure that either TREE_CHAIN (TREE_VALUE (attr) is set
> + and GOMP_FREE added here or that DECL_HAS_VALUE_EXPR_P (t)
> + is set, using in a condition much further below. */
> + gcc_assert (DECL_HAS_VALUE_EXPR_P (t)
> + || TREE_CHAIN (TREE_VALUE (attr)));
> + if (TREE_CHAIN (TREE_VALUE (attr)))
> {
> - if ((TREE_CODE (*e) == DECL_EXPR
> - && TREE_OPERAND (*e, 0) == t)
> - || (TREE_CODE (*e) == CLEANUP_POINT_EXPR
> - && TREE_CODE (TREE_OPERAND (*e, 0)) == DECL_EXPR
> - && TREE_OPERAND (TREE_OPERAND (*e, 0), 0) == t))
> - break;
> + /* Fortran is special as it does not have properly nest
> + declarations in blocks. And as there is no
> + initializer, there is also no expression to look for.
> + Hence, the FE makes the statement list of the
> + try-finally block available. We can put the GOMP_alloc
> + at the top, unless an allocator or size expression
> + requires to put it afterward; note that the size is
> + always later in generated code; for strings, no
> + size expr but still an expr might be available. */
> + tree sl = TREE_PURPOSE (TREE_CHAIN (TREE_VALUE (attr)));
> + tree_stmt_iterator e = tsi_start (sl);
> + tree needle = NULL_TREE;
> + if (TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr))))
> + {
> + needle = TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr)));
> + needle = (TREE_VALUE (needle) ? TREE_VALUE (needle)
> + : sz);
> + }
> + else if (TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr))))
> + needle = sz;
> + else if (DECL_P (alloc) && DECL_ARTIFICIAL (alloc))
> + needle = alloc;
> +
> + if (needle != NULL_TREE)
> + {
> + while (!tsi_end_p (e))
> + {
> + if (*e == needle
> + || (TREE_CODE (*e) == MODIFY_EXPR
> + && TREE_OPERAND (*e, 0) == needle))
> + break;
> + ++e;
> + }
> + gcc_assert (!tsi_end_p (e));
> + }
> + tsi_link_after (&e, tmp, TSI_SAME_STMT);
> +
> + /* As the cleanup is in BIND_EXPR_BODY, GOMP_free is added
> + here; for C/C++ it will be added in the 'cleanup'
> + section after gimplification. But Fortran already has
> + a try-finally block. */
> + sl = TREE_VALUE (TREE_CHAIN (TREE_VALUE (attr)));
> + e = tsi_last (sl);
> + tmp = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
> + tmp = build_call_expr_loc (EXPR_LOCATION (*e), tmp, 2, v,
> + build_zero_cst (ptr_type_node));
> + tsi_link_after (&e, tmp, TSI_SAME_STMT);
> + tmp = build_clobber (TREE_TYPE (v), CLOBBER_EOL);
> + tmp = fold_build2_loc (loc, MODIFY_EXPR, TREE_TYPE (v), v,
> + fold_convert (TREE_TYPE (v), tmp));
> ++e;
> + tsi_link_after (&e, tmp, TSI_SAME_STMT);
> }
> - gcc_assert (!tsi_end_p (e));
> - tsi_link_before (&e, tmp, TSI_SAME_STMT);
> + else
> + {
> + gcc_assert (TREE_CODE (BIND_EXPR_BODY (bind_expr))
> + == STATEMENT_LIST);
> + tree_stmt_iterator e;
> + e = tsi_start (BIND_EXPR_BODY (bind_expr));
> + while (!tsi_end_p (e))
> + {
> + if ((TREE_CODE (*e) == DECL_EXPR
> + && TREE_OPERAND (*e, 0) == t)
> + || (TREE_CODE (*e) == CLEANUP_POINT_EXPR
> + && (TREE_CODE (TREE_OPERAND (*e, 0))
> + == DECL_EXPR)
> + && (TREE_OPERAND (TREE_OPERAND (*e, 0), 0)
> + == t)))
> + break;
> + ++e;
> + }
> + gcc_assert (!tsi_end_p (e));
> + tsi_link_before (&e, tmp, TSI_SAME_STMT);
> + }
> }
> }
>
> @@ -1539,16 +1631,26 @@ gimplify_bind_expr (tree *expr_p, gimple_seq *pre_p)
> && !is_global_var (t)
> && DECL_CONTEXT (t) == current_function_decl)
> {
> + tree attr;
> if (flag_openmp
> && DECL_HAS_VALUE_EXPR_P (t)
> && TREE_USED (t)
> - && lookup_attribute ("omp allocate", DECL_ATTRIBUTES (t)))
> + && ((attr = lookup_attribute ("omp allocate",
> + DECL_ATTRIBUTES (t))) != NULL_TREE)
> + && TREE_CHAIN (TREE_VALUE (attr)) == NULL_TREE)
> {
> + /* For Fortran, TREE_CHAIN (TREE_VALUE (attr)) is set, which
> + causes that the GOMP_free call is already added above. */
> + tree v = TREE_OPERAND (DECL_VALUE_EXPR (t), 0);
> tree tmp = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
> - tmp = build_call_expr_loc (end_locus, tmp, 2,
> - TREE_OPERAND (DECL_VALUE_EXPR (t), 0),
> + tmp = build_call_expr_loc (end_locus, tmp, 2, v,
> build_zero_cst (ptr_type_node));
> gimplify_and_add (tmp, &cleanup);
> + gimple *clobber_stmt;
> + tmp = build_clobber (TREE_TYPE (v), CLOBBER_EOL);
> + clobber_stmt = gimple_build_assign (v, tmp);
> + gimple_set_location (clobber_stmt, end_locus);
> + gimplify_seq_add_stmt (&cleanup, clobber_stmt);
> }
> if (!DECL_HARD_REGISTER (t)
> && !TREE_THIS_VOLATILE (t)
> diff --git a/gcc/testsuite/c-c++-common/gomp/allocate-14.c b/gcc/testsuite/c-c++-common/gomp/allocate-14.c
> index b25da5497c5..894921a76d5 100644
> --- a/gcc/testsuite/c-c++-common/gomp/allocate-14.c
> +++ b/gcc/testsuite/c-c++-common/gomp/allocate-14.c
> @@ -17,7 +17,7 @@ h ()
> {
> #pragma omp target
> #pragma omp parallel
> - #pragma omp serial
> + #pragma omp single
> {
> int var2[5]; /* { dg-error "'allocate' directive for 'var2' inside a target region must specify an 'allocator' clause" } */
> #pragma omp allocate(var2)
> diff --git a/gcc/testsuite/c-c++-common/gomp/allocate-15.c b/gcc/testsuite/c-c++-common/gomp/allocate-15.c
> index 15105b9102e..52cb7686b7b 100644
> --- a/gcc/testsuite/c-c++-common/gomp/allocate-15.c
> +++ b/gcc/testsuite/c-c++-common/gomp/allocate-15.c
> @@ -19,7 +19,7 @@ h ()
> {
> #pragma omp target
> #pragma omp parallel
> - #pragma omp serial
> + #pragma omp single
> {
> int var2[5];
> #pragma omp allocate(var2)
> diff --git a/gcc/testsuite/c-c++-common/gomp/allocate-9.c b/gcc/testsuite/c-c++-common/gomp/allocate-9.c
> index 3c11080dd16..31382748be6 100644
> --- a/gcc/testsuite/c-c++-common/gomp/allocate-9.c
> +++ b/gcc/testsuite/c-c++-common/gomp/allocate-9.c
> @@ -20,7 +20,7 @@ typedef enum omp_allocator_handle_t
> static int A[5] = {1,2,3,4,5};
> int B, C, D;
>
> -/* If the following fails bacause of added predefined allocators, please update
> +/* If the following fails because of added predefined allocators, please update
> - c/c-parser.c's c_parser_omp_allocate
> - fortran/openmp.cc's is_predefined_allocator
> - libgomp/env.c's parse_allocator
> diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-10.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-10.f90
> new file mode 100644
> index 00000000000..e50db53c1a8
> --- /dev/null
> +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-10.f90
> @@ -0,0 +1,75 @@
> +! { dg-additional-options "-Wall -fdump-tree-gimple" }
> +
> +module m
> +use iso_c_binding
> +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
> +
> +
> +! { dg-final { scan-tree-dump-times "__builtin_GOMP_alloc" 3 "gimple" } }
> +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free" 3 "gimple" } }
> +
> +subroutine f
> + use m
> + implicit none
> + integer :: n
> + block
> + integer :: A(n) ! { dg-warning "Unused variable 'a' declared" }
> + end block
> +end
> +
> +subroutine f2
> + use m
> + implicit none
> + integer :: n ! { dg-note "'n' was declared here" }
> + block
> + integer :: A(n) ! { dg-warning "'n' is used uninitialized" }
> + !$omp allocate(A)
> + ! by matching 'A' above, TREE_USE is set. Hence:
> + ! { dg-final { scan-tree-dump-times "a = __builtin_GOMP_alloc \\(., D\.\[0-9\]+, 0B\\);" 1 "gimple" } }
> + ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(a, 0B\\);" 1 "gimple" } }
> + end block
> +end
> +
> +subroutine h1()
> + use m
> + implicit none
> + integer(omp_allocator_handle_kind) my_handle ! { dg-note "'my_handle' was declared here" }
> + integer :: B1(3)
> + !$omp allocate(B1) allocator(my_handle) ! { dg-warning "31:'my_handle' is used uninitialized" }
> + B1(1) = 5
> + ! { dg-final { scan-tree-dump-times "b1.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 12, D\.\[0-9\]+\\);" 1 "gimple" } }
> + ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(b1.\[0-9\]+, 0B\\);" 1 "gimple" } }
> +end
> +
> +subroutine h2()
> + use m
> + implicit none
> + integer(omp_allocator_handle_kind) my_handle ! { dg-note "'my_handle' was declared here" }
> + block
> + integer :: B2(3)
> + !$omp allocate(B2) allocator(my_handle) ! { dg-warning "33:'my_handle' is used uninitialized" }
> + ! Similar above; B2 is unused - but in gfortran, the match in 'allocate(B2)' already
> + ! causes TREE_USED = 1
> + ! { dg-final { scan-tree-dump-times "b2.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 12, D\.\[0-9\]+\\);" 1 "gimple" } }
> + ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(b2.\[0-9\]+, 0B\\);" 1 "gimple" } }
> + end block
> +end
> diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-11.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-11.f90
> new file mode 100644
> index 00000000000..8a8d93930b0
> --- /dev/null
> +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-11.f90
> @@ -0,0 +1,33 @@
> +module m
> +use iso_c_binding
> +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
> +
> +subroutine f ()
> + use m
> + implicit none
> + integer :: i
> + !$omp parallel firstprivate(i) allocate(allocator(omp_low_latency_mem_alloc): i)
> + ! { dg-error "Symbol 'omp_low_latency_mem_alloc' at .1. has no IMPLICIT type; did you mean 'omp_low_lat_mem_alloc'\\\?" "" { target *-*-* } .-1 }
> + ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind at .1." "" { target *-*-* } .-2 }
> + i = 4
> + !$omp end parallel
> +end
> diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-12.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-12.f90
> new file mode 100644
> index 00000000000..183c2941819
> --- /dev/null
> +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-12.f90
> @@ -0,0 +1,24 @@
> +module m
> + implicit none
> +contains
> +subroutine f ()
> + !$omp declare target
> + integer :: var ! { dg-error "'allocate' directive for 'var' inside a target region must specify an 'allocator' clause" }
> + !$omp allocate(var)
> + var = 5
> +end
> +
> +subroutine h ()
> + !$omp target
> + !$omp parallel
> + !$omp single
> + block
> + integer :: var2(5) ! { dg-error "'allocate' directive for 'var2' inside a target region must specify an 'allocator' clause" }
> + !$omp allocate(var2)
> + var2(1) = 7
> + end block
> + !$omp end single
> + !$omp end parallel
> + !$omp end target
> +end
> +end module
> diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-13.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-13.f90
> new file mode 100644
> index 00000000000..bf8a5a2bee2
> --- /dev/null
> +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-13.f90
> @@ -0,0 +1,25 @@
> +module m
> + implicit none
> + !$omp requires dynamic_allocators
> +contains
> +subroutine f ()
> + !$omp declare target
> + integer :: var
> + !$omp allocate(var)
> + var = 5
> +end
> +
> +subroutine h ()
> + !$omp target
> + !$omp parallel
> + !$omp single
> + block
> + integer :: var2(5)
> + !$omp allocate(var2)
> + var2(1) = 7
> + end block
> + !$omp end single
> + !$omp end parallel
> + !$omp end target
> +end
> +end module
> diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-14.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-14.f90
> new file mode 100644
> index 00000000000..8ff9c252e49
> --- /dev/null
> +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-14.f90
> @@ -0,0 +1,95 @@
> +! { dg-additional-options "-fcoarray=single -fcray-pointer" }
> +
> +module m
> +use iso_c_binding
> +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
> +
> +subroutine coarrays(x)
> + use m
> + implicit none
> +
> + integer :: x[*]
> + integer, allocatable :: y[:], z(:)[:]
> +
> + !$omp allocate(x) ! { dg-error "Unexpected dummy argument 'x' as argument at .1. to declarative !.OMP ALLOCATE" }
> +
> + !$omp allocators allocate(y) ! { dg-error "28:Unexpected coarray 'y' in 'allocate' at .1." }
> + allocate(y[*])
> +
> + !$omp allocate(z) ! { dg-error "17:Unexpected coarray 'z' in 'allocate' at .1." }
> + allocate(z(5)[*])
> + x = 5
> +end
> +
> +
> +integer function f() result(res)
> + !$omp allocate(f) ! { dg-error "Argument 'f' at .1. to declarative !.OMP ALLOCATE directive must be a variable" }
> + !$omp allocate(res) ! { dg-error "Unexpected function-result variable 'res' at .1. in declarative !.OMP ALLOCATE" }
> + res = 5
> +end
> +
> +integer function g() result(res)
> + allocatable :: res
> + !$omp allocators allocate(g) ! { dg-error "Expected variable list at .1." }
> +
> + !$omp allocators allocate (res)
> + allocate(res, source=5)
> + deallocate(res)
> +
> + !$omp allocate (res)
> + allocate(res, source=5)
> +end
> +
> +
> +subroutine cray_ptr()
> + real pointee(10)
> + pointer (ipt, pointee)
> + !$omp allocate(pointee) ! { dg-error "Sorry, Cray pointers and pointees such as 'pointee' are not supported with !.OMP ALLOCATE at .1." }
> + !$omp allocate(ipt) ! { dg-error "Sorry, Cray pointers and pointees such as 'ipt' are not supported with !.OMP ALLOCATE at .1." }
> +end
> +
> +subroutine equiv
> + integer :: A
> + real :: B(2)
> + equivalence(A,B)
> + !$omp allocate (A) ! { dg-error "Sorry, EQUIVALENCE object 'a' not supported with !.OMP ALLOCATE at .1." }
> + !$omp allocate (B) ! { dg-error "Sorry, EQUIVALENCE object 'b' not supported with !.OMP ALLOCATE at .1." }
> +end
> +
> +subroutine common
> + use m
> + integer :: a,b,c(5)
> + common /my/ a,b,c
> + !$omp allocate(b) allocator(omp_cgroup_mem_alloc) ! { dg-error "'b' at .1. is part of the common block '/my/' and may only be specificed implicitly via the named common block" }
> +end
> +
> +subroutine c_and_func_ptrs
> + use iso_c_binding
> + implicit none
> + procedure(), pointer :: p
> + type(c_ptr) :: cptr
> + type(c_ptr) :: cfunptr
> +
> + !$omp allocate(cptr) ! OK
> + !$omp allocate(cfunptr) ! OK? A normal derived-type var?
> + !$omp allocate(p) ! { dg-error "Argument 'p' at .1. to declarative !.OMP ALLOCATE directive must be a variable" }
> +end
> diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-15.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-15.f90
> new file mode 100644
> index 00000000000..a0690a56394
> --- /dev/null
> +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-15.f90
> @@ -0,0 +1,38 @@
> +module m
> +use iso_c_binding
> +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
> +
> +subroutine common
> + use m
> + integer :: a,b,c(5)
> + common /my/ a,b,c ! { dg-error "Sorry, !.OMP allocate for COMMON block variable 'my' at .1. not supported" }
> + !$omp allocate(/my/) allocator(omp_cgroup_mem_alloc)
> +end
> +
> +integer function allocators() result(res)
> + use m
> + integer, save :: a(5) = [1,2,3,4,5] ! { dg-error "Sorry, !.OMP allocate for variable 'a' at .1. with SAVE attribute not yet implemented" }
> + !$omp allocate(a) allocator(omp_high_bw_mem_alloc)
> + res = a(4)
> +end
> +
> +
> diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90
> index a2dcf105ee1..b93a37c780c 100644
> --- a/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90
> +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90
> @@ -33,13 +33,13 @@ 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(a)
> !$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)
> +integer, save :: k,l,m(5),r(2) ! { dg-error "Sorry, !.OMP allocate for variable 'k' at .1. with SAVE attribute not yet implemented" }
> !$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 )
> diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90
> index b856204d48a..ab85e327795 100644
> --- a/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90
> +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90
> @@ -47,7 +47,6 @@ 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" }
> @@ -59,7 +58,6 @@ 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
>
> @@ -74,7 +72,6 @@ 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" }
> @@ -86,7 +83,6 @@ 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" }
> @@ -99,7 +95,6 @@ subroutine five(n,my_alloc)
> 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
> @@ -113,7 +108,6 @@ subroutine five_SaveAll(n,my_alloc)
> 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" }
> @@ -127,7 +121,6 @@ subroutine five_Save(n,my_alloc)
> 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" }
> @@ -139,7 +132,6 @@ module five_Module
> 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" }
> @@ -151,7 +143,6 @@ program five_program
> 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" }
> @@ -170,7 +161,6 @@ subroutine six(n,my_alloc)
> 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" }
> diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-8.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-8.f90
> new file mode 100644
> index 00000000000..bb4d07d0c73
> --- /dev/null
> +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-8.f90
> @@ -0,0 +1,29 @@
> +! { dg-additional-options "-fdump-tree-original" }
> +
> +module m
> + use iso_c_binding
> + !use omp_lib, only: omp_allocator_handle_kind
> + implicit none
> + integer, parameter :: omp_allocator_handle_kind = c_intptr_t
> + integer :: a = 0, b = 42, c = 0
> +
> +contains
> + integer(omp_allocator_handle_kind) function get_alloc()
> + allocatable :: get_alloc
> + get_alloc = 2_omp_allocator_handle_kind
> + end
> + subroutine foo ()
> + !$omp scope private (a) firstprivate (b) reduction (+: c) allocate ( get_alloc() : a , b , c)
> + if (b /= 42) &
> + error stop
> + a = 36
> + b = 15
> + c = c + 1
> + !$omp end scope
> + end
> +end
> +
> +! { dg-final { scan-tree-dump "omp scope private\\(a\\) firstprivate\\(b\\) reduction\\(\\+:c\\) allocate\\(allocator\\(D\\.\[0-9\]+\\):a\\) allocate\\(allocator\\(D\\.\[0-9\]+\\):b\\) allocate\\(allocator\\(D\\.\[0-9\]+\\):c\\)" "original" } }
> +
> +! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = get_alloc \\(\\);\[\n\r\]+ *D\\.\[0-9\]+ = \\*D\\.\[0-9\]+;\[\n\r\]+ *__builtin_free \\(\\(void \\*\\) D\\.\[0-9\]+\\);" 1 "original" } }
> +
> diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-9.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-9.f90
> new file mode 100644
> index 00000000000..4d9553686c4
> --- /dev/null
> +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-9.f90
> @@ -0,0 +1,112 @@
> +module m
> +use iso_c_binding
> +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 m2
> + use m
> + implicit none
> + integer :: A(5) = [1,2,3,4,5], A2, A3, A4, A5
> + integer :: B, C, D
> +
> +! If the following fails because of added predefined allocators, please update
> +! - c/c-parser.c's c_parser_omp_allocate
> +! - fortran/openmp.cc's is_predefined_allocator
> +! - libgomp/env.c's parse_allocator
> +! - libgomp/libgomp.texi (document the new values - multiple locations)
> +! + ensure that the memory-spaces are also up to date.
> +
> +!$omp allocate(A) align(32) allocator(9_omp_allocator_handle_kind) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'a' at .2. has the SAVE attribute" }
> +
> +! typo in allocator name:
> +!$omp allocate(A2) allocator(omp_low_latency_mem_alloc) ! { dg-error "Symbol 'omp_low_latency_mem_alloc' at .1. has no IMPLICIT type; did you mean 'omp_low_lat_mem_alloc'\\?" }
> +! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'a2' at .2. has the SAVE attribute" "" { target *-*-* } .-1 }
> +
> +! align be const multiple of 2
> +!$omp allocate(A3) align(31) allocator(omp_default_mem_alloc) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
> +
> +! allocator missing (required as A is static)
> +!$omp allocate(A4) align(32) ! { dg-error "An ALLOCATOR clause is required as the list item 'a4' at .1. has the SAVE attribute" }
> +
> +! "expression in the clause must be a constant expression that evaluates to one of the
> +! predefined memory allocator values -> omp_low_lat_mem_alloc"
> +!$omp allocate(B) allocator(omp_high_bw_mem_alloc+1_omp_allocator_handle_kind) align(32) ! OK: omp_low_lat_mem_alloc
> +
> +!$omp allocate(C) allocator(2_omp_allocator_handle_kind) ! OK: omp_large_cap_mem_alloc
> +
> +!$omp allocate(A5) align(32) allocator(omp_null_allocator) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'a5' at .2. has the SAVE attribute" }
> +
> +!$omp allocate(C) align(32) allocator(omp_large_cap_mem_alloc) ! { dg-error "Duplicated variable 'c' in !.OMP ALLOCATE at .1." }
> +
> +contains
> +
> +integer function f()
> + !$omp allocate(D) align(32) allocator(omp_large_cap_mem_alloc) ! { dg-error "Argument 'd' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" }
> + f = A(1)
> +end
> +
> +integer function g()
> + integer :: a2, b2
> + !$omp allocate(a2)
> + !$omp allocate(a2) ! { dg-error "Duplicated variable 'a2' in !.OMP ALLOCATE at .1." }
> + a2=1; b2=2
> + block
> + integer :: c2
> + !$omp allocate(c2, b2) ! { dg-error "Argument 'b2' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" }
> + c2 = 3
> + g = c2+a2+b2
> + end block
> +end
> +
> +integer function h(q)
> + integer :: q
> + !$omp allocate(q) ! { dg-error "Unexpected dummy argument 'q' as argument at .1. to declarative !.OMP ALLOCATE" }
> + h = q
> +end
> +
> +integer function k ()
> + integer, save :: var3 = 8
> + !$omp allocate(var3) allocator(-1_omp_allocator_handle_kind) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'var3' at .2. has the SAVE attribute" }
> + k = var3
> +end
> +end module
> +
> +
> +subroutine foo
> + integer :: a, b
> + integer :: c, d,h
> + !$omp allocate(a,b)
> + b = 1; d = 5
> +contains
> +subroutine internal
> + integer :: e,f
> + !$omp allocate(c,d)
> + ! { dg-error "Argument 'c' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" "" { target *-*-* } .-1 }
> + ! { dg-error "Argument 'd' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" "" { target *-*-* } .-2 }
> + !$omp allocate(e)
> + a = 1; c = 2; e = 4
> + block
> + !$omp allocate(f) ! { dg-error "Argument 'f' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" }
> + !$omp allocate(h) ! { dg-error "Argument 'h' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" }
> + end block
> +end
> +end
> diff --git a/libgomp/libgomp.texi b/libgomp/libgomp.texi
> index 6a7770084d2..c163411c529 100644
> --- a/libgomp/libgomp.texi
> +++ b/libgomp/libgomp.texi
> @@ -225,7 +225,7 @@ The OpenMP 4.5 specification is fully supported.
> @item Predefined memory spaces, memory allocators, allocator traits
> @tab Y @tab See also @ref{Memory allocation}
> @item Memory management routines @tab Y @tab
> -@item @code{allocate} directive @tab P @tab Only C, only stack variables
> +@item @code{allocate} directive @tab P @tab Only C and Fortran, only stack variables
> @item @code{allocate} clause @tab P @tab Initial support
> @item @code{use_device_addr} clause on @code{target data} @tab Y @tab
> @item @code{ancestor} modifier on @code{device} clause @tab Y @tab
> @@ -297,7 +297,7 @@ The OpenMP 4.5 specification is fully supported.
> @item @code{strict} modifier in the @code{grainsize} and @code{num_tasks}
> clauses of the @code{taskloop} construct @tab Y @tab
> @item @code{align} clause in @code{allocate} directive @tab P
> - @tab Only C (and only stack variables)
> + @tab Only C and Fortran (and only stack variables)
> @item @code{align} modifier in @code{allocate} clause @tab Y @tab
> @item @code{thread_limit} clause to @code{target} construct @tab Y @tab
> @item @code{has_device_addr} clause to @code{target} construct @tab Y @tab
> diff --git a/libgomp/testsuite/libgomp.fortran/allocate-5.f90 b/libgomp/testsuite/libgomp.fortran/allocate-5.f90
> new file mode 100644
> index 00000000000..de9cd5a302e
> --- /dev/null
> +++ b/libgomp/testsuite/libgomp.fortran/allocate-5.f90
> @@ -0,0 +1,87 @@
> +! { dg-additional-options "-fdump-tree-gimple" }
> +
> +! { dg-final { scan-tree-dump-times "__builtin_GOMP_alloc \\(" 5 "gimple" } }
> +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(" 5 "gimple" } }
> +
> +
> +module m
> + use omp_lib
> + use iso_c_binding
> + implicit none (type, external)
> + integer(c_intptr_t) :: intptr
> +contains
> +
> +integer function one ()
> + integer :: sum, i
> + !$omp allocate(sum)
> + ! { dg-final { scan-tree-dump-times "sum\\.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 4, 0B\\);" 1 "gimple" } }
> + ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(sum\\.\[0-9\]+, 0B\\);" 1 "gimple" } }
> +
> + ! NOTE: Initializer cannot be omp_init_allocator - as 'A' is
> + ! in the same scope and the auto-omp_free comes later than
> + ! any omp_destroy_allocator.
> + integer(omp_allocator_handle_kind) :: my_allocator = omp_low_lat_mem_alloc
> + integer :: n = 25
> + sum = 0
> + block
> + type(omp_alloctrait) :: traits(1) = [ omp_alloctrait(omp_atk_alignment, 64) ]
> + integer :: A(n)
> + !$omp allocate(A) align(128) allocator(my_allocator)
> + ! { dg-final { scan-tree-dump-times "a = __builtin_GOMP_alloc \\(128, D\\.\[0-9\]+, D\\.\[0-9\]+\\);" 1 "gimple" } }
> + ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(a, 0B\\);" 1 "gimple" } }
> +
> + if (mod (transfer(loc(A), intptr), 128_c_intptr_t) /= 0) &
> + stop 2
> + do i = 1, n
> + A(i) = i
> + end do
> +
> + my_allocator = omp_init_allocator(omp_low_lat_mem_space,1,traits)
> + block
> + integer B(n)
> + integer C(5)
> + !$omp allocate(B,C) allocator(my_allocator)
> + ! { dg-final { scan-tree-dump-times "b = __builtin_GOMP_alloc \\(\[0-9\]+, D\\.\[0-9\]+, D\\.\[0-9\]+\\);" 1 "gimple" } }
> + ! { dg-final { scan-tree-dump-times "c\\.\[0-9\]+ = __builtin_GOMP_alloc \\(\[0-9\]+, 20, D\\.\[0-9\]+\\);" 1 "gimple" } }
> + ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(b, 0B\\);" 1 "gimple" } }
> + ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(c\\.\[0-9\]+, 0B\\);" 1 "gimple" } }
> +
> + integer :: D(5)
> + !$omp allocate(D) align(256)
> + ! { dg-final { scan-tree-dump-times "d\\.\[0-9\]+ = __builtin_GOMP_alloc \\(256, 20, 0B\\);" 1 "gimple" } }
> + ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(d\\.\[0-9\]+, 0B\\);" 1 "gimple" } }
> +
> + B = 0
> + C = [1,2,3,4,5]
> + D = [11,22,33,44,55]
> +
> + if (mod (transfer(loc(B), intptr), 64_c_intptr_t) /= 0) &
> + stop 3
> + if (mod (transfer(loc(C), intptr), 64_c_intptr_t) /= 0) &
> + stop 4
> + if (mod (transfer(loc(D), intptr), 256_c_intptr_t) /= 0) &
> + stop 5
> +
> + do i = 1, 5
> + if (C(i) /= i) &
> + stop 6
> + if (D(i) /= i + 10*i) &
> + stop 7
> + end do
> +
> + do i = 1, n
> + if (B(i) /= 0) &
> + stop 9
> + sum = sum + A(i)+B(i)+C(mod(i,5)+1)+D(mod(i,5)+1)
> + end do
> + end block
> + call omp_destroy_allocator (my_allocator)
> + end block
> + one = sum
> +end
> +end module
> +
> +use m
> +if (one () /= 1225) &
> + stop 1
> +end
> diff --git a/libgomp/testsuite/libgomp.fortran/allocate-6.f90 b/libgomp/testsuite/libgomp.fortran/allocate-6.f90
> new file mode 100644
> index 00000000000..5c32652f2a6
> --- /dev/null
> +++ b/libgomp/testsuite/libgomp.fortran/allocate-6.f90
> @@ -0,0 +1,123 @@
> +module m
> + use iso_c_binding
> + use omp_lib
> + implicit none (type, external)
> + integer(c_intptr_t) :: intptr
> +
> +! { dg-final { scan-tree-dump-not "__builtin_stack_save" "gimple" } }
> +! { dg-final { scan-tree-dump-not "__builtin_alloca" "gimple" } }
> +! { dg-final { scan-tree-dump-not "__builtin_stack_restore" "gimple" } }
> +
> +! { dg-final { scan-tree-dump-times "__builtin_GOMP_alloc \\(" 5 "gimple" } }
> +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(" 5 "gimple" } }
> +
> +contains
> +
> +subroutine one ()
> + integer :: result, n, i
> + result = 0
> + n = 3
> + !$omp target map(tofrom: result) firstprivate(n)
> + block
> + integer :: var, var2(n)
> + !$omp allocate(var,var2) align(128) allocator(omp_low_lat_mem_alloc)
> + var = 5
> +! { dg-final { scan-tree-dump-times "var\\.\[0-9\]+ = __builtin_GOMP_alloc \\(128, 4, 5\\);" 1 "gimple" } } */
> +! { dg-final { scan-tree-dump-times "var2\\.\[0-9\]+ = __builtin_GOMP_alloc \\(128, D\\.\[0-9\]+, 5\\);" 1 "gimple" } } */
> +
> +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(var\\.\[0-9\]+, 0B\\);" 1 "gimple" } } */
> +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(var2\\.\[0-9\]+, 0B\\);" 1 "gimple" } } */
> +
> + if (mod(transfer(loc(var), intptr), 128_c_intptr_t) /= 0) &
> + stop 1
> + if (mod(transfer(loc(var2), intptr), 128_c_intptr_t) /= 0) &
> + stop 2
> + if (var /= 5) &
> + stop 3
> +
> + !$omp parallel do
> + do i = 1, n
> + var2(i) = (i+32);
> + end do
> +
> + !$omp parallel loop reduction(+:result)
> + do i = 1, n
> + result = result + var + var2(i)
> + end do
> + end block
> + if (result /= (3*5 + 33 + 34 + 35)) &
> + stop 4
> +end
> +
> +subroutine two ()
> + type st
> + integer :: a, b
> + end type
> + integer :: scalar, array(5), i
> + type(st) s
> + !$omp allocate(scalar, array, s)
> +! { dg-final { scan-tree-dump-times "scalar\\.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 4, 0B\\);" 1 "gimple" } }
> +! { dg-final { scan-tree-dump-times "array\\.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 20, 0B\\);" 1 "gimple" } }
> +! { dg-final { scan-tree-dump-times "s\\.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 8, 0B\\);" 1 "gimple" } }
> +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(scalar\\.\[0-9\]+, 0B\\);" 1 "gimple" } }
> +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(array\\.\[0-9\]+, 0B\\);" 1 "gimple" } }
> +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(s\\.\[0-9\]+, 0B\\);" 1 "gimple" } }
> +
> + scalar = 44
> + array = [1,2,3,4,5]
> + s = st(a=11, b=56)
> +
> + !$omp parallel firstprivate(scalar) firstprivate(array) firstprivate(s)
> + if (scalar /= 44) &
> + stop 5
> + scalar = 33;
> + if (any (array /= [1,2,3,4,5])) &
> + stop 6
> + array = [10,20,30,40,50]
> + if (s%a /= 11 .or. s%b /= 56) &
> + stop 7
> + s%a = 74
> + s%b = 674
> + !$omp end parallel
> +
> + if (scalar /= 44) &
> + stop 8
> + if (any (array /= [1,2,3,4,5])) &
> + stop 9
> + if (s%a /= 11 .or. s%b /= 56) &
> + stop 10
> +
> + !$omp target defaultmap(firstprivate : scalar) defaultmap(none : aggregate) defaultmap(none : pointer)
> + if (scalar /= 44) &
> + stop 11
> + scalar = 33;
> + !$omp end target
> +
> + if (scalar /= 44) &
> + stop 12
> +
> + !$omp target defaultmap(none : scalar) defaultmap(firstprivate : aggregate) defaultmap(none : pointer) private(i)
> + if (any (array /= [1,2,3,4,5])) &
> + stop 13
> + do i = 1, 5
> + array(i) = 10*i
> + end do
> + !$omp end target
> +
> + if (any(array /= [1,2,3,4,5])) &
> + stop 13
> + !$omp target defaultmap(none : scalar) defaultmap(firstprivate : aggregate) defaultmap(none : pointer)
> + if (s%a /= 11 .or. s%b /= 56) &
> + stop 14
> + s%a = 74
> + s%b = 674
> + !$omp end target
> + if (s%a /= 11 .or. s%b /= 56) &
> + stop 15
> +end
> +end module
> +
> +use m
> + call one ()
> + call two ()
> +end
> diff --git a/libgomp/testsuite/libgomp.fortran/allocate-7.f90 b/libgomp/testsuite/libgomp.fortran/allocate-7.f90
> new file mode 100644
> index 00000000000..83f3eabfc3e
> --- /dev/null
> +++ b/libgomp/testsuite/libgomp.fortran/allocate-7.f90
> @@ -0,0 +1,342 @@
> +! { dg-additional-options "-fdump-tree-omplower" }
> +
> +! For the 4 vars in omp_parallel, 4 in omp_target and 2 in no_alloc2_func.
> +! { dg-final { scan-tree-dump-times "__builtin_GOMP_alloc \\(" 10 "omplower" } }
> +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(" 10 "omplower" } }
> +
> +module m
> + use iso_c_binding
> + use omp_lib
> + implicit none (type, external)
> + integer(c_intptr_t) :: intptr
> +
> +contains
> +
> +subroutine check_int (x, y)
> + integer :: x, y
> + value :: y
> + if (x /= y) &
> + stop 1
> +end
> +
> +subroutine check_ptr (x, y)
> + type(c_ptr) :: x
> + integer(c_intptr_t), value :: y
> + if (transfer(x,intptr) /= y) &
> + stop 2
> +end
> +
> +integer function no_alloc_func () result(res)
> + ! There is no __builtin_GOMP_alloc / __builtin_GOMP_free as
> + ! allocator == omp_default_mem_alloc (known at compile time.
> + integer :: no_alloc
> + !$omp allocate(no_alloc) allocator(omp_default_mem_alloc)
> + no_alloc = 7
> + res = no_alloc
> +end
> +
> +integer function no_alloc2_func() result(res)
> + ! If no_alloc2 were TREE_UNUSED, there would be no
> + ! __builtin_GOMP_alloc / __builtin_GOMP_free
> + ! However, as the parser already marks no_alloc2
> + ! and is_alloc2 as used, the tree is generated for both vars.
> + integer :: no_alloc2, is_alloc2
> + !$omp allocate(no_alloc2, is_alloc2)
> + is_alloc2 = 7
> + res = is_alloc2
> +end
> +
> +
> +subroutine omp_parallel ()
> + integer :: i, n, iii, jjj(5)
> + type(c_ptr) :: ptr
> + !$omp allocate(iii, jjj, ptr)
> + n = 6
> + iii = 5
> + ptr = transfer (int(z'1234', c_intptr_t), ptr)
> + block
> + integer :: kkk(n)
> + !$omp allocate(kkk)
> +
> + do i = 1, 5
> + jjj(i) = 3*i
> + end do
> + do i = 1, 6
> + kkk(i) = 7*i
> + end do
> +
> + !$omp parallel default(none) firstprivate(iii, jjj, kkk, ptr) if(.false.)
> + if (iii /= 5) &
> + stop 3
> + iii = 7
> + call check_int (iii, 7)
> + do i = 1, 5
> + if (jjj(i) /= 3*i) &
> + stop 4
> + end do
> + do i = 1, 6
> + if (kkk(i) /= 7*i) &
> + stop 5
> + end do
> + do i = 1, 5
> + jjj(i) = 4*i
> + end do
> + do i = 1, 6
> + kkk(i) = 8*i
> + end do
> + do i = 1, 5
> + call check_int (jjj(i), 4*i)
> + end do
> + do i = 1, 6
> + call check_int (kkk(i), 8*i)
> + end do
> + if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
> + stop 6
> + ptr = transfer (int(z'abcd', c_intptr_t), ptr)
> + if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) &
> + stop 7
> + call check_ptr (ptr, int(z'abcd', c_intptr_t))
> + !$omp end parallel
> +
> + if (iii /= 5) &
> + stop 8
> + call check_int (iii, 5)
> + do i = 1, 5
> + if (jjj(i) /= 3*i) &
> + stop 9
> + call check_int (jjj(i), 3*i)
> + end do
> + do i = 1, 6
> + if (kkk(i) /= 7*i) &
> + stop 10
> + call check_int (kkk(i), 7*i)
> + end do
> + if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
> + stop 11
> + call check_ptr (ptr, int(z'1234', c_intptr_t))
> +
> + !$omp parallel default(firstprivate) if(.false.)
> + if (iii /= 5) &
> + stop 12
> + iii = 7
> + call check_int (iii, 7)
> + do i = 1, 5
> + if (jjj(i) /= 3*i) &
> + stop 13
> + end do
> + do i = 1, 6
> + if (kkk(i) /= 7*i) &
> + stop 14
> + end do
> + do i = 1, 5
> + jjj(i) = 4*i
> + end do
> + do i = 1, 6
> + kkk(i) = 8*i
> + end do
> + do i = 1, 5
> + call check_int (jjj(i), 4*i)
> + end do
> + do i = 1, 6
> + call check_int (kkk(i), 8*i)
> + end do
> + if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
> + stop 15
> + ptr = transfer (int (z'abcd', c_intptr_t), ptr)
> + if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) &
> + stop 16
> + call check_ptr (ptr, int (z'abcd', c_intptr_t))
> + !$omp end parallel
> + if (iii /= 5) &
> + stop 17
> + call check_int (iii, 5)
> + do i = 1, 5
> + if (jjj(i) /= 3*i) &
> + stop 18
> + call check_int (jjj(i), 3*i)
> + end do
> + do i = 1, 6
> + if (kkk(i) /= 7*i) &
> + stop 19
> + call check_int (kkk(i), 7*i)
> + end do
> + if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
> + stop 20
> + call check_ptr (ptr, int (z'1234', c_intptr_t))
> + end block
> +end
> +
> +subroutine omp_target ()
> + integer :: i, n, iii, jjj(5)
> + type(c_ptr) :: ptr
> + !$omp allocate(iii, jjj, ptr)
> + n = 6
> + iii = 5
> + ptr = transfer (int (z'1234', c_intptr_t), ptr)
> + block
> + integer :: kkk(n)
> + !$omp allocate(kkk)
> + do i = 1, 5
> + jjj(i) = 3*i
> + end do
> + do i = 1, 6
> + kkk(i) = 7*i
> + end do
> +
> + !$omp target defaultmap(none) firstprivate(iii, jjj, kkk, ptr) private(i)
> + if (iii /= 5) &
> + stop 21
> + iii = 7
> + call check_int (iii, 7)
> + do i = 1, 5
> + if (jjj(i) /= 3*i) &
> + stop 22
> + end do
> + do i = 1, 6
> + if (kkk(i) /= 7*i) &
> + stop 23
> + end do
> + do i = 1, 5
> + jjj(i) = 4*i
> + end do
> + do i = 1, 6
> + kkk(i) = 8*i
> + end do
> + do i = 1, 5
> + call check_int (jjj(i), 4*i)
> + end do
> + do i = 1, 6
> + call check_int (kkk(i), 8*i)
> + end do
> + if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
> + stop 24
> + ptr = transfer (int (z'abcd', c_intptr_t), ptr)
> + if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) &
> + stop 25
> + call check_ptr (ptr, int (z'abcd', c_intptr_t))
> + !$omp end target
> +
> + if (iii /= 5) &
> + stop 26
> + call check_int (iii, 5)
> + do i = 1, 5
> + if (jjj(i) /= 3*i) &
> + stop 27
> + call check_int (jjj(i), 3*i)
> + end do
> + do i = 1, 6
> + if (kkk(i) /= 7*i) &
> + stop 28
> + call check_int (kkk(i), 7*i)
> + end do
> + if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
> + stop 29
> + call check_ptr (ptr, int (z'1234', c_intptr_t))
> +
> + !$omp target defaultmap(firstprivate)
> + if (iii /= 5) &
> + stop 30
> + iii = 7
> + call check_int (iii, 7)
> + do i = 1, 5
> + if (jjj(i) /= 3*i) &
> + stop 31
> + end do
> + do i = 1, 6
> + if (kkk(i) /= 7*i) &
> + stop 32
> + end do
> + do i = 1, 5
> + jjj(i) = 4*i
> + end do
> + do i = 1, 6
> + kkk(i) = 8*i
> + end do
> + do i = 1, 5
> + call check_int (jjj(i), 4*i)
> + end do
> + do i = 1, 6
> + call check_int (kkk(i), 8*i)
> + end do
> + if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
> + stop 33
> + ptr = transfer (int (z'abcd', c_intptr_t), ptr)
> + if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) &
> + stop 34
> + call check_ptr (ptr, int (z'abcd', c_intptr_t))
> + !$omp end target
> + if (iii /= 5) &
> + stop 35
> + call check_int (iii, 5)
> + do i = 1, 5
> + if (jjj(i) /= 3*i) &
> + stop 36
> + call check_int (jjj(i), 3*i)
> + end do
> + do i = 1, 6
> + if (kkk(i) /= 7*i) &
> + stop 37
> + call check_int (kkk(i), 7*i)
> + end do
> + if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
> + stop 38
> + call check_ptr (ptr, int (z'1234', c_intptr_t))
> +
> + !$omp target defaultmap(tofrom)
> + if (iii /= 5) &
> + stop 39
> + iii = 7
> + call check_int (iii, 7)
> + do i = 1, 5
> + if (jjj(i) /= 3*i) &
> + stop 40
> + end do
> + do i = 1, 6
> + if (kkk(i) /= 7*i) &
> + stop 41
> + end do
> + do i = 1, 5
> + jjj(i) = 4*i
> + end do
> + do i = 1, 6
> + kkk(i) = 8*i
> + end do
> + do i = 1, 5
> + call check_int (jjj(i), 4*i)
> + end do
> + do i = 1, 6
> + call check_int (kkk(i), 8*i)
> + end do
> + if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
> + stop 42
> + ptr = transfer (int(z'abcd',c_intptr_t), ptr)
> + if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) &
> + stop 43
> + call check_ptr (ptr, int (z'abcd', c_intptr_t))
> + !$omp end target
> +
> + if (iii /= 7) &
> + stop 44
> + call check_int (iii, 7)
> + do i = 1, 5
> + if (jjj(i) /= 4*i) &
> + stop 45
> + call check_int (jjj(i), 4*i)
> + end do
> + do i = 1, 6
> + if (kkk(i) /= 8*i) &
> + stop 46
> + call check_int (kkk(i), 8*i)
> + end do
> + if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) &
> + stop 47
> + call check_ptr (ptr, int (z'abcd', c_intptr_t))
> + end block
> +end
> +end module
> +
> +
> +use m
> + call omp_parallel ()
> + call omp_target ()
> +end
> diff --git a/libgomp/testsuite/libgomp.fortran/allocate-8.f90 b/libgomp/testsuite/libgomp.fortran/allocate-8.f90
> new file mode 100644
> index 00000000000..b9dea6c5148
> --- /dev/null
> +++ b/libgomp/testsuite/libgomp.fortran/allocate-8.f90
> @@ -0,0 +1,99 @@
> +module m
> +use omp_lib
> +implicit none
> +!!$omp requires dynamic_allocators
> +
> +integer :: final_count
> +
> +type t
> + integer :: i = 0
> + integer, allocatable :: A(:,:)
> +contains
> + final :: count_finalization
> +end type t
> +
> +contains
> +
> +elemental impure subroutine count_finalization(self)
> + type(t), intent(in) :: self
> + final_count = final_count + 1
> +end
> +
> +subroutine test(allocator)
> +integer(omp_allocator_handle_kind), optional, value :: allocator
> +call zero_size(allocator)
> +call finalization_test(allocator)
> +end subroutine test
> +
> +subroutine finalization_test(allocator)
> +integer(omp_allocator_handle_kind), optional, value :: allocator
> +integer :: n = 5
> +
> +final_count = 0;
> +block
> + type(t) :: A
> +! !$omp allocate(A) allocator(allocator)
> + A%i = 1
> +end block
> +if (final_count /= 1) &
> + stop 10
> +
> +final_count = 0;
> +block
> + type(t) :: B(7)
> + !$omp allocate(B) allocator(allocator)
> + B(1)%i = 1
> +end block
> +if (final_count /= 7) stop 10
> +
> +final_count = 0;
> +block
> + type(t) :: C(n)
> +! !$omp allocate(C) allocator(allocator)
> + C(1)%i = 1
> +end block
> +if (final_count /= 5) stop 10
> +
> +final_count = 0;
> +block
> + type(t) :: D(0)
> +! !$omp allocate(D) allocator(allocator)
> + D(1:0)%i = 1
> +end block
> +if (final_count /= 0) stop 10
> +end subroutine
> +
> +subroutine zero_size(allocator)
> +integer(omp_allocator_handle_kind), optional, value :: allocator
> +integer :: n
> +n = -3
> +
> +block
> + integer :: A(n)
> + character(len=n) :: B
> +! !$omp allocate(A,b) allocator(allocator)
> + if (size(A) /= 0 .or. len(b) /= 0) &
> + stop 1
> + B(1:len(b)) ='A'
> +end block
> +
> +!!$omp target
> +block
> + integer :: A(n)
> + character(len=n) :: B
> +! !$omp allocate(A,b) allocator(allocator)
> + if (size(A) /= 0 .or. len(b) /= 0) &
> + stop 2
> + B(1:len(b)) ='A'
> +end block
> +end
> +end module
> +
> +use m
> +call test()
> +call test(omp_default_mem_alloc)
> +call test(omp_large_cap_mem_alloc)
> +call test(omp_high_bw_mem_alloc)
> +call test(omp_low_lat_mem_alloc)
> +call test(omp_cgroup_mem_alloc)
> +end
-----------------
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
next prev parent reply other threads:[~2023-10-18 9:12 UTC|newest]
Thread overview: 7+ messages / expand[flat|nested] mbox.gz Atom feed top
2023-10-10 16:46 Tobias Burnus
2023-10-13 11:01 ` Jakub Jelinek
2023-10-13 13:29 ` Tobias Burnus
2023-10-18 9:12 ` Thomas Schwinge [this message]
2023-10-18 9:36 ` Jakub Jelinek
2023-10-18 10:56 ` [Patch] OpenMP: Avoid ICE with LTO and 'omp allocate (was: [Patch] Fortran: Support OpenMP's 'allocate' directive for stack vars) Tobias Burnus
2023-10-18 11:01 ` Jakub Jelinek
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=87wmvkuwdv.fsf@euler.schwinge.homeip.net \
--to=thomas@codesourcery.com \
--cc=fortran@gcc.gnu.org \
--cc=gcc-patches@gcc.gnu.org \
--cc=jakub@redhat.com \
--cc=tobias@codesourcery.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).