[flang-commits] [flang] e03664d - [flang] Fix parsing and semantics for array element substring%KIND/%LEN
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Fri Jul 22 16:54:57 PDT 2022
Author: Peter Klausler
Date: 2022-07-22T16:54:46-07:00
New Revision: e03664d40c707017dc5bab16be19d6939b5719d2
URL: https://github.com/llvm/llvm-project/commit/e03664d40c707017dc5bab16be19d6939b5719d2
DIFF: https://github.com/llvm/llvm-project/commit/e03664d40c707017dc5bab16be19d6939b5719d2.diff
LOG: [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
Added:
flang/test/Evaluate/rewrite02.f90
Modified:
flang/include/flang/Parser/dump-parse-tree.h
flang/include/flang/Parser/parse-tree.h
flang/include/flang/Semantics/expression.h
flang/lib/Parser/Fortran-parsers.cpp
flang/lib/Parser/expr-parsers.cpp
flang/lib/Parser/unparse.cpp
flang/lib/Semantics/expression.cpp
flang/lib/Semantics/resolve-names.cpp
Removed:
################################################################################
diff --git a/flang/include/flang/Parser/dump-parse-tree.h b/flang/include/flang/Parser/dump-parse-tree.h
index c97c368a847da..e0f8a0d632402 100644
--- a/flang/include/flang/Parser/dump-parse-tree.h
+++ b/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)
diff --git a/flang/include/flang/Parser/parse-tree.h b/flang/include/flang/Parser/parse-tree.h
index 0c16844749056..17cee660cbc02 100644
--- a/flang/include/flang/Parser/parse-tree.h
+++ b/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
diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h
index 70e67bc237373..042ffec9e6833 100644
--- a/flang/include/flang/Semantics/expression.h
+++ b/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
diff --git a/flang/lib/Parser/Fortran-parsers.cpp b/flang/lib/Parser/Fortran-parsers.cpp
index 81f704bc34cc7..e1c2ad40963bb 100644
--- a/flang/lib/Parser/Fortran-parsers.cpp
+++ b/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)))
diff --git a/flang/lib/Parser/expr-parsers.cpp b/flang/lib/Parser/expr-parsers.cpp
index e0a55b138be79..6b53866e820a0 100644
--- a/flang/lib/Parser/expr-parsers.cpp
+++ b/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)
diff --git a/flang/lib/Parser/unparse.cpp b/flang/lib/Parser/unparse.cpp
index 880d8323ab32a..f5381dd39b9a6 100644
--- a/flang/lib/Parser/unparse.cpp
+++ b/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, ":");
}
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 7bcd97607a049..d8b3f5e32c284 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/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) {
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 93c6315cf4c9a..06ffbd10b5d73 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/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);
diff --git a/flang/test/Evaluate/rewrite02.f90 b/flang/test/Evaluate/rewrite02.f90
new file mode 100644
index 0000000000000..e1eebe55134e5
--- /dev/null
+++ b/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
More information about the flang-commits
mailing list