[flang] Fix parsing and semantics for array element substring%KIND/%LEN

[klausler]

Summary

A type-param-inquiry of %KIND or %LEN applies to a designator, and
so must also be allowed for a substring. F18 presently (mis)parses
instances of a type-param-inquiry as structure component references
and then fixes them in expression semantics when types are known and
we can distinguish them. But when the base of a type-param-inquiry is
a substring of an array element, as in "charArray(i)(j:k)%len",
parsing fails.

Adjust the grammar to parse these cases, and extend expression semantics
to process the new production.

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/include/flang/Parser/dump-parse-tree.h

#include "llvm/Frontend/OpenMP/OMP.inc"
   NODE(parser, StructureField)
   NODE(parser, StructureStmt)
   NODE(parser, Submodule)
   NODE(parser, SubmoduleStmt)
   NODE(parser, SubroutineStmt)
   NODE(parser, SubroutineSubprogram)
   NODE(parser, SubscriptTriplet)
   NODE(parser, Substring)
+  NODE(parser, SubstringInquiry)
   NODE(parser, SubstringRange)
   NODE(parser, Suffix)
   NODE(parser, SyncAllStmt)
   NODE(parser, SyncImagesStmt)
   NODE(SyncImagesStmt, ImageSet)
   NODE(parser, SyncMemoryStmt)
   NODE(parser, SyncTeamStmt)
   NODE(parser, Target)

flang/include/flang/Parser/parse-tree.h

 struct VolatileStmt; // R862
 struct ImplicitStmt; // R863
 struct ImportStmt; // R867
 struct NamelistStmt; // R868
 struct EquivalenceStmt; // R870
 struct CommonStmt; // R873
 struct Substring; // R908
 struct CharLiteralConstantSubstring;
+struct SubstringInquiry;
 struct DataRef; // R911
 struct StructureComponent; // R913
 struct CoindexedNamedObject; // R914
 struct ArrayElement; // R917
 struct AllocateStmt; // R927
 struct NullifyStmt; // R939
 struct DeallocateStmt; // R941
 struct AssignmentStmt; // R1032
struct Expr {
 
   CharBlock source;
 
