[flang] Implement semantic checks for ELEMENTAL subprograms

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

Differential Revision: https://reviews.llvm.org/D109380

flang/lib/Semantics/check-declarations.cpp

@@ -90,6 +90,9 @@ private:
   bool InPure() const {
     return innermostSymbol_ && IsPureProcedure(*innermostSymbol_);
   }
+  bool InElemental() const {
+    return innermostSymbol_ && innermostSymbol_->attrs().test(Attr::ELEMENTAL);
+  }
   bool InFunction() const {
     return innermostSymbol_ && IsFunction(*innermostSymbol_);
   }
@@ -526,6 +529,44 @@ void CheckHelper::CheckObjectEntity(
     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)) {
@@ -689,7 +730,10 @@ void CheckHelper::CheckProcEntity(
       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) ||
@@ -845,9 +889,21 @@ void CheckHelper::CheckSubprogram(
       }
     }
   }
-  // See comment on the similar check in CheckProcEntity()
-  if (details.isDummy() && symbol.attrs().test(Attr::ELEMENTAL)) {
-    messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
+  if (symbol.attrs().test(Attr::ELEMENTAL)) {
+    // See comment on the similar check in CheckProcEntity()
+    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);
+        }
+      }
+    }
   }
 }
 

flang/test/Evaluate/folding28.f90

@@ -1,5 +1,4 @@
-! 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

flang/test/Semantics/assign03.f90

@@ -79,8 +79,9 @@ contains
     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
 

flang/test/Semantics/associated.f90

@@ -27,8 +27,9 @@ subroutine assoc()
     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)

flang/test/Semantics/elemental01.f90

@@ -0,0 +1,54 @@
+! 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

@@ -33,9 +33,9 @@ module m
     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

flang/test/Semantics/resolve83.f90

@@ -28,7 +28,9 @@ contains
     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

flang/test/Semantics/typeinfo01.f90

@@ -121,7 +121,7 @@ module m08
     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)]