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

[Peter Klausler via flang-commits]

https://github.com/klausler created https://github.com/llvm/llvm-project/pull/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.

>From 470cc65710eab04d5bc9e4a1034af2a270a2c3e9 Mon Sep 17 00:00:00 2001
From: Peter Klausler <pklausler at nvidia.com>
Date: Tue, 4 Jun 2024 12:52:26 -0700
Subject: [PATCH] [flang] Relax BIND(C) derived type component check

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.
---
 flang/lib/Semantics/check-declarations.cpp | 27 +++++++---------------
 flang/test/Semantics/bind-c15.f90          |  7 ++++++
 2 files changed, 15 insertions(+), 19 deletions(-)

diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 25de9d4af1ffb..64814b554000e 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);
@@ -2861,13 +2861,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
@@ -2878,14 +2877,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)};
@@ -2915,8 +2913,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,
@@ -2968,13 +2965,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);
   }
@@ -3024,8 +3014,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(),
@@ -3230,8 +3220,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