[flang] Fold TRIM

Accept IS_CONTIGUOUS and fold it

test folding is_contiguous

Original-commit: flang-compiler/f18@c75a0791b1
Reviewed-on: https://github.com/flang-compiler/f18/pull/911

flang/lib/evaluate/call.cc

@@ -191,6 +191,21 @@ std::optional<Expr<SubscriptInteger>> ProcedureRef::LEN() const {
   return proc_.LEN();
 }
 
+int ProcedureRef::Rank() const {
+  if (IsElemental()) {
+    for (const auto &arg : arguments_) {
+      if (arg) {
+        if (int rank{arg->Rank()}; rank > 0) {
+          return rank;
+        }
+      }
+    }
+    return 0;
+  } else {
+    return proc_.Rank();
+  }
+}
+
 ProcedureRef::~ProcedureRef() {}
 
 FOR_EACH_SPECIFIC_TYPE(template class FunctionRef, )

flang/lib/evaluate/call.h

@@ -197,7 +197,7 @@ public:
   const ActualArguments &arguments() const { return arguments_; }
 
   std::optional<Expr<SubscriptInteger>> LEN() const;
-  int Rank() const { return proc_.Rank(); }
+  int Rank() const;
   bool IsElemental() const { return proc_.IsElemental(); }
   bool operator==(const ProcedureRef &) const;
   std::ostream &AsFortran(std::ostream &) const;

flang/lib/evaluate/character.h

@@ -64,22 +64,22 @@ public:
     return str;
   }
 
-  static std::int64_t INDEX(
+  static ConstantSubscript INDEX(
       const Character &str, const Character &substr, bool back = false) {
     auto pos{back ? str.rfind(substr) : str.find(substr)};
-    return static_cast<std::int64_t>(pos == str.npos ? 0 : pos + 1);
+    return static_cast<ConstantSubscript>(pos == str.npos ? 0 : pos + 1);
   }
 
-  static std::int64_t SCAN(
+  static ConstantSubscript SCAN(
       const Character &str, const Character &set, bool back = false) {
     auto pos{back ? str.find_last_of(set) : str.find_first_of(set)};
-    return static_cast<std::int64_t>(pos == str.npos ? 0 : pos + 1);
+    return static_cast<ConstantSubscript>(pos == str.npos ? 0 : pos + 1);
   }
 
-  static std::int64_t VERIFY(
+  static ConstantSubscript VERIFY(
       const Character &str, const Character &set, bool back = false) {
     auto pos{back ? str.find_last_not_of(set) : str.find_first_not_of(set)};
-    return static_cast<std::int64_t>(pos == str.npos ? 0 : pos + 1);
+    return static_cast<ConstantSubscript>(pos == str.npos ? 0 : pos + 1);
   }
 
   // Resize adds spaces on the right if the new size is bigger than the
@@ -93,18 +93,24 @@ public:
     }
   }
 
-  static std::int64_t LEN_TRIM(const Character &str) {
+  static ConstantSubscript LEN_TRIM(const Character &str) {
     return VERIFY(str, Character{' '}, true);
   }
 
-  static Character REPEAT(const Character &str, std::int64_t ncopies) {
+  static Character REPEAT(const Character &str, ConstantSubscript ncopies) {
     Character result;
-    while (ncopies-- > 0) {
-      result += str;
+    if (!str.empty()) {
+      while (ncopies-- > 0) {
+        result += str;
+      }
     }
     return result;
   }
 
+  static Character TRIM(const Character &str) {
+    return str.substr(0, LEN_TRIM(str));
+  }
+
 private:
   // Following helpers assume that character encodings contain ASCII
   static constexpr CharT Space() { return 0x20; }

flang/lib/evaluate/check-expression.cc

@@ -261,7 +261,8 @@ public:
   using Base::operator();
 
   Result operator()(const semantics::Symbol &symbol) const {
-    if (symbol.attrs().test(semantics::Attr::CONTIGUOUS)) {
+    if (symbol.attrs().test(semantics::Attr::CONTIGUOUS) ||
+        symbol.Rank() == 0) {
       return true;
     } else if (semantics::IsPointer(symbol)) {
       return false;
@@ -276,11 +277,8 @@ public:
   }
 
   Result operator()(const ArrayRef &x) const {
-    if (x.base().Rank() > 0 || !CheckSubscripts(x.subscript())) {
-      return false;
-    } else {
-      return (*this)(x.base());
-    }
+    return (x.base().IsSymbol() || x.base().Rank() == 0) &&
+        CheckSubscripts(x.subscript()) && (*this)(x.base());
   }
   Result operator()(const CoarrayRef &x) const {
     return CheckSubscripts(x.subscript());
@@ -330,11 +328,11 @@ private:
 template<typename A>
 bool IsSimplyContiguous(const A &x, const IntrinsicProcTable &table) {
   if (IsVariable(x)) {
-    if (auto known{IsSimplyContiguousHelper{table}(x)}) {
-      return *known;
-    }
+    auto known{IsSimplyContiguousHelper{table}(x)};
+    return known && *known;
+  } else {
+    return true;  // not a variable
   }
-  return false;
 }
 
 template bool IsSimplyContiguous(

flang/lib/evaluate/fold-character.cc

@@ -45,9 +45,15 @@ Expr<Type<TypeCategory::Character, KIND>> FoldIntrinsicFunction(
           CharacterUtils<KIND>::REPEAT(std::get<Scalar<T>>(*scalars),
               std::get<Scalar<SubscriptInteger>>(*scalars).ToInt64())}};
     }
+  } else if (name == "trim") {  // not elemental
+    if (auto scalar{
+            GetScalarConstantArguments<T>(context, funcRef.arguments())}) {
+      return Expr<T>{Constant<T>{
+          CharacterUtils<KIND>::TRIM(std::get<Scalar<T>>(*scalar))}};
+    }
   }
   // TODO: cshift, eoshift, maxval, minval, pack, reduce,
-  // spread, transfer, transpose, trim, unpack
+  // spread, transfer, transpose, unpack
   return Expr<T>{std::move(funcRef)};
 }
 

flang/lib/evaluate/fold-logical.cc

@@ -6,6 +6,7 @@
 //
 //----------------------------------------------------------------------------//
 
+#include "check-expression.h"
 #include "fold-implementation.h"
 
 namespace Fortran::evaluate {
@@ -76,12 +77,21 @@ Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
             [&fptr](const Scalar<LargestInt> &i, const Scalar<LargestInt> &j) {
               return Scalar<T>{std::invoke(fptr, i, j)};
             }));
+  } else if (name == "is_contiguous") {
+    if (args.at(0)) {
+      if (auto *expr{args[0]->UnwrapExpr()}) {
+        if (IsSimplyContiguous(*expr, context.intrinsics())) {
+          return Expr<T>{true};
+        }
+      }
+    }
   } else if (name == "merge") {
     return FoldMerge<T>(context, std::move(funcRef));
   }
   // TODO: btest, cshift, dot_product, eoshift, is_iostat_end,
   // is_iostat_eor, lge, lgt, lle, llt, logical, matmul, out_of_range,
-  // pack, parity, reduce, spread, transfer, transpose, unpack
+  // pack, parity, reduce, spread, transfer, transpose, unpack,
+  // extends_type_of, same_type_as
   return Expr<T>{std::move(funcRef)};
 }
 

flang/lib/evaluate/intrinsics.cc

@@ -457,6 +457,8 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
         {{"i", SameInt}, {"shift", AnyInt},
             {"size", AnyInt, Rank::elemental, Optionality::optional}},
         SameInt},
