[flang] Handle type-bound user-defined operators

Pre-review clean-up

Original-commit: flang-compiler/f18@1d4e85563a
Reviewed-on: https://github.com/flang-compiler/f18/pull/901

flang/lib/parser/message.cc

@@ -126,7 +126,7 @@ bool Message::SortBefore(const Message &that) const {
   // Messages from prescanning have ProvenanceRange values for their locations,
   // while messages from later phases have CharBlock values, since the
   // conversion of cooked source stream locations to provenances is not
-  // free and needs to be deferred, since many messages created during parsing
+  // free and needs to be deferred, and many messages created during parsing
   // are speculative.  Messages with ProvenanceRange locations are ordered
   // before others for sorting.
   return std::visit(

flang/lib/semantics/expression.cc

@@ -131,6 +131,8 @@ common::IfNoLvalue<MaybeExpr, WRAPPED> TypedWrapper(
 class ArgumentAnalyzer {
 public:
   explicit ArgumentAnalyzer(ExpressionAnalyzer &context) : context_{context} {}
+  ArgumentAnalyzer(ExpressionAnalyzer &context, parser::CharBlock source)
+    : context_{context}, source_{source} {}
   bool fatalErrors() const { return fatalErrors_; }
   ActualArguments &&GetActuals() {
     CHECK(!fatalErrors_);
@@ -159,7 +161,8 @@ public:
 
   // Find and return a user-defined operator or report an error.
   // The provided message is used if there is no such operator.
-  MaybeExpr TryDefinedOp(const char *, parser::MessageFixedText &&);
+  MaybeExpr TryDefinedOp(
+      const char *, parser::MessageFixedText &&, bool isUserOp = false);
   template<typename E>
   MaybeExpr TryDefinedOp(E opr, parser::MessageFixedText &&msg) {
     return TryDefinedOp(
@@ -1843,7 +1846,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::FunctionReference &funcRef,
     std::optional<parser::StructureConstructor> *structureConstructor) {
   const parser::Call &call{funcRef.v};
   auto restorer{GetContextualMessages().SetLocation(call.source)};
-  ArgumentAnalyzer analyzer{*this};
+  ArgumentAnalyzer analyzer{*this, call.source};
   for (const auto &arg : std::get<std::list<parser::ActualArgSpec>>(call.t)) {
     analyzer.Analyze(arg, false /* not subroutine call */);
   }
@@ -1882,7 +1885,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::FunctionReference &funcRef,
 void ExpressionAnalyzer::Analyze(const parser::CallStmt &callStmt) {
   const parser::Call &call{callStmt.v};
   auto restorer{GetContextualMessages().SetLocation(call.source)};
-  ArgumentAnalyzer analyzer{*this};
+  ArgumentAnalyzer analyzer{*this, call.source};
   for (const auto &arg : std::get<std::list<parser::ActualArgSpec>>(call.t)) {
     analyzer.Analyze(arg, true /* is subroutine call */);
   }
@@ -2032,18 +2035,12 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::PercentLoc &x) {
 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::DefinedUnary &x) {
   const auto &name{std::get<parser::DefinedOpName>(x.t).v};
-  ArgumentAnalyzer analyzer{*this};
+  ArgumentAnalyzer analyzer{*this, name.source};
   analyzer.Analyze(std::get<1>(x.t));
-  if (!analyzer.fatalErrors()) {
-    if (auto callee{GetCalleeAndArguments(name, analyzer.GetActuals())}) {
-      CHECK(std::holds_alternative<ProcedureDesignator>(callee->u));
-      return MakeFunctionRef(name.source,
-          std::move(std::get<ProcedureDesignator>(callee->u)),
-          std::move(callee->arguments));
-    }
-  }
-  return std::nullopt;
+  return analyzer.TryDefinedOp(name.source.ToString().c_str(),
+      "No operator %s defined for %s"_err_en_US, true);
 }
+
 // Binary (dyadic) operations
 
 template<template<typename> class OPR>
@@ -2209,18 +2206,11 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NEQV &x) {
 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::DefinedBinary &x) {
   const auto &name{std::get<parser::DefinedOpName>(x.t).v};
-  ArgumentAnalyzer analyzer{*this};
+  ArgumentAnalyzer analyzer{*this, name.source};
   analyzer.Analyze(std::get<1>(x.t));
   analyzer.Analyze(std::get<2>(x.t));
-  if (!analyzer.fatalErrors()) {
-    if (auto callee{GetCalleeAndArguments(name, analyzer.GetActuals())}) {
-      CHECK(std::holds_alternative<ProcedureDesignator>(callee->u));
-      return MakeFunctionRef(name.source,
-          std::move(std::get<ProcedureDesignator>(callee->u)),
-          std::move(callee->arguments));
-    }
-  }
-  return std::nullopt;
+  return analyzer.TryDefinedOp(name.source.ToString().c_str(),
+      "No operator %s defined for %s and %s"_err_en_US, true);
 }
 
 static void CheckFuncRefToArrayElementRefHasSubscripts(
@@ -2604,7 +2594,7 @@ bool ArgumentAnalyzer::IsIntrinsicConcat() const {
 }
 
 MaybeExpr ArgumentAnalyzer::TryDefinedOp(
-    const char *opr, parser::MessageFixedText &&error) {
+    const char *opr, parser::MessageFixedText &&error, bool isUserOp) {
   if (AnyUntypedOperand()) {
     context_.Say(
         std::move(error), ToUpperCase(opr), TypeAsFortran(0), TypeAsFortran(1));
@@ -2612,11 +2602,12 @@ MaybeExpr ArgumentAnalyzer::TryDefinedOp(
   }
   {
     auto restorer{context_.GetContextualMessages().DiscardMessages()};
-    std::string oprNameString{"operator("s + opr + ')'};
+    std::string oprNameString{
+        isUserOp ? std::string{opr} : "operator("s + opr + ')'};
     parser::CharBlock oprName{oprNameString};
     const auto &scope{context_.context().FindScope(source_)};
     if (Symbol * symbol{scope.FindSymbol(oprName)}) {
-      parser::Name name{source_, symbol};
+      parser::Name name{symbol->name(), symbol};
       if (auto result{context_.AnalyzeDefinedOp(name, GetActuals())}) {
         return result;
       }
@@ -2656,10 +2647,10 @@ MaybeExpr ArgumentAnalyzer::TryDefinedOp(
 
 MaybeExpr ArgumentAnalyzer::TryBoundOp(const Symbol &symbol, int passIndex) {
   ActualArguments localActuals{actuals_};
-  const auto *proc{GetBindingResolution(GetType(passIndex), symbol)};
+  const Symbol *proc{GetBindingResolution(GetType(passIndex), symbol)};
   if (!proc) {
     proc = &symbol;
-    localActuals[passIndex]->set_isPassedObject();
+    localActuals.at(passIndex).value().set_isPassedObject();
   }
   return context_.MakeFunctionRef(
       source_, ProcedureDesignator{*proc}, std::move(localActuals));
@@ -2768,7 +2759,7 @@ const Symbol *ArgumentAnalyzer::FindBoundOp(
   if (!type || !type->scope()) {
     return nullptr;
   }
-  const Symbol *symbol{type->scope()->FindSymbol(oprName)};
+  const Symbol *symbol{type->scope()->FindComponent(oprName)};
   if (!symbol) {
     return nullptr;
   }

flang/lib/semantics/resolve-names.cc

@@ -5794,7 +5794,8 @@ bool ResolveNamesVisitor::Pre(const parser::DefinedOpName &x) {
     Say(name,
         "Logical constant '%s' may not be used as a defined operator"_err_en_US);
   } else {
-    Say(name, "Defined operator '%s' not found"_err_en_US);
+    // Resolved later in expression semantics
+    MakePlaceholder(name, MiscDetails::Kind::TypeBoundDefinedOp);
   }
   return false;
 }

flang/lib/semantics/semantics.cc

@@ -194,7 +194,7 @@ Scope &SemanticsContext::FindScope(parser::CharBlock source) {
   if (auto *scope{globalScope_.FindScope(source)}) {
     return *scope;
   } else {
-    common::die("invalid source location");
+    common::die("SemanticsContext::FindScope(): invalid source location");
   }
 }
 

flang/lib/semantics/symbol.h

@@ -299,8 +299,8 @@ class FinalProcDetails {};  // TODO
 class MiscDetails {
 public:
   ENUM_CLASS(Kind, None, ConstructName, ScopeName, PassName, ComplexPartRe,
-      ComplexPartIm, KindParamInquiry, LenParamInquiry,
-      SelectTypeAssociateName);
+      ComplexPartIm, KindParamInquiry, LenParamInquiry, SelectTypeAssociateName,
+      TypeBoundDefinedOp);
   MiscDetails(Kind kind) : kind_{kind} {}
   Kind kind() const { return kind_; }
 

flang/lib/semantics/tools.cc

@@ -149,8 +149,14 @@ bool IsIntrinsicConcat(const evaluate::DynamicType &type0, int rank0,
 }
 
 bool IsGenericDefinedOp(const Symbol &symbol) {
-  const auto *details{symbol.GetUltimate().detailsIf<GenericDetails>()};
-  return details && details->kind().IsDefinedOperator();
+  const Symbol &ultimate{symbol.GetUltimate()};
+  if (const auto *generic{ultimate.detailsIf<GenericDetails>()}) {
+    return generic->kind().IsDefinedOperator();
+  } else if (const auto *misc{ultimate.detailsIf<MiscDetails>()}) {
+    return misc->kind() == MiscDetails::Kind::TypeBoundDefinedOp;
+  } else {
+    return false;
+  }
 }
 
 bool IsCommonBlockContaining(const Symbol &block, const Symbol &object) {

flang/test/semantics/modfile35.f90

@@ -149,3 +149,102 @@ end
 !  real(4) :: a(1_8:y%p2(x))
 ! end
 !end
+
+module m3
+  type :: t1
+  contains
+    procedure, pass(x) :: p1 => f1
+    procedure :: p3 => f3
+    generic :: operator(.binary.) => p1
+    generic :: operator(.unary.) => p3
+  end type
+  type, extends(t1) :: t2
+  contains
+    procedure, pass(y) :: p2 => f2
+    generic :: operator(.binary.) => p2
+  end type
+contains
+  integer(8) pure function f1(x, y)
+    class(t1), intent(in) :: x
+    integer, intent(in) :: y
+  end
+  integer(8) pure function f2(x, y)
+    class(t1), intent(in) :: x
+    class(t2), intent(in) :: y
+  end
+  integer(8) pure function f3(x)
+    class(t1), intent(in) :: x
+  end
+  subroutine test1(x, y, a)
+    class(t1) :: x
+    integer :: y
+    real :: a(x .binary. y)
+  end
+  ! Resolve to operator in parent class
+  subroutine test2(x, y, a)
+    class(t2) :: x
+    integer :: y
+    real :: a(x .binary. y)
+  end
+  ! 2nd arg is passed object
+  subroutine test3(x, y, a)
+    class(t1) :: x
+    class(t2) :: y
+    real :: a(x .binary. y)
+  end
+  subroutine test4(x, y, a)
+    class(t1) :: x
+    class(t2) :: y
+    real :: a(.unary. x + .unary. y)
+  end
+end
+!Expect: m3.mod
+!module m3
+!  type::t1
+!  contains
+!    procedure,pass(x)::p1=>f1
+!    procedure::p3=>f3
+!    generic::.binary.=>p1
+!    generic::.unary.=>p3
+!  end type
+!  type,extends(t1)::t2
+!  contains
+!    procedure,pass(y)::p2=>f2
+!    generic::.binary.=>p2
+!  end type
+!contains
+!  pure function f1(x,y)
+!    class(t1),intent(in)::x
+!    integer(4),intent(in)::y
+!    integer(8)::f1
+!  end
+!  pure function f2(x,y)
+!    class(t1),intent(in)::x
+!    class(t2),intent(in)::y
+!    integer(8)::f2
+!  end
+!  pure function f3(x)
+!    class(t1),intent(in)::x
+!    integer(8)::f3
+!  end
+!  subroutine test1(x,y,a)
+!    class(t1)::x
+!    integer(4)::y
+!    real(4)::a(1_8:x%p1(y))
+!  end
+!  subroutine test2(x,y,a)
+!    class(t2)::x
+!    integer(4)::y
+!    real(4)::a(1_8:x%p1(y))
+!  end
+!  subroutine test3(x,y,a)
+!    class(t1)::x
+!    class(t2)::y
+!    real(4)::a(1_8:y%p2(x))
+!  end
+!  subroutine test4(x,y,a)
+!    class(t1)::x
+!    class(t2)::y
+!    real(4)::a(1_8:x%p3()+y%p3())
+!  end
+!end

flang/test/semantics/resolve62.f90

@@ -43,7 +43,7 @@ subroutine s3
   logical :: a, b, c
   x = y .foo. z  ! OK: f_real
   i = j .foo. k  ! OK: f_integer
-  !ERROR: No specific procedure of generic operator '.foo.' matches the actual arguments
+  !ERROR: No intrinsic or user-defined .FOO. matches operand types LOGICAL(4) and LOGICAL(4)
   a = b .foo. c
 end
 

flang/test/semantics/resolve63.f90

@@ -157,15 +157,15 @@ contains
   subroutine s1(x, y, z)
     logical :: x
     real :: y, z
-    !ERROR: Defined operator '.a.' not found
+    !ERROR: No operator .A. defined for REAL(4) and REAL(4)
     x = y .a. z
-    !ERROR: Defined operator '.o.' not found
+    !ERROR: No operator .O. defined for REAL(4) and REAL(4)
     x = y .o. z
-    !ERROR: Defined operator '.n.' not found
+    !ERROR: No operator .N. defined for REAL(4)
     x = .n. y
-    !ERROR: Defined operator '.xor.' not found
+    !ERROR: No operator .XOR. defined for REAL(4) and REAL(4)
     x = y .xor. z
-    !ERROR: Defined operator '.x.' not found
+    !ERROR: No operator .X. defined for REAL(4)
     x = .x. y
   end
 end
@@ -189,7 +189,7 @@ contains
     complex :: y, z
     !ERROR: No intrinsic or user-defined OPERATOR(.AND.) matches operand types COMPLEX(4) and COMPLEX(4)
     x = y .and. z
-    !ERROR: No specific procedure of generic operator '.a.' matches the actual arguments
+    !ERROR: No intrinsic or user-defined .A. matches operand types COMPLEX(4) and COMPLEX(4)
     x = y .a. z
   end
 end