[flang] Better shape analysis for CSHIFT, EOSHIFT, SPREAD

Original-commit: flang-compiler/f18@eb43df8 Reviewed-on: flang-compiler/f18#782 Tree-same-pre-rewrite: false
llvm · Oct 16, 2019 · f090eb8 · f090eb8
1 parent 3a4091b
commit f090eb8
Show file tree

Hide file tree

Showing 2 changed files with 31 additions and 1 deletion.
diff --git a/flang/lib/evaluate/shape.cc b/flang/lib/evaluate/shape.cc
@@ -471,6 +471,7 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
   } else if (const auto *intrinsic{call.proc().GetSpecificIntrinsic()}) {
     if (intrinsic->name == "shape" || intrinsic->name == "lbound" ||
         intrinsic->name == "ubound") {
+      // These are the array-valued cases for LBOUND and UBOUND (no DIM=).
       const auto *expr{call.arguments().front().value().UnwrapExpr()};
       CHECK(expr != nullptr);
       return Shape{MaybeExtentExpr{ExtentExpr{expr->Rank()}}};
@@ -492,6 +493,30 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
           }
         }
       }
+    } else if (intrinsic->name == "cshift" || intrinsic->name == "eoshift") {
+      if (!call.arguments().empty()) {
+        return (*this)(call.arguments()[0]);
+      }
+    } else if (intrinsic->name == "spread") {
+      // SHAPE(SPREAD(ARRAY,DIM,NCOPIES)) = SHAPE(ARRAY) with NCOPIES inserted
+      // at position DIM.
+      if (call.arguments().size() == 3) {
+        auto arrayShape{
+            (*this)(UnwrapExpr<Expr<SomeType>>(call.arguments().at(0)))};
+        const auto *dimArg{UnwrapExpr<Expr<SomeType>>(call.arguments().at(1))};
+        const auto *nCopies{
+            UnwrapExpr<Expr<SomeInteger>>(call.arguments().at(2))};
+        if (arrayShape.has_value() && dimArg != nullptr && nCopies != nullptr) {
+          if (auto dim{ToInt64(*dimArg)}) {
+            if (*dim >= 1 &&
+                static_cast<std::size_t>(*dim) <= arrayShape->size() + 1) {
+              arrayShape->emplace(arrayShape->begin() + *dim - 1,
+                  ConvertToType<ExtentType>(common::Clone(*nCopies)));
+              return std::move(*arrayShape);
+            }
+          }
+        }
+      }
     } else if (intrinsic->characteristics.value().attrs.test(characteristics::
                        Procedure::Attr::NullPointer)) {  // NULL(MOLD=)
       return (*this)(call.arguments());

diff --git a/flang/module/ieee_exceptions.f90 b/flang/module/ieee_exceptions.f90
@@ -46,7 +46,8 @@ module ieee_exceptions
       ieee_support_flag_4, ieee_support_flag_8, ieee_support_flag_10, &
       ieee_support_flag_16
   interface ieee_support_flag
-    module procedure :: ieee_support_flag_2, ieee_support_flag_3, &
+    module procedure :: ieee_support_flag, &
+      ieee_support_flag_2, ieee_support_flag_3, &
       ieee_support_flag_4, ieee_support_flag_8, ieee_support_flag_10, &
       ieee_support_flag_16
   end interface
@@ -88,6 +89,10 @@ subroutine ieee_set_status(status)
     type(ieee_status_type), intent(in) :: status
   end subroutine ieee_set_status
 
+  pure logical function ieee_support_flag(flag)
+    type(ieee_flag_type), intent(in) :: flag
+    ieee_support_flag = .true.
+  end function
   pure logical function ieee_support_flag_2(flag, x)
     type(ieee_flag_type), intent(in) :: flag
     real(kind=2), intent(in) :: x(..)