[flang-commits] [flang] 56cd8a5 - [flang] Relax BIND(C) derived type component check (#94392)

[via flang-commits]

Author: Peter Klausler
Date: 2024-06-11T16:38:51-07:00
New Revision: 56cd8a50b3e37cbb3cd3dc49909bdd14939cfdee

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

LOG: [flang] Relax BIND(C) derived type component check (#94392)

Allow an explicit BIND(C) derived type to have a non-BIND(C) component
so long as the component's type is interoperable and it satisfies all
other constraints.

Added: 
    

Modified: 
    flang/lib/Semantics/check-declarations.cpp
    flang/test/Semantics/bind-c15.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index bfb38fa1340ec..a55b360cee7ce 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -138,7 +138,7 @@ class CheckHelper {
   void CheckGlobalName(const Symbol &);
   void CheckProcedureAssemblyName(const Symbol &symbol);
   void CheckExplicitSave(const Symbol &);
-  parser::Messages WhyNotInteroperableDerivedType(const Symbol &, bool isError);
+  parser::Messages WhyNotInteroperableDerivedType(const Symbol &);
   parser::Messages WhyNotInteroperableObject(const Symbol &, bool isError);
   parser::Messages WhyNotInteroperableFunctionResult(const Symbol &);
   parser::Messages WhyNotInteroperableProcedure(const Symbol &, bool isError);
@@ -2892,13 +2892,12 @@ void CheckHelper::CheckProcedureAssemblyName(const Symbol &symbol) {
 }
 
 parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
-    const Symbol &symbol, bool isError) {
+    const Symbol &symbol) {
   parser::Messages msgs;
   if (examinedByWhyNotInteroperable_.find(symbol) !=
       examinedByWhyNotInteroperable_.end()) {
     return msgs;
   }
-  isError |= symbol.attrs().test(Attr::BIND_C);
   examinedByWhyNotInteroperable_.insert(symbol);
   if (const auto *derived{symbol.detailsIf<DerivedTypeDetails>()}) {
     if (derived->sequence()) { // C1801
@@ -2909,14 +2908,13 @@ parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
           "An interoperable derived type cannot have a type parameter"_err_en_US);
     } else if (const auto *parent{
                    symbol.scope()->GetDerivedTypeParent()}) { // C1803
-      if (isError) {
+      if (symbol.attrs().test(Attr::BIND_C)) {
         msgs.Say(symbol.name(),
             "A derived type with the BIND attribute cannot be an extended derived type"_err_en_US);
       } else {
         bool interoperableParent{true};
         if (parent->symbol()) {
-          auto bad{WhyNotInteroperableDerivedType(
-              *parent->symbol(), /*isError=*/false)};
+          auto bad{WhyNotInteroperableDerivedType(*parent->symbol())};
           if (bad.AnyFatalError()) {
             auto &msg{msgs.Say(symbol.name(),
                 "The parent of an interoperable type is not interoperable"_err_en_US)};
@@ -2946,8 +2944,7 @@ parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
             "An interoperable derived type cannot have a pointer or allocatable component"_err_en_US);
       } else if (const auto *type{component.GetType()}) {
         if (const auto *derived{type->AsDerived()}) {
-          auto bad{
-              WhyNotInteroperableDerivedType(derived->typeSymbol(), isError)};
+          auto bad{WhyNotInteroperableDerivedType(derived->typeSymbol())};
           if (bad.AnyFatalError()) {
             auto &msg{msgs.Say(component.name(),
                 "Component '%s' of an interoperable derived type must have an interoperable type but does not"_err_en_US,
@@ -2999,13 +2996,6 @@ parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
       }
     }
   }
-  if (isError) {
-    for (auto &m : msgs.messages()) {
-      if (!m.IsFatal()) {
-        m.set_severity(parser::Severity::Error);
-      }
-    }
-  }
   if (msgs.AnyFatalError()) {
     examinedByWhyNotInteroperable_.erase(symbol);
   }
@@ -3055,8 +3045,8 @@ parser::Messages CheckHelper::WhyNotInteroperableObject(
         msgs.Say(symbol.name(),
                 "The derived type of a BIND(C) object must also be BIND(C)"_err_en_US)
             .Attach(derived->typeSymbol().name(), "Non-BIND(C) type"_en_US);
-      } else if (auto bad{WhyNotInteroperableDerivedType(
-                     derived->typeSymbol(), /*isError=*/false)};
+      } else if (auto bad{
+                     WhyNotInteroperableDerivedType(derived->typeSymbol())};
                  bad.AnyFatalError()) {
         bad.AttachTo(
             msgs.Say(symbol.name(),
@@ -3261,8 +3251,7 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
       symbol.has<SubprogramDetails>()) {
     whyNot = WhyNotInteroperableProcedure(symbol, /*isError=*/isExplicitBindC);
   } else if (symbol.has<DerivedTypeDetails>()) {
-    whyNot =
-        WhyNotInteroperableDerivedType(symbol, /*isError=*/isExplicitBindC);
+    whyNot = WhyNotInteroperableDerivedType(symbol);
   }
   if (!whyNot.empty()) {
     bool anyFatal{whyNot.AnyFatalError()};

diff  --git a/flang/test/Semantics/bind-c15.f90 b/flang/test/Semantics/bind-c15.f90
index 9aaad52cc0e0a..82a3cbef791e8 100644
--- a/flang/test/Semantics/bind-c15.f90
+++ b/flang/test/Semantics/bind-c15.f90
@@ -16,6 +16,13 @@ module m
   type :: non_interoperable2
     type(non_interoperable1) b
   end type
+  type :: no_bind_c
+    real a
+  end type
+  type, bind(c) :: has_bind_c
+    !WARNING: Derived type of component 'a' of an interoperable derived type should have the BIND attribute
+    type(no_bind_c) :: a
+  end type
   interface
     subroutine sub_bind_c_1(x_bind_c) bind(c)
       import explicit_bind_c