[flang] Fix spurious errors from runtime derived type table construction

[klausler]

Summary

Andrezj W. @ Arm discovered that the runtime derived type table
building code in semantics was detecting fatal errors in the tests
that the f18 driver wasn't printing. This patch fixes f18 so that
these messages are printed; however, the messages were not valid user
errors, and the rest of this patch fixes them up.

There were two sources of the bogus errors. One was that the runtime
derived type information table builder was calculating the shapes of
allocatable and pointer array components in derived types, and then
complaining that they weren't constant or LEN parameter values, which
of course they couldn't be since they have to have deferred shapes
and those bounds were expressions like LBOUND(component,dim=1).

The second was that f18 was forwarding the actual LEN type parameter
expressions of a type instantiation too far into the uses of those
parameters in various expressions in the declarations of components;
when an actual LEN type parameter is not a constant value, it needs
to remain a "bare" type parameter inquiry so that it will be lowered
to a descriptor inquiry and acquire a captured expression value.

Fixing this up properly involved: moving some code into new utility
function templates in Evaluate/tools.h, tweaking the rewriting of
conversions in expression folding to elide needless integer kind
conversions of type parameter inquiries, making type parameter
inquiry folding *not* replace bare LEN type parameters with
non-constant actual parameter values, and cleaning up some
altered test results.

[PeteSteinfeld]

All builds, tests, and looks good.

[awarzynski]

Thank you for fixing this @klausler.

The changes in the driver LGTM. As for the other changes, I will defer to @PeteSteinfeld.

flang/include/flang/Evaluate/tools.h

 template <typename A, typename B> A *UnwrapExpr(std::optional<B> &x) {
   if (x) {
     return UnwrapExpr<A>(*x);
   } else {
     return nullptr;
   }
 }
 
+// A variant of UnwrapExpr above that also skips through (parentheses)
+// and conversions of kinds within a category.  Useful for extracting LEN
+// type parameter inquiries, at least.
+template <typename A, typename B>
+auto UnwrapConvertedExpr(B &x) -> common::Constify<A, B> * {
+  using Ty = std::decay_t<B>;
+  if constexpr (std::is_same_v<A, Ty>) {
+    return &x;
+  } else if constexpr (std::is_same_v<Ty, ActualArgument>) {
+    if (auto *expr{x.UnwrapExpr()}) {
+      return UnwrapConvertedExpr<A>(*expr);
+    }
+  } else if constexpr (std::is_same_v<Ty, Expr<SomeType>>) {
+    return std::visit([](auto &x) { return UnwrapConvertedExpr<A>(x); }, x.u);
+  } else if constexpr (!common::HasMember<A, TypelessExpression>) {
+    using Result = ResultType<A>;
+    if constexpr (std::is_same_v<Ty, Expr<Result>> ||
+        std::is_same_v<Ty, Expr<SomeKind<Result::category>>>) {
+      return std::visit([](auto &x) { return UnwrapConvertedExpr<A>(x); }, x.u);
+    } else if constexpr (std::is_same_v<Ty, Parentheses<Result>> ||
+        std::is_same_v<Ty, Convert<Result, Result::category>>) {
+      return std::visit(
+          [](auto &x) { return UnwrapConvertedExpr<A>(x); }, x.left().u);
+    }
+  }
+  return nullptr;
+}
+
+// When an expression is a "bare" LEN= derived type parameter inquiry,
+// possibly wrapped in integer kind conversions &/or parentheses, return
+// a pointer to the Symbol with TypeParamDetails.
+template <typename A> const Symbol *ExtractBareLenParameter(const A &expr) {
+  if (const auto *typeParam{
+          evaluate::UnwrapConvertedExpr<evaluate::TypeParamInquiry>(expr)}) {
+    if (!typeParam->base()) {
+      const Symbol &symbol{typeParam->parameter()};
+      if (const auto *tpd{symbol.detailsIf<semantics::TypeParamDetails>()}) {
+        if (tpd->attr() == common::TypeParamAttr::Len) {
+          return &symbol;
+        }
+      }
+    }
+  }
+  return nullptr;
+}
+
 // If an expression simply wraps a DataRef, extract and return it.
 // The Boolean argument controls the handling of Substring
 // references: when true (not default), it extracts the base DataRef
 // of a substring, if it has one.
 template <typename A>
 common::IfNoLvalue<std::optional<DataRef>, A> ExtractDataRef(
     const A &, bool intoSubstring) {
   return std::nullopt; // default base case

flang/lib/Evaluate/fold-implementation.h

return std::visit(
               FromCat == TypeCategory::Logical) {
             return Expr<TO>{value->IsTrue()};
           }
         } else if constexpr (TO::category == FromCat &&
             FromCat != TypeCategory::Character) {
           // Conversion of non-constant in same type category
           if constexpr (std::is_same_v<Operand, TO>) {
             return std::move(kindExpr); // remove needless conversion
-          } else if constexpr (std::is_same_v<TO, DescriptorInquiry::Result>) {
+          } else if constexpr (TO::category == TypeCategory::Logical ||
+              TO::category == TypeCategory::Integer) {
             if (auto *innerConv{
-                    std::get_if<Convert<Operand, TypeCategory::Integer>>(
-                        &kindExpr.u)}) {
+                    std::get_if<Convert<Operand, TO::category>>(&kindExpr.u)}) {
+              // Conversion of conversion of same category & kind
               if (auto *x{std::get_if<Expr<TO>>(&innerConv->left().u)}) {
-                if (std::holds_alternative<DescriptorInquiry>(x->u)) {
+                if constexpr (TO::category == TypeCategory::Logical ||
+                    TO::kind <= Operand::kind) {
+                  return std::move(*x); // no-op Logical or Integer
+                                        // widening/narrowing conversion pair
+                } else if constexpr (std::is_same_v<TO,
+                                         DescriptorInquiry::Result>) {
+                  if (std::holds_alternative<DescriptorInquiry>(x->u) ||
+                      std::holds_alternative<TypeParamInquiry>(x->u)) {
                     // int(int(size(...),kind=k),kind=8) -> size(...)
                     return std::move(*x);
                   }
                 }
               }
             }
           }
+        }
         return Expr<TO>{std::move(convert)};
       },
       convert.left().u);
 }
 
 template <typename T>
 Expr<T> FoldOperation(FoldingContext &context, Parentheses<T> &&x) {
   auto &operand{x.left()};

flang/lib/Evaluate/fold-integer.cpp

Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
   // cshift, dot_product, eoshift,
   // findloc, iall, iany, iparity, ibits, image_status, ishftc,
   // matmul, maxloc, maxval,
   // minloc, minval, not, pack, product, reduce,
   // sign, spread, sum, transfer, transpose, unpack
   return Expr<T>{std::move(funcRef)};
 }
 
