[flang] Add IsElementalProcedure() predicate

[klausler]

Summary

Replace most tests of the explicit Attr::ELEMENTAL symbol flag with
a new predicate IsElementalProcedure() that works correctly for alternate
ENTRY points and does the right thing for procedure interfaces that
reference elemental intrinsic functions like SIN() whose elemental
nature does not propagate.

[jeanPerier]

Looks good

[jeanPerier]

@klausler, they are failures when processing the intrinsic modules on Windows (see bots).

[klausler]

In D129022#3627759, @jeanPerier wrote:

@klausler, they are failures when processing the intrinsic modules on Windows (see bots).

Both the Windows and Debian build bots look fine here.

flang/include/flang/Evaluate/tools.h

 const Symbol *GetMainEntry(const Symbol *);
 
 // These functions are used in Evaluate so they are defined here rather than in
 // Semantics to avoid a link-time dependency on Semantics.
 // All of these apply GetUltimate() or ResolveAssociations() to their arguments.
 bool IsVariableName(const Symbol &);
 bool IsPureProcedure(const Symbol &);
 bool IsPureProcedure(const Scope &);
+bool IsElementalProcedure(const Symbol &);
 bool IsFunction(const Symbol &);
 bool IsFunction(const Scope &);
 bool IsProcedure(const Symbol &);
 bool IsProcedure(const Scope &);
 bool IsProcedurePointer(const Symbol &);
 bool IsAutomatic(const Symbol &);
 bool IsSaved(const Symbol &); // saved implicitly or explicitly
 bool IsDummy(const Symbol &);

flang/lib/Evaluate/call.cpp

if (const auto *proc{ultimate.detailsIf<semantics::ProcEntityDetails>()}) {
       return &ultimate;
     }
   }
   return nullptr;
 }
 
 bool ProcedureDesignator::IsElemental() const {
   if (const Symbol * interface{GetInterfaceSymbol()}) {
-    return interface->attrs().test(semantics::Attr::ELEMENTAL);
+    return IsElementalProcedure(*interface);
   } else if (const Symbol * symbol{GetSymbol()}) {
-    return symbol->attrs().test(semantics::Attr::ELEMENTAL);
+    return IsElementalProcedure(*symbol);
   } else if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&u)}) {
     return intrinsic->characteristics.value().attrs.test(
         characteristics::Procedure::Attr::Elemental);
   } else {
     DIE("ProcedureDesignator::IsElemental(): no case");
   }
   return false;
 }

flang/lib/Evaluate/tools.cpp

bool IsVariableName(const Symbol &original) {
   }
 }
 
 bool IsPureProcedure(const Symbol &original) {
   // An ENTRY is pure if its containing subprogram is
   const Symbol &symbol{DEREF(GetMainEntry(&original.GetUltimate()))};
   if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) {
     if (const Symbol * procInterface{procDetails->interface().symbol()}) {
-      // procedure component with a pure interface
+      // procedure with a pure interface
       return IsPureProcedure(*procInterface);
     }
   } else if (const auto *details{symbol.detailsIf<ProcBindingDetails>()}) {
     return IsPureProcedure(details->symbol());
   } else if (!IsProcedure(symbol)) {
     return false;
   }
   if (IsStmtFunction(symbol)) {
return symbol.attrs().test(Attr::PURE) ||
           !symbol.attrs().test(Attr::IMPURE));
 }
 
 bool IsPureProcedure(const Scope &scope) {
   const Symbol *symbol{scope.GetSymbol()};
   return symbol && IsPureProcedure(*symbol);
 }
 
+bool IsElementalProcedure(const Symbol &original) {
+  // An ENTRY is elemental if its containing subprogram is
+  const Symbol &symbol{DEREF(GetMainEntry(&original.GetUltimate()))};
+  if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) {
+    if (const Symbol * procInterface{procDetails->interface().symbol()}) {
+      // procedure with an elemental interface, ignoring the elemental
+      // aspect of intrinsic functions
+      return !procInterface->attrs().test(Attr::INTRINSIC) &&
+          IsElementalProcedure(*procInterface);
+    }
+  } else if (const auto *details{symbol.detailsIf<ProcBindingDetails>()}) {
+    return IsElementalProcedure(details->symbol());
+  } else if (!IsProcedure(symbol)) {
+    return false;
+  }
+  return symbol.attrs().test(Attr::ELEMENTAL);
+}
+
 bool IsFunction(const Symbol &symbol) {
   const Symbol &ultimate{symbol.GetUltimate()};
   return ultimate.test(Symbol::Flag::Function) ||
       (!ultimate.test(Symbol::Flag::Subroutine) &&
           common::visit(
               common::visitors{
                   [](const SubprogramDetails &x) { return x.isFunction(); },
                   [](const ProcEntityDetails &x) {

flang/lib/Semantics/check-declarations.cpp

private:
   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);
+    return innermostSymbol_ && IsElementalProcedure(*innermostSymbol_);
   }
   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()) {
if (IsAssumedLengthCharacter(symbol) && IsExternal(symbol)) { // C723
     if (symbol.attrs().test(Attr::RECURSIVE)) {
       messages_.Say(
           "An assumed-length CHARACTER(*) function cannot be RECURSIVE"_err_en_US);
     }
     if (symbol.Rank() > 0) {
       messages_.Say(
           "An assumed-length CHARACTER(*) function cannot return an array"_err_en_US);
     }
-    if (symbol.attrs().test(Attr::PURE)) {
-      messages_.Say(
-          "An assumed-length CHARACTER(*) function cannot be PURE"_err_en_US);
-    }
-    if (symbol.attrs().test(Attr::ELEMENTAL)) {
+    if (IsElementalProcedure(symbol)) {
       messages_.Say(
           "An assumed-length CHARACTER(*) function cannot be ELEMENTAL"_err_en_US);
+    } else if (IsPureProcedure(symbol)) {
+      messages_.Say(
+          "An assumed-length CHARACTER(*) function cannot be PURE"_err_en_US);
     }
     if (const Symbol * result{FindFunctionResult(symbol)}) {
       if (IsPointer(*result)) {
         messages_.Say(
             "An assumed-length CHARACTER(*) function cannot return a POINTER"_err_en_US);
       }
     }
   }
if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
                 "pointer '%s'"_err_en_US,
                 ultimate.name(), symbol.name());
           }
         } else if (!ultimate.attrs().test(Attr::EXTERNAL) &&
             ultimate.owner().kind() != Scope::Kind::Module) {
           context_.Say("Procedure pointer '%s' initializer '%s' is neither "
                        "an external nor a module procedure"_err_en_US,
               symbol.name(), ultimate.name());
-        } else if (ultimate.attrs().test(Attr::ELEMENTAL)) {
+        } else if (IsElementalProcedure(ultimate)) {
           context_.Say("Procedure pointer '%s' cannot be initialized with the "
                        "elemental procedure '%s"_err_en_US,
               symbol.name(), ultimate.name());
         } else {
           // TODO: Check the "shalls" in the 15.4.3.6 paragraphs 7-10.
         }
       }
     }
