[flang] Checks for pointers to intrinsic functions

[ekieri]

Summary

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.

[PeteSteinfeld]

Looks great!

Thanks for doing this.

flang/test/Semantics/resolve46.f90

2–4

Please add a comment to note that this test also tests for constraint C1515.

[ekieri]

Address comment from Pete

[ekieri]

Thanks @PeteSteinfeld for the review! I also added a comment for C1519 (initialisation of procedure pointers). All aspects of those constraints are not tested, but I intend to continue working towards that in subsequent patches.

[klausler]

flang/lib/Evaluate/characteristics.cpp

421–426

Possibly easier to follow:

auto intrinsic{...};
if (intrinsic && intrinsic->isRestrictedSpecific) {
  intrinsic.reset(); // exclude intrinsics from table 16.3
}
return intrinsic.

flang/lib/Semantics/check-declarations.cpp

636

You could emit distinct messages for the two possible error cases (!intrinsic for one, intrinsic->isRestrictedSpecific for the other).

If you choose to emit just the one message, the predicate could be made easier to follow as:

!intrinsic || intrinsic->isRestrictedSpecific

to avoid making the reader of the code have to figure out multiple negations.

785

My comments from line ca. 630 above also apply here.

[ekieri]

Address comments from Peter

[ekieri]

Thanks @klausler for your comments!

I do not have commit access. If this looks ok to you, could you land the patch for me? Please use “Emil Kieri <[e-mail]>” to commit it.

Cheers, Emil

flang/lib/Evaluate/characteristics.cpp

421–426

Yes, thanks!

flang/lib/Semantics/check-declarations.cpp

636

I would prefer to stay with just the one message. I think that better matches the actual condition (must be listed in 16.2), handling the cases separately would imho follow the implementation details rather than the underlying logic.

Thanks for the tip with the predicate! Looks cleaner, double negations should clearly be avoided.

[PeteSteinfeld]

Rather than Peter committing this, it’s better for you to do it yourself. Here’s how.

The first step is to get committer access to the llvm-project repository. You can request commit access for the llvm-project here: https://llvm.org/docs/DeveloperPolicy.html#obtaining-commit-access. Once access is granted, an invitation should be visible here: https://github.com/llvm.

Once you have committer access (actually, you can do this now), you should incorporate your changes into the latest source code from llvm-project, and make sure that everything builds and tests correctly. Here’s how to do that:

1. Start in your private repository in the branch that contains your changes.
2. If you have multiple commits, run git rebase -i to squash them into a single commit.
3. Merge the latest changes from llvm-project into your branch:

• git checkout main
• git pull
• git checkout mybranch
• git rebase main

4. Rebuild and retest to verify that your changes still work.
5. Push your changes to the main branch in the llvm-repository: git push origin mybranch:main

[ekieri]

Am I not supposed to havet a track record within the project to get commit access? The policy you linked suggests that. This is my first contribution to llvm.

[PeteSteinfeld]

In D112381#3085643, @ekieri wrote:

Am I not supposed to havet a track record within the project to get commit access? The policy you linked suggests that. This is my first contribution to llvm.

@ekieri, I've discussed this with Peter, and we both think that the best thing is for you to get commit access and do the commit yourself.

[ekieri]

In D112381#3090946, @PeteSteinfeld wrote:

In D112381#3085643, @ekieri wrote:

Am I not supposed to havet a track record within the project to get commit access? The policy you linked suggests that. This is my first contribution to llvm.

@ekieri, I've discussed this with Peter, and we both think that the best thing is for you to get commit access and do the commit yourself.

Ok, thanks. I have sent a request.

[ekieri]

That worked out nicely, thanks a lot for all your help!

flang/lib/Evaluate/characteristics.cpp

return std::visit(
           [&](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());
+              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()}) {
               return CharacterizeProcedure(
                   *interfaceSymbol, context, seenProcs);
             } else {
               result.attrs.set(Procedure::Attr::ImplicitInterface);
               const semantics::DeclTypeSpec *type{interface.type()};

flang/lib/Evaluate/intrinsics.cpp

static const SpecificIntrinsicInterface specificIntrinsicFunction[]{
     {{"idnint", {{"a", DoublePrecision}}, DefaultInt}, "nint"},
     {{"ifix", {{"a", AnyReal}}, DefaultInt}, "int", true},
     {{"index", {{"string", DefaultChar}, {"substring", DefaultChar}},
         DefaultInt}},
     {{"isign", {{"a", DefaultInt}, {"b", DefaultInt}}, DefaultInt}, "sign"},
     {{"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",
          {{"a1", DefaultInt}, {"a2", DefaultInt},
              {"a3", DefaultInt, Rank::elemental, Optionality::repeats}},
          DefaultInt},
         "max", true, true},
     {{"max1",

flang/lib/Semantics/check-declarations.cpp

if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
         }
       }
     } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
       if (proc->init() && *proc->init()) {
         // C1519 - must be nonelemental external or module procedure,
         // 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) &&
             ultimate.owner().kind() != Scope::Kind::Module) {
           context_.Say("Procedure pointer '%s' initializer '%s' is neither "
                        "an external nor a module procedure"_err_en_US,
               symbol.name(), ultimate.name());
         } else if (ultimate.attrs().test(Attr::ELEMENTAL)) {
           context_.Say("Procedure pointer '%s' cannot be initialized with the "
                        "elemental procedure '%s"_err_en_US,
if (!symbol.attrs().test(Attr::POINTER)) { // C756
           name);
     }
     CheckPassArg(symbol, details.interface().symbol(), details);
   }
   if (symbol.attrs().test(Attr::POINTER)) {
     CheckPointerInitialization(symbol);
     if (const Symbol * interface{details.interface().symbol()}) {
       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,
+        if (const auto intrinsic{
+                context_.intrinsics().IsSpecificIntrinsicFunction(
+                    interface->name().ToString())};
+            !intrinsic || intrinsic->isRestrictedSpecific) { // C1515
+          messages_.Say(
+              "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)) {
         messages_.Say("Procedure pointer '%s' may not be ELEMENTAL"_err_en_US,
             symbol.name()); // C1517
       }
     }
   } else if (symbol.attrs().test(Attr::SAVE)) {

flang/lib/Semantics/expression.cpp

if (auto *component{std::get_if<Component>(&ref.u)}) {
       DIE("unexpected alternative in DataRef");
     } else if (!symbol.attrs().test(semantics::Attr::INTRINSIC)) {
       if (symbol.has<semantics::GenericDetails>()) {
         Say("'%s' is not a specific procedure"_err_en_US, symbol.name());
       } else {
         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;
   } else if (MaybeExpr result{AsGenericExpr(std::move(ref))}) {
     return result;
   } else {
     if (!context_.HasError(last) && !context_.HasError(symbol)) {
       AttachDeclaration(

flang/test/Semantics/resolve46.f90

 ! 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