[flang-commits] [flang] [flang][semantics] add semantic check that STAT and ERRMSG are not (de)allocated by same statement (PR #164529)
Andre Kuhlenschmidt via flang-commits
flang-commits at lists.llvm.org
Thu Oct 23 19:16:53 PDT 2025
https://github.com/akuhlens updated https://github.com/llvm/llvm-project/pull/164529
>From 3d60ba3bb71c515d8b5c3a4f089127ad7f126a1e Mon Sep 17 00:00:00 2001
From: Andre Kuhlenschmidt <akuhlenschmi at nvidia.com>
Date: Tue, 21 Oct 2025 18:21:31 -0700
Subject: [PATCH 1/4] initial commit
---
flang/lib/Semantics/check-allocate.cpp | 26 +++++-
flang/lib/Semantics/check-deallocate.cpp | 104 ++++++++++++++---------
flang/test/Semantics/allocate14.f90 | 25 ++++++
3 files changed, 114 insertions(+), 41 deletions(-)
create mode 100644 flang/test/Semantics/allocate14.f90
diff --git a/flang/lib/Semantics/check-allocate.cpp b/flang/lib/Semantics/check-allocate.cpp
index e019bbdfa27f6..517063d3dd00b 100644
--- a/flang/lib/Semantics/check-allocate.cpp
+++ b/flang/lib/Semantics/check-allocate.cpp
@@ -26,6 +26,8 @@ struct AllocateCheckerInfo {
std::optional<evaluate::DynamicType> sourceExprType;
std::optional<parser::CharBlock> sourceExprLoc;
std::optional<parser::CharBlock> typeSpecLoc;
+ const parser::Name *statVar{nullptr};
+ const parser::Name *msgVar{nullptr};
int sourceExprRank{0}; // only valid if gotMold || gotSource
bool gotStat{false};
bool gotMsg{false};
@@ -141,11 +143,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);
}
+ if (const auto *designator{
+ parser::Unwrap<parser::Designator>(var)}) {
+ info.statVar = &parser::GetLastName(*designator);
+ }
info.gotStat = true;
},
[&](const parser::MsgVariable &var) {
@@ -158,6 +164,10 @@ static std::optional<AllocateCheckerInfo> CheckAllocateOptions(
context.Say(
"ERRMSG may not be duplicated in a ALLOCATE statement"_err_en_US);
}
+ if (const auto *designator{
+ parser::Unwrap<parser::Designator>(var)}) {
+ info.msgVar = &parser::GetLastName(*designator);
+ }
info.gotMsg = true;
},
},
@@ -690,6 +700,20 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
"Object in ALLOCATE must have DEVICE attribute when STREAM option is specified"_err_en_US);
}
}
+ if (allocateInfo_.gotStat && allocateInfo_.statVar) {
+ if (const Symbol *symbol{allocateInfo_.statVar->symbol};
+ symbol && *ultimate_ == symbol->GetUltimate()) {
+ context.Say(allocateInfo_.statVar->source,
+ "STAT variable in ALLOCATE must not be the variable being allocated"_err_en_US);
+ }
+ }
+ if (allocateInfo_.gotMsg && allocateInfo_.msgVar) {
+ if (const Symbol *symbol{allocateInfo_.msgVar->symbol};
+ symbol && *ultimate_ == symbol->GetUltimate()) {
+ context.Say(allocateInfo_.msgVar->source,
+ "ERRMSG variable in ALLOCATE must not be the variable being allocated"_err_en_US);
+ }
+ }
return RunCoarrayRelatedChecks(context);
}
diff --git a/flang/lib/Semantics/check-deallocate.cpp b/flang/lib/Semantics/check-deallocate.cpp
index c1ebc5f4c0ec2..d31793fa31c8b 100644
--- a/flang/lib/Semantics/check-deallocate.cpp
+++ b/flang/lib/Semantics/check-deallocate.cpp
@@ -17,20 +17,56 @@
namespace Fortran::semantics {
void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
+ bool gotStat{false}, gotMsg{false};
+ const parser::Name *statVar{nullptr}, *msgVar{nullptr};
+ 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);
+ }
+ if (const auto *designator{
+ parser::Unwrap<parser::Designator>(var)}) {
+ statVar = &parser::GetLastName(*designator);
+ }
+ 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);
+ }
+ if (const auto *designator{
+ parser::Unwrap<parser::Designator>(var)}) {
+ msgVar = &parser::GetLastName(*designator);
+ }
+ gotMsg = true;
+ },
+ },
+ deallocOpt.u);
+ }
for (const parser::AllocateObject &allocateObject :
std::get<std::list<parser::AllocateObject>>(deallocateStmt.t)) {
+ const Symbol *ultimate{nullptr};
common::visit(
common::visitors{
[&](const parser::Name &name) {
- const Symbol *symbol{
- name.symbol ? &name.symbol->GetUltimate() : nullptr};
- ;
- if (context_.HasError(symbol)) {
+ if (name.symbol) {
+ ultimate = &name.symbol->GetUltimate();
+ }
+ if (context_.HasError(ultimate)) {
// already reported an error
- } else if (!IsVariableName(*symbol)) {
+ } else if (!IsVariableName(*ultimate)) {
context_.Say(name.source,
"Name in DEALLOCATE statement must be a variable name"_err_en_US);
- } else if (!IsAllocatableOrObjectPointer(symbol)) { // C936
+ } else if (!IsAllocatableOrObjectPointer(ultimate)) { // C936
context_.Say(name.source,
"Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
} else if (auto whyNot{WhyNotDefinable(name.source,
@@ -38,7 +74,7 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
{DefinabilityFlag::PointerDefinition,
DefinabilityFlag::AcceptAllocatable,
DefinabilityFlag::PotentialDeallocation},
- *symbol)}) {
+ *ultimate)}) {
// Catch problems with non-definability of the
// pointer/allocatable
context_
@@ -48,7 +84,7 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
whyNot->set_severity(parser::Severity::Because)));
} else if (auto whyNot{WhyNotDefinable(name.source,
context_.FindScope(name.source),
- DefinabilityFlags{}, *symbol)}) {
+ DefinabilityFlags{}, *ultimate)}) {
// Catch problems with non-definability of the dynamic object
context_
.Say(name.source,
@@ -63,13 +99,11 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
// Only perform structureComponent checks if it was successfully
// analyzed by expression analysis.
auto source{structureComponent.component.source};
+ if (structureComponent.component.symbol) {
+ ultimate = &structureComponent.component.symbol->GetUltimate();
+ }
if (const auto *expr{GetExpr(context_, allocateObject)}) {
- if (const Symbol *
- symbol{structureComponent.component.symbol
- ? &structureComponent.component.symbol
- ->GetUltimate()
- : nullptr};
- !IsAllocatableOrObjectPointer(symbol)) { // F'2023 C936
+ if (!IsAllocatableOrObjectPointer(ultimate)) { // F'2023 C936
context_.Say(source,
"Component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
} else if (auto whyNot{WhyNotDefinable(source,
@@ -99,32 +133,22 @@ 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 (ultimate) {
+ if (gotStat && statVar) {
+ if (const Symbol *symbol{statVar->symbol};
+ symbol && *ultimate == symbol->GetUltimate()) {
+ context_.Say(statVar->source,
+ "STAT variable in DEALLOCATE must not be the variable being deallocated"_err_en_US);
+ }
+ }
+ if (gotMsg && msgVar) {
+ if (const Symbol *symbol{msgVar->symbol};
+ symbol && *ultimate == symbol->GetUltimate()) {
+ context_.Say(msgVar->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
new file mode 100644
index 0000000000000..02bab1a8c6040
--- /dev/null
+++ b/flang/test/Semantics/allocate14.f90
@@ -0,0 +1,25 @@
+! 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
+
+ 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)
+end program
+
>From 5da70acea0a6bd3f5412a4e7ebc086e3eda81822 Mon Sep 17 00:00:00 2001
From: Andre Kuhlenschmidt <akuhlenschmi at nvidia.com>
Date: Wed, 22 Oct 2025 14:58:48 -0700
Subject: [PATCH 2/4] address feedback
---
flang/lib/Semantics/check-allocate.cpp | 34 ++++-----
flang/lib/Semantics/check-deallocate.cpp | 88 +++++++++++-------------
flang/test/Semantics/allocate14.f90 | 31 +++++++++
3 files changed, 87 insertions(+), 66 deletions(-)
diff --git a/flang/lib/Semantics/check-allocate.cpp b/flang/lib/Semantics/check-allocate.cpp
index 517063d3dd00b..0490e500760c6 100644
--- a/flang/lib/Semantics/check-allocate.cpp
+++ b/flang/lib/Semantics/check-allocate.cpp
@@ -26,8 +26,10 @@ struct AllocateCheckerInfo {
std::optional<evaluate::DynamicType> sourceExprType;
std::optional<parser::CharBlock> sourceExprLoc;
std::optional<parser::CharBlock> typeSpecLoc;
- const parser::Name *statVar{nullptr};
- const parser::Name *msgVar{nullptr};
+ 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};
@@ -148,11 +150,10 @@ static std::optional<AllocateCheckerInfo> CheckAllocateOptions(
context.Say(
"STAT may not be duplicated in a ALLOCATE statement"_err_en_US);
}
- if (const auto *designator{
- parser::Unwrap<parser::Designator>(var)}) {
- info.statVar = &parser::GetLastName(*designator);
- }
info.gotStat = true;
+ info.statVar = GetExpr(context, var);
+ info.statSource =
+ parser::Unwrap<parser::Variable>(var)->GetSource();
},
[&](const parser::MsgVariable &var) {
WarnOnDeferredLengthCharacterScalar(context,
@@ -164,11 +165,10 @@ static std::optional<AllocateCheckerInfo> CheckAllocateOptions(
context.Say(
"ERRMSG may not be duplicated in a ALLOCATE statement"_err_en_US);
}
- if (const auto *designator{
- parser::Unwrap<parser::Designator>(var)}) {
- info.msgVar = &parser::GetLastName(*designator);
- }
info.gotMsg = true;
+ info.msgVar = GetExpr(context, var);
+ info.msgSource =
+ parser::Unwrap<parser::Variable>(var)->GetSource();
},
},
statOrErr.u);
@@ -700,17 +700,13 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
"Object in ALLOCATE must have DEVICE attribute when STREAM option is specified"_err_en_US);
}
}
- if (allocateInfo_.gotStat && allocateInfo_.statVar) {
- if (const Symbol *symbol{allocateInfo_.statVar->symbol};
- symbol && *ultimate_ == symbol->GetUltimate()) {
- context.Say(allocateInfo_.statVar->source,
+ if (const SomeExpr *allocObj{GetExpr(context, allocateObject_)}) {
+ if (allocateInfo_.statVar && *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_.gotMsg && allocateInfo_.msgVar) {
- if (const Symbol *symbol{allocateInfo_.msgVar->symbol};
- symbol && *ultimate_ == symbol->GetUltimate()) {
- context.Say(allocateInfo_.msgVar->source,
+ if (allocateInfo_.msgVar && *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-deallocate.cpp b/flang/lib/Semantics/check-deallocate.cpp
index d31793fa31c8b..51c048c56c6a2 100644
--- a/flang/lib/Semantics/check-deallocate.cpp
+++ b/flang/lib/Semantics/check-deallocate.cpp
@@ -13,12 +13,15 @@
#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 parser::Name *statVar{nullptr}, *msgVar{nullptr};
+ 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(
@@ -28,11 +31,9 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
context_.Say(
"STAT may not be duplicated in a DEALLOCATE statement"_err_en_US);
}
- if (const auto *designator{
- parser::Unwrap<parser::Designator>(var)}) {
- statVar = &parser::GetLastName(*designator);
- }
gotStat = true;
+ statVar = GetExpr(context_, var);
+ statSource = parser::Unwrap<parser::Variable>(var)->GetSource();
},
[&](const parser::MsgVariable &var) {
WarnOnDeferredLengthCharacterScalar(context_,
@@ -43,51 +44,49 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
context_.Say(
"ERRMSG may not be duplicated in a DEALLOCATE statement"_err_en_US);
}
- if (const auto *designator{
- parser::Unwrap<parser::Designator>(var)}) {
- msgVar = &parser::GetLastName(*designator);
- }
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)) {
- const Symbol *ultimate{nullptr};
+ parser::CharBlock source;
common::visit(
common::visitors{
[&](const parser::Name &name) {
- if (name.symbol) {
- ultimate = &name.symbol->GetUltimate();
- }
- if (context_.HasError(ultimate)) {
+ const Symbol *symbol{
+ name.symbol ? &name.symbol->GetUltimate() : nullptr};
+ source = name.source;
+ if (context_.HasError(symbol)) {
// already reported an error
- } else if (!IsVariableName(*ultimate)) {
- context_.Say(name.source,
+ } else if (!IsVariableName(*symbol)) {
+ context_.Say(source,
"Name in DEALLOCATE statement must be a variable name"_err_en_US);
- } else if (!IsAllocatableOrObjectPointer(ultimate)) { // C936
- context_.Say(name.source,
+ } else if (!IsAllocatableOrObjectPointer(symbol)) { // C936
+ 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},
- *ultimate)}) {
+ } 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{}, *ultimate)}) {
+ } 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)));
@@ -98,12 +97,13 @@ 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};
- if (structureComponent.component.symbol) {
- ultimate = &structureComponent.component.symbol->GetUltimate();
- }
+ source = structureComponent.component.source;
if (const auto *expr{GetExpr(context_, allocateObject)}) {
- if (!IsAllocatableOrObjectPointer(ultimate)) { // F'2023 C936
+ 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);
} else if (auto whyNot{WhyNotDefinable(source,
@@ -133,20 +133,14 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
},
},
allocateObject.u);
- if (ultimate) {
- if (gotStat && statVar) {
- if (const Symbol *symbol{statVar->symbol};
- symbol && *ultimate == symbol->GetUltimate()) {
- context_.Say(statVar->source,
- "STAT variable in DEALLOCATE must not be the variable being deallocated"_err_en_US);
- }
+ if (const SomeExpr *allocObj{GetExpr(context_, allocateObject)}) {
+ if (statVar && *allocObj == *statVar) {
+ context_.Say(statSource.value_or(source),
+ "STAT variable in DEALLOCATE must not be the variable being deallocated"_err_en_US);
}
- if (gotMsg && msgVar) {
- if (const Symbol *symbol{msgVar->symbol};
- symbol && *ultimate == symbol->GetUltimate()) {
- context_.Say(msgVar->source,
- "ERRMSG variable in DEALLOCATE must not be the variable being deallocated"_err_en_US);
- }
+ if (msgVar && *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
index 02bab1a8c6040..231e69250cf74 100644
--- a/flang/test/Semantics/allocate14.f90
+++ b/flang/test/Semantics/allocate14.f90
@@ -2,8 +2,15 @@
! 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)
@@ -21,5 +28,29 @@ program allocate14
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)
+
+ !FIXME: STAT variable in ALLOCATE must not be the variable being allocated
+ !FIXME: 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
+ deallocate(ts, stat=ts(1)%i, errmsg=ts(1)%msg)
end program
>From 78de4717b523ba1638a80c41878575b06f495da9 Mon Sep 17 00:00:00 2001
From: Andre Kuhlenschmidt <akuhlenschmi at nvidia.com>
Date: Thu, 23 Oct 2025 18:11:42 -0700
Subject: [PATCH 3/4] handle base that is allocation
---
flang/docs/ImplementingASemanticCheck.md | 2 +-
flang/include/flang/Evaluate/variable.h | 4 +-
flang/lib/Evaluate/variable.cpp | 59 ++++++++++++++++++++++++
flang/lib/Semantics/check-allocate.cpp | 28 ++++++++++-
flang/lib/Semantics/check-allocate.h | 1 +
flang/lib/Semantics/check-deallocate.cpp | 5 +-
flang/test/Semantics/allocate14.f90 | 8 ++--
7 files changed, 96 insertions(+), 11 deletions(-)
diff --git a/flang/docs/ImplementingASemanticCheck.md b/flang/docs/ImplementingASemanticCheck.md
index 598ef696ad14b..62f4d06350ece 100644
--- 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
index 5c14421fd3a1b..2e2a21cd78ebd 100644
--- 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
index b9b34d4d5bc89..25b53ea67c2f3 100644
--- 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
index 0490e500760c6..19f91cb5fd0b2 100644
--- 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
index e3f7f07bca5b7..da1d681a1923b 100644
--- 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
index 51c048c56c6a2..a58ad3f9b46d2 100644
--- 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
index 231e69250cf74..000b7c8ad5af2 100644
--- 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
>From e50223b022861831ff4e22c82cbea8cb1945750a Mon Sep 17 00:00:00 2001
From: Andre Kuhlenschmidt <akuhlenschmi at nvidia.com>
Date: Thu, 23 Oct 2025 19:16:40 -0700
Subject: [PATCH 4/4] explicitly null init pathSym and rootSym
---
flang/lib/Evaluate/variable.cpp | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/flang/lib/Evaluate/variable.cpp b/flang/lib/Evaluate/variable.cpp
index 25b53ea67c2f3..16ec725276331 100644
--- a/flang/lib/Evaluate/variable.cpp
+++ b/flang/lib/Evaluate/variable.cpp
@@ -769,7 +769,7 @@ struct has_GetFirstSymbol<T,
template <typename P, typename R>
bool TestVariableIsPathFromRoot(const P &path, const R &root) {
- const SymbolRef *pathSym, *rootSym;
+ const SymbolRef *pathSym{nullptr}, *rootSym{nullptr};
if constexpr (has_union<P>::value) {
pathSym = std::get_if<SymbolRef>(&path.u);
}
More information about the flang-commits
mailing list