handle base that is allocation

akuhlens · akuhlens · commit 12b2fa2e11b9 · 2025-10-30T09:20:15.000-07:00
diff --git a/flang/docs/ImplementingASemanticCheck.md b/flang/docs/ImplementingASemanticCheck.md
@@ -775,7 +775,7 @@ to make sure that the names were clear.  Here's what I ended up with:
 
 ```C++
   void DoChecker::Leave(const parser::Expr &parsedExpr) {
-    ActualArgumentSet argSet{CollectActualArguments(GetExpr(parsedExpr))};
+    ActualArgumentSet argSet{CollectActualArguments((parsedExpr))};
     for (const evaluate::ActualArgumentRef &argRef : argSet) {
       if (const SomeExpr * argExpr{argRef->UnwrapExpr()}) {
         if (const Symbol * var{evaluate::UnwrapWholeSymbolDataRef(*argExpr)}) {
diff --git a/flang/include/flang/Evaluate/variable.h b/flang/include/flang/Evaluate/variable.h
@@ -289,7 +289,7 @@ struct DataRef {
   const Symbol &GetLastSymbol() const;
   std::optional<Expr<SubscriptInteger>> LEN() const;
   llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
-
+  bool IsPathFrom(const DataRef &) const;
   std::variant<SymbolRef, Component, ArrayRef, CoarrayRef> u;
 };
 
@@ -400,7 +400,7 @@ template <typename T> class Designator {
   const Symbol *GetLastSymbol() const;
   std::optional<Expr<SubscriptInteger>> LEN() const;
   llvm::raw_ostream &AsFortran(llvm::raw_ostream &o) const;
-
+  bool IsPathFrom(const Designator<T> &) const;
   Variant u;
 };
 
diff --git a/flang/lib/Evaluate/variable.cpp b/flang/lib/Evaluate/variable.cpp
@@ -751,6 +751,65 @@ bool DescriptorInquiry::operator==(const DescriptorInquiry &that) const {
   return field_ == that.field_ && base_ == that.base_ &&
       dimension_ == that.dimension_;
 }
+#include <type_traits>
+#include <utility>
+template <typename T, typename = void> struct has_union : std::false_type {};
+template <typename T>
+struct has_union<T, std::void_t<decltype(T::u)>> : std::true_type {};
+template <typename T, typename = void> struct has_base : std::false_type {};
+template <typename T>
+struct has_base<T, std::void_t<decltype(std::declval<T>().base())>>
+    : std::true_type {};
+template <typename T, typename = void>
+struct has_GetFirstSymbol : std::false_type {};
+template <typename T>
+struct has_GetFirstSymbol<T,
+    std::void_t<decltype(std::declval<T>().GetFirstSymbol())>>
+    : std::true_type {};
+
+template <typename P, typename R>
+bool TestVariableIsPathFromRoot(const P &path, const R &root) {
+  const SymbolRef *pathSym, *rootSym;
+  if constexpr (has_union<P>::value) {
+    pathSym = std::get_if<SymbolRef>(&path.u);
+  }
+  if constexpr (has_union<R>::value) {
+    rootSym = std::get_if<SymbolRef>(&root.u);
+  }
+  if (pathSym) {
+    return rootSym && AreSameSymbol(*rootSym, *pathSym);
+  }
+  if constexpr (has_GetFirstSymbol<P>::value) {
+    if (rootSym) {
+      return AreSameSymbol(path.GetFirstSymbol(), *rootSym);
+    }
+  }
+  if constexpr (std::is_same_v<P, R>) {
+    if (path == root) {
+      return true;
+    }
+  }
+  if constexpr (has_base<P>::value) {
+    return TestVariableIsPathFromRoot(path.base(), root);
+  }
+  if constexpr (has_union<P>::value) {
+    return common::visit(
+        common::visitors{
+            [&](const auto &x) { return TestVariableIsPathFromRoot(x, root); },
+        },
+        path.u);
+  }
+  return false;
+}
+
+bool DataRef::IsPathFrom(const DataRef &that) const {
+  return TestVariableIsPathFromRoot(*this, that);
+}
+
+template <typename T>
+bool Designator<T>::IsPathFrom(const Designator<T> &that) const {
+  return TestVariableIsPathFromRoot(*this, that);
+}
 
 #ifdef _MSC_VER // disable bogus warning about missing definitions
 #pragma warning(disable : 4661)
diff --git a/flang/lib/Semantics/check-allocate.cpp b/flang/lib/Semantics/check-allocate.cpp
@@ -470,6 +470,29 @@ static bool HaveCompatibleLengths(
   }
 }
 
+bool IsSameAllocation(const SomeExpr *root, const SomeExpr *path) {
+  if (root) {
+    if (std::optional<evaluate::DataRef> rootRef{ExtractDataRef(root)}) {
+      if (path) {
+        if (std::optional<evaluate::DataRef> pathRef{ExtractDataRef(path)}) {
+          if (pathRef->IsPathFrom(*rootRef)) {
+            return true;
+          }
+        } else {
+          if (*root == *path) {
+            return true;
+          }
+        }
+      }
+    } else {
+      if (path && *root == *path) {
+        return true;
+      }
+    }
+  }
+  return false;
+}
+
 bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
   if (!ultimate_) {
     CHECK(context.AnyFatalError());
@@ -700,12 +723,13 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
           "Object in ALLOCATE must have DEVICE attribute when STREAM option is specified"_err_en_US);
     }
   }
+
   if (const SomeExpr *allocObj{GetExpr(context, allocateObject_)}) {
-    if (allocateInfo_.statVar && *allocObj == *allocateInfo_.statVar) {
+    if (IsSameAllocation(allocObj, allocateInfo_.statVar)) {
       context.Say(allocateInfo_.statSource.value_or(name_.source),
           "STAT variable in ALLOCATE must not be the variable being allocated"_err_en_US);
     }
-    if (allocateInfo_.msgVar && *allocObj == *allocateInfo_.msgVar) {
+    if (IsSameAllocation(allocObj, allocateInfo_.msgVar)) {
       context.Say(allocateInfo_.msgSource.value_or(name_.source),
           "ERRMSG variable in ALLOCATE must not be the variable being allocated"_err_en_US);
     }
diff --git a/flang/lib/Semantics/check-allocate.h b/flang/lib/Semantics/check-allocate.h
@@ -24,5 +24,6 @@ class AllocateChecker : public virtual BaseChecker {
 private:
   SemanticsContext &context_;
 };
+bool IsSameAllocation(const SomeExpr *root, const SomeExpr *path);
 } // namespace Fortran::semantics
 #endif // FORTRAN_SEMANTICS_CHECK_ALLOCATE_H_
diff --git a/flang/lib/Semantics/check-deallocate.cpp b/flang/lib/Semantics/check-deallocate.cpp
@@ -7,6 +7,7 @@
 //===----------------------------------------------------------------------===//
 
 #include "check-deallocate.h"
+#include "check-allocate.h"
 #include "definable.h"
 #include "flang/Evaluate/type.h"
 #include "flang/Parser/message.h"
@@ -134,11 +135,11 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
         },
         allocateObject.u);
     if (const SomeExpr *allocObj{GetExpr(context_, allocateObject)}) {
-      if (statVar && *allocObj == *statVar) {
+      if (IsSameAllocation(allocObj, statVar)) {
         context_.Say(statSource.value_or(source),
             "STAT variable in DEALLOCATE must not be the variable being deallocated"_err_en_US);
       }
-      if (msgVar && *allocObj == *msgVar) {
+      if (IsSameAllocation(allocObj, msgVar)) {
         context_.Say(msgSource.value_or(source),
             "ERRMSG variable in DEALLOCATE must not be the variable being deallocated"_err_en_US);
       }
diff --git a/flang/test/Semantics/allocate14.f90 b/flang/test/Semantics/allocate14.f90
@@ -46,11 +46,11 @@ program allocate14
   !ERROR: ERRMSG variable in DEALLOCATE must not be the variable being deallocated
   deallocate(tt(2)%msg, stat=tt(2)%i, errmsg=tt(2)%msg)
 
-  !FIXME: STAT variable in ALLOCATE must not be the variable being allocated
-  !FIXME: ERRMSG variable in ALLOCATE must not be the variable being allocated
+  !ERROR: STAT variable in ALLOCATE must not be the variable being allocated
+  !ERROR: ERRMSG variable in ALLOCATE must not be the variable being allocated
   allocate(ts(10), stat=ts(1)%i, errmsg=ts(1)%msg)
-  !FIXME: STAT variable in DEALLOCATE must not be the variable being deallocated
-  !FIXME: ERRMSG variable in DEALLOCATE must not be the variable being deallocated
+  !ERROR: STAT variable in DEALLOCATE must not be the variable being deallocated
+  !ERROR: ERRMSG variable in DEALLOCATE must not be the variable being deallocated
   deallocate(ts, stat=ts(1)%i, errmsg=ts(1)%msg)
 end program
 
