[flang-commits] [flang] [flang] Correct defined assignment case (PR #142020)

[Peter Klausler via flang-commits]

https://github.com/klausler created https://github.com/llvm/llvm-project/pull/142020

When a generic ASSIGNMENT(=) has elemental and non-elemental specific procedures that match the actual arguments, the non-elemental procedure must take precedence.  We get this right for generics defined with interface blocks, but the type-bound case fails if the non-elemental specific takes a non-default PASS argument.

Fixes https://github.com/llvm/llvm-project/issues/141807.

>From 1eb6e57dc34820cfdd4ff3e0893456ef42b358d7 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Thu, 29 May 2025 12:30:18 -0700
Subject: [PATCH] [flang] Correct defined assignment case

When a generic ASSIGNMENT(=) has elemental and non-elemental
specific procedures that match the actual arguments, the
non-elemental procedure must take precedence.  We get this
right for generics defined with interface blocks, but the
type-bound case fails if the non-elemental specific takes a
non-default PASS argument.

Fixes https://github.com/llvm/llvm-project/issues/141807.
---
 flang/lib/Semantics/expression.cpp | 34 +++++++++++++++++++-----------
 flang/test/Semantics/bug141807.f90 | 32 ++++++++++++++++++++++++++++
 2 files changed, 54 insertions(+), 12 deletions(-)
 create mode 100644 flang/test/Semantics/bug141807.f90

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<const Symbol *, bool> 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<ProcedureRef> ArgumentAnalyzer::GetDefinedAssignmentProc() {
   const Symbol *proc{nullptr};
+  bool isProcElemental{false};
   std::optional<int> 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