Improve type checks, add testcases

Author: kparzysz

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

@@ -2955,13 +2955,6 @@ struct VariableFinder : public evaluate::AnyTraverse<VariableFinder> {
 };
 } // namespace atomic
 
-static bool IsAllocatable(const SomeExpr &expr) {
-  std::vector<SomeExpr> dsgs{atomic::DesignatorCollector{}(expr)};
-  assert(dsgs.size() == 1 && "Should have a single top-level designator");
-  evaluate::SymbolVector syms{evaluate::GetSymbolVector(dsgs.front())};
-  return !syms.empty() && IsAllocatable(syms.back()) && !IsArrayElement(expr);
-}
-
 static bool IsPointerAssignment(const evaluate::Assignment &x) {
   return std::holds_alternative<evaluate::Assignment::BoundsSpec>(x.u) ||
       std::holds_alternative<evaluate::Assignment::BoundsRemapping>(x.u);
@@ -3149,30 +3142,69 @@ void OmpStructureChecker::ErrorShouldBeVariable(
 ///   function references with scalar data pointer result of non-character
 ///   intrinsic type or variables that are non-polymorphic scalar pointers
 ///   and any length type parameter must be constant.
-void OmpStructureChecker::CheckAtomicVariable(
-    const SomeExpr &atom, parser::CharBlock source) {
-  if (atom.Rank() != 0) {
-    context_.Say(source, "Atomic variable %s should be a scalar"_err_en_US,
-        atom.AsFortran());
+void OmpStructureChecker::CheckAtomicType(SymbolRef sym,
+                                          parser::CharBlock source,
+                                          std::string_view name) {
+  const DeclTypeSpec *typeSpec{sym->GetType()};
+  if (!typeSpec) {
+    return;
   }
 
-  if (std::optional<evaluate::DynamicType> dtype{atom.GetType()}) {
-    if (dtype->category() == TypeCategory::Character) {
+  if (!IsPointer(sym)) {
+    using Category = DeclTypeSpec::Category;
+    Category cat{typeSpec->category()};
+    if (cat == Category::Character) {
       context_.Say(source,
-          "Atomic variable %s cannot have CHARACTER type"_err_en_US,
-          atom.AsFortran());
-    } else if (dtype->IsPolymorphic()) {
+                   "Atomic variable %s cannot have CHARACTER type"_err_en_US,
+                   name);
+    } else if (cat != Category::Numeric && cat != Category::Logical) {
       context_.Say(source,
-          "Atomic variable %s cannot have a polymorphic type"_err_en_US,
-          atom.AsFortran());
+                   "Atomic variable %s should have an intrinsic type"_err_en_US,
+                   name);
     }
-    // TODO: Check non-constant type parameters for non-character types.
-    // At the moment there don't seem to be any.
+    return;
+  }
+
+  // Variable is a pointer.
+  if (typeSpec->IsPolymorphic()) {
+    context_.Say(
+        source,
+        "Atomic variable %s cannot be a pointer to a polymorphic type"_err_en_US,
+        name);
+    return;
   }
 
-  if (IsAllocatable(atom)) {
+  // Go over all length parameters, if any, and check if they are
+  // explicit.
+  if (const DerivedTypeSpec *derived{typeSpec->AsDerived()}) {
+    if (llvm::any_of(derived->parameters(), [](auto &&entry) {
+          // "entry" is a map entry
+          return entry.second.isLen() && !entry.second.isExplicit();
+        })) {
+      context_.Say(
+          source,
+          "Atomic variable %s is a pointer to a type with non-constant length parameter"_err_en_US,
+          name);
+    }
+  }
+}
+
+void OmpStructureChecker::CheckAtomicVariable(const SomeExpr &atom,
+                                              parser::CharBlock source) {
+  if (atom.Rank() != 0) {
+    context_.Say(source, "Atomic variable %s should be a scalar"_err_en_US,
+                 atom.AsFortran());
+  }
+
+  std::vector<SomeExpr> dsgs{atomic::DesignatorCollector{}(atom)};
+  assert(dsgs.size() == 1 && "Should have a single top-level designator");
+  evaluate::SymbolVector syms{evaluate::GetSymbolVector(dsgs.front())};
+
+  CheckAtomicType(syms.back(), source, atom.AsFortran());
+
+  if (IsAllocatable(syms.back()) && !IsArrayElement(atom)) {
     context_.Say(source, "Atomic variable %s cannot be ALLOCATABLE"_err_en_US,
-        atom.AsFortran());
+                 atom.AsFortran());
   }
 }
 

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

@@ -259,6 +259,8 @@ class OmpStructureChecker
   void CheckStorageOverlap(const evaluate::Expr<evaluate::SomeType> &,
       llvm::ArrayRef<evaluate::Expr<evaluate::SomeType>>, parser::CharBlock);
   void ErrorShouldBeVariable(const MaybeExpr &expr, parser::CharBlock source);
+  void CheckAtomicType(
+      SymbolRef sym, parser::CharBlock source, std::string_view name);
   void CheckAtomicVariable(
       const evaluate::Expr<evaluate::SomeType> &, parser::CharBlock);
   std::pair<const parser::ExecutionPartConstruct *,

flang/test/Semantics/OpenMP/atomic-read.f90

@@ -87,3 +87,32 @@ subroutine f07
   v = x
 end
 
+subroutine f08
+  type :: struct
+    integer :: m
+  end type
+  type(struct) :: x, v
+
+  !$omp atomic read
+  !ERROR: Atomic variable x should have an intrinsic type
+  v = x
+end
+
+subroutine f09(x, v)
+  class(*), pointer :: x, v
+
+  !$omp atomic read
+  !ERROR: Atomic variable x cannot be a pointer to a polymorphic type
+  v => x
+end
+
+subroutine f10(x, v)
+  type struct(length)
+    integer, len :: length
+  end type
+  type(struct(*)), pointer :: x, v
+
+  !$omp atomic read
+  !ERROR: Atomic variable x is a pointer to a type with non-constant length parameter
+  v => x
+end