Index: flang/lib/Semantics/expression.cpp =================================================================== --- flang/lib/Semantics/expression.cpp +++ flang/lib/Semantics/expression.cpp @@ -924,10 +924,30 @@ } else { const Symbol &ultimate{n.symbol->GetUltimate()}; if (ultimate.has()) { - // 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( Index: flang/lib/Semantics/runtime-type-info.cpp =================================================================== --- flang/lib/Semantics/runtime-type-info.cpp +++ flang/lib/Semantics/runtime-type-info.cpp @@ -428,9 +428,12 @@ (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. @@ -438,6 +441,8 @@ GetSuffixIfTypeKindParameters(*derivedTypeSpec, parameters)}) { distinctName += *suffix; } + } else if (isPDTDefinitionWithKindParameters) { + return nullptr; } std::string dtDescName{".dt."s + distinctName}; Scope *dtSymbolScope{const_cast(dtSymbol->scope())}; @@ -455,9 +460,7 @@ evaluate::StructureConstructorValues dtValues; AddValue(dtValues, derivedTypeSchema_, "name"s, SaveNameAsPointerTarget(scope, typeName)); - bool isPDTdefinitionWithKindParameters{ - !derivedTypeSpec && dtScope.IsDerivedTypeWithKindParameter()}; - if (!isPDTdefinitionWithKindParameters) { + if (!isPDTDefinitionWithKindParameters) { auto sizeInBytes{static_cast(dtScope.size())}; if (auto alignment{dtScope.alignment().value_or(0)}) { sizeInBytes += alignment - 1; @@ -467,10 +470,10 @@ AddValue( dtValues, derivedTypeSchema_, "sizeinbytes"s, IntToExpr(sizeInBytes)); } - bool isPDTinstantiation{derivedTypeSpec && &dtScope != dtSymbol->scope()}; - if (isPDTinstantiation) { - const Symbol *uninstDescObject{ - DescribeType(DEREF(const_cast(dtSymbol->scope())))}; + if (const Symbol * + uninstDescObject{isPDTInstantiation + ? DescribeType(DEREF(const_cast(dtSymbol->scope()))) + : nullptr}) { AddValue(dtValues, derivedTypeSchema_, "uninstantiated"s, evaluate::AsGenericExpr(evaluate::Expr{ evaluate::Designator{ @@ -489,22 +492,24 @@ // 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()}; - 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()}; + 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 @@ SaveNumericPointerTarget( scope, SaveObjectName(".lpk."s + distinctName), std::move(lenKinds))); // Traverse the components of the derived type - if (!isPDTdefinitionWithKindParameters) { + if (!isPDTDefinitionWithKindParameters) { std::vector dataComponentSymbols; std::vector procPtrComponents; for (const auto &pair : dtScope) { Index: flang/lib/Semantics/type.cpp =================================================================== --- flang/lib/Semantics/type.cpp +++ flang/lib/Semantics/type.cpp @@ -110,58 +110,81 @@ } 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(*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().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(&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()}; if (details.init()) { - auto expr{evaluate::Fold(foldingContext, SomeExpr{*details.init()})}; - AddParamValue(name, - ParamValue{ - std::move(std::get(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(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 +358,23 @@ if (ParamValue * paramValue{FindParameter(name)}) { const TypeParamDetails &details{symbol.get()}; 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(*folded)))); + desc += expr->AsFortran(); + instanceDetails.set_init( + std::move(DEREF(evaluate::UnwrapExpr(*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()) { Index: flang/test/Semantics/label18.f90# =================================================================== --- /dev/null +++ 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 Index: flang/test/Semantics/pdt02.f90 =================================================================== --- /dev/null +++ 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) + + Index: flang/test/Semantics/resolve105.f90 =================================================================== --- flang/test/Semantics/resolve105.f90 +++ flang/test/Semantics/resolve105.f90 @@ -43,6 +43,7 @@ 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 Index: flang/test/Semantics/resolve69.f90 =================================================================== --- flang/test/Semantics/resolve69.f90 +++ flang/test/Semantics/resolve69.f90 @@ -52,7 +52,7 @@ 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 @@ 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 Index: flang/test/Semantics/selecttype01.f90 =================================================================== --- flang/test/Semantics/selecttype01.f90 +++ flang/test/Semantics/selecttype01.f90 @@ -200,6 +200,7 @@ 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 Index: flang/test/Semantics/typeinfo01.f90 =================================================================== --- flang/test/Semantics/typeinfo01.f90 +++ flang/test/Semantics/typeinfo01.f90 @@ -34,9 +34,7 @@ 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