diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md index 14410f17ab8a..82f9a021c14e 100644 --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -374,6 +374,9 @@ end required, with warnings, even if it lacks the BIND(C) attribute. * A "mult-operand" in an expression can be preceded by a unary `+` or `-` operator. +* `BIND(C, NAME="...", CDEFINED)` signifies that the storage for an + interoperable variable will be allocated outside of Fortran, + probably by a C or C++ external definition. ### Extensions supported when enabled by options diff --git a/flang/include/flang/Parser/parse-tree.h b/flang/include/flang/Parser/parse-tree.h index 12e35075d2a6..f0b9b682030c 100644 --- a/flang/include/flang/Parser/parse-tree.h +++ b/flang/include/flang/Parser/parse-tree.h @@ -1296,10 +1296,13 @@ struct AcImpliedDo { }; // R808 language-binding-spec -> -// BIND ( C [, NAME = scalar-default-char-constant-expr] ) +// BIND ( C [, NAME = scalar-default-char-constant-expr ] +// [, CDEFINED ] ) // R1528 proc-language-binding-spec -> language-binding-spec -WRAPPER_CLASS( - LanguageBindingSpec, std::optional); +struct LanguageBindingSpec { + TUPLE_CLASS_BOILERPLATE(LanguageBindingSpec); + std::tuple, bool> t; +}; // R852 named-constant-def -> named-constant = constant-expr struct NamedConstantDef { diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h index 357a4c76d997..cdbe3e39386b 100644 --- a/flang/include/flang/Semantics/symbol.h +++ b/flang/include/flang/Semantics/symbol.h @@ -115,10 +115,13 @@ public: bool isExplicitBindName() const { return isExplicitBindName_; } void set_bindName(std::string &&name) { bindName_ = std::move(name); } void set_isExplicitBindName(bool yes) { isExplicitBindName_ = yes; } + bool isCDefined() const { return isCDefined_; } + void set_isCDefined(bool yes) { isCDefined_ = yes; } private: std::optional bindName_; bool isExplicitBindName_{false}; + bool isCDefined_{false}; }; // Device type specific OpenACC routine information @@ -814,6 +817,7 @@ public: void SetBindName(std::string &&); bool GetIsExplicitBindName() const; void SetIsExplicitBindName(bool); + void SetIsCDefined(bool); bool IsFuncResult() const; bool IsObjectArray() const; const ArraySpec *GetShape() const; diff --git a/flang/lib/Parser/Fortran-parsers.cpp b/flang/lib/Parser/Fortran-parsers.cpp index ff01974b549a..13f15c84e579 100644 --- a/flang/lib/Parser/Fortran-parsers.cpp +++ b/flang/lib/Parser/Fortran-parsers.cpp @@ -735,7 +735,8 @@ TYPE_PARSER(construct("PUBLIC" >> pure(AccessSpec::Kind::Public)) || // BIND ( C [, NAME = scalar-default-char-constant-expr] ) // R1528 proc-language-binding-spec -> language-binding-spec TYPE_PARSER(construct( - "BIND ( C" >> maybe(", NAME =" >> scalarDefaultCharConstantExpr) / ")")) + "BIND ( C" >> maybe(", NAME =" >> scalarDefaultCharConstantExpr), + (", CDEFINED" >> pure(true) || pure(false)) / ")")) // R809 coarray-spec -> deferred-coshape-spec-list | explicit-coshape-spec // N.B. Bracketed here rather than around references, for consistency with diff --git a/flang/lib/Parser/unparse.cpp b/flang/lib/Parser/unparse.cpp index b98aae8e8f7a..13ca2309ad50 100644 --- a/flang/lib/Parser/unparse.cpp +++ b/flang/lib/Parser/unparse.cpp @@ -524,7 +524,13 @@ public: Word("NULL()"); } void Unparse(const LanguageBindingSpec &x) { // R808 & R1528 - Word("BIND(C"), Walk(", NAME=", x.v), Put(')'); + Word("BIND(C"); + Walk( + ", NAME=", std::get>(x.t)); + if (std::get(x.t)) { + Word(", CDEFINED"); + } + Put(')'); } void Unparse(const CoarraySpec &x) { // R809 common::visit(common::visitors{ diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index 7397c3a51b61..17ff12568b06 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -315,6 +315,7 @@ private: bool IsConflictingAttr(Attr); MaybeExpr bindName_; // from BIND(C, NAME="...") + bool isCDefined_{false}; // BIND(C, NAME="...", CDEFINED) extension std::optional passName_; // from PASS(...) }; @@ -1762,6 +1763,7 @@ Attrs AttrsVisitor::EndAttrs() { cudaDataAttr_.reset(); passName_ = std::nullopt; bindName_.reset(); + isCDefined_ = false; return result; } @@ -1783,6 +1785,7 @@ void AttrsVisitor::SetBindNameOn(Symbol &symbol) { !symbol.attrs().test(Attr::BIND_C)) { return; } + symbol.SetIsCDefined(isCDefined_); std::optional label{ evaluate::GetScalarConstantValue(bindName_)}; // 18.9.2(2): discard leading and trailing blanks @@ -1820,9 +1823,12 @@ void AttrsVisitor::SetBindNameOn(Symbol &symbol) { void AttrsVisitor::Post(const parser::LanguageBindingSpec &x) { if (CheckAndSet(Attr::BIND_C)) { - if (x.v) { - bindName_ = EvaluateExpr(*x.v); + if (const auto &name{ + std::get>( + x.t)}) { + bindName_ = EvaluateExpr(*name); } + isCDefined_ = std::get(x.t); } } bool AttrsVisitor::Pre(const parser::IntentSpec &x) { @@ -4056,7 +4062,9 @@ void SubprogramVisitor::CreateEntry( Attrs attrs; const auto &suffix{std::get>(stmt.t)}; bool hasGlobalBindingName{outer.IsGlobal() && suffix && suffix->binding && - suffix->binding->v.has_value()}; + std::get>( + suffix->binding->t) + .has_value()}; if (!hasGlobalBindingName) { if (Symbol * extant{FindSymbol(outer, entryName)}) { if (!HandlePreviousCalls(entryName, *extant, subpFlag)) { @@ -4440,7 +4448,10 @@ Symbol &SubprogramVisitor::PushSubprogramScope(const parser::Name &name, bool hasModulePrefix) { Symbol *symbol{GetSpecificFromGeneric(name)}; if (!symbol) { - if (bindingSpec && currScope().IsGlobal() && bindingSpec->v) { + if (bindingSpec && currScope().IsGlobal() && + std::get>( + bindingSpec->t) + .has_value()) { // Create this new top-level subprogram with a binding label // in a new global scope, so that its symbol's name won't clash // with another symbol that has a distinct binding label. @@ -5670,7 +5681,9 @@ bool DeclarationVisitor::Pre(const parser::ProcedureDeclarationStmt &x) { const auto &procAttrSpec{std::get>(x.t)}; for (const parser::ProcAttrSpec &procAttr : procAttrSpec) { if (auto *bindC{std::get_if(&procAttr.u)}) { - if (bindC->v.has_value()) { + if (std::get>( + bindC->t) + .has_value()) { if (std::get>(x.t).size() > 1) { Say(context().location().value(), "A procedure declaration statement with a binding name may not declare multiple procedures"_err_en_US); diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp index 3eb120fd962f..023ab7b64e4f 100644 --- a/flang/lib/Semantics/symbol.cpp +++ b/flang/lib/Semantics/symbol.cpp @@ -375,6 +375,18 @@ void Symbol::SetIsExplicitBindName(bool yes) { details_); } +void Symbol::SetIsCDefined(bool yes) { + common::visit( + [&](auto &x) { + if constexpr (HasBindName) { + x.set_isCDefined(yes); + } else { + DIE("CDEFINED not allowed on this kind of symbol"); + } + }, + details_); +} + bool Symbol::IsFuncResult() const { return common::visit( common::visitors{[](const EntityDetails &x) { return x.isFuncResult(); }, @@ -422,6 +434,7 @@ llvm::raw_ostream &operator<<(llvm::raw_ostream &os, const EntityDetails &x) { os << " type: " << *x.type(); } DumpOptional(os, "bindName", x.bindName()); + DumpBool(os, "CDEFINED", x.isCDefined()); return os; } diff --git a/flang/test/Semantics/bind-c16.f90 b/flang/test/Semantics/bind-c16.f90 index b9dfb03e35ee..77c1a9160889 100644 --- a/flang/test/Semantics/bind-c16.f90 +++ b/flang/test/Semantics/bind-c16.f90 @@ -84,3 +84,8 @@ module m3 end end interface end + +!CHECK: cdef01, BIND(C), PUBLIC size=4 offset=0: ObjectEntity type: REAL(4) bindName:cDef01 CDEFINED +module m4 + real, bind(c, name='cDef01', cdefined) :: cdef01 +end