[flang] Rework component KIND= values in PDT instantiations

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