[flang-commits] [flang] 3bfe907 - [flang] Remove bogus messages for actual/dummy procedure argument compatibility
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Wed Mar 2 16:00:43 PST 2022
Author: Peter Klausler
Date: 2022-03-02T16:00:36-08:00
New Revision: 3bfe90748e812883d03f7b41f6199d73479179fc
URL: https://github.com/llvm/llvm-project/commit/3bfe90748e812883d03f7b41f6199d73479179fc
DIFF: https://github.com/llvm/llvm-project/commit/3bfe90748e812883d03f7b41f6199d73479179fc.diff
LOG: [flang] Remove bogus messages for actual/dummy procedure argument compatibility
Add new IsCompatibleWith() member functions to many classes in evaluate::characteristics
that apply more nuanced compatibility checking for function results, dummy
arguments, and procedure interfaces than the previous tests for complete
equivalence. Use IsCompatibleWith() in semantics for call checking.
Differential Revision: https://reviews.llvm.org/D120844
Added:
flang/test/Semantics/call25.f90
Modified:
flang/include/flang/Evaluate/characteristics.h
flang/lib/Evaluate/characteristics.cpp
flang/lib/Semantics/check-call.cpp
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 4c9f94652859b..3bd11dae57252 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -190,6 +190,7 @@ struct DummyDataObject {
bool operator!=(const DummyDataObject &that) const {
return !(*this == that);
}
+ bool IsCompatibleWith(const DummyDataObject &) const;
static std::optional<DummyDataObject> Characterize(
const semantics::Symbol &, FoldingContext &);
bool CanBePassedViaImplicitInterface() const;
@@ -208,7 +209,9 @@ struct DummyProcedure {
explicit DummyProcedure(Procedure &&);
bool operator==(const DummyProcedure &) const;
bool operator!=(const DummyProcedure &that) const { return !(*this == that); }
+ bool IsCompatibleWith(const DummyProcedure &) const;
llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
+
CopyableIndirection<Procedure> procedure;
common::Intent intent{common::Intent::Default};
Attrs attrs;
@@ -240,9 +243,12 @@ struct DummyArgument {
void SetIntent(common::Intent);
bool CanBePassedViaImplicitInterface() const;
bool IsTypelessIntrinsicDummy() const;
+ bool IsCompatibleWith(const DummyArgument &) const;
llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
- // name and pass are not characteristics and so does not participate in
- // operator== but are needed to determine if procedures are distinguishable
+
+ // name and pass are not characteristics and so do not participate in
+ // compatibility checks, but they are needed to determine whether
+ // procedures are distinguishable
std::string name;
bool pass{false}; // is this the PASS argument of its procedure
std::variant<DummyDataObject, DummyProcedure, AlternateReturn> u;
@@ -278,6 +284,7 @@ struct FunctionResult {
}
void SetType(DynamicType t) { std::get<TypeAndShape>(u).set_type(t); }
bool CanBeReturnedViaImplicitInterface() const;
+ bool IsCompatibleWith(const FunctionResult &) const;
llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
@@ -322,6 +329,8 @@ struct Procedure {
int FindPassIndex(std::optional<parser::CharBlock>) const;
bool CanBeCalledViaImplicitInterface() const;
bool CanOverride(const Procedure &, std::optional<int> passIndex) const;
+ bool IsCompatibleWith(const Procedure &) const;
+
llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
std::optional<FunctionResult> functionResult;
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 40263f6fc5517..b0a130d278530 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -254,6 +254,13 @@ bool DummyDataObject::operator==(const DummyDataObject &that) const {
coshape == that.coshape;
}
+bool DummyDataObject::IsCompatibleWith(const DummyDataObject &actual) const {
+ return type.shape() == actual.type.shape() &&
+ type.type().IsTkCompatibleWith(actual.type.type()) &&
+ attrs == actual.attrs && intent == actual.intent &&
+ coshape == actual.coshape;
+}
+
static common::Intent GetIntent(const semantics::Attrs &attrs) {
if (attrs.test(semantics::Attr::INTENT_IN)) {
return common::Intent::In;
@@ -336,6 +343,11 @@ bool DummyProcedure::operator==(const DummyProcedure &that) const {
procedure.value() == that.procedure.value();
}
+bool DummyProcedure::IsCompatibleWith(const DummyProcedure &actual) const {
+ return attrs == actual.attrs && intent == actual.intent &&
+ procedure.value().IsCompatibleWith(actual.procedure.value());
+}
+
static std::string GetSeenProcs(
const semantics::UnorderedSymbolSet &seenProcs) {
// Sort the symbols so that they appear in the same order on all platforms
@@ -535,6 +547,19 @@ 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) const {
+ if (const auto *ifaceData{std::get_if<DummyDataObject>(&u)}) {
+ const auto *actualData{std::get_if<DummyDataObject>(&actual.u)};
+ return actualData && ifaceData->IsCompatibleWith(*actualData);
+ } else if (const auto *ifaceProc{std::get_if<DummyProcedure>(&u)}) {
+ const auto *actualProc{std::get_if<DummyProcedure>(&actual.u)};
+ return actualProc && ifaceProc->IsCompatibleWith(*actualProc);
+ } else {
+ return std::holds_alternative<AlternateReturn>(u) &&
+ std::holds_alternative<AlternateReturn>(actual.u);
+ }
+}
+
static std::optional<DummyArgument> CharacterizeDummyArgument(
const semantics::Symbol &symbol, FoldingContext &context,
semantics::UnorderedSymbolSet &seenProcs) {
@@ -744,6 +769,33 @@ bool FunctionResult::CanBeReturnedViaImplicitInterface() const {
}
}
+bool FunctionResult::IsCompatibleWith(const FunctionResult &actual) const {
+ Attrs actualAttrs{actual.attrs};
+ actualAttrs.reset(Attr::Contiguous);
+ if (attrs != actualAttrs) {
+ return false;
+ } else if (const auto *ifaceTypeShape{std::get_if<TypeAndShape>(&u)}) {
+ if (const auto *actualTypeShape{std::get_if<TypeAndShape>(&actual.u)}) {
+ if (ifaceTypeShape->shape() != actualTypeShape->shape()) {
+ return false;
+ } else {
+ return ifaceTypeShape->type().IsTkCompatibleWith(
+ actualTypeShape->type());
+ }
+ } else {
+ return false;
+ }
+ } else {
+ const auto *ifaceProc{std::get_if<CopyableIndirection<Procedure>>(&u)};
+ if (const auto *actualProc{
+ std::get_if<CopyableIndirection<Procedure>>(&actual.u)}) {
+ return ifaceProc->value().IsCompatibleWith(actualProc->value());
+ } else {
+ return false;
+ }
+ }
+}
+
llvm::raw_ostream &FunctionResult::Dump(llvm::raw_ostream &o) const {
attrs.Dump(o, EnumToString);
std::visit(common::visitors{
@@ -768,6 +820,31 @@ bool Procedure::operator==(const Procedure &that) const {
dummyArguments == that.dummyArguments;
}
+bool Procedure::IsCompatibleWith(const Procedure &actual) const {
+ // 15.5.2.9(1): if dummy is not pure, actual need not be.
+ Attrs actualAttrs{actual.attrs};
+ if (!attrs.test(Attr::Pure)) {
+ actualAttrs.reset(Attr::Pure);
+ }
+ if (attrs != actualAttrs) {
+ return false;
+ } else if (IsFunction() != actual.IsFunction()) {
+ return false;
+ } else if (IsFunction() &&
+ !functionResult->IsCompatibleWith(*actual.functionResult)) {
+ return false;
+ } else if (dummyArguments.size() != actual.dummyArguments.size()) {
+ return false;
+ } else {
+ for (std::size_t j{0}; j < dummyArguments.size(); ++j) {
+ if (!dummyArguments[j].IsCompatibleWith(actual.dummyArguments[j])) {
+ return false;
+ }
+ }
+ return true;
+ }
+}
+
int Procedure::FindPassIndex(std::optional<parser::CharBlock> name) const {
int argCount{static_cast<int>(dummyArguments.size())};
int index{0};
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index d55efa84a11b1..c942bb3d0b973 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -561,12 +561,8 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
characteristics::Procedure::Attr::NullPointer);
}
}
- if (!interface.IsPure()) {
- // 15.5.2.9(1): if dummy is not pure, actual need not be.
- argInterface.attrs.reset(characteristics::Procedure::Attr::Pure);
- }
if (interface.HasExplicitInterface()) {
- if (interface != argInterface) {
+ if (!interface.IsCompatibleWith(argInterface)) {
// 15.5.2.9(1): Explicit interfaces must match
if (argInterface.HasExplicitInterface()) {
messages.Say(
@@ -592,7 +588,8 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
dummyName);
} else if (interface.IsFunction()) {
if (argInterface.IsFunction()) {
- if (interface.functionResult != argInterface.functionResult) {
+ if (!interface.functionResult->IsCompatibleWith(
+ *argInterface.functionResult)) {
messages.Say(
"Actual argument function associated with procedure %s has incompatible result type"_err_en_US,
dummyName);
@@ -626,7 +623,7 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
const Symbol *last{GetLastSymbol(*expr)};
if (!(last && IsProcedurePointer(*last))) {
// 15.5.2.9(5) -- dummy procedure POINTER
- // Interface compatibility has already been checked above by comparison.
+ // Interface compatibility has already been checked above
messages.Say(
"Actual argument associated with procedure pointer %s must be a POINTER unless INTENT(IN)"_err_en_US,
dummyName);
diff --git a/flang/test/Semantics/call25.f90 b/flang/test/Semantics/call25.f90
new file mode 100644
index 0000000000000..746c40263bd7b
--- /dev/null
+++ b/flang/test/Semantics/call25.f90
@@ -0,0 +1,49 @@
+! RUN: not %flang -fsyntax-only 2>&1 %s | FileCheck %s
+module m
+ contains
+ subroutine subr1(f)
+ character(5) f
+ print *, f('abcde')
+ end subroutine
+ subroutine subr2(f)
+ character(*) f
+ print *, f('abcde')
+ end subroutine
+ character(5) function explicitLength(x)
+ character(5), intent(in) :: x
+ explicitLength = x
+ end function
+ real function notChar(x)
+ character(*), intent(in) :: x
+ notChar = 0
+ end function
+end module
+
+character(*) function assumedLength(x)
+ character(*), intent(in) :: x
+ assumedLength = x
+end function
+
+subroutine subr3(f)
+ character(5) f
+ print *, f('abcde')
+end subroutine
+
+program main
+ use m
+ external assumedlength
+ character(5) :: assumedlength
+ call subr1(explicitLength)
+ call subr1(assumedLength)
+ !CHECK: error: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
+ call subr1(notChar)
+ call subr2(explicitLength)
+ call subr2(assumedLength)
+ !CHECK: error: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
+ call subr2(notChar)
+ call subr3(explicitLength)
+ call subr3(assumedLength)
+ !CHECK: Warning: if the procedure's interface were explicit, this reference would be in error:
+ !CHECK: Actual argument function associated with procedure dummy argument 'f=' has incompatible result type
+ call subr3(notChar)
+end program
More information about the flang-commits
mailing list