Index: flang/include/flang/Evaluate/characteristics.h =================================================================== --- flang/include/flang/Evaluate/characteristics.h +++ flang/include/flang/Evaluate/characteristics.h @@ -259,6 +259,8 @@ bool operator!=(const DummyArgument &that) const { return !(*this == that); } static std::optional FromActual( std::string &&, const Expr &, FoldingContext &); + static std::optional FromActual( + std::string &&, const ActualArgument &, FoldingContext &); bool IsOptional() const; void SetOptional(bool = true); common::Intent GetIntent() const; @@ -338,6 +340,10 @@ const ProcedureDesignator &, FoldingContext &); static std::optional Characterize( const ProcedureRef &, FoldingContext &); + // Characterizes the procedure being referenced, deducing dummy argument + // types from actual arguments in the case of an implicit interface. + static std::optional FromActuals( + const ProcedureDesignator &, const ActualArguments &, FoldingContext &); // At most one of these will return true. // For "EXTERNAL P" with no type for or calls to P, both will be false. Index: flang/include/flang/Semantics/expression.h =================================================================== --- flang/include/flang/Semantics/expression.h +++ flang/include/flang/Semantics/expression.h @@ -386,6 +386,9 @@ semantics::SemanticsContext &context_; FoldingContext &foldingContext_{context_.foldingContext()}; std::map impliedDos_; // values are INTEGER kinds + std::map> + implicitInterfaces_; bool isWholeAssumedSizeArrayOk_{false}; bool isNullPointerOk_{false}; bool useSavedTypedExprs_{true}; Index: flang/lib/Evaluate/characteristics.cpp =================================================================== --- flang/lib/Evaluate/characteristics.cpp +++ flang/lib/Evaluate/characteristics.cpp @@ -724,6 +724,17 @@ expr.u); } +std::optional DummyArgument::FromActual( + std::string &&name, const ActualArgument &arg, FoldingContext &context) { + if (const auto *expr{arg.UnwrapExpr()}) { + return FromActual(std::move(name), *expr, context); + } else if (arg.GetAssumedTypeDummy()) { + return std::nullopt; + } else { + return DummyArgument{AlternateReturn{}}; + } +} + bool DummyArgument::IsOptional() const { return common::visit( common::visitors{ @@ -1107,6 +1118,30 @@ return std::nullopt; } +std::optional Procedure::FromActuals(const ProcedureDesignator &proc, + const ActualArguments &args, FoldingContext &context) { + auto callee{Characterize(proc, context)}; + if (callee) { + if (callee->dummyArguments.empty() && + callee->attrs.test(Procedure::Attr::ImplicitInterface)) { + int j{0}; + for (const auto &arg : args) { + ++j; + if (arg) { + if (auto dummy{DummyArgument::FromActual( + "x"s + std::to_string(j), *arg, context)}) { + callee->dummyArguments.emplace_back(std::move(*dummy)); + continue; + } + } + callee.reset(); + break; + } + } + } + return callee; +} + bool Procedure::CanBeCalledViaImplicitInterface() const { // TODO: Pass back information on why we return false if (attrs.test(Attr::Elemental) || attrs.test(Attr::BindC)) { Index: flang/lib/Semantics/expression.cpp =================================================================== --- flang/lib/Semantics/expression.cpp +++ flang/lib/Semantics/expression.cpp @@ -2877,8 +2877,38 @@ ActualArguments &arguments) { bool treatExternalAsImplicit{IsExternalCalledImplicitly(callSite, proc)}; const Symbol *procSymbol{proc.GetSymbol()}; - auto chars{characteristics::Procedure::Characterize( - proc, context_.foldingContext())}; + std::optional chars; + if (procSymbol && procSymbol->has() && + procSymbol->owner().IsGlobal()) { + // Unknown global external, implicit interface; assume + // characteristics from the actual arguments, and check + // for consistency with other references. + chars = characteristics::Procedure::FromActuals( + proc, arguments, context_.foldingContext()); + if (chars && procSymbol) { + // Ensure calls over implicit interfaces are consistent + auto name{procSymbol->name()}; + if (auto iter{implicitInterfaces_.find(name)}; + iter != implicitInterfaces_.end()) { + std::string whyNot; + if (!chars->IsCompatibleWith(iter->second.second, &whyNot)) { + if (auto *msg{Say(callSite, + "Reference to the procedure '%s' has an implicit interface that is distinct from another reference: %s"_warn_en_US, + name, whyNot)}) { + msg->Attach( + iter->second.first, "previous reference to '%s'"_en_US, name); + } + } + } else { + implicitInterfaces_.insert( + std::make_pair(name, std::make_pair(callSite, *chars))); + } + } + } + if (!chars) { + chars = characteristics::Procedure::Characterize( + proc, context_.foldingContext()); + } bool ok{true}; if (chars) { if (treatExternalAsImplicit && !chars->CanBeCalledViaImplicitInterface()) { Index: flang/test/Semantics/bad-forward-type.f90 =================================================================== --- flang/test/Semantics/bad-forward-type.f90 +++ flang/test/Semantics/bad-forward-type.f90 @@ -5,22 +5,22 @@ !ERROR: The derived type 'undef' was forward-referenced but not defined type(undef) function f1() - call sub(f1) + call sub1(f1) end function !ERROR: The derived type 'undef' was forward-referenced but not defined type(undef) function f2() result(r) - call sub(r) + call sub2(r) end function !ERROR: The derived type 'undefpdt' was forward-referenced but not defined type(undefpdt(1)) function f3() - call sub(f3) + call sub3(f3) end function !ERROR: The derived type 'undefpdt' was forward-referenced but not defined type(undefpdt(1)) function f4() result(r) - call sub(f4) + call sub4(f4) end function !ERROR: 'bad' is not the name of a parameter for derived type 'pdt' Index: flang/test/Semantics/call35.f90 =================================================================== --- /dev/null +++ flang/test/Semantics/call35.f90 @@ -0,0 +1,21 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 -Werror +subroutine s1 + call ext(1, 2) +end + +subroutine s2 + !WARNING: Reference to the procedure 'ext' has an implicit interface that is distinct from another reference: distinct numbers of dummy arguments + call ext(1.) +end + +subroutine s3 + interface + !WARNING: The global subprogram 'ext' is not compatible with its local procedure declaration (incompatible procedure attributes: ImplicitInterface) + subroutine ext(n) + integer n + end + end interface + call ext(3) + !ERROR: Actual argument type 'REAL(4)' is not compatible with dummy argument type 'INTEGER(4)' + call ext(4.) +end Index: flang/test/Semantics/reshape.f90 =================================================================== --- flang/test/Semantics/reshape.f90 +++ flang/test/Semantics/reshape.f90 @@ -47,6 +47,7 @@ !ERROR: Size of 'shape=' argument must not be greater than 15 CALL ext_sub(RESHAPE([(n, n=1,20)], & [1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1])) + !WARNING: Reference to the procedure 'ext_sub' has an implicit interface that is distinct from another reference: incompatible dummy argument #1: incompatible dummy data object shapes !ERROR: 'shape=' argument must not have a negative extent CALL ext_sub(RESHAPE([(n, n=1,20)], [1, -5, 3])) !ERROR: 'order=' argument has unacceptable rank 2