[flang][semantics] add semantic check that STAT and ERRMSG are not (de)allocated by same statement

flang/lib/Semantics/check-allocate.cpp

@@ -26,6 +26,10 @@ struct AllocateCheckerInfo {
   std::optional<evaluate::DynamicType> sourceExprType;
   std::optional<parser::CharBlock> sourceExprLoc;
   std::optional<parser::CharBlock> typeSpecLoc;
+  std::optional<parser::CharBlock> statSource;
+  std::optional<parser::CharBlock> msgSource;
+  const SomeExpr *statVar{nullptr};
+  const SomeExpr *msgVar{nullptr};
   int sourceExprRank{0}; // only valid if gotMold || gotSource
   bool gotStat{false};
   bool gotMsg{false};
@@ -141,12 +145,15 @@ static std::optional<AllocateCheckerInfo> CheckAllocateOptions(
             [&](const parser::StatOrErrmsg &statOrErr) {
               common::visit(
                   common::visitors{
-                      [&](const parser::StatVariable &) {
+                      [&](const parser::StatVariable &var) {
                         if (info.gotStat) { // C943
                           context.Say(
                               "STAT may not be duplicated in a ALLOCATE statement"_err_en_US);
                         }
                         info.gotStat = true;
+                        info.statVar = GetExpr(context, var);
+                        info.statSource =
+                            parser::Unwrap<parser::Variable>(var)->GetSource();
                       },
                       [&](const parser::MsgVariable &var) {
                         WarnOnDeferredLengthCharacterScalar(context,
@@ -159,6 +166,9 @@ static std::optional<AllocateCheckerInfo> CheckAllocateOptions(
                               "ERRMSG may not be duplicated in a ALLOCATE statement"_err_en_US);
                         }
                         info.gotMsg = true;
+                        info.msgVar = GetExpr(context, var);
+                        info.msgSource =
+                            parser::Unwrap<parser::Variable>(var)->GetSource();
                       },
                   },
                   statOrErr.u);
@@ -460,6 +470,16 @@ static bool HaveCompatibleLengths(
   }
 }
 
+bool AreSameAllocation(const SomeExpr *root, const SomeExpr *path) {
+  if (root && path) {
+    // For now we just use equality of expressions. If we implement a more
+    // sophisticated alias analysis we should use it here.
+    return *root == *path;
+  } else {
+    return false;
+  }
+}
+
 bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
   if (!ultimate_) {
     CHECK(context.AnyFatalError());
@@ -690,6 +710,17 @@ 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 (AreSameAllocation(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 (AreSameAllocation(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);
+    }
+  }
   return RunCoarrayRelatedChecks(context);
 }
 

flang/lib/Semantics/check-allocate.h

@@ -24,5 +24,6 @@ class AllocateChecker : public virtual BaseChecker {
 private:
   SemanticsContext &context_;
 };
+bool AreSameAllocation(const SomeExpr *root, const SomeExpr *path);
 } // namespace Fortran::semantics
 #endif // FORTRAN_SEMANTICS_CHECK_ALLOCATE_H_

flang/lib/Semantics/check-deallocate.cpp

@@ -7,51 +7,87 @@
 //===----------------------------------------------------------------------===//
 
 #include "check-deallocate.h"
+#include "check-allocate.h"
 #include "definable.h"
 #include "flang/Evaluate/type.h"
 #include "flang/Parser/message.h"
 #include "flang/Parser/parse-tree.h"
 #include "flang/Semantics/expression.h"
 #include "flang/Semantics/tools.h"
+#include <optional>
 
 namespace Fortran::semantics {
 
 void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
+  bool gotStat{false}, gotMsg{false};
+  const SomeExpr *statVar{nullptr}, *msgVar{nullptr};
+  std::optional<parser::CharBlock> statSource;
+  std::optional<parser::CharBlock> msgSource;
+  for (const parser::StatOrErrmsg &deallocOpt :
+      std::get<std::list<parser::StatOrErrmsg>>(deallocateStmt.t)) {
+    common::visit(
+        common::visitors{
+            [&](const parser::StatVariable &var) {
+              if (gotStat) {
+                context_.Say(
+                    "STAT may not be duplicated in a DEALLOCATE statement"_err_en_US);
+              }
+              gotStat = true;
+              statVar = GetExpr(context_, var);
+              statSource = parser::Unwrap<parser::Variable>(var)->GetSource();
+            },
+            [&](const parser::MsgVariable &var) {
+              WarnOnDeferredLengthCharacterScalar(context_,
+                  GetExpr(context_, var),
+                  parser::UnwrapRef<parser::Variable>(var).GetSource(),
+                  "ERRMSG=");
+              if (gotMsg) {
+                context_.Say(
+                    "ERRMSG may not be duplicated in a DEALLOCATE statement"_err_en_US);
+              }
+              gotMsg = true;
+              msgVar = GetExpr(context_, var);
+              msgSource = parser::Unwrap<parser::Variable>(var)->GetSource();
+            },
+        },
+        deallocOpt.u);
+  }
   for (const parser::AllocateObject &allocateObject :
       std::get<std::list<parser::AllocateObject>>(deallocateStmt.t)) {
+    parser::CharBlock source;
     common::visit(
         common::visitors{
             [&](const parser::Name &name) {
               const Symbol *symbol{
                   name.symbol ? &name.symbol->GetUltimate() : nullptr};
-              ;
+              source = name.source;
               if (context_.HasError(symbol)) {
                 // already reported an error
               } else if (!IsVariableName(*symbol)) {
-                context_.Say(name.source,
+                context_.Say(source,
                     "Name in DEALLOCATE statement must be a variable name"_err_en_US);
               } else if (!IsAllocatableOrObjectPointer(symbol)) { // C936
-                context_.Say(name.source,
+                context_.Say(source,
                     "Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
-              } else if (auto whyNot{WhyNotDefinable(name.source,
-                             context_.FindScope(name.source),
-                             {DefinabilityFlag::PointerDefinition,
-                                 DefinabilityFlag::AcceptAllocatable,
-                                 DefinabilityFlag::PotentialDeallocation},
-                             *symbol)}) {
+              } else if (auto whyNot{
+                             WhyNotDefinable(source, context_.FindScope(source),
+                                 {DefinabilityFlag::PointerDefinition,
+                                     DefinabilityFlag::AcceptAllocatable,
+                                     DefinabilityFlag::PotentialDeallocation},
+                                 *symbol)}) {
                 // Catch problems with non-definability of the
                 // pointer/allocatable
                 context_
-                    .Say(name.source,
+                    .Say(source,
                         "Name in DEALLOCATE statement is not definable"_err_en_US)
                     .Attach(std::move(
                         whyNot->set_severity(parser::Severity::Because)));
-              } else if (auto whyNot{WhyNotDefinable(name.source,
-                             context_.FindScope(name.source),
-                             DefinabilityFlags{}, *symbol)}) {
+              } else if (auto whyNot{
+                             WhyNotDefinable(source, context_.FindScope(source),
+                                 DefinabilityFlags{}, *symbol)}) {
                 // Catch problems with non-definability of the dynamic object
                 context_
-                    .Say(name.source,
+                    .Say(source,
                         "Object in DEALLOCATE statement is not deallocatable"_err_en_US)
                     .Attach(std::move(
                         whyNot->set_severity(parser::Severity::Because)));
@@ -62,13 +98,12 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
             [&](const parser::StructureComponent &structureComponent) {
               // Only perform structureComponent checks if it was successfully
               // analyzed by expression analysis.
-              auto source{structureComponent.component.source};
+              source = structureComponent.component.source;
               if (const auto *expr{GetExpr(context_, allocateObject)}) {
-                if (const Symbol *
-                        symbol{structureComponent.component.symbol
-                                ? &structureComponent.component.symbol
-                                       ->GetUltimate()
-                                : nullptr};
+                if (const Symbol *symbol{structureComponent.component.symbol
+                            ? &structureComponent.component.symbol
+                                  ->GetUltimate()
+                            : nullptr};
                     !IsAllocatableOrObjectPointer(symbol)) { // F'2023 C936
                   context_.Say(source,
                       "Component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
@@ -99,32 +134,16 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
             },
         },
         allocateObject.u);
-  }
-  bool gotStat{false}, gotMsg{false};
-  for (const parser::StatOrErrmsg &deallocOpt :
-      std::get<std::list<parser::StatOrErrmsg>>(deallocateStmt.t)) {
-    common::visit(
-        common::visitors{
-            [&](const parser::StatVariable &) {
-              if (gotStat) {
-                context_.Say(
-                    "STAT may not be duplicated in a DEALLOCATE statement"_err_en_US);
-              }
-              gotStat = true;
-            },
-            [&](const parser::MsgVariable &var) {
-              WarnOnDeferredLengthCharacterScalar(context_,
-                  GetExpr(context_, var),
-                  parser::UnwrapRef<parser::Variable>(var).GetSource(),
-                  "ERRMSG=");
-              if (gotMsg) {
-                context_.Say(
-                    "ERRMSG may not be duplicated in a DEALLOCATE statement"_err_en_US);
-              }
-              gotMsg = true;
-            },
-        },
-        deallocOpt.u);
+    if (const SomeExpr *allocObj{GetExpr(context_, allocateObject)}) {
+      if (AreSameAllocation(allocObj, statVar)) {
+        context_.Say(statSource.value_or(source),
+            "STAT variable in DEALLOCATE must not be the variable being deallocated"_err_en_US);
+      }
+      if (AreSameAllocation(allocObj, msgVar)) {
+        context_.Say(msgSource.value_or(source),
+            "ERRMSG variable in DEALLOCATE must not be the variable being deallocated"_err_en_US);
+      }
+    }
   }
 }
 

flang/test/Semantics/allocate14.f90

@@ -0,0 +1,56 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Check for semantic errors in ALLOCATE statements
+
+program allocate14
+
+  integer, allocatable :: i1, i2
+  character(200), allocatable :: msg1, msg2
+  type t
+    integer, allocatable :: i
+    character(10), allocatable :: msg
+  end type t
+  type(t) :: tt(2)
+  type(t), allocatable :: ts(:)
+
+  allocate(i1)
+  allocate(msg1)
+
+  allocate(i2, stat=i1, errmsg=msg1)
+  allocate(msg2, stat=i1, errmsg=msg1)
+  deallocate(i2, stat=i1, errmsg=msg1)
+  deallocate(msg2, stat=i1, errmsg=msg1)
+
+  !ERROR: STAT variable in ALLOCATE must not be the variable being allocated
+  allocate(i2, stat=i2, errmsg=msg2)
+  !ERROR: ERRMSG variable in ALLOCATE must not be the variable being allocated
+  allocate(msg2, stat=i2, errmsg=msg2)
+  !ERROR: STAT variable in DEALLOCATE must not be the variable being deallocated
+  deallocate(i2, stat=i2, errmsg=msg2)
+  !ERROR: ERRMSG variable in DEALLOCATE must not be the variable being deallocated
+  deallocate(msg2, stat=i2, errmsg=msg2)
+
+  allocate(tt(1)%i)
+  allocate(tt(1)%msg)
+
+  allocate(tt(2)%i, stat=tt(1)%i, errmsg=tt(1)%msg)
+  allocate(tt(2)%msg, stat=tt(1)%i, errmsg=tt(1)%msg)
+  deallocate(tt(2)%i, stat=tt(1)%i, errmsg=tt(1)%msg)
+  deallocate(tt(2)%msg, stat=tt(1)%i, errmsg=tt(1)%msg)
+
+  !ERROR: STAT variable in ALLOCATE must not be the variable being allocated
+  allocate(tt(2)%i, stat=tt(2)%i, errmsg=tt(2)%msg)
+  !ERROR: ERRMSG variable in ALLOCATE must not be the variable being allocated
+  allocate(tt(2)%msg, stat=tt(2)%i, errmsg=tt(2)%msg)
+  !ERROR: STAT variable in DEALLOCATE must not be the variable being deallocated
+  deallocate(tt(2)%i, stat=tt(2)%i, errmsg=tt(2)%msg)
+  !ERROR: ERRMSG variable in DEALLOCATE must not be the variable being deallocated
+  deallocate(tt(2)%msg, stat=tt(2)%i, errmsg=tt(2)%msg)
+
+  !TODO: STAT variable in ALLOCATE must not be the variable being allocated
+  !TODO: ERRMSG variable in ALLOCATE must not be the variable being allocated
+  allocate(ts(10), stat=ts(1)%i, errmsg=ts(1)%msg)
+  !TODO: STAT variable in DEALLOCATE must not be the variable being deallocated
+  !TODO: ERRMSG variable in DEALLOCATE must not be the variable being deallocated
+  deallocate(ts, stat=ts(1)%i, errmsg=ts(1)%msg)
+end program
+