diff --git a/flang-rt/lib/runtime/allocatable.cpp b/flang-rt/lib/runtime/allocatable.cpp index ef18da6ea078..f724f0a20884 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(allocExtent[j]), j + 1, + static_cast(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 2c215f45bf51..08053594c12e 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 sourceExprShape; }; class AllocationCheckerHelper { @@ -259,6 +261,9 @@ static std::optional 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,52 @@ 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(allocateShapeSpecRank_)) { + std::size_t j{0}; + for (const auto &shapeSpec : + std::get>(allocation_.t)) { + if (j >= allocateInfo_.sourceExprShape->size()) { + break; + } + std::optional 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 < 0) { + extent = 0; + } + 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(extent), j + 1, + static_cast( + 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 1b7495e9fc07..8aeb069df09f 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