[flang] Relax ignore_tkr(c) for assumed-type BIND(C) descriptor dummies (#205445)

Relax `F2023 15.5.2.5 p2` derived-type checks for assumed-type
ignore_tkr(c) dummies passed by descriptor to bind(C) procedures. This
will allow passing a derived type with a type-bound procedure or FINAL
or a parameterized derived type to a TYPE(*), dimension(..) bind(C)
dummy.

flang/docs/Directives.md

@@ -27,6 +27,12 @@ A list of non-standard directives supported by Flang
   When the dummy argument is not passed by descriptor (e.g., an assumed-size
   array in a BIND(C) interface), the base address is extracted from the actual
   argument's descriptor and passed as a raw pointer.
+  When the dummy argument is assumed-type (`TYPE(*)`) and passed by descriptor
+  to a `BIND(C)` procedure, (C) also disables the F2023 15.5.2.5 p2 checks
+  that would otherwise reject actual arguments whose derived type has type
+  parameters, type-bound procedures, or final procedures; this is intended for
+  `BIND(C)` interfaces where the implementation treats the argument as an opaque
+  CFI descriptor at the call site.
   The letter (P) ignores pointer and allocatable matching, so that one can pass
   an allocatable array to routine with pointer array argument and vice versa.
   The letter (M) disables matching of the actual argument's CUDA storage

flang/lib/Semantics/check-call.cpp

@@ -517,27 +517,36 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
       actualFirstSymbol && actualFirstSymbol->attrs().test(Attr::VOLATILE)};
   if (actualDerived && !actualDerived->IsVectorType()) {
     if (dummy.type.type().IsAssumedType()) {
-      if (!actualDerived->parameters().empty()) { // 15.5.2.4(2)
-        messages.Say(
-            "Actual argument associated with TYPE(*) %s may not have a parameterized derived type"_err_en_US,
-            dummyName);
-      }
-      if (const Symbol *
-          tbp{FindImmediateComponent(*actualDerived, [](const Symbol &symbol) {
-            return symbol.has<ProcBindingDetails>();
-          })}) { // 15.5.2.4(2)
-        evaluate::SayWithDeclaration(messages, *tbp,
-            "Actual argument associated with TYPE(*) %s may not have type-bound procedure '%s'"_err_en_US,
-            dummyName, tbp->name());
-      }
-      auto finals{FinalsForDerivedTypeInstantiation(*actualDerived)};
-      if (!finals.empty()) { // 15.5.2.4(2)
-        SourceName name{finals.front()->name()};
-        if (auto *msg{messages.Say(
-                "Actual argument associated with TYPE(*) %s may not have derived type '%s' with FINAL subroutine '%s'"_err_en_US,
-                dummyName, actualDerived->typeSymbol().name(), name)}) {
-          msg->Attach(name, "FINAL subroutine '%s' in derived type '%s'"_en_US,
-              name, actualDerived->typeSymbol().name());
+      // Assumed-type dummies with ignore_tkr(c) passed via descriptor to
+      // bind(C) procedures model opaque CFI argument passing; the callee does
+      // not access derived-type structure as TYPE(*).
+      const bool relaxAssumedTypeDerivedChecks{procedure.IsBindC() &&
+          dummy.ignoreTKR.test(common::IgnoreTKR::Contiguous) &&
+          dummy.IsPassedByDescriptor(/*isBindC=*/true)};
+      if (!relaxAssumedTypeDerivedChecks) {
+        if (!actualDerived->parameters().empty()) { // F2023 15.5.2.5 p2
+          messages.Say(
+              "Actual argument associated with TYPE(*) %s may not have a parameterized derived type"_err_en_US,
+              dummyName);
+        }
+        if (const Symbol *tbp{FindImmediateComponent(
+                *actualDerived, [](const Symbol &symbol) {
+                  return symbol.has<ProcBindingDetails>();
+                })}) { // F2023 15.5.2.5 p2
+          evaluate::SayWithDeclaration(messages, *tbp,
+              "Actual argument associated with TYPE(*) %s may not have type-bound procedure '%s'"_err_en_US,
+              dummyName, tbp->name());
+        }
+        auto finals{FinalsForDerivedTypeInstantiation(*actualDerived)};
+        if (!finals.empty()) { // F2023 15.5.2.5 p2
+          SourceName name{finals.front()->name()};
+          if (auto *msg{messages.Say(
+                  "Actual argument associated with TYPE(*) %s may not have derived type '%s' with FINAL subroutine '%s'"_err_en_US,
+                  dummyName, actualDerived->typeSymbol().name(), name)}) {
+            msg->Attach(name,
+                "FINAL subroutine '%s' in derived type '%s'"_en_US, name,
+                actualDerived->typeSymbol().name());
+          }
         }
       }
     }

flang/test/Semantics/call03-ignore-tkr-c-relaxed.f90

@@ -0,0 +1,40 @@
+! RUN: %flang_fc1 -fsyntax-only %s
+! Test that ignore_tkr(c) on an assumed-type bind(C) descriptor dummy
+! relaxes F2023 15.5.2.5 p2 restrictions for opaque CFI argument passing.
+
+module m
+  type :: tbp
+   contains
+    procedure :: binding => subr
+  end type
+  type :: pdt(n)
+    integer, len :: n
+  end type
+  type :: final_typ
+   contains
+    final :: cleanup
+  end type
+
+ contains
+
+  subroutine subr(this)
+    class(tbp), intent(in) :: this
+  end subroutine
+  subroutine cleanup(this)
+    type(final_typ), intent(inout) :: this
+  end subroutine
+  subroutine cfi(x) bind(c)
+    type(*), dimension(..) :: x
+!dir$ ignore_tkr(c) x
+  end subroutine
+end module
+
+program main
+  use m
+  type(tbp) :: x
+  type(pdt(1)) :: y
+  type(final_typ) :: z
+  call cfi(x)
+  call cfi(y)
+  call cfi(z)
+end program

flang/test/Semantics/call03-ignore-tkr-c-strict.f90

@@ -0,0 +1,56 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
+! Assumed-type dummies must enforce F2023 15.5.2.5 p2 for derived types with
+! PDT, TBP, or FINAL unless bind(C), ignore_tkr(c), and descriptor passing
+! all apply.
+
+module m
+  type :: tbp
+   contains
+    procedure :: binding => subr
+  end type
+  type :: pdt(n)
+    integer, len :: n
+  end type
+  type :: final_typ
+   contains
+    final :: cleanup
+  end type
+
+ contains
+
+  subroutine subr(this)
+    class(tbp), intent(in) :: this
+  end subroutine
+  subroutine cleanup(this)
+    type(final_typ), intent(inout) :: this
+  end subroutine
+  subroutine cfi(x) bind(c)
+    type(*), dimension(..) :: x
+  end subroutine
+  subroutine not_cfi(x)
+    type(*), dimension(..) :: x
+!dir$ ignore_tkr(c) x
+  end subroutine
+  subroutine not_descriptor(x) bind(c)
+    type(*) :: x(*)
+!dir$ ignore_tkr(c) x
+  end subroutine
+end module
+
+program main
+  use m
+  type(tbp) :: x
+  type(tbp), dimension(1) :: arr
+  type(pdt(1)) :: y
+  type(final_typ) :: z
+  !ERROR: Actual argument associated with TYPE(*) dummy argument 'x=' may not have type-bound procedure 'binding'
+  call cfi(x)
+  !ERROR: Actual argument associated with TYPE(*) dummy argument 'x=' may not have a parameterized derived type
+  call cfi(y)
+  !ERROR: Actual argument associated with TYPE(*) dummy argument 'x=' may not have derived type 'final_typ' with FINAL subroutine 'cleanup'
+  call cfi(z)
+  !ERROR: Actual argument associated with TYPE(*) dummy argument 'x=' may not have type-bound procedure 'binding'
+  call not_cfi(x)
+  !ERROR: Actual argument associated with TYPE(*) dummy argument 'x=' may not have type-bound procedure 'binding'
+  call not_descriptor(arr)
+end program