[flang][OpenMP] Add semantic checks for is_device_ptr (#71255)

This patch adds the following semantic check for is_device_ptr ``` A list item that appears in an is_device_ptr clause must be a dummy argument that does not have the ALLOCATABLE, POINTER or VALUE attribute. ```
llvm · Nov 6, 2023 · d6b69a1 · d6b69a1
1 parent d9ccace
commit d6b69a1
Show file tree

Hide file tree

Showing 3 changed files with 47 additions and 14 deletions.
diff --git 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
@@ -2864,18 +2864,21 @@ void OmpStructureChecker::Enter(const parser::OmpClause::IsDevicePtr &x) {
     const auto &isDevicePtrClause{
         std::get<parser::OmpClause::IsDevicePtr>(itr->second->u)};
     const auto &isDevicePtrList{isDevicePtrClause.v};
-    std::list<parser::Name> isDevicePtrNameList;
-    for (const auto &ompObject : isDevicePtrList.v) {
-      if (const auto *name{parser::Unwrap<parser::Name>(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
@@ -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