diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -1684,7 +1684,6 @@ const parser::ProcComponentRef &pcr, ActualArguments &&arguments) -> std::optional { 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>(*base)}) { @@ -1722,7 +1721,7 @@ } } } - Say(name, + Say(sc.component.source, "Base of procedure component reference is not a derived-type object"_err_en_US); } } @@ -2940,18 +2939,26 @@ 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 --- /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 +