Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

[flang] Relax checking of dummy procedures under BIND(C) #92474

Merged
merged 1 commit into from
May 17, 2024

Conversation

klausler
Copy link
Contributor

As was done recently to allow derived types that are not explicitly BIND(C), but meet the requirements of BIND(C), to be acceptable for use in contexts nominally requiring BIND(C), this patch allows procedures that are not explicitly BIND(C) to be used in contexts that nominally require BIND(C) so long as (1) they meet the requirements of BIND(C), and (2) don't use dummy arguments whose implementations may vary under BIND(C), such as VALUE.

@llvmbot llvmbot added flang Flang issues not falling into any other category flang:semantics labels May 16, 2024
@llvmbot
Copy link
Collaborator

llvmbot commented May 16, 2024

@llvm/pr-subscribers-flang-semantics

Author: Peter Klausler (klausler)

Changes

As was done recently to allow derived types that are not explicitly BIND(C), but meet the requirements of BIND(C), to be acceptable for use in contexts nominally requiring BIND(C), this patch allows procedures that are not explicitly BIND(C) to be used in contexts that nominally require BIND(C) so long as (1) they meet the requirements of BIND(C), and (2) don't use dummy arguments whose implementations may vary under BIND(C), such as VALUE.


Patch is 30.90 KiB, truncated to 20.00 KiB below, full version: https://github.com/llvm/llvm-project/pull/92474.diff

