[flang-commits] [flang] ce6dd97 - [flang] Fix analyzed form of type-bound assignment

[Tim Keith via flang-commits]

Author: Tim Keith
Date: 2020-09-14T09:59:51-07:00
New Revision: ce6dd973ac556a326c38bd7667b4fb448f215d09

URL: https://github.com/llvm/llvm-project/commit/ce6dd973ac556a326c38bd7667b4fb448f215d09
DIFF: https://github.com/llvm/llvm-project/commit/ce6dd973ac556a326c38bd7667b4fb448f215d09.diff

LOG: [flang] Fix analyzed form of type-bound assignment

Change the analyzed form of type-bound assignment to match that of call
statements. Resolve the binding name to a specific subprogram when
possible by using `GetBindingResolution`. Otherwise leave it as a
type-bound procedure call.

Differential Revision: https://reviews.llvm.org/D87541

Added: 
    flang/test/Semantics/defined-ops.f90

Modified: 
    flang/lib/Semantics/expression.cpp

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index ae53559ea5db..fcce08db6ef6 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -1684,7 +1684,6 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
     const parser::ProcComponentRef &pcr, ActualArguments &&arguments)
     -> std::optional<CalleeAndArguments> {
   const parser::StructureComponent &sc{pcr.v.thing};
-  const auto &name{sc.component.source};
   if (MaybeExpr base{Analyze(sc.base)}) {
     if (const Symbol * sym{sc.component.symbol}) {
       if (auto *dtExpr{UnwrapExpr<Expr<SomeDerived>>(*base)}) {
@@ -1722,7 +1721,7 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
           }
         }
       }
-      Say(name,
+      Say(sc.component.source,
           "Base of procedure component reference is not a derived-type object"_err_en_US);
     }
   }
@@ -2940,18 +2939,26 @@ std::optional<ProcedureRef> ArgumentAnalyzer::GetDefinedAssignmentProc() {
       context_.EmitGenericResolutionError(*symbol);
     }
   }
-  for (std::size_t passIndex{0}; passIndex < actuals_.size(); ++passIndex) {
-    if (const Symbol * specific{FindBoundOp(oprName, passIndex)}) {
-      proc = specific;
+  int passedObjectIndex{-1};
+  for (std::size_t i{0}; i < actuals_.size(); ++i) {
+    if (const Symbol * specific{FindBoundOp(oprName, i)}) {
+      if (const Symbol *
+          resolution{GetBindingResolution(GetType(i), *specific)}) {
+        proc = resolution;
+      } else {
+        proc = specific;
+        passedObjectIndex = i;
+      }
     }
   }
-  if (proc) {
-    ActualArguments actualsCopy{actuals_};
-    actualsCopy[1]->Parenthesize();
-    return ProcedureRef{ProcedureDesignator{*proc}, std::move(actualsCopy)};
-  } else {
+  if (!proc) {
     return std::nullopt;
   }
+  ActualArguments actualsCopy{actuals_};
+  if (passedObjectIndex >= 0) {
+    actualsCopy[passedObjectIndex]->set_isPassedObject();
+  }
+  return ProcedureRef{ProcedureDesignator{*proc}, std::move(actualsCopy)};
 }
 
 void ArgumentAnalyzer::Dump(llvm::raw_ostream &os) {

diff  --git a/flang/test/Semantics/defined-ops.f90 b/flang/test/Semantics/defined-ops.f90
new file mode 100644
index 000000000000..24e72677c6eb
--- /dev/null
+++ b/flang/test/Semantics/defined-ops.f90
@@ -0,0 +1,88 @@
+! RUN: %f18 -funparse %s 2>&1 | FileCheck %s
+
+! Check the analyzed form of a defined operator or assignment.
+
+! Type-bound defined assignment
+module m1
+  type :: t
+  contains
+    procedure :: b1 => s1
+    procedure, pass(y) :: b2 => s2
+    generic :: assignment(=) => b1, b2
+  end type
+contains
+  subroutine s1(x, y)
+    class(t), intent(out) :: x
+    integer, intent(in) :: y
+  end
+  subroutine s2(x, y)
+    real, intent(out) :: x
+    class(t), intent(in) :: y
+  end
+  subroutine test1(x)
+    type(t) :: x
+    real :: a
+    !CHECK: CALL s1(x,1_4)
+    x = 1
+    !CHECK: CALL s2(a,x)
+    a = x
+  end
+  subroutine test2(x)
+    class(t) :: x
+    real :: a
+    !CHECK: CALL x%b1(1_4)
+    x = 1
+    !CHECK: CALL x%b2(a)
+    a = x
+  end
+end
+
+! Type-bound operator
+module m2
+  type :: t2
+  contains
+    procedure, pass(x2) :: b2 => f
+    generic :: operator(+) => b2
+  end type
+contains
+  integer pure function f(x1, x2)
+    class(t2), intent(in) :: x1
+    class(t2), intent(in) :: x2
+  end
+  subroutine test2(x, y)
+    class(t2) :: x
+    type(t2) :: y
+    !CHECK: i=f(x,y)
+    i = x + y
+    !CHECK: i=x%b2(y)
+    i = y + x
+  end
+end module
+
+! Non-type-bound assignment and operator
+module m3
+  type t
+  end type
+  interface assignment(=)
+    subroutine s1(x, y)
+      import
+      class(t), intent(out) :: x
+      integer, intent(in) :: y
+    end
+  end interface
+  interface operator(+)
+    integer function f(x, y)
+      import
+      class(t), intent(in) :: x, y
+    end
+  end interface
+contains
+  subroutine test(x, y)
+    class(t) :: x, y
+    !CHECK: CALL s1(x,2_4)
+    x = 2
+    !CHECK: i=f(x,y)
+    i = x + y
+  end
+end
+