[flang-commits] [flang] 67081ba - [flang] Enforce F'2023 C15121 (#94418)

via flang-commits flang-commits at lists.llvm.org
Tue Jun 11 17:07:40 PDT 2024


Author: Peter Klausler
Date: 2024-06-11T17:07:37-07:00
New Revision: 67081badfc65b8b60622314dd698834ffcfdbfa9

URL: https://github.com/llvm/llvm-project/commit/67081badfc65b8b60622314dd698834ffcfdbfa9
DIFF: https://github.com/llvm/llvm-project/commit/67081badfc65b8b60622314dd698834ffcfdbfa9.diff

LOG: [flang] Enforce F'2023 C15121 (#94418)

No specification expression in the declaration of the result variable of
an elemental function may depend on the value of a dummy argument. This
ensures that all of the results have the same type when the elemental
function is applied to the elements of an array.

Added: 
    

Modified: 
    flang/include/flang/Evaluate/check-expression.h
    flang/lib/Evaluate/check-expression.cpp
    flang/lib/Semantics/check-declarations.cpp
    flang/test/Lower/HLFIR/elemental-result-length.f90
    flang/test/Semantics/elemental01.f90

Removed: 
    


################################################################################
diff  --git a/flang/include/flang/Evaluate/check-expression.h b/flang/include/flang/Evaluate/check-expression.h
index e942ad7ebfc46..b711d289ba524 100644
--- a/flang/include/flang/Evaluate/check-expression.h
+++ b/flang/include/flang/Evaluate/check-expression.h
@@ -77,23 +77,26 @@ std::optional<Expr<SomeType>> NonPointerInitializationExpr(const Symbol &,
 // specification expressions.
 
 template <typename A>
-void CheckSpecificationExpr(
-    const A &, const semantics::Scope &, FoldingContext &);
-extern template void CheckSpecificationExpr(
-    const Expr<SomeType> &x, const semantics::Scope &, FoldingContext &);
-extern template void CheckSpecificationExpr(
-    const Expr<SomeInteger> &x, const semantics::Scope &, FoldingContext &);
+void CheckSpecificationExpr(const A &, const semantics::Scope &,
+    FoldingContext &, bool forElementalFunctionResult);
+extern template void CheckSpecificationExpr(const Expr<SomeType> &x,
+    const semantics::Scope &, FoldingContext &,
+    bool forElementalFunctionResult);
+extern template void CheckSpecificationExpr(const Expr<SomeInteger> &x,
+    const semantics::Scope &, FoldingContext &,
+    bool forElementalFunctionResult);
 extern template void CheckSpecificationExpr(const Expr<SubscriptInteger> &x,
-    const semantics::Scope &, FoldingContext &);
+    const semantics::Scope &, FoldingContext &,
+    bool forElementalFunctionResult);
 extern template void CheckSpecificationExpr(
     const std::optional<Expr<SomeType>> &x, const semantics::Scope &,
-    FoldingContext &);
+    FoldingContext &, bool forElementalFunctionResult);
 extern template void CheckSpecificationExpr(
     const std::optional<Expr<SomeInteger>> &x, const semantics::Scope &,
-    FoldingContext &);
+    FoldingContext &, bool forElementalFunctionResult);
 extern template void CheckSpecificationExpr(
     const std::optional<Expr<SubscriptInteger>> &x, const semantics::Scope &,
-    FoldingContext &);
+    FoldingContext &, bool forElementalFunctionResult);
 
 // Contiguity & "simple contiguity" (9.5.4)
 template <typename A>

diff  --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp
index 068514b514215..a4b152c60a72f 100644
--- a/flang/lib/Evaluate/check-expression.cpp
+++ b/flang/lib/Evaluate/check-expression.cpp
@@ -507,43 +507,6 @@ std::optional<Expr<SomeType>> NonPointerInitializationExpr(const Symbol &symbol,
   return std::nullopt;
 }
 
