Skip to content

Commit

Permalink
[flang] Improve procedure interface compatibility checking for dummy … (
Browse files Browse the repository at this point in the history 
#72704)

…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.
  • Loading branch information
@klausler
klausler committed Nov 30, 2023
1 parent f8a21df commit e86591b
Show file tree
Hide file tree
Showing 8 changed files with 261 additions and 54 deletions.
2 changes: 1 addition & 1 deletion flang/include/flang/Common/Fortran-features.h
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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>;
Expand Down
14 changes: 8 additions & 6 deletions flang/include/flang/Evaluate/characteristics.h
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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:
Expand Down Expand Up @@ -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;
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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;

Expand Down
13 changes: 11 additions & 2 deletions flang/include/flang/Evaluate/tools.h
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1089,11 +1089,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 {
Expand Down Expand Up @@ -1185,6 +1186,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 {
Expand Down Expand Up @@ -1261,6 +1268,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_
60 changes: 27 additions & 33 deletions flang/lib/Evaluate/characteristics.cpp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -38,18 +38,23 @@ 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)}) {
if (!*equiv) {
return false;
}
} else if (possibleWarning) {
*possibleWarning = true;
}
} else if (yDim) {
} else if (xDim || yDim) {
return false;
}
}
Expand Down Expand Up @@ -270,35 +275,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
Expand Down Expand Up @@ -748,11 +737,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";
Expand Down Expand Up @@ -1181,7 +1170,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};
Expand Down Expand Up @@ -1226,13 +1216,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;
Expand Down
103 changes: 100 additions & 3 deletions flang/lib/Evaluate/tools.cpp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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"
Expand All @@ -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'"
Expand Down Expand Up @@ -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 {
Expand Down Expand Up @@ -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
24 changes: 20 additions & 4 deletions flang/lib/Semantics/check-call.cpp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -971,7 +971,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(
Expand All @@ -988,6 +990,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()) {
Expand Down Expand Up @@ -1351,16 +1358,25 @@ 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)};
const evaluate::SpecificIntrinsic *specificIntrinsic{
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() + "'",
Expand Down
Loading

0 comments on commit e86591b

Please sign in to comment.