[flang-commits] [flang] [flang] Improve procedure interface compatibility checking for dummy … (PR #72704)
via flang-commits
flang-commits at lists.llvm.org
Fri Nov 17 13:31:07 PST 2023
llvmbot wrote:
<!--LLVM PR SUMMARY COMMENT-->
@llvm/pr-subscribers-flang-semantics
Author: Peter Klausler (klausler)
<details>
<summary>Changes</summary>
…arrays
When comparing dummy array extents, cope with references to symbols better (including references to other dummy arguments), and emit warnings in dubious cases that are not equivalent but not provably incompatible.
---
Patch is 26.13 KiB, truncated to 20.00 KiB below, full version: https://github.com/llvm/llvm-project/pull/72704.diff
8 Files Affected:
- (modified) flang/include/flang/Common/Fortran-features.h (+1-1)
- (modified) flang/include/flang/Evaluate/characteristics.h (+8-6)
- (modified) flang/include/flang/Evaluate/tools.h (+11-2)
- (modified) flang/lib/Evaluate/characteristics.cpp (+25-33)
- (modified) flang/lib/Evaluate/tools.cpp (+100-3)
- (modified) flang/lib/Semantics/check-call.cpp (+20-4)
- (modified) flang/lib/Semantics/pointer-assignment.cpp (+7-1)
- (modified) flang/test/Semantics/argshape01.f90 (+87-4)
``````````diff
diff --git a/flang/include/flang/Common/Fortran-features.h b/flang/include/flang/Common/Fortran-features.h
index 7e518a210f01cd3..a6b19e9833fc518 100644
--- a/flang/include/flang/Common/Fortran-features.h
+++ b/flang/include/flang/Common/Fortran-features.h
@@ -53,7 +53,7 @@ ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable,
ShortCharacterActual, ExprPassedToVolatile, ImplicitInterfaceActual,
PolymorphicTransferArg, PointerComponentTransferArg, TransferSizePresence,
F202XAllocatableBreakingChange, DimMustBePresent, CommonBlockPadding,
- LogicalVsCBool, BindCCharLength)
+ LogicalVsCBool, BindCCharLength, ProcDummyArgShapes)
using LanguageFeatures = EnumSet<LanguageFeature, LanguageFeature_enumSize>;
using UsageWarnings = EnumSet<UsageWarning, UsageWarning_enumSize>;
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index b07affc302622f0..43f8134b93c5c87 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -54,7 +54,8 @@ bool DistinguishableOpOrAssign(const common::LanguageFeatureControl &,
// Shapes of function results and dummy arguments have to have
// the same rank, the same deferred dimensions, and the same
// values for explicit dimensions when constant.
-bool ShapesAreCompatible(const Shape &, const Shape &);
+bool ShapesAreCompatible(
+ const Shape &, const Shape &, bool *possibleWarning = nullptr);
class TypeAndShape {
public:
@@ -222,8 +223,8 @@ struct DummyDataObject {
bool operator!=(const DummyDataObject &that) const {
return !(*this == that);
}
- bool IsCompatibleWith(
- const DummyDataObject &, std::string *whyNot = nullptr) const;
+ bool IsCompatibleWith(const DummyDataObject &, std::string *whyNot = nullptr,
+ std::optional<std::string> *warning = nullptr) const;
static std::optional<DummyDataObject> Characterize(
const semantics::Symbol &, FoldingContext &);
bool CanBePassedViaImplicitInterface() const;
@@ -283,8 +284,8 @@ struct DummyArgument {
void SetIntent(common::Intent);
bool CanBePassedViaImplicitInterface() const;
bool IsTypelessIntrinsicDummy() const;
- bool IsCompatibleWith(
- const DummyArgument &, std::string *whyNot = nullptr) const;
+ bool IsCompatibleWith(const DummyArgument &, std::string *whyNot = nullptr,
+ std::optional<std::string> *warning = nullptr) const;
llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
// name and pass are not characteristics and so do not participate in
@@ -379,7 +380,8 @@ struct Procedure {
bool CanBeCalledViaImplicitInterface() const;
bool CanOverride(const Procedure &, std::optional<int> passIndex) const;
bool IsCompatibleWith(const Procedure &, std::string *whyNot = nullptr,
- const SpecificIntrinsic * = nullptr) const;
+ const SpecificIntrinsic * = nullptr,
+ std::optional<std::string> *warning = nullptr) const;
llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index 55262a912d95629..602249013baabd6 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -1082,11 +1082,12 @@ bool IsExpandableScalar(const Expr<T> &expr, FoldingContext &context,
// Common handling for procedure pointer compatibility of left- and right-hand
// sides. Returns nullopt if they're compatible. Otherwise, it returns a
-// message that needs to be augmented by the names of the left and right sides
+// message that needs to be augmented by the names of the left and right sides.
std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
const std::optional<characteristics::Procedure> &lhsProcedure,
const characteristics::Procedure *rhsProcedure,
- const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible);
+ const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible,
+ std::optional<std::string> &warning);
// Scalar constant expansion
class ScalarConstantExpander {
@@ -1178,6 +1179,12 @@ class ArrayConstantBoundChanger {
ConstantSubscripts &&lbounds_;
};
+// Predicate: should two expressions be considered identical for the purposes
+// of determining whether two procedure interfaces are compatible, modulo
+// naming of corresponding dummy arguments?
+std::optional<bool> AreEquivalentInInterface(
+ const Expr<SubscriptInteger> &, const Expr<SubscriptInteger> &);
+
} // namespace Fortran::evaluate
namespace Fortran::semantics {
@@ -1254,6 +1261,8 @@ bool AreTkCompatibleTypes(const DeclTypeSpec *x, const DeclTypeSpec *y);
common::IgnoreTKRSet GetIgnoreTKR(const Symbol &);
+std::optional<int> GetDummyArgumentNumber(const Symbol *);
+
} // namespace Fortran::semantics
#endif // FORTRAN_EVALUATE_TOOLS_H_
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 16aa08603bdad41..bb44b0f1be8ce29 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -38,18 +38,21 @@ static void CopyAttrs(const semantics::Symbol &src, A &dst,
// Shapes of function results and dummy arguments have to have
// the same rank, the same deferred dimensions, and the same
// values for explicit dimensions when constant.
-bool ShapesAreCompatible(const Shape &x, const Shape &y) {
+bool ShapesAreCompatible(
+ const Shape &x, const Shape &y, bool *possibleWarning) {
if (x.size() != y.size()) {
return false;
}
auto yIter{y.begin()};
for (const auto &xDim : x) {
const auto &yDim{*yIter++};
- if (xDim) {
- if (!yDim || ToInt64(*xDim) != ToInt64(*yDim)) {
- return false;
+ if (xDim && yDim) {
+ if (auto equiv{AreEquivalentInInterface(*xDim, *yDim)}) {
+ return *equiv;
+ } else if (possibleWarning) {
+ *possibleWarning = true;
}
- } else if (yDim) {
+ } else if (xDim || yDim) {
return false;
}
}
@@ -270,35 +273,19 @@ llvm::raw_ostream &TypeAndShape::Dump(llvm::raw_ostream &o) const {
bool DummyDataObject::operator==(const DummyDataObject &that) const {
return type == that.type && attrs == that.attrs && intent == that.intent &&
coshape == that.coshape && cudaDataAttr == that.cudaDataAttr;
- ;
-}
-
-static bool AreCompatibleDummyDataObjectShapes(const Shape &x, const Shape &y) {
- int n{GetRank(x)};
- if (n != GetRank(y)) {
- return false;
- }
- auto xIter{x.begin()};
- auto yIter{y.begin()};
- for (; n-- > 0; ++xIter, ++yIter) {
- if (auto xVal{ToInt64(*xIter)}) {
- if (auto yVal{ToInt64(*yIter)}) {
- if (*xVal != *yVal) {
- return false;
- }
- }
- }
- }
- return true;
}
-bool DummyDataObject::IsCompatibleWith(
- const DummyDataObject &actual, std::string *whyNot) const {
- if (!AreCompatibleDummyDataObjectShapes(type.shape(), actual.type.shape())) {
+bool DummyDataObject::IsCompatibleWith(const DummyDataObject &actual,
+ std::string *whyNot, std::optional<std::string> *warning) const {
+ bool possibleWarning{false};
+ if (!ShapesAreCompatible(
+ type.shape(), actual.type.shape(), &possibleWarning)) {
if (whyNot) {
*whyNot = "incompatible dummy data object shapes";
}
return false;
+ } else if (warning && possibleWarning) {
+ *warning = "distinct dummy data object shapes";
}
// Treat deduced dummy character type as if it were assumed-length character
// to avoid useless "implicit interfaces have distinct type" warnings from
@@ -748,11 +735,11 @@ bool DummyArgument::operator==(const DummyArgument &that) const {
return u == that.u; // name and passed-object usage are not characteristics
}
-bool DummyArgument::IsCompatibleWith(
- const DummyArgument &actual, std::string *whyNot) const {
+bool DummyArgument::IsCompatibleWith(const DummyArgument &actual,
+ std::string *whyNot, std::optional<std::string> *warning) const {
if (const auto *ifaceData{std::get_if<DummyDataObject>(&u)}) {
if (const auto *actualData{std::get_if<DummyDataObject>(&actual.u)}) {
- return ifaceData->IsCompatibleWith(*actualData, whyNot);
+ return ifaceData->IsCompatibleWith(*actualData, whyNot, warning);
}
if (whyNot) {
*whyNot = "one dummy argument is an object, the other is not";
@@ -1181,7 +1168,8 @@ bool Procedure::operator==(const Procedure &that) const {
}
bool Procedure::IsCompatibleWith(const Procedure &actual, std::string *whyNot,
- const SpecificIntrinsic *specificIntrinsic) const {
+ const SpecificIntrinsic *specificIntrinsic,
+ std::optional<std::string> *warning) const {
// 15.5.2.9(1): if dummy is not pure, actual need not be.
// Ditto with elemental.
Attrs actualAttrs{actual.attrs};
@@ -1226,13 +1214,17 @@ bool Procedure::IsCompatibleWith(const Procedure &actual, std::string *whyNot,
// subroutine s1(base); subroutine s2(extended)
// procedure(s1), pointer :: p
// p => s2 ! an error, s2 is more restricted, can't handle "base"
+ std::optional<std::string> gotWarning;
if (!actual.dummyArguments[j].IsCompatibleWith(
- dummyArguments[j], whyNot)) {
+ dummyArguments[j], whyNot, warning ? &gotWarning : nullptr)) {
if (whyNot) {
*whyNot = "incompatible dummy argument #"s + std::to_string(j + 1) +
": "s + *whyNot;
}
return false;
+ } else if (warning && !*warning && gotWarning) {
+ *warning = "possibly incompatible dummy argument #"s +
+ std::to_string(j + 1) + ": "s + std::move(*gotWarning);
}
}
return true;
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index 9d51649652537ed..8c755da4a2d8b81 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -1082,7 +1082,8 @@ std::optional<std::string> FindImpureCall(
std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
const std::optional<characteristics::Procedure> &lhsProcedure,
const characteristics::Procedure *rhsProcedure,
- const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible) {
+ const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible,
+ std::optional<std::string> &warning) {
std::optional<parser::MessageFixedText> msg;
if (!lhsProcedure) {
msg = "In assignment to object %s, the target '%s' is a procedure"
@@ -1096,8 +1097,8 @@ std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
*rhsProcedure->functionResult, &whyNotCompatible)) {
msg =
"Function %s associated with incompatible function designator '%s': %s"_err_en_US;
- } else if (lhsProcedure->IsCompatibleWith(
- *rhsProcedure, &whyNotCompatible, specificIntrinsic)) {
+ } else if (lhsProcedure->IsCompatibleWith(*rhsProcedure, &whyNotCompatible,
+ specificIntrinsic, &warning)) {
// OK
} else if (isCall) {
msg = "Procedure %s associated with result of reference to function '%s'"
@@ -1275,6 +1276,83 @@ std::optional<Expr<SomeType>> HollerithToBOZ(FoldingContext &context,
}
}
+// Extracts a whole symbol being used as a bound of a dummy argument,
+// possibly wrapped with parentheses or MAX(0, ...).
+template <int KIND>
+static const Symbol *GetBoundSymbol(
+ const Expr<Type<TypeCategory::Integer, KIND>> &expr) {
+ using T = Type<TypeCategory::Integer, KIND>;
+ return common::visit(
+ common::visitors{
+ [](const Extremum<T> &max) -> const Symbol * {
+ if (max.ordering == Ordering::Greater) {
+ if (auto zero{ToInt64(max.left())}; zero && *zero == 0) {
+ return GetBoundSymbol(max.right());
+ }
+ }
+ return nullptr;
+ },
+ [](const Parentheses<T> &x) { return GetBoundSymbol(x.left()); },
+ [](const Designator<T> &x) -> const Symbol * {
+ if (const auto *ref{std::get_if<SymbolRef>(&x.u)}) {
+ return &**ref;
+ }
+ return nullptr;
+ },
+ [](const Convert<T, TypeCategory::Integer> &x) {
+ return common::visit(
+ [](const auto &y) -> const Symbol * {
+ using yType = std::decay_t<decltype(y)>;
+ using yResult = typename yType::Result;
+ if constexpr (yResult::kind <= KIND) {
+ return GetBoundSymbol(y);
+ } else {
+ return nullptr;
+ }
+ },
+ x.left().u);
+ },
+ [](const auto &) -> const Symbol * { return nullptr; },
+ },
+ expr.u);
+}
+
+std::optional<bool> AreEquivalentInInterface(
+ const Expr<SubscriptInteger> &x, const Expr<SubscriptInteger> &y) {
+ auto xVal{ToInt64(x)};
+ auto yVal{ToInt64(y)};
+ if (xVal && yVal) {
+ return *xVal == *yVal;
+ } else if (xVal || yVal) {
+ return false;
+ }
+ const Symbol *xSym{GetBoundSymbol(x)};
+ const Symbol *ySym{GetBoundSymbol(y)};
+ if (xSym && ySym) {
+ if (&xSym->GetUltimate() == &ySym->GetUltimate()) {
+ return true; // USE/host associated same symbol
+ }
+ auto xNum{semantics::GetDummyArgumentNumber(xSym)};
+ auto yNum{semantics::GetDummyArgumentNumber(ySym)};
+ if (xNum && yNum) {
+ if (*xNum == *yNum) {
+ auto xType{DynamicType::From(*xSym)};
+ auto yType{DynamicType::From(*ySym)};
+ return xType && yType && xType->IsEquivalentTo(*yType);
+ }
+ }
+ return false;
+ } else if (xSym || ySym) {
+ return false;
+ }
+ // Neither expression is an integer constant or a whole symbol.
+ if (x == y) {
+ return true;
+ } else {
+ return std::nullopt; // not sure
+ }
+}
+
} // namespace Fortran::evaluate
namespace Fortran::semantics {
@@ -1788,4 +1866,23 @@ common::IgnoreTKRSet GetIgnoreTKR(const Symbol &symbol) {
return result;
}
+std::optional<int> GetDummyArgumentNumber(const Symbol *symbol) {
+ if (symbol) {
+ if (IsDummy(*symbol)) {
+ if (const Symbol * subpSym{symbol->owner().symbol()}) {
+ if (const auto *subp{subpSym->detailsIf<SubprogramDetails>()}) {
+ int j{0};
+ for (const Symbol *dummy : subp->dummyArgs()) {
+ if (dummy == symbol) {
+ return j;
+ }
+ ++j;
+ }
+ }
+ }
+ }
+ }
+ return std::nullopt;
+}
+
} // namespace Fortran::semantics
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index efc2cb0a291ddce..42922229fb91d28 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -968,7 +968,9 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
}
if (interface.HasExplicitInterface()) {
std::string whyNot;
- if (!interface.IsCompatibleWith(argInterface, &whyNot)) {
+ std::optional<std::string> warning;
+ if (!interface.IsCompatibleWith(argInterface, &whyNot,
+ /*specificIntrinsic=*/nullptr, &warning)) {
// 15.5.2.9(1): Explicit interfaces must match
if (argInterface.HasExplicitInterface()) {
messages.Say(
@@ -985,6 +987,11 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
"Actual procedure argument has an implicit interface which is not known to be compatible with %s which has an explicit interface"_warn_en_US,
dummyName);
}
+ } else if (warning &&
+ context.ShouldWarn(common::UsageWarning::ProcDummyArgShapes)) {
+ messages.Say(
+ "Actual procedure argument has possible interface incompatibility with %s: %s"_warn_en_US,
+ dummyName, std::move(*warning));
}
} else { // 15.5.2.9(2,3)
if (interface.IsSubroutine() && argInterface.IsFunction()) {
@@ -1348,6 +1355,7 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
*targetExpr, foldingContext)}) {
bool isCall{!!UnwrapProcedureRef(*targetExpr)};
std::string whyNot;
+ std::optional<std::string> warning;
const auto *targetProcDesignator{
evaluate::UnwrapExpr<evaluate::ProcedureDesignator>(
*targetExpr)};
@@ -1355,9 +1363,17 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
targetProcDesignator
? targetProcDesignator->GetSpecificIntrinsic()
: nullptr};
- if (std::optional<parser::MessageFixedText> msg{
- CheckProcCompatibility(isCall, pointerProc,
- &*targetProc, specificIntrinsic, whyNot)}) {
+ std::optional<parser::MessageFixedText> msg{
+ CheckProcCompatibility(isCall, pointerProc, &*targetProc,
+ specificIntrinsic, whyNot, warning)};
+ if (!msg && warning &&
+ semanticsContext.ShouldWarn(
+ common::UsageWarning::ProcDummyArgShapes)) {
+ msg =
+ "Procedures '%s' and '%s' may not be completely compatible: %s"_warn_en_US;
+ whyNot = std::move(*warning);
+ }
+ if (msg) {
msg->set_severity(parser::Severity::Warning);
messages.Say(std::move(*msg),
"pointer '" + pointerExpr->AsFortran() + "'",
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index 0dcaa4e3f2a359c..4c293e85cf9de9c 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -359,12 +359,18 @@ bool PointerAssignmentChecker::Check(parser::CharBlock rhsName, bool isCall,
const Procedure *rhsProcedure,
const evaluate::SpecificIntrinsic *specific) {
std::string whyNot;
+ std::optional<std::string> warning;
CharacterizeProcedure();
if (std::optional<MessageFixedText> msg{evaluate::CheckProcCompatibility(
- isCall, procedure_, rhsProcedure, specific, whyNot)}) {
+ isCall, procedure_, rhsProcedure, specific, whyNot, warning)}) {
Say(std::move(*msg), description_, rhsName, whyNot);
return false;
}
+ if (context_.ShouldWarn(common::UsageWarning::ProcDummyArgShapes) &&
+ warning) {
+ Say("%s and %s may not be completely compatible procedures: %s"_warn_en_US,
+ description_, rhsName, std::move(*warning));
+ }
return true;
}
diff --git a/flang/test/Semantics/argshape01.f90 b/flang/test/Semantics/argshape01.f90
index b57641a1b898b34..19cca1ca4620a7c 100644
--- a/flang/test/Semantics/argshape01.f90
+++ b/flang/test/Semantics/argshape01.f90
@@ -1,6 +1,7 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
! Detect incompatible argument shapes
module m
+ integer :: ha = 1
contains
subroutine s1(a)
real, intent(in) :: a(2,3)
@@ -17,6 +18,32 @@ subroutine s4(a)
subroutine s5(a)
real, intent(in) :: a(..)
end
+ subroutine s6(a,n,m)
+ integer, intent(in) :: n, m
+ real, intent(in) :: a(n, m)
+ end
+ subroutine s6b(a,nn,mm)
+ integer, intent(in) :: nn, mm
+ real, intent(in) :: a(nn, mm)
+ end
+ subroutine s7(a,n,m)
+ integer, intent(in) :: n, m
+ real, intent(in) :: a(m, n)
+ end
+ subroutine s8(a,n,m)
+ integer, intent(in) :: n, m
+ real, intent(in) :: a(n+1,m+1)
+ end
+ subroutine s8b(a,n,m)
+ integer, intent(in) :: n, m
+ real, intent(in) :: a(n-1,m+2)
+ end
+ subroutine s9(a)
+ real, intent(in) :: a(ha,ha)
+ end
+ subroutine s9b(a)
+ real, intent(in) :: a(ha,ha)
+ end
subroutine s1c(s)
procedure(s1) :: s
end
@@ -32,6 +59,18 @@ subroutine s4c(s)
subroutine s5c(s)
procedure(s5) :: s
end
+ subroutine s6c(s)
+ procedure(s6) :: s
+ end
+ subroutine s7c(s)
+ procedure(s7) :: s
+ end
+ subroutine s8c(s)
+ procedure(s8) :: s
+ end
+ subroutine...
[truncated]
``````````
</details>
https://github.com/llvm/llvm-project/pull/72704
More information about the flang-commits
mailing list