diff --git a/flang/lib/Evaluate/fold-integer.cpp b/flang/lib/Evaluate/fold-integer.cpp index 8b39ee028b3c9..eea7b6ee7a952 100644 --- a/flang/lib/Evaluate/fold-integer.cpp +++ b/flang/lib/Evaluate/fold-integer.cpp @@ -658,43 +658,24 @@ Expr> FoldIntrinsicFunction( // Substitute a bare type parameter reference with its value if it has one now Expr FoldOperation( FoldingContext &context, TypeParamInquiry &&inquiry) { - std::optional base{inquiry.base()}; - parser::CharBlock parameterName{inquiry.parameter().name()}; - if (base) { - // Handling "designator%typeParam". Get the value of the type parameter - // from the instantiation of the base - if (const semantics::DeclTypeSpec * - declType{base->GetLastSymbol().GetType()}) { - const semantics::DerivedTypeSpec dType{declType->derivedTypeSpec()}; - if (const semantics::ParamValue * - paramValue{dType.FindParameter(parameterName)}) { - const semantics::MaybeIntExpr ¶mExpr{paramValue->GetExplicit()}; - if (paramExpr && IsConstantExpr(*paramExpr)) { - Expr intExpr{*paramExpr}; - return Fold(context, - ConvertToType(std::move(intExpr))); - } - } - } - } else { + if (!inquiry.base()) { // A "bare" type parameter: replace with its value, if that's now known. if (const auto *pdt{context.pdtInstance()}) { if (const semantics::Scope * scope{context.pdtInstance()->scope()}) { - auto iter{scope->find(parameterName)}; + auto iter{scope->find(inquiry.parameter().name())}; if (iter != scope->end()) { const Symbol &symbol{*iter->second}; const auto *details{symbol.detailsIf()}; - if (details) { - const semantics::MaybeIntExpr &initExpr{details->init()}; - if (initExpr && IsConstantExpr(*initExpr)) { - Expr expr{*initExpr}; - return Fold(context, - ConvertToType(std::move(expr))); - } + if (details && details->init() && + (details->attr() == common::TypeParamAttr::Kind || + IsConstantExpr(*details->init()))) { + Expr expr{*details->init()}; + return Fold(context, + ConvertToType(std::move(expr))); } } } - if (const auto *value{pdt->FindParameter(parameterName)}) { + if (const auto *value{pdt->FindParameter(inquiry.parameter().name())}) { if (value->isExplicit()) { return Fold(context, AsExpr(ConvertToType( diff --git a/flang/lib/Evaluate/formatting.cpp b/flang/lib/Evaluate/formatting.cpp index f7cfaa3e6dff3..df3671a919b59 100644 --- a/flang/lib/Evaluate/formatting.cpp +++ b/flang/lib/Evaluate/formatting.cpp @@ -614,7 +614,7 @@ llvm::raw_ostream &BaseObject::AsFortran(llvm::raw_ostream &o) const { llvm::raw_ostream &TypeParamInquiry::AsFortran(llvm::raw_ostream &o) const { if (base_) { - base_.value().AsFortran(o) << '%'; + return base_->AsFortran(o) << '%'; } return EmitVar(o, parameter_); } diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp index c548b5cbd1998..741b253322977 100644 --- a/flang/lib/Semantics/type.cpp +++ b/flang/lib/Semantics/type.cpp @@ -205,8 +205,7 @@ class InstantiateHelper { } void InstantiateComponent(const Symbol &); const DeclTypeSpec *InstantiateType(const Symbol &); - const DeclTypeSpec &InstantiateIntrinsicType( - SourceName, const DeclTypeSpec &); + const DeclTypeSpec &InstantiateIntrinsicType(const DeclTypeSpec &); DerivedTypeSpec CreateDerivedTypeSpec(const DerivedTypeSpec &, bool); SemanticsContext &context_; @@ -365,7 +364,7 @@ const DeclTypeSpec *InstantiateHelper::InstantiateType(const Symbol &symbol) { CreateDerivedTypeSpec(*spec, symbol.test(Symbol::Flag::ParentComp)), context_, type->category()); } else if (type->AsIntrinsic()) { - return &InstantiateIntrinsicType(symbol.name(), *type); + return &InstantiateIntrinsicType(*type); } else if (type->category() == DeclTypeSpec::ClassStar) { return type; } else { @@ -375,7 +374,7 @@ const DeclTypeSpec *InstantiateHelper::InstantiateType(const Symbol &symbol) { // Apply type parameter values to an intrinsic type spec. const DeclTypeSpec &InstantiateHelper::InstantiateIntrinsicType( - SourceName symbolName, const DeclTypeSpec &spec) { + const DeclTypeSpec &spec) { const IntrinsicTypeSpec &intrinsic{DEREF(spec.AsIntrinsic())}; if (evaluate::ToInt64(intrinsic.kind())) { return spec; // KIND is already a known constant @@ -388,7 +387,7 @@ const DeclTypeSpec &InstantiateHelper::InstantiateIntrinsicType( if (evaluate::IsValidKindOfIntrinsicType(intrinsic.category(), *value)) { kind = *value; } else { - foldingContext().messages().Say(symbolName, + foldingContext().messages().Say( "KIND parameter value (%jd) of intrinsic type %s " "did not resolve to a supported value"_err_en_US, *value, diff --git a/flang/test/Semantics/assign04.f90 b/flang/test/Semantics/assign04.f90 index 7cb30c49d7cd5..a88c3a5b69f47 100644 --- a/flang/test/Semantics/assign04.f90 +++ b/flang/test/Semantics/assign04.f90 @@ -8,7 +8,7 @@ subroutine s1 type(t(1, 2)) :: x !ERROR: Assignment to constant 'x%k' is not allowed x%k = 4 - !ERROR: Assignment to constant 'x%l' is not allowed + !ERROR: Left-hand side of assignment is not modifiable x%l = 3 end diff --git a/flang/test/Semantics/resolve104.f90 b/flang/test/Semantics/resolve104.f90 deleted file mode 100644 index 176c9d68d9e93..0000000000000 --- a/flang/test/Semantics/resolve104.f90 +++ /dev/null @@ -1,64 +0,0 @@ -! RUN: %S/test_errors.sh %s %t %f18 -! Test constant folding of type parameter values both a base value and a -! parameter name are supplied. -! -! Type parameters are described in 7.5.3 and constant expressions are described -! in 10.1.12. 10.1.12, paragraph 4 defines whether a specification inquiry is -! a constant expression. Section 10.1.11, paragraph 3, item (2) states that a -! type parameter inquiry is a specification inquiry. - -module m1 - type dtype(goodDefaultKind, badDefaultKind) - integer, kind :: goodDefaultKind = 4 - integer, kind :: badDefaultKind = 343 - ! next field OK only if instantiated with a good value of goodDefaultKind - !ERROR: KIND parameter value (99) of intrinsic type REAL did not resolve to a supported value - real(goodDefaultKind) :: goodDefaultField - ! next field OK only if instantiated with a good value of goodDefaultKind - !ERROR: KIND parameter value (343) of intrinsic type REAL did not resolve to a supported value - !ERROR: KIND parameter value (99) of intrinsic type REAL did not resolve to a supported value - real(badDefaultKind) :: badDefaultField - end type dtype - type(dtype) :: v1 - type(dtype(4, 4)) :: v2 - type(dtype(99, 4)) :: v3 - type(dtype(4, 99)) :: v4 -end module m1 - -module m2 - type baseType(baseParam) - integer, kind :: baseParam = 4 - end type baseType - type dtype(dtypeParam) - integer, kind :: dtypeParam = 4 - type(baseType(dtypeParam)) :: baseField - !ERROR: KIND parameter value (343) of intrinsic type REAL did not resolve to a supported value - real(baseField%baseParam) :: realField - end type dtype - - type(dtype) :: v1 - type(dtype(8)) :: v2 - type(dtype(343)) :: v3 -end module m2 - -module m3 - type dtype(goodDefaultLen, badDefaultLen) - integer, len :: goodDefaultLen = 4 - integer, len :: badDefaultLen = 343 - end type dtype - type(dtype) :: v1 - type(dtype(4, 4)) :: v2 - type(dtype(99, 4)) :: v3 - type(dtype(4, 99)) :: v4 - real(v1%goodDefaultLen), pointer :: pGood1 - !ERROR: REAL(KIND=343) is not a supported type - real(v1%badDefaultLen), pointer :: pBad1 - real(v2%goodDefaultLen), pointer :: pGood2 - real(v2%badDefaultLen), pointer :: pBad2 - !ERROR: REAL(KIND=99) is not a supported type - real(v3%goodDefaultLen), pointer :: pGood3 - real(v3%badDefaultLen), pointer :: pBad3 - real(v4%goodDefaultLen), pointer :: pGood4 - !ERROR: REAL(KIND=99) is not a supported type - real(v4%badDefaultLen), pointer :: pBad4 -end module m3 diff --git a/flang/test/Semantics/resolve89.f90 b/flang/test/Semantics/resolve89.f90 index eaa902bf54ebc..f3bf218fdce7b 100644 --- a/flang/test/Semantics/resolve89.f90 +++ b/flang/test/Semantics/resolve89.f90 @@ -107,7 +107,7 @@ subroutine inner (derivedArg) type localDerivedType ! OK because the specification inquiry is a constant integer, dimension(localDerived%kindParam) :: goodField - ! OK because the value of lenParam is constant in this context + !ERROR: Invalid specification expression: non-constant reference to a type parameter inquiry not allowed for derived type components or type parameter values integer, dimension(derivedArg%lenParam) :: badField end type localDerivedType