[flang-commits] [flang] f8f7002 - [flang] Catch procedure pointer interface error

[peter klausler via flang-commits]

Author: peter klausler
Date: 2021-06-03T14:02:42-07:00
New Revision: f8f7002828ec66cd6261d3e00312e9b1f4b59b79

URL: https://github.com/llvm/llvm-project/commit/f8f7002828ec66cd6261d3e00312e9b1f4b59b79
DIFF: https://github.com/llvm/llvm-project/commit/f8f7002828ec66cd6261d3e00312e9b1f4b59b79.diff

LOG: [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

Added: 
    

Modified: 
    flang/lib/Evaluate/characteristics.cpp
    flang/lib/Semantics/check-declarations.cpp

Removed: 
    


################################################################################
diff  --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 9588de4fd37f6..fc34e1b831e9c 100644
--- 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 7d83b1b4b530e..faeaff5ad778e 100644
--- 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
       }