Skip to content

Commit

Permalink
[flang] Accept CLASS(*) array in EOSHIFT (#116114)
Browse files Browse the repository at this point in the history 
The intrinsic processing code wasn't allowing the ARRAY= argument to the
EOSHIFT intrinsic function to be CLASS(*). That case seems to conform to
the standard, although only one compiler could actually handle it, so
allow for it.

Fixes llvm/llvm-project#115923.
  • Loading branch information
@klausler
klausler authored Nov 14, 2024
1 parent 17daa84 commit 376713f
Show file tree
Hide file tree
Showing 3 changed files with 42 additions and 20 deletions.
26 changes: 13 additions & 13 deletions flang/lib/Evaluate/intrinsics.cpp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -168,8 +168,6 @@ static constexpr TypePattern SameCharNoLen{CharType, KindCode::sameKind};
static constexpr TypePattern SameLogical{LogicalType, KindCode::same};
static constexpr TypePattern SameRelatable{RelatableType, KindCode::same};
static constexpr TypePattern SameIntrinsic{IntrinsicType, KindCode::same};
static constexpr TypePattern SameDerivedType{
CategorySet{TypeCategory::Derived}, KindCode::same};
static constexpr TypePattern SameType{AnyType, KindCode::same};

// Match some kind of some INTEGER or REAL type(s); when argument types
Expand Down Expand Up @@ -438,6 +436,12 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
{"shift", AnyInt}},
SameInt},
{"dshiftr", {{"i", BOZ}, {"j", SameInt}, {"shift", AnyInt}}, SameInt},
{"eoshift",
{{"array", SameType, Rank::array},
{"shift", AnyInt, Rank::dimRemovedOrScalar},
// BOUNDARY= is not optional for non-intrinsic types
{"boundary", SameType, Rank::dimRemovedOrScalar}, OptionalDIM},
SameType, Rank::conformable, IntrinsicClass::transformationalFunction},
{"eoshift",
{{"array", SameIntrinsic, Rank::array},
{"shift", AnyInt, Rank::dimRemovedOrScalar},
Expand All @@ -446,14 +450,6 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
OptionalDIM},
SameIntrinsic, Rank::conformable,
IntrinsicClass::transformationalFunction},
{"eoshift",
{{"array", SameDerivedType, Rank::array},
{"shift", AnyInt, Rank::dimRemovedOrScalar},
// BOUNDARY= is not optional for derived types
{"boundary", SameDerivedType, Rank::dimRemovedOrScalar},
OptionalDIM},
SameDerivedType, Rank::conformable,
IntrinsicClass::transformationalFunction},
{"epsilon",
{{"x", SameReal, Rank::anyOrAssumedRank, Optionality::required,
common::Intent::In, {ArgFlag::canBeMoldNull}}},
Expand Down Expand Up @@ -1937,12 +1933,16 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
dimArg = j;
argOk = true;
break;
case KindCode::same:
case KindCode::same: {
if (!sameArg) {
sameArg = arg;
}
argOk = type->IsTkLenCompatibleWith(sameArg->GetType().value());
break;
// Check both ways so that a CLASS(*) actuals to
// MOVE_ALLOC and EOSHIFT both work.
auto sameType{sameArg->GetType().value()};
argOk = sameType.IsTkLenCompatibleWith(*type) ||
type->IsTkLenCompatibleWith(sameType);
} break;
case KindCode::sameKind:
if (!sameArg) {
sameArg = arg;
Expand Down
14 changes: 7 additions & 7 deletions flang/runtime/transformational.cpp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -46,7 +46,7 @@ class ShiftControl {
lb_[k++] = shiftDim.LowerBound();
if (shiftDim.Extent() != source.GetDimension(j).Extent()) {
terminator_.Crash("%s: on dimension %d, SHIFT= has extent %jd but "
"SOURCE= has extent %jd",
"ARRAY= has extent %jd",
which, k, static_cast<std::intmax_t>(shiftDim.Extent()),
static_cast<std::intmax_t>(source.GetDimension(j).Extent()));
}
Expand Down Expand Up @@ -460,7 +460,7 @@ void RTDEF(Cshift)(Descriptor &result, const Descriptor &source,
RUNTIME_CHECK(terminator, rank > 1);
if (dim < 1 || dim > rank) {
terminator.Crash(
"CSHIFT: DIM=%d must be >= 1 and <= SOURCE= rank %d", dim, rank);
"CSHIFT: DIM=%d must be >= 1 and <= ARRAY= rank %d", dim, rank);
}
ShiftControl shiftControl{shift, terminator, dim};
shiftControl.Init(source, "CSHIFT");
Expand Down Expand Up @@ -527,7 +527,7 @@ void RTDEF(Eoshift)(Descriptor &result, const Descriptor &source,
RUNTIME_CHECK(terminator, rank > 1);
if (dim < 1 || dim > rank) {
terminator.Crash(
"EOSHIFT: DIM=%d must be >= 1 and <= SOURCE= rank %d", dim, rank);
"EOSHIFT: DIM=%d must be >= 1 and <= ARRAY= rank %d", dim, rank);
}
std::size_t elementLen{
AllocateResult(result, source, rank, extent, terminator, "EOSHIFT")};
Expand All @@ -538,7 +538,7 @@ void RTDEF(Eoshift)(Descriptor &result, const Descriptor &source,
RUNTIME_CHECK(terminator, boundary->type() == source.type());
if (boundary->ElementBytes() != elementLen) {
terminator.Crash("EOSHIFT: BOUNDARY= has element byte length %zd, but "
"SOURCE= has length %zd",
"ARRAY= has length %zd",
boundary->ElementBytes(), elementLen);
}
if (boundaryRank > 0) {
Expand All @@ -547,7 +547,7 @@ void RTDEF(Eoshift)(Descriptor &result, const Descriptor &source,
if (j != dim - 1) {
if (boundary->GetDimension(k).Extent() != extent[j]) {
terminator.Crash("EOSHIFT: BOUNDARY= has extent %jd on dimension "
"%d but must conform with extent %jd of SOURCE=",
"%d but must conform with extent %jd of ARRAY=",
static_cast<std::intmax_t>(boundary->GetDimension(k).Extent()),
k + 1, static_cast<std::intmax_t>(extent[j]));
}
Expand Down Expand Up @@ -611,7 +611,7 @@ void RTDEF(EoshiftVector)(Descriptor &result, const Descriptor &source,
RUNTIME_CHECK(terminator, boundary->type() == source.type());
if (boundary->ElementBytes() != elementLen) {
terminator.Crash("EOSHIFT: BOUNDARY= has element byte length %zd but "
"SOURCE= has length %zd",
"ARRAY= has length %zd",
boundary->ElementBytes(), elementLen);
}
}
Expand Down Expand Up @@ -658,7 +658,7 @@ void RTDEF(Pack)(Descriptor &result, const Descriptor &source,
RUNTIME_CHECK(terminator, vector->rank() == 1);
RUNTIME_CHECK(terminator, source.type() == vector->type());
if (source.ElementBytes() != vector->ElementBytes()) {
terminator.Crash("PACK: SOURCE= has element byte length %zd, but VECTOR= "
terminator.Crash("PACK: ARRAY= has element byte length %zd, but VECTOR= "
"has length %zd",
source.ElementBytes(), vector->ElementBytes());
}
Expand Down
22 changes: 22 additions & 0 deletions flang/test/Evaluate/bug115923.f90
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,22 @@
! RUN: %flang_fc1 -fsyntax-only -pedantic %s 2>&1 | FileCheck %s
! Ensure that EOSHIFT's ARRAY= argument and result can be CLASS(*).
! CHECK-NOT: error:
! CHECK: warning: Source of TRANSFER is polymorphic
! CHECK: warning: Mold of TRANSFER is polymorphic
program p
type base
integer j
end type
type, extends(base) :: extended
integer k
end type
class(base), allocatable :: polyArray(:,:,:)
class(*), allocatable :: unlimited(:)
allocate(polyArray, source=reshape([(extended(n,n-1),n=1,8)],[2,2,2]))
allocate(unlimited, source=[(base(9),n=1,16)])
select type (x => eoshift(transfer(polyArray, unlimited), -4, base(-1)))
type is (base); print *, 'base', x
type is (extended); print *, 'extended?', x
class default; print *, 'class default??'
end select
end

0 comments on commit 376713f

Please sign in to comment.