[flang-commits] [flang] [llvm] [flang][runtime] Check SOURCE= conformability on ALLOCATE (PR #144113)
via flang-commits
flang-commits at lists.llvm.org
Fri Jun 13 16:16:16 PDT 2025
llvmbot wrote:
<!--LLVM PR SUMMARY COMMENT-->
@llvm/pr-subscribers-flang-semantics
Author: Peter Klausler (klausler)
<details>
<summary>Changes</summary>
The SOURCE= expression of an ALLOCATE statement, when present and not scalar, must conform to the shape of the allocated objects. Check this at runtime, and return a recoverable error, or crash, when appropriate.
Fixes https://github.com/llvm/llvm-project/issues/143900.
---
Full diff: https://github.com/llvm/llvm-project/pull/144113.diff
3 Files Affected:
- (modified) flang-rt/lib/runtime/allocatable.cpp (+20)
- (modified) flang/lib/Semantics/check-allocate.cpp (+48)
- (modified) flang/test/Semantics/allocate11.f90 (+1)
``````````diff
diff --git a/flang-rt/lib/runtime/allocatable.cpp b/flang-rt/lib/runtime/allocatable.cpp
index ef18da6ea0786..f724f0a20884b 100644
--- a/flang-rt/lib/runtime/allocatable.cpp
+++ b/flang-rt/lib/runtime/allocatable.cpp
@@ -165,6 +165,26 @@ int RTDEF(AllocatableAllocateSource)(Descriptor &alloc,
alloc, /*asyncObject=*/nullptr, hasStat, errMsg, sourceFile, sourceLine)};
if (stat == StatOk) {
Terminator terminator{sourceFile, sourceLine};
+ if (alloc.rank() != source.rank() && source.rank() != 0) {
+ terminator.Crash("ALLOCATE object has rank %d while SOURCE= has rank %d",
+ alloc.rank(), source.rank());
+ }
+ if (int rank{source.rank()}; rank > 0) {
+ SubscriptValue allocExtent[maxRank], sourceExtent[maxRank];
+ alloc.GetShape(allocExtent);
+ source.GetShape(sourceExtent);
+ for (int j{0}; j < rank; ++j) {
+ if (allocExtent[j] != sourceExtent[j]) {
+ if (!hasStat) {
+ terminator.Crash("ALLOCATE object has extent %jd on dimension %d, "
+ "but SOURCE= has extent %jd",
+ static_cast<std::intmax_t>(allocExtent[j]), j + 1,
+ static_cast<std::intmax_t>(sourceExtent[j]));
+ }
+ return StatInvalidExtent;
+ }
+ }
+ }
DoFromSourceAssign(alloc, source, terminator);
}
return stat;
diff --git a/flang/lib/Semantics/check-allocate.cpp b/flang/lib/Semantics/check-allocate.cpp
index 2c215f45bf516..21b5c0ab733b5 100644
--- a/flang/lib/Semantics/check-allocate.cpp
+++ b/flang/lib/Semantics/check-allocate.cpp
@@ -10,6 +10,7 @@
#include "assignment.h"
#include "definable.h"
#include "flang/Evaluate/fold.h"
+#include "flang/Evaluate/shape.h"
#include "flang/Evaluate/type.h"
#include "flang/Parser/parse-tree.h"
#include "flang/Parser/tools.h"
@@ -33,6 +34,7 @@ struct AllocateCheckerInfo {
bool gotMold{false};
bool gotStream{false};
bool gotPinned{false};
+ std::optional<evaluate::ConstantSubscripts> sourceExprShape;
};
class AllocationCheckerHelper {
@@ -259,6 +261,9 @@ static std::optional<AllocateCheckerInfo> CheckAllocateOptions(
CheckCopyabilityInPureScope(messages, *expr, scope);
}
}
+ auto maybeShape{evaluate::GetShape(context.foldingContext(), *expr)};
+ info.sourceExprShape =
+ evaluate::AsConstantExtents(context.foldingContext(), maybeShape);
} else {
// Error already reported on source expression.
// Do not continue allocate checks.
@@ -581,6 +586,49 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
.Attach(
ultimate_->name(), "Declared here with rank %d"_en_US, rank_);
return false;
+ } else if (allocateInfo_.gotSource && allocateInfo_.sourceExprShape &&
+ allocateInfo_.sourceExprShape->size() ==
+ static_cast<std::size_t>(allocateShapeSpecRank_)) {
+ std::size_t j{0};
+ for (const auto &shapeSpec :
+ std::get<std::list<parser::AllocateShapeSpec>>(allocation_.t)) {
+ if (j >= allocateInfo_.sourceExprShape->size()) {
+ break;
+ }
+ std::optional<evaluate::ConstantSubscript> lbound;
+ if (const auto &lb{std::get<0>(shapeSpec.t)}) {
+ lbound.reset();
+ const auto &lbExpr{lb->thing.thing.value()};
+ if (const auto *expr{GetExpr(context, lbExpr)}) {
+ auto folded{
+ evaluate::Fold(context.foldingContext(), SomeExpr(*expr))};
+ lbound = evaluate::ToInt64(folded);
+ evaluate::SetExpr(lbExpr, std::move(folded));
+ }
+ } else {
+ lbound = 1;
+ }
+ if (lbound) {
+ const auto &ubExpr{std::get<1>(shapeSpec.t).thing.thing.value()};
+ if (const auto *expr{GetExpr(context, ubExpr)}) {
+ auto folded{
+ evaluate::Fold(context.foldingContext(), SomeExpr(*expr))};
+ auto ubound{evaluate::ToInt64(folded)};
+ evaluate::SetExpr(ubExpr, std::move(folded));
+ if (ubound) {
+ auto extent{*ubound - *lbound + 1};
+ if (extent != allocateInfo_.sourceExprShape->at(j)) {
+ context.Say(name_.source,
+ "Allocation has extent %jd on dimension %d, but SOURCE= has extent %jd"_err_en_US,
+ static_cast<std::intmax_t>(extent), j + 1,
+ static_cast<std::intmax_t>(
+ allocateInfo_.sourceExprShape->at(j)));
+ }
+ }
+ }
+ }
+ ++j;
+ }
}
}
} else { // allocating a scalar object
diff --git a/flang/test/Semantics/allocate11.f90 b/flang/test/Semantics/allocate11.f90
index 1b7495e9fc07d..8aeb069df09f2 100644
--- a/flang/test/Semantics/allocate11.f90
+++ b/flang/test/Semantics/allocate11.f90
@@ -163,6 +163,7 @@ subroutine C938_C947(var2, ptr, ptr2, fptr, my_team, srca)
allocate(var2(2)[5:*], MOLD=my_team)
!ERROR: SOURCE or MOLD expression type must not be C_PTR or C_FUNPTR from ISO_C_BINDING when an allocatable object is a coarray
allocate(var2(2)[5:*], MOLD=ptr)
+ !ERROR: Allocation has extent 2 on dimension 1, but SOURCE= has extent 9
!ERROR: SOURCE or MOLD expression type must not be C_PTR or C_FUNPTR from ISO_C_BINDING when an allocatable object is a coarray
allocate(var2(2)[5:*], SOURCE=ptr2)
!ERROR: SOURCE or MOLD expression type must not be C_PTR or C_FUNPTR from ISO_C_BINDING when an allocatable object is a coarray
``````````
</details>
https://github.com/llvm/llvm-project/pull/144113
More information about the flang-commits
mailing list