[flang] Resolve names in ASSOCIATE and SELECT TYPE

Create `AssocEntityDetails` for symbols that represent entities
identified by the associate-name in ASSOCIATE and SELECT TYPE
constructs.

For ASSOCIATE, create a new scope for the associated entity.
For SELECT TYPE, create a new scope for each of type guard blocks.
Each one contains an associated entity with the appropriate type.

For SELECT TYPE, also create a place-holder symbol for the
associate-name in the SELECT TYPE statement. The real symbols
are in the new scopes and none of them is uniquely identified
with the associate-name.

Handling of `Selector` is common between these, with
`associate-name => expr | variable` recorded in
`ConstructVisitor::association_`.

When the selector is an expression, derive the type of the associated
entity from the type of the expression. This required some refactoring
of how `DeclTypeSpec`s are created. The `DerivedTypeSpec` that comes
from and expression is const so we can only create const `DeclTypeSpec`s
from it. But there were times during name resolution when we needed to
set type parameters in the current `DeclTypeSpec`. Now the non-const
`DerivedTypeSpec` is saved separately from the const `DeclTypeSpec`
while we are processing a declaration type spec. This makes it
unnecessary to save the derived type name.

Add a type alias for `common::Indirection` to reduce verbosity.

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

diff --git a/flang/lib/semantics/resolve-names.cc b/flang/lib/semantics/resolve-names.cc
index 3de9d81..abf65cc 100644 (file)
--- a/flang/lib/semantics/resolve-names.cc
+++ b/flang/lib/semantics/resolve-names.cc
@@ -39,6 +39,7 @@ namespace Fortran::semantics {
 
 using namespace parser::literals;
 
+template<typename T> using Indirection = common::Indirection<T>;
 using Message = parser::Message;
 using Messages = parser::Messages;
 using MessageFixedText = parser::MessageFixedText;
@@ -248,6 +249,7 @@ public:
   void Post(const parser::IntrinsicTypeSpec::Complex &);
   void Post(const parser::IntrinsicTypeSpec::DoublePrecision &);
   void Post(const parser::IntrinsicTypeSpec::DoubleComplex &);
+  bool Pre(const parser::DeclarationTypeSpec::Class &);
   void Post(const parser::DeclarationTypeSpec::ClassStar &);
   void Post(const parser::DeclarationTypeSpec::TypeStar &);
   void Post(const parser::TypeParamSpec &);
@@ -258,17 +260,19 @@ public:
 protected:
   struct State {
     bool expectDeclTypeSpec{false};  // should only see decl-type-spec when true
-    DeclTypeSpec *declTypeSpec{nullptr};
-    const parser::Name *derivedTypeName{nullptr};
+    const DeclTypeSpec *declTypeSpec{nullptr};
+    struct {
+      DerivedTypeSpec *type{nullptr};
+      DeclTypeSpec::Category category{DeclTypeSpec::TypeDerived};
+    } derived;
   };
 
-  DeclTypeSpec *GetDeclTypeSpec();
+  const DeclTypeSpec *GetDeclTypeSpec();
   void BeginDeclTypeSpec();
   void EndDeclTypeSpec();
   State SetDeclTypeSpecState(State);
-  const parser::Name *derivedTypeName() const { return state_.derivedTypeName; }
-  void SetDeclTypeSpec(const parser::Name &, DeclTypeSpec &);
-  void SetDeclTypeSpec(DeclTypeSpec &);
+  void SetDeclTypeSpec(const DeclTypeSpec &);
+  DerivedTypeSpec &SetDerivedTypeSpec(Scope &, const parser::Name &);
   ParamValue GetParamValue(const parser::TypeParamValue &);
 
 private:
@@ -624,7 +628,6 @@ public:
   void Post(const parser::CharSelector::LengthAndKind &);
   void Post(const parser::CharLength &);
   void Post(const parser::LengthSelector &);
-  void Post(const parser::DeclarationTypeSpec::Class &);
   bool Pre(const parser::DeclarationTypeSpec::Record &);
   bool Pre(const parser::DerivedTypeSpec &);
   void Post(const parser::DerivedTypeDef &x);
@@ -691,7 +694,7 @@ private:
   Symbol &DeclareObjectEntity(const parser::Name &, Attrs);
   Symbol &DeclareProcEntity(const parser::Name &, Attrs, const ProcInterface &);
   void SetType(const parser::Name &, const DeclTypeSpec &);
-  const Symbol *ResolveDerivedType(const parser::Name * = nullptr);
+  const Symbol *ResolveDerivedType(const parser::Name &);
   bool CanBeTypeBoundProc(const Symbol &);
   Symbol *FindExplicitInterface(const parser::Name &);
   const Symbol *FindTypeSymbol(const parser::Name &);
@@ -757,17 +760,21 @@ public:
   void Post(const parser::ForallStmt &);
   bool Pre(const parser::BlockStmt &);
   bool Pre(const parser::EndBlockStmt &);
+  void Post(const parser::Selector &);
+  bool Pre(const parser::AssociateStmt &);
+  void Post(const parser::EndAssociateStmt &);
+  void Post(const parser::Association &);
+  void Post(const parser::SelectTypeStmt &);
+  bool Pre(const parser::SelectTypeConstruct::TypeCase &);
+  void Post(const parser::SelectTypeConstruct::TypeCase &);
+  void Post(const parser::TypeGuardStmt::Guard &);
 
   // Definitions of construct names
   bool Pre(const parser::WhereConstructStmt &x) { return CheckDef(x.t); }
   bool Pre(const parser::ForallConstructStmt &x) { return CheckDef(x.t); }
-  bool Pre(const parser::AssociateStmt &x) { return CheckDef(x.t); }
   bool Pre(const parser::ChangeTeamStmt &x) { return CheckDef(x.t); }
   bool Pre(const parser::CriticalStmt &x) { return CheckDef(x.t); }
-  bool Pre(const parser::LabelDoStmt &x) {
-    CHECK(false);
-    return false;
-  }
+  bool Pre(const parser::LabelDoStmt &x) { common::die("should not happen"); }
   bool Pre(const parser::NonLabelDoStmt &x) { return CheckDef(x.t); }
   bool Pre(const parser::IfThenStmt &x) { return CheckDef(x.t); }
   bool Pre(const parser::SelectCaseStmt &x) { return CheckDef(x.t); }
@@ -777,12 +784,12 @@ public:
   bool Pre(const parser::SelectTypeStmt &x) {
     return CheckDef(std::get<0>(x.t));
   }
+
   // References to construct names
   void Post(const parser::MaskedElsewhereStmt &x) { CheckRef(x.t); }
   void Post(const parser::ElsewhereStmt &x) { CheckRef(x.v); }
   void Post(const parser::EndWhereStmt &x) { CheckRef(x.v); }
   void Post(const parser::EndForallStmt &x) { CheckRef(x.v); }
-  void Post(const parser::EndAssociateStmt &x) { CheckRef(x.v); }
   void Post(const parser::EndChangeTeamStmt &x) { CheckRef(x.t); }
   void Post(const parser::EndCriticalStmt &x) { CheckRef(x.v); }
   void Post(const parser::EndDoStmt &x) { CheckRef(x.v); }
@@ -797,6 +804,14 @@ public:
   void Post(const parser::ExitStmt &x) { CheckRef(x.v); }
 
 private:
+  // The represents: associate-name => expr | variable
+  // expr is set unless there were errors
+  struct {
+    const parser::Name *name{nullptr};
+    const parser::Name *variable{nullptr};
+    MaybeExpr expr;
+  } association_;
+
   template<typename T> bool CheckDef(const T &t) {
     return CheckDef(std::get<std::optional<parser::Name>>(t));
   }
@@ -806,6 +821,10 @@ private:
   bool CheckDef(const std::optional<parser::Name> &);
   void CheckRef(const std::optional<parser::Name> &);
   void CheckIntegerType(const Symbol &);
+  const DeclTypeSpec &ToDeclTypeSpec(const evaluate::DynamicType &);
+  Symbol *MakeAssocEntity();
+  void SetTypeFromAssociation(Symbol &);
+  void SetAttrsFromAssociation(Symbol &);
 };
 
 // Walk the parse tree and resolve names to symbols.
