[flang] Support PDT KIND parameters in later parameter kind expressions

Fortran allows an earlier-declared KIND type parameter of a parameterized
derived type to be used in the constant expression defining the integer
kind of a later type parameter.

  TYPE :: T(K,L)
    INTEGER, KIND :: K
    INTEGER(K), LEN :: L
    ...
  END TYPE

Differential Revision: https://reviews.llvm.org/D159044https://reviews.llvm.org/D159044

flang/lib/Evaluate/fold-implementation.h

@@ -1132,12 +1132,17 @@ Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
 template <typename T>
 Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&funcRef) {
   ActualArguments &args{funcRef.arguments()};
-  for (std::optional<ActualArgument> &arg : args) {
-    if (auto *expr{UnwrapExpr<Expr<SomeType>>(arg)}) {
-      *expr = Fold(context, std::move(*expr));
+  const auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};
+  if (!intrinsic || intrinsic->name != "kind") {
+    // Don't fold the argument to KIND(); it might be a TypeParamInquiry
+    // with a forced result type that doesn't match the parameter.
+    for (std::optional<ActualArgument> &arg : args) {
+      if (auto *expr{UnwrapExpr<Expr<SomeType>>(arg)}) {
+        *expr = Fold(context, std::move(*expr));
+      }
     }
   }
-  if (auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)}) {
+  if (intrinsic) {
     const std::string name{intrinsic->name};
     if (name == "cshift") {
       return Folder<T>{context}.CSHIFT(std::move(funcRef));

flang/lib/Evaluate/fold-integer.cpp

@@ -844,10 +844,23 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
   } else if (name == "int_ptr_kind") {
     return Expr<T>{8};
   } else if (name == "kind") {
-    if constexpr (common::HasMember<T, IntegerTypes>) {
-      return Expr<T>{args[0].value().GetType()->kind()};
-    } else {
-      DIE("kind() result not integral");
+    // FoldOperation(FunctionRef &&) in fold-implementation.h will not
+    // have folded the argument; in the case of TypeParamInquiry,
+    // try to get the type of the parameter itself.
+    if (const auto *expr{args[0] ? args[0]->UnwrapExpr() : nullptr}) {
+      std::optional<DynamicType> dyType;
+      if (const auto *inquiry{UnwrapExpr<TypeParamInquiry>(*expr)}) {
+        if (const auto *typeSpec{inquiry->parameter().GetType()}) {
+          if (const auto *intrinType{typeSpec->AsIntrinsic()}) {
+            if (auto k{ToInt64(Fold(
+                    context, Expr<SubscriptInteger>{intrinType->kind()}))}) {
+              return Expr<T>{*k};
+            }
+          }
+        }
+      } else if (auto dyType{expr->GetType()}) {
+        return Expr<T>{dyType->kind()};
+      }
     }
   } else if (name == "iparity") {
     return FoldBitReduction(

flang/lib/Semantics/expression.cpp

@@ -924,10 +924,30 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Name &n) {
   } else {
     const Symbol &ultimate{n.symbol->GetUltimate()};
     if (ultimate.has<semantics::TypeParamDetails>()) {
-      // A bare reference to a derived type parameter (within a parameterized
-      // derived type definition)
+      // A bare reference to a derived type parameter within a parameterized
+      // derived type definition.
+      auto dyType{DynamicType::From(ultimate)};
+      if (!dyType) {
+        // When the integer kind of this type parameter is not known now,
+        // it's either an error or because it depends on earlier-declared kind
+        // type parameters.  So assume that it's a subscript integer for now
+        // while processing other specification expressions in the PDT
+        // definition; the right kind value will be used later in each of its
+        // instantiations.
+        int kind{SubscriptInteger::kind};
+        if (const auto *typeSpec{ultimate.GetType()}) {
+          if (const semantics::IntrinsicTypeSpec *
+              intrinType{typeSpec->AsIntrinsic()}) {
+            if (auto k{ToInt64(Fold(semantics::KindExpr{intrinType->kind()}))};
+                k && IsValidKindOfIntrinsicType(TypeCategory::Integer, *k)) {
+              kind = *k;
+            }
+          }
+        }
+        dyType = DynamicType{TypeCategory::Integer, kind};
+      }
       return Fold(ConvertToType(
-          ultimate, AsGenericExpr(TypeParamInquiry{std::nullopt, ultimate})));
+          *dyType, AsGenericExpr(TypeParamInquiry{std::nullopt, ultimate})));
     } else {
       if (n.symbol->attrs().test(semantics::Attr::VOLATILE)) {
         if (const semantics::Scope *pure{semantics::FindPureProcedureContaining(

flang/lib/Semantics/runtime-type-info.cpp

@@ -428,16 +428,21 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
       (typeName.front() == '.' && !context_.IsTempName(typeName))) {
     return nullptr;
   }
+  bool isPDTDefinitionWithKindParameters{
+      !derivedTypeSpec && dtScope.IsDerivedTypeWithKindParameter()};
+  bool isPDTInstantiation{derivedTypeSpec && &dtScope != dtSymbol->scope()};
   const SymbolVector *parameters{GetTypeParameters(*dtSymbol)};
   std::string distinctName{typeName};
-  if (&dtScope != dtSymbol->scope() && derivedTypeSpec) {
+  if (isPDTInstantiation) {
     // Only create new type descriptions for different kind parameter values.
     // Type with different length parameters/same kind parameters can all
     // share the same type description available in the current scope.
     if (auto suffix{
             GetSuffixIfTypeKindParameters(*derivedTypeSpec, parameters)}) {
       distinctName += *suffix;
     }
+  } else if (isPDTDefinitionWithKindParameters) {
+    return nullptr;
   }
   std::string dtDescName{".dt."s + distinctName};
   Scope *dtSymbolScope{const_cast<Scope *>(dtSymbol->scope())};
@@ -455,9 +460,7 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
   evaluate::StructureConstructorValues dtValues;
   AddValue(dtValues, derivedTypeSchema_, "name"s,
       SaveNameAsPointerTarget(scope, typeName));
-  bool isPDTdefinitionWithKindParameters{
-      !derivedTypeSpec && dtScope.IsDerivedTypeWithKindParameter()};
-  if (!isPDTdefinitionWithKindParameters) {
+  if (!isPDTDefinitionWithKindParameters) {
     auto sizeInBytes{static_cast<common::ConstantSubscript>(dtScope.size())};
     if (auto alignment{dtScope.alignment().value_or(0)}) {
       sizeInBytes += alignment - 1;
@@ -467,10 +470,10 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
     AddValue(
         dtValues, derivedTypeSchema_, "sizeinbytes"s, IntToExpr(sizeInBytes));
   }
-  bool isPDTinstantiation{derivedTypeSpec && &dtScope != dtSymbol->scope()};
-  if (isPDTinstantiation) {
-    const Symbol *uninstDescObject{
-        DescribeType(DEREF(const_cast<Scope *>(dtSymbol->scope())))};
+  if (const Symbol *
+      uninstDescObject{isPDTInstantiation
+              ? DescribeType(DEREF(const_cast<Scope *>(dtSymbol->scope())))
+              : nullptr}) {
     AddValue(dtValues, derivedTypeSchema_, "uninstantiated"s,
         evaluate::AsGenericExpr(evaluate::Expr<evaluate::SomeDerived>{
             evaluate::Designator<evaluate::SomeDerived>{
@@ -489,22 +492,24 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
     // by their instantiated (or default) values, while LEN= type
     // parameters are described by their INTEGER kinds.
     for (SymbolRef ref : *parameters) {
-      const auto &tpd{ref->get<TypeParamDetails>()};
-      if (tpd.attr() == common::TypeParamAttr::Kind) {
-        auto value{evaluate::ToInt64(tpd.init()).value_or(0)};
-        if (derivedTypeSpec) {
-          if (const auto *pv{derivedTypeSpec->FindParameter(ref->name())}) {
-            if (pv->GetExplicit()) {
-              if (auto instantiatedValue{
-                      evaluate::ToInt64(*pv->GetExplicit())}) {
-                value = *instantiatedValue;
+      if (const auto *inst{dtScope.FindComponent(ref->name())}) {
+        const auto &tpd{inst->get<TypeParamDetails>()};
+        if (tpd.attr() == common::TypeParamAttr::Kind) {
+          auto value{evaluate::ToInt64(tpd.init()).value_or(0)};
+          if (derivedTypeSpec) {
+            if (const auto *pv{derivedTypeSpec->FindParameter(inst->name())}) {
+              if (pv->GetExplicit()) {
+                if (auto instantiatedValue{
+                        evaluate::ToInt64(*pv->GetExplicit())}) {
+                  value = *instantiatedValue;
+                }
               }
             }
           }
+          kinds.emplace_back(value);
+        } else { // LEN= parameter
+          lenKinds.emplace_back(GetIntegerKind(*inst));
         }
-        kinds.emplace_back(value);
-      } else { // LEN= parameter
-        lenKinds.emplace_back(GetIntegerKind(*ref));
       }
     }
   }
@@ -515,7 +520,7 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
       SaveNumericPointerTarget<Int1>(
           scope, SaveObjectName(".lpk."s + distinctName), std::move(lenKinds)));
   // Traverse the components of the derived type
-  if (!isPDTdefinitionWithKindParameters) {
+  if (!isPDTDefinitionWithKindParameters) {
     std::vector<const Symbol *> dataComponentSymbols;
     std::vector<evaluate::StructureConstructor> procPtrComponents;
     for (const auto &pair : dtScope) {

flang/lib/Semantics/type.cpp

@@ -110,58 +110,80 @@ void DerivedTypeSpec::EvaluateParameters(SemanticsContext &context) {
   }
   evaluated_ = true;
   auto &messages{foldingContext.messages()};
-
-  // Fold the explicit type parameter value expressions first.  Do not
-  // fold them within the scope of the derived type being instantiated;
-  // these expressions cannot use its type parameters.  Convert the values
-  // of the expressions to the declared types of the type parameters.
-  auto parameterDecls{OrderParameterDeclarations(typeSymbol_)};
-  for (const Symbol &symbol : parameterDecls) {
-    const SourceName &name{symbol.name()};
+  for (const Symbol &symbol : OrderParameterDeclarations(typeSymbol_)) {
+    SourceName name{symbol.name()};
+    int parameterKind{evaluate::TypeParamInquiry::Result::kind};
+    // Compute the integer kind value of the type parameter,
+    // which may depend on the values of earlier ones.
+    if (const auto *typeSpec{symbol.GetType()}) {
+      if (const IntrinsicTypeSpec * intrinType{typeSpec->AsIntrinsic()};
+          intrinType && intrinType->category() == TypeCategory::Integer) {
+        auto restorer{foldingContext.WithPDTInstance(*this)};
+        auto folded{Fold(foldingContext, KindExpr{intrinType->kind()})};
+        if (auto k{evaluate::ToInt64(folded)}; k &&
+            evaluate::IsValidKindOfIntrinsicType(TypeCategory::Integer, *k)) {
+          parameterKind = static_cast<int>(*k);
+        } else {
+          messages.Say(
+              "Type of type parameter '%s' (%s) is not a valid kind of INTEGER"_err_en_US,
+              name, intrinType->kind().AsFortran());
+        }
+      }
+    }
+    bool ok{
+        symbol.get<TypeParamDetails>().attr() == common::TypeParamAttr::Len};
     if (ParamValue * paramValue{FindParameter(name)}) {
+      // Explicit type parameter value expressions are not folded within
+      // the scope of the derived type being instantiated, as the expressions
+      // themselves are not in that scope and cannot reference its type
+      // parameters.
       if (const MaybeIntExpr & expr{paramValue->GetExplicit()}) {
-        if (auto converted{evaluate::ConvertToType(symbol, SomeExpr{*expr})}) {
+        evaluate::DynamicType dyType{TypeCategory::Integer, parameterKind};
+        if (auto converted{evaluate::ConvertToType(dyType, SomeExpr{*expr})}) {
           SomeExpr folded{
               evaluate::Fold(foldingContext, std::move(*converted))};
           if (auto *intExpr{std::get_if<SomeIntExpr>(&folded.u)}) {
+            ok = ok || evaluate::IsActuallyConstant(*intExpr);
             paramValue->SetExplicit(std::move(*intExpr));
-            continue;
           }
-        }
-        if (!context.HasError(symbol)) {
+        } else if (!context.HasError(symbol)) {
           evaluate::SayWithDeclaration(messages, symbol,
-              "Value of type parameter '%s' (%s) is not convertible to its"
-              " type"_err_en_US,
-              name, expr->AsFortran());
+              "Value of type parameter '%s' (%s) is not convertible to its type (%s)"_err_en_US,
+              name, expr->AsFortran(), dyType.AsFortran());
         }
       }
-    }
-  }
-
-  // Default initialization expressions for the derived type's parameters
-  // may reference other parameters so long as the declaration precedes the
-  // use in the expression (10.1.12).  This is not necessarily the same
-  // order as "type parameter order" (7.5.3.2).
-  // Type parameter default value expressions are folded in declaration order
-  // within the scope of the derived type so that the values of earlier type
-  // parameters are available for use in the default initialization
-  // expressions of later parameters.
-  auto restorer{foldingContext.WithPDTInstance(*this)};
-  for (const Symbol &symbol : parameterDecls) {
-    const SourceName &name{symbol.name()};
-    if (!FindParameter(name)) {
+    } else {
+      // Default type parameter value expressions are folded within
+      // the scope of the derived type being instantiated.
       const TypeParamDetails &details{symbol.get<TypeParamDetails>()};
       if (details.init()) {
-        auto expr{evaluate::Fold(foldingContext, SomeExpr{*details.init()})};
-        AddParamValue(name,
-            ParamValue{
-                std::move(std::get<SomeIntExpr>(expr.u)), details.attr()});
+        evaluate::DynamicType dyType{TypeCategory::Integer, parameterKind};
+        if (auto converted{
+                evaluate::ConvertToType(dyType, SomeExpr{*details.init()})}) {
+          auto restorer{foldingContext.WithPDTInstance(*this)};
+          SomeExpr folded{
+              evaluate::Fold(foldingContext, std::move(*converted))};
+          ok = ok || evaluate::IsActuallyConstant(folded);
+          AddParamValue(name,
+              ParamValue{
+                  std::move(std::get<SomeIntExpr>(folded.u)), details.attr()});
+        } else {
+          if (!context.HasError(symbol)) {
+            evaluate::SayWithDeclaration(messages, symbol,
+                "Default value of type parameter '%s' (%s) is not convertible to its type (%s)"_err_en_US,
+                name, details.init()->AsFortran(), dyType.AsFortran());
+          }
+        }
       } else if (!context.HasError(symbol)) {
         messages.Say(name_,
             "Type parameter '%s' lacks a value and has no default"_err_en_US,
             name);
       }
     }
+    if (!ok && !context.HasError(symbol)) {
+      messages.Say(
+          "Value of KIND type parameter '%s' must be constant"_err_en_US, name);
+    }
   }
 }
 
@@ -335,20 +357,23 @@ void DerivedTypeSpec::Instantiate(Scope &containingScope) {
       if (ParamValue * paramValue{FindParameter(name)}) {
         const TypeParamDetails &details{symbol.get<TypeParamDetails>()};
         paramValue->set_attr(details.attr());
-        TypeParamDetails instanceDetails{details.attr()};
-        if (const DeclTypeSpec * type{details.type()}) {
-          instanceDetails.set_type(*type);
-        }
         desc += sep;
         desc += name.ToString();
         desc += '=';
         sep = ',';
+        TypeParamDetails instanceDetails{details.attr()};
         if (MaybeIntExpr expr{paramValue->GetExplicit()}) {
-          if (auto folded{evaluate::NonPointerInitializationExpr(symbol,
-                  SomeExpr{std::move(*expr)}, foldingContext, &newScope)}) {
-            desc += folded->AsFortran();
-            instanceDetails.set_init(
-                std::move(DEREF(evaluate::UnwrapExpr<SomeIntExpr>(*folded))));
+          desc += expr->AsFortran();
+          instanceDetails.set_init(
+              std::move(DEREF(evaluate::UnwrapExpr<SomeIntExpr>(*expr))));
+          if (auto dyType{expr->GetType()}) {
+            instanceDetails.set_type(newScope.MakeNumericType(
+                TypeCategory::Integer, KindExpr{dyType->kind()}));
+          }
+        }
+        if (!instanceDetails.type()) {
+          if (const DeclTypeSpec * type{details.type()}) {
+            instanceDetails.set_type(*type);
           }
         }
         if (!instanceDetails.init()) {

flang/test/Semantics/label18.f90#

@@ -0,0 +1,18 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
+program main
+  if (.true.) then
+    do j = 1, 2
+      goto 1 ! ok; used to cause looping in label resolution
+    end do
+  else
+    goto 1 ! ok
+1 end if
+  if (.true.) then
+    do j = 1, 2
+      !WARNING: Label '1' is in a construct that should not be used as a branch target here
+      goto 1
+    end do
+  end if
+  !WARNING: Label '1' is in a construct that should not be used as a branch target here
+  goto 1
+end

flang/test/Semantics/pdt02.f90

@@ -0,0 +1,15 @@
+! RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s
+program p
+  type t(k,n)
+    integer, kind :: k
+    integer(k), len :: n
+!CHECK: warning: INTEGER(1) addition overflowed
+    integer :: c = n + 1_1
+  end type
+!CHECK: in the context: instantiation of parameterized derived type 't(k=1_4,n=127_1)'
+  print *, t(1,127)()
+end
+
+!CHECK:  PRINT *, t(k=1_4,n=127_1)(c=-128_4)
+
+

flang/test/Semantics/resolve105.f90

@@ -43,6 +43,7 @@ subroutine testGoodDefault(arg)
   end subroutine testGoodDefault
 
   subroutine testStar(arg)
+    !ERROR: Value of KIND type parameter 'kindparam' must be constant
     type(dtype(*)),intent(inout) :: arg
     if (associated(arg%field)) stop 'fail'
   end subroutine testStar

flang/test/Semantics/resolve69.f90

@@ -52,7 +52,7 @@ function foo3()
   end type derived
 
   type (derived(constVal, 3)) :: constDerivedKind
-!ERROR: Value of kind type parameter 'typekind' (nonconstval) must be a scalar INTEGER constant
+!ERROR: Value of KIND type parameter 'typekind' must be constant
 !ERROR: Invalid specification expression: reference to local entity 'nonconstval'
   type (derived(nonConstVal, 3)) :: nonConstDerivedKind
 
@@ -63,6 +63,7 @@ function foo3()
   type (derived(3, nonConstVal)) :: nonConstDerivedLen
 !ERROR: 'colonderivedlen' has a type derived(typekind=3_4,typelen=:) with a deferred type parameter but is neither an allocatable nor an object pointer
   type (derived(3, :)) :: colonDerivedLen
+!ERROR: Value of KIND type parameter 'typekind' must be constant
 !ERROR: 'colonderivedlen1' has a type derived(typekind=:,typelen=:) with a deferred type parameter but is neither an allocatable nor an object pointer
   type (derived( :, :)) :: colonDerivedLen1
   type (derived( :, :)), pointer :: colonDerivedLen2

flang/test/Semantics/selecttype01.f90

@@ -200,6 +200,7 @@ subroutine foo(x)
     type is (pdt(kind=1, len=*))
     !ERROR: Type specification 'pdt(kind=2_4,len=*)' must be an extension of TYPE 'pdt(kind=1_4,len=:)'
     type is (pdt(kind=2, len=*))
+    !ERROR: Value of KIND type parameter 'kind' must be constant
     !ERROR: Type specification 'pdt(kind=*,len=*)' must be an extension of TYPE 'pdt(kind=1_4,len=:)'
     type is (pdt(kind=*, len=*))
     end select