   std::variant<common::Indirection<CharLiteralConstantSubstring>,
       LiteralConstant, common::Indirection<Designator>, ArrayConstructor,
       StructureConstructor, common::Indirection<FunctionReference>, Parentheses,
       UnaryPlus, Negate, NOT, PercentLoc, DefinedUnary, Power, Multiply, Divide,
       Add, Subtract, Concat, LT, LE, EQ, NE, GE, GT, AND, OR, EQV, NEQV,
-      DefinedBinary, ComplexConstructor>
+      DefinedBinary, ComplexConstructor, common::Indirection<SubstringInquiry>>
       u;
 };
 
 // R912 part-ref -> part-name [( section-subscript-list )] [image-selector]
 struct PartRef {
   BOILERPLATE(PartRef);
   PartRef(Name &&n, std::list<SectionSubscript> &&ss,
       std::optional<ImageSelector> &&is)
struct Substring {
   std::tuple<DataRef, SubstringRange> t;
 };
 
 struct CharLiteralConstantSubstring {
   TUPLE_CLASS_BOILERPLATE(CharLiteralConstantSubstring);
   std::tuple<CharLiteralConstant, SubstringRange> t;
 };
 
+// substring%KIND/LEN type parameter inquiry for cases that could not be
+// parsed as part-refs and fixed up afterwards.  N.B. we only have to
+// handle inquiries into designator-based substrings, not those based on
+// char-literal-constants.
+struct SubstringInquiry {
+  CharBlock source;
+  WRAPPER_CLASS_BOILERPLATE(SubstringInquiry, Substring);
+};
+
 // R901 designator -> object-name | array-element | array-section |
 //                    coindexed-named-object | complex-part-designator |
 //                    structure-component | substring
 struct Designator {
   UNION_CLASS_BOILERPLATE(Designator);
   bool EndsInBareName() const;
   CharBlock source;
   std::variant<DataRef, Substring> u;

flang/include/flang/Semantics/expression.h

private:
   MaybeExpr Analyze(const parser::HollerithLiteralConstant &);
   MaybeExpr Analyze(const parser::BOZLiteralConstant &);
   MaybeExpr Analyze(const parser::NamedConstant &);
   MaybeExpr Analyze(const parser::DataStmtConstant &);
   MaybeExpr Analyze(const parser::Substring &);
   MaybeExpr Analyze(const parser::ArrayElement &);
   MaybeExpr Analyze(const parser::CoindexedNamedObject &);
   MaybeExpr Analyze(const parser::CharLiteralConstantSubstring &);
+  MaybeExpr Analyze(const parser::SubstringInquiry &);
   MaybeExpr Analyze(const parser::ArrayConstructor &);
   MaybeExpr Analyze(const parser::FunctionReference &,
       std::optional<parser::StructureConstructor> * = nullptr);
   MaybeExpr Analyze(const parser::Expr::Parentheses &);
   MaybeExpr Analyze(const parser::Expr::UnaryPlus &);
   MaybeExpr Analyze(const parser::Expr::Negate &);
   MaybeExpr Analyze(const parser::Expr::NOT &);
   MaybeExpr Analyze(const parser::Expr::PercentLoc &);
private:
   std::optional<Component> CreateComponent(
       DataRef &&, const Symbol &, const semantics::Scope &);
   MaybeExpr CompleteSubscripts(ArrayRef &&);
   MaybeExpr ApplySubscripts(DataRef &&, std::vector<Subscript> &&);
   bool CheckRanks(const DataRef &); // Return false if error exists.
   std::optional<Expr<SubscriptInteger>> GetSubstringBound(
       const std::optional<parser::ScalarIntExpr> &);
   MaybeExpr AnalyzeDefinedOp(const parser::Name &, ActualArguments &&);
+  MaybeExpr FixMisparsedSubstring(const parser::Designator &);
 
   struct CalleeAndArguments {
     // A non-component function reference may constitute a misparsed
     // structure constructor, in which case its derived type's Symbol
     // will appear here.
     std::variant<ProcedureDesignator, SymbolRef> u;
     ActualArguments arguments;
   };

flang/lib/Parser/Fortran-parsers.cpp

 //        scalar-structure-component | scalar-char-literal-constant |
 //        scalar-named-constant
 TYPE_PARSER(
     construct<Substring>(dataRef, parenthesized(Parser<SubstringRange>{})))
 
 TYPE_PARSER(construct<CharLiteralConstantSubstring>(
     charLiteralConstant, parenthesized(Parser<SubstringRange>{})))
 
+TYPE_PARSER(sourced(construct<SubstringInquiry>(Parser<Substring>{}) /
+    ("%LEN"_tok || "%KIND"_tok)))
+
 // R910 substring-range -> [scalar-int-expr] : [scalar-int-expr]
 TYPE_PARSER(construct<SubstringRange>(
     maybe(scalarIntExpr), ":" >> maybe(scalarIntExpr)))
 
 // R911 data-ref -> part-ref [% part-ref]...
 // R914 coindexed-named-object -> data-ref
 // R917 array-element -> data-ref
 TYPE_PARSER(

flang/lib/Parser/expr-parsers.cpp

 // R776 ac-do-variable -> do-variable
 TYPE_PARSER(construct<AcImpliedDoControl>(
     maybe(integerTypeSpec / "::"), loopBounds(scalarIntExpr)))
 
 // R1001 primary ->
 //         literal-constant | designator | array-constructor |
 //         structure-constructor | function-reference | type-param-inquiry |
 //         type-param-name | ( expr )
-// N.B. type-param-inquiry is parsed as a structure component
+// type-param-inquiry is parsed as a structure component, except for
+// substring%KIND/LEN
 constexpr auto primary{instrumented("primary"_en_US,
     first(construct<Expr>(indirect(Parser<CharLiteralConstantSubstring>{})),
         construct<Expr>(literalConstant),
         construct<Expr>(construct<Expr::Parentheses>(parenthesized(expr))),
-        construct<Expr>(indirect(functionReference) / !"("_tok),
-        construct<Expr>(designator / !"("_tok),
+        construct<Expr>(indirect(functionReference) / !"("_tok / !"%"_tok),
+        construct<Expr>(designator / !"("_tok / !"%"_tok),
+        construct<Expr>(indirect(Parser<SubstringInquiry>{})), // %LEN or %KIND
         construct<Expr>(Parser<StructureConstructor>{}),
         construct<Expr>(Parser<ArrayConstructor>{}),
         // PGI/XLF extension: COMPLEX constructor (x,y)
         extension<LanguageFeature::ComplexConstructor>(
             "nonstandard usage: generalized COMPLEX constructor"_port_en_US,
             construct<Expr>(parenthesized(
                 construct<Expr::ComplexConstructor>(expr, "," >> expr)))),
         extension<LanguageFeature::PercentLOC>(

flang/lib/Parser/unparse.cpp

public:
   void Unparse(const Substring &x) { // R908, R909
     Walk(std::get<DataRef>(x.t));
     Put('('), Walk(std::get<SubstringRange>(x.t)), Put(')');
   }
   void Unparse(const CharLiteralConstantSubstring &x) {
     Walk(std::get<CharLiteralConstant>(x.t));
     Put('('), Walk(std::get<SubstringRange>(x.t)), Put(')');
   }
+  void Unparse(const SubstringInquiry &x) {
+    Walk(x.v);
+    Put(x.source.end()[-1] == 'n' ? "%LEN" : "%KIND");
+  }
   void Unparse(const SubstringRange &x) { // R910
     Walk(x.t, ":");
   }
   void Unparse(const PartRef &x) { // R912
     Walk(x.name);
     Walk("(", x.subscripts, ",", ")");
     Walk(x.imageSelector);
   }

flang/lib/Semantics/expression.cpp

return common::visit(
           },
           [](const SymbolRef &) { return true; },
           [](const CoarrayRef &) { return true; },
       },
       dataRef.u);
 }
 
 // Parse tree correction after a substring S(j:k) was misparsed as an
-// array section.  N.B. Fortran substrings have to have a range, not a
+// array section.  Fortran substrings must have a range, not a
 // single index.
-static void FixMisparsedSubstring(const parser::Designator &d) {
-  auto &mutate{const_cast<parser::Designator &>(d)};
-  if (auto *dataRef{std::get_if<parser::DataRef>(&mutate.u)}) {
-    if (auto *ae{std::get_if<common::Indirection<parser::ArrayElement>>(
-            &dataRef->u)}) {
-      parser::ArrayElement &arrElement{ae->value()};
-      if (!arrElement.subscripts.empty()) {
-        auto iter{arrElement.subscripts.begin()};
-        if (auto *triplet{std::get_if<parser::SubscriptTriplet>(&iter->u)}) {
-          if (!std::get<2>(triplet->t) /* no stride */ &&
-              ++iter == arrElement.subscripts.end() /* one subscript */) {
-            if (Symbol *
-                symbol{common::visit(
-                    common::visitors{
-                        [](parser::Name &n) { return n.symbol; },
-                        [](common::Indirection<parser::StructureComponent>
-                                &sc) { return sc.value().component.symbol; },
-                        [](auto &) -> Symbol * { return nullptr; },
-                    },
-                    arrElement.base.u)}) {
-              const Symbol &ultimate{symbol->GetUltimate()};
-              if (const semantics::DeclTypeSpec * type{ultimate.GetType()}) {
-                if (!ultimate.IsObjectArray() &&
-                    type->category() == semantics::DeclTypeSpec::Character) {
-                  // The ambiguous S(j:k) was parsed as an array section
-                  // reference, but it's now clear that it's a substring.
-                  // Fix the parse tree in situ.
-                  mutate.u = arrElement.ConvertToSubstring();
-                }
-              }
-            }
-          }
-        }
-      }
-    }
+static std::optional<parser::Substring> FixMisparsedSubstringDataRef(
+    parser::DataRef &dataRef) {
+  if (auto *ae{
+          std::get_if<common::Indirection<parser::ArrayElement>>(&dataRef.u)}) {
+    // ...%a(j:k) and "a" is a character scalar
+    if (arrElement.subscripts.size() == 1) {
+      if (auto *triplet{std::get_if<parser::SubscriptTriplet>(
+              &arrElement.subscripts.front().u)}) {
+        if (!std::get<2 /*stride*/>(triplet->t).has_value()) {
+          if (const Symbol *
+              symbol{parser::GetLastName(arrElement.base).symbol}) {
+                return arrElement.ConvertToSubstring();
+  return std::nullopt;
+}
+
+// When a designator is a misparsed type-param-inquiry of a misparsed
+// substring -- it looks like a structure component reference of an array
+// slice -- fix the substring and then convert to an intrinsic function
+// call to KIND() or LEN().  And when the designator is a misparsed
+// substring, convert it into a substring reference in place.
+MaybeExpr ExpressionAnalyzer::FixMisparsedSubstring(
+    const parser::Designator &d) {
+  auto &mutate{const_cast<parser::Designator &>(d)};
+  if (auto *dataRef{std::get_if<parser::DataRef>(&mutate.u)}) {
+    if (auto *sc{std::get_if<common::Indirection<parser::StructureComponent>>(
+            &dataRef->u)}) {
+      parser::StructureComponent &structComponent{sc->value()};
+      parser::CharBlock which{structComponent.component.source};
+      if (which == "kind" || which == "len") {
+        if (auto substring{
+                FixMisparsedSubstringDataRef(structComponent.base)}) {
+          // ...%a(j:k)%kind or %len and "a" is a character scalar
+          mutate.u = std::move(*substring);
+          if (MaybeExpr substringExpr{Analyze(d)}) {
+            return MakeFunctionRef(which,
+                ActualArguments{ActualArgument{std::move(*substringExpr)}});
           }
         }
+      }
+    } else if (auto substring{FixMisparsedSubstringDataRef(*dataRef)}) {
+      mutate.u = std::move(*substring);
+    }
+  }
+  return std::nullopt;
+}
 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Designator &d) {
   auto restorer{GetContextualMessages().SetLocation(d.source)};
-  FixMisparsedSubstring(d);
+  if (auto substringInquiry{FixMisparsedSubstring(d)}) {
+    return std::move(substringInquiry);
+  }
   // These checks have to be deferred to these "top level" data-refs where
   // we can be sure that there are no following subscripts (yet).
   if (MaybeExpr result{Analyze(d.u)}) {
     if (std::optional<DataRef> dataRef{ExtractDataRef(std::move(result))}) {
       if (!CheckRanks(std::move(*dataRef))) {
         return std::nullopt;
       }
       return Designate(std::move(*dataRef));
if (auto *charExpr{std::get_if<Expr<SomeCharacter>>(&string->u)}) {
                 Expr<Result>{Designator<Result>{std::move(substring)}});
           },
           std::move(charExpr->u));
     }
   }
   return std::nullopt;
 }
 
+// substring%KIND/LEN
+MaybeExpr ExpressionAnalyzer::Analyze(const parser::SubstringInquiry &x) {
+  if (MaybeExpr substring{Analyze(x.v)}) {
+    CHECK(x.source.size() >= 8);
+    int nameLen{x.source.end()[-1] == 'n' ? 3 /*LEN*/ : 4 /*KIND*/};
+    parser::CharBlock name{
+        x.source.end() - nameLen, static_cast<std::size_t>(nameLen)};
+    CHECK(name == "len" || name == "kind");
+    return MakeFunctionRef(
+        name, ActualArguments{ActualArgument{std::move(*substring)}});
+  } else {
+    return std::nullopt;
+  }
+}
+
 // Subscripted array references
 std::optional<Expr<SubscriptInteger>> ExpressionAnalyzer::AsSubscript(
     MaybeExpr &&expr) {
   if (expr) {
     if (expr->Rank() > 1) {
       Say("Subscript expression has rank %d greater than 1"_err_en_US,
           expr->Rank());
     }

flang/lib/Semantics/resolve-names.cpp

public:
 
   bool Pre(const parser::SpecificationPart &);
   void Post(const parser::Program &);
   bool Pre(const parser::ImplicitStmt &);
   void Post(const parser::PointerObject &);
   void Post(const parser::AllocateObject &);
   bool Pre(const parser::PointerAssignmentStmt &);
   void Post(const parser::Designator &);
+  void Post(const parser::SubstringInquiry &);
   template <typename A, typename B>
   void Post(const parser::LoopBounds<A, B> &x) {
     ResolveName(*parser::Unwrap<parser::Name>(x.name));
   }
   void Post(const parser::ProcComponentRef &);
   bool Pre(const parser::FunctionReference &);
   bool Pre(const parser::CallStmt &);
   bool Pre(const parser::ImportStmt &);

 }
 
 const parser::Name *DeclarationVisitor::ResolveDesignator(
     const parser::Designator &x) {
   return common::visit(
       common::visitors{
           [&](const parser::DataRef &x) { return ResolveDataRef(x); },
           [&](const parser::Substring &x) {
+            Walk(std::get<parser::SubstringRange>(x.t).t);
             return ResolveDataRef(std::get<parser::DataRef>(x.t));
           },
       },
       x.u);
 }
 
 const parser::Name *DeclarationVisitor::ResolveDataRef(
     const parser::DataRef &x) {
if (const parser::Name * name{parser::Unwrap<parser::Name>(expr)}) {
     }
   }
   Walk(expr);
   return false;
 }
 void ResolveNamesVisitor::Post(const parser::Designator &x) {
   ResolveDesignator(x);
 }
+void ResolveNamesVisitor::Post(const parser::SubstringInquiry &x) {
+  Walk(std::get<parser::SubstringRange>(x.v.t).t);
+  ResolveDataRef(std::get<parser::DataRef>(x.v.t));
+}
 
 void ResolveNamesVisitor::Post(const parser::ProcComponentRef &x) {
   ResolveStructureComponent(x.v.thing);
 }
 void ResolveNamesVisitor::Post(const parser::TypeGuardStmt &x) {
   DeclTypeSpecVisitor::Post(x);
   ConstructVisitor::Post(x);
 }

flang/test/Evaluate/rewrite02.f90

+! RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s
+! Tests handling of easily-misparsed substrings and substring
+! type parameter inquiries.
+subroutine foo(j)
+  integer, intent(in) :: j
+  character*4 sc, ac(1)
+  type t
+    character*4 sc, ac(1)
+  end type
+  type(t) st, at(1)
+  !CHECK: PRINT *, sc(1_8:int(j,kind=8))
+  print *, sc(1:j)
+  !CHECK: PRINT *, ac(1_8)(1_8:int(j,kind=8))
+  print *, ac(1)(1:j)
+  !CHECK: PRINT *, st%sc(1_8:int(j,kind=8))
+  print *, st%sc(1:j)
+  !CHECK: PRINT *, st%ac(1_8)(1_8:int(j,kind=8))
+  print *, st%ac(1)(1:j)
+  !CHECK: PRINT *, at(1_8)%sc(1_8:int(j,kind=8))
+  print *, at(1)%sc(1:j)
+  !CHECK: PRINT *, at(1_8)%ac(1_8)(1_8:int(j,kind=8))
+  print *, at(1)%ac(1)(1:j)
+  !CHECK: PRINT *, 1_4
+  print *, sc(1:j)%kind
+  !CHECK: PRINT *, 1_4
+  print *, ac(1)(1:j)%kind
+  !CHECK: PRINT *, 1_4
+  print *, st%sc(1:j)%kind
+  !CHECK: PRINT *, 1_4
+  print *, st%ac(1)(1:j)%kind
+  !CHECK: PRINT *, 1_4
+  print *, at(1)%sc(1:j)%kind
+  !CHECK: PRINT *, 1_4
+  print *, at(1)%ac(1)(1:j)%kind
+  !CHECK: PRINT *, int(max(0_8,int(j,kind=8)-1_8+1_8),kind=4)
+  print *, sc(1:j)%len
+  !CHECK: PRINT *, int(max(0_8,int(j,kind=8)-1_8+1_8),kind=4)
+  print *, ac(1)(1:j)%len
+  !CHECK: PRINT *, int(max(0_8,int(j,kind=8)-1_8+1_8),kind=4)
+  print *, st%sc(1:j)%len
+  !CHECK: PRINT *, int(max(0_8,int(j,kind=8)-1_8+1_8),kind=4)
+  print *, st%ac(1)(1:j)%len
+  !CHECK: PRINT *, int(max(0_8,int(j,kind=8)-1_8+1_8),kind=4)
+  print *, at(1)%sc(1:j)%len
+  !CHECK: PRINT *, int(max(0_8,int(j,kind=8)-1_8+1_8),kind=4)
+  print *, at(1)%ac(1)(1:j)%len
+end