-static bool IsNonLocal(const semantics::Symbol &symbol) {
-  return semantics::IsDummy(symbol) || symbol.has<semantics::UseDetails>() ||
-      symbol.owner().kind() == semantics::Scope::Kind::Module ||
-      semantics::FindCommonBlockContaining(symbol) ||
-      symbol.has<semantics::HostAssocDetails>();
-}
-
-static bool IsPermissibleInquiry(const semantics::Symbol &firstSymbol,
-    const semantics::Symbol &lastSymbol, DescriptorInquiry::Field field,
-    const semantics::Scope &localScope) {
-  if (IsNonLocal(firstSymbol)) {
-    return true;
-  }
-  if (&localScope != &firstSymbol.owner()) {
-    return true;
-  }
-  // Inquiries on local objects may not access a deferred bound or length.
-  // (This code used to be a switch, but it proved impossible to write it
-  // thus without running afoul of bogus warnings from 
diff erent C++
-  // compilers.)
-  if (field == DescriptorInquiry::Field::Rank) {
-    return true; // always known
-  }
-  const auto *object{lastSymbol.detailsIf<semantics::ObjectEntityDetails>()};
-  if (field == DescriptorInquiry::Field::LowerBound ||
-      field == DescriptorInquiry::Field::Extent ||
-      field == DescriptorInquiry::Field::Stride) {
-    return object && !object->shape().CanBeDeferredShape();
-  }
-  if (field == DescriptorInquiry::Field::Len) {
-    return object && object->type() &&
-        object->type()->category() == semantics::DeclTypeSpec::Character &&
-        !object->type()->characterTypeSpec().length().isDeferred();
-  }
-  return false;
-}
-
 // Specification expression validation (10.1.11(2), C1010)
 class CheckSpecificationExprHelper
     : public AnyTraverse<CheckSpecificationExprHelper,
@@ -551,9 +514,10 @@ class CheckSpecificationExprHelper
 public:
   using Result = std::optional<std::string>;
   using Base = AnyTraverse<CheckSpecificationExprHelper, Result>;
-  explicit CheckSpecificationExprHelper(
-      const semantics::Scope &s, FoldingContext &context)
-      : Base{*this}, scope_{s}, context_{context} {}
+  explicit CheckSpecificationExprHelper(const semantics::Scope &s,
+      FoldingContext &context, bool forElementalFunctionResult)
+      : Base{*this}, scope_{s}, context_{context},
+        forElementalFunctionResult_{forElementalFunctionResult} {}
   using Base::operator();
 
   Result operator()(const CoarrayRef &) const { return "coindexed reference"; }
