From 57e53f013087d68305fe278aca0a92efc9b0e899 Mon Sep 17 00:00:00 2001
From: Peter Steinfeld <psteinfeld@nvidia.com>
Date: Fri, 25 Jun 2021 11:28:30 -0700
Subject: [PATCH] [flang] Fix conformability for intrinsic procedures

There are situations where the arguments of intrinsics must be
conformable, which is defined in section 3.36.  This means they must
have "the same shape, or one being an array and the other being scalar".
But the check we were actually making was that their ranks were the same.

This change fixes that and adds a test for the UNPACK intrinsic, where
the FIELD argument "shall be conformable with MASK".

Differential Revision: https://reviews.llvm.org/D104936
---
 flang/lib/Evaluate/intrinsics.cpp | 19 +++++++++++++++++--
 flang/test/Semantics/unpack.f90   | 15 +++++++++++++++
 2 files changed, 32 insertions(+), 2 deletions(-)
 create mode 100644 flang/test/Semantics/unpack.f90

diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index c8d8b02..5e30505 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -1355,6 +1355,7 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
 
   // 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 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
         argOk = rank > 0;
         if (!arrayArg) {
           arrayArg = arg;
+          arrayArgName = d.keyword;
         } else {
           argOk &= rank == arrayArg->Rank();
         }
@@ -1424,9 +1426,22 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
       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:
diff --git a/flang/test/Semantics/unpack.f90 b/flang/test/Semantics/unpack.f90
new file mode 100644
index 0000000..d624f9c
--- /dev/null
+++ b/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
-- 
2.7.4