7 Files Affected:

  • (modified) flang/include/flang/Semantics/tools.h (+13-14)
  • (modified) flang/lib/Semantics/check-declarations.cpp (+242-174)
  • (modified) flang/test/Semantics/bind-c03.f90 (+3-3)
  • (modified) flang/test/Semantics/bind-c09.f90 (+9-9)
  • (modified) flang/test/Semantics/bind-c12.f90 (+68-3)
  • (modified) flang/test/Semantics/resolve81.f90 (+1)
  • (modified) flang/test/Semantics/resolve82.f90 (+1-1)
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index 46978441a640e..0b5308d9242de 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -213,8 +213,7 @@ inline bool IsCUDADeviceContext(const Scope *scope) {
 }
 
 inline bool HasCUDAAttr(const Symbol &sym) {
-  if (const auto *details{
-          sym.GetUltimate().detailsIf<semantics::ObjectEntityDetails>()}) {
+  if (const auto *details{sym.GetUltimate().detailsIf<ObjectEntityDetails>()}) {
     if (details->cudaDataAttr()) {
       return true;
     }
@@ -224,17 +223,18 @@ inline bool HasCUDAAttr(const Symbol &sym) {
 
 inline bool NeedCUDAAlloc(const Symbol &sym) {
   bool inDeviceSubprogram{IsCUDADeviceContext(&sym.owner())};
-  if (Fortran::semantics::IsDummy(sym))
+  if (IsDummy(sym)) {
     return false;
-  if (const auto *details{
-          sym.GetUltimate().detailsIf<semantics::ObjectEntityDetails>()}) {
+  }
+  if (const auto *details{sym.GetUltimate().detailsIf<ObjectEntityDetails>()}) {
     if (details->cudaDataAttr() &&
         (*details->cudaDataAttr() == common::CUDADataAttr::Device ||
             *details->cudaDataAttr() == common::CUDADataAttr::Managed ||
             *details->cudaDataAttr() == common::CUDADataAttr::Unified)) {
       // Descriptor is allocated on host when in host context.
-      if (Fortran::semantics::IsAllocatable(sym))
+      if (IsAllocatable(sym)) {
         return inDeviceSubprogram;
+      }
       return true;
     }
   }
@@ -246,7 +246,7 @@ std::optional<common::CUDADataAttr> GetCUDADataAttr(const Symbol *);
 
 // Return an error if a symbol is not accessible from a scope
 std::optional<parser::MessageFormattedText> CheckAccessibleSymbol(
-    const semantics::Scope &, const Symbol &);
+    const Scope &, const Symbol &);
 
 // Analysis of image control statements
 bool IsImageControlStmt(const parser::ExecutableConstruct &);
@@ -706,14 +706,13 @@ inline const parser::Name *getDesignatorNameIfDataRef(
 bool CouldBeDataPointerValuedFunction(const Symbol *);
 
 template <typename R, typename T>
-std::optional<R> GetConstExpr(
-    Fortran::semantics::SemanticsContext &semanticsContext, const T &x) {
-  using DefaultCharConstantType = Fortran::evaluate::Ascii;
-  if (const auto *expr{Fortran::semantics::GetExpr(semanticsContext, x)}) {
-    const auto foldExpr{Fortran::evaluate::Fold(
-        semanticsContext.foldingContext(), Fortran::common::Clone(*expr))};
+std::optional<R> GetConstExpr(SemanticsContext &semanticsContext, const T &x) {
+  using DefaultCharConstantType = evaluate::Ascii;
+  if (const auto *expr{GetExpr(semanticsContext, x)}) {
+    const auto foldExpr{evaluate::Fold(
+        semanticsContext.foldingContext(), common::Clone(*expr))};
     if constexpr (std::is_same_v<R, std::string>) {
-      return Fortran::evaluate::GetScalarConstantValue<DefaultCharConstantType>(
+      return evaluate::GetScalarConstantValue<DefaultCharConstantType>(
           foldExpr);
     }
   }
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 527a1a9539aa6..ef021e7b5c81b 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -139,8 +139,10 @@ class CheckHelper {
   void CheckProcedureAssemblyName(const Symbol &symbol);
   void CheckExplicitSave(const Symbol &);
   parser::Messages WhyNotInteroperableDerivedType(const Symbol &, bool isError);
+  parser::Messages WhyNotInteroperableObject(const Symbol &, bool isError);
+  parser::Messages WhyNotInteroperableFunctionResult(const Symbol &);
+  parser::Messages WhyNotInteroperableProcedure(const Symbol &, bool isError);
   void CheckBindC(const Symbol &);
-  void CheckBindCFunctionResult(const Symbol &);
   // Check functions for defined I/O procedures
   void CheckDefinedIoProc(
       const Symbol &, const GenericDetails &, common::DefinedIo);
@@ -189,8 +191,8 @@ class CheckHelper {
   // Collection of target dependent assembly names of external and BIND(C)
   // procedures.
   std::map<std::string, SymbolRef> procedureAssemblyNames_;
-  // Derived types that have been examined by WhyNotInteroperableDerivedType
-  UnorderedSymbolSet examinedByWhyNotInteroperableDerivedType_;
+  // Derived types that have been examined by WhyNotInteroperable_XXX
+  UnorderedSymbolSet examinedByWhyNotInteroperable_;
 };
 
 class DistinguishabilityHelper {
@@ -438,7 +440,6 @@ void CheckHelper::Check(const Symbol &symbol) {
       messages_.Say(
           "A function result may not also be a named constant"_err_en_US);
     }
-    CheckBindCFunctionResult(symbol);
   }
   if (IsAutomatic(symbol)) {
     if (const Symbol * common{FindCommonBlockContaining(symbol)}) {
@@ -510,35 +511,6 @@ void CheckHelper::CheckExplicitSave(const Symbol &symbol) {
   }
 }
 
-void CheckHelper::CheckBindCFunctionResult(const Symbol &symbol) { // C1553
-  if (!innermostSymbol_ || !IsBindCProcedure(*innermostSymbol_)) {
-    return;
-  }
-  if (IsPointer(symbol) || IsAllocatable(symbol)) {
-    messages_.Say(
-        "BIND(C) function result cannot have ALLOCATABLE or POINTER attribute"_err_en_US);
-  }
-  if (const DeclTypeSpec * type{symbol.GetType()};
-      type && type->category() == DeclTypeSpec::Character) {
-    bool isConstOne{false}; // 18.3.1(1)
-    if (const auto &len{type->characterTypeSpec().length().GetExplicit()}) {
-      if (auto constLen{evaluate::ToInt64(*len)}) {
-        isConstOne = constLen == 1;
-      }
-    }
-    if (!isConstOne) {
-      messages_.Say(
-          "BIND(C) character function result must have length one"_err_en_US);
-    }
-  }
-  if (symbol.Rank() > 0) {
-    messages_.Say("BIND(C) function result must be scalar"_err_en_US);
-  }
-  if (symbol.Corank()) {
-    messages_.Say("BIND(C) function result cannot be a coarray"_err_en_US);
-  }
-}
-
 void CheckHelper::CheckValue(
     const Symbol &symbol, const DerivedTypeSpec *derived) { // C863 - C865
   if (IsProcedure(symbol)) {
@@ -2870,12 +2842,12 @@ void CheckHelper::CheckProcedureAssemblyName(const Symbol &symbol) {
 parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
     const Symbol &symbol, bool isError) {
   parser::Messages msgs;
-  if (examinedByWhyNotInteroperableDerivedType_.find(symbol) !=
-      examinedByWhyNotInteroperableDerivedType_.end()) {
+  if (examinedByWhyNotInteroperable_.find(symbol) !=
+      examinedByWhyNotInteroperable_.end()) {
     return msgs;
   }
   isError |= symbol.attrs().test(Attr::BIND_C);
-  examinedByWhyNotInteroperableDerivedType_.insert(symbol);
+  examinedByWhyNotInteroperable_.insert(symbol);
   if (const auto *derived{symbol.detailsIf<DerivedTypeDetails>()}) {
     if (derived->sequence()) { // C1801
       msgs.Say(symbol.name(),
@@ -2971,7 +2943,7 @@ parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
     if (derived->componentNames().empty()) { // F'2023 C1805
       if (context_.ShouldWarn(common::LanguageFeature::EmptyBindCDerivedType)) {
         msgs.Say(symbol.name(),
-            "A derived type with the BIND attribute should not be empty"_port_en_US);
+            "A derived type with the BIND attribute should not be empty"_warn_en_US);
       }
     }
   }
@@ -2983,7 +2955,221 @@ parser::Messages CheckHelper::WhyNotInteroperableDerivedType(
     }
   }
   if (msgs.AnyFatalError()) {
-    examinedByWhyNotInteroperableDerivedType_.erase(symbol);
+    examinedByWhyNotInteroperable_.erase(symbol);
+  }
+  return msgs;
+}
+
+parser::Messages CheckHelper::WhyNotInteroperableObject(
+    const Symbol &symbol, bool isError) {
+  parser::Messages msgs;
+  if (examinedByWhyNotInteroperable_.find(symbol) !=
+      examinedByWhyNotInteroperable_.end()) {
+    return msgs;
+  }
+  bool isExplicitBindC{symbol.attrs().test(Attr::BIND_C)};
+  isError |= isExplicitBindC;
+  examinedByWhyNotInteroperable_.insert(symbol);
+  CHECK(symbol.has<ObjectEntityDetails>());
+  if (isExplicitBindC && !symbol.owner().IsModule()) {
+    messages_.Say(symbol.name(),
+        "A variable with BIND(C) attribute may only appear in the specification part of a module"_err_en_US);
+  }
+  auto shape{evaluate::GetShape(foldingContext_, symbol)};
+  if (shape) {
+    if (evaluate::GetRank(*shape) == 0) { // 18.3.4
+      if (IsAllocatableOrPointer(symbol) && !IsDummy(symbol)) {
+        messages_.Say(symbol.name(),
+            "A scalar interoperable variable may not be ALLOCATABLE or POINTER"_err_en_US);
+      }
+    } else if (auto extents{
+                   evaluate::AsConstantExtents(foldingContext_, *shape)}) {
+      if (evaluate::GetSize(*extents) == 0) {
+        msgs.Say(symbol.name(),
+            "Interoperable array must have at least one element"_err_en_US);
+      }
+    } else if (!evaluate::IsExplicitShape(symbol) &&
+        !IsAssumedSizeArray(symbol) &&
+        !(IsDummy(symbol) && !symbol.attrs().test(Attr::VALUE))) {
+      msgs.Say(symbol.name(),
+          "BIND(C) array must have explicit shape or be assumed-size unless a dummy argument without the VALUE attribute"_err_en_US);
+    }
+  }
+  if (const auto *type{symbol.GetType()}) {
+    const auto *derived{type->AsDerived()};
+    if (derived) {
+      if (derived->typeSymbol().attrs().test(Attr::BIND_C)) {
+      } else if (isError) {
+        if (auto *msg{messages_.Say(symbol.name(),
+                "The derived type of a BIND(C) object must also be BIND(C)"_err_en_US)}) {
+          msg->Attach(derived->typeSymbol().name(), "Non-BIND(C) type"_en_US);
+        }
+        context_.SetError(symbol);
+      } else if (auto bad{WhyNotInteroperableDerivedType(
+                     derived->typeSymbol(), /*isError=*/false)};
+                 bad.AnyFatalError()) {
+        if (auto *msg{messages_.Say(symbol.name(),
+                "The derived type of an interoperable object must be interoperable, but is not"_err_en_US)}) {
+          msg->Attach(
+              derived->typeSymbol().name(), "Non-interoperable type"_en_US);
+          bad.AttachTo(*msg, parser::Severity::None);
+        }
+      } else {
+        if (auto *msg{messages_.Say(symbol.name(),
+                "The derived type of an interoperable object should be BIND(C)"_warn_en_US)}) {
+          msg->Attach(derived->typeSymbol().name(), "Non-BIND(C) type"_en_US);
+        }
+      }
+    }
+    if (type->IsAssumedType()) { // ok
+    } else if (IsAssumedLengthCharacter(symbol)) {
+      if (const auto *subp{symbol.owner().symbol()};
+          subp && !subp->attrs().test(Attr::BIND_C)) {
+        msgs.Say(symbol.name(),
+            "An assumed-length dummy argument must not appear in a non-BIND(C) subprogram that needs to be interoperable"_err_en_US);
+      }
+    } else if (IsAllocatableOrPointer(symbol) &&
+        type->category() == DeclTypeSpec::Character &&
+        type->characterTypeSpec().length().isDeferred()) {
+      // ok; F'2023 18.3.7 p2(6)
+    } else if (derived ||
+        IsInteroperableIntrinsicType(*type, context_.languageFeatures())) {
+      // F'2023 18.3.7 p2(4,5)
+    } else if (type->category() == DeclTypeSpec::Logical) {
+      if (context_.ShouldWarn(common::UsageWarning::LogicalVsCBool) &&
+          !InModuleFile()) {
+        if (IsDummy(symbol)) {
+          msgs.Say(symbol.name(),
+              "A BIND(C) LOGICAL dummy argument should have the interoperable KIND=C_BOOL"_port_en_US);
+        } else {
+          msgs.Say(symbol.name(),
+              "A BIND(C) LOGICAL object should have the interoperable KIND=C_BOOL"_port_en_US);
+        }
+      }
+    } else if (symbol.attrs().test(Attr::VALUE)) {
+      msgs.Say(symbol.name(),
+          "A BIND(C) VALUE dummy argument must have an interoperable type"_err_en_US);
+    } else {
+      msgs.Say(symbol.name(),
+          "A BIND(C) object must have an interoperable type"_err_en_US);
+    }
+  }
+  if (IsOptional(symbol) && !symbol.attrs().test(Attr::VALUE)) {
+    msgs.Say(symbol.name(),
+        "An interoperable procedure with an OPTIONAL dummy argument might not be portable"_port_en_US);
+  }
+  if (symbol.attrs().test(Attr::VALUE)) {
+    if (const auto *subp{symbol.owner().symbol()};
+        subp && !subp->attrs().test(Attr::BIND_C)) {
+      msgs.Say(symbol.name(),
+          "A VALUE dummy argument must not appear in a non-BIND(C) subprogram that needs to be interoperable"_err_en_US);
+    }
+  }
+  if (IsDescriptor(symbol) && IsPointer(symbol) &&
+      symbol.attrs().test(Attr::CONTIGUOUS)) {
+    msgs.Say(symbol.name(),
+        "An interoperable pointer must not be CONTIGUOUS"_err_en_US);
+  }
+  if (msgs.AnyFatalError()) {
+    examinedByWhyNotInteroperable_.erase(symbol);
+  }
+  return msgs;
+}
+
+parser::Messages CheckHelper::WhyNotInteroperableFunctionResult(
+    const Symbol &symbol) {
+  parser::Messages msgs;
+  if (IsPointer(symbol) || IsAllocatable(symbol)) {
+    msgs.Say(symbol.name(),
+        "Interoperable function result may not have ALLOCATABLE or POINTER attribute"_err_en_US);
+  }
+  if (const DeclTypeSpec * type{symbol.GetType()};
+      type && type->category() == DeclTypeSpec::Character) {
+    bool isConstOne{false}; // 18.3.1(1)
+    if (const auto &len{type->characterTypeSpec().length().GetExplicit()}) {
+      if (auto constLen{evaluate::ToInt64(*len)}) {
+        isConstOne = constLen == 1;
+      }
+    }
+    if (!isConstOne) {
+      msgs.Say(symbol.name(),
+          "Interoperable character function result must have length one"_err_en_US);
+    }
+  }
+  if (symbol.Rank() > 0) {
+    msgs.Say(symbol.name(),
+        "Interoperable function result must be scalar"_err_en_US);
+  }
+  if (symbol.Corank()) {
+    msgs.Say(symbol.name(),
+        "Interoperable function result may not be a coarray"_err_en_US);
+  }
+  return msgs;
+}
+
+parser::Messages CheckHelper::WhyNotInteroperableProcedure(
+    const Symbol &symbol, bool isError) {
+  parser::Messages msgs;
+  if (examinedByWhyNotInteroperable_.find(symbol) !=
+      examinedByWhyNotInteroperable_.end()) {
+    return msgs;
+  }
+  isError |= symbol.attrs().test(Attr::BIND_C);
+  examinedByWhyNotInteroperable_.insert(symbol);
+  if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
+    if (isError) {
+      if (!proc->procInterface() ||
+          !proc->procInterface()->attrs().test(Attr::BIND_C)) {
+        msgs.Say(symbol.name(),
+            "An interface name with the BIND attribute must appear if the BIND attribute appears in a procedure declaration"_err_en_US);
+      }
+    } else if (!proc->procInterface()) {
+      msgs.Say(symbol.name(),
+          "An interoperable procedure should have an interface"_port_en_US);
+    } else if (!proc->procInterface()->attrs().test(Attr::BIND_C)) {
+      auto bad{WhyNotInteroperableProcedure(
+          *proc->procInterface(), /*isError=*/false)};
+      if (bad.AnyFatalError()) {
+        bad.AttachTo(msgs.Say(symbol.name(),
+            "An interoperable procedure must have an interoperable interface"_err_en_US));
+      } else {
+        msgs.Say(symbol.name(),
+            "An interoperable procedure should have an interface with the BIND attribute"_warn_en_US);
+      }
+    }
+  } else if (const auto *subp{symbol.detailsIf<SubprogramDetails>()}) {
+    for (const Symbol *dummy : subp->dummyArgs()) {
+      if (dummy) {
+        parser::Messages dummyMsgs;
+        if (dummy->has<ProcEntityDetails>() ||
+            dummy->has<SubprogramDetails>()) {
+          dummyMsgs = WhyNotInteroperableProcedure(*dummy, /*isError=*/false);
+          if (dummyMsgs.empty() && !dummy->attrs().test(Attr::BIND_C)) {
+            dummyMsgs.Say(dummy->name(),
+                "A dummy procedure of an interoperable procedure should be BIND(C)"_warn_en_US);
+          }
+        } else if (dummy->has<ObjectEntityDetails>()) {
+          dummyMsgs = WhyNotInteroperableObject(*dummy, /*isError=*/false);
+        } else {
+          CheckBindC(*dummy);
+        }
+        msgs.Annex(std::move(dummyMsgs));
+      } else {
+        msgs.Say(symbol.name(),
+            "A subprogram interface with the BIND attribute may not have an alternate return argument"_err_en_US);
+      }
+    }
+    if (subp->isFunction()) {
+      if (subp->result().has<ObjectEntityDetails>()) {
+        msgs.Annex(WhyNotInteroperableFunctionResult(subp->result()));
+      } else {
+        msgs.Say(subp->result().name(),
+            "The result of an interoperable function must be a data object"_err_en_US);
+      }
+    }
+  }
+  if (msgs.AnyFatalError()) {
+    examinedByWhyNotInteroperable_.erase(symbol);
   }
   return msgs;
 }
@@ -2998,6 +3184,7 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
     // symbol must be interoperable (e.g., dummy argument of interoperable
     // procedure interface) but is not itself BIND(C).
   }
+  parser::Messages whyNot;
   if (const std::string * bindName{symbol.GetBindName()};
       bindName) { // has a binding name
     if (!bindName->empty()) {
@@ -3032,143 +3219,24 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
     }
   }
   if (symbol.has<ObjectEntityDetails>()) {
-    if (isExplicitBindC && !symbol.owner().IsModule()) {
-      messages_.Say(symbol.name(),
-          "A variable with BIND(C) attribute may only appear in the specification part of a module"_err_en_US);
-      context_.SetError(symbol);
-    }
-    auto shape{evaluate::GetShape(foldingContext_, symbol)};
-    if (shape) {
-      if (evaluate::GetRank(*shape) == 0) { // 18.3.4
-        if (isExplicitBindC && IsAllocatableOrPointer(symbol)) {
-          messages_.Say(symbol.name(),
-              "A scalar interoperable variable may not be ALLOCATABLE or POINTER"_err_en_US);
-          context_.SetError(symbol);
-        }
-      } else { // 18.3.5
-        if (auto extents{
-                evaluate::AsConstantExtents(foldingContext_, *shape)}) {
-          if (evaluate::GetSize(*extents) == 0) {
-            SayWithDeclaration(symbol, symbol.name(),
-                "Interoperable array must have at least one element"_err_en_US);
-            context_.SetError(symbol);
-          }
-        } else if ((isExplicitBindC || symbol.attrs().test(Attr::VALUE)) &&
-            !evaluate::IsExplicitShape(symbol) && !IsAssumedSizeArray(symbol)) {
-          SayWithDeclaration(symbol, symbol.name(),
-              "BIND(C) array must have explicit shape or be assumed-size unless a dummy argument without the VALUE attribute"_err_en_US);
-          context_.SetError(symbol);
-        }
-      }
-    }
-    if (const auto *type{symbol.GetType()}) {
-      const auto *derived{type->AsDerived()};
-      if (derived) {
-        if (derived->typeSymbol().attrs().test(Attr::BIND_C)) {
-        } else if (isExplicitBindC) {
-          if (auto *msg{messages_.Say(symbol.name(),
-                  "The derived type of a BIND(C) object must also be BIND(C)"_err_en_US)}) {
-            msg->Attach(derived->typeSymbol().name(), "Non-BIND(C) type"_en_US);
-          }
-          context_.SetError(symbol);
-        } else if (auto bad{WhyNotInteroperableDerivedType(
-                       derived->typeSymbol(), /*isError=*/false)};
-                   bad.AnyFatalError()) {
-          if (auto *msg{messages_.Say(symbol.name(),
-                  "The derived type of an interoperable object must be interoperable, but is not"_err_en_US)}) {
-            msg->Attach(
-                derived->typeSymbol().name(), "Non-interoperable type"_en_US);
-            bad.AttachTo(*msg, parser::Severity::None);
-          }
-          context_.SetError(symbol);
-        } else if (context_.ShouldWarn(
-                       common::LanguageFeature::NonBindCInteroperability) &&
-            !InModuleFile()) {
-          if (auto *msg{messages_.Say(symbol.name(),
-                  "The derived type of an interoperable object should be BIND(C)"_warn_en_US)}) {
-            msg->Attach(derived->typeSymbol().name(), "Non-BIND(C) type"_en_US);
-          }
-        }
-      }
-      if (type->IsAssumedType() || IsAssumedLengthCharacter(symbol)) {
-        // ok
-      } else if (IsAllocatableOrPointer(symbol) &&
-          type->category() == DeclTypeSpec::Character &&
-          type->characterTypeSpec().length().isDeferred()) {
-        // ok; F'2023 18.3.7 p2(6)
-      } else if (derived ||
-          IsInteroperableIntrinsicType(*type, context_.languageFeatures())) {
-        // F'2023 18.3.7 p2(4,5)
-      } else if (type->cate...
[truncated]

As was done recently to allow derived types that are not
explicitly BIND(C), but meet the requirements of BIND(C),
to be acceptable for use in contexts nominally requiring
BIND(C), this patch allows procedures that are not explicitly
BIND(C) to be used in contexts that nominally require BIND(C)
so long as (1) they meet the requirements of BIND(C), and
(2) don't use dummy arguments whose implementations may vary
under BIND(C), such as VALUE.
@klausler klausler merged commit ab7930b into llvm:main May 17, 2024
3 of 4 checks passed
@klausler klausler deleted the zhen branch May 17, 2024 22:50
@DanielCChen
Copy link
Contributor

DanielCChen commented May 22, 2024

@klausler This PR seems broke some of our test cases. The following is a reproducer.

subroutine sub(a) bind(c)
  use, intrinsic :: iso_c_binding
  integer(c_int16_t), value :: a
  entry ent_intval1 (a)
  return
end

Flang now complains:

t.f:3:32: error: A VALUE dummy argument must not appear in a non-BIND(C) entry of a subprogram with an entry that must be interoperable
    integer(c_int16_t), value :: a
                                 ^

XLF, ifort and gfortran seem all accept the code.

@klausler
Copy link
Contributor Author

That is exactly the kind of usage that I wanted to catch; will investigate further to see whether this situation is really a problem or not.

@DanielCChen
Copy link
Contributor

That is exactly the kind of usage that I wanted to catch; will investigate further to see whether this situation is really a problem or not.

Thanks.
Adding bind(c) to the entry statement will make the code compile.

@klausler
Copy link
Contributor Author

That is exactly the kind of usage that I wanted to catch; will investigate further to see whether this situation is really a problem or not.

Thanks. Adding bind(c) to the entry statement will make the code compile.

Yes, having BIND(C) on both entry points resolves the discrepancy. My worry here is that the BIND(C) entry point will expect a VALUE argument to arrive in a register and the non-BIND(C) entry point will not; but maybe it doesn't matter.

klausler added a commit to klausler/llvm-project that referenced this pull request May 22, 2024
Two checks related to BIND(C) vs non-BIND(C) entry points with
the same dummy argument added by llvm#92474
have turned out to be unnecessary.  Revert them and adjust the tests.
@klausler
Copy link
Contributor Author

Addressed by #93112.

klausler added a commit that referenced this pull request May 23, 2024
Two checks related to BIND(C) vs non-BIND(C) entry points with the same
dummy argument added by #92474
have turned out to be unnecessary. Revert them and adjust the tests.
@klausler
Copy link
Contributor Author

The fix has been merged.

jameshu15869 pushed a commit to jameshu15869/llvm-project that referenced this pull request May 31, 2024
Two checks related to BIND(C) vs non-BIND(C) entry points with the same
dummy argument added by llvm#92474
have turned out to be unnecessary. Revert them and adjust the tests.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Labels
flang:semantics flang Flang issues not falling into any other category
Projects
None yet
Development

Successfully merging this pull request may close these issues.

None yet

5 participants