diff --git a/flang/include/flang/Evaluate/common.h b/flang/include/flang/Evaluate/common.h index fb800c6ceb686..0263f15d4215e 100644 --- a/flang/include/flang/Evaluate/common.h +++ b/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 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 moduleFileName_; std::map impliedDos_; const common::LanguageFeatureControl &languageFeatures_; diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h index 30f5dfd8a44cd..95c97f264a667 100644 --- a/flang/include/flang/Semantics/expression.h +++ b/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 diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h index 975423b32da73..18109dd6450f6 100644 --- a/flang/include/flang/Semantics/symbol.h +++ b/flang/include/flang/Semantics/symbol.h @@ -510,6 +510,11 @@ class DerivedTypeDetails { const std::list &componentNames() const { return componentNames_; } + const std::map & + 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 originalKindParameterMap_; + friend llvm::raw_ostream &operator<<( llvm::raw_ostream &, const DerivedTypeDetails &); }; diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp index fe679da4ff98b..f204eef54ef84 100644 --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -2515,7 +2515,8 @@ std::optional 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 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); diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index b7c7603d667d8..0da3133102914 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/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 &kind) { + if (inPDTDefinition_) { + if (category != TypeCategory::Derived && kind) { + if (const auto *expr{ + std::get_if(&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(*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 ¶mNames{std::get>(x.t)}; + if (!paramNames.empty()) { + set_inPDTDefinition(true); + } if (auto *details{symbol.detailsIf()}) { - for (const auto &name : std::get>(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().add_component(symbol); + auto &details{currScope().symbol()->get()}; + details.add_component(symbol); + if (const parser::Expr *kindExpr{GetOriginalKindParameter()}) { + details.add_originalKindParameter(name.source, kindExpr); + } } ClearArraySpec(); ClearCoarraySpec(); diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp index 6152f61fafd7f..69169469fe8ce 100644 --- a/flang/lib/Semantics/symbol.cpp +++ b/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()) { diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp index 69e6ffa47d09e..7baa1d6c4a4d5 100644 --- a/flang/lib/Semantics/type.cpp +++ b/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 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,43 @@ 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().detailsIf()}) { + 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; + 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(*analyzed)}) { + kindExpr = evaluate::ConvertToType( + 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 +613,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, diff --git a/flang/test/Semantics/kinds03.f90 b/flang/test/Semantics/kinds03.f90 index a15a4a9baa731..ed915bd14954d 100644 --- a/flang/test/Semantics/kinds03.f90 +++ b/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 diff --git a/flang/test/Semantics/pdt05.f90 b/flang/test/Semantics/pdt05.f90 new file mode 100644 index 0000000000000..6a5d56ee94e39 --- /dev/null +++ b/flang/test/Semantics/pdt05.f90 @@ -0,0 +1,20 @@ +!RUN: %flang_fc1 -fdebug-unparse %s | FileCheck %s + +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 +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 diff --git a/flang/test/Semantics/real10-x86-01.f90 b/flang/test/Semantics/real10-x86-01.f90 index ccaf34d8332a1..4215de3a8a9ee 100644 --- a/flang/test/Semantics/real10-x86-01.f90 +++ b/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 diff --git a/flang/test/Semantics/symbol17.f90 b/flang/test/Semantics/symbol17.f90 index a0d916e55cfa4..f5f722290c901 100644 --- a/flang/test/Semantics/symbol17.f90 +++ b/flang/test/Semantics/symbol17.f90 @@ -79,7 +79,7 @@ type(fwdpdt(kind(0))) function f2(n) type :: fwdpdt(k) !REF: /f2/fwdpdt/k integer, kind :: k - !REF: /f2/fwdpdt/k + !DEF: /f2/DerivedType2/k TypeParam INTEGER(4) !DEF: /f2/fwdpdt/n ObjectEntity INTEGER(int(int(k,kind=4),kind=8)) integer(kind=k) :: n end type @@ -99,7 +99,7 @@ subroutine s2 (q1) type :: fwdpdt(k) !REF: /s2/fwdpdt/k integer, kind :: k - !REF: /s2/fwdpdt/k + !DEF: /s2/DerivedType2/k TypeParam INTEGER(4) !DEF: /s2/fwdpdt/n ObjectEntity INTEGER(int(int(k,kind=4),kind=8)) integer(kind=k) :: n end type @@ -110,31 +110,31 @@ subroutine s2 (q1) !DEF: /m1 Module module m1 !DEF: /m1/forward PRIVATE DerivedType - private :: forward + private :: forward !DEF: /m1/base PUBLIC DerivedType - type :: base + type :: base !REF: /m1/forward !DEF: /m1/base/p POINTER ObjectEntity CLASS(forward) - class(forward), pointer :: p - end type + class(forward), pointer :: p + end type !REF: /m1/base !REF: /m1/forward - type, extends(base) :: forward + type, extends(base) :: forward !DEF: /m1/forward/n ObjectEntity INTEGER(4) - integer :: n - end type - contains + integer :: n + end type +contains !DEF: /m1/test PUBLIC (Subroutine) Subprogram - subroutine test + subroutine test !REF: /m1/forward !DEF: /m1/test/object TARGET ObjectEntity TYPE(forward) - type(forward), target :: object + type(forward), target :: object !REF: /m1/test/object !REF: /m1/base/p - object%p => object + object%p => object !REF: /m1/test/object !REF: /m1/base/p !REF: /m1/forward/n - object%p%n = 666 - end subroutine + object%p%n = 666 + end subroutine end module diff --git a/flang/test/Semantics/type-parameter-constant.f90 b/flang/test/Semantics/type-parameter-constant.f90 index 376bffd0233ff..681012c094e9f 100644 --- a/flang/test/Semantics/type-parameter-constant.f90 +++ b/flang/test/Semantics/type-parameter-constant.f90 @@ -10,6 +10,6 @@ !ERROR: Value of KIND type parameter 'r' must be constant !WARNING: specification expression refers to local object 'six' (initialized and saved) [-Wsaved-local-in-spec-expr] !WARNING: specification expression refers to local object 'twenty_three' (initialized and saved) [-Wsaved-local-in-spec-expr] - type(a(six, twenty_three)) :: a2 + type(a(six, twenty_three)) :: a2 print *, a1%data%kind -end \ No newline at end of file +end