Skip to content

Commit d416f71

Browse files
klauslerklausler
committed
[flang] Improve procedure interface compatibility checking for dummy 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.
1 parent 328fd36 commit d416f71

File tree

8 files changed

+261
-54
lines changed

8 files changed

+261
-54
lines changed

‎flang/include/flang/Common/Fortran-features.h

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -53,7 +53,7 @@ ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable,
5353
ShortCharacterActual, ExprPassedToVolatile, ImplicitInterfaceActual,
5454
PolymorphicTransferArg, PointerComponentTransferArg, TransferSizePresence,
5555
F202XAllocatableBreakingChange, DimMustBePresent, CommonBlockPadding,
56-
LogicalVsCBool, BindCCharLength)
56+
LogicalVsCBool, BindCCharLength, ProcDummyArgShapes)
5757

5858
using LanguageFeatures = EnumSet<LanguageFeature, LanguageFeature_enumSize>;
5959
using UsageWarnings = EnumSet<UsageWarning, UsageWarning_enumSize>;

‎flang/include/flang/Evaluate/characteristics.h

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -54,7 +54,8 @@ bool DistinguishableOpOrAssign(const common::LanguageFeatureControl &,
5454
// Shapes of function results and dummy arguments have to have
5555
// the same rank, the same deferred dimensions, and the same
5656
// values for explicit dimensions when constant.
57-
bool ShapesAreCompatible(const Shape &, const Shape &);
57+
bool ShapesAreCompatible(
58+
const Shape &, const Shape &, bool *possibleWarning = nullptr);
5859

5960
class TypeAndShape {
6061
public:
@@ -222,8 +223,8 @@ struct DummyDataObject {
222223
bool operator!=(const DummyDataObject &that) const {
223224
return !(*this == that);
224225
}
225-
bool IsCompatibleWith(
226-
const DummyDataObject &, std::string *whyNot = nullptr) const;
226+
bool IsCompatibleWith(const DummyDataObject &, std::string *whyNot = nullptr,
227+
std::optional<std::string> *warning = nullptr) const;
227228
static std::optional<DummyDataObject> Characterize(
228229
const semantics::Symbol &, FoldingContext &);
229230
bool CanBePassedViaImplicitInterface() const;
@@ -283,8 +284,8 @@ struct DummyArgument {
283284
void SetIntent(common::Intent);
284285
bool CanBePassedViaImplicitInterface() const;
285286
bool IsTypelessIntrinsicDummy() const;
286-
bool IsCompatibleWith(
287-
const DummyArgument &, std::string *whyNot = nullptr) const;
287+
bool IsCompatibleWith(const DummyArgument &, std::string *whyNot = nullptr,
288+
std::optional<std::string> *warning = nullptr) const;
288289
llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
289290

290291
// name and pass are not characteristics and so do not participate in
@@ -379,7 +380,8 @@ struct Procedure {
379380
bool CanBeCalledViaImplicitInterface() const;
380381
bool CanOverride(const Procedure &, std::optional<int> passIndex) const;
381382
bool IsCompatibleWith(const Procedure &, std::string *whyNot = nullptr,
382-
const SpecificIntrinsic * = nullptr) const;
383+
const SpecificIntrinsic * = nullptr,
384+
std::optional<std::string> *warning = nullptr) const;
383385

384386
llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
385387

‎flang/include/flang/Evaluate/tools.h

Lines changed: 11 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1082,11 +1082,12 @@ bool IsExpandableScalar(const Expr<T> &expr, FoldingContext &context,
10821082

10831083
// Common handling for procedure pointer compatibility of left- and right-hand
10841084
// sides. Returns nullopt if they're compatible. Otherwise, it returns a
1085-
// message that needs to be augmented by the names of the left and right sides
1085+
// message that needs to be augmented by the names of the left and right sides.
10861086
std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
10871087
const std::optional<characteristics::Procedure> &lhsProcedure,
10881088
const characteristics::Procedure *rhsProcedure,
1089-
const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible);
1089+
const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible,
1090+
std::optional<std::string> &warning);
10901091

10911092
// Scalar constant expansion
10921093
class ScalarConstantExpander {
@@ -1178,6 +1179,12 @@ class ArrayConstantBoundChanger {
11781179
ConstantSubscripts &&lbounds_;
11791180
};
11801181

1182+
// Predicate: should two expressions be considered identical for the purposes
1183+
// of determining whether two procedure interfaces are compatible, modulo
1184+
// naming of corresponding dummy arguments?
1185+
std::optional<bool> AreEquivalentInInterface(
1186+
const Expr<SubscriptInteger> &, const Expr<SubscriptInteger> &);
1187+
11811188
} // namespace Fortran::evaluate
11821189

11831190
namespace Fortran::semantics {
@@ -1254,6 +1261,8 @@ bool AreTkCompatibleTypes(const DeclTypeSpec *x, const DeclTypeSpec *y);
12541261

12551262
common::IgnoreTKRSet GetIgnoreTKR(const Symbol &);
12561263

1264+
std::optional<int> GetDummyArgumentNumber(const Symbol *);
1265+
12571266
} // namespace Fortran::semantics
12581267

12591268
#endif // FORTRAN_EVALUATE_TOOLS_H_

‎flang/lib/Evaluate/characteristics.cpp

Lines changed: 27 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -38,18 +38,23 @@ static void CopyAttrs(const semantics::Symbol &src, A &dst,
3838
// Shapes of function results and dummy arguments have to have
3939
// the same rank, the same deferred dimensions, and the same
4040
// values for explicit dimensions when constant.
41-
bool ShapesAreCompatible(const Shape &x, const Shape &y) {
41+
bool ShapesAreCompatible(
42+
const Shape &x, const Shape &y, bool *possibleWarning) {
4243
if (x.size() != y.size()) {
4344
return false;
4445
}
4546
auto yIter{y.begin()};
4647
for (const auto &xDim : x) {
4748
const auto &yDim{*yIter++};
48-
if (xDim) {
49-
if (!yDim || ToInt64(*xDim) != ToInt64(*yDim)) {
50-
return false;
49+
if (xDim && yDim) {
50+
if (auto equiv{AreEquivalentInInterface(*xDim, *yDim)}) {
51+
if (!*equiv) {
52+
return false;
53+
}
54+
} else if (possibleWarning) {
55+
*possibleWarning = true;
5156
}
52-
} else if (yDim) {
57+
} else if (xDim || yDim) {
5358
return false;
5459
}
5560
}
@@ -270,35 +275,19 @@ llvm::raw_ostream &TypeAndShape::Dump(llvm::raw_ostream &o) const {
270275
bool DummyDataObject::operator==(const DummyDataObject &that) const {
271276
return type == that.type && attrs == that.attrs && intent == that.intent &&
272277
coshape == that.coshape && cudaDataAttr == that.cudaDataAttr;
273-
;
274-
}
275-
276-
static bool AreCompatibleDummyDataObjectShapes(const Shape &x, const Shape &y) {
277-
int n{GetRank(x)};
278-
if (n != GetRank(y)) {
279-
return false;
280-
}
281-
auto xIter{x.begin()};
282-
auto yIter{y.begin()};
283-
for (; n-- > 0; ++xIter, ++yIter) {
284-
if (auto xVal{ToInt64(*xIter)}) {
285-
if (auto yVal{ToInt64(*yIter)}) {
286-
if (*xVal != *yVal) {
287-
return false;
288-
}
289-
}
290-
}
291-
}
292-
return true;
293278
}
294279

295-
bool DummyDataObject::IsCompatibleWith(
296-
const DummyDataObject &actual, std::string *whyNot) const {
297-
if (!AreCompatibleDummyDataObjectShapes(type.shape(), actual.type.shape())) {
280+
bool DummyDataObject::IsCompatibleWith(const DummyDataObject &actual,
281+
std::string *whyNot, std::optional<std::string> *warning) const {
282+
bool possibleWarning{false};
283+
if (!ShapesAreCompatible(
284+
type.shape(), actual.type.shape(), &possibleWarning)) {
298285
if (whyNot) {
299286
*whyNot = "incompatible dummy data object shapes";
300287
}
301288
return false;
289+
} else if (warning && possibleWarning) {
290+
*warning = "distinct dummy data object shapes";
302291
}
303292
// Treat deduced dummy character type as if it were assumed-length character
304293
// to avoid useless "implicit interfaces have distinct type" warnings from
@@ -748,11 +737,11 @@ bool DummyArgument::operator==(const DummyArgument &that) const {
748737
return u == that.u; // name and passed-object usage are not characteristics
749738
}
750739

751-
bool DummyArgument::IsCompatibleWith(
752-
const DummyArgument &actual, std::string *whyNot) const {
740+
bool DummyArgument::IsCompatibleWith(const DummyArgument &actual,
741+
std::string *whyNot, std::optional<std::string> *warning) const {
753742
if (const auto *ifaceData{std::get_if<DummyDataObject>(&u)}) {
754743
if (const auto *actualData{std::get_if<DummyDataObject>(&actual.u)}) {
755-
return ifaceData->IsCompatibleWith(*actualData, whyNot);
744+
return ifaceData->IsCompatibleWith(*actualData, whyNot, warning);
756745
}
757746
if (whyNot) {
758747
*whyNot = "one dummy argument is an object, the other is not";
@@ -1181,7 +1170,8 @@ bool Procedure::operator==(const Procedure &that) const {
11811170
}
11821171

11831172
bool Procedure::IsCompatibleWith(const Procedure &actual, std::string *whyNot,
1184-
const SpecificIntrinsic *specificIntrinsic) const {
1173+
const SpecificIntrinsic *specificIntrinsic,
1174+
std::optional<std::string> *warning) const {
11851175
// 15.5.2.9(1): if dummy is not pure, actual need not be.
11861176
// Ditto with elemental.
11871177
Attrs actualAttrs{actual.attrs};
@@ -1226,13 +1216,17 @@ bool Procedure::IsCompatibleWith(const Procedure &actual, std::string *whyNot,
12261216
// subroutine s1(base); subroutine s2(extended)
12271217
// procedure(s1), pointer :: p
12281218
// p => s2 ! an error, s2 is more restricted, can't handle "base"
1219+
std::optional<std::string> gotWarning;
12291220
if (!actual.dummyArguments[j].IsCompatibleWith(
1230-
dummyArguments[j], whyNot)) {
1221+
dummyArguments[j], whyNot, warning ? &gotWarning : nullptr)) {
12311222
if (whyNot) {
12321223
*whyNot = "incompatible dummy argument #"s + std::to_string(j + 1) +
12331224
": "s + *whyNot;
12341225
}
12351226
return false;
1227+
} else if (warning && !*warning && gotWarning) {
1228+
*warning = "possibly incompatible dummy argument #"s +
1229+
std::to_string(j + 1) + ": "s + std::move(*gotWarning);
12361230
}
12371231
}
12381232
return true;

‎flang/lib/Evaluate/tools.cpp

Lines changed: 100 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1082,7 +1082,8 @@ std::optional<std::string> FindImpureCall(
10821082
std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
10831083
const std::optional<characteristics::Procedure> &lhsProcedure,
10841084
const characteristics::Procedure *rhsProcedure,
1085-
const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible) {
1085+
const SpecificIntrinsic *specificIntrinsic, std::string &whyNotCompatible,
1086+
std::optional<std::string> &warning) {
10861087
std::optional<parser::MessageFixedText> msg;
10871088
if (!lhsProcedure) {
10881089
msg = "In assignment to object %s, the target '%s' is a procedure"
@@ -1096,8 +1097,8 @@ std::optional<parser::MessageFixedText> CheckProcCompatibility(bool isCall,
10961097
*rhsProcedure->functionResult, &whyNotCompatible)) {
10971098
msg =
10981099
"Function %s associated with incompatible function designator '%s': %s"_err_en_US;
1099-
} else if (lhsProcedure->IsCompatibleWith(
1100-
*rhsProcedure, &whyNotCompatible, specificIntrinsic)) {
1100+
} else if (lhsProcedure->IsCompatibleWith(*rhsProcedure, &whyNotCompatible,
1101+
specificIntrinsic, &warning)) {
11011102
// OK
11021103
} else if (isCall) {
11031104
msg = "Procedure %s associated with result of reference to function '%s'"
@@ -1275,6 +1276,83 @@ std::optional<Expr<SomeType>> HollerithToBOZ(FoldingContext &context,
12751276
}
12761277
}
12771278

1279+
// Extracts a whole symbol being used as a bound of a dummy argument,
1280+
// possibly wrapped with parentheses or MAX(0, ...).
1281+
template <int KIND>
1282+
static const Symbol *GetBoundSymbol(
1283+
const Expr<Type<TypeCategory::Integer, KIND>> &expr) {
1284+
using T = Type<TypeCategory::Integer, KIND>;
1285+
return common::visit(
1286+
common::visitors{
1287+
[](const Extremum<T> &max) -> const Symbol * {
1288+
if (max.ordering == Ordering::Greater) {
1289+
if (auto zero{ToInt64(max.left())}; zero && *zero == 0) {
1290+
return GetBoundSymbol(max.right());
1291+
}
1292+
}
1293+
return nullptr;
1294+
},
1295+
[](const Parentheses<T> &x) { return GetBoundSymbol(x.left()); },
1296+
[](const Designator<T> &x) -> const Symbol * {
1297+
if (const auto *ref{std::get_if<SymbolRef>(&x.u)}) {
1298+
return &**ref;
1299+
}
1300+
return nullptr;
1301+
},
1302+
[](const Convert<T, TypeCategory::Integer> &x) {
1303+
return common::visit(
1304+
[](const auto &y) -> const Symbol * {
1305+
using yType = std::decay_t<decltype(y)>;
1306+
using yResult = typename yType::Result;
1307+
if constexpr (yResult::kind <= KIND) {
1308+
return GetBoundSymbol(y);
1309+
} else {
1310+
return nullptr;
1311+
}
1312+
},
1313+
x.left().u);
1314+
},
1315+
[](const auto &) -> const Symbol * { return nullptr; },
1316+
},
1317+
expr.u);
1318+
}
1319+
1320+
std::optional<bool> AreEquivalentInInterface(
1321+
const Expr<SubscriptInteger> &x, const Expr<SubscriptInteger> &y) {
1322+
auto xVal{ToInt64(x)};
1323+
auto yVal{ToInt64(y)};
1324+
if (xVal && yVal) {
1325+
return *xVal == *yVal;
1326+
} else if (xVal || yVal) {
1327+
return false;
1328+
}
1329+
const Symbol *xSym{GetBoundSymbol(x)};
1330+
const Symbol *ySym{GetBoundSymbol(y)};
1331+
if (xSym && ySym) {
1332+
if (&xSym->GetUltimate() == &ySym->GetUltimate()) {
1333+
return true; // USE/host associated same symbol
1334+
}
1335+
auto xNum{semantics::GetDummyArgumentNumber(xSym)};
1336+
auto yNum{semantics::GetDummyArgumentNumber(ySym)};
1337+
if (xNum && yNum) {
1338+
if (*xNum == *yNum) {
1339+
auto xType{DynamicType::From(*xSym)};
1340+
auto yType{DynamicType::From(*ySym)};
1341+
return xType && yType && xType->IsEquivalentTo(*yType);
1342+
}
1343+
}
1344+
return false;
1345+
} else if (xSym || ySym) {
1346+
return false;
1347+
}
1348+
// Neither expression is an integer constant or a whole symbol.
1349+
if (x == y) {
1350+
return true;
1351+
} else {
1352+
return std::nullopt; // not sure
1353+
}
1354+
}
1355+
12781356
} // namespace Fortran::evaluate
12791357

12801358
namespace Fortran::semantics {
@@ -1788,4 +1866,23 @@ common::IgnoreTKRSet GetIgnoreTKR(const Symbol &symbol) {
17881866
return result;
17891867
}
17901868

1869+
std::optional<int> GetDummyArgumentNumber(const Symbol *symbol) {
1870+
if (symbol) {
1871+
if (IsDummy(*symbol)) {
1872+
if (const Symbol * subpSym{symbol->owner().symbol()}) {
1873+
if (const auto *subp{subpSym->detailsIf<SubprogramDetails>()}) {
1874+
int j{0};
1875+
for (const Symbol *dummy : subp->dummyArgs()) {
1876+
if (dummy == symbol) {
1877+
return j;
1878+
}
1879+
++j;
1880+
}
1881+
}
1882+
}
1883+
}
1884+
}
1885+
return std::nullopt;
1886+
}
1887+
17911888
} // namespace Fortran::semantics

‎flang/lib/Semantics/check-call.cpp

Lines changed: 20 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -968,7 +968,9 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
968968
}
969969
if (interface.HasExplicitInterface()) {
970970
std::string whyNot;
971-
if (!interface.IsCompatibleWith(argInterface, &whyNot)) {
971+
std::optional<std::string> warning;
972+
if (!interface.IsCompatibleWith(argInterface, &whyNot,
973+
/*specificIntrinsic=*/nullptr, &warning)) {
972974
// 15.5.2.9(1): Explicit interfaces must match
973975
if (argInterface.HasExplicitInterface()) {
974976
messages.Say(
@@ -985,6 +987,11 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
985987
"Actual procedure argument has an implicit interface which is not known to be compatible with %s which has an explicit interface"_warn_en_US,
986988
dummyName);
987989
}
990+
} else if (warning &&
991+
context.ShouldWarn(common::UsageWarning::ProcDummyArgShapes)) {
992+
messages.Say(
993+
"Actual procedure argument has possible interface incompatibility with %s: %s"_warn_en_US,
994+
dummyName, std::move(*warning));
988995
}
989996
} else { // 15.5.2.9(2,3)
990997
if (interface.IsSubroutine() && argInterface.IsFunction()) {
@@ -1348,16 +1355,25 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
13481355
*targetExpr, foldingContext)}) {
13491356
bool isCall{!!UnwrapProcedureRef(*targetExpr)};
13501357
std::string whyNot;
1358+
std::optional<std::string> warning;
13511359
const auto *targetProcDesignator{
13521360
evaluate::UnwrapExpr<evaluate::ProcedureDesignator>(
13531361
*targetExpr)};
13541362
const evaluate::SpecificIntrinsic *specificIntrinsic{
13551363
targetProcDesignator
13561364
? targetProcDesignator->GetSpecificIntrinsic()
13571365
: nullptr};
1358-
if (std::optional<parser::MessageFixedText> msg{
1359-
CheckProcCompatibility(isCall, pointerProc,
1360-
&*targetProc, specificIntrinsic, whyNot)}) {
1366+
std::optional<parser::MessageFixedText> msg{
1367+
CheckProcCompatibility(isCall, pointerProc, &*targetProc,
1368+
specificIntrinsic, whyNot, warning)};
1369+
if (!msg && warning &&
1370+
semanticsContext.ShouldWarn(
1371+
common::UsageWarning::ProcDummyArgShapes)) {
1372+
msg =
1373+
"Procedures '%s' and '%s' may not be completely compatible: %s"_warn_en_US;
1374+
whyNot = std::move(*warning);
1375+
}
1376+
if (msg) {
13611377
msg->set_severity(parser::Severity::Warning);
13621378
messages.Say(std::move(*msg),
13631379
"pointer '" + pointerExpr->AsFortran() + "'",

0 commit comments

Comments
 (0)