From 13c0fe36f9b783c2cda73821ade75084cf591ae2 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler@nvidia.com>
Date: Tue, 5 Nov 2024 15:25:26 -0800
Subject: [PATCH] [flang] Soften interoperability error when standard allows

The standard doesn't require that an interoperable procedure's
dummy arguments have interoperable derived types in some cases.
Although nearly all extant Fortran compilers emit errors, some
don't, and things should work; so reduce the current fatal error
message to an optional portability warning.

Fixes https://github.com/llvm/llvm-project/issues/115010.
---
 flang/include/flang/Evaluate/tools.h       |  3 +--
 flang/lib/Semantics/check-declarations.cpp | 23 +++++++++++++++++-----
 flang/test/Semantics/bind-c17.f90          | 10 ++++++++++
 3 files changed, 29 insertions(+), 7 deletions(-)
 create mode 100644 flang/test/Semantics/bind-c17.f90

diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index f547138f5a116..a8a6eb922a045 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -1103,8 +1103,7 @@ extern template semantics::UnorderedSymbolSet CollectCudaSymbols(
 bool HasVectorSubscript(const Expr<SomeType> &);
 
 // Utilities for attaching the location of the declaration of a symbol
-// of interest to a message, if both pointers are non-null.  Handles
-// the case of USE association gracefully.
+// of interest to a message.  Handles the case of USE association gracefully.
 parser::Message *AttachDeclaration(parser::Message &, const Symbol &);
 parser::Message *AttachDeclaration(parser::Message *, const Symbol &);
 template <typename MESSAGES, typename... A>
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index f8e873008ceab..f0fe54a0af308 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -147,7 +147,8 @@ class CheckHelper {
   void CheckProcedureAssemblyName(const Symbol &symbol);
   void CheckExplicitSave(const Symbol &);
   parser::Messages WhyNotInteroperableDerivedType(const Symbol &);
-  parser::Messages WhyNotInteroperableObject(const Symbol &);
+  parser::Messages WhyNotInteroperableObject(
+      const Symbol &, bool allowNonInteroperableType = false);
   parser::Messages WhyNotInteroperableFunctionResult(const Symbol &);
   parser::Messages WhyNotInteroperableProcedure(const Symbol &, bool isError);
   void CheckBindC(const Symbol &);
@@ -2999,7 +3000,8 @@ parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
   return msgs;
 }
 
-parser::Messages CheckHelper::WhyNotInteroperableObject(const Symbol &symbol) {
+parser::Messages CheckHelper::WhyNotInteroperableObject(
+    const Symbol &symbol, bool allowNonInteroperableType) {
   parser::Messages msgs;
   if (examinedByWhyNotInteroperable_.find(symbol) !=
       examinedByWhyNotInteroperable_.end()) {
@@ -3035,8 +3037,13 @@ parser::Messages CheckHelper::WhyNotInteroperableObject(const Symbol &symbol) {
   if (const auto *type{symbol.GetType()}) {
     const auto *derived{type->AsDerived()};
     if (derived && !derived->typeSymbol().attrs().test(Attr::BIND_C)) {
-      if (!context_.IsEnabled(
-              common::LanguageFeature::NonBindCInteroperability)) {
+      if (allowNonInteroperableType) { // portability warning only
+        evaluate::AttachDeclaration(
+            context_.Warn(common::UsageWarning::Portability, symbol.name(),
+                "The derived type of this interoperable object should be BIND(C)"_port_en_US),
+            derived->typeSymbol());
+      } else if (!context_.IsEnabled(
+                     common::LanguageFeature::NonBindCInteroperability)) {
         msgs.Say(symbol.name(),
                 "The derived type of an interoperable object must be BIND(C)"_err_en_US)
             .Attach(derived->typeSymbol().name(), "Non-BIND(C) type"_en_US);
@@ -3176,7 +3183,13 @@ parser::Messages CheckHelper::WhyNotInteroperableProcedure(
                 "A dummy procedure of an interoperable procedure should be BIND(C)"_warn_en_US);
           }
         } else if (dummy->has<ObjectEntityDetails>()) {
-          dummyMsgs = WhyNotInteroperableObject(*dummy);
+          // Emit only optional portability warnings for non-interoperable
+          // types when the dummy argument is not VALUE and will be implemented
+          // on the C side by either a cdesc_t * or a void *.  F'2023 18.3.7 (5)
+          bool allowNonInteroperableType{!dummy->attrs().test(Attr::VALUE) &&
+              (IsDescriptor(*dummy) || IsAssumedType(*dummy))};
+          dummyMsgs =
+              WhyNotInteroperableObject(*dummy, allowNonInteroperableType);
         } else {
           CheckBindC(*dummy);
         }
diff --git a/flang/test/Semantics/bind-c17.f90 b/flang/test/Semantics/bind-c17.f90
new file mode 100644
index 0000000000000..8e0ecde67a0a5
--- /dev/null
+++ b/flang/test/Semantics/bind-c17.f90
@@ -0,0 +1,10 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic -Werror
+module m
+  type a ! not BIND(C)
+  end type
+ contains
+  subroutine sub(x) bind(c)
+    !PORTABILITY: The derived type of this interoperable object should be BIND(C)
+    type(a), pointer, intent(in) :: x
+  end
+end