diff --git a/flang/include/flang/Parser/dump-parse-tree.h b/flang/include/flang/Parser/dump-parse-tree.h --- a/flang/include/flang/Parser/dump-parse-tree.h +++ b/flang/include/flang/Parser/dump-parse-tree.h @@ -664,6 +664,7 @@ 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 --- a/flang/include/flang/Parser/parse-tree.h +++ b/flang/include/flang/Parser/parse-tree.h @@ -179,6 +179,7 @@ struct CommonStmt; // R873 struct Substring; // R908 struct CharLiteralConstantSubstring; +struct SubstringInquiry; struct DataRef; // R911 struct StructureComponent; // R913 struct CoindexedNamedObject; // R914 @@ -1734,7 +1735,7 @@ StructureConstructor, common::Indirection, 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> u; }; @@ -1778,6 +1779,15 @@ std::tuple 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 --- a/flang/include/flang/Semantics/expression.h +++ b/flang/include/flang/Semantics/expression.h @@ -269,6 +269,7 @@ 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 * = nullptr); @@ -326,6 +327,7 @@ std::optional> GetSubstringBound( const std::optional &); 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 --- a/flang/lib/Parser/Fortran-parsers.cpp +++ b/flang/lib/Parser/Fortran-parsers.cpp @@ -1075,6 +1075,9 @@ TYPE_PARSER(construct( charLiteralConstant, parenthesized(Parser{}))) +TYPE_PARSER(sourced(construct(Parser{}) / + ("%LEN"_tok || "%KIND"_tok))) + // R910 substring-range -> [scalar-int-expr] : [scalar-int-expr] TYPE_PARSER(construct( maybe(scalarIntExpr), ":" >> maybe(scalarIntExpr))) diff --git a/flang/lib/Parser/expr-parsers.cpp b/flang/lib/Parser/expr-parsers.cpp --- a/flang/lib/Parser/expr-parsers.cpp +++ b/flang/lib/Parser/expr-parsers.cpp @@ -66,13 +66,15 @@ // 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(indirect(Parser{})), construct(literalConstant), construct(construct(parenthesized(expr))), - construct(indirect(functionReference) / !"("_tok), - construct(designator / !"("_tok), + construct(indirect(functionReference) / !"("_tok / !"%"_tok), + construct(designator / !"("_tok / !"%"_tok), + construct(indirect(Parser{})), // %LEN or %KIND construct(Parser{}), construct(Parser{}), // PGI/XLF extension: COMPLEX constructor (x,y) diff --git a/flang/lib/Parser/unparse.cpp b/flang/lib/Parser/unparse.cpp --- a/flang/lib/Parser/unparse.cpp +++ b/flang/lib/Parser/unparse.cpp @@ -758,6 +758,10 @@ Walk(std::get(x.t)); Put('('), Walk(std::get(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 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -336,49 +336,74 @@ } // 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 FixMisparsedSubstringDataRef( + parser::DataRef &dataRef) { + if (auto *ae{ + std::get_if>(&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( + &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(d)}; if (auto *dataRef{std::get_if(&mutate.u)}) { - if (auto *ae{std::get_if>( + if (auto *sc{std::get_if>( &dataRef->u)}) { - parser::ArrayElement &arrElement{ae->value()}; - if (!arrElement.subscripts.empty()) { - auto iter{arrElement.subscripts.begin()}; - if (auto *triplet{std::get_if(&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 - &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 @@ 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(nameLen)}; + CHECK(name == "len" || name == "kind"); + return MakeFunctionRef( + name, ActualArguments{ActualArgument{std::move(*substring)}}); + } else { + return std::nullopt; + } +} + // Subscripted array references std::optional> ExpressionAnalyzer::AsSubscript( MaybeExpr &&expr) { diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -1456,6 +1456,7 @@ void Post(const parser::AllocateObject &); bool Pre(const parser::PointerAssignmentStmt &); void Post(const parser::Designator &); + void Post(const parser::SubstringInquiry &); template void Post(const parser::LoopBounds &x) { ResolveName(*parser::Unwrap(x.name)); @@ -6458,6 +6459,7 @@ common::visitors{ [&](const parser::DataRef &x) { return ResolveDataRef(x); }, [&](const parser::Substring &x) { + Walk(std::get(x.t).t); return ResolveDataRef(std::get(x.t)); }, }, @@ -7312,6 +7314,10 @@ void ResolveNamesVisitor::Post(const parser::Designator &x) { ResolveDesignator(x); } +void ResolveNamesVisitor::Post(const parser::SubstringInquiry &x) { + Walk(std::get(x.v.t).t); + ResolveDataRef(std::get(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 --- /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