[flang] Checks for pointers to intrinsic functions

Check that when a procedure pointer is initialised or assigned with an intrinsic
function, or when its interface is being defined by one, that intrinsic function
is unrestricted specific (listed in Table 16.2 of F'2018).

Mark intrinsics LGE, LGT, LLE, and LLT as restricted specific. Getting their
classifications right helps in designing the tests.

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

5 files changed, 61 insertions, 21 deletions

diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index d61ff9b791e4..464c9e9bce0d 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -418,8 +418,12 @@ static std::optional<Procedure> CharacterizeProcedure(
               // 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());
+              auto intrinsic{context.intrinsics().IsSpecificIntrinsicFunction(
+                  symbol.name().ToString())};
+              if (intrinsic && intrinsic->isRestrictedSpecific) {
+                intrinsic.reset(); // Exclude intrinsics from table 16.3.
+              }
+              return intrinsic;
             }
             const semantics::ProcInterface &interface{proc.interface()};
             if (const semantics::Symbol * interfaceSymbol{interface.symbol()}) {
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 519f0e642409..20be19e5f109 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -994,13 +994,17 @@ static const SpecificIntrinsicInterface specificIntrinsicFunction[]{
     {{"len", {{"string", DefaultChar, Rank::anyOrAssumedRank}}, DefaultInt,
         Rank::scalar}},
     {{"lge", {{"string_a", DefaultChar}, {"string_b", DefaultChar}},
-        DefaultLogical}},
+         DefaultLogical},
+        "lge", true},
     {{"lgt", {{"string_a", DefaultChar}, {"string_b", DefaultChar}},
-        DefaultLogical}},
+         DefaultLogical},
+        "lgt", true},
     {{"lle", {{"string_a", DefaultChar}, {"string_b", DefaultChar}},
-        DefaultLogical}},
+         DefaultLogical},
+        "lle", true},
     {{"llt", {{"string_a", DefaultChar}, {"string_b", DefaultChar}},
-        DefaultLogical}},
+         DefaultLogical},
+        "llt", true},
     {{"log", {{"x", DefaultReal}}, DefaultReal}},
     {{"log10", {{"x", DefaultReal}}, DefaultReal}},
     {{"max0",
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 5a2c05acf002..6b52de57fc37 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -624,10 +624,14 @@ 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
+          if (const auto intrinsic{
+                  context_.intrinsics().IsSpecificIntrinsicFunction(
+                      ultimate.name().ToString())};
+              !intrinsic || intrinsic->isRestrictedSpecific) { // C1030
             context_.Say(
-                "Intrinsic procedure '%s' is not a specific intrinsic permitted for use as the initializer for procedure pointer '%s'"_err_en_US,
+                "Intrinsic procedure '%s' is not an unrestricted 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) &&
@@ -774,10 +778,14 @@ void CheckHelper::CheckProcEntity(
     CheckPointerInitialization(symbol);
     if (const Symbol * interface{details.interface().symbol()}) {
       if (interface->attrs().test(Attr::INTRINSIC)) {
-        if (!context_.intrinsics().IsSpecificIntrinsicFunction(
-                interface->name().ToString())) { // C1515
+        if (const auto intrinsic{
+                context_.intrinsics().IsSpecificIntrinsicFunction(
+                    interface->name().ToString())};
+            !intrinsic || intrinsic->isRestrictedSpecific) { // 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,
+              "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)) {
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 9635659c47c6..b217c81f31a3 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -190,13 +190,14 @@ MaybeExpr ExpressionAnalyzer::Designate(DataRef &&ref) {
         return Expr<SomeType>{ProcedureDesignator{symbol}};
       }
     } else if (auto interface{context_.intrinsics().IsSpecificIntrinsicFunction(
-                   symbol.name().ToString())}) {
+                   symbol.name().ToString())};
+               interface && !interface->isRestrictedSpecific) {
       SpecificIntrinsic intrinsic{
           symbol.name().ToString(), std::move(*interface)};
       intrinsic.isRestrictedSpecific = interface->isRestrictedSpecific;
       return Expr<SomeType>{ProcedureDesignator{std::move(intrinsic)}};
     } else {
-      Say("'%s' is not a specific intrinsic procedure"_err_en_US,
+      Say("'%s' is not an unrestricted specific intrinsic procedure"_err_en_US,
           symbol.name());
     }
     return std::nullopt;
diff --git a/flang/test/Semantics/resolve46.f90 b/flang/test/Semantics/resolve46.f90
index 716d72f83576..981008ae3ea4 100644
--- a/flang/test/Semantics/resolve46.f90
+++ b/flang/test/Semantics/resolve46.f90
@@ -1,22 +1,45 @@
 ! RUN: %python %S/test_errors.py %s %flang_fc1
-! C1030 - pointers to intrinsic procedures
+! C1030 - assignment of pointers to intrinsic procedures
+! C1515 - interface definition for procedure pointers
+! C1519 - initialization of pointers to intrinsic procedures
 program main
   intrinsic :: cos ! a specific & generic intrinsic name
   intrinsic :: alog10 ! a specific intrinsic name, not generic
   intrinsic :: null ! a weird special case
   intrinsic :: bessel_j0 ! generic intrinsic, not specific
   intrinsic :: amin0
+  intrinsic :: mod
+  intrinsic :: llt
   !ERROR: 'haltandcatchfire' is not a known intrinsic procedure
   intrinsic :: haltandcatchfire
-  procedure(sin), pointer :: p
+
+  abstract interface
+     logical function chrcmp(a,b)
+       character(*), intent(in) :: a
+       character(*), intent(in) :: b
+     end function chrcmp
+  end interface
+
+  procedure(sin), pointer :: p => cos
+  !ERROR: Intrinsic procedure 'amin0' is not an unrestricted specific intrinsic permitted for use as the definition of the interface to procedure pointer 'q'
+  procedure(amin0), pointer :: q
+  !ERROR: Intrinsic procedure 'bessel_j0' is not an unrestricted specific intrinsic permitted for use as the definition of the interface to procedure pointer 'r'
+  procedure(bessel_j0), pointer :: r
+  !ERROR: Intrinsic procedure 'llt' is not an unrestricted specific intrinsic permitted for use as the initializer for procedure pointer 's'
+  procedure(chrcmp), pointer :: s => llt
+  !ERROR: Intrinsic procedure 'bessel_j0' is not an unrestricted specific intrinsic permitted for use as the initializer for procedure pointer 't'
+  procedure(cos), pointer :: t => bessel_j0
+  procedure(chrcmp), pointer :: u
   p => alog ! valid use of an unrestricted specific intrinsic
   p => alog10 ! ditto, but already declared intrinsic
   p => cos ! ditto, but also generic
   p => tan ! a generic & an unrestricted specific, not already declared
-  !ERROR: Procedure pointer 'p' associated with incompatible procedure designator 'amin0'
-  p => amin0
-  !ERROR: Procedure pointer 'p' associated with incompatible procedure designator 'amin1'
-  p => amin1
-  !ERROR: 'bessel_j0' is not a specific intrinsic procedure
+  !ERROR: Procedure pointer 'p' associated with incompatible procedure designator 'mod'
+  p => mod
+  !ERROR: Procedure pointer 'p' associated with incompatible procedure designator 'index'
+  p => index
+  !ERROR: 'bessel_j0' is not an unrestricted specific intrinsic procedure
   p => bessel_j0
+  !ERROR: 'llt' is not an unrestricted specific intrinsic procedure
+  u => llt
 end program main