[flang] Prevent bad expression rewrite 0*ARR -> 0

[klausler]

Don't rewrite 0*X to 0 if X is not scalar. Up until now this hasn't shown up as a bug because a scalar 0 works in nearly all expressions where an array would be expected. But not in all cases -- this bad rewrite can cause generic procedure resolution to fail when it causes an actual argument to have an unsupported rank.

[llvmbot]

@llvm/pr-subscribers-flang-semantics

Author: Peter Klausler (klausler)

Changes

Don't rewrite 0*X to 0 if X is not scalar. Up until now this hasn't shown up as a bug because a scalar 0 works in nearly all expressions where an array would be expected. But not in all cases -- this bad rewrite can cause generic procedure resolution to fail when it causes an actual argument to have an unsupported rank.

---

Full diff: https://github.com/llvm/llvm-project/pull/79853.diff

2 Files Affected:

• (modified) flang/lib/Evaluate/fold-implementation.h (+1-1)
• (added) flang/test/Semantics/generic08.f90 (+22)

diff --git a/flang/lib/Evaluate/fold-implementation.h b/flang/lib/Evaluate/fold-implementation.h
index ed015da951090d5..798bc5f37f6f424 100644
--- a/flang/lib/Evaluate/fold-implementation.h
+++ b/flang/lib/Evaluate/fold-implementation.h
@@ -1927,7 +1927,7 @@ Expr<T> FoldOperation(FoldingContext &context, Multiply<T> &&x) {
       x.left() = Expr<T>{std::move(*c)};
     }
     if (auto c{GetScalarConstantValue<T>(x.left())}) {
-      if (c->IsZero()) {
+      if (c->IsZero() && x.right().Rank() == 0) {
         return std::move(x.left());
       } else if (c->CompareSigned(Scalar<T>{1}) == Ordering::Equal) {
         if (IsVariable(x.right())) {
diff --git a/flang/test/Semantics/generic08.f90 b/flang/test/Semantics/generic08.f90
new file mode 100644
index 000000000000000..327a7b21d320991
--- /dev/null
+++ b/flang/test/Semantics/generic08.f90
@@ -0,0 +1,22 @@
+! RUN: %flang_fc1 -fsyntax-only -pedantic %s  2>&1 | FileCheck %s --allow-empty
+! Regression test for pFUnit case: ensure that 0*ka doesn't get rewritten
+! into a scalar 0 and then fail generic resolution.
+! CHECK-NOT: error:
+program test
+  interface g
+    procedure s
+  end interface
+  integer(1) a(1)
+  a(1) = 2
+  call test(1_1, a)
+ contains
+  subroutine s(a1,a2)
+    integer(1) a1(:), a2(:)
+    print *, a1
+    print *, a2
+  end
+  subroutine test(j,ka)
+    integer(1) j, ka(:)
+    call g(int(j+0*ka,kind(ka)), ka)
+  end
+end

[jeanPerier]

LGTM