[flang][OpenMP] Add diagnostic for ATOMIC WRITE with pointer to non-intrinsic type

Fixes #161932

Author: Krish Gupta

flang/lib/Semantics/check-omp-atomic.cpp

@@ -580,6 +580,38 @@ void OmpStructureChecker::CheckAtomicVariable(
   }
 }
 
+void OmpStructureChecker::CheckAtomicVariable(const SomeExpr &atom,
+    parser::CharBlock source, const evaluate::Assignment &assign) {
+  // First do all the standard checks
+  CheckAtomicVariable(atom, source);
+
+  // For intrinsic assignment, check if the variable is a pointer
+  // to a non-intrinsic type, which is not allowed in atomic operations
+  if (!IsPointerAssignment(assign)) {
+    std::vector<SomeExpr> dsgs{GetAllDesignators(atom)};
+    if (!dsgs.empty()) {
+      evaluate::SymbolVector syms{evaluate::GetSymbolVector(dsgs.front())};
+      if (!syms.empty() && IsPointer(syms.back())) {
+        SymbolRef sym = syms.back();
+        if (const DeclTypeSpec *typeSpec{sym->GetType()}) {
+          using Category = DeclTypeSpec::Category;
+          Category cat{typeSpec->category()};
+          if (cat != Category::Numeric && cat != Category::Logical) {
+            std::string details = " has the POINTER attribute";
+            if (const auto *derived{typeSpec->AsDerived()}) {
+              details +=
+                  " and derived type '"s + derived->name().ToString() + "'";
+            }
+            context_.Say(source,
+                "ATOMIC operation requires an intrinsic scalar variable; '%s'%s"_err_en_US,
+                sym->name(), details);
+          }
+        }
+      }
+    }
+  }
+}
+
 void OmpStructureChecker::CheckStorageOverlap(const SomeExpr &base,
     llvm::ArrayRef<evaluate::Expr<evaluate::SomeType>> exprs,
     parser::CharBlock source) {
@@ -789,7 +821,7 @@ void OmpStructureChecker::CheckAtomicCaptureAssignment(
   if (!IsVarOrFunctionRef(atom)) {
     ErrorShouldBeVariable(atom, rsrc);
   } else {
-    CheckAtomicVariable(atom, rsrc);
+    CheckAtomicVariable(atom, rsrc, capture);
     // This part should have been checked prior to calling this function.
     assert(*GetConvertInput(capture.rhs) == atom &&
         "This cannot be a capture assignment");
@@ -808,7 +840,7 @@ void OmpStructureChecker::CheckAtomicReadAssignment(
     if (!IsVarOrFunctionRef(atom)) {
       ErrorShouldBeVariable(atom, rsrc);
     } else {
-      CheckAtomicVariable(atom, rsrc);
+      CheckAtomicVariable(atom, rsrc, read);
       CheckStorageOverlap(atom, {read.lhs}, source);
     }
   } else {
@@ -829,7 +861,7 @@ void OmpStructureChecker::CheckAtomicWriteAssignment(
   if (!IsVarOrFunctionRef(atom)) {
     ErrorShouldBeVariable(atom, rsrc);
   } else {
-    CheckAtomicVariable(atom, lsrc);
+    CheckAtomicVariable(atom, lsrc, write);
     CheckStorageOverlap(atom, {write.rhs}, source);
   }
 }
@@ -854,7 +886,7 @@ OmpStructureChecker::CheckAtomicUpdateAssignment(
     return std::nullopt;
   }
 
-  CheckAtomicVariable(atom, lsrc);
+  CheckAtomicVariable(atom, lsrc, update);
 
   auto [hasErrors, tryReassoc]{CheckAtomicUpdateAssignmentRhs(
       atom, update.rhs, source, /*suppressDiagnostics=*/true)};
@@ -1017,7 +1049,7 @@ void OmpStructureChecker::CheckAtomicConditionalUpdateAssignment(
     return;
   }
 
-  CheckAtomicVariable(atom, alsrc);
+  CheckAtomicVariable(atom, alsrc, assign);
 
   auto top{GetTopLevelOperationIgnoreResizing(cond)};
   // Missing arguments to operations would have been diagnosed by now.

flang/lib/Semantics/check-omp-structure.h

@@ -266,6 +266,8 @@ class OmpStructureChecker
       SymbolRef sym, parser::CharBlock source, std::string_view name);
   void CheckAtomicVariable(
       const evaluate::Expr<evaluate::SomeType> &, parser::CharBlock);
+  void CheckAtomicVariable(const evaluate::Expr<evaluate::SomeType> &,
+      parser::CharBlock, const evaluate::Assignment &);
   std::pair<const parser::ExecutionPartConstruct *,
       const parser::ExecutionPartConstruct *>
   CheckUpdateCapture(const parser::ExecutionPartConstruct *ec1,

flang/test/Semantics/OpenMP/omp-atomic-write-pointer-derived.f90

@@ -0,0 +1,8 @@
+! RUN: not %flang_fc1 -fopenmp -fsyntax-only %s 2>&1 | FileCheck %s
+type t
+end type
+type(t), pointer :: a1, a2
+!$omp atomic write
+a1 = a2
+! CHECK: error: ATOMIC WRITE requires an intrinsic scalar variable; 'a1' has the POINTER attribute and derived type 't'
+end