[flang] Fix conformability checking for intrinsic arguments

[PeteSteinfeld]

Summary

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".

[klausler]

Why isn't the conformance checking that's implied by the definition of UNPACK in the intrinsics table catching this case? Is it because it only checks rank? If so, you should put this extra compile-time checking into the general argument conformance checking, and it'll apply to more intrinsics than just UNPACK.

flang/lib/Evaluate/intrinsics.cpp

2165

spelling

[PeteSteinfeld]

Responding to Peter's comments. In particular, it looks like the check I added
for the UNPACK intrinsic was changed to a more general fix for determining
conformability of intrinsic arguments in general.

flang/lib/Evaluate/intrinsics.cpp

if (!argOk) {
           "Actual argument for '%s=' has bad type or kind '%s'"_err_en_US,
           d.keyword, type->AsFortran());
       return std::nullopt;
     }
   }
 
   // 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};
   for (std::size_t j{0}; j < dummies; ++j) {
     const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]};
     if (const ActualArgument * arg{actualForDummy[j]}) {
       if (IsAssumedRank(*arg) && d.rank != Rank::anyOrAssumedRank) {
         messages.Say("Assumed-rank array cannot be forwarded to "
if (const ActualArgument * arg{actualForDummy[j]}) {
         break;
       case Rank::matrix:
         argOk = rank == 2;
         break;
       case Rank::array:
         argOk = rank > 0;
         if (!arrayArg) {
           arrayArg = arg;
+          arrayArgName = d.keyword;
         } else {
           argOk &= rank == arrayArg->Rank();
         }
         break;
       case Rank::known:
         if (!knownArg) {
           knownArg = arg;
         }
         argOk = rank == knownArg->Rank();
         break;
       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:
         CHECK(arrayArg);
         argOk = rank == 0 || rank + 1 == arrayArg->Rank();
         break;
       case Rank::reduceOperation:
         // TODO: validate the reduction operation -- it must be a pure
static bool ApplySpecificChecks(SpecificCall &call, FoldingContext &context) {
   return ok;
 }
 
 static DynamicType GetReturnType(const SpecificIntrinsicInterface &interface,
     const common::IntrinsicTypeDefaultKinds &defaults) {
   TypeCategory category{TypeCategory::Integer};
   switch (interface.result.kindCode) {
   case KindCode::defaultIntegerKind:
     break;
   case KindCode::doublePrecision:
   case KindCode::defaultRealKind:
     category = TypeCategory::Real;
     break;
   default:
     CRASH_NO_CASE;
   }
   int kind{interface.result.kindCode == KindCode::doublePrecision

flang/test/Semantics/unpack.f90

+! 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