@@ -1069,7 +1088,7 @@ bool AttrsVisitor::Pre(const parser::Pass &x) {
 
 // DeclTypeSpecVisitor implementation
 
-DeclTypeSpec *DeclTypeSpecVisitor::GetDeclTypeSpec() {
+const DeclTypeSpec *DeclTypeSpecVisitor::GetDeclTypeSpec() {
   return state_.declTypeSpec;
 }
 
@@ -1089,7 +1108,8 @@ DeclTypeSpecVisitor::State DeclTypeSpecVisitor::SetDeclTypeSpecState(State x) {
 }
 
 void DeclTypeSpecVisitor::Post(const parser::TypeParamSpec &x) {
-  DerivedTypeSpec &derivedTypeSpec{state_.declTypeSpec->derivedTypeSpec()};
+  CHECK(state_.derived.type);
+  DerivedTypeSpec &derivedTypeSpec{*state_.derived.type};
   const auto &value{std::get<parser::TypeParamValue>(x.t)};
   if (const auto &keyword{std::get<std::optional<parser::Keyword>>(x.t)}) {
     derivedTypeSpec.AddParamValue(keyword->v.source, GetParamValue(value));
@@ -1163,6 +1183,10 @@ void DeclTypeSpecVisitor::MakeNumericType(TypeCategory category, int kind) {
   SetDeclTypeSpec(context().MakeNumericType(category, kind));
 }
 
+bool DeclTypeSpecVisitor::Pre(const parser::DeclarationTypeSpec::Class &x) {
+  state_.derived.category = DeclTypeSpec::ClassDerived;
+  return true;
+}
 void DeclTypeSpecVisitor::Post(const parser::DeclarationTypeSpec::ClassStar &) {
   SetDeclTypeSpec(context().globalScope().MakeClassStarType());
 }
@@ -1172,16 +1196,19 @@ void DeclTypeSpecVisitor::Post(const parser::DeclarationTypeSpec::TypeStar &) {
 
 // Check that we're expecting to see a DeclTypeSpec (and haven't seen one yet)
 // and save it in state_.declTypeSpec.
-void DeclTypeSpecVisitor::SetDeclTypeSpec(DeclTypeSpec &declTypeSpec) {
+void DeclTypeSpecVisitor::SetDeclTypeSpec(const DeclTypeSpec &declTypeSpec) {
   CHECK(state_.expectDeclTypeSpec);
   CHECK(!state_.declTypeSpec);
   state_.declTypeSpec = &declTypeSpec;
 }
-// Set both the derived type name and corresponding DeclTypeSpec.
-void DeclTypeSpecVisitor::SetDeclTypeSpec(
-    const parser::Name &name, DeclTypeSpec &declTypeSpec) {
-  state_.derivedTypeName = &name;
-  SetDeclTypeSpec(declTypeSpec);
+
+// Set the current DeclTypeSpec to a derived type created from this name.
+DerivedTypeSpec &DeclTypeSpecVisitor::SetDerivedTypeSpec(
+    Scope &scope, const parser::Name &typeName) {
+  DerivedTypeSpec &derived{scope.MakeDerivedType(*typeName.symbol)};
+  SetDeclTypeSpec(scope.MakeDerivedType(state_.derived.category, derived));
+  state_.derived.type = &derived;
+  return derived;
 }
 
 int DeclTypeSpecVisitor::GetKindParamValue(
@@ -1607,7 +1634,7 @@ bool ScopeHandler::ConvertToProcEntity(Symbol &symbol) {
 bool ModuleVisitor::Pre(const parser::Only &x) {
   std::visit(
       common::visitors{
-          [&](const common::Indirection<parser::GenericSpec> &generic) {
+          [&](const Indirection<parser::GenericSpec> &generic) {
             std::visit(
                 common::visitors{
                     [&](const parser::Name &name) { AddUse(name); },
@@ -2510,20 +2537,14 @@ void DeclarationVisitor::Post(const parser::LengthSelector &x) {
   }
 }
 
-void DeclarationVisitor::Post(const parser::DeclarationTypeSpec::Class &x) {
-  // created by default with TypeDerived; change to ClassDerived
-  GetDeclTypeSpec()->set_category(DeclTypeSpec::ClassDerived);
-}
-
 bool DeclarationVisitor::Pre(const parser::DeclarationTypeSpec::Record &) {
   return true;  // TODO
 }
 
 bool DeclarationVisitor::Pre(const parser::DerivedTypeSpec &x) {
   const auto &typeName{std::get<parser::Name>(x.t)};
-  if (const auto *symbol{ResolveDerivedType(&typeName)}) {
-    SetDeclTypeSpec(typeName, currScope().MakeDerivedType(*symbol));
-    GetDeclTypeSpec()->derivedTypeSpec().set_scope(*symbol->scope());
+  if (const auto *symbol{ResolveDerivedType(typeName)}) {
+    SetDerivedTypeSpec(currScope(), typeName).set_scope(*symbol->scope());
   }
   return true;
 }
@@ -2581,16 +2602,17 @@ void DeclarationVisitor::Post(const parser::DerivedTypeStmt &x) {
   auto &symbol{MakeSymbol(name, GetAttrs(), DerivedTypeDetails{})};
   PushScope(Scope::Kind::DerivedType, &symbol);
   if (auto *extendsName{derivedTypeInfo_.extends}) {
-    if (const Symbol * extends{ResolveDerivedType(extendsName)}) {
+    if (const Symbol * extends{ResolveDerivedType(*extendsName)}) {
       symbol.get<DerivedTypeDetails>().set_extends(extendsName->source);
       // Declare the "parent component"; private if the type is
       if (OkToAddComponent(*extendsName, extends)) {
         auto &comp{DeclareEntity<ObjectEntityDetails>(*extendsName, Attrs{})};
         comp.attrs().set(Attr::PRIVATE, extends->attrs().test(Attr::PRIVATE));
         comp.set(Symbol::Flag::ParentComp);
-        auto &type{currScope().MakeDerivedType(*extends)};
-        type.derivedTypeSpec().set_scope(currScope());
-        comp.SetType(type);
+        DerivedTypeSpec &derived{currScope().MakeDerivedType(*extends)};
+        derived.set_scope(currScope());
+        comp.SetType(
+            currScope().MakeDerivedType(DeclTypeSpec::TypeDerived, derived));
       }
     }
   }
@@ -2748,8 +2770,7 @@ void DeclarationVisitor::Post(const parser::FinalProcedureStmt &x) {
 }
 
 bool DeclarationVisitor::Pre(const parser::TypeBoundGenericStmt &x) {
-  const auto &genericSpec{
-      std::get<common::Indirection<parser::GenericSpec>>(x.t)};
+  const auto &genericSpec{std::get<Indirection<parser::GenericSpec>>(x.t)};
   const auto *genericName{GetGenericSpecName(*genericSpec)};
   if (!genericName) {
     return false;
@@ -2808,7 +2829,6 @@ bool DeclarationVisitor::Pre(const parser::AllocateStmt &) {
   return true;
 }
 void DeclarationVisitor::Post(const parser::AllocateStmt &) {
-  ResolveDerivedType();
   EndDeclTypeSpec();
 }
 
@@ -2817,7 +2837,6 @@ bool DeclarationVisitor::Pre(const parser::StructureConstructor &x) {
   BeginDeclTypeSpec();
   Walk(std::get<parser::DerivedTypeSpec>(x.t));
   Walk(std::get<std::list<parser::ComponentSpec>>(x.t));
-  ResolveDerivedType();
   EndDeclTypeSpec();
   SetDeclTypeSpecState(savedState);
   return false;
@@ -2868,20 +2887,14 @@ void DeclarationVisitor::SetType(
   }
 }
 
-// Find the Symbol for this derived type; derivedTypeName if not specified.
-const Symbol *DeclarationVisitor::ResolveDerivedType(const parser::Name *name) {
-  if (name == nullptr) {
-    name = derivedTypeName();
-    if (name == nullptr) {
-      return nullptr;
-    }
-  }
-  const auto *symbol{FindSymbol(*name)};
+// Find the Symbol for this derived type.
+const Symbol *DeclarationVisitor::ResolveDerivedType(const parser::Name &name) {
+  const auto *symbol{FindSymbol(name)};
   if (!symbol) {
-    Say(*name, "Derived type '%s' not found"_err_en_US);
+    Say(name, "Derived type '%s' not found"_err_en_US);
     return nullptr;
   }
-  if (CheckUseError(*name)) {
+  if (CheckUseError(name)) {
     return nullptr;
   }
   if (auto *details{symbol->detailsIf<UseDetails>()}) {
@@ -2893,7 +2906,7 @@ const Symbol *DeclarationVisitor::ResolveDerivedType(const parser::Name *name) {
     }
   }
   if (!symbol->has<DerivedTypeDetails>()) {
-    Say(*name, "'%s' is not a derived type"_err_en_US);
+    Say(name, "'%s' is not a derived type"_err_en_US);
     return nullptr;
   }
   return symbol;
@@ -3108,6 +3121,87 @@ bool ConstructVisitor::Pre(const parser::EndBlockStmt &x) {
   return false;
 }
 
+void ConstructVisitor::Post(const parser::Selector &x) {
+  association_ = {};
+  const parser::Name *variable{nullptr};
+  MaybeExpr expr{std::visit(
+      common::visitors{
+          [&](const parser::Expr &y) { return EvaluateExpr(y); },
+          [&](const parser::Variable &y) {
+            if (const auto *des{
+                    std::get_if<Indirection<parser::Designator>>(&y.u)}) {
+              if (const auto *dr{std::get_if<parser::DataRef>(&(*des)->u)}) {
+                variable = std::get_if<parser::Name>(&dr->u);
+                if (variable && !FindSymbol(*variable)) {
+                  variable = nullptr;
+                  return MaybeExpr{};
+                }
+              }
+            }
+            return std::visit(
+                [&](const auto &z) { return EvaluateExpr(*z); }, y.u);
+          },
+      },
+      x.u)};
+  if (expr) {
+    association_.expr = std::move(expr);
+    association_.variable = variable;
+  }
+}
+
+bool ConstructVisitor::Pre(const parser::AssociateStmt &x) {
+  CheckDef(x.t);
+  PushScope(Scope::Kind::Block, nullptr);
+  return true;
+}
+void ConstructVisitor::Post(const parser::EndAssociateStmt &x) {
+  PopScope();
+  CheckRef(x.v);
+}
+
+void ConstructVisitor::Post(const parser::Association &x) {
+  const auto &name{std::get<parser::Name>(x.t)};
+  association_.name = &name;
+  if (auto *symbol{MakeAssocEntity()}) {
+    SetTypeFromAssociation(*symbol);
+    SetAttrsFromAssociation(*symbol);
+  }
+}
+
+void ConstructVisitor::Post(const parser::SelectTypeStmt &x) {
+  if (!association_.expr) {
+    return;  // reported error in expression evaluation
+  }
+  if (const std::optional<parser::Name> &name{std::get<1>(x.t)}) {
+    // This isn't a name in the current scope, it is in each TypeGuardStmt
+    MakePlaceholder(*name, MiscDetails::Kind::SelectTypeAssociateName);
+    association_.name = &*name;
+  } else if (!association_.variable) {
+    Say("Selector is not a named variable: 'associate-name =>' is required"_err_en_US);
+    association_ = {};
+    return;
+  }
+}
+
+bool ConstructVisitor::Pre(const parser::SelectTypeConstruct::TypeCase &) {
+  PushScope(Scope::Kind::Block, nullptr);
+  return true;
+}
+void ConstructVisitor::Post(const parser::SelectTypeConstruct::TypeCase &) {
+  PopScope();
+}
+
+void ConstructVisitor::Post(const parser::TypeGuardStmt::Guard &x) {
+  if (auto *symbol{MakeAssocEntity()}) {
+    if (std::holds_alternative<parser::Default>(x.u)) {
+      SetTypeFromAssociation(*symbol);
+    } else if (const auto *type{GetDeclTypeSpec()}) {
+      symbol->SetType(*type);
+    }
+    SetAttrsFromAssociation(*symbol);
+  }
+}
+
 bool ConstructVisitor::CheckDef(const std::optional<parser::Name> &x) {
   if (x) {
     MakeSymbol(*x, MiscDetails{MiscDetails::Kind::ConstructName});
@@ -3130,6 +3224,72 @@ void ConstructVisitor::CheckIntegerType(const Symbol &symbol) {
   }
 }
 
+// Make a symbol representing an associating entity from association_.
+Symbol *ConstructVisitor::MakeAssocEntity() {
+  if (!association_.name) {
+    return nullptr;
+  }
+  auto &symbol{MakeSymbol(*association_.name, UnknownDetails{})};
+  if (symbol.has<AssocEntityDetails>() && symbol.owner() == currScope()) {
+    Say(*association_.name,  // C1104
+        "The associate name '%s' is already used in this associate statement"_err_en_US);
+    return nullptr;
+  }
+  if (auto &expr{association_.expr}) {
+    symbol.set_details(AssocEntityDetails{std::move(*expr)});
+  }
+  return &symbol;
+}
+
+// Set the type of symbol based on the current association variable or expr.
+void ConstructVisitor::SetTypeFromAssociation(Symbol &symbol) {
+  if (association_.variable) {
+    if (const Symbol * varSymbol{association_.variable->symbol}) {
+      if (const DeclTypeSpec * type{varSymbol->GetType()}) {
+        symbol.SetType(*type);
+      }
+    }
+  } else if (const auto &expr{association_.expr}) {
+    if (std::optional<evaluate::DynamicType> type{expr->GetType()}) {
+      symbol.SetType(ToDeclTypeSpec(*type));
+    }
+  }
+}
+
+// If current selector is a variable, set some of its attributes on symbol.
+void ConstructVisitor::SetAttrsFromAssociation(Symbol &symbol) {
+  if (association_.variable) {
+    if (const auto *varSymbol{association_.variable->symbol}) {
+      symbol.attrs() |= varSymbol->attrs() &
+          Attrs{Attr::TARGET, Attr::ASYNCHRONOUS, Attr::VOLATILE,
+              Attr::CONTIGUOUS};
+      if (varSymbol->attrs().test(Attr::POINTER)) {
+        symbol.attrs().set(Attr::TARGET);
+      }
+    }
+  }
+}
+
+const DeclTypeSpec &ConstructVisitor::ToDeclTypeSpec(
+    const evaluate::DynamicType &type) {
+  switch (type.category) {
+  case common::TypeCategory::Integer:
+  case common::TypeCategory::Real:
+  case common::TypeCategory::Complex:
+    return context().MakeNumericType(type.category, type.kind);
+  case common::TypeCategory::Logical:
+    return context().MakeLogicalType(type.kind);
+  case common::TypeCategory::Character:
+    // TODO: need length from DynamicType
+    return currScope().MakeCharacterType(ParamValue::Deferred(), type.kind);
+  case common::TypeCategory::Derived:
+    CHECK(type.derived);
+    return currScope().MakeDerivedType(
+        DeclTypeSpec::TypeDerived, *type.derived);
+  default: CRASH_NO_CASE;
+  }
+}
+
 // ResolveNamesVisitor implementation
 
 bool ResolveNamesVisitor::Pre(const parser::CommonBlockObject &x) {
@@ -3222,13 +3382,13 @@ const parser::Name *ResolveNamesVisitor::ResolveDataRef(
   return std::visit(
       common::visitors{
           [=](const parser::Name &y) { return ResolveName(y); },
-          [=](const common::Indirection<parser::StructureComponent> &y) {
+          [=](const Indirection<parser::StructureComponent> &y) {
             return ResolveStructureComponent(*y);
           },
-          [=](const common::Indirection<parser::ArrayElement> &y) {
+          [=](const Indirection<parser::ArrayElement> &y) {
             return ResolveArrayElement(*y);
           },
-          [=](const common::Indirection<parser::CoindexedNamedObject> &y) {
+          [=](const Indirection<parser::CoindexedNamedObject> &y) {
             return ResolveCoindexedNamedObject(*y);
           },
       },
@@ -3267,7 +3427,7 @@ const parser::Name *ResolveNamesVisitor::FindComponent(
     return nullptr;
   }
   auto &symbol{*base->symbol};
-  if (!ConvertToObjectEntity(symbol)) {
+  if (!symbol.has<AssocEntityDetails>() && !ConvertToObjectEntity(symbol)) {
     Say2(*base, "'%s' is an invalid base for a component reference"_err_en_US,
         symbol, "Declaration of '%s'"_en_US);
     return nullptr;
@@ -3454,7 +3614,7 @@ bool ModuleVisitor::Pre(const parser::AccessStmt &x) {
       std::visit(
           common::visitors{
               [=](const parser::Name &y) { SetAccess(y, accessAttr); },
-              [=](const common::Indirection<parser::GenericSpec> &y) {
+              [=](const Indirection<parser::GenericSpec> &y) {
                 std::visit(
                     common::visitors{
                         [=](const parser::Name &z) {
@@ -3576,6 +3736,7 @@ bool ResolveNamesVisitor::Pre(const parser::ImplicitStmt &x) {
   }
   return ImplicitRulesVisitor::Pre(x);
 }
+
 void ResolveNamesVisitor::Post(const parser::PointerObject &x) {
   std::visit(
       common::visitors{

diff --git a/flang/lib/semantics/scope.cc b/flang/lib/semantics/scope.cc
index 5dab9a6..7edd456 100644 (file)
--- a/flang/lib/semantics/scope.cc
+++ b/flang/lib/semantics/scope.cc
@@ -70,21 +70,21 @@ bool Scope::AddSubmodule(const SourceName &name, Scope &submodule) {
   return submodules_.emplace(name, &submodule).second;
 }
 
-DeclTypeSpec &Scope::MakeNumericType(TypeCategory category, int kind) {
+const DeclTypeSpec &Scope::MakeNumericType(TypeCategory category, int kind) {
   return MakeLengthlessType(NumericTypeSpec{category, kind});
 }
-DeclTypeSpec &Scope::MakeLogicalType(int kind) {
+const DeclTypeSpec &Scope::MakeLogicalType(int kind) {
   return MakeLengthlessType(LogicalTypeSpec{kind});
 }
-DeclTypeSpec &Scope::MakeTypeStarType() {
+const DeclTypeSpec &Scope::MakeTypeStarType() {
   return MakeLengthlessType(DeclTypeSpec{DeclTypeSpec::TypeStar});
 }
-DeclTypeSpec &Scope::MakeClassStarType() {
+const DeclTypeSpec &Scope::MakeClassStarType() {
   return MakeLengthlessType(DeclTypeSpec{DeclTypeSpec::ClassStar});
 }
 // Types that can't have length parameters can be reused without having to
 // compare length expressions. They are stored in the global scope.
-DeclTypeSpec &Scope::MakeLengthlessType(const DeclTypeSpec &type) {
+const DeclTypeSpec &Scope::MakeLengthlessType(const DeclTypeSpec &type) {
   auto it{std::find(declTypeSpecs_.begin(), declTypeSpecs_.end(), type)};
   if (it != declTypeSpecs_.end()) {
     return *it;
@@ -94,15 +94,18 @@ DeclTypeSpec &Scope::MakeLengthlessType(const DeclTypeSpec &type) {
   }
 }
 
-DeclTypeSpec &Scope::MakeCharacterType(ParamValue &&length, int kind) {
+const DeclTypeSpec &Scope::MakeCharacterType(ParamValue &&length, int kind) {
   characterTypeSpecs_.emplace_back(std::move(length), kind);
   declTypeSpecs_.emplace_back(characterTypeSpecs_.back());
   return declTypeSpecs_.back();
 }
 
-DeclTypeSpec &Scope::MakeDerivedType(const Symbol &typeSymbol) {
-  DerivedTypeSpec &spec{derivedTypeSpecs_.emplace_back(typeSymbol)};
-  return declTypeSpecs_.emplace_back(DeclTypeSpec::TypeDerived, spec);
+DerivedTypeSpec &Scope::MakeDerivedType(const Symbol &typeSymbol) {
+  return derivedTypeSpecs_.emplace_back(typeSymbol);
+}
+const DeclTypeSpec &Scope::MakeDerivedType(
+    DeclTypeSpec::Category category, const DerivedTypeSpec &derived) {
+  return declTypeSpecs_.emplace_back(category, derived);
 }
 
 Scope::ImportKind Scope::GetImportKind() const {

diff --git a/flang/lib/semantics/scope.h b/flang/lib/semantics/scope.h
index 7ea55a1..96ce136 100644 (file)
--- a/flang/lib/semantics/scope.h
+++ b/flang/lib/semantics/scope.h
@@ -121,12 +121,15 @@ public:
   Scope *FindSubmodule(const SourceName &) const;
   bool AddSubmodule(const SourceName &, Scope &);
 
-  DeclTypeSpec &MakeNumericType(TypeCategory, int kind);
-  DeclTypeSpec &MakeLogicalType(int kind);
-  DeclTypeSpec &MakeCharacterType(ParamValue &&length, int kind = 0);
-  DeclTypeSpec &MakeDerivedType(const Symbol &);
-  DeclTypeSpec &MakeTypeStarType();
-  DeclTypeSpec &MakeClassStarType();
+  DerivedTypeSpec &MakeDerivedType(const Symbol &);
+
+  const DeclTypeSpec &MakeNumericType(TypeCategory, int kind);
+  const DeclTypeSpec &MakeLogicalType(int kind);
+  const DeclTypeSpec &MakeCharacterType(ParamValue &&length, int kind = 0);
+  const DeclTypeSpec &MakeDerivedType(
+      DeclTypeSpec::Category, const DerivedTypeSpec &);
+  const DeclTypeSpec &MakeTypeStarType();
+  const DeclTypeSpec &MakeClassStarType();
 
   // For modules read from module files, this is the stream of characters
   // that are referenced by SourceName objects.
@@ -168,7 +171,7 @@ private:
   static Symbols<1024> allSymbols;
 
   bool CanImport(const SourceName &) const;
-  DeclTypeSpec &MakeLengthlessType(const DeclTypeSpec &);
+  const DeclTypeSpec &MakeLengthlessType(const DeclTypeSpec &);
 
   friend std::ostream &operator<<(std::ostream &, const Scope &);
 };

diff --git a/flang/lib/semantics/semantics.cc b/flang/lib/semantics/semantics.cc
index 96fce6b..2eab98b 100644 (file)
--- a/flang/lib/semantics/semantics.cc
+++ b/flang/lib/semantics/semantics.cc
@@ -1,4 +1,4 @@
-// Copyright (c) 2018, NVIDIA CORPORATION.  All rights reserved.
+// Copyright (c) 2018-2019, 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.
@@ -37,14 +37,14 @@ SemanticsContext::SemanticsContext(
     foldingContext_{evaluate::FoldingContext{
         parser::ContextualMessages{parser::CharBlock{}, &messages_}}} {}
 
-DeclTypeSpec &SemanticsContext::MakeNumericType(
+const DeclTypeSpec &SemanticsContext::MakeNumericType(
     TypeCategory category, int kind) {
   if (kind == 0) {
     kind = defaultKinds_.GetDefaultKind(category);
   }
   return globalScope_.MakeNumericType(category, kind);
 }
-DeclTypeSpec &SemanticsContext::MakeLogicalType(int kind) {
+const DeclTypeSpec &SemanticsContext::MakeLogicalType(int kind) {
   if (kind == 0) {
     kind = defaultKinds_.GetDefaultKind(TypeCategory::Logical);
   }

diff --git a/flang/lib/semantics/semantics.h b/flang/lib/semantics/semantics.h
index 1a55bd4..a7bfecd 100644 (file)
--- a/flang/lib/semantics/semantics.h
+++ b/flang/lib/semantics/semantics.h
@@ -1,4 +1,4 @@
-// Copyright (c) 2018, NVIDIA CORPORATION.  All rights reserved.
+// Copyright (c) 2018-2019, 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.
@@ -67,8 +67,8 @@ public:
     return *this;
   }
 
-  DeclTypeSpec &MakeNumericType(TypeCategory, int kind = 0);
-  DeclTypeSpec &MakeLogicalType(int kind = 0);
+  const DeclTypeSpec &MakeNumericType(TypeCategory, int kind = 0);
+  const DeclTypeSpec &MakeLogicalType(int kind = 0);
 
   bool AnyFatalError() const;
   template<typename... A> parser::Message &Say(A... args) {

diff --git a/flang/lib/semantics/symbol.cc b/flang/lib/semantics/symbol.cc
index 7f1711c..771e2b6 100644 (file)
--- a/flang/lib/semantics/symbol.cc
+++ b/flang/lib/semantics/symbol.cc
@@ -74,9 +74,7 @@ void EntityDetails::set_type(const DeclTypeSpec &type) {
   type_ = &type;
 }
 
-void EntityDetails::ReplaceType(const DeclTypeSpec &type) {
-  type_ = &type;
-}
+void EntityDetails::ReplaceType(const DeclTypeSpec &type) { type_ = &type; }
 
 void ObjectEntityDetails::set_shape(const ArraySpec &shape) {
   CHECK(shape_.empty());
@@ -198,7 +196,7 @@ std::string DetailsToString(const Details &details) {
           [](const FinalProcDetails &) { return "FinalProc"; },
           [](const TypeParamDetails &) { return "TypeParam"; },
           [](const MiscDetails &) { return "Misc"; },
-          [](const auto &) { return "unknown"; },
+          [](const AssocEntityDetails &) { return "AssocEntity"; },
       },
       details);
 }
@@ -253,6 +251,7 @@ const DeclTypeSpec *Symbol::GetType() const {
       common::visitors{
           [](const EntityDetails &x) { return x.type(); },
           [](const ObjectEntityDetails &x) { return x.type(); },
+          [](const AssocEntityDetails &x) { return x.type(); },
           [](const ProcEntityDetails &x) { return x.interface().type(); },
           [](const TypeParamDetails &x) { return x.type(); },
           [](const auto &) -> const DeclTypeSpec * { return nullptr; },
@@ -265,6 +264,7 @@ void Symbol::SetType(const DeclTypeSpec &type) {
       common::visitors{
           [&](EntityDetails &x) { x.set_type(type); },
           [&](ObjectEntityDetails &x) { x.set_type(type); },
+          [&](AssocEntityDetails &x) { x.set_type(type); },
           [&](ProcEntityDetails &x) { x.interface().set_type(type); },
           [&](TypeParamDetails &x) { x.set_type(type); },
           [](auto &) {},
@@ -366,6 +366,12 @@ std::ostream &operator<<(std::ostream &os, const ObjectEntityDetails &x) {
   return os;
 }
 
+std::ostream &operator<<(std::ostream &os, const AssocEntityDetails &x) {
+  os << *static_cast<const EntityDetails *>(&x);
+  x.expr().AsFortran(os << ' ');
+  return os;
+}
+
 bool ProcEntityDetails::HasExplicitInterface() const {
   if (auto *symbol{interface_.symbol()}) {
     return symbol->HasExplicitInterface();
@@ -451,10 +457,6 @@ std::ostream &operator<<(std::ostream &os, const Details &details) {
           [&](const SubprogramNameDetails &x) {
             os << ' ' << EnumToString(x.kind());
           },
-          [&](const EntityDetails &x) { os << x; },
-          [&](const ObjectEntityDetails &x) { os << x; },
-          [&](const ProcEntityDetails &x) { os << x; },
-          [&](const DerivedTypeDetails &x) { os << x; },
           [&](const UseDetails &x) {
             os << " from " << x.symbol().name() << " in " << x.module().name();
           },
@@ -497,6 +499,7 @@ std::ostream &operator<<(std::ostream &os, const Details &details) {
           [&](const MiscDetails &x) {
             os << ' ' << MiscDetails::EnumToString(x.kind());
           },
+          [&](const auto &x) { os << x; },
       },
       details);
   return os;

diff --git a/flang/lib/semantics/symbol.h b/flang/lib/semantics/symbol.h
index 22efa0b..2169d67 100644 (file)
--- a/flang/lib/semantics/symbol.h
+++ b/flang/lib/semantics/symbol.h
@@ -123,6 +123,16 @@ private:
   friend std::ostream &operator<<(std::ostream &, const EntityDetails &);
 };
 
+// Symbol is associated with a name or expression in a SELECT TYPE or ASSOCIATE.
+class AssocEntityDetails : public EntityDetails {
+public:
+  AssocEntityDetails(SomeExpr &&expr) : expr_{std::move(expr)} {}
+  const SomeExpr &expr() const { return expr_; }
+
+private:
+  SomeExpr expr_;
+};
+
 // An entity known to be an object.
 class ObjectEntityDetails : public EntityDetails {
 public:
@@ -241,7 +251,8 @@ class FinalProcDetails {};
 class MiscDetails {
 public:
   ENUM_CLASS(Kind, None, ConstructName, ScopeName, PassName, ComplexPartRe,
-      ComplexPartIm, KindParamInquiry, LenParamInquiry);
+      ComplexPartIm, KindParamInquiry, LenParamInquiry,
+      SelectTypeAssociateName);
   MiscDetails(Kind kind) : kind_{kind} {}
   Kind kind() const { return kind_; }
 
@@ -340,9 +351,10 @@ class UnknownDetails {};
 
 using Details = std::variant<UnknownDetails, MainProgramDetails, ModuleDetails,
     SubprogramDetails, SubprogramNameDetails, EntityDetails,
-    ObjectEntityDetails, ProcEntityDetails, DerivedTypeDetails, UseDetails,
-    UseErrorDetails, HostAssocDetails, GenericDetails, ProcBindingDetails,
-    GenericBindingDetails, FinalProcDetails, TypeParamDetails, MiscDetails>;
+    ObjectEntityDetails, ProcEntityDetails, AssocEntityDetails,
+    DerivedTypeDetails, UseDetails, UseErrorDetails, HostAssocDetails,
+    GenericDetails, ProcBindingDetails, GenericBindingDetails, FinalProcDetails,
+    TypeParamDetails, MiscDetails>;
 std::ostream &operator<<(std::ostream &, const Details &);
 std::string DetailsToString(const Details &);
 

diff --git a/flang/lib/semantics/type.cc b/flang/lib/semantics/type.cc
index 4b9a8aa..6bc0e2c 100644 (file)
--- a/flang/lib/semantics/type.cc
+++ b/flang/lib/semantics/type.cc
@@ -134,7 +134,7 @@ DeclTypeSpec::DeclTypeSpec(const LogicalTypeSpec &typeSpec)
   : category_{Logical}, typeSpec_{typeSpec} {}
 DeclTypeSpec::DeclTypeSpec(CharacterTypeSpec &typeSpec)
   : category_{Character}, typeSpec_{&typeSpec} {}
-DeclTypeSpec::DeclTypeSpec(Category category, DerivedTypeSpec &typeSpec)
+DeclTypeSpec::DeclTypeSpec(Category category, const DerivedTypeSpec &typeSpec)
   : category_{category}, typeSpec_{&typeSpec} {
   CHECK(category == TypeDerived || category == ClassDerived);
 }
@@ -171,10 +171,6 @@ const CharacterTypeSpec &DeclTypeSpec::characterTypeSpec() const {
   CHECK(category_ == Character);
   return *typeSpec_.character;
 }
-DerivedTypeSpec &DeclTypeSpec::derivedTypeSpec() {
-  CHECK(category_ == TypeDerived || category_ == ClassDerived);
-  return *typeSpec_.derived;
-}
 const DerivedTypeSpec &DeclTypeSpec::derivedTypeSpec() const {
   CHECK(category_ == TypeDerived || category_ == ClassDerived);
   return *typeSpec_.derived;

diff --git a/flang/lib/semantics/type.h b/flang/lib/semantics/type.h
index b1bd017..1cf7768 100644 (file)
--- a/flang/lib/semantics/type.h
+++ b/flang/lib/semantics/type.h
@@ -85,8 +85,8 @@ private:
 // 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; }
+  static ParamValue Assumed() { return Category::Assumed; }
+  static ParamValue Deferred() { return Category::Deferred; }
   explicit ParamValue(MaybeIntExpr &&expr);
   explicit ParamValue(std::int64_t);
   bool isExplicit() const { return category_ == Category::Explicit; }
@@ -242,7 +242,7 @@ public:
   // character
   DeclTypeSpec(CharacterTypeSpec &);
   // TYPE(derived-type-spec) or CLASS(derived-type-spec)
-  DeclTypeSpec(Category, DerivedTypeSpec &);
+  DeclTypeSpec(Category, const DerivedTypeSpec &);
   // TYPE(*) or CLASS(*)
   DeclTypeSpec(Category);
   DeclTypeSpec() = delete;
@@ -258,7 +258,6 @@ public:
   const LogicalTypeSpec &logicalTypeSpec() const;
   const CharacterTypeSpec &characterTypeSpec() const;
   const DerivedTypeSpec &derivedTypeSpec() const;
-  DerivedTypeSpec &derivedTypeSpec();
   void set_category(Category category) { category_ = category; }
 
 private:
@@ -267,12 +266,12 @@ private:
     TypeSpec() : derived{nullptr} {}
     TypeSpec(NumericTypeSpec numeric) : numeric{numeric} {}
     TypeSpec(LogicalTypeSpec logical) : logical{logical} {}
-    TypeSpec(CharacterTypeSpec *character) : character{character} {}
-    TypeSpec(DerivedTypeSpec *derived) : derived{derived} {}
+    TypeSpec(const CharacterTypeSpec *character) : character{character} {}
+    TypeSpec(const DerivedTypeSpec *derived) : derived{derived} {}
     NumericTypeSpec numeric;
     LogicalTypeSpec logical;
-    CharacterTypeSpec *character;
-    DerivedTypeSpec *derived;
+    const CharacterTypeSpec *character;
+    const DerivedTypeSpec *derived;
   } typeSpec_;
 };
 std::ostream &operator<<(std::ostream &, const DeclTypeSpec &);

diff --git a/flang/test/semantics/CMakeLists.txt b/flang/test/semantics/CMakeLists.txt
index 8c54b31..3950730 100644 (file)
--- a/flang/test/semantics/CMakeLists.txt
+++ b/flang/test/semantics/CMakeLists.txt
@@ -63,6 +63,7 @@ set(ERROR_TESTS
   resolve36.f90
   resolve37.f90
   resolve38.f90
+  resolve39.f90
 )
 
 # These test files have expected symbols in the source
@@ -77,6 +78,7 @@ set(SYMBOL_TESTS
   symbol08.f90
   symbol09.f90
   symbol10.f90
+  symbol11.f90
 )
 
 # These test files have expected .mod file contents in the source

diff --git a/flang/test/semantics/resolve39.f90 b/flang/test/semantics/resolve39.f90
new file mode 100644 (file)
index 0000000..72c2b31
--- /dev/null
+++ b/flang/test/semantics/resolve39.f90
@@ -0,0 +1,24 @@
+! Copyright (c) 2019, 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.
+
+subroutine s1
+  implicit none
+  real(8) :: x = 2.0
+  !ERROR: The associate name 'a' is already used in this associate statement
+  associate(a => x, b => x+1, a => x+2)
+    x = b
+  end associate
+  !ERROR: No explicit type declared for 'b'
+  x = b
+end

diff --git a/flang/test/semantics/symbol11.f90 b/flang/test/semantics/symbol11.f90
new file mode 100644 (file)
index 0000000..a6d3cd0
--- /dev/null
+++ b/flang/test/semantics/symbol11.f90
@@ -0,0 +1,95 @@
+! Copyright (c) 2019, 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.
+
+!DEF: /s1 Subprogram
+subroutine s1
+ implicit none
+ !DEF: /s1/x ObjectEntity REAL(8)
+ real(kind=8) :: x = 2.0
+ !DEF: /s1/a ObjectEntity INTEGER(4)
+ integer a
+ !DEF: /s1/t DerivedType
+ type :: t
+ end type
+ !REF: /s1/t
+ !DEF: /s1/z ALLOCATABLE ObjectEntity CLASS(t)
+ class(t), allocatable :: z
+ !DEF: /s1/Block1/a AssocEntity REAL(8)
+ !REF: /s1/x
+ !DEF: /s1/Block1/b AssocEntity REAL(8)
+ !DEF: /s1/Block1/c AssocEntity CLASS(t)
+ !REF: /s1/z
+ associate (a => x, b => x+1, c => z)
+  !REF: /s1/x
+  !REF: /s1/Block1/a
+  x = a
+ end associate
+end subroutine
+
+!DEF: /s2 Subprogram
+subroutine s2
+ !DEF: /s2/x ObjectEntity CHARACTER(4_4,1)
+ !DEF: /s2/y ObjectEntity CHARACTER(4_4,1)
+ character(len=4) x, y
+ !DEF: /s2/Block1/z AssocEntity CHARACTER(4_4,1)
+ !REF: /s2/x
+ associate (z => x)
+  !REF: /s2/Block1/z
+  print *, "z:", z
+ end associate
+ !TODO: need correct length for z
+ !DEF: /s2/Block2/z AssocEntity CHARACTER(:,1)
+ !REF: /s2/x
+ !REF: /s2/y
+ associate (z => x//y)
+  !REF: /s2/Block2/z
+  print *, "z:", z
+ end associate
+end subroutine
+
+!DEF: /s3 Subprogram
+subroutine s3
+ !DEF: /s3/t1 DerivedType
+ type :: t1
+  !DEF: /s3/t1/a1 ObjectEntity INTEGER(4)
+  integer :: a1
+ end type
+ !REF: /s3/t1
+ !DEF: /s3/t2 DerivedType
+ type, extends(t1) :: t2
+  !DEF: /s3/t2/a2 ObjectEntity INTEGER(4)
+  integer :: a2
+ end type
+ !DEF: /s3/i ObjectEntity INTEGER(4)
+ integer i
+ !REF: /s3/t1
+ !DEF: /s3/x POINTER ObjectEntity CLASS(t1)
+ class(t1), pointer :: x
+ !REF: /s3/x
+ select type (y => x)
+  !REF: /s3/t2
+  class is (t2)
+   !REF: /s3/i
+   !DEF: /s3/Block1/y TARGET AssocEntity TYPE(t2)
+   !REF: /s3/t2/a2
+   i = y%a2
+   type is (integer(kind=8))
+    !REF: /s3/i
+    !DEF: /s3/Block2/y TARGET AssocEntity INTEGER(8)
+    i = y
+   class default
+    !DEF: /s3/Block3/y TARGET AssocEntity CLASS(t1)
+    print *, y
+ end select
+end subroutine

diff --git a/flang/test/semantics/test_symbols.sh b/flang/test/semantics/test_symbols.sh
index 55ce147..c64753a 100755 (executable)
--- a/flang/test/semantics/test_symbols.sh
+++ b/flang/test/semantics/test_symbols.sh
@@ -1,5 +1,5 @@
 #!/usr/bin/env bash
-# Copyright (c) 2018, NVIDIA CORPORATION.  All rights reserved.
+# Copyright (c) 2018-2019, 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.
@@ -46,7 +46,7 @@ sed -e 's/!\([DR]EF:\)/KEEP \1/' \
 egrep -v '^ *!' $src1 > $src2  # strip out meaningful comments
 $CMD $src2 > $src3  # compile, inserting comments for symbols
 
-if diff -U999999 $src1 $src3 > $diffs; then
+if diff -w -U999999 $src1 $src3 > $diffs; then
   echo PASS
 else
   sed '1,/^\@\@/d' $diffs