[flang] Save proc pointer inits in symbol table; add IsSaved() predicate to tools

Original-commit: flang-compiler/f18@23c6be9168
Reviewed-on: https://github.com/flang-compiler/f18/pull/638
Tree-same-pre-rewrite: false

flang/lib/semantics/resolve-names.cc

@@ -858,7 +858,7 @@ private:
   bool HandleUnrestrictedSpecificIntrinsicFunction(const parser::Name &);
   const parser::Name *FindComponent(const parser::Name *, const parser::Name &);
   void CheckInitialDataTarget(const Symbol &, const SomeExpr &, SourceName);
-  void CheckInitialProcTarget(const Symbol &, const parser::Name &);
+  void CheckInitialProcTarget(const Symbol &, const parser::Name &, SourceName);
   void Initialization(const parser::Name &, const parser::Initialization &,
       bool inComponentDecl);
   bool PassesLocalityChecks(const parser::Name &name, Symbol &symbol);
@@ -3754,17 +3754,9 @@ void DeclarationVisitor::AddSaveName(
 
 // Set the SAVE attribute on symbol unless it is implicitly saved anyway.
 void DeclarationVisitor::SetSaveAttr(Symbol &symbol) {
-  auto scopeKind{symbol.owner().kind()};
-  if (scopeKind == Scope::Kind::MainProgram ||
-      scopeKind == Scope::Kind::Module) {
-    return;
+  if (!IsSaved(symbol)) {
+    symbol.attrs().set(Attr::SAVE);
   }
-  if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
-    if (details->init()) {
-      return;
-    }
-  }
-  symbol.attrs().set(Attr::SAVE);
 }
 
 // Check types of common block objects, now that they are known.
@@ -4854,7 +4846,7 @@ void DeclarationVisitor::CheckInitialDataTarget(
             pointer.name(), ultimate.name());
         return;
       }
