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 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; 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 u; @@ -278,6 +284,7 @@ struct FunctionResult { } void SetType(DynamicType t) { std::get(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) const; bool CanBeCalledViaImplicitInterface() const; bool CanOverride(const Procedure &, std::optional passIndex) const; + bool IsCompatibleWith(const Procedure &) const; + llvm::raw_ostream &Dump(llvm::raw_ostream &) const; std::optional 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(&u)}) { + const auto *actualData{std::get_if(&actual.u)}; + return actualData && ifaceData->IsCompatibleWith(*actualData); + } else if (const auto *ifaceProc{std::get_if(&u)}) { + const auto *actualProc{std::get_if(&actual.u)}; + return actualProc && ifaceProc->IsCompatibleWith(*actualProc); + } else { + return std::holds_alternative(u) && + std::holds_alternative(actual.u); + } +} + static std::optional 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(&u)}) { + if (const auto *actualTypeShape{std::get_if(&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>(&u)}; + if (const auto *actualProc{ + std::get_if>(&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 name) const { int argCount{static_cast(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