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

[via flang-commits]

Author: Peter Klausler
Date: 2024-01-29T14:25:53-08:00
New Revision: d83c97714756e828c9c7091aa8294e022c93a454

URL: https://github.com/llvm/llvm-project/commit/d83c97714756e828c9c7091aa8294e022c93a454
DIFF: https://github.com/llvm/llvm-project/commit/d83c97714756e828c9c7091aa8294e022c93a454.diff

LOG: [flang] Prevent bad expression rewrite 0*ARR -> 0 (#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.

Added: 
    flang/test/Semantics/generic08.f90

Modified: 
    flang/lib/Evaluate/fold-implementation.h

Removed: 
    


################################################################################
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