diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp index d68e71f57f141..f4af738284ed7 100644 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -2907,7 +2907,7 @@ std::pair ExpressionAnalyzer::ResolveGeneric( continue; } // Matching distance is smaller than the previously matched - // specific. Let it go thourgh so the current procedure is picked. + // specific. Let it go through so the current procedure is picked. } else { // 16.9.144(6): a bare NULL() is not allowed as an actual // argument to a generic procedure if the specific procedure @@ -4824,31 +4824,41 @@ bool ArgumentAnalyzer::OkLogicalIntegerAssignment( std::optional ArgumentAnalyzer::GetDefinedAssignmentProc() { const Symbol *proc{nullptr}; + bool isProcElemental{false}; std::optional passedObjectIndex; std::string oprNameString{"assignment(=)"}; parser::CharBlock oprName{oprNameString}; const auto &scope{context_.context().FindScope(source_)}; - // If multiple resolutions were possible, they will have been already - // diagnosed. { auto restorer{context_.GetContextualMessages().DiscardMessages()}; if (const Symbol *symbol{scope.FindSymbol(oprName)}) { ExpressionAnalyzer::AdjustActuals noAdjustment; proc = context_.ResolveGeneric(*symbol, actuals_, noAdjustment, true).first; + if (proc) { + isProcElemental = IsElementalProcedure(*proc); + } } - for (std::size_t i{0}; !proc && i < actuals_.size(); ++i) { + for (std::size_t i{0}; (!proc || isProcElemental) && i < actuals_.size(); + ++i) { const Symbol *generic{nullptr}; if (const Symbol * binding{FindBoundOp(oprName, i, generic, /*isSubroutine=*/true)}) { - if (CheckAccessibleSymbol(scope, DEREF(generic))) { - // ignore inaccessible type-bound ASSIGNMENT(=) generic - } else if (const Symbol * - resolution{GetBindingResolution(GetType(i), *binding)}) { - proc = resolution; - } else { - proc = binding; - passedObjectIndex = i; + // ignore inaccessible type-bound ASSIGNMENT(=) generic + if (!CheckAccessibleSymbol(scope, DEREF(generic))) { + const Symbol *resolution{GetBindingResolution(GetType(i), *binding)}; + const Symbol &newProc{*(resolution ? resolution : binding)}; + bool isElemental{IsElementalProcedure(newProc)}; + if (!proc || !isElemental) { + // Non-elemental resolution overrides elemental + proc = &newProc; + isProcElemental = isElemental; + if (resolution) { + passedObjectIndex.reset(); + } else { + passedObjectIndex = i; + } + } } } } diff --git a/flang/test/Semantics/bug141807.f90 b/flang/test/Semantics/bug141807.f90 new file mode 100644 index 0000000000000..48539f19927c1 --- /dev/null +++ b/flang/test/Semantics/bug141807.f90 @@ -0,0 +1,32 @@ +!RUN: %flang_fc1 -fdebug-unparse %s | FileCheck %s +!Ensure that non-elemental specific takes precedence over elemental +!defined assignment, even with non-default PASS argument. +module m + type base + integer :: n = -999 + contains + procedure, pass(from) :: array_assign_scalar + procedure :: elemental_assign + generic :: assignment(=) => array_assign_scalar, elemental_assign + end type + contains + subroutine array_assign_scalar(to, from) + class(base), intent(out) :: to(:) + class(base), intent(in) :: from + to%n = from%n + end + impure elemental subroutine elemental_assign(to, from) + class(base), intent(out) :: to + class(base), intent(in) :: from + to%n = from%n + end +end + +use m +type(base) :: array(1), scalar +scalar%n = 1 +!CHECK: CALL array_assign_scalar(array,(scalar)) +array = scalar +!CHECK: CALL elemental_assign(array,[base::scalar]) +array = [scalar] +end