-// Substitute a bare type parameter reference with its value if it has one now
+// Substitutes a bare type parameter reference with its value if it has one now
+// in an instantiation.  Bare LEN type parameters are substituted only when
+// the known value is constant.
 Expr<TypeParamInquiry::Result> FoldOperation(
     FoldingContext &context, TypeParamInquiry &&inquiry) {
   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()}) {
       if (const semantics::ParamValue *
           paramValue{
               declType->derivedTypeSpec().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.
+    // A "bare" type parameter: replace with its value, if that's now known
+    // in a current derived type instantiation, for KIND type parameters.
     if (const auto *pdt{context.pdtInstance()}) {
+      bool isLen{false};
       if (const semantics::Scope * scope{context.pdtInstance()->scope()}) {
         auto iter{scope->find(parameterName)};
         if (iter != scope->end()) {
           const Symbol &symbol{*iter->second};
           const auto *details{symbol.detailsIf<semantics::TypeParamDetails>()};
           if (details) {
+            isLen = details->attr() == common::TypeParamAttr::Len;
             const semantics::MaybeIntExpr &initExpr{details->init()};
-            if (initExpr && IsConstantExpr(*initExpr)) {
+            if (initExpr && IsConstantExpr(*initExpr) &&
+                (!isLen || ToInt64(*initExpr))) {
               Expr<SomeInteger> expr{*initExpr};
               return Fold(context,
                   ConvertToType<TypeParamInquiry::Result>(std::move(expr)));
             }
           }
         }
       }
       if (const auto *value{pdt->FindParameter(parameterName)}) {
         if (value->isExplicit()) {
-          return Fold(context,
+          auto folded{Fold(context,
               AsExpr(ConvertToType<TypeParamInquiry::Result>(
-                  Expr<SomeInteger>{value->GetExplicit().value()})));
+                  Expr<SomeInteger>{value->GetExplicit().value()})))};
+          if (!isLen || ToInt64(folded)) {
+            return folded;
+          }
         }
       }
     }
   }
   return AsExpr(std::move(inquiry));
 }
 
 std::optional<std::int64_t> ToInt64(const Expr<SomeInteger> &expr) {

flang/lib/Semantics/runtime-type-info.cpp

private:
   // Specialization for optional<Expr<SomeInteger and SubscriptInteger>>
   template <typename T>
   evaluate::StructureConstructor GetValue(
       const std::optional<evaluate::Expr<T>> &expr,
       const SymbolVector *parameters) {
     if (auto constValue{evaluate::ToInt64(expr)}) {
       return PackageIntValue(explicitEnum_, *constValue);
     }
+    if (expr) {
       if (parameters) {
-      if (const auto *typeParam{
-              evaluate::UnwrapExpr<evaluate::TypeParamInquiry>(expr)}) {
-        if (!typeParam->base()) {
-          const Symbol &symbol{typeParam->parameter()};
-          if (const auto *tpd{symbol.detailsIf<TypeParamDetails>()}) {
-            if (tpd->attr() == common::TypeParamAttr::Len) {
-              return PackageIntValue(lenParameterEnum_,
-                  FindLenParameterIndex(*parameters, symbol));
-            }
-          }
+        if (const Symbol * lenParam{evaluate::ExtractBareLenParameter(*expr)}) {
+          return PackageIntValue(
+              lenParameterEnum_, FindLenParameterIndex(*parameters, *lenParam));
         }
       }
-    }
-    if (expr) {
       context_.Say(location_,
           "Specification expression '%s' is neither constant nor a length type parameter"_err_en_US,
           expr->AsFortran());
     }
     return PackageIntValue(deferredEnum_);
   }
 
   SemanticsContext &context_;
AddValue(values, componentSchema_, "lenvalue"s,
                 static_cast<evaluate::ConstantSubscript>(lenParams.size())}));
   } else {
     AddValue(values, componentSchema_, "lenvalue"s,
         SomeExpr{evaluate::NullPointer{}});
   }
   // Shape information
   int rank{evaluate::GetRank(shape)};
   AddValue(values, componentSchema_, "rank"s, IntExpr<1>(rank));
