[flang] Rework component KIND= values in PDT instantiations (#162367)

When processing the KIND= values of type specifications in parameterized
derived type component declarations, it turns out to be necessary to
analyze their expressions' parse trees rather than to just fold their
typed expression representations. The types of the subexpressions may
depend on the values of KIND parameters.

Further, when checking the values of KIND= actual arguments to type
conversion intrinsic functions (e.g., INT(..., KIND=)) that appear in
KIND specifiers for PDT component declarations, don't emit an error for
the derived type definition, but instead emit them for derived type
instantiations.

Fixes #161961.

Author: klausler

flang/include/flang/Evaluate/common.h

@@ -231,14 +231,20 @@ class FoldingContext {
       : messages_{that.messages_}, defaults_{that.defaults_},
         intrinsics_{that.intrinsics_},
         targetCharacteristics_{that.targetCharacteristics_},
-        pdtInstance_{that.pdtInstance_}, impliedDos_{that.impliedDos_},
+        pdtInstance_{that.pdtInstance_},
+        analyzingPDTComponentKindSelector_{
+            that.analyzingPDTComponentKindSelector_},
+        impliedDos_{that.impliedDos_},
         languageFeatures_{that.languageFeatures_}, tempNames_{that.tempNames_} {
   }
   FoldingContext(
       const FoldingContext &that, const parser::ContextualMessages &m)
       : messages_{m}, defaults_{that.defaults_}, intrinsics_{that.intrinsics_},
         targetCharacteristics_{that.targetCharacteristics_},
-        pdtInstance_{that.pdtInstance_}, impliedDos_{that.impliedDos_},
+        pdtInstance_{that.pdtInstance_},
+        analyzingPDTComponentKindSelector_{
+            that.analyzingPDTComponentKindSelector_},
+        impliedDos_{that.impliedDos_},
         languageFeatures_{that.languageFeatures_}, tempNames_{that.tempNames_} {
   }
 
@@ -248,6 +254,9 @@ class FoldingContext {
     return defaults_;
   }
   const semantics::DerivedTypeSpec *pdtInstance() const { return pdtInstance_; }
+  bool analyzingPDTComponentKindSelector() const {
+    return analyzingPDTComponentKindSelector_;
+  }
   const IntrinsicProcTable &intrinsics() const { return intrinsics_; }
   const TargetCharacteristics &targetCharacteristics() const {
     return targetCharacteristics_;
@@ -290,6 +299,10 @@ class FoldingContext {
     return common::ScopedSet(pdtInstance_, nullptr);
   }
 
+  common::Restorer<bool> AnalyzingPDTComponentKindSelector() {
+    return common::ScopedSet(analyzingPDTComponentKindSelector_, true);
+  }
+
   parser::CharBlock SaveTempName(std::string &&name) {
     return {*tempNames_.emplace(std::move(name)).first};
   }
@@ -300,6 +313,7 @@ class FoldingContext {
   const IntrinsicProcTable &intrinsics_;
   const TargetCharacteristics &targetCharacteristics_;
   const semantics::DerivedTypeSpec *pdtInstance_{nullptr};
+  bool analyzingPDTComponentKindSelector_{false};
   std::optional<parser::CharBlock> moduleFileName_;
   std::map<parser::CharBlock, ConstantSubscript> impliedDos_;
   const common::LanguageFeatureControl &languageFeatures_;

flang/include/flang/Semantics/expression.h

@@ -535,6 +535,7 @@ class ExprChecker {
     return true;
   }
   void Post(const parser::ComponentDefStmt &) { inComponentDefStmt_ = false; }
+  bool Pre(const parser::KindSelector &) { return !inComponentDefStmt_; }
   bool Pre(const parser::Initialization &x) {
     // Default component initialization expressions (but not DATA-like ones
     // as in DEC STRUCTUREs) were already analyzed in name resolution

flang/include/flang/Semantics/symbol.h

@@ -510,6 +510,11 @@ class DerivedTypeDetails {
   const std::list<SourceName> &componentNames() const {
     return componentNames_;
   }
+  const std::map<SourceName, const parser::Expr *> &
+  originalKindParameterMap() const {
+    return originalKindParameterMap_;
+  }
+  void add_originalKindParameter(SourceName, const parser::Expr *);
 
   // If this derived type extends another, locate the parent component's symbol.
   const Symbol *GetParentComponent(const Scope &) const;
@@ -538,6 +543,8 @@ class DerivedTypeDetails {
   bool sequence_{false};
   bool isDECStructure_{false};
   bool isForwardReferenced_{false};
+  std::map<SourceName, const parser::Expr *> originalKindParameterMap_;
+
   friend llvm::raw_ostream &operator<<(
       llvm::raw_ostream &, const DerivedTypeDetails &);
 };

flang/lib/Evaluate/intrinsics.cpp

@@ -2515,7 +2515,8 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
       CHECK(kindDummyArg);
       CHECK(result.categorySet == CategorySet{*category});
       if (kindArg) {
-        if (auto *expr{kindArg->UnwrapExpr()}) {
+        auto *expr{kindArg->UnwrapExpr()};
+        if (expr) {
           CHECK(expr->Rank() == 0);
           if (auto code{ToInt64(Fold(context, common::Clone(*expr)))}) {
             if (context.targetCharacteristics().IsTypeEnabled(
@@ -2529,8 +2530,16 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
             }
           }
         }
-        messages.Say(
-            "'kind=' argument must be a constant scalar integer whose value is a supported kind for the intrinsic result type"_err_en_US);
+        if (context.analyzingPDTComponentKindSelector() && expr &&
+            IsConstantExpr(*expr)) {
+          // Don't emit an error about a KIND= actual argument value when
+          // processing a kind selector in a PDT component declaration before
+          // it is instantianted, so long as it's a constant expression.
+          // It will be renanalyzed later during instantiation.
+        } else {
+          messages.Say(
+              "'kind=' argument must be a constant scalar integer whose value is a supported kind for the intrinsic result type"_err_en_US);
+        }
         // use default kind below for error recovery
       } else if (kindDummyArg->flags.test(ArgFlag::defaultsToSameKind)) {
         CHECK(sameArg);

flang/lib/Semantics/resolve-names.cpp

@@ -357,6 +357,7 @@ class DeclTypeSpecVisitor : public AttrsVisitor {
       DeclTypeSpec::Category category{DeclTypeSpec::TypeDerived};
     } derived;
     bool allowForwardReferenceToDerivedType{false};
+    const parser::Expr *originalKindParameter{nullptr};
   };
 
   bool allowForwardReferenceToDerivedType() const {
@@ -365,8 +366,10 @@ class DeclTypeSpecVisitor : public AttrsVisitor {
   void set_allowForwardReferenceToDerivedType(bool yes) {
     state_.allowForwardReferenceToDerivedType = yes;
   }
+  void set_inPDTDefinition(bool yes) { inPDTDefinition_ = yes; }
 
-  const DeclTypeSpec *GetDeclTypeSpec();
+  const DeclTypeSpec *GetDeclTypeSpec() const;
+  const parser::Expr *GetOriginalKindParameter() const;
   void BeginDeclTypeSpec();
   void EndDeclTypeSpec();
   void SetDeclTypeSpec(const DeclTypeSpec &);
@@ -380,6 +383,7 @@ class DeclTypeSpecVisitor : public AttrsVisitor {
 
 private:
   State state_;
+  bool inPDTDefinition_{false};
 
   void MakeNumericType(TypeCategory, int kind);
 };
@@ -2454,9 +2458,12 @@ bool AttrsVisitor::Pre(const common::CUDADataAttr x) {
 
 // DeclTypeSpecVisitor implementation
 
-const DeclTypeSpec *DeclTypeSpecVisitor::GetDeclTypeSpec() {
+const DeclTypeSpec *DeclTypeSpecVisitor::GetDeclTypeSpec() const {
   return state_.declTypeSpec;
 }
+const parser::Expr *DeclTypeSpecVisitor::GetOriginalKindParameter() const {
+  return state_.originalKindParameter;
+}
 
 void DeclTypeSpecVisitor::BeginDeclTypeSpec() {
   CHECK(!state_.expectDeclTypeSpec);
@@ -2541,6 +2548,21 @@ void DeclTypeSpecVisitor::SetDeclTypeSpec(const DeclTypeSpec &declTypeSpec) {
 
 KindExpr DeclTypeSpecVisitor::GetKindParamExpr(
     TypeCategory category, const std::optional<parser::KindSelector> &kind) {
+  if (inPDTDefinition_) {
+    if (category != TypeCategory::Derived && kind) {
+      if (const auto *expr{
+              std::get_if<parser::ScalarIntConstantExpr>(&kind->u)}) {
+        CHECK(!state_.originalKindParameter);
+        // Save a pointer to the KIND= expression in the parse tree
+        // in case we need to reanalyze it during PDT instantiation.
+        state_.originalKindParameter = &expr->thing.thing.thing.value();
+      }
+    }
+    // Inhibit some errors now that will be caught later during instantiations.
+    auto restorer{
+        context().foldingContext().AnalyzingPDTComponentKindSelector()};
+    return AnalyzeKindSelector(context(), category, kind);
+  }
   return AnalyzeKindSelector(context(), category, kind);
 }
 
@@ -6410,6 +6432,7 @@ bool DeclarationVisitor::Pre(const parser::DerivedTypeDef &x) {
   details.set_isForwardReferenced(false);
   derivedTypeInfo_ = {};
   PopScope();
+  set_inPDTDefinition(false);
   return false;
 }
 
@@ -6437,6 +6460,10 @@ void DeclarationVisitor::Post(const parser::DerivedTypeStmt &x) {
     // component without producing spurious errors about already
     // existing.
     const Symbol &extendsSymbol{extendsType->typeSymbol()};
+    if (extendsSymbol.scope() &&
+        extendsSymbol.scope()->IsParameterizedDerivedType()) {
+      set_inPDTDefinition(true);
+    }
     auto restorer{common::ScopedSet(extendsName->symbol, nullptr)};
     if (OkToAddComponent(*extendsName, &extendsSymbol)) {
       auto &comp{DeclareEntity<ObjectEntityDetails>(*extendsName, Attrs{})};
@@ -6455,8 +6482,12 @@ void DeclarationVisitor::Post(const parser::DerivedTypeStmt &x) {
   }
   // Create symbols now for type parameters so that they shadow names
   // from the enclosing specification part.
+  const auto &paramNames{std::get<std::list<parser::Name>>(x.t)};
+  if (!paramNames.empty()) {
+    set_inPDTDefinition(true);
+  }
   if (auto *details{symbol.detailsIf<DerivedTypeDetails>()}) {
-    for (const auto &name : std::get<std::list<parser::Name>>(x.t)) {
+    for (const auto &name : paramNames) {
       if (Symbol * symbol{MakeTypeSymbol(name, TypeParamDetails{})}) {
         details->add_paramNameOrder(*symbol);
       }
@@ -6544,8 +6575,7 @@ void DeclarationVisitor::Post(const parser::ComponentDecl &x) {
     if (const auto *derived{declType->AsDerived()}) {
       if (!attrs.HasAny({Attr::POINTER, Attr::ALLOCATABLE})) {
         if (derivedTypeInfo_.type == &derived->typeSymbol()) { // C744
-          Say("Recursive use of the derived type requires "
-              "POINTER or ALLOCATABLE"_err_en_US);
+          Say("Recursive use of the derived type requires POINTER or ALLOCATABLE"_err_en_US);
         }
       }
     }
@@ -6558,7 +6588,11 @@ void DeclarationVisitor::Post(const parser::ComponentDecl &x) {
         Initialization(name, *init, /*inComponentDecl=*/true);
       }
     }
-    currScope().symbol()->get<DerivedTypeDetails>().add_component(symbol);
+    auto &details{currScope().symbol()->get<DerivedTypeDetails>()};
+    details.add_component(symbol);
+    if (const parser::Expr *kindExpr{GetOriginalKindParameter()}) {
+      details.add_originalKindParameter(name.source, kindExpr);
+    }
   }
   ClearArraySpec();
   ClearCoarraySpec();

flang/lib/Semantics/symbol.cpp

@@ -769,6 +769,11 @@ void DerivedTypeDetails::add_component(const Symbol &symbol) {
   componentNames_.push_back(symbol.name());
 }
 
+void DerivedTypeDetails::add_originalKindParameter(
+    SourceName name, const parser::Expr *expr) {
+  originalKindParameterMap_.emplace(name, expr);
+}
+
 const Symbol *DerivedTypeDetails::GetParentComponent(const Scope &scope) const {
   if (auto extends{GetParentComponentName()}) {
     if (auto iter{scope.find(*extends)}; iter != scope.cend()) {

flang/lib/Semantics/type.cpp

@@ -443,9 +443,9 @@ void InstantiateHelper::InstantiateComponents(const Scope &fromScope) {
 // Walks a parsed expression to prepare it for (re)analysis;
 // clears out the typedExpr analysis results and re-resolves
 // symbol table pointers of type parameters.
-class ComponentInitResetHelper {
+class ResetHelper {
 public:
-  explicit ComponentInitResetHelper(Scope &scope) : scope_{scope} {}
+  explicit ResetHelper(Scope &scope) : scope_{scope} {}
 
   template <typename A> bool Pre(const A &) { return true; }
 
@@ -498,7 +498,7 @@ void InstantiateHelper::InstantiateComponent(const Symbol &oldSymbol) {
     }
     if (const auto *parsedExpr{details->unanalyzedPDTComponentInit()}) {
       // Analyze the parsed expression in this PDT instantiation context.
-      ComponentInitResetHelper resetter{scope_};
+      ResetHelper resetter{scope_};
       parser::Walk(*parsedExpr, resetter);
       auto restorer{foldingContext().messages().SetLocation(newSymbol.name())};
       details->set_init(evaluate::Fold(
@@ -564,16 +564,44 @@ static ParamValue FoldCharacterLength(evaluate::FoldingContext &foldingContext,
 // Apply type parameter values to an intrinsic type spec.
 const DeclTypeSpec &InstantiateHelper::InstantiateIntrinsicType(
     SourceName symbolName, const DeclTypeSpec &spec) {
+  const parser::Expr *originalKindExpr{nullptr};
+  if (const DerivedTypeSpec *derived{scope_.derivedTypeSpec()}) {
+    if (const auto *details{derived->originalTypeSymbol()
+                .GetUltimate()
+                .detailsIf<DerivedTypeDetails>()}) {
+      const auto &originalKindMap{details->originalKindParameterMap()};
+      if (auto iter{originalKindMap.find(symbolName)};
+          iter != originalKindMap.end()) {
+        originalKindExpr = iter->second;
+      }
+    }
+  }
   const IntrinsicTypeSpec &intrinsic{DEREF(spec.AsIntrinsic())};
-  if (spec.category() != DeclTypeSpec::Character &&
+  if (spec.category() != DeclTypeSpec::Character && !originalKindExpr &&
       evaluate::IsActuallyConstant(intrinsic.kind())) {
     return spec; // KIND is already a known constant
   }
   // The expression was not originally constant, but now it must be so
   // in the context of a parameterized derived type instantiation.
-  KindExpr copy{Fold(common::Clone(intrinsic.kind()))};
+  std::optional<KindExpr> kindExpr;
+  if (originalKindExpr) {
+    ResetHelper resetter{scope_};
+    parser::Walk(*originalKindExpr, resetter);
+    auto restorer{foldingContext().messages().DiscardMessages()};
+    if (MaybeExpr analyzed{AnalyzeExpr(scope_.context(), *originalKindExpr)}) {
+      if (auto *intExpr{evaluate::UnwrapExpr<SomeIntExpr>(*analyzed)}) {
+        kindExpr = evaluate::ConvertToType<evaluate::SubscriptInteger>(
+            std::move(*intExpr));
+      }
+    }
+  }
+  if (!kindExpr) {
+    kindExpr = KindExpr{intrinsic.kind()};
+    CHECK(kindExpr.has_value());
+  }
+  KindExpr folded{Fold(std::move(*kindExpr))};
   int kind{context().GetDefaultKind(intrinsic.category())};
-  if (auto value{evaluate::ToInt64(copy)}) {
+  if (auto value{evaluate::ToInt64(folded)}) {
     if (foldingContext().targetCharacteristics().IsTypeEnabled(
             intrinsic.category(), *value)) {
       kind = *value;
@@ -586,7 +614,7 @@ const DeclTypeSpec &InstantiateHelper::InstantiateIntrinsicType(
   } else {
     std::string exprString;
     llvm::raw_string_ostream sstream(exprString);
-    copy.AsFortran(sstream);
+    folded.AsFortran(sstream);
     foldingContext().messages().Say(symbolName,
         "KIND parameter expression (%s) of intrinsic type %s did not resolve to a constant value"_err_en_US,
         exprString,

flang/test/Semantics/kinds03.f90

@@ -5,7 +5,7 @@
  type :: ipdt(k)
   !REF: /MainProgram1/ipdt/k
   integer, kind :: k
-  !REF: /MainProgram1/ipdt/k
+  !DEF: /MainProgram1/DerivedType9/k TypeParam INTEGER(4)
   !DEF: /MainProgram1/ipdt/x ObjectEntity INTEGER(int(int(k,kind=4),kind=8))
   integer(kind=k) :: x
  end type ipdt
@@ -14,7 +14,7 @@
  type :: rpdt(k)
   !REF: /MainProgram1/rpdt/k
   integer, kind :: k
-  !REF: /MainProgram1/rpdt/k
+  !DEF: /MainProgram1/DerivedType13/k TypeParam INTEGER(4)
   !DEF: /MainProgram1/rpdt/x ObjectEntity REAL(int(int(k,kind=4),kind=8))
   real(kind=k) :: x
  end type rpdt
@@ -23,7 +23,7 @@
  type :: zpdt(k)
   !REF: /MainProgram1/zpdt/k
   integer, kind :: k
-  !REF: /MainProgram1/zpdt/k
+  !DEF: /MainProgram1/DerivedType17/k TypeParam INTEGER(4)
   !DEF: /MainProgram1/zpdt/x ObjectEntity COMPLEX(int(int(k,kind=4),kind=8))
   complex(kind=k) :: x
  end type zpdt
@@ -32,7 +32,7 @@
  type :: lpdt(k)
   !REF: /MainProgram1/lpdt/k
   integer, kind :: k
-  !REF: /MainProgram1/lpdt/k
+  !DEF: /MainProgram1/DerivedType21/k TypeParam INTEGER(4)
   !DEF: /MainProgram1/lpdt/x ObjectEntity LOGICAL(int(int(k,kind=4),kind=8))
   logical(kind=k) :: x
  end type lpdt

flang/test/Semantics/pdt05.f90

@@ -0,0 +1,24 @@
+!RUN: %flang_fc1 -fdebug-unparse %s | FileCheck %s
+
+module pdt05
+  type base(k1,k2)
+    integer(1),kind :: k1
+    integer(k1),kind :: k2
+    integer(kind(int(k1,1)+int(k2,k1))) j
+    integer(kind(int(k1,1)+int(k2,kind(k2)))) k
+  end type
+end
+
+use pdt05
+type(base(2,7)) x27
+type(base(8,7)) x87
+print *, 'x27%j', kind(x27%j)
+print *, 'x27%k', kind(x27%k)
+print *, 'x87%j', kind(x87%j)
+print *, 'x87%k', kind(x87%k)
+end
+
+!CHECK: PRINT *, "x27%j", 2_4
+!CHECK: PRINT *, "x27%k", 2_4
+!CHECK: PRINT *, "x87%j", 8_4
+!CHECK: PRINT *, "x87%k", 8_4

flang/test/Semantics/real10-x86-01.f90

@@ -6,7 +6,7 @@
  type :: rpdt(k)
   !REF: /MainProgram1/rpdt/k
   integer, kind :: k
-  !REF: /MainProgram1/rpdt/k
+  !DEF: /MainProgram1/DerivedType3/k TypeParam INTEGER(4)
   !DEF: /MainProgram1/rpdt/x ObjectEntity REAL(int(int(k,kind=4),kind=8))
   real(kind=k) :: x
  end type rpdt
@@ -15,7 +15,7 @@
  type :: zpdt(k)
   !REF: /MainProgram1/zpdt/k
   integer, kind :: k
-  !REF: /MainProgram1/zpdt/k
+  !DEF: /MainProgram1/DerivedType4/k TypeParam INTEGER(4)
   !DEF: /MainProgram1/zpdt/x ObjectEntity COMPLEX(int(int(k,kind=4),kind=8))
   complex(kind=k) :: x
  end type zpdt