[flang] Add support for character type specs

Recognize the various ways of specifying character lengths.

Define CharacterTypeSpec with length and kind and store them in the
current scope, as is done with DerivedTypeSpec (which can also have
length parameters).

Note: IntrinsicTypeSpec is no longer used for characters, so it
should have a different name. Similarly, in DeclTypeSpec::Category,
Intrinsic does not include Character.

Original-commit: flang-compiler/f18@5f84785193
Reviewed-on: https://github.com/flang-compiler/f18/pull/247
Tree-same-pre-rewrite: false

flang/lib/semantics/resolve-names.cc

@@ -218,7 +218,6 @@ public:
   void Post(const parser::IntrinsicTypeSpec::Complex &);
   void Post(const parser::IntrinsicTypeSpec::DoublePrecision &);
   void Post(const parser::IntrinsicTypeSpec::DoubleComplex &);
-  void Post(const parser::IntrinsicTypeSpec::Character &);
   void Post(const parser::DeclarationTypeSpec::ClassStar &);
   void Post(const parser::DeclarationTypeSpec::TypeStar &);
   void Post(const parser::TypeParamSpec &);
@@ -231,18 +230,18 @@ protected:
   void EndDeclTypeSpec();
   const parser::Name *derivedTypeName() const { return derivedTypeName_; }
   void SetDeclTypeSpec(const parser::Name &, DeclTypeSpec &);
+  void SetDeclTypeSpec(DeclTypeSpec &);
+  ParamValue GetParamValue(const parser::TypeParamValue &);
 
 private:
   bool expectDeclTypeSpec_{false};  // should only see decl-type-spec when true
   DeclTypeSpec *declTypeSpec_{nullptr};
   const parser::Name *derivedTypeName_{nullptr};
 
-  void SetDeclTypeSpec(DeclTypeSpec &declTypeSpec);
   void MakeIntrinsic(TypeCategory, const std::optional<parser::KindSelector> &);
   void MakeIntrinsic(TypeCategory, int kind);
   int GetKindParamValue(
       TypeCategory, const std::optional<parser::KindSelector> &);
-  ParamValue GetParamValue(const parser::TypeParamValue &);
 };
 
 // Visit ImplicitStmt and related parse tree nodes and updates implicit rules.
@@ -581,6 +580,10 @@ public:
   void Post(const parser::DimensionStmt::Declaration &);
   bool Pre(const parser::TypeDeclarationStmt &) { return BeginDecl(); }
   void Post(const parser::TypeDeclarationStmt &) { EndDecl(); }
+  void Post(const parser::IntrinsicTypeSpec::Character &);
+  void Post(const parser::CharSelector::LengthAndKind &);
+  void Post(const parser::TypeParamValue &);
+  void Post(const parser::CharLength &);
   void Post(const parser::DeclarationTypeSpec::Class &);
   bool Pre(const parser::DeclarationTypeSpec::Record &);
   bool Pre(const parser::DerivedTypeSpec &);
@@ -625,6 +628,11 @@ protected:
 private:
   // The attribute corresponding to the statement containing an ObjectDecl
   std::optional<Attr> objectDeclAttr_;