if (!symbol.attrs().test(Attr::POINTER) && // C843
                     " 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) ||
+        (IsElementalProcedure(symbol) ||
             (interface && !interface->attrs().test(Attr::INTRINSIC) &&
-                interface->attrs().test(Attr::ELEMENTAL)))) {
+                IsElementalProcedure(*interface)))) {
       // 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*
       // explicitly forbidden.  But we allow "PROCEDURE(SIN)::dummy"
       // because it is explicitly legal to *pass* the specific intrinsic
       // function SIN as an actual argument.
       messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
     }
if (const Symbol * interface{details.interface().symbol()}) {
                     interface->name().ToString())};
             !intrinsic || intrinsic->isRestrictedSpecific) { // C1515
           messages_.Say(
               "Intrinsic procedure '%s' is not an unrestricted specific "
               "intrinsic permitted for use as the definition of the interface "
               "to procedure pointer '%s'"_err_en_US,
               interface->name(), symbol.name());
         }
-      } else if (interface->attrs().test(Attr::ELEMENTAL)) {
+      } else if (IsElementalProcedure(*interface)) {
         messages_.Say("Procedure pointer '%s' may not be ELEMENTAL"_err_en_US,
             symbol.name()); // C1517
       }
     }
   } else if (symbol.attrs().test(Attr::SAVE)) {
     messages_.Say(
         "Procedure '%s' with SAVE attribute must also have POINTER attribute"_err_en_US,
         symbol.name());
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)) {
+  if (IsElementalProcedure(symbol)) {
     // See comment on the similar check in CheckProcEntity()
     if (details.isDummy()) {
       messages_.Say("A dummy procedure may not be ELEMENTAL"_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);
if (const Symbol * overridden{FindOverriddenBinding(symbol)}) {
     }
     if (const auto *overriddenBinding{
             overridden->detailsIf<ProcBindingDetails>()}) {
       if (!IsPureProcedure(symbol) && IsPureProcedure(*overridden)) {
         SayWithDeclaration(*overridden,
             "An overridden pure type-bound procedure binding must also be pure"_err_en_US);
         return;
       }
-      if (!binding.symbol().attrs().test(Attr::ELEMENTAL) &&
-          overriddenBinding->symbol().attrs().test(Attr::ELEMENTAL)) {
+      if (!IsElementalProcedure(binding.symbol()) &&
+          IsElementalProcedure(overriddenBinding->symbol())) {
         SayWithDeclaration(*overridden,
             "A type-bound procedure and its override must both, or neither, be ELEMENTAL"_err_en_US);
         return;
       }
       bool isNopass{symbol.attrs().test(Attr::NOPASS)};
       if (isNopass != overridden->attrs().test(Attr::NOPASS)) {
         SayWithDeclaration(*overridden,
             isNopass

flang/lib/Semantics/check-omp-structure.cpp

bool Pre(const parser::AssignmentStmt &assignment) {
     }
     return true;
   }
 
   bool Pre(const parser::Expr &expr) {
     if (const auto *e{GetExpr(context_, expr)}) {
       for (const Symbol &symbol : evaluate::CollectSymbols(*e)) {
         const Symbol &root{GetAssociationRoot(symbol)};
-        if (IsFunction(root) &&
-            !(root.attrs().test(Attr::ELEMENTAL) ||
-                root.attrs().test(Attr::INTRINSIC))) {
+        if (IsFunction(root) && !IsElementalProcedure(root)) {
           context_.Say(expr.source,
               "User defined non-ELEMENTAL function "
               "'%s' is not allowed in a WORKSHARE construct"_err_en_US,
               root.name());
         }
       }
     }
     return false;

flang/lib/Semantics/symbol.cpp

 const Symbol *DerivedTypeDetails::GetFinalForRank(int rank) const {
   for (const auto &pair : finals_) {
     const Symbol &symbol{*pair.second};
     if (const auto *details{symbol.detailsIf<SubprogramDetails>()}) {
       if (details->dummyArgs().size() == 1) {
         if (const Symbol * arg{details->dummyArgs().at(0)}) {
           if (const auto *object{arg->detailsIf<ObjectEntityDetails>()}) {
             if (rank == object->shape().Rank() || object->IsAssumedRank() ||
-                symbol.attrs().test(Attr::ELEMENTAL)) {
+                IsElementalProcedure(symbol)) {
               return &symbol;
             }
           }
         }
       }
     }
   }
   return nullptr;