-      if (!ultimate.attrs().test(Attr::SAVE)) {
+      if (!IsSaved(ultimate)) {
         Say(source,
             "Pointer '%s' cannot be initialized with a reference to an object '%s' that lacks the SAVE attribute"_err_en_US,
             pointer.name(), ultimate.name());
@@ -4868,8 +4860,27 @@ void DeclarationVisitor::CheckInitialDataTarget(
 }
 
 void DeclarationVisitor::CheckInitialProcTarget(
-    const Symbol &pointer, const parser::Name &target) {
-  // TODO pmk write
+    const Symbol &pointer, const parser::Name &target, SourceName source) {
+  // C1519 - must be nonelemental external or module procedure,
+  // or an unrestricted specific intrinsic function.
+  if (const Symbol * targetSym{target.symbol}) {
+    const Symbol &ultimate{targetSym->GetUltimate()};
+    if (ultimate.attrs().test(Attr::INTRINSIC)) {
+    } else if (!ultimate.attrs().test(Attr::EXTERNAL) &&
+        ultimate.owner().kind() != Scope::Kind::Module) {
+      Say(source,
+          "Procedure pointer '%s' initializer '%s' is neither "
+          "an external nor a module procedure"_err_en_US,
+          pointer.name(), ultimate.name());
+    } else if (ultimate.attrs().test(Attr::ELEMENTAL)) {
+      Say(source,
+          "Procedure pointer '%s' cannot be initialized with the "
+          "elemental procedure '%s"_err_en_US,
+          pointer.name(), ultimate.name());
+    } else {
+      // TODO: Check the "shalls" in the 15.4.3.6 paragraphs 7-10.
+    }
+  }
 }
 
 void DeclarationVisitor::Initialization(const parser::Name &name,
@@ -4970,13 +4981,15 @@ void DeclarationVisitor::PointerInitialization(
     Symbol &ultimate{name.symbol->GetUltimate()};
     if (IsProcedurePointer(ultimate)) {
       auto &details{ultimate.get<ProcEntityDetails>()};
-      if (details.init() == nullptr) {
+      if (!details.init().has_value()) {
         Walk(target);
         if (const auto *targetName{std::get_if<parser::Name>(&target.u)}) {
-          CheckInitialProcTarget(ultimate, *targetName);
+          CheckInitialProcTarget(ultimate, *targetName, name.source);
           if (targetName->symbol != nullptr) {
             details.set_init(*targetName->symbol);
           }
+        } else {
+          details.set_init(nullptr);  // NULL()
         }
       }
     } else {

flang/lib/semantics/symbol.cc

@@ -359,8 +359,12 @@ std::ostream &operator<<(std::ostream &os, const ProcEntityDetails &x) {
   }
   DumpOptional(os, "bindName", x.bindName());
   DumpOptional(os, "passName", x.passName());
-  if (x.init_ != nullptr) {
-    os << " => " << x.init_->name();
+  if (x.init()) {
+    if (const Symbol * target{*x.init()}) {
+      os << " => " << target->name();
+    } else {
+      os << " => NULL()";
+    }
   }
   return os;
 }

flang/lib/semantics/symbol.h

@@ -204,13 +204,13 @@ public:
   void set_interface(const ProcInterface &interface) { interface_ = interface; }
   inline bool HasExplicitInterface() const;
 
-  const Symbol *init() const { return init_; }
-  Symbol *init() { return init_; }
-  void set_init(Symbol &symbol) { init_ = &symbol; }
+  std::optional<const Symbol *> init() const { return init_; }
+  void set_init(const Symbol &symbol) { init_ = &symbol; }
+  void set_init(std::nullptr_t) { init_ = nullptr; }
 
 private:
   ProcInterface interface_;
-  Symbol *init_{nullptr};
+  std::optional<const Symbol *> init_;  // if present but null => NULL()
   friend std::ostream &operator<<(std::ostream &, const ProcEntityDetails &);
 };
 

flang/lib/semantics/tools.cc

@@ -400,6 +400,45 @@ bool IsOrContainsEventOrLockComponent(const Symbol &symbol) {
   return false;
 }
 
+bool IsSaved(const Symbol &symbol) {
+  auto scopeKind{symbol.owner().kind()};
+  if (scopeKind == Scope::Kind::MainProgram ||
+      scopeKind == Scope::Kind::Module) {
+    return true;
+  } else if (scopeKind == Scope::Kind::DerivedType) {
+    return false;  // this is a component
+  } else if (symbol.attrs().test(Attr::SAVE)) {
+    return true;
+  } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+    return object->init().has_value();
+  } else if (IsProcedurePointer(symbol)) {
+    return symbol.get<ProcEntityDetails>().init().has_value();
+  } else {
+    return false;
+  }
+}
+
+const Symbol *FindUltimateComponent(const DerivedTypeSpec &derivedTypeSpec,
+    std::function<bool(const Symbol &)> predicate) {
+  const auto *scope{derivedTypeSpec.typeSymbol().scope()};
+  CHECK(scope);
+  for (const auto &pair : *scope) {
+    const Symbol &component{*pair.second};
+    const DeclTypeSpec *type{component.GetType()};
+    if (!type) {
+      continue;
+    }
+    const DerivedTypeSpec *derived{type->AsDerived()};
+    bool isUltimate{IsAllocatableOrPointer(component) || !derived};
+    if (const Symbol *
+        result{!isUltimate ? FindUltimateComponent(*derived, predicate)
+                           : predicate(component) ? &component : nullptr}) {
+      return result;
+    }
+  }
+  return nullptr;
+}
+
 bool IsFinalizable(const Symbol &symbol) {
   if (const DeclTypeSpec * type{symbol.GetType()}) {
     if (const DerivedTypeSpec * derived{type->AsDerived()}) {

flang/lib/semantics/tools.h

@@ -82,6 +82,8 @@ const Symbol *HasCoarrayUltimateComponent(const DerivedTypeSpec &);
 // Same logic as HasCoarrayUltimateComponent, but looking for
 const Symbol *HasEventOrLockPotentialComponent(const DerivedTypeSpec &);
 bool IsOrContainsEventOrLockComponent(const Symbol &);
+// Has an explicit or implied SAVE attribute
+bool IsSaved(const Symbol &);
 
 // Return an ultimate component of type that matches predicate, or nullptr.
 const Symbol *FindUltimateComponent(

flang/test/semantics/procinterface01.f90

@@ -51,7 +51,7 @@ module module1
  type :: derived1
   !REF: /module1/abstract1
   !DEF: /module1/derived1/p1 NOPASS, POINTER ProcEntity REAL(4)
-  !DEF: /module1/nested1 ELEMENTAL, PUBLIC Subprogram REAL(4)
+  !DEF: /module1/nested1 PUBLIC Subprogram REAL(4)
   procedure(abstract1), pointer, nopass :: p1 => nested1
   !REF: /module1/explicit1
   !DEF: /module1/derived1/p2 NOPASS, POINTER ProcEntity REAL(4)
@@ -84,7 +84,7 @@ contains
 
  !REF: /module1/nested1
  !DEF: /module1/nested1/x INTENT(IN) ObjectEntity REAL(4)
- real elemental function nested1(x)
+ real function nested1(x)
   !REF: /module1/nested1/x
   real, intent(in) :: x
   !DEF: /module1/nested1/nested1 ObjectEntity REAL(4)