diff --git a/flang/lib/Evaluate/fold-integer.cpp b/flang/lib/Evaluate/fold-integer.cpp --- a/flang/lib/Evaluate/fold-integer.cpp +++ b/flang/lib/Evaluate/fold-integer.cpp @@ -658,24 +658,43 @@ // Substitute a bare type parameter reference with its value if it has one now Expr FoldOperation( FoldingContext &context, TypeParamInquiry &&inquiry) { - if (!inquiry.base()) { + 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()}) { + if (const semantics::ParamValue * + paramValue{ + declType->derivedTypeSpec().FindParameter(parameterName)}) { + const semantics::MaybeIntExpr ¶mExpr{paramValue->GetExplicit()}; + if (paramExpr && IsConstantExpr(*paramExpr)) { + Expr intExpr{*paramExpr}; + return Fold(context, + ConvertToType(std::move(intExpr))); + } + } + } + } else { // 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(inquiry.parameter().name())}; + auto iter{scope->find(parameterName)}; if (iter != scope->end()) { const Symbol &symbol{*iter->second}; const auto *details{symbol.detailsIf()}; - if (details && details->init() && - (details->attr() == common::TypeParamAttr::Kind || - IsConstantExpr(*details->init()))) { - Expr expr{*details->init()}; - return Fold(context, - ConvertToType(std::move(expr))); + if (details) { + const semantics::MaybeIntExpr &initExpr{details->init()}; + if (initExpr && IsConstantExpr(*initExpr)) { + Expr expr{*initExpr}; + return Fold(context, + ConvertToType(std::move(expr))); + } } } } - if (const auto *value{pdt->FindParameter(inquiry.parameter().name())}) { + if (const auto *value{pdt->FindParameter(parameterName)}) { if (value->isExplicit()) { return Fold(context, AsExpr(ConvertToType( diff --git a/flang/lib/Evaluate/formatting.cpp b/flang/lib/Evaluate/formatting.cpp --- a/flang/lib/Evaluate/formatting.cpp +++ b/flang/lib/Evaluate/formatting.cpp @@ -614,7 +614,7 @@ llvm::raw_ostream &TypeParamInquiry::AsFortran(llvm::raw_ostream &o) const { if (base_) { - return base_->AsFortran(o) << '%'; + base_.value().AsFortran(o) << '%'; } return EmitVar(o, parameter_); } diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp --- a/flang/lib/Semantics/type.cpp +++ b/flang/lib/Semantics/type.cpp @@ -205,7 +205,8 @@ } void InstantiateComponent(const Symbol &); const DeclTypeSpec *InstantiateType(const Symbol &); - const DeclTypeSpec &InstantiateIntrinsicType(const DeclTypeSpec &); + const DeclTypeSpec &InstantiateIntrinsicType( + SourceName, const DeclTypeSpec &); DerivedTypeSpec CreateDerivedTypeSpec(const DerivedTypeSpec &, bool); SemanticsContext &context_; @@ -364,7 +365,7 @@ CreateDerivedTypeSpec(*spec, symbol.test(Symbol::Flag::ParentComp)), context_, type->category()); } else if (type->AsIntrinsic()) { - return &InstantiateIntrinsicType(*type); + return &InstantiateIntrinsicType(symbol.name(), *type); } else if (type->category() == DeclTypeSpec::ClassStar) { return type; } else { @@ -374,7 +375,7 @@ // Apply type parameter values to an intrinsic type spec. const DeclTypeSpec &InstantiateHelper::InstantiateIntrinsicType( - const DeclTypeSpec &spec) { + SourceName symbolName, const DeclTypeSpec &spec) { const IntrinsicTypeSpec &intrinsic{DEREF(spec.AsIntrinsic())}; if (evaluate::ToInt64(intrinsic.kind())) { return spec; // KIND is already a known constant @@ -387,7 +388,7 @@ if (evaluate::IsValidKindOfIntrinsicType(intrinsic.category(), *value)) { kind = *value; } else { - foldingContext().messages().Say( + foldingContext().messages().Say(symbolName, "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 --- a/flang/test/Semantics/assign04.f90 +++ b/flang/test/Semantics/assign04.f90 @@ -8,7 +8,7 @@ type(t(1, 2)) :: x !ERROR: Assignment to constant 'x%k' is not allowed x%k = 4 - !ERROR: Left-hand side of assignment is not modifiable + !ERROR: Assignment to constant 'x%l' is not allowed x%l = 3 end diff --git a/flang/test/Semantics/resolve104.f90 b/flang/test/Semantics/resolve104.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/resolve104.f90 @@ -0,0 +1,64 @@ +! 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 --- a/flang/test/Semantics/resolve89.f90 +++ b/flang/test/Semantics/resolve89.f90 @@ -107,7 +107,7 @@ type localDerivedType ! OK because the specification inquiry is a constant integer, dimension(localDerived%kindParam) :: goodField - !ERROR: Invalid specification expression: non-constant reference to a type parameter inquiry not allowed for derived type components or type parameter values + ! OK because the value of lenParam is constant in this context integer, dimension(derivedArg%lenParam) :: badField end type localDerivedType