[flang-commits] [flang] [flang] Prevent bad expression rewrite 0*ARR -> 0 (PR #79853)

[Peter Klausler via flang-commits]

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

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.

>From 64a61aeab4cecf0bce48820c04fb14ec49a524da Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Mon, 29 Jan 2024 08:00:24 -0800
Subject: [PATCH] [flang] Prevent bad expression rewrite 0*ARR -> 0

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.
---
 flang/lib/Evaluate/fold-implementation.h |  2 +-
 flang/test/Semantics/generic08.f90       | 22 ++++++++++++++++++++++
 2 files changed, 23 insertions(+), 1 deletion(-)
 create mode 100644 flang/test/Semantics/generic08.f90

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