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

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.

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

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

@@ -664,6 +664,7 @@ class ParseTreeDumper {
   NODE(parser, SubroutineSubprogram)
   NODE(parser, SubscriptTriplet)
   NODE(parser, Substring)
+  NODE(parser, SubstringInquiry)
   NODE(parser, SubstringRange)
   NODE(parser, Suffix)
   NODE(parser, SyncAllStmt)

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

@@ -179,6 +179,7 @@ struct EquivalenceStmt; // R870
 struct CommonStmt; // R873
 struct Substring; // R908
 struct CharLiteralConstantSubstring;
+struct SubstringInquiry;
 struct DataRef; // R911
 struct StructureComponent; // R913
 struct CoindexedNamedObject; // R914
@@ -1734,7 +1735,7 @@ struct Expr {
       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;
 };
 
@@ -1778,6 +1779,15 @@ struct 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

flang/include/flang/Semantics/expression.h

@@ -269,6 +269,7 @@ class ExpressionAnalyzer {
   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);
@@ -326,6 +327,7 @@ class ExpressionAnalyzer {
   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

flang/lib/Parser/Fortran-parsers.cpp

@@ -1075,6 +1075,9 @@ TYPE_PARSER(
 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)))

flang/lib/Parser/expr-parsers.cpp

@@ -66,13 +66,15 @@ TYPE_PARSER(construct<AcImpliedDoControl>(
 //         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)

flang/lib/Parser/unparse.cpp

@@ -758,6 +758,10 @@ class UnparseVisitor {
     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, ":");
   }

flang/lib/Semantics/expression.cpp

@@ -336,49 +336,74 @@ bool ExpressionAnalyzer::CheckRanks(const DataRef &dataRef) {
 }
 
 // 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) {
+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
+    parser::ArrayElement &arrElement{ae->value()};
+    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}) {
+            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.
+                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 *ae{std::get_if<common::Indirection<parser::ArrayElement>>(
+    if (auto *sc{std::get_if<common::Indirection<parser::StructureComponent>>(
             &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();
-                }
-              }
-            }
+      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)}) {
@@ -918,6 +943,21 @@ MaybeExpr ExpressionAnalyzer::Analyze(
   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) {

flang/lib/Semantics/resolve-names.cpp

@@ -1456,6 +1456,7 @@ class ResolveNamesVisitor : public virtual ScopeHandler,
   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));
@@ -6458,6 +6459,7 @@ const parser::Name *DeclarationVisitor::ResolveDesignator(
       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));
           },
       },
@@ -7312,6 +7314,10 @@ bool ResolveNamesVisitor::Pre(const parser::PointerAssignmentStmt &x) {
 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);

flang/test/Evaluate/rewrite02.f90

@@ -0,0 +1,47 @@
+! 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