[flang] Accept CLASS(*) array in EOSHIFT (#116114)

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 #115923.

Author: klausler

flang/lib/Evaluate/intrinsics.cpp

@@ -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
@@ -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},
@@ -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}}},
@@ -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;

flang/runtime/transformational.cpp

@@ -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()));
           }
@@ -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");
@@ -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")};
@@ -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) {
@@ -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]));
           }
@@ -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);
     }
   }
@@ -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());
     }

flang/test/Evaluate/bug115923.f90

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