[flang-commits] [flang] [flang] Catch bad members of BIND(C) COMMON block (PR #148971)

[via flang-commits]

llvmbot wrote:


<!--LLVM PR SUMMARY COMMENT-->

@llvm/pr-subscribers-flang-semantics

Author: Peter Klausler (klausler)

<details>
<summary>Changes</summary>

Variables that can't be BIND(C), like pointers, can't be in a BIND(C) common block, either.

Fixes https://github.com/llvm/llvm-project/issues/148922.

---
Full diff: https://github.com/llvm/llvm-project/pull/148971.diff


2 Files Affected:

- (modified) flang/lib/Semantics/check-declarations.cpp (+29-10) 
- (added) flang/test/Semantics/bind-c18.f90 (+7) 


``````````diff
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index f9d64485f1407..04fedcee20f12 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -151,8 +151,8 @@ class CheckHelper {
   void CheckProcedureAssemblyName(const Symbol &symbol);
   void CheckExplicitSave(const Symbol &);
   parser::Messages WhyNotInteroperableDerivedType(const Symbol &);
-  parser::Messages WhyNotInteroperableObject(
-      const Symbol &, bool allowNonInteroperableType = false);
+  parser::Messages WhyNotInteroperableObject(const Symbol &,
+      bool allowNonInteroperableType = false, bool forCommonBlock = false);
   parser::Messages WhyNotInteroperableFunctionResult(const Symbol &);
   parser::Messages WhyNotInteroperableProcedure(const Symbol &, bool isError);
   void CheckBindC(const Symbol &);
@@ -519,11 +519,28 @@ void CheckHelper::Check(const Symbol &symbol) {
 }
 
 void CheckHelper::CheckCommonBlock(const Symbol &symbol) {
+  auto restorer{messages_.SetLocation(symbol.name())};
   CheckGlobalName(symbol);
   if (symbol.attrs().test(Attr::BIND_C)) {
     CheckBindC(symbol);
+    for (auto ref : symbol.get<CommonBlockDetails>().objects()) {
+      if (ref->has<ObjectEntityDetails>()) {
+        if (auto msgs{WhyNotInteroperableObject(*ref,
+                /*allowInteroperableType=*/false, /*forCommonBlock=*/true)};
+            !msgs.empty()) {
+          if (auto *msg{messages_.Say(symbol.name(),
+                  "'%s' may not be a member of BIND(C) COMMON block /%s/"_err_en_US,
+                  ref->name(), symbol.name())}) {
+            for (parser::Message &reason : msgs.messages()) {
+              reason.set_severity(parser::Severity::Because);
+              msg->Attach(std::move(reason));
+            }
+          }
+        }
+      }
+    }
   }
-  for (MutableSymbolRef ref : symbol.get<CommonBlockDetails>().objects()) {
+  for (auto ref : symbol.get<CommonBlockDetails>().objects()) {
     if (ref->test(Symbol::Flag::CrayPointee)) {
       messages_.Say(ref->name(),
           "Cray pointee '%s' may not be a member of a COMMON block"_err_en_US,
@@ -3154,14 +3171,16 @@ parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
 }
 
 parser::Messages CheckHelper::WhyNotInteroperableObject(
-    const Symbol &symbol, bool allowNonInteroperableType) {
+    const Symbol &symbol, bool allowNonInteroperableType, bool forCommonBlock) {
   parser::Messages msgs;
-  if (examinedByWhyNotInteroperable_.find(symbol) !=
-      examinedByWhyNotInteroperable_.end()) {
-    return msgs;
+  if (!forCommonBlock) {
+    if (examinedByWhyNotInteroperable_.find(symbol) !=
+        examinedByWhyNotInteroperable_.end()) {
+      return msgs;
+    }
+    examinedByWhyNotInteroperable_.insert(symbol);
   }
   bool isExplicitBindC{symbol.attrs().test(Attr::BIND_C)};
-  examinedByWhyNotInteroperable_.insert(symbol);
   CHECK(symbol.has<ObjectEntityDetails>());
   if (isExplicitBindC && !symbol.owner().IsModule()) {
     msgs.Say(symbol.name(),
@@ -3338,8 +3357,8 @@ parser::Messages CheckHelper::WhyNotInteroperableProcedure(
           // 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);
+          dummyMsgs = WhyNotInteroperableObject(
+              *dummy, allowNonInteroperableType, /*forCommonBlock=*/false);
         } else {
           CheckBindC(*dummy);
         }
diff --git a/flang/test/Semantics/bind-c18.f90 b/flang/test/Semantics/bind-c18.f90
new file mode 100644
index 0000000000000..98a90796c514d
--- /dev/null
+++ b/flang/test/Semantics/bind-c18.f90
@@ -0,0 +1,7 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+bind(c) :: /blk/
+!ERROR: 'x' may not be a member of BIND(C) COMMON block /blk/
+!BECAUSE: A scalar interoperable variable may not be ALLOCATABLE or POINTER
+common /blk/ x
+integer, pointer :: x
+end

``````````

</details>


https://github.com/llvm/llvm-project/pull/148971