Skip to content

Commit c9da9c0

Browse files
klauslerklausler
committed
[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
1 parent 27d996e commit c9da9c0

File tree

11 files changed

+181
-79
lines changed

11 files changed

+181
-79
lines changed

‎flang/lib/Evaluate/fold-implementation.h

Lines changed: 9 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1132,12 +1132,17 @@ Expr<Type<TypeCategory::Logical, KIND>> FoldIntrinsicFunction(
11321132
template <typename T>
11331133
Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&funcRef) {
11341134
ActualArguments &args{funcRef.arguments()};
1135-
for (std::optional<ActualArgument> &arg : args) {
1136-
if (auto *expr{UnwrapExpr<Expr<SomeType>>(arg)}) {
1137-
*expr = Fold(context, std::move(*expr));
1135+
const auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};
1136+
if (!intrinsic || intrinsic->name != "kind") {
1137+
// Don't fold the argument to KIND(); it might be a TypeParamInquiry
1138+
// with a forced result type that doesn't match the parameter.
1139+
for (std::optional<ActualArgument> &arg : args) {
1140+
if (auto *expr{UnwrapExpr<Expr<SomeType>>(arg)}) {
1141+
*expr = Fold(context, std::move(*expr));
1142+
}
11381143
}
11391144
}
1140-
if (auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)}) {
1145+
if (intrinsic) {
11411146
const std::string name{intrinsic->name};
11421147
if (name == "cshift") {
11431148
return Folder<T>{context}.CSHIFT(std::move(funcRef));

‎flang/lib/Evaluate/fold-integer.cpp

Lines changed: 17 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -844,10 +844,23 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
844844
} else if (name == "int_ptr_kind") {
845845
return Expr<T>{8};
846846
} else if (name == "kind") {
847-
if constexpr (common::HasMember<T, IntegerTypes>) {
848-
return Expr<T>{args[0].value().GetType()->kind()};
849-
} else {
850-
DIE("kind() result not integral");
847+
// FoldOperation(FunctionRef &&) in fold-implementation.h will not
848+
// have folded the argument; in the case of TypeParamInquiry,
849+
// try to get the type of the parameter itself.
850+
if (const auto *expr{args[0] ? args[0]->UnwrapExpr() : nullptr}) {
851+
std::optional<DynamicType> dyType;
852+
if (const auto *inquiry{UnwrapExpr<TypeParamInquiry>(*expr)}) {
853+
if (const auto *typeSpec{inquiry->parameter().GetType()}) {
854+
if (const auto *intrinType{typeSpec->AsIntrinsic()}) {
855+
if (auto k{ToInt64(Fold(
856+
context, Expr<SubscriptInteger>{intrinType->kind()}))}) {
857+
return Expr<T>{*k};
858+
}
859+
}
860+
}
861+
} else if (auto dyType{expr->GetType()}) {
862+
return Expr<T>{dyType->kind()};
863+
}
851864
}
852865
} else if (name == "iparity") {
853866
return FoldBitReduction(

‎flang/lib/Semantics/expression.cpp

Lines changed: 23 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -924,10 +924,30 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Name &n) {
924924
} else {
925925
const Symbol &ultimate{n.symbol->GetUltimate()};
926926
if (ultimate.has<semantics::TypeParamDetails>()) {
927-
// A bare reference to a derived type parameter (within a parameterized
928-
// derived type definition)
927+
// A bare reference to a derived type parameter within a parameterized
928+
// derived type definition.
929+
auto dyType{DynamicType::From(ultimate)};
930+
if (!dyType) {
931+
// When the integer kind of this type parameter is not known now,
932+
// it's either an error or because it depends on earlier-declared kind
933+
// type parameters. So assume that it's a subscript integer for now
934+
// while processing other specification expressions in the PDT
935+
// definition; the right kind value will be used later in each of its
936+
// instantiations.
937+
int kind{SubscriptInteger::kind};
938+
if (const auto *typeSpec{ultimate.GetType()}) {
939+
if (const semantics::IntrinsicTypeSpec *
940+
intrinType{typeSpec->AsIntrinsic()}) {
941+
if (auto k{ToInt64(Fold(semantics::KindExpr{intrinType->kind()}))};
942+
k && IsValidKindOfIntrinsicType(TypeCategory::Integer, *k)) {
943+
kind = *k;
944+
}
945+
}
946+
}
947+
dyType = DynamicType{TypeCategory::Integer, kind};
948+
}
929949
return Fold(ConvertToType(
930-
ultimate, AsGenericExpr(TypeParamInquiry{std::nullopt, ultimate})));
950+
*dyType, AsGenericExpr(TypeParamInquiry{std::nullopt, ultimate})));
931951
} else {
932952
if (n.symbol->attrs().test(semantics::Attr::VOLATILE)) {
933953
if (const semantics::Scope *pure{semantics::FindPureProcedureContaining(

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

Lines changed: 26 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -428,16 +428,21 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
428428
(typeName.front() == '.' && !context_.IsTempName(typeName))) {
429429
return nullptr;
430430
}
431+
bool isPDTDefinitionWithKindParameters{
432+
!derivedTypeSpec && dtScope.IsDerivedTypeWithKindParameter()};
433+
bool isPDTInstantiation{derivedTypeSpec && &dtScope != dtSymbol->scope()};
431434
const SymbolVector *parameters{GetTypeParameters(*dtSymbol)};
432435
std::string distinctName{typeName};
433-
if (&dtScope != dtSymbol->scope() && derivedTypeSpec) {
436+
if (isPDTInstantiation) {
434437
// Only create new type descriptions for different kind parameter values.
435438
// Type with different length parameters/same kind parameters can all
436439
// share the same type description available in the current scope.
437440
if (auto suffix{
438441
GetSuffixIfTypeKindParameters(*derivedTypeSpec, parameters)}) {
439442
distinctName += *suffix;
440443
}
444+
} else if (isPDTDefinitionWithKindParameters) {
445+
return nullptr;
441446
}
442447
std::string dtDescName{".dt."s + distinctName};
443448
Scope *dtSymbolScope{const_cast<Scope *>(dtSymbol->scope())};
@@ -455,9 +460,7 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
455460
evaluate::StructureConstructorValues dtValues;
456461
AddValue(dtValues, derivedTypeSchema_, "name"s,
457462
SaveNameAsPointerTarget(scope, typeName));
458-
bool isPDTdefinitionWithKindParameters{
459-
!derivedTypeSpec && dtScope.IsDerivedTypeWithKindParameter()};
460-
if (!isPDTdefinitionWithKindParameters) {
463+
if (!isPDTDefinitionWithKindParameters) {
461464
auto sizeInBytes{static_cast<common::ConstantSubscript>(dtScope.size())};
462465
if (auto alignment{dtScope.alignment().value_or(0)}) {
463466
sizeInBytes += alignment - 1;
@@ -467,10 +470,10 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
467470
AddValue(
468471
dtValues, derivedTypeSchema_, "sizeinbytes"s, IntToExpr(sizeInBytes));
469472
}
470-
bool isPDTinstantiation{derivedTypeSpec && &dtScope != dtSymbol->scope()};
471-
if (isPDTinstantiation) {
472-
const Symbol *uninstDescObject{
473-
DescribeType(DEREF(const_cast<Scope *>(dtSymbol->scope())))};
473+
if (const Symbol *
474+
uninstDescObject{isPDTInstantiation
475+
? DescribeType(DEREF(const_cast<Scope *>(dtSymbol->scope())))
476+
: nullptr}) {
474477
AddValue(dtValues, derivedTypeSchema_, "uninstantiated"s,
475478
evaluate::AsGenericExpr(evaluate::Expr<evaluate::SomeDerived>{
476479
evaluate::Designator<evaluate::SomeDerived>{
@@ -489,22 +492,24 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
489492
// by their instantiated (or default) values, while LEN= type
490493
// parameters are described by their INTEGER kinds.
491494
for (SymbolRef ref : *parameters) {
492-
const auto &tpd{ref->get<TypeParamDetails>()};
493-
if (tpd.attr() == common::TypeParamAttr::Kind) {
494-
auto value{evaluate::ToInt64(tpd.init()).value_or(0)};
495-
if (derivedTypeSpec) {
496-
if (const auto *pv{derivedTypeSpec->FindParameter(ref->name())}) {
497-
if (pv->GetExplicit()) {
498-
if (auto instantiatedValue{
499-
evaluate::ToInt64(*pv->GetExplicit())}) {
500-
value = *instantiatedValue;
495+
if (const auto *inst{dtScope.FindComponent(ref->name())}) {
496+
const auto &tpd{inst->get<TypeParamDetails>()};
497+
if (tpd.attr() == common::TypeParamAttr::Kind) {
498+
auto value{evaluate::ToInt64(tpd.init()).value_or(0)};
499+
if (derivedTypeSpec) {
500+
if (const auto *pv{derivedTypeSpec->FindParameter(inst->name())}) {
501+
if (pv->GetExplicit()) {
502+
if (auto instantiatedValue{
503+
evaluate::ToInt64(*pv->GetExplicit())}) {
504+
value = *instantiatedValue;
505+
}
501506
}
502507
}
503508
}
509+
kinds.emplace_back(value);
510+
} else { // LEN= parameter
511+
lenKinds.emplace_back(GetIntegerKind(*inst));
504512
}
505-
kinds.emplace_back(value);
506-
} else { // LEN= parameter
507-
lenKinds.emplace_back(GetIntegerKind(*ref));
508513
}
509514
}
510515
}
@@ -515,7 +520,7 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
515520
SaveNumericPointerTarget<Int1>(
516521
scope, SaveObjectName(".lpk."s + distinctName), std::move(lenKinds)));
517522
// Traverse the components of the derived type
518-
if (!isPDTdefinitionWithKindParameters) {
523+
if (!isPDTDefinitionWithKindParameters) {
519524
std::vector<const Symbol *> dataComponentSymbols;
520525
std::vector<evaluate::StructureConstructor> procPtrComponents;
521526
for (const auto &pair : dtScope) {

‎flang/lib/Semantics/type.cpp

Lines changed: 68 additions & 43 deletions
Original file line numberDiff line numberDiff line change
@@ -110,58 +110,80 @@ void DerivedTypeSpec::EvaluateParameters(SemanticsContext &context) {
110110
}
111111
evaluated_ = true;
112112
auto &messages{foldingContext.messages()};
113-
114-
// Fold the explicit type parameter value expressions first. Do not
115-
// fold them within the scope of the derived type being instantiated;
116-
// these expressions cannot use its type parameters. Convert the values
117-
// of the expressions to the declared types of the type parameters.
118-
auto parameterDecls{OrderParameterDeclarations(typeSymbol_)};
119-
for (const Symbol &symbol : parameterDecls) {
120-
const SourceName &name{symbol.name()};
113+
for (const Symbol &symbol : OrderParameterDeclarations(typeSymbol_)) {
114+
SourceName name{symbol.name()};
115+
int parameterKind{evaluate::TypeParamInquiry::Result::kind};
116+
// Compute the integer kind value of the type parameter,
117+
// which may depend on the values of earlier ones.
118+
if (const auto *typeSpec{symbol.GetType()}) {
119+
if (const IntrinsicTypeSpec * intrinType{typeSpec->AsIntrinsic()};
120+
intrinType && intrinType->category() == TypeCategory::Integer) {
121+
auto restorer{foldingContext.WithPDTInstance(*this)};
122+
auto folded{Fold(foldingContext, KindExpr{intrinType->kind()})};
123+
if (auto k{evaluate::ToInt64(folded)}; k &&
124+
evaluate::IsValidKindOfIntrinsicType(TypeCategory::Integer, *k)) {
125+
parameterKind = static_cast<int>(*k);
126+
} else {
127+
messages.Say(
128+
"Type of type parameter '%s' (%s) is not a valid kind of INTEGER"_err_en_US,
129+
name, intrinType->kind().AsFortran());
130+
}
131+
}
132+
}
133+
bool ok{
134+
symbol.get<TypeParamDetails>().attr() == common::TypeParamAttr::Len};
121135
if (ParamValue * paramValue{FindParameter(name)}) {
136+
// Explicit type parameter value expressions are not folded within
137+
// the scope of the derived type being instantiated, as the expressions
138+
// themselves are not in that scope and cannot reference its type
139+
// parameters.
122140
if (const MaybeIntExpr & expr{paramValue->GetExplicit()}) {
123-
if (auto converted{evaluate::ConvertToType(symbol, SomeExpr{*expr})}) {
141+
evaluate::DynamicType dyType{TypeCategory::Integer, parameterKind};
142+
if (auto converted{evaluate::ConvertToType(dyType, SomeExpr{*expr})}) {
124143
SomeExpr folded{
125144
evaluate::Fold(foldingContext, std::move(*converted))};
126145
if (auto *intExpr{std::get_if<SomeIntExpr>(&folded.u)}) {
146+
ok = ok || evaluate::IsActuallyConstant(*intExpr);
127147
paramValue->SetExplicit(std::move(*intExpr));
128-
continue;
129148
}
130-
}
131-
if (!context.HasError(symbol)) {
149+
} else if (!context.HasError(symbol)) {
132150
evaluate::SayWithDeclaration(messages, symbol,
133-
"Value of type parameter '%s' (%s) is not convertible to its"
134-
" type"_err_en_US,
135-
name, expr->AsFortran());
151+
"Value of type parameter '%s' (%s) is not convertible to its type (%s)"_err_en_US,
152+
name, expr->AsFortran(), dyType.AsFortran());
136153
}
137154
}
138-
}
139-
}
140-
141-
// Default initialization expressions for the derived type's parameters
142-
// may reference other parameters so long as the declaration precedes the
143-
// use in the expression (10.1.12). This is not necessarily the same
144-
// order as "type parameter order" (7.5.3.2).
145-
// Type parameter default value expressions are folded in declaration order
146-
// within the scope of the derived type so that the values of earlier type
147-
// parameters are available for use in the default initialization
148-
// expressions of later parameters.
149-
auto restorer{foldingContext.WithPDTInstance(*this)};
150-
for (const Symbol &symbol : parameterDecls) {
151-
const SourceName &name{symbol.name()};
152-
if (!FindParameter(name)) {
155+
} else {
156+
// Default type parameter value expressions are folded within
157+
// the scope of the derived type being instantiated.
153158
const TypeParamDetails &details{symbol.get<TypeParamDetails>()};
154159
if (details.init()) {
155-
auto expr{evaluate::Fold(foldingContext, SomeExpr{*details.init()})};
156-
AddParamValue(name,
157-
ParamValue{
158-
std::move(std::get<SomeIntExpr>(expr.u)), details.attr()});
160+
evaluate::DynamicType dyType{TypeCategory::Integer, parameterKind};
161+
if (auto converted{
162+
evaluate::ConvertToType(dyType, SomeExpr{*details.init()})}) {
163+
auto restorer{foldingContext.WithPDTInstance(*this)};
164+
SomeExpr folded{
165+
evaluate::Fold(foldingContext, std::move(*converted))};
166+
ok = ok || evaluate::IsActuallyConstant(folded);
167+
AddParamValue(name,
168+
ParamValue{
169+
std::move(std::get<SomeIntExpr>(folded.u)), details.attr()});
170+
} else {
171+
if (!context.HasError(symbol)) {
172+
evaluate::SayWithDeclaration(messages, symbol,
173+
"Default value of type parameter '%s' (%s) is not convertible to its type (%s)"_err_en_US,
174+
name, details.init()->AsFortran(), dyType.AsFortran());
175+
}
176+
}
159177
} else if (!context.HasError(symbol)) {
160178
messages.Say(name_,
161179
"Type parameter '%s' lacks a value and has no default"_err_en_US,
162180
name);
163181
}
164182
}
183+
if (!ok && !context.HasError(symbol)) {
184+
messages.Say(
185+
"Value of KIND type parameter '%s' must be constant"_err_en_US, name);
186+
}
165187
}
166188
}
167189

@@ -335,20 +357,23 @@ void DerivedTypeSpec::Instantiate(Scope &containingScope) {
335357
if (ParamValue * paramValue{FindParameter(name)}) {
336358
const TypeParamDetails &details{symbol.get<TypeParamDetails>()};
337359
paramValue->set_attr(details.attr());
338-
TypeParamDetails instanceDetails{details.attr()};
339-
if (const DeclTypeSpec * type{details.type()}) {
340-
instanceDetails.set_type(*type);
341-
}
342360
desc += sep;
343361
desc += name.ToString();
344362
desc += '=';
345363
sep = ',';
364+
TypeParamDetails instanceDetails{details.attr()};
346365
if (MaybeIntExpr expr{paramValue->GetExplicit()}) {
347-
if (auto folded{evaluate::NonPointerInitializationExpr(symbol,
348-
SomeExpr{std::move(*expr)}, foldingContext, &newScope)}) {
349-
desc += folded->AsFortran();
350-
instanceDetails.set_init(
351-
std::move(DEREF(evaluate::UnwrapExpr<SomeIntExpr>(*folded))));
366+
desc += expr->AsFortran();
367+
instanceDetails.set_init(
368+
std::move(DEREF(evaluate::UnwrapExpr<SomeIntExpr>(*expr))));
369+
if (auto dyType{expr->GetType()}) {
370+
instanceDetails.set_type(newScope.MakeNumericType(
371+
TypeCategory::Integer, KindExpr{dyType->kind()}));
372+
}
373+
}
374+
if (!instanceDetails.type()) {
375+
if (const DeclTypeSpec * type{details.type()}) {
376+
instanceDetails.set_type(*type);
352377
}
353378
}
354379
if (!instanceDetails.init()) {

‎flang/test/Semantics/label18.f90#

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,18 @@
1+
! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
2+
program main
3+
if (.true.) then
4+
do j = 1, 2
5+
goto 1 ! ok; used to cause looping in label resolution
6+
end do
7+
else
8+
goto 1 ! ok
9+
1 end if
10+
if (.true.) then
11+
do j = 1, 2
12+
!WARNING: Label '1' is in a construct that should not be used as a branch target here
13+
goto 1
14+
end do
15+
end if
16+
!WARNING: Label '1' is in a construct that should not be used as a branch target here
17+
goto 1
18+
end

‎flang/test/Semantics/pdt02.f90

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
! RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s
2+
program p
3+
type t(k,n)
4+
integer, kind :: k
5+
integer(k), len :: n
6+
!CHECK: warning: INTEGER(1) addition overflowed
7+
integer :: c = n + 1_1
8+
end type
9+
!CHECK: in the context: instantiation of parameterized derived type 't(k=1_4,n=127_1)'
10+
print *, t(1,127)()
11+
end
12+
13+
!CHECK: PRINT *, t(k=1_4,n=127_1)(c=-128_4)
14+
15+

‎flang/test/Semantics/resolve105.f90

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -43,6 +43,7 @@ subroutine testGoodDefault(arg)
4343
end subroutine testGoodDefault
4444

4545
subroutine testStar(arg)
46+
!ERROR: Value of KIND type parameter 'kindparam' must be constant
4647
type(dtype(*)),intent(inout) :: arg
4748
if (associated(arg%field)) stop 'fail'
4849
end subroutine testStar

‎flang/test/Semantics/resolve69.f90

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -52,7 +52,7 @@ function foo3()
5252
end type derived
5353

5454
type (derived(constVal, 3)) :: constDerivedKind
55-
!ERROR: Value of kind type parameter 'typekind' (nonconstval) must be a scalar INTEGER constant
55+
!ERROR: Value of KIND type parameter 'typekind' must be constant
5656
!ERROR: Invalid specification expression: reference to local entity 'nonconstval'
5757
type (derived(nonConstVal, 3)) :: nonConstDerivedKind
5858

@@ -63,6 +63,7 @@ function foo3()
6363
type (derived(3, nonConstVal)) :: nonConstDerivedLen
6464
!ERROR: 'colonderivedlen' has a type derived(typekind=3_4,typelen=:) with a deferred type parameter but is neither an allocatable nor an object pointer
6565
type (derived(3, :)) :: colonDerivedLen
66+
!ERROR: Value of KIND type parameter 'typekind' must be constant
6667
!ERROR: 'colonderivedlen1' has a type derived(typekind=:,typelen=:) with a deferred type parameter but is neither an allocatable nor an object pointer
6768
type (derived( :, :)) :: colonDerivedLen1
6869
type (derived( :, :)), pointer :: colonDerivedLen2

‎flang/test/Semantics/selecttype01.f90

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -200,6 +200,7 @@ subroutine foo(x)
200200
type is (pdt(kind=1, len=*))
201201
!ERROR: Type specification 'pdt(kind=2_4,len=*)' must be an extension of TYPE 'pdt(kind=1_4,len=:)'
202202
type is (pdt(kind=2, len=*))
203+
!ERROR: Value of KIND type parameter 'kind' must be constant
203204
!ERROR: Type specification 'pdt(kind=*,len=*)' must be an extension of TYPE 'pdt(kind=1_4,len=:)'
204205
type is (pdt(kind=*, len=*))
205206
end select

0 commit comments

Comments
 (0)