[flang-commits] [flang] b3026ba - [flang] Soften interoperability error when standard allows (#115092)

[via flang-commits]

Author: Peter Klausler
Date: 2024-11-14T14:56:44-08:00
New Revision: b3026bab91bd05453e7385377c40213a5b518dae

URL: https://github.com/llvm/llvm-project/commit/b3026bab91bd05453e7385377c40213a5b518dae
DIFF: https://github.com/llvm/llvm-project/commit/b3026bab91bd05453e7385377c40213a5b518dae.diff

LOG: [flang] Soften interoperability error when standard allows (#115092)

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.

Added: 
    flang/test/Semantics/bind-c17.f90

Modified: 
    flang/include/flang/Evaluate/tools.h
    flang/lib/Semantics/check-declarations.cpp

Removed: 
    


################################################################################
diff  --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index f547138f5a116c..a8a6eb922a045d 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 86881225e1e55c..354594f3339df9 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 &);
@@ -3001,7 +3002,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()) {
@@ -3037,8 +3039,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);
@@ -3178,7 +3185,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 00000000000000..8e0ecde67a0a50
--- /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