From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from esa3.mentor.iphmx.com (esa3.mentor.iphmx.com [68.232.137.180]) by sourceware.org (Postfix) with ESMTPS id 5AB9C3858D33; Wed, 18 Oct 2023 09:12:58 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 5AB9C3858D33 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 5AB9C3858D33 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=68.232.137.180 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1697620384; cv=none; b=Z2+2qHipdWCR0bVWaFn7mzqupvxQWb7nl1Tjn7ePT7MoAv9PBnGfb7P1NXi3RkVI7Cr8LPREBuWbSeItvXbz9GqzRzY3m1HHkJY0rQqQkIQKAW8i4Z6k6FIykw5qrAnomvY6U5Fm4YqKBrbEVT6ExSI0ZYOhfGw4u0JYa7q/Ifc= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1697620384; c=relaxed/simple; bh=1dXyLYv5N8/s/eOsE5HnTu+ehGoSytzNqdGYF43gplE=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=HZdRvP5fFzfueE7f6CyyVMFTxJAXD01bqN7yN7WPPNhiRlkr5ho9EE6JYLTb8PEXei7fWgo3SRXAlFSIY/AAbeMqgHVNHnjvv/H8Fsz2RtxuTeSL54cmoeyEK/o1Nh0RdVFv/Cfpy9CzcyoJIKJuBqAYuRWlGD1aUlXvyoq7q8g= ARC-Authentication-Results: i=1; server2.sourceware.org X-CSE-ConnectionGUID: HYx1xem5TReG+v2ucSDfeg== X-CSE-MsgGUID: Wx37wu+UToKm/BEtQyJ2/w== X-IronPort-AV: E=Sophos;i="6.03,234,1694764800"; d="scan'208";a="19973721" Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa3.mentor.iphmx.com with ESMTP; 18 Oct 2023 01:12:52 -0800 IronPort-SDR: 9Y8f9PLKX5ul7GzlU+qrQ+VaMxDmyRfo+0kLdA+0TXuuhTDewFiw4DoOZAu1Tlxq+zxYBB8Nwk 3uQLsCbla+fMaxHRMvFMWZg6+WFl5FP02kwp55ZMQ2PDMFKWNpAqSZ1NSHNl6IJi9KwX1Eo3CD P4T6vHGMo64Oob5Cow9BNu2bLjWKdSL2nKf0ank23zoecqW6f3W2oN2YSwg0ugHPjQRfRb8LKs EyM42KBInVzFZ4xOqhRs+Tdukk4naSjm0i/3qdTByfEnWTb2o5SUNqibqlg7qKF9Wj+GVowYpm i9w= From: Thomas Schwinge To: Tobias Burnus CC: Jakub Jelinek , , Subject: Re: [Patch] Fortran: Support OpenMP's 'allocate' directive for stack vars In-Reply-To: <7f16971c-ff06-4e48-85e2-5b38828b7bc2@codesourcery.com> References: <457ea120-5cca-48e0-89d6-c3eab4234b61@codesourcery.com> <7f16971c-ff06-4e48-85e2-5b38828b7bc2@codesourcery.com> User-Agent: Notmuch/0.29.3+94~g74c3f1b (https://notmuchmail.org) Emacs/28.2 (x86_64-pc-linux-gnu) Date: Wed, 18 Oct 2023 11:12:44 +0200 Message-ID: <87wmvkuwdv.fsf@euler.schwinge.homeip.net> MIME-Version: 1.0 Content-Type: text/plain; charset="utf-8" Content-Transfer-Encoding: quoted-printable X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: svr-ies-mbx-11.mgc.mentorg.com (139.181.222.11) To svr-ies-mbx-10.mgc.mentorg.com (139.181.222.10) X-Spam-Status: No, score=-11.1 required=5.0 tests=BAYES_00,GIT_PATCH_0,HEADER_FROM_DIFFERENT_DOMAINS,KAM_DMARC_STATUS,SPF_HELO_PASS,SPF_PASS,TXREP,URIBL_BLACK,WEIRD_PORT autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org List-Id: Hi Tobias! On 2023-10-13T15:29:52+0200, Tobias Burnus wrote: > =3D> 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 com= piler 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: t= ree code 'statement_list' is not supported in LTO streams) +FAIL: libgomp.fortran/allocate-7.f90 -O (internal compiler error: t= ree code 'statement_list' is not supported in LTO streams) Gr=C3=BC=C3=9Fe 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 =3D NULL; > > for (; name; name =3D n) > { > @@ -5552,7 +5553,13 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, boo= l 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 !=3D name->u2.allocator) > + { > + last_allocator =3D 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 =3D *head; n; n =3D n->next) > { > - n->u2.allocator =3D ((allocator) > - ? gfc_copy_expr (allocator) : NULL); > + n->u2.allocator =3D allocator; > n->u.align =3D (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 =3D vars->next) > { > vars->u.align =3D (align) ? gfc_copy_expr (align) : NULL; > - vars->u2.allocator =3D ((allocator) ? gfc_copy_expr (allocator) := NULL); > + vars->u2.allocator =3D 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_na= mespace *ns, > /* Assume that a constant expression in the range 1 (omp_default_mem_all= oc) > 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 =3D list; n; n =3D n->next) > - n->sym->mark =3D 0; > for (gfc_omp_namelist *n =3D list; n; n =3D n->next) > { > + if (n->sym->attr.result || n->sym->result =3D=3D 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 !=3D FL_VARIABLE) > { > gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE " > @@ -7220,8 +7227,7 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_om= p_namelist *list) > &n->where); > continue; > } > - if (ns !=3D n->sym->ns || n->sym->attr.use_assoc > - || n->sym->attr.host_assoc || n->sym->attr.imported) > + if (ns !=3D n->sym->ns || n->sym->attr.use_assoc || n->sym->attr.i= mported) > { > gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shal= l be" > " in the same scope as the variable declaration", > @@ -7234,7 +7240,13 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_o= mp_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_o= mp_namelist *list) > n->sym->name, &n->where); > continue; > } > - n->sym->mark =3D 1; > + /* For 'equivalence(a,b)', a 'union_type { a,b} equiv.0' is = created > + with a value expression for 'a' as 'equiv.0.a' (likewise for b); w= hile > + this can be handled, EQUIVALENCE is marked as obsolescent since Fo= rtran > + 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 !$OM= P " > + "ALLOCATE at %L", n->sym->name, &n->where); > + continue; > + } > + /* Similar for Cray pointer/pointee - they could be implemented bu= t 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 =3D 1; > if ((n->sym->ts.type =3D=3D BT_CLASS && n->sym->attr.class_ok > && CLASS_DATA (n->sym)->attr.allocatable) > || (n->sym->ts.type !=3D BT_CLASS && n->sym->attr.allocatable)) > @@ -7307,8 +7340,6 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_om= p_namelist *list) > "% 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/c= ontains > @@ -7897,6 +7928,9 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clause= s *omp_clauses, > { > if (n->sym =3D=3D NULL) > continue; > + if (n->sym->attr.codimension) > + gfc_error ("Unexpected coarray %qs in % at %L", > + n->sym->name, &n->where); > for (a =3D code->block->next->ext.alloc.list; a; a =3D a->nex= t) > if (a->expr->expr_type =3D=3D EXPR_VARIABLE > && a->expr->symtree->n.sym =3D=3D 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 =3D=3D BT_CLASS && n->sym->attr.class_ok) > alloc_ptr =3D (CLASS_DATA (n->sym)->attr.allocatable > || CLASS_DATA (n->sym)->attr.class_pointer); > else > - alloc_ptr =3D (n->sym->attr.allocatable || n->sym->attr.pointer > - || n->sym->attr.proc_pointer); > + alloc_ptr =3D 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 =3D true; > else > has_non_allocatable =3D 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_sy= mbol * sym, > gimplifier to allocate storage, and all that good stuff. */ > tmp =3D fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (dec= l), decl); > gfc_add_expr_to_block (&init, tmp); > + if (sym->attr.omp_allocate) > + { > + /* Save location of size calculation to ensure GOMP_alloc is plac= ed > + after it. */ > + tree omp_alloc =3D lookup_attribute ("omp allocate", > + DECL_ATTRIBUTES (decl)); > + TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc))) > + =3D 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_sy= mbol * 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 =3D TYPE_SIZE_UNIT (gfc_get_element_type (type)); > + size =3D fold_build2_loc (input_location, MULT_EXPR, gfc_array_ind= ex_type, > + size, fold_convert (gfc_array_index_type, tmp= )); > + size =3D gfc_evaluate_now (size, &init); > > - if (flag_stack_arrays) > + tree omp_alloc =3D lookup_attribute ("omp allocate", > + DECL_ATTRIBUTES (decl)); > + TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc))) > + =3D build_tree_list (size, NULL_TREE); > + space =3D NULL_TREE; > + } > + else if (flag_stack_arrays) > { > gcc_assert (TREE_CODE (TREE_TYPE (decl)) =3D=3D POINTER_TYPE); > space =3D 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, gf= c_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 =3D proc_sym->ns; > + if (proc_sym->ns->proc_name !=3D proc_sym) > + for (omp_ns =3D proc_sym->ns->contained; omp_ns; > + omp_ns =3D omp_ns->sibling) > + if (omp_ns->proc_name =3D=3D proc_sym) > + break; > + > + /* Add 'omp allocate' attribute for gfc_trans_auto_array_allocation an= d > + unset attr.omp_allocate for 'omp allocate allocator(omp_default_mem= _alloc), > + which has the normal codepath except for an invalid-use check in th= e ME. > + The main processing happens later in this function. */ > + for (struct gfc_omp_namelist *n =3D omp_ns ? omp_ns->omp_allocate : NU= LL; > + n; n =3D n->next) > + if (!TREE_STATIC (n->sym->backend_decl)) > + { > + /* Add empty entries - described and to be filled below. */ > + tree tmp =3D build_tree_list (NULL_TREE, NULL_TREE); > + TREE_CHAIN (tmp) =3D build_tree_list (NULL_TREE, NULL_TREE); > + DECL_ATTRIBUTES (n->sym->backend_decl) > + =3D tree_cons (get_identifier ("omp allocate"), tmp, > + DECL_ATTRIBUTES (n->sym->backend_dec= l)); > + if (n->u.align =3D=3D NULL > + && n->u2.allocator !=3D NULL > + && n->u2.allocator->expr_type =3D=3D EXPR_CONSTANT > + && mpz_cmp_si (n->u2.allocator->value.integer, 1) =3D=3D 0) > + n->sym->attr.omp_allocate =3D 0; > + } > + > for (sym =3D proc_sym->tlink; sym !=3D proc_sym; sym =3D sym->tlink) > { > bool alloc_comp_or_fini =3D (sym->ts.type =3D=3D BT_DERIVED) > @@ -5105,6 +5136,101 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, g= fc_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 d= oes > + 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 t= he > + code has to be added, e.g. for character len expressions, which aff= ect > + the UNIT_SIZE. */ > + gfc_expr *last_allocator =3D NULL; > + if (omp_ns && omp_ns->omp_allocate) > + { > + if (!block->init || TREE_CODE (block->init) !=3D STATEMENT_LIST) > + { > + tree tmp =3D build1_v (LABEL_EXPR, gfc_build_label_decl (NULL_TRE= E)); > + append_to_statement_list (tmp, &block->init); > + } > + if (!block->cleanup || TREE_CODE (block->cleanup) !=3D STATEMENT_L= IST) > + { > + tree tmp =3D build1_v (LABEL_EXPR, gfc_build_label_decl (NULL_TRE= E)); > + append_to_statement_list (tmp, &block->cleanup); > + } > + } > + tree init_stmtlist =3D block->init; > + tree cleanup_stmtlist =3D block->cleanup; > + se.expr =3D NULL_TREE; > + for (struct gfc_omp_namelist *n =3D omp_ns ? omp_ns->omp_allocate : NU= LL; > + n; n =3D n->next) > + if (!TREE_STATIC (n->sym->backend_decl)) > + { > + tree align =3D (n->u.align ? gfc_conv_constant_to_tree (n->u.align) > + : NULL_TREE); > + if (last_allocator !=3D n->u2.allocator) > + { > + location_t loc =3D input_location; > + gfc_init_se (&se, NULL); > + if (n->u2.allocator) > + { > + input_location =3D gfc_get_location (&n->u2.allocator->wher= e); > + gfc_conv_expr (&se, n->u2.allocator); > + } > + /* We need to evalulate non-constants - also to find the locati= on > + after which the GOMP_alloc has to be added to - also as BLOC= K > + 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 =3D 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), N= ULL); > + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), > + NULL); > + gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), NU= LL); > + } > + last_allocator =3D n->u2.allocator; > + input_location =3D 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 =3D lookup_attribute ("omp allocate", > + DECL_ATTRIBUTES (n->sym->backend_decl)= ); > + tmp =3D TREE_VALUE (tmp); > + TREE_PURPOSE (tmp) =3D se.expr; > + TREE_VALUE (tmp) =3D align; > + TREE_PURPOSE (TREE_CHAIN (tmp)) =3D init_stmtlist; > + TREE_VALUE (TREE_CHAIN (tmp)) =3D 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 =3D gfc_sym_get_dummy_args (proc_sym); f; f =3D 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_om= p_clauses *clauses, > } > break; > case OMP_LIST_ALLOCATE: > - for (; n !=3D NULL; n =3D n->next) > - if (n->sym->attr.referenced) > - { > - tree t =3D gfc_trans_omp_variable (n->sym, false); > - if (t !=3D error_mark_node) > - { > - tree node =3D build_omp_clause (input_location, > - OMP_CLAUSE_ALLOCATE); > - OMP_CLAUSE_DECL (node) =3D t; > - if (n->u2.allocator) > - { > - tree allocator_; > - gfc_init_se (&se, NULL); > - gfc_conv_expr (&se, n->u2.allocator); > - allocator_ =3D gfc_evaluate_now (se.expr, block); > - OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) =3D allocator_= ; > - } > - if (n->u.align) > - { > - tree align_; > - gfc_init_se (&se, NULL); > - gfc_conv_expr (&se, n->u.align); > - align_ =3D gfc_evaluate_now (se.expr, block); > - OMP_CLAUSE_ALLOCATE_ALIGN (node) =3D align_; > - } > - omp_clauses =3D gfc_trans_add_clause (node, omp_clauses= ); > - } > - } > + { > + tree allocator_ =3D NULL_TREE; > + gfc_expr *alloc_expr =3D NULL; > + for (; n !=3D NULL; n =3D n->next) > + if (n->sym->attr.referenced) > + { > + tree t =3D gfc_trans_omp_variable (n->sym, false); > + if (t !=3D error_mark_node) > + { > + tree node =3D build_omp_clause (input_location, > + OMP_CLAUSE_ALLOCATE); > + OMP_CLAUSE_DECL (node) =3D t; > + if (n->u2.allocator) > + { > + if (alloc_expr !=3D n->u2.allocator) > + { > + gfc_init_se (&se, NULL); > + gfc_conv_expr (&se, n->u2.allocator); > + gfc_add_block_to_block (block, &se.pre); > + allocator_ =3D gfc_evaluate_now (se.expr, blo= ck); > + gfc_add_block_to_block (block, &se.post); > + } > + OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) =3D allocato= r_; > + } > + alloc_expr =3D 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 =3D=3D NULL > + && se.post.head =3D=3D NULL); > + align_ =3D se.expr; > + OMP_CLAUSE_ALLOCATE_ALIGN (node) =3D align_; > + } > + omp_clauses =3D gfc_trans_add_clause (node, omp_claus= es); > + } > + } > + else > + alloc_expr =3D n->u2.allocator; > + } > break; > case OMP_LIST_LINEAR: > { > @@ -7184,11 +7198,14 @@ gfc_trans_omp_sections (gfc_code *code, gfc_omp_c= lauses *clauses) > static tree > gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses) > { > - tree omp_clauses =3D gfc_trans_omp_clauses (NULL, clauses, code->loc); > + stmtblock_t block; > + gfc_start_block (&block); > + tree omp_clauses =3D gfc_trans_omp_clauses (&block, clauses, code->loc= ); > tree stmt =3D gfc_trans_omp_code (code->block->next, true); > stmt =3D build2_loc (gfc_get_location (&code->loc), OMP_SINGLE, void_t= ype_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 =3D=3D NULL_TREE > || !integer_onep (alloc))) > { > - tree tmp =3D build_pointer_type (TREE_TYPE (t)); > - tree v =3D create_tmp_var (tmp, get_name (t)); > - DECL_IGNORED_P (v) =3D 0; > - tmp =3D remove_attribute ("omp allocate", DECL_ATTRIBUTES= (t)); > - DECL_ATTRIBUTES (v) > - =3D tree_cons (get_identifier ("omp allocate var"), > - build_tree_list (NULL_TREE, t), tmp); > - tmp =3D build_fold_indirect_ref (v); > - TREE_THIS_NOTRAP (tmp) =3D 1; > - SET_DECL_VALUE_EXPR (t, tmp); > - DECL_HAS_VALUE_EXPR_P (t) =3D 1; > - tree sz =3D 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_fun= ptr); > + note that normal proc pointers are rejected. */ > + tree type =3D TREE_TYPE (t); > + tree tmp, v; > + if (lang_GNU_Fortran () > + && POINTER_TYPE_P (type) > + && TREE_TYPE (type) !=3D void_type_node > + && TREE_CODE (TREE_TYPE (type)) !=3D FUNCTION_TYPE) > + { > + type =3D TREE_TYPE (type); > + v =3D t; > + } > + else > + { > + tmp =3D build_pointer_type (type); > + v =3D create_tmp_var (tmp, get_name (t)); > + DECL_IGNORED_P (v) =3D 0; > + DECL_ATTRIBUTES (v) > + =3D tree_cons (get_identifier ("omp allocate var"), > + build_tree_list (NULL_TREE, t), > + DECL_ATTRIBUTES (t)); > + tmp =3D build_fold_indirect_ref (v); > + TREE_THIS_NOTRAP (tmp) =3D 1; > + SET_DECL_VALUE_EXPR (t, tmp); > + DECL_HAS_VALUE_EXPR_P (t) =3D 1; > + } > + tree sz =3D TYPE_SIZE_UNIT (type); > + /* The size to use in Fortran might not match TYPE_SIZE_U= NIT; > + 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 =3D TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr))); > + sz =3D TREE_PURPOSE (sz); > + } > if (alloc =3D=3D NULL_TREE) > alloc =3D build_zero_cst (ptr_type_node); > if (align =3D=3D NULL_TREE) > @@ -1425,28 +1452,93 @@ gimplify_bind_expr (tree *expr_p, gimple_seq *pre= _p) > align =3D build_int_cst (size_type_node, > MAX (tree_to_uhwi (align), > DECL_ALIGN_UNIT (t))); > + location_t loc =3D DECL_SOURCE_LOCATION (t); > tmp =3D builtin_decl_explicit (BUILT_IN_GOMP_ALLOC); > - tmp =3D build_call_expr_loc (DECL_SOURCE_LOCATION (t), tm= p, > - 3, align, sz, alloc); > - tmp =3D fold_build2_loc (DECL_SOURCE_LOCATION (t), MODIFY= _EXPR, > - TREE_TYPE (v), v, > + tmp =3D build_call_expr_loc (loc, tmp, 3, align, sz, allo= c); > + tmp =3D fold_build2_loc (loc, MODIFY_EXPR, TREE_TYPE (v),= v, > fold_convert (TREE_TYPE (v), tmp))= ; > - gcc_assert (BIND_EXPR_BODY (bind_expr) !=3D NULL_TREE > - && (TREE_CODE (BIND_EXPR_BODY (bind_expr)) > - =3D=3D STATEMENT_LIST)); > - tree_stmt_iterator e =3D tsi_start (BIND_EXPR_BODY (bind_= expr)); > - while (!tsi_end_p (e)) > + gcc_assert (BIND_EXPR_BODY (bind_expr) !=3D NULL_TREE); > + /* Ensure that either TREE_CHAIN (TREE_VALUE (attr) is se= t > + 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) =3D=3D DECL_EXPR > - && TREE_OPERAND (*e, 0) =3D=3D t) > - || (TREE_CODE (*e) =3D=3D CLEANUP_POINT_EXPR > - && TREE_CODE (TREE_OPERAND (*e, 0)) =3D=3D DE= CL_EXPR > - && TREE_OPERAND (TREE_OPERAND (*e, 0), 0) =3D= =3D t)) > - break; > + /* Fortran is special as it does not have properly ne= st > + declarations in blocks. And as there is no > + initializer, there is also no expression to look f= or. > + Hence, the FE makes the statement list of the > + try-finally block available. We can put the GOMP_a= lloc > + at the top, unless an allocator or size expression > + requires to put it afterward; note that the size i= s > + always later in generated code; for strings, no > + size expr but still an expr might be available. *= / > + tree sl =3D TREE_PURPOSE (TREE_CHAIN (TREE_VALUE (att= r))); > + tree_stmt_iterator e =3D tsi_start (sl); > + tree needle =3D NULL_TREE; > + if (TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr)))) > + { > + needle =3D TREE_CHAIN (TREE_CHAIN (TREE_VALUE (at= tr))); > + needle =3D (TREE_VALUE (needle) ? TREE_VALUE (nee= dle) > + : sz); > + } > + else if (TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr)))) > + needle =3D sz; > + else if (DECL_P (alloc) && DECL_ARTIFICIAL (alloc)) > + needle =3D alloc; > + > + if (needle !=3D NULL_TREE) > + { > + while (!tsi_end_p (e)) > + { > + if (*e =3D=3D needle > + || (TREE_CODE (*e) =3D=3D MODIFY_EXPR > + && TREE_OPERAND (*e, 0) =3D=3D 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 =3D TREE_VALUE (TREE_CHAIN (TREE_VALUE (attr))); > + e =3D tsi_last (sl); > + tmp =3D builtin_decl_explicit (BUILT_IN_GOMP_FREE); > + tmp =3D build_call_expr_loc (EXPR_LOCATION (*e), tmp,= 2, v, > + build_zero_cst (ptr_type_n= ode)); > + tsi_link_after (&e, tmp, TSI_SAME_STMT); > + tmp =3D build_clobber (TREE_TYPE (v), CLOBBER_EOL); > + tmp =3D fold_build2_loc (loc, MODIFY_EXPR, TREE_TYPE = (v), v, > + fold_convert (TREE_TYPE (v), t= mp)); > ++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)) > + =3D=3D STATEMENT_LIST); > + tree_stmt_iterator e; > + e =3D tsi_start (BIND_EXPR_BODY (bind_expr)); > + while (!tsi_end_p (e)) > + { > + if ((TREE_CODE (*e) =3D=3D DECL_EXPR > + && TREE_OPERAND (*e, 0) =3D=3D t) > + || (TREE_CODE (*e) =3D=3D CLEANUP_POINT_EXPR > + && (TREE_CODE (TREE_OPERAND (*e, 0)) > + =3D=3D DECL_EXPR) > + && (TREE_OPERAND (TREE_OPERAND (*e, 0), 0= ) > + =3D=3D 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) =3D=3D 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 =3D lookup_attribute ("omp allocate", > + DECL_ATTRIBUTES (t))) !=3D NULL= _TREE) > + && TREE_CHAIN (TREE_VALUE (attr)) =3D=3D NULL_TREE) > { > + /* For Fortran, TREE_CHAIN (TREE_VALUE (attr)) is set, which > + causes that the GOMP_free call is already added above. */ > + tree v =3D TREE_OPERAND (DECL_VALUE_EXPR (t), 0); > tree tmp =3D builtin_decl_explicit (BUILT_IN_GOMP_FREE); > - tmp =3D build_call_expr_loc (end_locus, tmp, 2, > - TREE_OPERAND (DECL_VALUE_EXPR (t),= 0), > + tmp =3D build_call_expr_loc (end_locus, tmp, 2, v, > build_zero_cst (ptr_type_node)); > gimplify_and_add (tmp, &cleanup); > + gimple *clobber_stmt; > + tmp =3D build_clobber (TREE_TYPE (v), CLOBBER_EOL); > + clobber_stmt =3D 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/testsuit= e/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' insi= de 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/testsuit= e/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] =3D {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/testsui= te/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 =3D c_intptr_t > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_null_allocator =3D 0 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_default_mem_alloc =3D 1 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_large_cap_mem_alloc =3D 2 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_const_mem_alloc =3D 3 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_high_bw_mem_alloc =3D 4 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_low_lat_mem_alloc =3D 5 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_cgroup_mem_alloc =3D 6 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_pteam_mem_alloc =3D 7 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_thread_mem_alloc =3D 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 =3D __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) =3D 5 > + ! { dg-final { scan-tree-dump-times "b1.\[0-9\]+ =3D __builtin_GOMP_al= loc \\(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_hand= le' is used uninitialized" } > + ! Similar above; B2 is unused - but in gfortran, the match in 'alloc= ate(B2)' already > + ! causes TREE_USED =3D 1 > + ! { dg-final { scan-tree-dump-times "b2.\[0-9\]+ =3D __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/testsui= te/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 =3D c_intptr_t > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_null_allocator =3D 0 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_default_mem_alloc =3D 1 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_large_cap_mem_alloc =3D 2 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_const_mem_alloc =3D 3 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_high_bw_mem_alloc =3D 4 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_low_lat_mem_alloc =3D 5 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_cgroup_mem_alloc =3D 6 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_pteam_mem_alloc =3D 7 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_thread_mem_alloc =3D 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 IMPLI= CIT type; did you mean 'omp_low_lat_mem_alloc'\\\?" "" { target *-*-* } .-1= } > + ! { dg-error "Expected integer expression of the 'omp_allocator_hand= le_kind' kind at .1." "" { target *-*-* } .-2 } > + i =3D 4 > + !$omp end parallel > +end > diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-12.f90 b/gcc/testsui= te/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 =3D 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) =3D 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/testsui= te/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 =3D 5 > +end > + > +subroutine h () > + !$omp target > + !$omp parallel > + !$omp single > + block > + integer :: var2(5) > + !$omp allocate(var2) > + var2(1) =3D 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/testsui= te/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=3Dsingle -fcray-pointer" } > + > +module m > +use iso_c_binding > +integer, parameter :: omp_allocator_handle_kind =3D c_intptr_t > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_null_allocator =3D 0 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_default_mem_alloc =3D 1 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_large_cap_mem_alloc =3D 2 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_const_mem_alloc =3D 3 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_high_bw_mem_alloc =3D 4 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_low_lat_mem_alloc =3D 5 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_cgroup_mem_alloc =3D 6 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_pteam_mem_alloc =3D 7 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_thread_mem_alloc =3D 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 argu= ment at .1. to declarative !.OMP ALLOCATE" } > + > + !$omp allocators allocate(y) ! { dg-error "28:Unexpected coarray 'y' i= n 'allocate' at .1." } > + allocate(y[*]) > + > + !$omp allocate(z) ! { dg-error "17:Unexpected coarray 'z' in 'allocate= ' at .1." } > + allocate(z(5)[*]) > + x =3D 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 =3D 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=3D5) > + deallocate(res) > + > + !$omp allocate (res) > + allocate(res, source=3D5) > +end > + > + > +subroutine cray_ptr() > + real pointee(10) > + pointer (ipt, pointee) > + !$omp allocate(pointee) ! { dg-error "Sorry, Cray pointers and point= ees such as 'pointee' are not supported with !.OMP ALLOCATE at .1." } > + !$omp allocate(ipt) ! { dg-error "Sorry, Cray pointers and point= ees 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 su= pported with !.OMP ALLOCATE at .1." } > + !$omp allocate (B) ! { dg-error "Sorry, EQUIVALENCE object 'b' not su= pported 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' a= t .1. is part of the common block '/my/' and may only be specificed implici= tly 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/testsui= te/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 =3D c_intptr_t > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_null_allocator =3D 0 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_default_mem_alloc =3D 1 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_large_cap_mem_alloc =3D 2 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_const_mem_alloc =3D 3 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_high_bw_mem_alloc =3D 4 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_low_lat_mem_alloc =3D 5 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_cgroup_mem_alloc =3D 6 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_pteam_mem_alloc =3D 7 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_thread_mem_alloc =3D 8 > +end > + > +subroutine common > + use m > + integer :: a,b,c(5) > + common /my/ a,b,c ! { dg-error "Sorry, !.OMP allocate for COMMON bloc= k 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) =3D [1,2,3,4,5] ! { dg-error "Sorry, !.OMP allo= cate for variable 'a' at .1. with SAVE attribute not yet implemented" } > + !$omp allocate(a) allocator(omp_high_bw_mem_alloc) > + res =3D a(4) > +end > + > + > diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 b/gcc/testsuit= e/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=3Domp_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/testsuit= e/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=3D5 > > !$omp allocate(prm) align(64) ! { dg-error "Argument 'prm' at .1. to dec= larative !.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 "Argum= ent '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 "Unexpecte= d 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 "Argu= ment '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 "Duplica= ted variable 'c' in !.OMP ALLOCATE" } > !$omp allocate (/com4/) allocator (omp_pteam_mem_alloc) ! { dg-error "Du= plicated 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 pos= itive 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 pos= itive constant integer alignment expression at .1. that is a power of two" = } > !$omp allocate (ss) align([4]) ! { dg-error "ALIGN requires a scalar pos= itive constant integer alignment expression at .1. that is a power of two" = } > !$omp allocate (tt) align(32.0) ! { dg-error "ALIGN requires a scalar po= sitive 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 expre= ssion 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 expre= ssion of the 'omp_allocator_handle_kind' kind" } > !$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Expe= cted 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 r= equired in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAV= E attribute" } > -! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported= " "" { target *-*-* } .-1 } > !$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator r= equired in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAV= E attribute" } > !$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Pred= efined 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 alloca= tor required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has th= e 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 r= equired in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAV= E attribute" } > -! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported= " "" { target *-*-* } .-1 } > !$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator r= equired in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAV= E attribute" } > !$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Pred= efined 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 alloca= tor required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has th= e 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 r= equired in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAV= E attribute" } > -! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported= " "" { target *-*-* } .-1 } > !$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator r= equired in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAV= E attribute" } > !$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Pred= efined 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 alloca= tor required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has th= e 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 r= equired in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAV= E attribute" } > -! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported= " "" { target *-*-* } .-1 } > !$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator r= equired in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAV= E attribute" } > !$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Pred= efined 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 alloca= tor required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has th= e 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 alloc= ator 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 alloc= ator 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/' a= t .2. has the SAVE attribute" } > diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-8.f90 b/gcc/testsuit= e/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 =3D c_intptr_t > + integer :: a =3D 0, b =3D 42, c =3D 0 > + > +contains > + integer(omp_allocator_handle_kind) function get_alloc() > + allocatable :: get_alloc > + get_alloc =3D 2_omp_allocator_handle_kind > + end > + subroutine foo () > + !$omp scope private (a) firstprivate (b) reduction (+: c) allocate ( g= et_alloc() : a , b , c) > + if (b /=3D 42) & > + error stop > + a =3D 36 > + b =3D 15 > + c =3D 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\\) alloca= te\\(allocator\\(D\\.\[0-9\]+\\):b\\) allocate\\(allocator\\(D\\.\[0-9\]+\\= ):c\\)" "original" } } > + > +! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ =3D get_alloc \\(\\);\= [\n\r\]+ *D\\.\[0-9\]+ =3D \\*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/testsuit= e/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 =3D c_intptr_t > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_null_allocator =3D 0 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_default_mem_alloc =3D 1 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_large_cap_mem_alloc =3D 2 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_const_mem_alloc =3D 3 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_high_bw_mem_alloc =3D 4 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_low_lat_mem_alloc =3D 5 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_cgroup_mem_alloc =3D 6 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_pteam_mem_alloc =3D 7 > + integer (kind=3Domp_allocator_handle_kind), & > + parameter :: omp_thread_mem_alloc =3D 8 > +end > + > + > +module m2 > + use m > + implicit none > + integer :: A(5) =3D [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 l= ist item 'a' at .2. has the SAVE attribute" } > + > +! typo in allocator name: > +!$omp allocate(A2) allocator(omp_low_latency_mem_alloc) ! { dg-error "S= ymbol '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. a= s 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-err= or "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 requir= ed 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-e= rror "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 sa= me scope as the variable declaration" } > + f =3D A(1) > +end > + > +integer function g() > + integer :: a2, b2 > + !$omp allocate(a2) > + !$omp allocate(a2) ! { dg-error "Duplicated variable 'a2' in !.OMP AL= LOCATE at .1." } > + a2=3D1; b2=3D2 > + block > + integer :: c2 > + !$omp allocate(c2, b2) ! { dg-error "Argument 'b2' at .1. to declara= tive !.OMP ALLOCATE shall be in the same scope as the variable declaration"= } > + c2 =3D 3 > + g =3D c2+a2+b2 > + end block > +end > + > +integer function h(q) > + integer :: q > + !$omp allocate(q) ! { dg-error "Unexpected dummy argument 'q' as argu= ment at .1. to declarative !.OMP ALLOCATE" } > + h =3D q > +end > + > +integer function k () > + integer, save :: var3 =3D 8 > + !$omp allocate(var3) allocator(-1_omp_allocator_handle_kind) ! { dg-e= rror "Predefined allocator required in ALLOCATOR clause at .1. as the list = item 'var3' at .2. has the SAVE attribute" } > + k =3D var3 > +end > +end module > + > + > +subroutine foo > + integer :: a, b > + integer :: c, d,h > + !$omp allocate(a,b) > + b =3D 1; d =3D 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 =3D 1; c =3D 2; e =3D 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 sta= ck 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 @t= ab > diff --git a/libgomp/testsuite/libgomp.fortran/allocate-5.f90 b/libgomp/t= estsuite/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\]+ =3D __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 =3D omp_low_lat_mem= _alloc > + integer :: n =3D 25 > + sum =3D 0 > + block > + type(omp_alloctrait) :: traits(1) =3D [ omp_alloctrait(omp_atk_alignme= nt, 64) ] > + integer :: A(n) > + !$omp allocate(A) align(128) allocator(my_allocator) > + ! { dg-final { scan-tree-dump-times "a =3D __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) /=3D 0) & > + stop 2 > + do i =3D 1, n > + A(i) =3D i > + end do > + > + my_allocator =3D 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 =3D __builtin_GOMP_alloc \\(\= [0-9\]+, D\\.\[0-9\]+, D\\.\[0-9\]+\\);" 1 "gimple" } } > + ! { dg-final { scan-tree-dump-times "c\\.\[0-9\]+ =3D __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\]+ =3D __builtin_GOMP= _alloc \\(256, 20, 0B\\);" 1 "gimple" } } > + ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(d\\.\[0-= 9\]+, 0B\\);" 1 "gimple" } } > + > + B =3D 0 > + C =3D [1,2,3,4,5] > + D =3D [11,22,33,44,55] > + > + if (mod (transfer(loc(B), intptr), 64_c_intptr_t) /=3D 0) & > + stop 3 > + if (mod (transfer(loc(C), intptr), 64_c_intptr_t) /=3D 0) & > + stop 4 > + if (mod (transfer(loc(D), intptr), 256_c_intptr_t) /=3D 0) & > + stop 5 > + > + do i =3D 1, 5 > + if (C(i) /=3D i) & > + stop 6 > + if (D(i) /=3D i + 10*i) & > + stop 7 > + end do > + > + do i =3D 1, n > + if (B(i) /=3D 0) & > + stop 9 > + sum =3D 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 =3D sum > +end > +end module > + > +use m > +if (one () /=3D 1225) & > + stop 1 > +end > diff --git a/libgomp/testsuite/libgomp.fortran/allocate-6.f90 b/libgomp/t= estsuite/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 =3D 0 > + n =3D 3 > + !$omp target map(tofrom: result) firstprivate(n) > + block > + integer :: var, var2(n) > + !$omp allocate(var,var2) align(128) allocator(omp_low_lat_mem_allo= c) > + var =3D 5 > +! { dg-final { scan-tree-dump-times "var\\.\[0-9\]+ =3D __builtin_GOMP_a= lloc \\(128, 4, 5\\);" 1 "gimple" } } */ > +! { dg-final { scan-tree-dump-times "var2\\.\[0-9\]+ =3D __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) /=3D 0) & > + stop 1 > + if (mod(transfer(loc(var2), intptr), 128_c_intptr_t) /=3D 0) & > + stop 2 > + if (var /=3D 5) & > + stop 3 > + > + !$omp parallel do > + do i =3D 1, n > + var2(i) =3D (i+32); > + end do > + > + !$omp parallel loop reduction(+:result) > + do i =3D 1, n > + result =3D result + var + var2(i) > + end do > + end block > + if (result /=3D (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\]+ =3D __builtin_GOM= P_alloc \\(4, 4, 0B\\);" 1 "gimple" } } > +! { dg-final { scan-tree-dump-times "array\\.\[0-9\]+ =3D __builtin_GOMP= _alloc \\(4, 20, 0B\\);" 1 "gimple" } } > +! { dg-final { scan-tree-dump-times "s\\.\[0-9\]+ =3D __builtin_GOMP_all= oc \\(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 =3D 44 > + array =3D [1,2,3,4,5] > + s =3D st(a=3D11, b=3D56) > + > + !$omp parallel firstprivate(scalar) firstprivate(array) firstprivate(s= ) > + if (scalar /=3D 44) & > + stop 5 > + scalar =3D 33; > + if (any (array /=3D [1,2,3,4,5])) & > + stop 6 > + array =3D [10,20,30,40,50] > + if (s%a /=3D 11 .or. s%b /=3D 56) & > + stop 7 > + s%a =3D 74 > + s%b =3D 674 > + !$omp end parallel > + > + if (scalar /=3D 44) & > + stop 8 > + if (any (array /=3D [1,2,3,4,5])) & > + stop 9 > + if (s%a /=3D 11 .or. s%b /=3D 56) & > + stop 10 > + > + !$omp target defaultmap(firstprivate : scalar) defaultmap(none : aggre= gate) defaultmap(none : pointer) > + if (scalar /=3D 44) & > + stop 11 > + scalar =3D 33; > + !$omp end target > + > + if (scalar /=3D 44) & > + stop 12 > + > + !$omp target defaultmap(none : scalar) defaultmap(firstprivate : aggre= gate) defaultmap(none : pointer) private(i) > + if (any (array /=3D [1,2,3,4,5])) & > + stop 13 > + do i =3D 1, 5 > + array(i) =3D 10*i > + end do > + !$omp end target > + > + if (any(array /=3D [1,2,3,4,5])) & > + stop 13 > + !$omp target defaultmap(none : scalar) defaultmap(firstprivate : aggre= gate) defaultmap(none : pointer) > + if (s%a /=3D 11 .or. s%b /=3D 56) & > + stop 14 > + s%a =3D 74 > + s%b =3D 674 > + !$omp end target > + if (s%a /=3D 11 .or. s%b /=3D 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/t= estsuite/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_fun= c. > +! { dg-final { scan-tree-dump-times "__builtin_GOMP_alloc \\(" 10 "omplo= wer" } } > +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(" 10 "omplow= er" } } > + > +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 /=3D y) & > + stop 1 > +end > + > +subroutine check_ptr (x, y) > + type(c_ptr) :: x > + integer(c_intptr_t), value :: y > + if (transfer(x,intptr) /=3D y) & > + stop 2 > +end > + > +integer function no_alloc_func () result(res) > + ! There is no __builtin_GOMP_alloc / __builtin_GOMP_free as > + ! allocator =3D=3D omp_default_mem_alloc (known at compile time. > + integer :: no_alloc > + !$omp allocate(no_alloc) allocator(omp_default_mem_alloc) > + no_alloc =3D 7 > + res =3D 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 =3D 7 > + res =3D is_alloc2 > +end > + > + > +subroutine omp_parallel () > + integer :: i, n, iii, jjj(5) > + type(c_ptr) :: ptr > + !$omp allocate(iii, jjj, ptr) > + n =3D 6 > + iii =3D 5 > + ptr =3D transfer (int(z'1234', c_intptr_t), ptr) > + block > + integer :: kkk(n) > + !$omp allocate(kkk) > + > + do i =3D 1, 5 > + jjj(i) =3D 3*i > + end do > + do i =3D 1, 6 > + kkk(i) =3D 7*i > + end do > + > + !$omp parallel default(none) firstprivate(iii, jjj, kkk, ptr) if(.fals= e.) > + if (iii /=3D 5) & > + stop 3 > + iii =3D 7 > + call check_int (iii, 7) > + do i =3D 1, 5 > + if (jjj(i) /=3D 3*i) & > + stop 4 > + end do > + do i =3D 1, 6 > + if (kkk(i) /=3D 7*i) & > + stop 5 > + end do > + do i =3D 1, 5 > + jjj(i) =3D 4*i > + end do > + do i =3D 1, 6 > + kkk(i) =3D 8*i > + end do > + do i =3D 1, 5 > + call check_int (jjj(i), 4*i) > + end do > + do i =3D 1, 6 > + call check_int (kkk(i), 8*i) > + end do > + if (transfer (ptr, intptr) /=3D int(z'1234', c_intptr_t)) & > + stop 6 > + ptr =3D transfer (int(z'abcd', c_intptr_t), ptr) > + if (transfer (ptr, intptr) /=3D int(z'abcd', c_intptr_t)) & > + stop 7 > + call check_ptr (ptr, int(z'abcd', c_intptr_t)) > + !$omp end parallel > + > + if (iii /=3D 5) & > + stop 8 > + call check_int (iii, 5) > + do i =3D 1, 5 > + if (jjj(i) /=3D 3*i) & > + stop 9 > + call check_int (jjj(i), 3*i) > + end do > + do i =3D 1, 6 > + if (kkk(i) /=3D 7*i) & > + stop 10 > + call check_int (kkk(i), 7*i) > + end do > + if (transfer (ptr, intptr) /=3D 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 /=3D 5) & > + stop 12 > + iii =3D 7 > + call check_int (iii, 7) > + do i =3D 1, 5 > + if (jjj(i) /=3D 3*i) & > + stop 13 > + end do > + do i =3D 1, 6 > + if (kkk(i) /=3D 7*i) & > + stop 14 > + end do > + do i =3D 1, 5 > + jjj(i) =3D 4*i > + end do > + do i =3D 1, 6 > + kkk(i) =3D 8*i > + end do > + do i =3D 1, 5 > + call check_int (jjj(i), 4*i) > + end do > + do i =3D 1, 6 > + call check_int (kkk(i), 8*i) > + end do > + if (transfer (ptr, intptr) /=3D int(z'1234', c_intptr_t)) & > + stop 15 > + ptr =3D transfer (int (z'abcd', c_intptr_t), ptr) > + if (transfer (ptr, intptr) /=3D int(z'abcd', c_intptr_t)) & > + stop 16 > + call check_ptr (ptr, int (z'abcd', c_intptr_t)) > + !$omp end parallel > + if (iii /=3D 5) & > + stop 17 > + call check_int (iii, 5) > + do i =3D 1, 5 > + if (jjj(i) /=3D 3*i) & > + stop 18 > + call check_int (jjj(i), 3*i) > + end do > + do i =3D 1, 6 > + if (kkk(i) /=3D 7*i) & > + stop 19 > + call check_int (kkk(i), 7*i) > + end do > + if (transfer (ptr, intptr) /=3D 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 =3D 6 > + iii =3D 5 > + ptr =3D transfer (int (z'1234', c_intptr_t), ptr) > + block > + integer :: kkk(n) > + !$omp allocate(kkk) > + do i =3D 1, 5 > + jjj(i) =3D 3*i > + end do > + do i =3D 1, 6 > + kkk(i) =3D 7*i > + end do > + > + !$omp target defaultmap(none) firstprivate(iii, jjj, kkk, ptr) private= (i) > + if (iii /=3D 5) & > + stop 21 > + iii =3D 7 > + call check_int (iii, 7) > + do i =3D 1, 5 > + if (jjj(i) /=3D 3*i) & > + stop 22 > + end do > + do i =3D 1, 6 > + if (kkk(i) /=3D 7*i) & > + stop 23 > + end do > + do i =3D 1, 5 > + jjj(i) =3D 4*i > + end do > + do i =3D 1, 6 > + kkk(i) =3D 8*i > + end do > + do i =3D 1, 5 > + call check_int (jjj(i), 4*i) > + end do > + do i =3D 1, 6 > + call check_int (kkk(i), 8*i) > + end do > + if (transfer (ptr, intptr) /=3D int(z'1234', c_intptr_t)) & > + stop 24 > + ptr =3D transfer (int (z'abcd', c_intptr_t), ptr) > + if (transfer (ptr, intptr) /=3D int(z'abcd', c_intptr_t)) & > + stop 25 > + call check_ptr (ptr, int (z'abcd', c_intptr_t)) > + !$omp end target > + > + if (iii /=3D 5) & > + stop 26 > + call check_int (iii, 5) > + do i =3D 1, 5 > + if (jjj(i) /=3D 3*i) & > + stop 27 > + call check_int (jjj(i), 3*i) > + end do > + do i =3D 1, 6 > + if (kkk(i) /=3D 7*i) & > + stop 28 > + call check_int (kkk(i), 7*i) > + end do > + if (transfer (ptr, intptr) /=3D int(z'1234', c_intptr_t)) & > + stop 29 > + call check_ptr (ptr, int (z'1234', c_intptr_t)) > + > + !$omp target defaultmap(firstprivate) > + if (iii /=3D 5) & > + stop 30 > + iii =3D 7 > + call check_int (iii, 7) > + do i =3D 1, 5 > + if (jjj(i) /=3D 3*i) & > + stop 31 > + end do > + do i =3D 1, 6 > + if (kkk(i) /=3D 7*i) & > + stop 32 > + end do > + do i =3D 1, 5 > + jjj(i) =3D 4*i > + end do > + do i =3D 1, 6 > + kkk(i) =3D 8*i > + end do > + do i =3D 1, 5 > + call check_int (jjj(i), 4*i) > + end do > + do i =3D 1, 6 > + call check_int (kkk(i), 8*i) > + end do > + if (transfer (ptr, intptr) /=3D int(z'1234', c_intptr_t)) & > + stop 33 > + ptr =3D transfer (int (z'abcd', c_intptr_t), ptr) > + if (transfer (ptr, intptr) /=3D int(z'abcd', c_intptr_t)) & > + stop 34 > + call check_ptr (ptr, int (z'abcd', c_intptr_t)) > + !$omp end target > + if (iii /=3D 5) & > + stop 35 > + call check_int (iii, 5) > + do i =3D 1, 5 > + if (jjj(i) /=3D 3*i) & > + stop 36 > + call check_int (jjj(i), 3*i) > + end do > + do i =3D 1, 6 > + if (kkk(i) /=3D 7*i) & > + stop 37 > + call check_int (kkk(i), 7*i) > + end do > + if (transfer (ptr, intptr) /=3D int(z'1234', c_intptr_t)) & > + stop 38 > + call check_ptr (ptr, int (z'1234', c_intptr_t)) > + > + !$omp target defaultmap(tofrom) > + if (iii /=3D 5) & > + stop 39 > + iii =3D 7 > + call check_int (iii, 7) > + do i =3D 1, 5 > + if (jjj(i) /=3D 3*i) & > + stop 40 > + end do > + do i =3D 1, 6 > + if (kkk(i) /=3D 7*i) & > + stop 41 > + end do > + do i =3D 1, 5 > + jjj(i) =3D 4*i > + end do > + do i =3D 1, 6 > + kkk(i) =3D 8*i > + end do > + do i =3D 1, 5 > + call check_int (jjj(i), 4*i) > + end do > + do i =3D 1, 6 > + call check_int (kkk(i), 8*i) > + end do > + if (transfer (ptr, intptr) /=3D int(z'1234', c_intptr_t)) & > + stop 42 > + ptr =3D transfer (int(z'abcd',c_intptr_t), ptr) > + if (transfer (ptr, intptr) /=3D int(z'abcd', c_intptr_t)) & > + stop 43 > + call check_ptr (ptr, int (z'abcd', c_intptr_t)) > + !$omp end target > + > + if (iii /=3D 7) & > + stop 44 > + call check_int (iii, 7) > + do i =3D 1, 5 > + if (jjj(i) /=3D 4*i) & > + stop 45 > + call check_int (jjj(i), 4*i) > + end do > + do i =3D 1, 6 > + if (kkk(i) /=3D 8*i) & > + stop 46 > + call check_int (kkk(i), 8*i) > + end do > + if (transfer (ptr, intptr) /=3D 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/t= estsuite/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 =3D 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 =3D 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 =3D 5 > + > +final_count =3D 0; > +block > + type(t) :: A > +! !$omp allocate(A) allocator(allocator) > + A%i =3D 1 > +end block > +if (final_count /=3D 1) & > + stop 10 > + > +final_count =3D 0; > +block > + type(t) :: B(7) > + !$omp allocate(B) allocator(allocator) > + B(1)%i =3D 1 > +end block > +if (final_count /=3D 7) stop 10 > + > +final_count =3D 0; > +block > + type(t) :: C(n) > +! !$omp allocate(C) allocator(allocator) > + C(1)%i =3D 1 > +end block > +if (final_count /=3D 5) stop 10 > + > +final_count =3D 0; > +block > + type(t) :: D(0) > +! !$omp allocate(D) allocator(allocator) > + D(1:0)%i =3D 1 > +end block > +if (final_count /=3D 0) stop 10 > +end subroutine > + > +subroutine zero_size(allocator) > +integer(omp_allocator_handle_kind), optional, value :: allocator > +integer :: n > +n =3D -3 > + > +block > + integer :: A(n) > + character(len=3Dn) :: B > +! !$omp allocate(A,b) allocator(allocator) > + if (size(A) /=3D 0 .or. len(b) /=3D 0) & > + stop 1 > + B(1:len(b)) =3D'A' > +end block > + > +!!$omp target > +block > + integer :: A(n) > + character(len=3Dn) :: B > +! !$omp allocate(A,b) allocator(allocator) > + if (size(A) /=3D 0 .or. len(b) /=3D 0) & > + stop 2 > + B(1:len(b)) =3D'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=C3=9Fe 201= , 80634 M=C3=BCnchen; Gesellschaft mit beschr=C3=A4nkter Haftung; Gesch=C3= =A4ftsf=C3=BChrer: Thomas Heurung, Frank Th=C3=BCrauf; Sitz der Gesellschaf= t: M=C3=BCnchen; Registergericht M=C3=BCnchen, HRB 106955