@@ -572,7 +536,10 @@ class CheckSpecificationExprHelper
              "reference variable '"s +
           ultimate.name().ToString() + "'";
     } else if (IsDummy(ultimate)) {
-      if (ultimate.attrs().test(semantics::Attr::OPTIONAL)) {
+      if (!inInquiry_ && forElementalFunctionResult_) {
+        return "dependence on value of dummy argument '"s +
+            ultimate.name().ToString() + "'";
+      } else if (ultimate.attrs().test(semantics::Attr::OPTIONAL)) {
         return "reference to OPTIONAL dummy argument '"s +
             ultimate.name().ToString() + "'";
       } else if (!inInquiry_ &&
@@ -629,8 +596,8 @@ class CheckSpecificationExprHelper
     // expressions will have been converted to expressions over descriptor
     // inquiries by Fold().
     // Catch REAL, ALLOCATABLE :: X(:); REAL :: Y(SIZE(X))
-    if (IsPermissibleInquiry(x.base().GetFirstSymbol(),
-            x.base().GetLastSymbol(), x.field(), scope_)) {
+    if (IsPermissibleInquiry(
+            x.base().GetFirstSymbol(), x.base().GetLastSymbol(), x.field())) {
       auto restorer{common::ScopedSet(inInquiry_, true)};
       return (*this)(x.base());
     } else if (IsConstantExpr(x)) {
@@ -641,10 +608,18 @@ class CheckSpecificationExprHelper
   }
 
   Result operator()(const TypeParamInquiry &inq) const {
-    if (scope_.IsDerivedType() && !IsConstantExpr(inq) &&
-        inq.base() /* X%T, not local T */) { // C750, C754
-      return "non-constant reference to a type parameter inquiry not "
-             "allowed for derived type components or type parameter values";
+    if (scope_.IsDerivedType()) {
+      if (!IsConstantExpr(inq) &&
+          inq.base() /* X%T, not local T */) { // C750, C754
+        return "non-constant reference to a type parameter inquiry not allowed "
+               "for derived type components or type parameter values";
+      }
+    } else if (inq.base() &&
+        IsInquiryAlwaysPermissible(inq.base()->GetFirstSymbol())) {
+      auto restorer{common::ScopedSet(inInquiry_, true)};
+      return (*this)(inq.base());
+    } else if (!IsConstantExpr(inq)) {
+      return "non-constant type parameter inquiry not allowed for local object";
     }
     return std::nullopt;
   }
@@ -719,19 +694,19 @@ class CheckSpecificationExprHelper
                 intrin.name == "is_contiguous") { // ok
             } else if (intrin.name == "len" &&
                 IsPermissibleInquiry(dataRef->GetFirstSymbol(),
-                    dataRef->GetLastSymbol(), DescriptorInquiry::Field::Len,
-                    scope_)) { // ok
+                    dataRef->GetLastSymbol(),
+                    DescriptorInquiry::Field::Len)) { // ok
             } else if (intrin.name == "lbound" &&
                 IsPermissibleInquiry(dataRef->GetFirstSymbol(),
                     dataRef->GetLastSymbol(),
-                    DescriptorInquiry::Field::LowerBound, scope_)) { // ok
+                    DescriptorInquiry::Field::LowerBound)) { // ok
             } else if ((intrin.name == "shape" || intrin.name == "size" ||
                            intrin.name == "sizeof" ||
                            intrin.name == "storage_size" ||
                            intrin.name == "ubound") &&
                 IsPermissibleInquiry(dataRef->GetFirstSymbol(),
-                    dataRef->GetLastSymbol(), DescriptorInquiry::Field::Extent,
-                    scope_)) { // ok
+                    dataRef->GetLastSymbol(),
+                    DescriptorInquiry::Field::Extent)) { // ok
             } else {
               return "non-constant inquiry function '"s + intrin.name +
                   "' not allowed for local object";
@@ -750,32 +725,86 @@ class CheckSpecificationExprHelper
   // Contextual information: this flag is true when in an argument to
   // an inquiry intrinsic like SIZE().
   mutable bool inInquiry_{false};
+  bool forElementalFunctionResult_{false}; // F'2023 C15121
   const std::set<std::string> badIntrinsicsForComponents_{
       "allocated", "associated", "extends_type_of", "present", "same_type_as"};
+
+  bool IsInquiryAlwaysPermissible(const semantics::Symbol &) const;
+  bool IsPermissibleInquiry(const semantics::Symbol &firstSymbol,
+      const semantics::Symbol &lastSymbol,
+      DescriptorInquiry::Field field) const;
 };
 
+bool CheckSpecificationExprHelper::IsInquiryAlwaysPermissible(
+    const semantics::Symbol &symbol) const {
+  if (&symbol.owner() != &scope_ || symbol.has<semantics::UseDetails>() ||
+      symbol.owner().kind() == semantics::Scope::Kind::Module ||
+      semantics::FindCommonBlockContaining(symbol) ||
+      symbol.has<semantics::HostAssocDetails>()) {
+    return true; // it's nonlocal
+  } else if (semantics::IsDummy(symbol) && !forElementalFunctionResult_) {
+    return true;
+  } else {
+    return false;
+  }
+}
+
+bool CheckSpecificationExprHelper::IsPermissibleInquiry(
+    const semantics::Symbol &firstSymbol, const semantics::Symbol &lastSymbol,
+    DescriptorInquiry::Field field) const {
+  if (IsInquiryAlwaysPermissible(firstSymbol)) {
+    return true;
+  }
+  // Inquiries on local objects may not access a deferred bound or length.
+  // (This code used to be a switch, but it proved impossible to write it
+  // thus without running afoul of bogus warnings from 
diff erent C++
+  // compilers.)
+  if (field == DescriptorInquiry::Field::Rank) {
+    return true; // always known
+  }
+  const auto *object{lastSymbol.detailsIf<semantics::ObjectEntityDetails>()};
+  if (field == DescriptorInquiry::Field::LowerBound ||
+      field == DescriptorInquiry::Field::Extent ||
+      field == DescriptorInquiry::Field::Stride) {
+    return object && !object->shape().CanBeDeferredShape();
+  }
+  if (field == DescriptorInquiry::Field::Len) {
+    return object && object->type() &&
+        object->type()->category() == semantics::DeclTypeSpec::Character &&
+        !object->type()->characterTypeSpec().length().isDeferred();
+  }
+  return false;
+}
+
 template <typename A>
-void CheckSpecificationExpr(
-    const A &x, const semantics::Scope &scope, FoldingContext &context) {
-  if (auto why{CheckSpecificationExprHelper{scope, context}(x)}) {
-    context.messages().Say(
-        "Invalid specification expression: %s"_err_en_US, *why);
+void CheckSpecificationExpr(const A &x, const semantics::Scope &scope,
+    FoldingContext &context, bool forElementalFunctionResult) {
+  if (auto why{CheckSpecificationExprHelper{
+          scope, context, forElementalFunctionResult}(x)}) {
+    context.messages().Say("Invalid specification expression%s: %s"_err_en_US,
+        forElementalFunctionResult ? " for elemental function result" : "",
+        *why);
   }
 }
 
-template void CheckSpecificationExpr(
-    const Expr<SomeType> &, const semantics::Scope &, FoldingContext &);
-template void CheckSpecificationExpr(
-    const Expr<SomeInteger> &, const semantics::Scope &, FoldingContext &);
-template void CheckSpecificationExpr(
-    const Expr<SubscriptInteger> &, const semantics::Scope &, FoldingContext &);
+template void CheckSpecificationExpr(const Expr<SomeType> &,
+    const semantics::Scope &, FoldingContext &,
+    bool forElementalFunctionResult);
+template void CheckSpecificationExpr(const Expr<SomeInteger> &,
+    const semantics::Scope &, FoldingContext &,
+    bool forElementalFunctionResult);
+template void CheckSpecificationExpr(const Expr<SubscriptInteger> &,
+    const semantics::Scope &, FoldingContext &,
+    bool forElementalFunctionResult);
 template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &,
-    const semantics::Scope &, FoldingContext &);
+    const semantics::Scope &, FoldingContext &,
+    bool forElementalFunctionResult);
 template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &,
-    const semantics::Scope &, FoldingContext &);
+    const semantics::Scope &, FoldingContext &,
+    bool forElementalFunctionResult);
 template void CheckSpecificationExpr(
     const std::optional<Expr<SubscriptInteger>> &, const semantics::Scope &,
-    FoldingContext &);
+    FoldingContext &, bool forElementalFunctionResult);
 
 // IsContiguous() -- 9.5.4
 class IsContiguousHelper

