[flang] Relax two !DIR$ IGNORE_TKR error cases with descriptor arguments

[klausler]

Summary

Allow two currently erroneous cases of !DIR$ IGNORE_TKR errors: allocatable
and pointers, and IGNORE_TKR(R) on (other) arguments passed via descriptors.
Downgrade these cases to warnings when they appear in external interfaces,
since their implementations may well be in C. But retain the error status
on these cases for module procedures, since the Fortran implementation
probably can't work.

[razvanlupusoru]

flang/test/Semantics/ignore_tkr01.f90

144

Would you mind adding a test for assumed-shape in addition to assumed-rank? It should also be a warning.

[tschuett]

Independent of whether you use arc of the web interface with e.g. git diff -U999999 u > mypatch.patch you could add context to your diff:
https://llvm.org/docs/Phabricator.html#requesting-a-review-via-the-web-interface
which will be really appreciated by your reviewers.

[klausler]

Add requested test, and a better warning for IGNORE_TKR(R) on assumed-rank

[razvanlupusoru]

flang/lib/Semantics/check-declarations.cpp

739

The test below is not checking for this error - but for the other error.

739

Never mind. I missed it.

[razvanlupusoru]

Thank you.

flang/lib/Evaluate/type.cpp

for (const ShapeSpec &shapeSpec : details.shape()) {
     if (!lb || !ub || !IsConstantExpr(*lb) || !IsConstantExpr(*ub)) {
       return true;
     }
   }
   return false;
 }
 
 static bool IsDescriptor(const ProcEntityDetails &details) {
-  // A procedure pointer or dummy procedure must be & is a descriptor if
-  // and only if it requires a static link.
-  // TODO: refine this placeholder
+  // TODO: refine this placeholder; procedure pointers and dummy
+  // procedures should now be simple addresses (possibly of thunks)
   return details.HasExplicitInterface();
 }
 
 bool IsDescriptor(const Symbol &symbol) {
   return common::visit(
       common::visitors{
           [&](const ObjectEntityDetails &d) {
             return IsAllocatableOrPointer(symbol) || IsDescriptor(d);
return common::visit(
       },
       symbol.details());
 }
 
 bool IsPassedViaDescriptor(const Symbol &symbol) {
   if (!IsDescriptor(symbol)) {
     return false;
   }
+  if (IsAllocatableOrPointer(symbol)) {
+    return true;
+  }
   if (const auto *object{
           symbol.GetUltimate().detailsIf<ObjectEntityDetails>()}) {
     if (object->isDummy()) {
       if (object->type() &&
           object->type()->category() == DeclTypeSpec::Character) {
         return false;
       }
       if (object->IsAssumedSize()) {

flang/lib/Semantics/check-declarations.cpp

if (InPure() && !IsStmtFunction(DEREF(innermostSymbol_)) &&
           }
         }
       } else if (!IsIntentInOut(symbol)) { // C1586
         messages_.Say(
             "non-POINTER dummy argument of pure subroutine must have INTENT() or VALUE attribute"_err_en_US);
       }
     }
     if (auto ignoreTKR{GetIgnoreTKR(symbol)}; !ignoreTKR.empty()) {
-      if (IsAllocatableOrPointer(symbol)) {
+      const Symbol *ownerSymbol{symbol.owner().symbol()};
+      const auto *ownerSubp{ownerSymbol->detailsIf<SubprogramDetails>()};
+      bool inInterface{ownerSubp && ownerSubp->isInterface()};
+      bool inExplicitInterface{
+          inInterface && !IsSeparateModuleProcedureInterface(ownerSymbol)};
+      bool inModuleProc{
+          !inInterface && ownerSymbol && IsModuleProcedure(*ownerSymbol)};
+      if (!inExplicitInterface && !inModuleProc) {
         messages_.Say(
-            "!DIR$ IGNORE_TKR may not apply to an allocatable or pointer"_err_en_US);
-      } else if (ignoreTKR.test(common::IgnoreTKR::Contiguous) &&
+            "!DIR$ IGNORE_TKR may apply only in an interface or a module procedure"_err_en_US);
+      }
+      if (ignoreTKR.test(common::IgnoreTKR::Contiguous) &&
           !IsAssumedShape(symbol)) {
         messages_.Say(
             "!DIR$ IGNORE_TKR(C) may apply only to an assumed-shape array"_err_en_US);
-      } else if (ignoreTKR.test(common::IgnoreTKR::Rank) &&
-          IsPassedViaDescriptor(symbol)) {
-        messages_.Say(
-            "!DIR$ IGNORE_TKR(R) may not apply to a dummy argument passed via descriptor"_err_en_US);
-      } else if (const Symbol * ownerSymbol{symbol.owner().symbol()}) {
-        if (const auto *ownerSubp{ownerSymbol->detailsIf<SubprogramDetails>()};
-            ownerSubp && !ownerSubp->isInterface() &&
-            !FindModuleContaining(symbol.owner())) {
-          messages_.Say(
-              "!DIR$ IGNORE_TKR may apply only in an interface or a module procedure"_err_en_US);
-        } else if (ownerSymbol->attrs().test(Attr::ELEMENTAL) &&
-            details.ignoreTKR().test(common::IgnoreTKR::Rank)) {
-          messages_.Say(
-              "!DIR$ IGNORE_TKR(R) may not apply in an ELEMENTAL procedure"_err_en_US);
-        }
+      }
+      if (ownerSymbol && ownerSymbol->attrs().test(Attr::ELEMENTAL) &&
+      if (IsPassedViaDescriptor(symbol)) {
+        if (IsAllocatableOrPointer(symbol)) {
+          if (inExplicitInterface) {
+            messages_.Say(
+                "!DIR$ IGNORE_TKR should not apply to an allocatable or pointer"_warn_en_US);
+          } else {
+            messages_.Say(
+                "!DIR$ IGNORE_TKR may not apply to an allocatable or pointer"_err_en_US);
+          }
+        } else if (ignoreTKR.test(common::IgnoreTKR::Rank)) {
+          if (ignoreTKR.count() == 1 && evaluate::IsAssumedRank(symbol)) {
+            messages_.Say(
+                "!DIR$ IGNORE_TKR(R) is not meaningful for an assumed-rank array"_warn_en_US);
+          } else if (inExplicitInterface) {
+            messages_.Say(
+                "!DIR$ IGNORE_TKR(R) should not apply to a dummy argument passed via descriptor"_warn_en_US);
+          } else {
+            messages_.Say(
+                "!DIR$ IGNORE_TKR(R) may not apply to a dummy argument passed via descriptor"_err_en_US);
+          }
+        }
       }
     }
   } else if (symbol.attrs().test(Attr::INTENT_IN) ||
       symbol.attrs().test(Attr::INTENT_OUT) ||
       symbol.attrs().test(Attr::INTENT_INOUT)) {
     messages_.Say(
         "INTENT attributes may apply only to a dummy argument"_err_en_US); // C843
   } else if (IsOptional(symbol)) {

flang/test/Semantics/ignore_tkr01.f90

!dir$ ignore_tkr() x
 
     subroutine t8(x)
 !dir$ ignore_tkr x
       real, intent(in) :: x
     end
 
     subroutine t9(x)
 !dir$ ignore_tkr x
-!ERROR: !DIR$ IGNORE_TKR may not apply to an allocatable or pointer
+!WARNING: !DIR$ IGNORE_TKR should not apply to an allocatable or pointer
       real, intent(in), allocatable :: x
     end
 
     subroutine t10(x)
 !dir$ ignore_tkr x
-!ERROR: !DIR$ IGNORE_TKR may not apply to an allocatable or pointer
+!WARNING: !DIR$ IGNORE_TKR should not apply to an allocatable or pointer
       real, intent(in), pointer :: x
     end
 
     subroutine t11
 !dir$ ignore_tkr x
 !ERROR: !DIR$ IGNORE_TKR directive may apply only to a dummy data argument
       real :: x
     end
!dir$ ignore_tkr r
     end
 
     elemental subroutine t13(x)
 !dir$ ignore_tkr(r) x
 !ERROR: !DIR$ IGNORE_TKR(R) may not apply in an ELEMENTAL procedure
       real, intent(in) :: x
     end
 
+    subroutine t14(x)
+!dir$ ignore_tkr(r) x
+!WARNING: !DIR$ IGNORE_TKR(R) should not apply to a dummy argument passed via descriptor
+      real x(:)
+    end
+
   end interface
 
  contains
-  subroutine t14(x)
+    subroutine t15(x)
+!dir$ ignore_tkr x
+!ERROR: !DIR$ IGNORE_TKR may not apply to an allocatable or pointer
+      real, intent(in), allocatable :: x
+    end
+
+    subroutine t16(x)
+!dir$ ignore_tkr x
+!ERROR: !DIR$ IGNORE_TKR may not apply to an allocatable or pointer
+      real, intent(in), pointer :: x
+    end
+
+  subroutine t17(x)
     real x
     x = x + 1.
 !ERROR: !DIR$ IGNORE_TKR directive must appear in the specification part
 !dir$ ignore_tkr x
   end
 
-  subroutine t15(x)
+  subroutine t18(x)
 !ERROR: 'q' is not a valid letter for !DIR$ IGNORE_TKR directive
 !dir$ ignore_tkr(q) x
     real x
     x = x + 1.
   end
 
-  subroutine t16(x)
+  subroutine t19(x)
     real x
    contains
     subroutine inner
 !ERROR: 'x' must be local to this subprogram
 !dir$ ignore_tkr x
     end
   end
 
-  subroutine t17(x)
+  subroutine t20(x)
     real x
     block
 !ERROR: 'x' must be local to this subprogram
 !dir$ ignore_tkr x
     end block
   end
 
-  subroutine t18(x)
+  subroutine t21(x)
 !dir$ ignore_tkr(c) x
 !ERROR: !DIR$ IGNORE_TKR(C) may apply only to an assumed-shape array
     real x(1)
   end
 
-  subroutine t19(x)
+  subroutine t22(x)
 !dir$ ignore_tkr(r) x
-!ERROR: !DIR$ IGNORE_TKR(R) may not apply to a dummy argument passed via descriptor
+!WARNING: !DIR$ IGNORE_TKR(R) is not meaningful for an assumed-rank array
     real x(..)
   end
 
+  subroutine t23(x)
+!dir$ ignore_tkr(r) x
+!ERROR: !DIR$ IGNORE_TKR(R) may not apply to a dummy argument passed via descriptor
+    real x(:)
+  end
+
 end
 
 subroutine bad1(x)
 !dir$ ignore_tkr x
 !ERROR: !DIR$ IGNORE_TKR may apply only in an interface or a module procedure
   real, intent(in) :: x
 end