diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h index e3deb2da1be04a..633787f45e8525 100644 --- a/flang/include/flang/Semantics/tools.h +++ b/flang/include/flang/Semantics/tools.h @@ -143,6 +143,9 @@ inline bool IsPointer(const Symbol &symbol) { inline bool IsAllocatable(const Symbol &symbol) { return symbol.attrs().test(Attr::ALLOCATABLE); } +inline bool IsValue(const Symbol &symbol) { + return symbol.attrs().test(Attr::VALUE); +} // IsAllocatableOrObjectPointer() may be the better choice inline bool IsAllocatableOrPointer(const Symbol &symbol) { return IsPointer(symbol) || IsAllocatable(symbol); diff --git a/flang/lib/Semantics/check-omp-structure.cpp b/flang/lib/Semantics/check-omp-structure.cpp index a328424e0c098d..2054a13bd92e79 100644 --- a/flang/lib/Semantics/check-omp-structure.cpp +++ b/flang/lib/Semantics/check-omp-structure.cpp @@ -2864,18 +2864,21 @@ void OmpStructureChecker::Enter(const parser::OmpClause::IsDevicePtr &x) { const auto &isDevicePtrClause{ std::get(itr->second->u)}; const auto &isDevicePtrList{isDevicePtrClause.v}; - std::list isDevicePtrNameList; - for (const auto &ompObject : isDevicePtrList.v) { - if (const auto *name{parser::Unwrap(ompObject)}) { - if (name->symbol) { - if (!(IsBuiltinCPtr(*(name->symbol)))) { - context_.Say(itr->second->source, - "Variable '%s' in IS_DEVICE_PTR clause must be of type C_PTR"_err_en_US, - name->ToString()); - } else { - isDevicePtrNameList.push_back(*name); - } - } + SymbolSourceMap currSymbols; + GetSymbolsInObjectList(isDevicePtrList, currSymbols); + for (auto &[symbol, source] : currSymbols) { + if (!(IsBuiltinCPtr(*symbol))) { + context_.Say(itr->second->source, + "Variable '%s' in IS_DEVICE_PTR clause must be of type C_PTR"_err_en_US, + source.ToString()); + } else if (!(IsDummy(*symbol))) { + context_.Say(itr->second->source, + "Variable '%s' in IS_DEVICE_PTR clause must be a dummy argument"_err_en_US, + source.ToString()); + } else if (IsAllocatableOrPointer(*symbol) || IsValue(*symbol)) { + context_.Say(itr->second->source, + "Variable '%s' in IS_DEVICE_PTR clause must be a dummy argument that does not have the ALLOCATABLE, POINTER or VALUE attribute."_err_en_US, + source.ToString()); } } } diff --git a/flang/test/Semantics/OpenMP/target01.f90 b/flang/test/Semantics/OpenMP/target01.f90 index d672b905a70ad2..485fa1f2530c3b 100644 --- a/flang/test/Semantics/OpenMP/target01.f90 +++ b/flang/test/Semantics/OpenMP/target01.f90 @@ -1,5 +1,6 @@ ! RUN: %python %S/../test_errors.py %s %flang_fc1 -fopenmp - + +subroutine foo(b) use iso_c_binding integer :: x,y type(C_PTR) :: b @@ -28,4 +29,30 @@ y = y - 1 !$omp end target -end +end subroutine foo + +subroutine bar(b1, b2, b3) + use iso_c_binding + integer :: y + type(c_ptr) :: c + type(c_ptr), allocatable :: b1 + type(c_ptr), pointer :: b2 + type(c_ptr), value :: b3 + + !ERROR: Variable 'c' in IS_DEVICE_PTR clause must be a dummy argument + !$omp target is_device_ptr(c) + y = y + 1 + !$omp end target + !ERROR: Variable 'b1' in IS_DEVICE_PTR clause must be a dummy argument that does not have the ALLOCATABLE, POINTER or VALUE attribute. + !$omp target is_device_ptr(b1) + y = y + 1 + !$omp end target + !ERROR: Variable 'b2' in IS_DEVICE_PTR clause must be a dummy argument that does not have the ALLOCATABLE, POINTER or VALUE attribute. + !$omp target is_device_ptr(b2) + y = y + 1 + !$omp end target + !ERROR: Variable 'b3' in IS_DEVICE_PTR clause must be a dummy argument that does not have the ALLOCATABLE, POINTER or VALUE attribute. + !$omp target is_device_ptr(b3) + y = y + 1 + !$omp end target +end subroutine bar