[flang] Improve constant folding for type parameter inquiries

We were not folding type parameter inquiries for the form 'var%typeParam'
where 'typeParam' was a KIND or LEN type parameter of a derived type and 'var'
was a designator of the derived type.  I fixed this by adding code to the
function 'FoldOperation()' for 'TypeParamInquiry's to handle this case.  I also
cleaned up the code for the case where there is no designator.

In order to make the error messages correctly refer to both the points of
declaration and instantiation, I needed to add an argument to the function
'InstantiateIntrinsicType()' for the location of the instantiation.

I also changed the formatting of 'TypeParamInquiry' to correctly format this
case.  I also added tests for both KIND and LEN type parameter inquiries in
resolve104.f90.

Making these changes revealed an error in resolve89.f90 and caused one of the
error messages in assign04.f90 to be different.

Differential Revision: https://reviews.llvm.org/D99892

6 files changed, 100 insertions, 16 deletions

diff --git a/flang/lib/Evaluate/fold-integer.cpp b/flang/lib/Evaluate/fold-integer.cpp
index eea7b6ee7a95..8b39ee028b3c 100644
--- a/flang/lib/Evaluate/fold-integer.cpp
+++ b/flang/lib/Evaluate/fold-integer.cpp
@@ -658,24 +658,43 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
 // Substitute a bare type parameter reference with its value if it has one now
 Expr<TypeParamInquiry::Result> FoldOperation(
     FoldingContext &context, TypeParamInquiry &&inquiry) {
-  if (!inquiry.base()) {
+  std::optional<NamedEntity> 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 &paramExpr{paramValue->GetExplicit()};
+        if (paramExpr && IsConstantExpr(*paramExpr)) {
+          Expr<SomeInteger> intExpr{*paramExpr};
+          return Fold(context,
+              ConvertToType<TypeParamInquiry::Result>(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<semantics::TypeParamDetails>()};
-          if (details && details->init() &&
-              (details->attr() == common::TypeParamAttr::Kind ||
-                  IsConstantExpr(*details->init()))) {
-            Expr<SomeInteger> expr{*details->init()};
-            return Fold(context,
-                ConvertToType<TypeParamInquiry::Result>(std::move(expr)));
+          if (details) {
+            const semantics::MaybeIntExpr &initExpr{details->init()};
+            if (initExpr && IsConstantExpr(*initExpr)) {
+              Expr<SomeInteger> expr{*initExpr};
+              return Fold(context,
+                  ConvertToType<TypeParamInquiry::Result>(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<TypeParamInquiry::Result>(
diff --git a/flang/lib/Evaluate/formatting.cpp b/flang/lib/Evaluate/formatting.cpp
index df3671a919b5..f7cfaa3e6dff 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_) {
-    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
index 741b25332297..c548b5cbd199 100644
--- a/flang/lib/Semantics/type.cpp
+++ b/flang/lib/Semantics/type.cpp
@@ -205,7 +205,8 @@ private:
   }
   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 @@ const DeclTypeSpec *InstantiateHelper::InstantiateType(const Symbol &symbol) {
         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 @@ const DeclTypeSpec *InstantiateHelper::InstantiateType(const Symbol &symbol) {
 
 // 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 @@ const DeclTypeSpec &InstantiateHelper::InstantiateIntrinsicType(
     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
index a88c3a5b69f4..7cb30c49d7cd 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: 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
index 000000000000..176c9d68d9e9
--- /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
index f3bf218fdce7..eaa902bf54eb 100644
--- a/flang/test/Semantics/resolve89.f90
+++ b/flang/test/Semantics/resolve89.f90
@@ -107,7 +107,7 @@ subroutine s1()
       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