diff  --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index a55b360cee7ce..92bfea2496223 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -40,7 +40,9 @@ class CheckHelper {
   SemanticsContext &context() { return context_; }
   void Check() { Check(context_.globalScope()); }
   void Check(const ParamValue &, bool canBeAssumed);
-  void Check(const Bound &bound) { CheckSpecExpr(bound.GetExplicit()); }
+  void Check(const Bound &bound) {
+    CheckSpecExpr(bound.GetExplicit(), /*forElementalFunctionResult=*/false);
+  }
   void Check(const ShapeSpec &spec) {
     Check(spec.lbound());
     Check(spec.ubound());
@@ -53,8 +55,10 @@ class CheckHelper {
   const Procedure *Characterize(const Symbol &);
 
 private:
-  template <typename A> void CheckSpecExpr(const A &x) {
-    evaluate::CheckSpecificationExpr(x, DEREF(scope_), foldingContext_);
+  template <typename A>
+  void CheckSpecExpr(const A &x, bool forElementalFunctionResult) {
+    evaluate::CheckSpecificationExpr(
+        x, DEREF(scope_), foldingContext_, forElementalFunctionResult);
   }
   void CheckValue(const Symbol &, const DerivedTypeSpec *);
   void CheckVolatile(const Symbol &, const DerivedTypeSpec *);
@@ -222,7 +226,7 @@ void CheckHelper::Check(const ParamValue &value, bool canBeAssumed) {
           "An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, character named constant, or external function result"_err_en_US);
     }
   } else {
-    CheckSpecExpr(value.GetExplicit());
+    CheckSpecExpr(value.GetExplicit(), /*forElementalFunctionResult=*/false);
   }
 }
 
@@ -378,24 +382,31 @@ void CheckHelper::Check(const Symbol &symbol) {
     } else {
       Check(*type, canHaveAssumedParameter);
     }
-    if (InPure() && InFunction() && IsFunctionResult(symbol)) {
-      if (type->IsPolymorphic() && IsAllocatable(symbol)) { // C1585
-        messages_.Say(
-            "Result of pure function may not be both polymorphic and ALLOCATABLE"_err_en_US);
-      }
-      if (derived) {
-        // These cases would be caught be the general validation of local
-        // variables in a pure context, but these messages are more specific.
-        if (HasImpureFinal(symbol)) { // C1584
+    if (InFunction() && IsFunctionResult(symbol)) {
+      if (InPure()) {
+        if (type->IsPolymorphic() && IsAllocatable(symbol)) { // C1585
           messages_.Say(
-              "Result of pure function may not have an impure FINAL subroutine"_err_en_US);
+              "Result of pure function may not be both polymorphic and ALLOCATABLE"_err_en_US);
         }
-        if (auto bad{FindPolymorphicAllocatableUltimateComponent(*derived)}) {
-          SayWithDeclaration(*bad,
-              "Result of pure function may not have polymorphic ALLOCATABLE ultimate component '%s'"_err_en_US,
-              bad.BuildResultDesignatorName());
+        if (derived) {
+          // These cases would be caught be the general validation of local
+          // variables in a pure context, but these messages are more specific.
+          if (HasImpureFinal(symbol)) { // C1584
+            messages_.Say(
+                "Result of pure function may not have an impure FINAL subroutine"_err_en_US);
+          }
+          if (auto bad{FindPolymorphicAllocatableUltimateComponent(*derived)}) {
+            SayWithDeclaration(*bad,
+                "Result of pure function may not have polymorphic ALLOCATABLE ultimate component '%s'"_err_en_US,
+                bad.BuildResultDesignatorName());
+          }
         }
       }
+      if (InElemental() && isChar) { // F'2023 C15121
+        CheckSpecExpr(type->characterTypeSpec().length().GetExplicit(),
+            /*forElementalFunctionResult=*/true);
+        // TODO: check PDT LEN parameters
+      }
     }
   }
   if (IsAssumedLengthCharacter(symbol) && IsFunction(symbol)) { // C723

diff  --git a/flang/test/Lower/HLFIR/elemental-result-length.f90 b/flang/test/Lower/HLFIR/elemental-result-length.f90
index 0aaf7c93770c9..278ef013d952e 100644
--- a/flang/test/Lower/HLFIR/elemental-result-length.f90
+++ b/flang/test/Lower/HLFIR/elemental-result-length.f90
@@ -8,12 +8,6 @@ elemental function fct1(a, b) result(t)
   t = a // b
 end function
 
-elemental function fct2(c) result(t)
-  integer, intent(in) :: c
-  character(c) :: t
-
-end function
-
 subroutine sub2(a,b,c)
   character(*), intent(inout) :: c
   character(*), intent(in) :: a, b
@@ -42,25 +36,6 @@ subroutine sub2(a,b,c)
 ! CHECK: %[[RES:.*]] = fir.alloca !fir.char<1,?>(%[[RES_LENGTH]] : index) {bindc_name = ".result"}
 ! CHECK: fir.call @_QMm1Pfct1
 
-subroutine sub3(c)
-  character(*), intent(inout) :: c(:)
-
-  c = fct2(10)
-end subroutine
-
-! CHECK-LABEL: func.func @_QMm1Psub3(
-! CHECK-SAME: %[[ARG0:.*]]: !fir.box<!fir.array<?x!fir.char<1,?>>> {fir.bindc_name = "c"}) {
-! CHECK: %[[C10:.*]] = arith.constant 10 : i32
-! CHECK: %[[C:.*]]:2 = hlfir.declare %[[ARG0]] dummy_scope %{{.*}} {fortran_attrs = #fir.var_attrs<intent_inout>, uniq_name = "_QMm1Fsub3Ec"} : (!fir.box<!fir.array<?x!fir.char<1,?>>>, !fir.dscope) -> (!fir.box<!fir.array<?x!fir.char<1,?>>>, !fir.box<!fir.array<?x!fir.char<1,?>>>)
-! CHECK: %[[ASSOC:.*]]:3 = hlfir.associate %[[C10]] {adapt.valuebyref} : (i32) -> (!fir.ref<i32>, !fir.ref<i32>, i1)
-! CHECK: %[[INPUT_ARG0:.*]]:2 = hlfir.declare %[[ASSOC]]#1 {fortran_attrs = #fir.var_attrs<intent_in>, uniq_name = "_QMm1Ffct2Ec"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
-! CHECK: %[[LOAD_INPUT_ARG0:.*]] = fir.load %[[INPUT_ARG0]]#0 : !fir.ref<i32>
-! CHECK: %[[LOAD_INPUT_ARG0_IDX:.*]] = fir.convert %[[LOAD_INPUT_ARG0]] : (i32) -> index
-! CHECK: %[[CMPI:.*]] = arith.cmpi sgt, %[[LOAD_INPUT_ARG0_IDX]], %c0{{.*}} : index
-! CHECK: %[[LENGTH:.*]] = arith.select %[[CMPI]], %[[LOAD_INPUT_ARG0_IDX]], %c0{{.*}} : index
-! CHECK: %[[RES:.*]] = fir.alloca !fir.char<1,?>(%[[LENGTH]] : index) {bindc_name = ".result"}
-! CHECK: fir.call @_QMm1Pfct2
-
 subroutine sub4(a,b,c)
   character(*), intent(inout) :: c(:)
   character(*), intent(in) :: a(:), b(:)

diff  --git a/flang/test/Semantics/elemental01.f90 b/flang/test/Semantics/elemental01.f90
index 6b2b25907ef60..f0e501e9d8311 100644
--- a/flang/test/Semantics/elemental01.f90
+++ b/flang/test/Semantics/elemental01.f90
@@ -47,3 +47,41 @@ elemental function ptrf(n)
   !ERROR: The result of an ELEMENTAL function may not be a POINTER
   real, pointer :: ptrf
 end function
+
+module m
+  integer modvar
+  type t
+    character(:), allocatable :: c
+  end type
+  type pdt(L)
+    integer, len :: L
+  end type
+  type container
+    class(pdt(:)), allocatable :: c
+  end type
+ contains
+  !ERROR: Invalid specification expression for elemental function result: dependence on value of dummy argument 'n'
+  elemental character(n) function bad1(n)
+    integer, intent(in) :: n
+  end
+  !ERROR: Invalid specification expression for elemental function result: non-constant inquiry function 'len' not allowed for local object
+  elemental character(x%c%len) function bad2(x)
+    type(t), intent(in) :: x
+  end
+  !ERROR: Invalid specification expression for elemental function result: non-constant type parameter inquiry not allowed for local object
+  elemental character(x%c%L) function bad3(x)
+    class(container), intent(in) :: x
+  end
+  elemental character(len(x)) function ok1(x) ! ok
+    character(*), intent(in) :: x
+  end
+  elemental character(modvar) function ok2(x) ! ok
+    character(*), intent(in) :: x
+  end
+  elemental character(len(x)) function ok3(x) ! ok
+    character(modvar), intent(in) :: x
+  end
+  elemental character(storage_size(x)) function ok4(x) ! ok
+    class(*), intent(in) :: x
+  end
+end


        


More information about the flang-commits mailing list