[flang] Implement semantic checks for ELEMENTAL subprograms

[klausler]

Summary

Adds missing semantic checks for ELEMENTAL functions and subroutines,
their dummy arguments, and their results from F'2018 15.8.1 C15100-15102.

[klausler]

Cope with more test infrastructure churn.

[PeteSteinfeld]

Looks great!

Thanks for doing this.

flang/lib/Semantics/check-declarations.cpp

private:
   void CheckEquivalenceSet(const EquivalenceSet &);
   void CheckBlockData(const Scope &);
   void CheckGenericOps(const Scope &);
   bool CheckConflicting(const Symbol &, Attr, Attr);
   void WarnMissingFinal(const Symbol &);
   bool InPure() const {
     return innermostSymbol_ && IsPureProcedure(*innermostSymbol_);
   }
+  bool InElemental() const {
+    return innermostSymbol_ && innermostSymbol_->attrs().test(Attr::ELEMENTAL);
+  }
   bool InFunction() const {
     return innermostSymbol_ && IsFunction(*innermostSymbol_);
   }
   template <typename... A>
   void SayWithDeclaration(const Symbol &symbol, A &&...x) {
     if (parser::Message * msg{messages_.Say(std::forward<A>(x)...)}) {
       if (messages_.at().begin() != symbol.name().begin()) {
         evaluate::AttachDeclaration(*msg, symbol);
if (InPure() && !IsStmtFunction(DEREF(innermostSymbol_)) &&
       symbol.attrs().test(Attr::INTENT_OUT) ||
       symbol.attrs().test(Attr::INTENT_INOUT)) {
     messages_.Say("INTENT attributes may apply only to a dummy "
                   "argument"_err_en_US); // C843
   } else if (IsOptional(symbol)) {
     messages_.Say("OPTIONAL attribute may apply only to a dummy "
                   "argument"_err_en_US); // C849
   }
+  if (InElemental()) {
+    if (details.isDummy()) { // C15100
+      if (details.shape().Rank() > 0) {
+        messages_.Say(
+            "A dummy argument of an ELEMENTAL procedure must be scalar"_err_en_US);
+      }
+      if (IsAllocatable(symbol)) {
+        messages_.Say(
+            "A dummy argument of an ELEMENTAL procedure may not be ALLOCATABLE"_err_en_US);
+      }
+      if (IsCoarray(symbol)) {
+        messages_.Say(
+            "A dummy argument of an ELEMENTAL procedure may not be a coarray"_err_en_US);
+      }
+      if (IsPointer(symbol)) {
+        messages_.Say(
+            "A dummy argument of an ELEMENTAL procedure may not be a POINTER"_err_en_US);
+      }
+      if (!symbol.attrs().HasAny(Attrs{Attr::VALUE, Attr::INTENT_IN,
+              Attr::INTENT_INOUT, Attr::INTENT_OUT})) { // C15102
+        messages_.Say(
+            "A dummy argument of an ELEMENTAL procedure must have an INTENT() or VALUE attribute"_err_en_US);
+      }
+    } else if (IsFunctionResult(symbol)) { // C15101
+      if (details.shape().Rank() > 0) {
+        messages_.Say(
+            "The result of an ELEMENTAL function must be scalar"_err_en_US);
+      }
+      if (IsAllocatable(symbol)) {
+        messages_.Say(
+            "The result of an ELEMENTAL function may not be ALLOCATABLE"_err_en_US);
+      }
+      if (IsPointer(symbol)) {
+        messages_.Say(
+            "The result of an ELEMENTAL function may not be a POINTER"_err_en_US);
+      }
+    }
+  }
   if (HasDeclarationInitializer(symbol)) { // C808; ignore DATA initialization
     CheckPointerInitialization(symbol);
     if (IsAutomatic(symbol)) {
       messages_.Say(
           "An automatic variable or component must not be initialized"_err_en_US);
     } else if (IsDummy(symbol)) {
       messages_.Say("A dummy argument must not be initialized"_err_en_US);
     } else if (IsFunctionResult(symbol)) {
void CheckHelper::CheckProcEntity(
   if (details.isDummy()) {
     if (!symbol.attrs().test(Attr::POINTER) && // C843
         (symbol.attrs().test(Attr::INTENT_IN) ||
             symbol.attrs().test(Attr::INTENT_OUT) ||
             symbol.attrs().test(Attr::INTENT_INOUT))) {
       messages_.Say("A dummy procedure without the POINTER attribute"
                     " may not have an INTENT attribute"_err_en_US);
     }
-
+    if (InElemental()) { // C15100
+      messages_.Say(
+          "An ELEMENTAL subprogram may not have a dummy procedure"_err_en_US);
+    }
     const Symbol *interface { details.interface().symbol() };
     if (!symbol.attrs().test(Attr::INTRINSIC) &&
         (symbol.attrs().test(Attr::ELEMENTAL) ||
             (interface && !interface->attrs().test(Attr::INTRINSIC) &&
                 interface->attrs().test(Attr::ELEMENTAL)))) {
       // There's no explicit constraint or "shall" that we can find in the
       // standard for this check, but it seems to be implied in multiple
       // sites, and ELEMENTAL non-intrinsic actual arguments *are*
if (const Scope * entryScope{details.entryScope()}) {
     if (error) {
       if (auto *msg{messages_.Say(symbol.name(), *error)}) {
         if (subprogram) {
           msg->Attach(subprogram->name(), "Containing subprogram"_en_US);
         }
       }
     }
   }
+  if (symbol.attrs().test(Attr::ELEMENTAL)) {
     // See comment on the similar check in CheckProcEntity()
-  if (details.isDummy() && symbol.attrs().test(Attr::ELEMENTAL)) {
+    if (details.isDummy()) {
       messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
+    } else if (details.dummyArgs().empty()) {
+      messages_.Say(
+          "An ELEMENTAL subprogram must have at least one dummy argument"_err_en_US);
+    } else {
+      for (const Symbol *dummy : details.dummyArgs()) {
+        if (!dummy) { // C15100
+          messages_.Say(
+              "An ELEMENTAL subroutine may not have an alternate return dummy argument"_err_en_US);
+        }
+      }
+    }
   }
 }
 
 void CheckHelper::CheckDerivedType(
     const Symbol &derivedType, const DerivedTypeDetails &details) {
   if (details.isForwardReferenced() && !context_.HasError(derivedType)) {
     messages_.Say("The derived type '%s' has not been defined"_err_en_US,
         derivedType.name());

flang/test/Evaluate/folding28.f90

-! RUN: %S/test_folding.sh %s %t %flang_fc1
-! REQUIRES: shell
+! RUN: %python %S/test_folding.py %s %flang_fc1
 ! Tests folding of SQRT()
 module m
   implicit none
   ! +Inf
   real(8), parameter :: inf8 = z'7ff0000000000000'
   logical, parameter :: test_inf8 = sqrt(inf8) == inf8
   ! max finite
   real(8), parameter :: h8 = huge(1.0_8), h8z = z'7fefffffffffffff'

flang/test/Semantics/assign03.f90

subroutine s5
     p_pure => f_impure
   contains
     pure integer function f_pure()
       f_pure = 1
     end
     integer function f_impure()
       f_impure = 1
     end
-    elemental integer function f_elemental()
-      f_elemental = 1
+    elemental integer function f_elemental(n)
+      real, value :: n
+      f_elemental = n
     end
   end
 
   ! 10.2.2.4(4)
   subroutine s6
     procedure(s), pointer :: p, q
     procedure(), pointer :: r
     external :: s_external

flang/test/Semantics/associated.f90

real function realFunc(x)
     real, intent(in) :: x
     realFunc = x
   end function
 
   pure integer function pureFunc()
     pureFunc = 343
   end function pureFunc
 
-  elemental integer function elementalFunc()
-    elementalFunc = 343
+  elemental integer function elementalFunc(n)
+    integer, value :: n
+    elementalFunc = n
   end function elementalFunc
 
   subroutine subr(i)
     integer :: i
   end subroutine subr
 
   subroutine test()
     integer :: intVar

flang/test/Semantics/elemental01.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Tests ELEMENTAL subprogram constraints C15100-15102
+
+!ERROR: An ELEMENTAL subprogram must have at least one dummy argument
+elemental integer function noargs
+  noargs = 1
+end function
+
+!ERROR: An ELEMENTAL subroutine may not have an alternate return dummy argument
+elemental subroutine altret(*)
+end subroutine
+
+elemental subroutine arrarg(a)
+  !ERROR: A dummy argument of an ELEMENTAL procedure must be scalar
+  real, intent(in) :: a(1)
+end subroutine
+
+elemental subroutine alloarg(a)
+  !ERROR: A dummy argument of an ELEMENTAL procedure may not be ALLOCATABLE
+  real, intent(in), allocatable :: a
+end subroutine
+
+elemental subroutine coarg(a)
+  !ERROR: A dummy argument of an ELEMENTAL procedure may not be a coarray
+  real, intent(in) :: a[*]
+end subroutine
+
+elemental subroutine ptrarg(a)
+  !ERROR: A dummy argument of an ELEMENTAL procedure may not be a POINTER
+  real, intent(in), pointer :: a
+end subroutine
+
+impure elemental subroutine barearg(a)
+  !ERROR: A dummy argument of an ELEMENTAL procedure must have an INTENT() or VALUE attribute
+  real :: a
+end subroutine
+
+elemental function arrf(n)
+  integer, value :: n
+  !ERROR: The result of an ELEMENTAL function must be scalar
+  real :: arrf(n)
+end function
+
+elemental function allof(n)
+  integer, value :: n
+  !ERROR: The result of an ELEMENTAL function may not be ALLOCATABLE
+  real, allocatable :: allof
+end function
+
+elemental function ptrf(n)
+  integer, value :: n
+  !ERROR: The result of an ELEMENTAL function may not be a POINTER
+  real, pointer :: ptrf
+end function

flang/test/Semantics/final02.f90

  contains
   subroutine t1f0(x)
     type(t1) :: x
   end subroutine
   subroutine t1f1(x)
     type(t1) :: x(:)
   end subroutine
   impure elemental subroutine t2fe(x)
-    type(t2) :: x
+    type(t2), intent(in out) :: x
   end subroutine
-  impure elemental subroutine t3far(x)
+  subroutine t3far(x)
     type(t3) :: x(..)
   end subroutine
 end module
 
 subroutine test ! *not* a main program, since they don't finalize locals
   use m
   !CHECK-NOT: 'scalar1' of derived type 't1'
   type(t1) :: scalar1

flang/test/Semantics/resolve83.f90

 !      declaration-type-spec, ELEMENTAL, IMPURE, MODULE, NON_RECURSIVE, 
 !      PURE, RECURSIVE
 
     !ERROR: FUNCTION prefix cannot specify the type more than once
     real pure real function realFunc()
     end function realFunc
 
     !WARNING: Attribute 'ELEMENTAL' cannot be used more than once
-    elemental real elemental function elementalFunc()
+    elemental real elemental function elementalFunc(x)
+      real, value :: x
+      elementalFunc = x
     end function elementalFunc
 
     !WARNING: Attribute 'IMPURE' cannot be used more than once
     impure real impure function impureFunc()
     end function impureFunc
 
     !WARNING: Attribute 'PURE' cannot be used more than once
     pure real pure function pureFunc()

flang/test/Semantics/typeinfo01.f90

  contains
   subroutine s1(x)
     type(t) :: x(:)
   end subroutine
   subroutine s2(x)
     type(t) :: x(3,3)
   end subroutine
   impure elemental subroutine s3(x)
-    type(t) :: x
+    type(t), intent(in) :: x
   end subroutine
 !CHECK: .dt.t, SAVE, TARGET (CompilerCreated): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=0_8,uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=NULL(),component=NULL(),procptr=NULL(),special=.s.t,specialbitset=3200_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=0_1,nofinalizationneeded=0_1)
 !CHECK: .s.t, SAVE, TARGET (CompilerCreated): ObjectEntity type: TYPE(specialbinding) shape: 0_8:2_8 init:[specialbinding::specialbinding(which=7_1,isargdescriptorset=0_1,proc=s3),specialbinding(which=10_1,isargdescriptorset=1_1,proc=s1),specialbinding(which=11_1,isargdescriptorset=0_1,proc=s2)]
 end module
 
 module m09
   type :: t
    contains