+    {"is_contiguous", {{"array", Addressable, Rank::anyOrAssumedRank}},
+        DefaultLogical},
     {"is_iostat_end", {{"i", AnyInt}}, DefaultLogical},
     {"is_iostat_eor", {{"i", AnyInt}}, DefaultLogical},
     {"kind", {{"x", AnyIntrinsic}}, DefaultInt},
@@ -704,8 +706,6 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
 //   LCOBOUND, UCOBOUND, FAILED_IMAGES, GET_TEAM, IMAGE_INDEX,
 //   NUM_IMAGES, STOPPED_IMAGES, TEAM_NUMBER, THIS_IMAGE,
 //   COSHAPE
-// TODO: Object characteristic inquiry functions
-//   IS_CONTIGUOUS
 // TODO: Non-standard intrinsic functions
 //  AND, OR, XOR, LSHIFT, RSHIFT, SHIFT, ZEXT, IZEXT,
 //  COMPL, EQV, NEQV, INT8, JINT, JNINT, KNINT,

flang/test/evaluate/CMakeLists.txt

@@ -142,6 +142,7 @@ set(FOLDING_TESTS
   folding06.f90
   folding07.f90
   folding08.f90
+  folding09.f90
 )
 
 add_test(Expression expression-test)

flang/test/evaluate/folding09.f90

@@ -0,0 +1,27 @@
+! Test folding of IS_CONTIGUOUS on simply contiguous items (9.5.4)
+! When IS_CONTIGUOUS() is constant, it's .TRUE.
+
+module m
+  real, target :: hosted(2)
+ contains
+  function f()
+    real, pointer, contiguous :: f(:)
+    f => hosted
+  end function
+  subroutine test(arr1, arr2, arr3, mat)
+    real, intent(in) :: arr1(:), arr2(10), mat(10, 10)
+    real, intent(in), contiguous :: arr3(:)
+    real :: scalar
+    logical, parameter :: isc01 = is_contiguous(0)
+    logical, parameter :: isc02 = is_contiguous(scalar)
+    logical, parameter :: isc03 = is_contiguous(scalar + scalar)
+    logical, parameter :: isc04 = is_contiguous([0, 1, 2])
+    logical, parameter :: isc05 = is_contiguous(arr1 + 1.0)
+    logical, parameter :: isc06 = is_contiguous(arr2)
+    logical, parameter :: isc07 = is_contiguous(mat)
+    logical, parameter :: isc08 = is_contiguous(mat(1:10,1))
+    logical, parameter :: isc09 = is_contiguous(arr2(1:10:1))
+    logical, parameter :: isc10 = is_contiguous(arr3)
+    logical, parameter :: isc11 = is_contiguous(f())
+  end subroutine
+end module

flang/test/semantics/modfile32.f90

@@ -216,7 +216,7 @@ end
 ! end
 ! subroutine s3(x, y)
 !  real(4) :: x(1_8:10_8, 1_8:10_8)
-!  real(4) :: y(1_8:int(ubound(f_elem(x),1_4),kind=8))
+!  real(4) :: y(1_8:10_8)
 ! end
 !end