-  if (rank > 0) {
+  if (rank > 0 && !IsAllocatable(symbol) && !IsPointer(symbol)) {
     std::vector<evaluate::StructureConstructor> bounds;
     evaluate::NamedEntity entity{symbol};
     auto &foldingContext{context_.foldingContext()};
     for (int j{0}; j < rank; ++j) {
       bounds.emplace_back(GetValue(std::make_optional(evaluate::GetLowerBound(
                                        foldingContext, entity, j)),
           parameters));
       bounds.emplace_back(GetValue(

flang/lib/Semantics/type.cpp

public:
   // Instantiate components from fromScope into scope_
   void InstantiateComponents(const Scope &);
 
 private:
   SemanticsContext &context() const { return scope_.context(); }
   evaluate::FoldingContext &foldingContext() {
     return context().foldingContext();
   }
-  template <typename T> T Fold(T &&expr) {
+  template <typename A> A Fold(A &&expr) {
     return evaluate::Fold(foldingContext(), std::move(expr));
   }
   void InstantiateComponent(const Symbol &);
   const DeclTypeSpec *InstantiateType(const Symbol &);
   const DeclTypeSpec &InstantiateIntrinsicType(
       SourceName, const DeclTypeSpec &);
   DerivedTypeSpec CreateDerivedTypeSpec(const DerivedTypeSpec &, bool);
 
for (ShapeSpec &dim : details->coshape()) {
       }
     }
     if (MaybeExpr & init{details->init()}) {
       // Non-pointer components with default initializers are
       // processed now so that those default initializers can be used
       // in PARAMETER structure constructors.
       auto restorer{foldingContext().messages().SetLocation(newSymbol.name())};
       init = IsPointer(newSymbol)
-          ? evaluate::Fold(foldingContext(), std::move(*init))
+          ? Fold(std::move(*init))
           : evaluate::NonPointerInitializationExpr(
                 newSymbol, std::move(*init), foldingContext());
     }
   } else if (auto *procDetails{newSymbol.detailsIf<ProcEntityDetails>()}) {
     // We have a procedure pointer.  Instantiate its return type
     if (const DeclTypeSpec * returnType{InstantiateType(newSymbol)}) {
       ProcInterface &interface{procDetails->interface()};
       if (!interface.symbol()) {

flang/test/Semantics/modfile22.f90

 type(t), parameter :: p = t(k=1)(a='xx',b='xx')
 character(len=2), parameter :: c2(3) = [character(len=2) :: 'x', 'xx', 'xxx']
 end module m
 
 !Expect: m.mod
 !module m
 !type::t(k)
 !integer(4),kind::k=1_4
-!character(1_4,int(int(k,kind=4),kind=8))::a
-!character(3_4,int(int(k,kind=4),kind=8))::b
+!character(1_4,k)::a
+!character(3_4,k)::b
 !end type
 !type(t(k=1_4)),parameter::p=t(k=1_4)(a="x",b="xx ")
 !character(2_4,1),parameter::c2(1_8:3_8)=[CHARACTER(KIND=1,LEN=2)::"x ","xx","xx"]
 !end

flang/test/Semantics/typeinfo01.f90

type :: t(len)
     real, pointer :: pointer => target
     character(len=len) :: chauto
     real :: automatic(len)
   end type
 !CHECK: .dt.t, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(name=.n.t,parent=NULL(),uninstantiated=NULL(),kindparameter=NULL(),lenparameterkind=.lpk.t)
 !CHECK: .lpk.t, SAVE, TARGET: ObjectEntity type: INTEGER(1) shape: 0_8:0_8 init:[INTEGER(1)::8_1]
  contains
   subroutine s1(x)
-!CHECK: .b.t.1.allocatable, SAVE, TARGET: ObjectEntity type: TYPE(value) shape: 0_8:1_8,0_8:0_8 init:reshape([value::value(genre=1_1,value=0_8),value(genre=1_1,value=0_8)],shape=[2,1])
 !CHECK: .b.t.1.automatic, SAVE, TARGET: ObjectEntity type: TYPE(value) shape: 0_8:1_8,0_8:0_8 init:reshape([value::value(genre=2_1,value=1_8),value(genre=3_1,value=0_8)],shape=[2,1])
-!CHECK: .c.t.1, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:3_8 init:[component::component(name=.n.allocatable,genre=3_1,category=1_1,kind=4_1,rank=1_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=.b.t.1.allocatable,initialization=NULL()),component(name=.n.automatic,genre=4_1,category=1_1,kind=4_1,rank=1_1,offset=96_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=.b.t.1.automatic,initialization=NULL()),component(name=.n.chauto,genre=4_1,category=3_1,kind=1_1,rank=0_1,offset=72_8,characterlen=value(genre=3_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL()),component(name=.n.pointer,genre=2_1,category=1_1,kind=4_1,rank=0_1,offset=48_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=target)]
+!CHECK: .c.t.1, SAVE, TARGET: ObjectEntity type: TYPE(component) shape: 0_8:3_8 init:[component::component(name=.n.allocatable,genre=3_1,category=1_1,kind=4_1,rank=1_1,offset=0_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL()),component(name=.n.automatic,genre=4_1,category=1_1,kind=4_1,rank=1_1,offset=96_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=.b.t.1.automatic,initialization=NULL()),component(name=.n.chauto,genre=4_1,category=3_1,kind=1_1,rank=0_1,offset=72_8,characterlen=value(genre=3_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=NULL()),component(name=.n.pointer,genre=2_1,category=1_1,kind=4_1,rank=0_1,offset=48_8,characterlen=value(genre=1_1,value=0_8),derived=NULL(),lenvalue=NULL(),bounds=NULL(),initialization=target)]
 !CHECK: .dt.t.1, SAVE, TARGET: ObjectEntity type: TYPE(derivedtype) init:derivedtype(binding=NULL(),name=.n.t,sizeinbytes=144_8,parent=NULL(),uninstantiated=.dt.t,kindparameter=NULL(),lenparameterkind=.lpk.t.1,component=.c.t.1,procptr=NULL(),special=NULL())
 !CHECK: .lpk.t.1, SAVE, TARGET: ObjectEntity type: INTEGER(1) shape: 0_8:0_8 init:[INTEGER(1)::8_1]
     type(t(*)), intent(in) :: x
   end subroutine
 end module

flang/tools/f18/f18.cpp

if (driver.measureTree) {
     MeasureParseTree(parseTree);
   }
   if (!driver.debugNoSemantics || driver.dumpSymbols ||
       driver.dumpUnparseWithSymbols || driver.getDefinition ||
       driver.getSymbolsSources) {
     Fortran::semantics::Semantics semantics{semanticsContext, parseTree,
         parsing.cooked().AsCharBlock(), driver.debugModuleWriter};
     semantics.Perform();
+    Fortran::semantics::RuntimeDerivedTypeTables tables;
+    if (!semantics.AnyFatalError()) {
+      tables =
+          Fortran::semantics::BuildRuntimeDerivedTypeTables(semanticsContext);
+      if (!tables.schemata) {
+        llvm::errs() << driver.prefix
+                     << "could not find module file for __fortran_type_info\n";
+      }
+    }
     semantics.EmitMessages(llvm::errs());
     if (semantics.AnyFatalError()) {
       if (driver.dumpSymbols) {
         semantics.DumpSymbols(llvm::outs());
       }
       llvm::errs() << driver.prefix << "Semantic errors in " << path << '\n';
       exitStatus = EXIT_FAILURE;
       if (driver.dumpParseTree) {
         Fortran::parser::DumpTree(llvm::outs(), parseTree, &asFortran);
       }
       return {};
     }
-    auto tables{
-        Fortran::semantics::BuildRuntimeDerivedTypeTables(semanticsContext)};
-    if (!tables.schemata) {
-      llvm::errs() << driver.prefix
-                   << "could not find module file for __fortran_type_info\n";
-    }
     if (driver.dumpSymbols) {
       semantics.DumpSymbols(llvm::outs());
     }
     if (driver.dumpUnparseWithSymbols) {
       Fortran::semantics::UnparseWithSymbols(
           llvm::outs(), parseTree, driver.encoding);
       return {};
     }