[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
This commit is contained in:
Peter Steinfeld 2021-06-25 11:28:30 -07:00
parent 4f5ebfdcd6
commit 57e53f0130
2 changed files with 32 additions and 2 deletions

View File

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

View File

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