[flang-commits] [flang] 57e53f0 - [flang] Fix conformability for intrinsic procedures

[Peter Steinfeld via flang-commits]

Author: Peter Steinfeld
Date: 2021-06-28T11:09:24-07:00
New Revision: 57e53f013087d68305fe278aca0a92efc9b0e899

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

LOG: [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

Added: 
    flang/test/Semantics/unpack.f90

Modified: 
    flang/lib/Evaluate/intrinsics.cpp

Removed: 
    


################################################################################
diff  --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index c8d8b02d58abc..5e305055b6913 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 0000000000000..d624f9c2e38a1
--- /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