[flang] Save binding labels as strings

[tskeith]

Summary

Binding labels start as expressions but they have to evaluate to
constant character of default kind, so they can be represented as an
std::string. Leading and trailing blanks have to be removed, so the
folded expression isn't exactly right anyway.

So all BIND(C) symbols now have a string binding label, either the
default or user-supplied one. This is recorded in the .mod file.

Add WithBindName mix-in for details classes that can have a binding
label so that they are all consistent. Add GetBindName() and
SetBindName() member functions to Symbol.

Add tests that verifies that leading and trailing blanks are ignored
in binding labels and that the default label is folded to lower case.

[tskeith]

Remove debugging code

[klausler]

flang/include/flang/Evaluate/type.h

55 ↗

(On Diff #332773)

CHARACTER(1) may not be the default CHARACTER kind in all compilations; I'm specifically thinking about legacy Kanji modes. You might want a different name.

[tskeith]

Remove misleading DefaultCharacter typedef.

[tskeith]

flang/include/flang/Evaluate/type.h

55 ↗

(On Diff #332773)

I've removed DefaultCharacter.

[jeanPerier]

LGTM, thanks that will make the lowering part cleaner.

[tskeith]

Fix assignment to label.

flang/include/flang/Semantics/symbol.h

private:
   const Scope *scope_{nullptr};
 };
 
 class MainProgramDetails {
 public:
 private:
 };
 
-class SubprogramDetails {
+class WithBindName {
+public:
+  const std::string *bindName() const {
+    return bindName_ ? &*bindName_ : nullptr;
+  }
+  void set_bindName(std::string &&name) { bindName_ = std::move(name); }
+
+private:
+  std::optional<std::string> bindName_;
+};
+
+class SubprogramDetails : public WithBindName {
 public:
   bool isFunction() const { return result_ != nullptr; }
   bool isInterface() const { return isInterface_; }
   void set_isInterface(bool value = true) { isInterface_ = value; }
   Scope *entryScope() { return entryScope_; }
   const Scope *entryScope() const { return entryScope_; }
   void set_entryScope(Scope &scope) { entryScope_ = &scope; }
-  MaybeExpr bindName() const { return bindName_; }
-  void set_bindName(MaybeExpr &&expr) { bindName_ = std::move(expr); }
   const Symbol &result() const {
     CHECK(isFunction());
     return *result_;
   }
   void set_result(Symbol &result) {
     CHECK(!result_);
     result_ = &result;
   }
   const std::vector<Symbol *> &dummyArgs() const { return dummyArgs_; }
   void add_dummyArg(Symbol &symbol) { dummyArgs_.push_back(&symbol); }
   void add_alternateReturn() { dummyArgs_.push_back(nullptr); }
   const MaybeExpr &stmtFunction() const { return stmtFunction_; }
   void set_stmtFunction(SomeExpr &&expr) { stmtFunction_ = std::move(expr); }
 
 private:
   bool isInterface_{false}; // true if this represents an interface-body
-  MaybeExpr bindName_;
   std::vector<Symbol *> dummyArgs_; // nullptr -> alternate return indicator
   Symbol *result_{nullptr};
   Scope *entryScope_{nullptr}; // if ENTRY, points to subprogram's scope
   MaybeExpr stmtFunction_;
   friend llvm::raw_ostream &operator<<(
       llvm::raw_ostream &, const SubprogramDetails &);
 };
 
public:
   ProgramTree &node() const { return *node_; }
 
 private:
   SubprogramKind kind_;
   common::Reference<ProgramTree> node_;
 };
 
 // A name from an entity-decl -- could be object or function.
-class EntityDetails {
+class EntityDetails : public WithBindName {
 public:
   explicit EntityDetails(bool isDummy = false) : isDummy_{isDummy} {}
   const DeclTypeSpec *type() const { return type_; }
   void set_type(const DeclTypeSpec &);
   void ReplaceType(const DeclTypeSpec &);
   bool isDummy() const { return isDummy_; }
   void set_isDummy(bool value = true) { isDummy_ = value; }
   bool isFuncResult() const { return isFuncResult_; }
   void set_funcResult(bool x) { isFuncResult_ = x; }
-  MaybeExpr bindName() const { return bindName_; }
-  void set_bindName(MaybeExpr &&expr) { bindName_ = std::move(expr); }
 
 private:
   bool isDummy_{false};
   bool isFuncResult_{false};
   const DeclTypeSpec *type_{nullptr};
-  MaybeExpr bindName_;
   friend llvm::raw_ostream &operator<<(
       llvm::raw_ostream &, const EntityDetails &);
 };
 
 // Symbol is associated with a name or expression in a SELECT TYPE or ASSOCIATE.
 class AssocEntityDetails : public EntityDetails {
 public:
   AssocEntityDetails() {}
public:
   void add_objects(const SymbolVector &objects) {
     objects_.insert(objects_.end(), objects.begin(), objects.end());
   }
 
 private:
   SymbolVector objects_;
 };
 
-class CommonBlockDetails {
+class CommonBlockDetails : public WithBindName {
 public:
   MutableSymbolVector &objects() { return objects_; }
   const MutableSymbolVector &objects() const { return objects_; }
   void add_object(Symbol &object) { objects_.emplace_back(object); }
-  MaybeExpr bindName() const { return bindName_; }
-  void set_bindName(MaybeExpr &&expr) { bindName_ = std::move(expr); }
   std::size_t alignment() const { return alignment_; }
   void set_alignment(std::size_t alignment) { alignment_ = alignment; }
 
 private:
   MutableSymbolVector objects_;
-  MaybeExpr bindName_;
   std::size_t alignment_{0}; // required alignment in bytes
 };
 
 class MiscDetails {
 public:
   ENUM_CLASS(Kind, None, ConstructName, ScopeName, PassName, ComplexPartRe,
       ComplexPartIm, KindParamInquiry, LenParamInquiry, SelectRankAssociateName,
       SelectTypeAssociateName, TypeBoundDefinedOp);
public:
   bool CanReplaceDetails(const Details &details) const;
 
   // Follow use-associations and host-associations to get the ultimate entity.
   inline Symbol &GetUltimate();
   inline const Symbol &GetUltimate() const;
 
   inline DeclTypeSpec *GetType();
   inline const DeclTypeSpec *GetType() const;
-
   void SetType(const DeclTypeSpec &);
+
+  const std::string *GetBindName() const;
+  void SetBindName(std::string &&);
   bool IsFuncResult() const;
   bool IsObjectArray() const;
   bool IsSubprogram() const;
   bool IsFromModFile() const;
   bool HasExplicitInterface() const {
     return std::visit(common::visitors{
                           [](const SubprogramDetails &) { return true; },
                           [](const SubprogramNameDetails &) { return true; },

flang/lib/Semantics/CMakeLists.txt

-
 add_flang_library(FortranSemantics
   assignment.cpp
   attr.cpp
   canonicalize-acc.cpp
   canonicalize-do.cpp
   canonicalize-omp.cpp
   check-acc-structure.cpp
   check-allocate.cpp

flang/lib/Semantics/check-declarations.cpp

void SubprogramMatchHelper::Check(
   if (nonRecursive1 != symbol2.attrs().test(Attr::NON_RECURSIVE)) { // C1551
     Say(symbol1, symbol2,
         nonRecursive1
             ? "Module subprogram '%s' has NON_RECURSIVE prefix but"
               " the corresponding interface body does not"_err_en_US
             : "Module subprogram '%s' does not have NON_RECURSIVE prefix but "
               "the corresponding interface body does"_err_en_US);
   }
-  MaybeExpr bindName1{details1.bindName()};
-  MaybeExpr bindName2{details2.bindName()};
-  if (bindName1.has_value() != bindName2.has_value()) {
+  const std::string *bindName1{details1.bindName()};
+  const std::string *bindName2{details2.bindName()};
+  if (!bindName1 && !bindName2) {
+    // OK - neither has a binding label
+  } else if (!bindName1) {
     Say(symbol1, symbol2,
-        bindName1.has_value()
-            ? "Module subprogram '%s' has a binding label but the corresponding"
-              " interface body does not"_err_en_US
-            : "Module subprogram '%s' does not have a binding label but the"
-              " corresponding interface body does"_err_en_US);
-  } else if (bindName1) {
-    std::string string1{bindName1->AsFortran()};
-    std::string string2{bindName2->AsFortran()};
-    if (string1 != string2) {
-      Say(symbol1, symbol2,
-          "Module subprogram '%s' has binding label %s but the corresponding"
-          " interface body has %s"_err_en_US,
-          string1, string2);
-    }
+        "Module subprogram '%s' does not have a binding label but the"
+  } else if (!bindName2) {
+        "Module subprogram '%s' has a binding label but the"
+        " corresponding interface body does not"_err_en_US);
+  } else if (*bindName1 != *bindName2) {
+    Say(symbol1, symbol2,
+        "Module subprogram '%s' has binding label '%s' but the corresponding"
+        " interface body has '%s'"_err_en_US,
+        *details1.bindName(), *details2.bindName());
   }
   const Procedure *proc1{checkHelper.Characterize(symbol1)};
   const Procedure *proc2{checkHelper.Characterize(symbol2)};
   if (!proc1 || !proc2) {
     return;
   }
   if (proc1->functionResult && proc2->functionResult &&
       *proc1->functionResult != *proc2->functionResult) {

flang/lib/Semantics/mod-file.cpp

 static void PutProcEntity(llvm::raw_ostream &, const Symbol &);
 static void PutPassName(llvm::raw_ostream &, const std::optional<SourceName> &);
 static void PutTypeParam(llvm::raw_ostream &, const Symbol &);
 static void PutEntity(
     llvm::raw_ostream &, const Symbol &, std::function<void()>, Attrs);
 static void PutInit(llvm::raw_ostream &, const Symbol &, const MaybeExpr &);
 static void PutInit(llvm::raw_ostream &, const MaybeIntExpr &);
 static void PutBound(llvm::raw_ostream &, const Bound &);
-static llvm::raw_ostream &PutAttrs(llvm::raw_ostream &, Attrs,
-    const MaybeExpr & = std::nullopt, std::string before = ","s,
+llvm::raw_ostream &PutAttrs(llvm::raw_ostream &, Attrs,
+    const std::string * = nullptr, std::string before = ","s,
     std::string after = ""s);
 
 static llvm::raw_ostream &PutAttr(llvm::raw_ostream &, Attr);
 static llvm::raw_ostream &PutType(llvm::raw_ostream &, const DeclTypeSpec &);
 static llvm::raw_ostream &PutLower(llvm::raw_ostream &, const std::string &);
 static std::error_code WriteFile(
     const std::string &, const std::string &, bool = true);
 static bool FileContentsMatch(
void ModFileWriter::PutSubprogram(const Symbol &symbol) {
   if (!ss.str().empty()) {
     decls_ << ss.str().substr(1) << "::" << symbol.name() << '\n';
   }
   bool isInterface{details.isInterface()};
   llvm::raw_ostream &os{isInterface ? decls_ : contains_};
   if (isInterface) {
     os << (isAbstract ? "abstract " : "") << "interface\n";
   }
-  PutAttrs(os, prefixAttrs, std::nullopt, ""s, " "s);
+  PutAttrs(os, prefixAttrs, nullptr, ""s, " "s);
   os << (details.isFunction() ? "function " : "subroutine ");
   os << symbol.name() << '(';
   int n = 0;
   for (const auto &dummy : details.dummyArgs()) {
     if (n++ > 0) {
       os << ',';
     }
     if (dummy) {
void PutBound(llvm::raw_ostream &os, const Bound &x) {
   }
 }
 
 // Write an entity (object or procedure) declaration.
 // writeType is called to write out the type.
 void PutEntity(llvm::raw_ostream &os, const Symbol &symbol,
     std::function<void()> writeType, Attrs attrs) {
   writeType();
-  MaybeExpr bindName;
-  std::visit(common::visitors{
-                 [&](const SubprogramDetails &x) { bindName = x.bindName(); },
-                 [&](const ObjectEntityDetails &x) { bindName = x.bindName(); },
-                 [&](const ProcEntityDetails &x) { bindName = x.bindName(); },
-                 [&](const auto &) {},
-             },
-      symbol.details());
-  PutAttrs(os, attrs, bindName);
+  PutAttrs(os, attrs, symbol.GetBindName());
   os << "::" << symbol.name();
 }
 
 // Put out each attribute to os, surrounded by `before` and `after` and
 // mapped to lower case.
 llvm::raw_ostream &PutAttrs(llvm::raw_ostream &os, Attrs attrs,
-    const MaybeExpr &bindName, std::string before, std::string after) {
+    const std::string *bindName, std::string before, std::string after) {
   attrs.set(Attr::PUBLIC, false); // no need to write PUBLIC
   attrs.set(Attr::EXTERNAL, false); // no need to write EXTERNAL
   if (bindName) {
-    bindName->AsFortran(os << before << "bind(c, name=") << ')' << after;
+    os << before << "bind(c, name=\"" << *bindName << "\")" << after;
     attrs.set(Attr::BIND_C, false);
   }
   for (std::size_t i{0}; i < Attr_enumSize; ++i) {
     Attr attr{static_cast<Attr>(i)};
     if (attrs.test(attr)) {
       PutAttr(os << before, attr) << after;
     }
   }

flang/lib/Semantics/resolve-names.cpp

std::visit(common::visitors{
                  [&](ProcBindingDetails &x) { x.set_passName(*passName_); },
                  [](auto &) { common::die("unexpected pass name"); },
              },
       symbol.details());
   return true;
 }
 
 bool AttrsVisitor::SetBindNameOn(Symbol &symbol) {
-  if (!bindName_) {
+  if (!attrs_ || !attrs_->test(Attr::BIND_C)) {
     return false;
   }
-  std::visit(
-      common::visitors{
-          [&](EntityDetails &x) { x.set_bindName(std::move(bindName_)); },
-          [&](ObjectEntityDetails &x) { x.set_bindName(std::move(bindName_)); },
-          [&](ProcEntityDetails &x) { x.set_bindName(std::move(bindName_)); },
-          [&](SubprogramDetails &x) { x.set_bindName(std::move(bindName_)); },
-          [&](CommonBlockDetails &x) { x.set_bindName(std::move(bindName_)); },
-          [](auto &) { common::die("unexpected bind name"); },
-      },
-      symbol.details());
+  std::optional<std::string> label{evaluate::GetScalarConstantValue<
+      evaluate::Type<TypeCategory::Character, 1>>(bindName_)};
+  // 18.9.2(2): discard leading and trailing blanks, ignore if all blank
+  if (label) {
+    auto first{label->find_first_not_of(" ")};
+    auto last{label->find_last_not_of(" ")};
+    if (first == std::string::npos) {
+      Say(currStmtSource().value(), "Blank binding label ignored"_en_US);
+      label.reset();
+    } else {
+      label = label->substr(first, last - first + 1);
+    }
+  }
+  if (!label) {
+    label = parser::ToLowerCaseLetters(symbol.name().ToString());
+  }
+  symbol.SetBindName(std::move(*label));
   return true;
 }
 
 void AttrsVisitor::Post(const parser::LanguageBindingSpec &x) {
   CHECK(attrs_);
   if (CheckAndSet(Attr::BIND_C)) {
     if (x.v) {
       bindName_ = EvaluateExpr(*x.v);

flang/lib/Semantics/symbol.cpp

 //===-- lib/Semantics/symbol.cpp ------------------------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Semantics/symbol.h"
 #include "flang/Common/idioms.h"
 #include "flang/Evaluate/expression.h"
 #include "flang/Semantics/scope.h"
 #include "flang/Semantics/semantics.h"
 #include "flang/Semantics/tools.h"
 #include "llvm/Support/raw_ostream.h"
 #include <string>
+#include <type_traits>
 
 namespace Fortran::semantics {
 
 template <typename T>
 static void DumpOptional(llvm::raw_ostream &os, const char *label, const T &x) {
   if (x) {
     os << ' ' << label << ':' << *x;
   }
void ModuleDetails::set_scope(const Scope *scope) {
   bool scopeIsSubmodule{scope->parent().kind() == Scope::Kind::Module};
   CHECK(isSubmodule_ == scopeIsSubmodule);
   scope_ = scope;
 }
 
 llvm::raw_ostream &operator<<(
     llvm::raw_ostream &os, const SubprogramDetails &x) {
   DumpBool(os, "isInterface", x.isInterface_);
-  DumpExpr(os, "bindName", x.bindName_);
+  DumpOptional(os, "bindName", x.bindName());
   if (x.result_) {
     DumpType(os << " result:", x.result());
     os << x.result_->name();
     if (!x.result_->attrs().empty()) {
       os << ", " << x.result_->attrs();
     }
   }
   if (x.entryScope_) {
std::visit(common::visitors{
                  [&](AssocEntityDetails &x) { x.set_type(type); },
                  [&](ProcEntityDetails &x) { x.interface().set_type(type); },
                  [&](TypeParamDetails &x) { x.set_type(type); },
                  [](auto &) {},
              },
       details_);
 }
 
+template <typename T>
+constexpr bool HasBindName{std::is_convertible_v<T, const WithBindName *>};
+
+const std::string *Symbol::GetBindName() const {
+  return std::visit(
+      [&](auto &x) -> const std::string * {
+        if constexpr (HasBindName<decltype(&x)>) {
+          return x.bindName();
+        } else {
+          return nullptr;
+        }
+      },
+      details_);
+}
+
+void Symbol::SetBindName(std::string &&name) {
+  std::visit(
+      [&](auto &x) {
+        if constexpr (HasBindName<decltype(&x)>) {
+          x.set_bindName(std::move(name));
+        } else {
+          DIE("bind name not allowed on this kind of symbol");
+        }
+      },
+      details_);
+}
+
 bool Symbol::IsFuncResult() const {
   return std::visit(
       common::visitors{[](const EntityDetails &x) { return x.isFuncResult(); },
           [](const ObjectEntityDetails &x) { return x.isFuncResult(); },
           [](const ProcEntityDetails &x) { return x.isFuncResult(); },
           [](const HostAssocDetails &x) { return x.symbol().IsFuncResult(); },
           [](const auto &) { return false; }},
       details_);
ObjectEntityDetails::ObjectEntityDetails(EntityDetails &&d)
     : EntityDetails(d) {}
 
 llvm::raw_ostream &operator<<(llvm::raw_ostream &os, const EntityDetails &x) {
   DumpBool(os, "dummy", x.isDummy());
   DumpBool(os, "funcResult", x.isFuncResult());
   if (x.type()) {
     os << " type: " << *x.type();
   }
-  DumpExpr(os, "bindName", x.bindName_);
+  DumpOptional(os, "bindName", x.bindName());
   return os;
 }
 
 llvm::raw_ostream &operator<<(
     llvm::raw_ostream &os, const ObjectEntityDetails &x) {
   os << *static_cast<const EntityDetails *>(&x);
   DumpList(os, "shape", x.shape());
   DumpList(os, "coshape", x.coshape());

 
 llvm::raw_ostream &operator<<(
     llvm::raw_ostream &os, const ProcEntityDetails &x) {
   if (auto *symbol{x.interface_.symbol()}) {
     os << ' ' << symbol->name();
   } else {
     DumpType(os, x.interface_.type());
   }
-  DumpExpr(os, "bindName", x.bindName());
+  DumpOptional(os, "bindName", x.bindName());
   DumpOptional(os, "passName", x.passName());
   if (x.init()) {
     if (const Symbol * target{*x.init()}) {
       os << " => " << target->name();
     } else {
       os << " => NULL()";
     }
   }
std::visit( //
             os << " => " << x.symbol().name();
             DumpOptional(os, "passName", x.passName());
           },
           [&](const NamelistDetails &x) {
             os << ':';
             DumpSymbolVector(os, x.objects());
           },
           [&](const CommonBlockDetails &x) {
+            DumpOptional(os, "bindName", x.bindName());
             if (x.alignment()) {
               os << " alignment=" << x.alignment();
             }
             os << ':';
             for (const auto &object : x.objects()) {
               os << ' ' << object->name();
             }
           },

flang/test/Semantics/modfile04.f90

 ! RUN: %S/test_modfile.sh %s %t %f18
 ! modfile with subprograms
 
 module m1
   type :: t
   end type
 contains
 
-  pure subroutine s(x, y) bind(c)
+  pure subroutine Ss(x, y) bind(c)
     logical x
     intent(inout) y
     intent(in) x
   end subroutine
 
   real function f1() result(x)
     x = 1.0
   end function
contains
   end subroutine
 end module m3
 
 !Expect: m1.mod
 !module m1
 !type::t
 !end type
 !contains
-!pure subroutine s(x,y) bind(c)
+!pure subroutine ss(x,y) bind(c, name="ss")
 !logical(4),intent(in)::x
 !real(4),intent(inout)::y
 !end
 !function f1() result(x)
 !real(4)::x
 !end
 !function f2(y)
 !complex(4)::y

flang/test/Semantics/modfile21.f90

 !  real(4)::z
 !  real(4)::u
 !  real(4)::v
 !  complex(4)::w
 !  real(4)::cb
 !  common/cb/x,y,z
 !  bind(c, name="CB")::/cb/
 !  common/cb2/a,b,c
-!  bind(c)::/cb2/
+!  bind(c, name="cb2")::/cb2/
 !  common/b/cb
 !  common//t,w,u,v
 !end

flang/test/Semantics/separate-mp02.f90

 module m2b
   interface
     module subroutine s1()
     end
     module subroutine s2() bind(c, name="s2")
     end
     module subroutine s3() bind(c, name="s3")
     end
+    module subroutine s4() bind(c, name=" s4")
+    end
+    module subroutine s5() bind(c)
+    end
+    module subroutine s6() bind(c)
+    end
   end interface
 end
 
 submodule(m2b) sm2b
   character(*), parameter :: suffix = "_xxx"
 contains
   !ERROR: Module subprogram 's1' has a binding label but the corresponding interface body does not
   module subroutine s1() bind(c, name="s1")
   end
   !ERROR: Module subprogram 's2' does not have a binding label but the corresponding interface body does
   module subroutine s2()
   end
-  !ERROR: Module subprogram 's3' has binding label "s3_xxx" but the corresponding interface body has "s3"
+  !ERROR: Module subprogram 's3' has binding label 's3_xxx' but the corresponding interface body has 's3'
   module subroutine s3() bind(c, name="s3" // suffix)
   end
+  module subroutine s4() bind(c, name="s4  ")
+  end
+  module subroutine s5() bind(c, name=" s5")
+  end
+  !ERROR: Module subprogram 's6' has binding label 'not_s6' but the corresponding interface body has 's6'
+  module subroutine s6() bind(c, name="not_s6")
+  end
 end
 
 
 module m3
   interface
     module subroutine s1(x, y, z)
       procedure(real), pointer, intent(in) :: x
       procedure(real), pointer, intent(out) :: y