[PATCH] D104936: [flang] Fix conformability checking for intrinsic arguments

[Pete Steinfeld via Phabricator via llvm-commits]

This revision was automatically updated to reflect the committed changes.
Closed by commit rG57e53f013087: [flang] Fix conformability for intrinsic procedures (authored by PeteSteinfeld).

Repository:
  rG LLVM Github Monorepo

CHANGES SINCE LAST ACTION
  https://reviews.llvm.org/D104936/new/

https://reviews.llvm.org/D104936

Files:
  flang/lib/Evaluate/intrinsics.cpp
  flang/test/Semantics/unpack.f90


Index: flang/test/Semantics/unpack.f90
===================================================================
--- /dev/null
+++ flang/test/Semantics/unpack.f90
@@ -0,0 +1,15 @@
+! RUN: %S/test_errors.sh %s %t %flang_fc1
+! UNPACK() intrinsic function error tests
+program test_unpack
+  integer, dimension(2) :: vector = [343, 512]
+  logical, dimension(2, 2) :: mask = &
+    reshape([.true., .false., .true., .false.], [2, 2])
+  integer, dimension(2, 2) :: field = reshape([1, 2, 3, 4, 5, 6], [2, 2])
+  integer, dimension(2, 1) :: bad_field = reshape([1, 2], [2, 1])
+  integer :: scalar_field
+  integer, dimension(2, 2) :: result
+  result = unpack(vector, mask, field)
+  !ERROR: Dimension 2 of 'mask=' argument has extent 2, but 'field=' argument has extent 1
+  result = unpack(vector, mask, bad_field)
+  result = unpack(vector, mask, scalar_field)
+end program
Index: flang/lib/Evaluate/intrinsics.cpp
===================================================================
--- flang/lib/Evaluate/intrinsics.cpp
+++ flang/lib/Evaluate/intrinsics.cpp
@@ -1355,6 +1355,7 @@
 
   // Check the ranks of the arguments against the intrinsic's interface.
   const ActualArgument *arrayArg{nullptr};
+  const char *arrayArgName{nullptr};
   const ActualArgument *knownArg{nullptr};
   std::optional<int> shapeArgSize;
   int elementalRank{0};
@@ -1411,6 +1412,7 @@
         argOk = rank > 0;
         if (!arrayArg) {
           arrayArg = arg;
+          arrayArgName = d.keyword;
         } else {
           argOk &= rank == arrayArg->Rank();
         }
@@ -1424,9 +1426,22 @@
       case Rank::anyOrAssumedRank:
         argOk = true;
         break;
-      case Rank::conformable:
+      case Rank::conformable: // arg must be conformable with previous arrayArg
         CHECK(arrayArg);
-        argOk = rank == 0 || rank == arrayArg->Rank();
+        CHECK(arrayArgName);
+        if (const std::optional<Shape> &arrayArgShape{
+                GetShape(context, *arrayArg)}) {
+          if (const std::optional<Shape> &argShape{GetShape(context, *arg)}) {
+            std::string arrayArgMsg{"'"};
+            arrayArgMsg = arrayArgMsg + arrayArgName + "='" + " argument";
+            std::string argMsg{"'"};
+            argMsg = argMsg + d.keyword + "='" + " argument";
+            CheckConformance(context.messages(), *arrayArgShape, *argShape,
+                CheckConformanceFlags::RightScalarExpandable,
+                arrayArgMsg.c_str(), argMsg.c_str());
+          }
+        }
+        argOk = true; // Avoid an additional error message
         break;
       case Rank::dimReduced:
       case Rank::dimRemovedOrScalar:


-------------- next part --------------
A non-text attachment was scrubbed...
Name: D104936.354957.patch
Type: text/x-patch
Size: 2644 bytes
Desc: not available
URL: <http://lists.llvm.org/pipermail/llvm-commits/attachments/20210628/be60bccb/attachment.bin>