[flang-commits] [flang] [flang] Refine "same type" testing for intrinsic arguments (PR #125133)

[Peter Klausler via flang-commits]

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

Some errors aren't being caught, such as the case in the linked bug where the PAD= argument to RESHAPE() didn't have the same declared type as the ARRAY=; this led to a crash in lowering.  Refine the "same type" testing logic for intrinsic procedures, and add a better test.

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


>From cbf4abf9778da814eb108357786f3fe9f109aca5 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Thu, 30 Jan 2025 13:19:55 -0800
Subject: [PATCH 1/2] wip

---
 flang/lib/Evaluate/intrinsics.cpp     | 14 +++++++-------
 flang/lib/Semantics/resolve-names.cpp |  2 +-
 2 files changed, 8 insertions(+), 8 deletions(-)

diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 1c7e564f706ad4..c6b7a5e7eab65c 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2032,16 +2032,16 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
       dimArg = j;
       argOk = true;
       break;
-    case KindCode::same: {
+    case KindCode::same:
       if (!sameArg) {
         sameArg = arg;
+        argOk = true;
+      } else {
+        auto sameType{sameArg->GetType().value()};
+        argOk = sameType.IsTkLenCompatibleWith(*type) ||
+            (name == "move_alloc"s && type->IsTkLenCompatibleWith(sameType));
       }
-      // Check both ways so that a CLASS(*) actuals to
-      // MOVE_ALLOC and EOSHIFT both work.
-      auto sameType{sameArg->GetType().value()};
-      argOk = sameType.IsTkLenCompatibleWith(*type) ||
-          type->IsTkLenCompatibleWith(sameType);
-    } break;
+      break;
     case KindCode::sameKind:
       if (!sameArg) {
         sameArg = arg;
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index a586b8e969ec61..58363533114d78 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -9737,7 +9737,7 @@ void ResolveNamesVisitor::ResolveSpecificationParts(ProgramTree &node) {
       },
       node.stmt());
   Walk(node.spec());
-  bool inDeviceSubprogram = false;
+  bool inDeviceSubprogram{false};
   // If this is a function, convert result to an object. This is to prevent the
   // result from being converted later to a function symbol if it is called
   // inside the function.

>From 13d74eb334063fd7748bcaac25d7379294f27c68 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Thu, 30 Jan 2025 15:12:45 -0800
Subject: [PATCH 2/2] [flang] Refine "same type" testing for intrinsic
 arguments

Some errors aren't being caught, such as the case in the linked bug
where the PAD= argument to RESHAPE() didn't have the same declared
type as the ARRAY=; this led to a crash in lowering.  Refine the
"same type" testing logic for intrinsic procedures, and add a
better test.

Fixes https://github.com/llvm/llvm-project/issues/124976.
---
 flang/lib/Evaluate/intrinsics.cpp  | 17 +++++++++------
 flang/test/Semantics/bug124976.f90 | 33 ++++++++++++++++++++++++++++++
 2 files changed, 44 insertions(+), 6 deletions(-)
 create mode 100644 flang/test/Semantics/bug124976.f90

diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index c6b7a5e7eab65c..5feb9a9cb8d519 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2032,16 +2032,21 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
       dimArg = j;
       argOk = true;
       break;
-    case KindCode::same:
+    case KindCode::same: {
       if (!sameArg) {
         sameArg = arg;
-        argOk = true;
+      }
+      auto sameType{sameArg->GetType().value()};
+      if (name == "move_alloc"s) {
+        // second argument can be more general
+        argOk = type->IsTkLenCompatibleWith(sameType);
+      } else if (name == "merge"s) {
+        argOk = type->IsTkLenCompatibleWith(sameType) &&
+            sameType.IsTkLenCompatibleWith(*type);
       } else {
-        auto sameType{sameArg->GetType().value()};
-        argOk = sameType.IsTkLenCompatibleWith(*type) ||
-            (name == "move_alloc"s && type->IsTkLenCompatibleWith(sameType));
+        argOk = sameType.IsTkLenCompatibleWith(*type);
       }
-      break;
+    } break;
     case KindCode::sameKind:
       if (!sameArg) {
         sameArg = arg;
diff --git a/flang/test/Semantics/bug124976.f90 b/flang/test/Semantics/bug124976.f90
new file mode 100644
index 00000000000000..29c21d4ead8475
--- /dev/null
+++ b/flang/test/Semantics/bug124976.f90
@@ -0,0 +1,33 @@
+!RUN: %python %S/test_errors.py %s %flang_fc1
+program main
+  type base
+    integer :: x = 1
+  end type
+  type, extends(base) :: child
+    integer :: y = 2
+  end type
+  class(child), allocatable :: c1(:), c2(:,:)
+  class(base), allocatable :: b1(:), b2(:,:)
+  logical var(1)
+  common /blk/ var
+  allocate(c1(2), c2(2,2), b1(2), b2(2,2))
+  !ERROR: Actual argument for 'pad=' has bad type or kind 'CLASS(base)'
+  c2 = reshape(c1, shape(c2), pad=b1)
+  b2 = reshape(b1, shape(b2), pad=c1) ! ok
+  !ERROR: Actual argument for 'to=' has bad type or kind 'CLASS(child)'
+  call move_alloc(b1, c1)
+  call move_alloc(c1, b1) ! ok
+  !ERROR: Actual argument for 'boundary=' has bad type or kind 'CLASS(base)'
+  c1 = eoshift(c1, 1, b1(1))
+  c1 = eoshift(c1, 1, c2(1,1)) ! ok
+  b1 = eoshift(b1, 1, c1(1)) ! ok
+  !ERROR: Actual argument for 'fsource=' has bad type or kind 'CLASS(child)'
+  b1 = merge(b1, c1, var(1))
+  !ERROR: Actual argument for 'fsource=' has bad type or kind 'CLASS(base)'
+  b1 = merge(c1, b1, var(1))
+  b1 = merge(b1, b1, var(1)) ! ok
+  !ERROR: Actual argument for 'vector=' has bad type or kind 'CLASS(base)'
+  c1 = pack(c1, var, b1)
+  c1 = pack(c1, var, c1) ! ok
+  b1 = pack(b1, var, c1) ! ok
+end