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

[klausler]

Summary

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

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/lib/Semantics/expression.cpp

if (std::optional<int> kind{IsImpliedDo(n.source)}) {
     return AsMaybeExpr(ConvertToKind<TypeCategory::Integer>(
         *kind, AsExpr(ImpliedDoIndex{n.source})));
   }
   if (context_.HasError(n.symbol)) { // includes case of no symbol
     return std::nullopt;
   } 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(
                 context_.FindScope(n.source))}) {
           SayAt(n,
               "VOLATILE variable '%s' may not be referenced in pure subprogram '%s'"_err_en_US,
               n.source, DEREF(pure->symbol()).name());
           n.symbol->attrs().reset(semantics::Attr::VOLATILE);

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

const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
   }
   auto locationRestorer{common::ScopedSet(location_, dtSymbol->name())};
   // Check for an existing description that can be imported from a USE'd module
   std::string typeName{dtSymbol->name().ToString()};
   if (typeName.empty() ||
       (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())};
   Scope &scope{
       GetContainingNonDerivedScope(dtSymbolScope ? *dtSymbolScope : dtScope)};
   if (const auto it{scope.find(SourceName{dtDescName})}; it != scope.end()) {
     dtScope.set_runtimeDerivedTypeDescription(*it->second);
     return &*it->second;
   }
 
   // Create a new description object before populating it so that mutual
   // references will work as pointer targets.
   Symbol &dtObject{CreateObject(dtDescName, derivedTypeSchema_, scope)};
   dtScope.set_runtimeDerivedTypeDescription(dtObject);
   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;
       sizeInBytes /= alignment;
       sizeInBytes *= alignment;
     }
     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>{
                 DEREF(uninstDescObject)}}));
   } else {
     AddValue(dtValues, derivedTypeSchema_, "uninstantiated"s,
         SomeExpr{evaluate::NullPointer{}});
   }
   using Int8 = evaluate::Type<TypeCategory::Integer, 8>;
   using Int1 = evaluate::Type<TypeCategory::Integer, 1>;
   std::vector<Int8::Scalar> kinds;
   std::vector<Int1::Scalar> lenKinds;
   if (parameters) {
     // Package the derived type's parameters in declaration order for
     // each category of parameter.  KIND= type parameters are described
     // 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 (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(ref->name())}) {
+            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(*ref));
+          lenKinds.emplace_back(GetIntegerKind(*inst));
+        }
       }
     }
   }
   AddValue(dtValues, derivedTypeSchema_, "kindparameter"s,
       SaveNumericPointerTarget<Int8>(
           scope, SaveObjectName(".kp."s + distinctName), std::move(kinds)));
   AddValue(dtValues, derivedTypeSchema_, "lenparameterkind"s,
       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) {
       const Symbol &symbol{*pair.second};
       auto locationRestorer{common::ScopedSet(location_, symbol.name())};
       common::visit(
           common::visitors{
               [&](const TypeParamDetails &) {

flang/lib/Semantics/type.cpp

 void DerivedTypeSpec::EvaluateParameters(SemanticsContext &context) {
   evaluate::FoldingContext &foldingContext{context.foldingContext()};
   CookParameters(foldingContext);
   if (evaluated_) {
     return;
   }
   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)};
+        if (auto k{evaluate::ToInt64(
+                Fold(foldingContext, KindExpr{intrinType->kind()}))};
+            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()})};
+        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>(expr.u)), details.attr()});
+                  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);
+    }
   }
 }
 
 void DerivedTypeSpec::AddParamValue(SourceName name, ParamValue &&value) {
   CHECK(cooked_);
   auto pair{parameters_.insert(std::make_pair(name, std::move(value)))};
   CHECK(pair.second); // name was not already present
 }
if (typeScope.find(symbol.name()) != typeScope.end()) {
       // This type parameter belongs to the derived type itself, not to
       // one of its ancestors.  Put the type parameter expression value,
       // when there is one, into the new scope as the initialization value
       // for the parameter.  And when there is no explicit value, add an
       // uninitialized type parameter to forestall use of any default.
       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();
+              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()) {
           desc += '*';
         }
         newScope.try_emplace(name, std::move(instanceDetails));
       }
     }

flang/test/Semantics/label18.f90#

+! 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

+! 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

program test
   end type child
 contains
   subroutine testGoodDefault(arg)
     type(dtype) :: arg
     if (associated(arg%field)) stop 'fail'
   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
 
   subroutine testBadDeclaration(arg)
     type(dtype(66)) :: arg
     if (associated(arg%field)) stop 'fail'
   end subroutine testBadDeclaration

flang/test/Semantics/resolve69.f90

!ERROR: Must have INTEGER type, but is REAL(4)
   type derived(typeKind, typeLen)
     integer, kind :: typeKind
     integer, len :: typeLen
     character(typeKind) :: kindValue
     character(typeLen) :: lenValue
   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
 
   !OK because all type-params are constants
   type (derived(3, constVal)) :: constDerivedLen
 
 !ERROR: Invalid specification expression: reference to local entity 'nonconstval'
   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
   type (derived(4, :)), pointer :: colonDerivedLen3
 end subroutine s1
 
 !C702
 !ERROR: 'f1' has a type CHARACTER(KIND=1,LEN=:) with a deferred type parameter but is neither an allocatable nor an object pointer

flang/test/Semantics/selecttype01.f90

module c1162a
   end type
  contains
   subroutine foo(x)
     class(pdt(kind=1,len=:)), allocatable :: x
     select type (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
   end subroutine
 end module
 
 subroutine CheckC1163
   use m1

flang/test/Semantics/typeinfo01.f90

 
 module m03
   type :: kpdt(k)
     integer(kind=1), kind :: k = 1
     real(kind=k) :: a
   end type
   type(kpdt(4)) :: x
 !CHECK: .c.kpdt.4, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(component) shape: 0_8:0_8 init:[component::component(name=.n.a,genre=1_1,category=1_1,kind=4_1,rank=0_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL())]
-!CHECK: .dt.kpdt, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(name=.n.kpdt,uninstantiated=NULL(),kindparameter=.kp.kpdt,lenparameterkind=NULL())
-!CHECK: .dt.kpdt.4, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.kpdt,sizeinbytes=4_8,uninstantiated=.dt.kpdt,kindparameter=.kp.kpdt.4,lenparameterkind=NULL(),component=.c.kpdt.4,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
-!CHECK: .kp.kpdt, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: INTEGER(8) shape: 0_8:0_8 init:[INTEGER(8)::1_8]
+!CHECK: .dt.kpdt.4, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.kpdt,sizeinbytes=4_8,uninstantiated=NULL(),kindparameter=.kp.kpdt.4,lenparameterkind=NULL(),component=.c.kpdt.4,procptr=NULL(),special=NULL(),specialbitset=0_4,hasparent=0_1,noinitializationneeded=1_1,nodestructionneeded=1_1,nofinalizationneeded=1_1)
 !CHECK: .kp.kpdt.4, SAVE, TARGET (CompilerCreated, ReadOnly): ObjectEntity type: INTEGER(8) shape: 0_8:0_8 init:[INTEGER(8)::4_8]
 end module
 
 module m04
   type :: tbps
    contains
     procedure :: b2 => s1
     procedure :: b1 => s1