diff --git a/flang/lib/Semantics/resolve-directives.cpp b/flang/lib/Semantics/resolve-directives.cpp index 218e3e7266ca9..9e5357160ea16 100644 --- a/flang/lib/Semantics/resolve-directives.cpp +++ b/flang/lib/Semantics/resolve-directives.cpp @@ -362,6 +362,24 @@ class OmpAttributeVisitor : DirectiveAttributeVisitor { explicit OmpAttributeVisitor(SemanticsContext &context) : DirectiveAttributeVisitor(context) {} + static const Scope &scopingUnit(const Scope &scope) { + const Scope *iter{&scope}; + for (; !iter->IsTopLevel(); iter = &iter->parent()) { + switch (iter->kind()) { + case Scope::Kind::BlockConstruct: + case Scope::Kind::BlockData: + case Scope::Kind::DerivedType: + case Scope::Kind::MainProgram: + case Scope::Kind::Module: + case Scope::Kind::Subprogram: + return *iter; + default: + break; + } + } + return *iter; + } + template void Walk(const A &x) { parser::Walk(x, *this); } template bool Pre(const A &) { return true; } template void Post(const A &) {} @@ -952,7 +970,6 @@ class OmpAttributeVisitor : DirectiveAttributeVisitor { void ResolveOmpNameList(const std::list &, Symbol::Flag); void ResolveOmpName(const parser::Name &, Symbol::Flag); Symbol *ResolveName(const parser::Name *); - Symbol *ResolveOmpObjectScope(const parser::Name *); Symbol *DeclareOrMarkOtherAccessEntity(const parser::Name &, Symbol::Flag); Symbol *DeclareOrMarkOtherAccessEntity(Symbol &, Symbol::Flag); void CheckMultipleAppearances( @@ -2925,31 +2942,6 @@ Symbol *OmpAttributeVisitor::ResolveOmpCommonBlockName( return nullptr; } -// Use this function over ResolveOmpName when an omp object's scope needs -// resolving, it's symbol flag isn't important and a simple check for resolution -// failure is desired. Using ResolveOmpName means needing to work with the -// context to check for failure, whereas here a pointer comparison is all that's -// needed. -Symbol *OmpAttributeVisitor::ResolveOmpObjectScope(const parser::Name *name) { - - // TODO: Investigate whether the following block can be replaced by, or - // included in, the ResolveOmpName function - if (auto *prev{name ? GetContext().scope.parent().FindSymbol(name->source) - : nullptr}) { - name->symbol = prev; - return nullptr; - } - - // TODO: Investigate whether the following block can be replaced by, or - // included in, the ResolveOmpName function - if (auto *ompSymbol{ - name ? GetContext().scope.FindSymbol(name->source) : nullptr}) { - name->symbol = ompSymbol; - return ompSymbol; - } - return nullptr; -} - void OmpAttributeVisitor::ResolveOmpObjectList( const parser::OmpObjectList &ompObjectList, Symbol::Flag ompFlag) { for (const auto &ompObject : ompObjectList.v) { @@ -3028,13 +3020,19 @@ void OmpAttributeVisitor::ResolveOmpDesignator( context_.Say(designator.source, "List items specified in the ALLOCATE directive must not have the ALLOCATABLE attribute unless the directive is associated with an ALLOCATE statement"_err_en_US); } - if ((ompFlag == Symbol::Flag::OmpDeclarativeAllocateDirective || - ompFlag == Symbol::Flag::OmpExecutableAllocateDirective) && - ResolveOmpObjectScope(name) == nullptr) { - context_.Say(designator.source, // 2.15.3 - "List items must be declared in the same scoping unit in which the %s directive appears"_err_en_US, - parser::ToUpperCaseLetters( - llvm::omp::getOpenMPDirectiveName(directive, version))); + bool checkScope{ompFlag == Symbol::Flag::OmpDeclarativeAllocateDirective}; + // In 5.1 the scope check only applies to declarative allocate. + if (version == 50 && !checkScope) { + checkScope = ompFlag == Symbol::Flag::OmpExecutableAllocateDirective; + } + if (checkScope) { + if (scopingUnit(GetContext().scope) != + scopingUnit(symbol->GetUltimate().owner())) { + context_.Say(designator.source, // 2.15.3 + "List items must be declared in the same scoping unit in which the %s directive appears"_err_en_US, + parser::ToUpperCaseLetters( + llvm::omp::getOpenMPDirectiveName(directive, version))); + } } if (ompFlag == Symbol::Flag::OmpReduction) { // Using variables inside of a namelist in OpenMP reductions diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index 43b49e01c89c7..bb362602b2367 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -1627,12 +1627,14 @@ class OmpVisitor : public virtual DeclarationVisitor { void Post(const parser::OpenMPDeclareTargetConstruct &) { SkipImplicitTyping(false); } - bool Pre(const parser::OpenMPDeclarativeAllocate &) { + bool Pre(const parser::OpenMPDeclarativeAllocate &x) { + AddOmpSourceRange(x.source); SkipImplicitTyping(true); return true; } void Post(const parser::OpenMPDeclarativeAllocate &) { SkipImplicitTyping(false); + messageHandler().set_currStmtSource(std::nullopt); } bool Pre(const parser::OpenMPDeclarativeConstruct &x) { AddOmpSourceRange(x.source); diff --git a/flang/test/Semantics/OpenMP/allocate01.f90 b/flang/test/Semantics/OpenMP/allocate01.f90 index e0b084ff0030b..5280d1b68a731 100644 --- a/flang/test/Semantics/OpenMP/allocate01.f90 +++ b/flang/test/Semantics/OpenMP/allocate01.f90 @@ -20,7 +20,6 @@ subroutine sema() print *, a !WARNING: OpenMP directive ALLOCATE has been deprecated, please use ALLOCATORS instead. [-Wopen-mp-usage] - !ERROR: List items must be declared in the same scoping unit in which the ALLOCATE directive appears !$omp allocate(x) allocator(omp_default_mem_alloc) allocate ( x(a), darray(a, b) ) end subroutine sema diff --git a/flang/test/Semantics/OpenMP/allocate08.f90 b/flang/test/Semantics/OpenMP/allocate08.f90 index fc950ea4fca36..5bfa918be4cad 100644 --- a/flang/test/Semantics/OpenMP/allocate08.f90 +++ b/flang/test/Semantics/OpenMP/allocate08.f90 @@ -27,10 +27,12 @@ subroutine allocate() !$omp allocate(x) allocator(omp_default_mem_alloc) !$omp allocate(y) allocator(omp_default_mem_alloc) + !ERROR: List items must be declared in the same scoping unit in which the ALLOCATE directive appears !$omp allocate(z) allocator(omp_default_mem_alloc) !$omp allocate(x) !$omp allocate(y) + !ERROR: List items must be declared in the same scoping unit in which the ALLOCATE directive appears !$omp allocate(z) !$omp allocate(w) allocator(custom_allocator) @@ -40,5 +42,6 @@ subroutine allocate() !ERROR: If list items within the ALLOCATE directive have the SAVE attribute, are a common block name, or are declared in the scope of a module, then only predefined memory allocator parameters can be used in the allocator clause !$omp allocate(y) allocator(custom_allocator) !ERROR: If list items within the ALLOCATE directive have the SAVE attribute, are a common block name, or are declared in the scope of a module, then only predefined memory allocator parameters can be used in the allocator clause + !ERROR: List items must be declared in the same scoping unit in which the ALLOCATE directive appears !$omp allocate(z) allocator(custom_allocator) end subroutine allocate diff --git a/flang/test/Semantics/OpenMP/allocators04.f90 b/flang/test/Semantics/OpenMP/allocators04.f90 index 212e48fbd1b26..c71c7ca8466ba 100644 --- a/flang/test/Semantics/OpenMP/allocators04.f90 +++ b/flang/test/Semantics/OpenMP/allocators04.f90 @@ -22,10 +22,12 @@ subroutine allocate() trait(1)%value = default_mem_fb custom_allocator = omp_init_allocator(omp_default_mem_space, 1, trait) + !ERROR: List items must be declared in the same scoping unit in which the ALLOCATORS directive appears !$omp allocators allocate(omp_default_mem_alloc: a) allocate(a) !ERROR: If list items within the ALLOCATORS directive have the SAVE attribute, are a common block name, or are declared in the scope of a module, then only predefined memory allocator parameters can be used in the allocator clause + !ERROR: List items must be declared in the same scoping unit in which the ALLOCATORS directive appears !$omp allocators allocate(custom_allocator: b) allocate(b) end subroutine diff --git a/flang/test/Semantics/OpenMP/allocators05.f90 b/flang/test/Semantics/OpenMP/allocators05.f90 index 0e8366a2461e6..efacdfaec7647 100644 --- a/flang/test/Semantics/OpenMP/allocators05.f90 +++ b/flang/test/Semantics/OpenMP/allocators05.f90 @@ -15,11 +15,9 @@ subroutine allocate() integer, parameter :: LEN = 2 !$omp target private(a, b) - !ERROR: List items must be declared in the same scoping unit in which the ALLOCATORS directive appears !$omp allocators allocate(omp_default_mem_alloc: a) allocate(a(LEN)) !ERROR: ALLOCATORS directives that appear in a TARGET region must specify an allocator - !ERROR: List items must be declared in the same scoping unit in which the ALLOCATORS directive appears !$omp allocators allocate(b) allocate(b(LEN)) !$omp end target