[flang-commits] [flang] [flang] Further work on relaxing BIND(C) enforcement (PR #92029)

[Peter Klausler via flang-commits]

https://github.com/klausler created https://github.com/llvm/llvm-project/pull/92029

When a BIND(C) interface or subprogram has a dummy argument whose derived type is not BIND(C) but meets the constraints and requirements of a BIND(C) type, accept it with a warning.

>From ce925b4094552ca7b3650e71c490eb77cb40e2b5 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Mon, 13 May 2024 13:40:03 -0700
Subject: [PATCH] [flang] Further work on relaxing BIND(C) enforcement

When a BIND(C) interface or subprogram has a dummy argument whose
derived type is not BIND(C) but meets the constraints and requirements
of a BIND(C) type, accept it with a warning.
---
 flang/lib/Semantics/check-declarations.cpp | 16 +++++---
 flang/test/Semantics/bind-c15.f90          | 45 ++++++++++++++++++++++
 2 files changed, 56 insertions(+), 5 deletions(-)
 create mode 100644 flang/test/Semantics/bind-c15.f90

diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 26efa288b5aee..c9ec3a8a53c1e 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -2875,7 +2875,8 @@ parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
       } else {
         bool interoperableParent{true};
         if (parent->symbol()) {
-          auto bad{WhyNotInteroperableDerivedType(*parent->symbol(), false)};
+          auto bad{WhyNotInteroperableDerivedType(
+              *parent->symbol(), /*isError=*/false)};
           if (bad.AnyFatalError()) {
             auto &msg{msgs.Say(symbol.name(),
                 "The parent of an interoperable type is not interoperable"_err_en_US)};
@@ -2965,6 +2966,9 @@ parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
       }
     }
   }
+  if (msgs.AnyFatalError()) {
+    examinedByWhyNotInteroperableDerivedType_.erase(symbol);
+  }
   return msgs;
 }
 
@@ -3052,8 +3056,8 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
           }
           context_.SetError(symbol);
         } else if (auto bad{WhyNotInteroperableDerivedType(
-                       derived->typeSymbol(), false)};
-                   !bad.empty()) {
+                       derived->typeSymbol(), /*isError=*/false)};
+                   bad.AnyFatalError()) {
           if (auto *msg{messages_.Say(symbol.name(),
                   "The derived type of an interoperable object must be interoperable, but is not"_err_en_US)}) {
             msg->Attach(
@@ -3061,7 +3065,9 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
             bad.AttachTo(*msg, parser::Severity::None);
           }
           context_.SetError(symbol);
-        } else {
+        } else if (context_.ShouldWarn(
+                       common::LanguageFeature::NonBindCInteroperability) &&
+            !InModuleFile()) {
           if (auto *msg{messages_.Say(symbol.name(),
                   "The derived type of an interoperable object should be BIND(C)"_warn_en_US)}) {
             msg->Attach(derived->typeSymbol().name(), "Non-BIND(C) type"_en_US);
@@ -3135,7 +3141,7 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
       }
     }
   } else if (symbol.has<DerivedTypeDetails>()) {
-    if (auto msgs{WhyNotInteroperableDerivedType(symbol, false)};
+    if (auto msgs{WhyNotInteroperableDerivedType(symbol, /*isError=*/false)};
         !msgs.empty()) {
       bool anyFatal{msgs.AnyFatalError()};
       if (msgs.AnyFatalError() ||
diff --git a/flang/test/Semantics/bind-c15.f90 b/flang/test/Semantics/bind-c15.f90
new file mode 100644
index 0000000000000..9aaad52cc0e0a
--- /dev/null
+++ b/flang/test/Semantics/bind-c15.f90
@@ -0,0 +1,45 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
+
+module m
+  type, bind(c) :: explicit_bind_c
+    real a
+  end type
+  type :: interoperable1
+    type(explicit_bind_c) a
+  end type
+  type, extends(interoperable1) :: interoperable2
+    real b
+  end type
+  type :: non_interoperable1
+    real, allocatable :: a
+  end type
+  type :: non_interoperable2
+    type(non_interoperable1) b
+  end type
+  interface
+    subroutine sub_bind_c_1(x_bind_c) bind(c)
+      import explicit_bind_c
+      type(explicit_bind_c), intent(in) :: x_bind_c
+    end
+    subroutine sub_bind_c_2(x_interop1) bind(c)
+      import interoperable1
+      !WARNING: The derived type of an interoperable object should be BIND(C)
+      type(interoperable1), intent(in) :: x_interop1
+    end
+    subroutine sub_bind_c_3(x_interop2) bind(c)
+      import interoperable2
+      !WARNING: The derived type of an interoperable object should be BIND(C)
+      type(interoperable2), intent(in) :: x_interop2
+    end
+    subroutine sub_bind_c_4(x_non_interop1) bind(c)
+      import non_interoperable1
+      !ERROR: The derived type of an interoperable object must be interoperable, but is not
+      type(non_interoperable1), intent(in) :: x_non_interop1
+    end
+    subroutine sub_bind_c_5(x_non_interop2) bind(c)
+      import non_interoperable2
+      !ERROR: The derived type of an interoperable object must be interoperable, but is not
+      type(non_interoperable2), intent(in) :: x_non_interop2
+    end
+  end interface
+end