[flang] Catch procedure pointer interface error

A procedure pointer is allowed to name a specific intrinsic function
from F'2018 table 16.2 as its interface, but not other intrinsic
procedures.  Catch this error, and thereby also fix a crash resulting
from a failure later in compilation from failed characteristics;
while here, also catch the similar error with initializers.

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

diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 9588de4fd37f6998073940db50fce22405a63509..fc34e1b831e9c317274f875cf955632c55d3259f 100644 (file)
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -367,7 +367,7 @@ static std::optional<Procedure> CharacterizeProcedure(
     const semantics::Symbol &original, FoldingContext &context,
     semantics::UnorderedSymbolSet &seenProcs) {
   Procedure result;
-  const auto &symbol{original.GetUltimate()};
+  const auto &symbol{ResolveAssociations(original)};
   if (seenProcs.find(symbol) != seenProcs.end()) {
     std::string procsList{GetSeenProcs(seenProcs)};
     context.messages().Say(symbol.name(),
@@ -417,6 +417,11 @@ static std::optional<Procedure> CharacterizeProcedure(
           [&](const semantics::ProcEntityDetails &proc)
               -> std::optional<Procedure> {
             if (symbol.attrs().test(semantics::Attr::INTRINSIC)) {
+              // Fails when the intrinsic is not a specific intrinsic function
+              // from F'2018 table 16.2.  In order to handle forward references,
+              // attempts to use impermissible intrinsic procedures as the
+              // interfaces of procedure pointers are caught and flagged in
+              // declaration checking in Semantics.
               return context.intrinsics().IsSpecificIntrinsicFunction(
                   symbol.name().ToString());
             }
@@ -786,7 +791,7 @@ std::optional<Procedure> Procedure::Characterize(
     const ProcedureDesignator &proc, FoldingContext &context) {
   if (const auto *symbol{proc.GetSymbol()}) {
     if (auto result{characteristics::Procedure::Characterize(
-            symbol->GetUltimate(), context)}) {
+            ResolveAssociations(*symbol), context)}) {
       return result;
     }
   } else if (const auto *intrinsic{proc.GetSpecificIntrinsic()}) {

diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 7d83b1b4b530e5dfdd4f638222ccbd464985c59e..faeaff5ad778eafe1912a6a6e5dd68283a8245a2 100644 (file)
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -575,6 +575,12 @@ void CheckHelper::CheckPointerInitialization(const Symbol &symbol) {
         // or an unrestricted specific intrinsic function.
         const Symbol &ultimate{(*proc->init())->GetUltimate()};
         if (ultimate.attrs().test(Attr::INTRINSIC)) {
+          if (!context_.intrinsics().IsSpecificIntrinsicFunction(
+                  ultimate.name().ToString())) { // C1030
+            context_.Say(
+                "Intrinsic procedure '%s' is not a specific intrinsic permitted for use as the initializer for procedure 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 "
@@ -715,8 +721,14 @@ void CheckHelper::CheckProcEntity(
   if (symbol.attrs().test(Attr::POINTER)) {
     CheckPointerInitialization(symbol);
     if (const Symbol * interface{details.interface().symbol()}) {
-      if (interface->attrs().test(Attr::ELEMENTAL) &&
-          !interface->attrs().test(Attr::INTRINSIC)) {
+      if (interface->attrs().test(Attr::INTRINSIC)) {
+        if (!context_.intrinsics().IsSpecificIntrinsicFunction(
+                interface->name().ToString())) { // C1515
+          messages_.Say(
+              "Intrinsic procedure '%s' is not a 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)) {
         messages_.Say("Procedure pointer '%s' may not be ELEMENTAL"_err_en_US,
             symbol.name()); // C1517
       }