[flang] Enforce F'2023 C15121

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.

Author: klausler

flang/lib/Semantics/check-declarations.cpp

@@ -243,6 +243,31 @@ void CheckHelper::Check(
   }
 }
 
+// Checks an elemental function result type parameter specification
+// expression for an unacceptable use of a dummy argument.
+class BadDummyChecker : public evaluate::AnyTraverse<BadDummyChecker, bool> {
+public:
+  using Base = evaluate::AnyTraverse<BadDummyChecker, bool>;
+  BadDummyChecker(parser::ContextualMessages &messages, const Scope &scope)
+      : Base{*this}, messages_{messages}, scope_{scope} {}
+  using Base::operator();
+  bool operator()(const evaluate::DescriptorInquiry &) {
+    return false; // shield base() of inquiry from further checking
+  }
+  bool operator()(const Symbol &symbol) {
+    if (&symbol.owner() == &scope_ && IsDummy(symbol)) {
+      messages_.Say(
+          "Specification expression for elemental function result may not depend on dummy argument '%s''s value"_err_en_US,
+          symbol.name());
+    }
+    return false;
+  }
+
+private:
+  parser::ContextualMessages &messages_;
+  const Scope &scope_;
+};
+
 void CheckHelper::Check(const Symbol &symbol) {
   if (symbol.name().size() > common::maxNameLen &&
       &symbol == &symbol.GetUltimate()) {
@@ -378,24 +403,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
+        BadDummyChecker{messages_, symbol.owner()}(
+            type->characterTypeSpec().length().GetExplicit());
+        // TODO: check PDT LEN parameters
+      }
     }
   }
   if (IsAssumedLengthCharacter(symbol) && IsFunction(symbol)) { // C723

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(:)

flang/test/Semantics/elemental01.f90

@@ -47,3 +47,28 @@ 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
+ contains
+  !ERROR: Specification expression for elemental function result may not depend on dummy argument 'n''s value
+  elemental character(n) function bad1(n)
+    integer, intent(in) :: n
+  end
+  !ERROR: Specification expression for elemental function result may not depend on dummy argument 'x''s value
+  elemental character(x%c%len) function bad2(x)
+    type(t), 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
+end