+  // Info about current character type while walking DeclTypeSpec
+  struct {
+    std::optional<ParamValue> length;
+    int kind{0};
+  } charInfo_;
   // Info about current derived type while walking DerivedTypeStmt
   struct {
     const parser::Name *extends{nullptr};  // EXTENDS(name)
@@ -1020,9 +1028,6 @@ void DeclTypeSpecVisitor::Post(const parser::TypeGuardStmt &) {
 void DeclTypeSpecVisitor::Post(const parser::IntegerTypeSpec &x) {
   MakeIntrinsic(TypeCategory::Integer, x.v);
 }
-void DeclTypeSpecVisitor::Post(const parser::IntrinsicTypeSpec::Character &x) {
-  CHECK(!"TODO: character");
-}
 void DeclTypeSpecVisitor::Post(const parser::IntrinsicTypeSpec::Logical &x) {
   MakeIntrinsic(TypeCategory::Logical, x.kind);
 }
@@ -2341,6 +2346,35 @@ Symbol &DeclarationVisitor::DeclareObjectEntity(
   return symbol;
 }
 
+void DeclarationVisitor::Post(const parser::IntrinsicTypeSpec::Character &x) {
+  if (!charInfo_.length) {
+    charInfo_.length = ParamValue{SomeExpr{
+        evaluate::AsExpr(evaluate::Constant<evaluate::SubscriptInteger>{1})}};
+  }
+  SetDeclTypeSpec(currScope().MakeDeclTypeSpec(
+      std::move(*charInfo_.length), charInfo_.kind));
+  charInfo_ = {};
+}
+void DeclarationVisitor::Post(const parser::CharSelector::LengthAndKind &x) {
+  if (auto maybeExpr{EvaluateExpr(x.kind)}) {
+    charInfo_.kind = evaluate::ToInt64(*maybeExpr).value();
+  }
+  if (x.length) {
+    charInfo_.length = GetParamValue(*x.length);
+  }
+}
+void DeclarationVisitor::Post(const parser::TypeParamValue &x) {
+  if (!derivedTypeName()) {
+    charInfo_.length = GetParamValue(x);
+  }
+}
+void DeclarationVisitor::Post(const parser::CharLength &x) {
+  if (const auto *length{std::get_if<std::int64_t>(&x.u)}) {
+    charInfo_.length = ParamValue{SomeExpr{evaluate::AsExpr(
+        evaluate::Constant<evaluate::SubscriptInteger>{*length})}};
+  }
+}
+
 void DeclarationVisitor::Post(const parser::DeclarationTypeSpec::Class &x) {
   // created by default with TypeDerived; change to ClassDerived
   GetDeclTypeSpec()->set_category(DeclTypeSpec::ClassDerived);

flang/lib/semantics/scope.cc

@@ -70,6 +70,7 @@ bool Scope::AddSubmodule(const SourceName &name, Scope &submodule) {
   return submodules_.emplace(name, &submodule).second;
 }
 DeclTypeSpec &Scope::MakeDeclTypeSpec(TypeCategory category, int kind) {
+  CHECK(category != TypeCategory::Character);
   DeclTypeSpec type{IntrinsicTypeSpec{category, kind}};
   auto it{std::find(declTypeSpecs_.begin(), declTypeSpecs_.end(), type)};
   if (it != declTypeSpecs_.end()) {
@@ -79,6 +80,12 @@ DeclTypeSpec &Scope::MakeDeclTypeSpec(TypeCategory category, int kind) {
     return declTypeSpecs_.back();
   }
 }
+DeclTypeSpec &Scope::MakeDeclTypeSpec(ParamValue &&length, int kind) {
+  characterTypeSpecs_.emplace_back(std::move(length), kind);
+  declTypeSpecs_.emplace_back(characterTypeSpecs_.back());
+  return declTypeSpecs_.back();
+}
+
 DeclTypeSpec &Scope::MakeDeclTypeSpec(
     DeclTypeSpec::Category category, const SourceName &name) {
   CHECK(category == DeclTypeSpec::TypeDerived ||

flang/lib/semantics/scope.h

@@ -122,6 +122,7 @@ public:
   bool AddSubmodule(const SourceName &, Scope &);
 
   DeclTypeSpec &MakeDeclTypeSpec(TypeCategory, int kind);
+  DeclTypeSpec &MakeDeclTypeSpec(ParamValue &&length, int kind = 0);
   DeclTypeSpec &MakeDeclTypeSpec(DeclTypeSpec::Category, const SourceName &);
   DeclTypeSpec &MakeDeclTypeSpec(DeclTypeSpec::Category);
   DerivedTypeSpec &MakeDerivedTypeSpec(const SourceName &);
@@ -155,6 +156,7 @@ private:
   mapType symbols_;
   std::map<SourceName, Scope *> submodules_;
   std::list<DeclTypeSpec> declTypeSpecs_;
+  std::list<CharacterTypeSpec> characterTypeSpecs_;
   std::list<DerivedTypeSpec> derivedTypeSpecs_;
   std::string chars_;
   std::optional<ImportKind> importKind_;

flang/lib/semantics/type.cc

@@ -110,6 +110,7 @@ std::ostream &operator<<(std::ostream &o, const ParamValue &x) {
 
 IntrinsicTypeSpec::IntrinsicTypeSpec(TypeCategory category, int kind)
   : category_{category}, kind_{kind} {
+  CHECK(category != TypeCategory::Character);
   CHECK(category != TypeCategory::Derived);
   CHECK(kind > 0);
 }
@@ -122,8 +123,18 @@ std::ostream &operator<<(std::ostream &os, const IntrinsicTypeSpec &x) {
   return os;
 }
 
+std::ostream &operator<<(std::ostream &os, const CharacterTypeSpec &x) {
+  os << "CHARACTER(" << x.length();
+  if (x.kind() != 0) {
+    os << ",kind=" << x.kind();
+  }
+  return os << ')';
+}
+
 DeclTypeSpec::DeclTypeSpec(const IntrinsicTypeSpec &intrinsic)
   : category_{Intrinsic}, typeSpec_{intrinsic} {}
+DeclTypeSpec::DeclTypeSpec(CharacterTypeSpec &character)
+  : category_{Character}, typeSpec_{&character} {}
 DeclTypeSpec::DeclTypeSpec(Category category, DerivedTypeSpec &derived)
   : category_{category}, typeSpec_{&derived} {
   CHECK(category == TypeDerived || category == ClassDerived);
@@ -135,6 +146,10 @@ const IntrinsicTypeSpec &DeclTypeSpec::intrinsicTypeSpec() const {
   CHECK(category_ == Intrinsic);
   return typeSpec_.intrinsic;
 }
+const CharacterTypeSpec &DeclTypeSpec::characterTypeSpec() const {
+  CHECK(category_ == Character);
+  return *typeSpec_.character;
+}
 DerivedTypeSpec &DeclTypeSpec::derivedTypeSpec() {
   CHECK(category_ == TypeDerived || category_ == ClassDerived);
   return *typeSpec_.derived;
@@ -158,6 +173,7 @@ bool DeclTypeSpec::operator==(const DeclTypeSpec &that) const {
 std::ostream &operator<<(std::ostream &o, const DeclTypeSpec &x) {
   switch (x.category()) {
   case DeclTypeSpec::Intrinsic: return o << x.intrinsicTypeSpec();
+  case DeclTypeSpec::Character: return o << x.characterTypeSpec();
   case DeclTypeSpec::TypeDerived:
     return o << "TYPE(" << x.derivedTypeSpec() << ')';
   case DeclTypeSpec::ClassDerived:

flang/lib/semantics/type.h

@@ -73,11 +73,31 @@ private:
   friend std::ostream &operator<<(std::ostream &, const Bound &);
 };
 
+// A type parameter value: integer expression or assumed or deferred.
+class ParamValue {
+public:
+  static const ParamValue Assumed() { return Category::Assumed; }
+  static const ParamValue Deferred() { return Category::Deferred; }
+  ParamValue(MaybeExpr &&expr)
+    : category_{Category::Explicit}, expr_{std::move(expr)} {}
+  bool isExplicit() const { return category_ == Category::Explicit; }
+  bool isAssumed() const { return category_ == Category::Assumed; }
+  bool isDeferred() const { return category_ == Category::Deferred; }
+  const MaybeExpr &GetExplicit() const { return expr_; }
+
+private:
+  enum class Category { Explicit, Deferred, Assumed };
+  ParamValue(Category category) : category_{category} {}
+  Category category_;
+  MaybeExpr expr_;
+  friend std::ostream &operator<<(std::ostream &, const ParamValue &);
+};
+
 class IntrinsicTypeSpec {
 public:
   IntrinsicTypeSpec(TypeCategory, int kind);
-  const TypeCategory category() const { return category_; }
-  const int kind() const { return kind_; }
+  TypeCategory category() const { return category_; }
+  int kind() const { return kind_; }
   bool operator==(const IntrinsicTypeSpec &x) const {
     return category_ == x.category_ && kind_ == x.kind_;
   }
@@ -87,7 +107,19 @@ private:
   TypeCategory category_;
   int kind_;
   friend std::ostream &operator<<(std::ostream &os, const IntrinsicTypeSpec &x);
-  // TODO: Character and len
+};
+
+class CharacterTypeSpec {
+public:
+  CharacterTypeSpec(ParamValue &&length, int kind)
+    : length_{std::move(length)}, kind_{kind} {}
+  int kind() const { return kind_; }
+  const ParamValue length() const { return length_; }
+
+private:
+  ParamValue length_;
+  int kind_;
+  friend std::ostream &operator<<(std::ostream &os, const CharacterTypeSpec &x);
 };
 
 class ShapeSpec {
@@ -144,26 +176,6 @@ private:
 
 using ArraySpec = std::list<ShapeSpec>;
 
-// A type parameter value: integer expression or assumed or deferred.
-class ParamValue {
-public:
-  static const ParamValue Assumed() { return Category::Assumed; }
-  static const ParamValue Deferred() { return Category::Deferred; }
-  ParamValue(MaybeExpr &&expr)
-    : category_{Category::Explicit}, expr_{std::move(expr)} {}
-  bool isExplicit() const { return category_ == Category::Explicit; }
-  bool isAssumed() const { return category_ == Category::Assumed; }
-  bool isDeferred() const { return category_ == Category::Deferred; }
-  const MaybeExpr &GetExplicit() const { return expr_; }
-
-private:
-  enum class Category { Explicit, Deferred, Assumed };
-  ParamValue(Category category) : category_{category} {}
-  Category category_;
-  MaybeExpr expr_;
-  friend std::ostream &operator<<(std::ostream &, const ParamValue &);
-};
-
 class DerivedTypeSpec {
 public:
   using listType = std::list<std::pair<std::optional<SourceName>, ParamValue>>;
@@ -187,10 +199,19 @@ private:
 
 class DeclTypeSpec {
 public:
-  enum Category { Intrinsic, TypeDerived, ClassDerived, TypeStar, ClassStar };
+  enum Category {
+    Intrinsic,
+    Character,
+    TypeDerived,
+    ClassDerived,
+    TypeStar,
+    ClassStar
+  };
 
-  // intrinsic-type-spec or TYPE(intrinsic-type-spec)
+  // intrinsic-type-spec or TYPE(intrinsic-type-spec), not character
   DeclTypeSpec(const IntrinsicTypeSpec &);
+  // character
+  DeclTypeSpec(CharacterTypeSpec &);
   // TYPE(derived-type-spec) or CLASS(derived-type-spec)
   DeclTypeSpec(Category, DerivedTypeSpec &);
   // TYPE(*) or CLASS(*)
@@ -202,8 +223,9 @@ public:
 
   Category category() const { return category_; }
   const IntrinsicTypeSpec &intrinsicTypeSpec() const;
-  DerivedTypeSpec &derivedTypeSpec();
+  const CharacterTypeSpec &characterTypeSpec() const;
   const DerivedTypeSpec &derivedTypeSpec() const;
+  DerivedTypeSpec &derivedTypeSpec();
   void set_category(Category category) { category_ = category; }
 
 private:
@@ -211,8 +233,10 @@ private:
   union TypeSpec {
     TypeSpec() : derived{nullptr} {}
     TypeSpec(IntrinsicTypeSpec intrinsic) : intrinsic{intrinsic} {}
+    TypeSpec(CharacterTypeSpec *character) : character{character} {}
     TypeSpec(DerivedTypeSpec *derived) : derived{derived} {}
     IntrinsicTypeSpec intrinsic;
+    CharacterTypeSpec *character;
     DerivedTypeSpec *derived;
   } typeSpec_;
 };

flang/test/semantics/CMakeLists.txt

@@ -91,6 +91,7 @@ set(MODFILE_TESTS
   modfile10.f90
   modfile11.f90
   modfile12.f90
+  modfile13.f90
 )
 
 set(LABEL_TESTS

flang/test/semantics/modfile13.f90

@@ -0,0 +1,46 @@
+! Copyright (c) 2018, NVIDIA CORPORATION.  All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+!     http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
+module m
+  character(2) :: z
+  character(len=3) :: y
+  character*4 :: x
+  character :: w
+  character(len=:), allocatable :: v
+contains
+  subroutine s(n, a, b, c, d)
+    integer :: n
+    character(len=n+1,kind=1) :: a
+    character(n+2,2) :: b
+    character*(n+3) :: c
+    character(*) :: d
+  end
+end
+
+!Expect: m.mod
+!module m
+!  character(2_4)::z
+!  character(3_4)::y
+!  character(4_8)::x
+!  character(1_8)::w
+!  character(:),allocatable::v
+!contains
+!  subroutine s(n,a,b,c,d)
+!    integer(4)::n
+!    character((n+1_4),kind=1)::a
+!    character((n+2_4),kind=2)::b
+!    character((n+3_4))::c
+!    character(*)::d
+!  end
+!end

flang/test/semantics/resolve37.f90

@@ -29,4 +29,6 @@ end type
 type(t(.true.)) :: w
 !ERROR: expression must be INTEGER
 real :: w(l*2)
+!ERROR: expression must be INTEGER
+character(len=l) :: v
 end