[flang] Warn about inconsistent implicit interfaces

[klausler]

Summary

When a global procedure has no explicit interface, emit warnings
when its references are inconsistent implicit procedure interfaces.

flang/include/flang/Evaluate/characteristics.h

struct DummyArgument {
   DummyArgument(std::string &&name, DummyProcedure &&x)
       : name{std::move(name)}, u{std::move(x)} {}
   explicit DummyArgument(AlternateReturn &&x) : u{std::move(x)} {}
   ~DummyArgument();
   bool operator==(const DummyArgument &) const;
   bool operator!=(const DummyArgument &that) const { return !(*this == that); }
   static std::optional<DummyArgument> FromActual(
       std::string &&, const Expr<SomeType> &, FoldingContext &);
+  static std::optional<DummyArgument> FromActual(
+      std::string &&, const ActualArgument &, FoldingContext &);
   bool IsOptional() const;
   void SetOptional(bool = true);
   common::Intent GetIntent() const;
   void SetIntent(common::Intent);
   bool CanBePassedViaImplicitInterface() const;
   bool IsTypelessIntrinsicDummy() const;
   bool IsCompatibleWith(
       const DummyArgument &, std::string *whyNot = nullptr) const;
struct Procedure {
   // "unrestricted specific intrinsic function".
   // Error messages are produced when a procedure cannot be characterized.
   static std::optional<Procedure> Characterize(
       const semantics::Symbol &, FoldingContext &);
   static std::optional<Procedure> Characterize(
       const ProcedureDesignator &, FoldingContext &);
   static std::optional<Procedure> 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<Procedure> 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.
   bool IsFunction() const { return functionResult.has_value(); }
   bool IsSubroutine() const { return attrs.test(Attr::Subroutine); }
 
   bool IsPure() const { return attrs.test(Attr::Pure); }
   bool IsElemental() const { return attrs.test(Attr::Elemental); }

flang/include/flang/Semantics/expression.h

private:
   bool CheckIsValidForwardReference(const semantics::DerivedTypeSpec &);
   MaybeExpr AnalyzeComplex(MaybeExpr &&re, MaybeExpr &&im, const char *what);
 
   MaybeExpr IterativelyAnalyzeSubexpressions(const parser::Expr &);
 
   semantics::SemanticsContext &context_;
   FoldingContext &foldingContext_{context_.foldingContext()};
   std::map<parser::CharBlock, int> impliedDos_; // values are INTEGER kinds
+  std::map<parser::CharBlock,
+      std::pair<parser::CharBlock, evaluate::characteristics::Procedure>>
+      implicitInterfaces_;
   bool isWholeAssumedSizeArrayOk_{false};
   bool isNullPointerOk_{false};
   bool useSavedTypedExprs_{true};
   bool inWhereBody_{false};
   bool inDataStmtObject_{false};
   bool inDataStmtConstant_{false};
   bool inStmtFunctionDefinition_{false};
   bool iterativelyAnalyzingSubexpressions_{false};

flang/lib/Evaluate/characteristics.cpp

return common::visit(
             } else {
               return std::optional<DummyArgument>{};
             }
           },
       },
       expr.u);
 }
 
+std::optional<DummyArgument> 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{
           [](const DummyDataObject &data) {
             return data.attrs.test(DummyDataObject::Attr::Optional);
           },
           [](const DummyProcedure &proc) {
             return proc.attrs.test(DummyProcedure::Attr::Optional);
if (callee->functionResult) {
           proc{callee->functionResult->IsProcedurePointer()}) {
         return {*proc};
       }
     }
   }
   return std::nullopt;
 }
 
+std::optional<Procedure> 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)) {
     return false; // 15.4.2.2(5,6)
   } else if (IsFunction() &&
       !functionResult->CanBeReturnedViaImplicitInterface()) {
     return false;
   } else {

flang/lib/Semantics/expression.cpp

static bool IsExternalCalledImplicitly(
   }
 }
 
 std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
     parser::CharBlock callSite, const ProcedureDesignator &proc,
     ActualArguments &arguments) {
   bool treatExternalAsImplicit{IsExternalCalledImplicitly(callSite, proc)};
   const Symbol *procSymbol{proc.GetSymbol()};
-  auto chars{characteristics::Procedure::Characterize(
-      proc, context_.foldingContext())};
+  std::optional<characteristics::Procedure> chars;
+  if (procSymbol && procSymbol->has<semantics::ProcEntityDetails>() &&
+      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()) {
       Say(callSite,
           "References to the procedure '%s' require an explicit interface"_err_en_US,
           DEREF(procSymbol).name());
     }
     const SpecificIntrinsic *specificIntrinsic{proc.GetSpecificIntrinsic()};

flang/test/Semantics/bad-forward-type.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 ! Forward references to derived types (error cases)
 ! C732 A parent-type-name shall be the name of a previously defined
 ! extensible type (7.5.7).
 
 !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'
 type(pdt(bad=1)) function f5()
   type :: pdt(good)
     integer, kind :: good = kind(0)
     integer(kind=good) :: n
   end type

flang/test/Semantics/call35.f90

+! 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

flang/test/Semantics/reshape.f90

type :: dType
     integer :: field(2)
   end type dType
   type(dType), parameter :: array19(*) = [dType::dType(field=[1,2])]
   logical, parameter :: lVar = all(array19(:)%field(1) == [2])
 
   !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
   array20 = RESHAPE([(n, n = 1, 4)], [2, 3], order = bad_order)
 end program reshaper