[PATCH] D103570: [flang] Catch procedure pointer interface error

[Peter Klausler via Phabricator via llvm-commits]

This revision was automatically updated to reflect the committed changes.
Closed by commit rGf8f7002828ec: [flang] Catch procedure pointer interface error (authored by klausler).
Herald added a project: LLVM.
Herald added a subscriber: llvm-commits.

Repository:
  rG LLVM Github Monorepo

CHANGES SINCE LAST ACTION
  https://reviews.llvm.org/D103570/new/

https://reviews.llvm.org/D103570

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


Index: flang/lib/Semantics/check-declarations.cpp
===================================================================
--- flang/lib/Semantics/check-declarations.cpp
+++ flang/lib/Semantics/check-declarations.cpp
@@ -575,6 +575,12 @@
         // 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 @@
   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
       }
Index: flang/lib/Evaluate/characteristics.cpp
===================================================================
--- flang/lib/Evaluate/characteristics.cpp
+++ flang/lib/Evaluate/characteristics.cpp
@@ -367,7 +367,7 @@
     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 @@
           [&](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 @@
     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()}) {


-------------- next part --------------
A non-text attachment was scrubbed...
Name: D103570.349679.patch
Type: text/x-patch
Size: 3572 bytes
Desc: not available
URL: <http://lists.llvm.org/pipermail/llvm-commits/attachments/20210603/faf04dea/attachment.bin>