[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

@@ -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:

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