forked from OSchip/llvm-project
[flang] Outline per-type parsers to reduce f18 build-time
CPU & memory requirements Original-commit: flang-compiler/f18@f48fe07dfa Reviewed-on: https://github.com/flang-compiler/f18/pull/862 Tree-same-pre-rewrite: false
This commit is contained in:
peter klausler
parent
b738d4ad38
commit
40f0e01d2d
|
|
@ -13,16 +13,22 @@
|
|||
# limitations under the License.
|
||||
|
||||
add_library(FortranParser
|
||||
Fortran-parsers.cc
|
||||
char-buffer.cc
|
||||
char-set.cc
|
||||
characters.cc
|
||||
debug-parser.cc
|
||||
executable-parsers.cc
|
||||
expr-parsers.cc
|
||||
instrumented-parser.cc
|
||||
io-parsers.cc
|
||||
message.cc
|
||||
openmp-parsers.cc
|
||||
parse-tree.cc
|
||||
parsing.cc
|
||||
preprocessor.cc
|
||||
prescan.cc
|
||||
program-parsers.cc
|
||||
provenance.cc
|
||||
source.cc
|
||||
token-sequence.cc
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,529 @@
|
|||
// Copyright (c) 2018-2019, NVIDIA CORPORATION. All rights reserved.
|
||||
//
|
||||
// Licensed under the Apache License, Version 2.0 (the "License");
|
||||
// you may not use this file except in compliance with the License.
|
||||
// You may obtain a copy of the License at
|
||||
//
|
||||
// http://www.apache.org/licenses/LICENSE-2.0
|
||||
//
|
||||
// Unless required by applicable law or agreed to in writing, software
|
||||
// distributed under the License is distributed on an "AS IS" BASIS,
|
||||
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
// See the License for the specific language governing permissions and
|
||||
// limitations under the License.
|
||||
|
||||
#include "basic-parsers.h"
|
||||
#include "characters.h"
|
||||
#include "debug-parser.h"
|
||||
#include "expr-parsers.h"
|
||||
#include "misc-parsers.h"
|
||||
#include "parse-tree.h"
|
||||
#include "stmt-parser.h"
|
||||
#include "token-parsers.h"
|
||||
#include "type-parser-implementation.h"
|
||||
|
||||
namespace Fortran::parser {
|
||||
|
||||
// Fortran allows the statement with the corresponding label at the end of
|
||||
// a do-construct that begins with an old-style label-do-stmt to be a
|
||||
// new-style END DO statement; e.g., DO 10 I=1,N; ...; 10 END DO. Usually,
|
||||
// END DO statements appear only at the ends of do-constructs that begin
|
||||
// with a nonlabel-do-stmt, so care must be taken to recognize this case and
|
||||
// essentially treat them like CONTINUE statements.
|
||||
|
||||
// R514 executable-construct ->
|
||||
// action-stmt | associate-construct | block-construct |
|
||||
// case-construct | change-team-construct | critical-construct |
|
||||
// do-construct | if-construct | select-rank-construct |
|
||||
// select-type-construct | where-construct | forall-construct
|
||||
constexpr auto executableConstruct{
|
||||
first(construct<ExecutableConstruct>(CapturedLabelDoStmt{}),
|
||||
construct<ExecutableConstruct>(EndDoStmtForCapturedLabelDoStmt{}),
|
||||
construct<ExecutableConstruct>(indirect(Parser<DoConstruct>{})),
|
||||
// Attempt DO statements before assignment statements for better
|
||||
// error messages in cases like "DO10I=1,(error)".
|
||||
construct<ExecutableConstruct>(statement(actionStmt)),
|
||||
construct<ExecutableConstruct>(indirect(Parser<AssociateConstruct>{})),
|
||||
construct<ExecutableConstruct>(indirect(Parser<BlockConstruct>{})),
|
||||
construct<ExecutableConstruct>(indirect(Parser<CaseConstruct>{})),
|
||||
construct<ExecutableConstruct>(indirect(Parser<ChangeTeamConstruct>{})),
|
||||
construct<ExecutableConstruct>(indirect(Parser<CriticalConstruct>{})),
|
||||
construct<ExecutableConstruct>(indirect(Parser<IfConstruct>{})),
|
||||
construct<ExecutableConstruct>(indirect(Parser<SelectRankConstruct>{})),
|
||||
construct<ExecutableConstruct>(indirect(Parser<SelectTypeConstruct>{})),
|
||||
construct<ExecutableConstruct>(indirect(whereConstruct)),
|
||||
construct<ExecutableConstruct>(indirect(forallConstruct)),
|
||||
construct<ExecutableConstruct>(indirect(ompEndLoopDirective)),
|
||||
construct<ExecutableConstruct>(indirect(openmpConstruct)),
|
||||
construct<ExecutableConstruct>(indirect(compilerDirective)))};
|
||||
|
||||
// R510 execution-part-construct ->
|
||||
// executable-construct | format-stmt | entry-stmt | data-stmt
|
||||
// Extension (PGI/Intel): also accept NAMELIST in execution part
|
||||
constexpr auto obsoleteExecutionPartConstruct{recovery(ignoredStatementPrefix >>
|
||||
fail<ExecutionPartConstruct>(
|
||||
"obsolete legacy extension is not supported"_err_en_US),
|
||||
construct<ExecutionPartConstruct>(construct<ErrorRecovery>(ok /
|
||||
statement("REDIMENSION" >> name /
|
||||
parenthesized(nonemptyList(Parser<AllocateShapeSpec>{}))))))};
|
||||
|
||||
TYPE_PARSER(recovery(
|
||||
withMessage("expected execution part construct"_err_en_US,
|
||||
CONTEXT_PARSER("execution part construct"_en_US,
|
||||
first(construct<ExecutionPartConstruct>(executableConstruct),
|
||||
construct<ExecutionPartConstruct>(
|
||||
statement(indirect(formatStmt))),
|
||||
construct<ExecutionPartConstruct>(
|
||||
statement(indirect(entryStmt))),
|
||||
construct<ExecutionPartConstruct>(
|
||||
statement(indirect(dataStmt))),
|
||||
extension<LanguageFeature::ExecutionPartNamelist>(
|
||||
construct<ExecutionPartConstruct>(
|
||||
statement(indirect(Parser<NamelistStmt>{})))),
|
||||
obsoleteExecutionPartConstruct))),
|
||||
construct<ExecutionPartConstruct>(executionPartErrorRecovery)))
|
||||
|
||||
// R509 execution-part -> executable-construct [execution-part-construct]...
|
||||
TYPE_CONTEXT_PARSER("execution part"_en_US,
|
||||
construct<ExecutionPart>(many(executionPartConstruct)))
|
||||
|
||||
// R515 action-stmt ->
|
||||
// allocate-stmt | assignment-stmt | backspace-stmt | call-stmt |
|
||||
// close-stmt | continue-stmt | cycle-stmt | deallocate-stmt |
|
||||
// endfile-stmt | error-stop-stmt | event-post-stmt | event-wait-stmt |
|
||||
// exit-stmt | fail-image-stmt | flush-stmt | form-team-stmt |
|
||||
// goto-stmt | if-stmt | inquire-stmt | lock-stmt | nullify-stmt |
|
||||
// open-stmt | pointer-assignment-stmt | print-stmt | read-stmt |
|
||||
// return-stmt | rewind-stmt | stop-stmt | sync-all-stmt |
|
||||
// sync-images-stmt | sync-memory-stmt | sync-team-stmt | unlock-stmt |
|
||||
// wait-stmt | where-stmt | write-stmt | computed-goto-stmt | forall-stmt
|
||||
// R1159 continue-stmt -> CONTINUE
|
||||
// R1163 fail-image-stmt -> FAIL IMAGE
|
||||
TYPE_PARSER(first(construct<ActionStmt>(indirect(Parser<AllocateStmt>{})),
|
||||
construct<ActionStmt>(indirect(assignmentStmt)),
|
||||
construct<ActionStmt>(indirect(pointerAssignmentStmt)),
|
||||
construct<ActionStmt>(indirect(Parser<BackspaceStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<CallStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<CloseStmt>{})),
|
||||
construct<ActionStmt>(construct<ContinueStmt>("CONTINUE"_tok)),
|
||||
construct<ActionStmt>(indirect(Parser<CycleStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<DeallocateStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<EndfileStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<EventPostStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<EventWaitStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<ExitStmt>{})),
|
||||
construct<ActionStmt>(construct<FailImageStmt>("FAIL IMAGE"_sptok)),
|
||||
construct<ActionStmt>(indirect(Parser<FlushStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<FormTeamStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<GotoStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<IfStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<InquireStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<LockStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<NullifyStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<OpenStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<PrintStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<ReadStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<ReturnStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<RewindStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<StopStmt>{})), // & error-stop-stmt
|
||||
construct<ActionStmt>(indirect(Parser<SyncAllStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<SyncImagesStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<SyncMemoryStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<SyncTeamStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<UnlockStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<WaitStmt>{})),
|
||||
construct<ActionStmt>(indirect(whereStmt)),
|
||||
construct<ActionStmt>(indirect(Parser<WriteStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<ComputedGotoStmt>{})),
|
||||
construct<ActionStmt>(indirect(forallStmt)),
|
||||
construct<ActionStmt>(indirect(Parser<ArithmeticIfStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<AssignStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<AssignedGotoStmt>{})),
|
||||
construct<ActionStmt>(indirect(Parser<PauseStmt>{}))))
|
||||
|
||||
// R1102 associate-construct -> associate-stmt block end-associate-stmt
|
||||
TYPE_CONTEXT_PARSER("ASSOCIATE construct"_en_US,
|
||||
construct<AssociateConstruct>(statement(Parser<AssociateStmt>{}), block,
|
||||
statement(Parser<EndAssociateStmt>{})))
|
||||
|
||||
// R1103 associate-stmt ->
|
||||
// [associate-construct-name :] ASSOCIATE ( association-list )
|
||||
TYPE_CONTEXT_PARSER("ASSOCIATE statement"_en_US,
|
||||
construct<AssociateStmt>(maybe(name / ":"),
|
||||
"ASSOCIATE" >> parenthesized(nonemptyList(Parser<Association>{}))))
|
||||
|
||||
// R1104 association -> associate-name => selector
|
||||
TYPE_PARSER(construct<Association>(name, "=>" >> selector))
|
||||
|
||||
// R1105 selector -> expr | variable
|
||||
TYPE_PARSER(construct<Selector>(variable) / lookAhead(","_tok || ")"_tok) ||
|
||||
construct<Selector>(expr))
|
||||
|
||||
// R1106 end-associate-stmt -> END ASSOCIATE [associate-construct-name]
|
||||
TYPE_PARSER(construct<EndAssociateStmt>(
|
||||
recovery("END ASSOCIATE" >> maybe(name), endStmtErrorRecovery)))
|
||||
|
||||
// R1107 block-construct ->
|
||||
// block-stmt [block-specification-part] block end-block-stmt
|
||||
TYPE_CONTEXT_PARSER("BLOCK construct"_en_US,
|
||||
construct<BlockConstruct>(statement(Parser<BlockStmt>{}),
|
||||
Parser<BlockSpecificationPart>{}, // can be empty
|
||||
block, statement(Parser<EndBlockStmt>{})))
|
||||
|
||||
// R1108 block-stmt -> [block-construct-name :] BLOCK
|
||||
TYPE_PARSER(construct<BlockStmt>(maybe(name / ":") / "BLOCK"))
|
||||
|
||||
// R1109 block-specification-part ->
|
||||
// [use-stmt]... [import-stmt]... [implicit-part]
|
||||
// [[declaration-construct]... specification-construct]
|
||||
// C1107 prohibits COMMON, EQUIVALENCE, INTENT, NAMELIST, OPTIONAL, VALUE,
|
||||
// and statement function definitions. C1108 prohibits SAVE /common/.
|
||||
// C1570 indirectly prohibits ENTRY. These constraints are best enforced later.
|
||||
// The odd grammar rule above would have the effect of forcing any
|
||||
// trailing FORMAT and DATA statements after the last specification-construct
|
||||
// to be recognized as part of the block-construct's block part rather than
|
||||
// its block-specification-part, a distinction without any apparent difference.
|
||||
TYPE_PARSER(construct<BlockSpecificationPart>(specificationPart))
|
||||
|
||||
// R1110 end-block-stmt -> END BLOCK [block-construct-name]
|
||||
TYPE_PARSER(construct<EndBlockStmt>(
|
||||
recovery("END BLOCK" >> maybe(name), endStmtErrorRecovery)))
|
||||
|
||||
// R1111 change-team-construct -> change-team-stmt block end-change-team-stmt
|
||||
TYPE_CONTEXT_PARSER("CHANGE TEAM construct"_en_US,
|
||||
construct<ChangeTeamConstruct>(statement(Parser<ChangeTeamStmt>{}), block,
|
||||
statement(Parser<EndChangeTeamStmt>{})))
|
||||
|
||||
// R1112 change-team-stmt ->
|
||||
// [team-construct-name :] CHANGE TEAM
|
||||
// ( team-value [, coarray-association-list] [, sync-stat-list] )
|
||||
TYPE_CONTEXT_PARSER("CHANGE TEAM statement"_en_US,
|
||||
construct<ChangeTeamStmt>(maybe(name / ":"),
|
||||
"CHANGE TEAM"_sptok >> "("_tok >> teamValue,
|
||||
defaulted("," >> nonemptyList(Parser<CoarrayAssociation>{})),
|
||||
defaulted("," >> nonemptyList(statOrErrmsg))) /
|
||||
")")
|
||||
|
||||
// R1113 coarray-association -> codimension-decl => selector
|
||||
TYPE_PARSER(
|
||||
construct<CoarrayAssociation>(Parser<CodimensionDecl>{}, "=>" >> selector))
|
||||
|
||||
// R1114 end-change-team-stmt ->
|
||||
// END TEAM [( [sync-stat-list] )] [team-construct-name]
|
||||
TYPE_CONTEXT_PARSER("END TEAM statement"_en_US,
|
||||
construct<EndChangeTeamStmt>(
|
||||
"END TEAM" >> defaulted(parenthesized(optionalList(statOrErrmsg))),
|
||||
maybe(name)))
|
||||
|
||||
// R1117 critical-stmt ->
|
||||
// [critical-construct-name :] CRITICAL [( [sync-stat-list] )]
|
||||
TYPE_CONTEXT_PARSER("CRITICAL statement"_en_US,
|
||||
construct<CriticalStmt>(maybe(name / ":"),
|
||||
"CRITICAL" >> defaulted(parenthesized(optionalList(statOrErrmsg)))))
|
||||
|
||||
// R1116 critical-construct -> critical-stmt block end-critical-stmt
|
||||
TYPE_CONTEXT_PARSER("CRITICAL construct"_en_US,
|
||||
construct<CriticalConstruct>(statement(Parser<CriticalStmt>{}), block,
|
||||
statement(Parser<EndCriticalStmt>{})))
|
||||
|
||||
// R1118 end-critical-stmt -> END CRITICAL [critical-construct-name]
|
||||
TYPE_PARSER(construct<EndCriticalStmt>(
|
||||
recovery("END CRITICAL" >> maybe(name), endStmtErrorRecovery)))
|
||||
|
||||
// R1119 do-construct -> do-stmt block end-do
|
||||
// R1120 do-stmt -> nonlabel-do-stmt | label-do-stmt
|
||||
TYPE_CONTEXT_PARSER("DO construct"_en_US,
|
||||
construct<DoConstruct>(
|
||||
statement(Parser<NonLabelDoStmt>{}) / EnterNonlabelDoConstruct{}, block,
|
||||
statement(Parser<EndDoStmt>{}) / LeaveDoConstruct{}))
|
||||
|
||||
// R1125 concurrent-header ->
|
||||
// ( [integer-type-spec ::] concurrent-control-list
|
||||
// [, scalar-mask-expr] )
|
||||
TYPE_PARSER(parenthesized(construct<ConcurrentHeader>(
|
||||
maybe(integerTypeSpec / "::"), nonemptyList(Parser<ConcurrentControl>{}),
|
||||
maybe("," >> scalarLogicalExpr))))
|
||||
|
||||
// R1126 concurrent-control ->
|
||||
// index-name = concurrent-limit : concurrent-limit [: concurrent-step]
|
||||
// R1127 concurrent-limit -> scalar-int-expr
|
||||
// R1128 concurrent-step -> scalar-int-expr
|
||||
TYPE_PARSER(construct<ConcurrentControl>(name / "=", scalarIntExpr / ":",
|
||||
scalarIntExpr, maybe(":" >> scalarIntExpr)))
|
||||
|
||||
// R1130 locality-spec ->
|
||||
// LOCAL ( variable-name-list ) | LOCAL_INIT ( variable-name-list ) |
|
||||
// SHARED ( variable-name-list ) | DEFAULT ( NONE )
|
||||
TYPE_PARSER(construct<LocalitySpec>(construct<LocalitySpec::Local>(
|
||||
"LOCAL" >> parenthesized(listOfNames))) ||
|
||||
construct<LocalitySpec>(construct<LocalitySpec::LocalInit>(
|
||||
"LOCAL_INIT"_sptok >> parenthesized(listOfNames))) ||
|
||||
construct<LocalitySpec>(construct<LocalitySpec::Shared>(
|
||||
"SHARED" >> parenthesized(listOfNames))) ||
|
||||
construct<LocalitySpec>(
|
||||
construct<LocalitySpec::DefaultNone>("DEFAULT ( NONE )"_tok)))
|
||||
|
||||
// R1123 loop-control ->
|
||||
// [,] do-variable = scalar-int-expr , scalar-int-expr
|
||||
// [, scalar-int-expr] |
|
||||
// [,] WHILE ( scalar-logical-expr ) |
|
||||
// [,] CONCURRENT concurrent-header concurrent-locality
|
||||
// R1129 concurrent-locality -> [locality-spec]...
|
||||
TYPE_CONTEXT_PARSER("loop control"_en_US,
|
||||
maybe(","_tok) >>
|
||||
(construct<LoopControl>(loopBounds(scalarExpr)) ||
|
||||
construct<LoopControl>(
|
||||
"WHILE" >> parenthesized(scalarLogicalExpr)) ||
|
||||
construct<LoopControl>(construct<LoopControl::Concurrent>(
|
||||
"CONCURRENT" >> concurrentHeader,
|
||||
many(Parser<LocalitySpec>{})))))
|
||||
|
||||
// R1121 label-do-stmt -> [do-construct-name :] DO label [loop-control]
|
||||
TYPE_CONTEXT_PARSER("label DO statement"_en_US,
|
||||
construct<LabelDoStmt>(
|
||||
maybe(name / ":"), "DO" >> label, maybe(loopControl)))
|
||||
|
||||
// R1122 nonlabel-do-stmt -> [do-construct-name :] DO [loop-control]
|
||||
TYPE_CONTEXT_PARSER("nonlabel DO statement"_en_US,
|
||||
construct<NonLabelDoStmt>(maybe(name / ":"), "DO" >> maybe(loopControl)))
|
||||
|
||||
// R1132 end-do-stmt -> END DO [do-construct-name]
|
||||
TYPE_CONTEXT_PARSER("END DO statement"_en_US,
|
||||
construct<EndDoStmt>(
|
||||
recovery("END DO" >> maybe(name), endStmtErrorRecovery)))
|
||||
|
||||
// R1133 cycle-stmt -> CYCLE [do-construct-name]
|
||||
TYPE_CONTEXT_PARSER(
|
||||
"CYCLE statement"_en_US, construct<CycleStmt>("CYCLE" >> maybe(name)))
|
||||
|
||||
// R1134 if-construct ->
|
||||
// if-then-stmt block [else-if-stmt block]...
|
||||
// [else-stmt block] end-if-stmt
|
||||
// R1135 if-then-stmt -> [if-construct-name :] IF ( scalar-logical-expr )
|
||||
// THEN R1136 else-if-stmt ->
|
||||
// ELSE IF ( scalar-logical-expr ) THEN [if-construct-name]
|
||||
// R1137 else-stmt -> ELSE [if-construct-name]
|
||||
// R1138 end-if-stmt -> END IF [if-construct-name]
|
||||
TYPE_CONTEXT_PARSER("IF construct"_en_US,
|
||||
construct<IfConstruct>(
|
||||
statement(construct<IfThenStmt>(maybe(name / ":"),
|
||||
"IF" >> parenthesized(scalarLogicalExpr) / "THEN")),
|
||||
block,
|
||||
many(construct<IfConstruct::ElseIfBlock>(
|
||||
unambiguousStatement(construct<ElseIfStmt>(
|
||||
"ELSE IF" >> parenthesized(scalarLogicalExpr),
|
||||
"THEN" >> maybe(name))),
|
||||
block)),
|
||||
maybe(construct<IfConstruct::ElseBlock>(
|
||||
statement(construct<ElseStmt>("ELSE" >> maybe(name))), block)),
|
||||
statement(construct<EndIfStmt>(
|
||||
recovery("END IF" >> maybe(name), endStmtErrorRecovery)))))
|
||||
|
||||
// R1139 if-stmt -> IF ( scalar-logical-expr ) action-stmt
|
||||
TYPE_CONTEXT_PARSER("IF statement"_en_US,
|
||||
construct<IfStmt>("IF" >> parenthesized(scalarLogicalExpr),
|
||||
unlabeledStatement(actionStmt)))
|
||||
|
||||
// R1140 case-construct ->
|
||||
// select-case-stmt [case-stmt block]... end-select-stmt
|
||||
TYPE_CONTEXT_PARSER("SELECT CASE construct"_en_US,
|
||||
construct<CaseConstruct>(statement(Parser<SelectCaseStmt>{}),
|
||||
many(construct<CaseConstruct::Case>(
|
||||
unambiguousStatement(Parser<CaseStmt>{}), block)),
|
||||
statement(endSelectStmt)))
|
||||
|
||||
// R1141 select-case-stmt -> [case-construct-name :] SELECT CASE ( case-expr
|
||||
// ) R1144 case-expr -> scalar-expr
|
||||
TYPE_CONTEXT_PARSER("SELECT CASE statement"_en_US,
|
||||
construct<SelectCaseStmt>(
|
||||
maybe(name / ":"), "SELECT CASE" >> parenthesized(scalar(expr))))
|
||||
|
||||
// R1142 case-stmt -> CASE case-selector [case-construct-name]
|
||||
TYPE_CONTEXT_PARSER("CASE statement"_en_US,
|
||||
construct<CaseStmt>("CASE" >> Parser<CaseSelector>{}, maybe(name)))
|
||||
|
||||
// R1143 end-select-stmt -> END SELECT [case-construct-name]
|
||||
// R1151 end-select-rank-stmt -> END SELECT [select-construct-name]
|
||||
// R1155 end-select-type-stmt -> END SELECT [select-construct-name]
|
||||
TYPE_PARSER(construct<EndSelectStmt>(
|
||||
recovery("END SELECT" >> maybe(name), endStmtErrorRecovery)))
|
||||
|
||||
// R1145 case-selector -> ( case-value-range-list ) | DEFAULT
|
||||
constexpr auto defaultKeyword{construct<Default>("DEFAULT"_tok)};
|
||||
TYPE_PARSER(parenthesized(construct<CaseSelector>(
|
||||
nonemptyList(Parser<CaseValueRange>{}))) ||
|
||||
construct<CaseSelector>(defaultKeyword))
|
||||
|
||||
// R1147 case-value -> scalar-constant-expr
|
||||
constexpr auto caseValue{scalar(constantExpr)};
|
||||
|
||||
// R1146 case-value-range ->
|
||||
// case-value | case-value : | : case-value | case-value : case-value
|
||||
TYPE_PARSER(construct<CaseValueRange>(construct<CaseValueRange::Range>(
|
||||
construct<std::optional<CaseValue>>(caseValue),
|
||||
":" >> maybe(caseValue))) ||
|
||||
construct<CaseValueRange>(
|
||||
construct<CaseValueRange::Range>(construct<std::optional<CaseValue>>(),
|
||||
":" >> construct<std::optional<CaseValue>>(caseValue))) ||
|
||||
construct<CaseValueRange>(caseValue))
|
||||
|
||||
// R1148 select-rank-construct ->
|
||||
// select-rank-stmt [select-rank-case-stmt block]...
|
||||
// end-select-rank-stmt
|
||||
TYPE_CONTEXT_PARSER("SELECT RANK construct"_en_US,
|
||||
construct<SelectRankConstruct>(statement(Parser<SelectRankStmt>{}),
|
||||
many(construct<SelectRankConstruct::RankCase>(
|
||||
unambiguousStatement(Parser<SelectRankCaseStmt>{}), block)),
|
||||
statement(endSelectStmt)))
|
||||
|
||||
// R1149 select-rank-stmt ->
|
||||
// [select-construct-name :] SELECT RANK
|
||||
// ( [associate-name =>] selector )
|
||||
TYPE_CONTEXT_PARSER("SELECT RANK statement"_en_US,
|
||||
construct<SelectRankStmt>(maybe(name / ":"),
|
||||
"SELECT RANK"_sptok >> "("_tok >> maybe(name / "=>"), selector / ")"))
|
||||
|
||||
// R1150 select-rank-case-stmt ->
|
||||
// RANK ( scalar-int-constant-expr ) [select-construct-name] |
|
||||
// RANK ( * ) [select-construct-name] |
|
||||
// RANK DEFAULT [select-construct-name]
|
||||
TYPE_CONTEXT_PARSER("RANK case statement"_en_US,
|
||||
"RANK" >> (construct<SelectRankCaseStmt>(
|
||||
parenthesized(construct<SelectRankCaseStmt::Rank>(
|
||||
scalarIntConstantExpr) ||
|
||||
construct<SelectRankCaseStmt::Rank>(star)) ||
|
||||
construct<SelectRankCaseStmt::Rank>(defaultKeyword),
|
||||
maybe(name))))
|
||||
|
||||
// R1152 select-type-construct ->
|
||||
// select-type-stmt [type-guard-stmt block]... end-select-type-stmt
|
||||
TYPE_CONTEXT_PARSER("SELECT TYPE construct"_en_US,
|
||||
construct<SelectTypeConstruct>(statement(Parser<SelectTypeStmt>{}),
|
||||
many(construct<SelectTypeConstruct::TypeCase>(
|
||||
unambiguousStatement(Parser<TypeGuardStmt>{}), block)),
|
||||
statement(endSelectStmt)))
|
||||
|
||||
// R1153 select-type-stmt ->
|
||||
// [select-construct-name :] SELECT TYPE
|
||||
// ( [associate-name =>] selector )
|
||||
TYPE_CONTEXT_PARSER("SELECT TYPE statement"_en_US,
|
||||
construct<SelectTypeStmt>(maybe(name / ":"),
|
||||
"SELECT TYPE (" >> maybe(name / "=>"), selector / ")"))
|
||||
|
||||
// R1154 type-guard-stmt ->
|
||||
// TYPE IS ( type-spec ) [select-construct-name] |
|
||||
// CLASS IS ( derived-type-spec ) [select-construct-name] |
|
||||
// CLASS DEFAULT [select-construct-name]
|
||||
TYPE_CONTEXT_PARSER("type guard statement"_en_US,
|
||||
construct<TypeGuardStmt>("TYPE IS"_sptok >>
|
||||
parenthesized(construct<TypeGuardStmt::Guard>(typeSpec)) ||
|
||||
"CLASS IS"_sptok >> parenthesized(construct<TypeGuardStmt::Guard>(
|
||||
derivedTypeSpec)) ||
|
||||
construct<TypeGuardStmt::Guard>("CLASS" >> defaultKeyword),
|
||||
maybe(name)))
|
||||
|
||||
// R1156 exit-stmt -> EXIT [construct-name]
|
||||
TYPE_CONTEXT_PARSER(
|
||||
"EXIT statement"_en_US, construct<ExitStmt>("EXIT" >> maybe(name)))
|
||||
|
||||
// R1157 goto-stmt -> GO TO label
|
||||
TYPE_CONTEXT_PARSER(
|
||||
"GOTO statement"_en_US, construct<GotoStmt>("GO TO" >> label))
|
||||
|
||||
// R1158 computed-goto-stmt -> GO TO ( label-list ) [,] scalar-int-expr
|
||||
TYPE_CONTEXT_PARSER("computed GOTO statement"_en_US,
|
||||
construct<ComputedGotoStmt>("GO TO" >> parenthesized(nonemptyList(label)),
|
||||
maybe(","_tok) >> scalarIntExpr))
|
||||
|
||||
// R1160 stop-stmt -> STOP [stop-code] [, QUIET = scalar-logical-expr]
|
||||
// R1161 error-stop-stmt ->
|
||||
// ERROR STOP [stop-code] [, QUIET = scalar-logical-expr]
|
||||
TYPE_CONTEXT_PARSER("STOP statement"_en_US,
|
||||
construct<StopStmt>("STOP" >> pure(StopStmt::Kind::Stop) ||
|
||||
"ERROR STOP"_sptok >> pure(StopStmt::Kind::ErrorStop),
|
||||
maybe(Parser<StopCode>{}), maybe(", QUIET =" >> scalarLogicalExpr)))
|
||||
|
||||
// R1162 stop-code -> scalar-default-char-expr | scalar-int-expr
|
||||
// The two alternatives for stop-code can't be distinguished at
|
||||
// parse time.
|
||||
TYPE_PARSER(construct<StopCode>(scalar(expr)))
|
||||
|
||||
// R1164 sync-all-stmt -> SYNC ALL [( [sync-stat-list] )]
|
||||
TYPE_CONTEXT_PARSER("SYNC ALL statement"_en_US,
|
||||
construct<SyncAllStmt>("SYNC ALL"_sptok >>
|
||||
defaulted(parenthesized(optionalList(statOrErrmsg)))))
|
||||
|
||||
// R1166 sync-images-stmt -> SYNC IMAGES ( image-set [, sync-stat-list] )
|
||||
// R1167 image-set -> int-expr | *
|
||||
TYPE_CONTEXT_PARSER("SYNC IMAGES statement"_en_US,
|
||||
"SYNC IMAGES"_sptok >> parenthesized(construct<SyncImagesStmt>(
|
||||
construct<SyncImagesStmt::ImageSet>(intExpr) ||
|
||||
construct<SyncImagesStmt::ImageSet>(star),
|
||||
defaulted("," >> nonemptyList(statOrErrmsg)))))
|
||||
|
||||
// R1168 sync-memory-stmt -> SYNC MEMORY [( [sync-stat-list] )]
|
||||
TYPE_CONTEXT_PARSER("SYNC MEMORY statement"_en_US,
|
||||
construct<SyncMemoryStmt>("SYNC MEMORY"_sptok >>
|
||||
defaulted(parenthesized(optionalList(statOrErrmsg)))))
|
||||
|
||||
// R1169 sync-team-stmt -> SYNC TEAM ( team-value [, sync-stat-list] )
|
||||
TYPE_CONTEXT_PARSER("SYNC TEAM statement"_en_US,
|
||||
construct<SyncTeamStmt>("SYNC TEAM"_sptok >> "("_tok >> teamValue,
|
||||
defaulted("," >> nonemptyList(statOrErrmsg)) / ")"))
|
||||
|
||||
// R1170 event-post-stmt -> EVENT POST ( event-variable [, sync-stat-list] )
|
||||
// R1171 event-variable -> scalar-variable
|
||||
TYPE_CONTEXT_PARSER("EVENT POST statement"_en_US,
|
||||
construct<EventPostStmt>("EVENT POST"_sptok >> "("_tok >> scalar(variable),
|
||||
defaulted("," >> nonemptyList(statOrErrmsg)) / ")"))
|
||||
|
||||
// R1172 event-wait-stmt ->
|
||||
// EVENT WAIT ( event-variable [, event-wait-spec-list] )
|
||||
TYPE_CONTEXT_PARSER("EVENT WAIT statement"_en_US,
|
||||
construct<EventWaitStmt>("EVENT WAIT"_sptok >> "("_tok >> scalar(variable),
|
||||
defaulted("," >> nonemptyList(Parser<EventWaitStmt::EventWaitSpec>{})) /
|
||||
")"))
|
||||
|
||||
// R1174 until-spec -> UNTIL_COUNT = scalar-int-expr
|
||||
constexpr auto untilSpec{"UNTIL_COUNT =" >> scalarIntExpr};
|
||||
|
||||
// R1173 event-wait-spec -> until-spec | sync-stat
|
||||
TYPE_PARSER(construct<EventWaitStmt::EventWaitSpec>(untilSpec) ||
|
||||
construct<EventWaitStmt::EventWaitSpec>(statOrErrmsg))
|
||||
|
||||
// R1177 team-variable -> scalar-variable
|
||||
constexpr auto teamVariable{scalar(variable)};
|
||||
|
||||
// R1175 form-team-stmt ->
|
||||
// FORM TEAM ( team-number , team-variable [, form-team-spec-list] )
|
||||
// R1176 team-number -> scalar-int-expr
|
||||
TYPE_CONTEXT_PARSER("FORM TEAM statement"_en_US,
|
||||
construct<FormTeamStmt>("FORM TEAM"_sptok >> "("_tok >> scalarIntExpr,
|
||||
"," >> teamVariable,
|
||||
defaulted("," >> nonemptyList(Parser<FormTeamStmt::FormTeamSpec>{})) /
|
||||
")"))
|
||||
|
||||
// R1178 form-team-spec -> NEW_INDEX = scalar-int-expr | sync-stat
|
||||
TYPE_PARSER(
|
||||
construct<FormTeamStmt::FormTeamSpec>("NEW_INDEX =" >> scalarIntExpr) ||
|
||||
construct<FormTeamStmt::FormTeamSpec>(statOrErrmsg))
|
||||
|
||||
// R1182 lock-variable -> scalar-variable
|
||||
constexpr auto lockVariable{scalar(variable)};
|
||||
|
||||
// R1179 lock-stmt -> LOCK ( lock-variable [, lock-stat-list] )
|
||||
TYPE_CONTEXT_PARSER("LOCK statement"_en_US,
|
||||
construct<LockStmt>("LOCK (" >> lockVariable,
|
||||
defaulted("," >> nonemptyList(Parser<LockStmt::LockStat>{})) / ")"))
|
||||
|
||||
// R1180 lock-stat -> ACQUIRED_LOCK = scalar-logical-variable | sync-stat
|
||||
TYPE_PARSER(
|
||||
construct<LockStmt::LockStat>("ACQUIRED_LOCK =" >> scalarLogicalVariable) ||
|
||||
construct<LockStmt::LockStat>(statOrErrmsg))
|
||||
|
||||
// R1181 unlock-stmt -> UNLOCK ( lock-variable [, sync-stat-list] )
|
||||
TYPE_CONTEXT_PARSER("UNLOCK statement"_en_US,
|
||||
construct<UnlockStmt>("UNLOCK (" >> lockVariable,
|
||||
defaulted("," >> nonemptyList(statOrErrmsg)) / ")"))
|
||||
|
||||
}
|
||||
|
|
@ -0,0 +1,520 @@
|
|||
// Copyright (c) 2018-2019, NVIDIA CORPORATION. All rights reserved.
|
||||
//
|
||||
// Licensed under the Apache License, Version 2.0 (the "License");
|
||||
// you may not use this file except in compliance with the License.
|
||||
// You may obtain a copy of the License at
|
||||
//
|
||||
// http://www.apache.org/licenses/LICENSE-2.0
|
||||
//
|
||||
// Unless required by applicable law or agreed to in writing, software
|
||||
// distributed under the License is distributed on an "AS IS" BASIS,
|
||||
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
// See the License for the specific language governing permissions and
|
||||
// limitations under the License.
|
||||
|
||||
#include "expr-parsers.h"
|
||||
#include "basic-parsers.h"
|
||||
#include "characters.h"
|
||||
#include "debug-parser.h"
|
||||
#include "misc-parsers.h"
|
||||
#include "parse-tree.h"
|
||||
#include "stmt-parser.h"
|
||||
#include "token-parsers.h"
|
||||
#include "type-parser-implementation.h"
|
||||
|
||||
namespace Fortran::parser {
|
||||
|
||||
// R764 boz-literal-constant -> binary-constant | octal-constant | hex-constant
|
||||
// R765 binary-constant -> B ' digit [digit]... ' | B " digit [digit]... "
|
||||
// R766 octal-constant -> O ' digit [digit]... ' | O " digit [digit]... "
|
||||
// R767 hex-constant ->
|
||||
// Z ' hex-digit [hex-digit]... ' | Z " hex-digit [hex-digit]... "
|
||||
// extension: X accepted for Z
|
||||
// extension: BOZX suffix accepted
|
||||
TYPE_PARSER(construct<BOZLiteralConstant>(BOZLiteral{}))
|
||||
|
||||
// R769 array-constructor -> (/ ac-spec /) | lbracket ac-spec rbracket
|
||||
TYPE_CONTEXT_PARSER("array constructor"_en_US,
|
||||
construct<ArrayConstructor>(
|
||||
"(/" >> Parser<AcSpec>{} / "/)" || bracketed(Parser<AcSpec>{})))
|
||||
|
||||
// R770 ac-spec -> type-spec :: | [type-spec ::] ac-value-list
|
||||
TYPE_PARSER(construct<AcSpec>(maybe(typeSpec / "::"),
|
||||
nonemptyList("expected array constructor values"_err_en_US,
|
||||
Parser<AcValue>{})) ||
|
||||
construct<AcSpec>(typeSpec / "::"))
|
||||
|
||||
// R773 ac-value -> expr | ac-implied-do
|
||||
TYPE_PARSER(
|
||||
// PGI/Intel extension: accept triplets in array constructors
|
||||
extension<LanguageFeature::TripletInArrayConstructor>(
|
||||
construct<AcValue>(construct<AcValue::Triplet>(scalarIntExpr,
|
||||
":" >> scalarIntExpr, maybe(":" >> scalarIntExpr)))) ||
|
||||
construct<AcValue>(indirect(expr)) ||
|
||||
construct<AcValue>(indirect(Parser<AcImpliedDo>{})))
|
||||
|
||||
// R774 ac-implied-do -> ( ac-value-list , ac-implied-do-control )
|
||||
TYPE_PARSER(parenthesized(
|
||||
construct<AcImpliedDo>(nonemptyList(Parser<AcValue>{} / lookAhead(","_tok)),
|
||||
"," >> Parser<AcImpliedDoControl>{})))
|
||||
|
||||
// R775 ac-implied-do-control ->
|
||||
// [integer-type-spec ::] ac-do-variable = scalar-int-expr ,
|
||||
// scalar-int-expr [, scalar-int-expr]
|
||||
// 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
|
||||
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>(Parser<StructureConstructor>{}),
|
||||
construct<Expr>(Parser<ArrayConstructor>{}),
|
||||
// PGI/XLF extension: COMPLEX constructor (x,y)
|
||||
extension<LanguageFeature::ComplexConstructor>(
|
||||
construct<Expr>(parenthesized(
|
||||
construct<Expr::ComplexConstructor>(expr, "," >> expr)))),
|
||||
extension<LanguageFeature::PercentLOC>(construct<Expr>("%LOC" >>
|
||||
parenthesized(construct<Expr::PercentLoc>(indirect(variable)))))))};
|
||||
|
||||
// R1002 level-1-expr -> [defined-unary-op] primary
|
||||
// TODO: Reasonable extension: permit multiple defined-unary-ops
|
||||
constexpr auto level1Expr{sourced(
|
||||
first(primary, // must come before define op to resolve .TRUE._8 ambiguity
|
||||
construct<Expr>(construct<Expr::DefinedUnary>(definedOpName, primary)),
|
||||
extension<LanguageFeature::SignedPrimary>(
|
||||
construct<Expr>(construct<Expr::UnaryPlus>("+" >> primary))),
|
||||
extension<LanguageFeature::SignedPrimary>(
|
||||
construct<Expr>(construct<Expr::Negate>("-" >> primary)))))};
|
||||
|
||||
// R1004 mult-operand -> level-1-expr [power-op mult-operand]
|
||||
// R1007 power-op -> **
|
||||
// Exponentiation (**) is Fortran's only right-associative binary operation.
|
||||
struct MultOperand {
|
||||
using resultType = Expr;
|
||||
constexpr MultOperand() {}
|
||||
static inline std::optional<Expr> Parse(ParseState &);
|
||||
};
|
||||
|
||||
static constexpr auto multOperand{sourced(MultOperand{})};
|
||||
|
||||
inline std::optional<Expr> MultOperand::Parse(ParseState &state) {
|
||||
std::optional<Expr> result{level1Expr.Parse(state)};
|
||||
if (result) {
|
||||
static constexpr auto op{attempt("**"_tok)};
|
||||
if (op.Parse(state)) {
|
||||
std::function<Expr(Expr &&)> power{[&result](Expr &&right) {
|
||||
return Expr{Expr::Power(std::move(result).value(), std::move(right))};
|
||||
}};
|
||||
return applyLambda(power, multOperand).Parse(state); // right-recursive
|
||||
}
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
// R1005 add-operand -> [add-operand mult-op] mult-operand
|
||||
// R1008 mult-op -> * | /
|
||||
// The left recursion in the grammar is implemented iteratively.
|
||||
constexpr struct AddOperand {
|
||||
using resultType = Expr;
|
||||
constexpr AddOperand() {}
|
||||
static inline std::optional<Expr> Parse(ParseState &state) {
|
||||
std::optional<Expr> result{multOperand.Parse(state)};
|
||||
if (result) {
|
||||
auto source{result->source};
|
||||
std::function<Expr(Expr &&)> multiply{[&result](Expr &&right) {
|
||||
return Expr{
|
||||
Expr::Multiply(std::move(result).value(), std::move(right))};
|
||||
}};
|
||||
std::function<Expr(Expr &&)> divide{[&result](Expr &&right) {
|
||||
return Expr{Expr::Divide(std::move(result).value(), std::move(right))};
|
||||
}};
|
||||
auto more{attempt(sourced("*" >> applyLambda(multiply, multOperand) ||
|
||||
"/" >> applyLambda(divide, multOperand)))};
|
||||
while (std::optional<Expr> next{more.Parse(state)}) {
|
||||
result = std::move(next);
|
||||
result->source.ExtendToCover(source);
|
||||
}
|
||||
}
|
||||
return result;
|
||||
}
|
||||
} addOperand;
|
||||
|
||||
// R1006 level-2-expr -> [[level-2-expr] add-op] add-operand
|
||||
// R1009 add-op -> + | -
|
||||
// These are left-recursive productions, implemented iteratively.
|
||||
// Note that standard Fortran admits a unary + or - to appear only here,
|
||||
// by means of a missing first operand; e.g., 2*-3 is valid in C but not
|
||||
// standard Fortran. We accept unary + and - to appear before any primary
|
||||
// as an extension.
|
||||
constexpr struct Level2Expr {
|
||||
using resultType = Expr;
|
||||
constexpr Level2Expr() {}
|
||||
static inline std::optional<Expr> Parse(ParseState &state) {
|
||||
static constexpr auto unary{
|
||||
sourced(
|
||||
construct<Expr>(construct<Expr::UnaryPlus>("+" >> addOperand)) ||
|
||||
construct<Expr>(construct<Expr::Negate>("-" >> addOperand))) ||
|
||||
addOperand};
|
||||
std::optional<Expr> result{unary.Parse(state)};
|
||||
if (result) {
|
||||
auto source{result->source};
|
||||
std::function<Expr(Expr &&)> add{[&result](Expr &&right) {
|
||||
return Expr{Expr::Add(std::move(result).value(), std::move(right))};
|
||||
}};
|
||||
std::function<Expr(Expr &&)> subtract{[&result](Expr &&right) {
|
||||
return Expr{
|
||||
Expr::Subtract(std::move(result).value(), std::move(right))};
|
||||
}};
|
||||
auto more{attempt(sourced("+" >> applyLambda(add, addOperand) ||
|
||||
"-" >> applyLambda(subtract, addOperand)))};
|
||||
while (std::optional<Expr> next{more.Parse(state)}) {
|
||||
result = std::move(next);
|
||||
result->source.ExtendToCover(source);
|
||||
}
|
||||
}
|
||||
return result;
|
||||
}
|
||||
} level2Expr;
|
||||
|
||||
// R1010 level-3-expr -> [level-3-expr concat-op] level-2-expr
|
||||
// R1011 concat-op -> //
|
||||
// Concatenation (//) is left-associative for parsing performance, although
|
||||
// one would never notice if it were right-associated.
|
||||
constexpr struct Level3Expr {
|
||||
using resultType = Expr;
|
||||
constexpr Level3Expr() {}
|
||||
static inline std::optional<Expr> Parse(ParseState &state) {
|
||||
std::optional<Expr> result{level2Expr.Parse(state)};
|
||||
if (result) {
|
||||
auto source{result->source};
|
||||
std::function<Expr(Expr &&)> concat{[&result](Expr &&right) {
|
||||
return Expr{Expr::Concat(std::move(result).value(), std::move(right))};
|
||||
}};
|
||||
auto more{attempt(sourced("//" >> applyLambda(concat, level2Expr)))};
|
||||
while (std::optional<Expr> next{more.Parse(state)}) {
|
||||
result = std::move(next);
|
||||
result->source.ExtendToCover(source);
|
||||
}
|
||||
}
|
||||
return result;
|
||||
}
|
||||
} level3Expr;
|
||||
|
||||
// R1012 level-4-expr -> [level-3-expr rel-op] level-3-expr
|
||||
// R1013 rel-op ->
|
||||
// .EQ. | .NE. | .LT. | .LE. | .GT. | .GE. |
|
||||
// == | /= | < | <= | > | >= @ | <>
|
||||
// N.B. relations are not recursive (i.e., LOGICAL is not ordered)
|
||||
constexpr struct Level4Expr {
|
||||
using resultType = Expr;
|
||||
constexpr Level4Expr() {}
|
||||
static inline std::optional<Expr> Parse(ParseState &state) {
|
||||
std::optional<Expr> result{level3Expr.Parse(state)};
|
||||
if (result) {
|
||||
auto source{result->source};
|
||||
std::function<Expr(Expr &&)> lt{[&result](Expr &&right) {
|
||||
return Expr{Expr::LT(std::move(result).value(), std::move(right))};
|
||||
}};
|
||||
std::function<Expr(Expr &&)> le{[&result](Expr &&right) {
|
||||
return Expr{Expr::LE(std::move(result).value(), std::move(right))};
|
||||
}};
|
||||
std::function<Expr(Expr &&)> eq{[&result](Expr &&right) {
|
||||
return Expr{Expr::EQ(std::move(result).value(), std::move(right))};
|
||||
}};
|
||||
std::function<Expr(Expr &&)> ne{[&result](Expr &&right) {
|
||||
return Expr{Expr::NE(std::move(result).value(), std::move(right))};
|
||||
}};
|
||||
std::function<Expr(Expr &&)> ge{[&result](Expr &&right) {
|
||||
return Expr{Expr::GE(std::move(result).value(), std::move(right))};
|
||||
}};
|
||||
std::function<Expr(Expr &&)> gt{[&result](Expr &&right) {
|
||||
return Expr{Expr::GT(std::move(result).value(), std::move(right))};
|
||||
}};
|
||||
auto more{attempt(
|
||||
sourced((".LT."_tok || "<"_tok) >> applyLambda(lt, level3Expr) ||
|
||||
(".LE."_tok || "<="_tok) >> applyLambda(le, level3Expr) ||
|
||||
(".EQ."_tok || "=="_tok) >> applyLambda(eq, level3Expr) ||
|
||||
(".NE."_tok || "/="_tok ||
|
||||
extension<LanguageFeature::AlternativeNE>(
|
||||
"<>"_tok /* PGI/Cray extension; Cray also has .LG. */)) >>
|
||||
applyLambda(ne, level3Expr) ||
|
||||
(".GE."_tok || ">="_tok) >> applyLambda(ge, level3Expr) ||
|
||||
(".GT."_tok || ">"_tok) >> applyLambda(gt, level3Expr)))};
|
||||
if (std::optional<Expr> next{more.Parse(state)}) {
|
||||
next->source.ExtendToCover(source);
|
||||
return next;
|
||||
}
|
||||
}
|
||||
return result;
|
||||
}
|
||||
} level4Expr;
|
||||
|
||||
// R1014 and-operand -> [not-op] level-4-expr
|
||||
// R1018 not-op -> .NOT.
|
||||
// N.B. Fortran's .NOT. binds less tightly than its comparison operators do.
|
||||
// PGI/Intel extension: accept multiple .NOT. operators
|
||||
constexpr struct AndOperand {
|
||||
using resultType = Expr;
|
||||
constexpr AndOperand() {}
|
||||
static inline std::optional<Expr> Parse(ParseState &);
|
||||
} andOperand;
|
||||
|
||||
// Match a logical operator or, optionally, its abbreviation.
|
||||
inline constexpr auto logicalOp(const char *op, const char *abbrev) {
|
||||
return TokenStringMatch{op} ||
|
||||
extension<LanguageFeature::LogicalAbbreviations>(
|
||||
TokenStringMatch{abbrev});
|
||||
}
|
||||
|
||||
inline std::optional<Expr> AndOperand::Parse(ParseState &state) {
|
||||
static constexpr auto notOp{attempt(logicalOp(".NOT.", ".N.") >> andOperand)};
|
||||
if (std::optional<Expr> negation{notOp.Parse(state)}) {
|
||||
return Expr{Expr::NOT{std::move(*negation)}};
|
||||
} else {
|
||||
return level4Expr.Parse(state);
|
||||
}
|
||||
}
|
||||
|
||||
// R1015 or-operand -> [or-operand and-op] and-operand
|
||||
// R1019 and-op -> .AND.
|
||||
// .AND. is left-associative
|
||||
constexpr struct OrOperand {
|
||||
using resultType = Expr;
|
||||
constexpr OrOperand() {}
|
||||
static inline std::optional<Expr> Parse(ParseState &state) {
|
||||
static constexpr auto operand{sourced(andOperand)};
|
||||
std::optional<Expr> result{operand.Parse(state)};
|
||||
if (result) {
|
||||
auto source{result->source};
|
||||
std::function<Expr(Expr &&)> logicalAnd{[&result](Expr &&right) {
|
||||
return Expr{Expr::AND(std::move(result).value(), std::move(right))};
|
||||
}};
|
||||
auto more{attempt(sourced(
|
||||
logicalOp(".AND.", ".A.") >> applyLambda(logicalAnd, andOperand)))};
|
||||
while (std::optional<Expr> next{more.Parse(state)}) {
|
||||
result = std::move(next);
|
||||
result->source.ExtendToCover(source);
|
||||
}
|
||||
}
|
||||
return result;
|
||||
}
|
||||
} orOperand;
|
||||
|
||||
// R1016 equiv-operand -> [equiv-operand or-op] or-operand
|
||||
// R1020 or-op -> .OR.
|
||||
// .OR. is left-associative
|
||||
constexpr struct EquivOperand {
|
||||
using resultType = Expr;
|
||||
constexpr EquivOperand() {}
|
||||
static inline std::optional<Expr> Parse(ParseState &state) {
|
||||
std::optional<Expr> result{orOperand.Parse(state)};
|
||||
if (result) {
|
||||
auto source{result->source};
|
||||
std::function<Expr(Expr &&)> logicalOr{[&result](Expr &&right) {
|
||||
return Expr{Expr::OR(std::move(result).value(), std::move(right))};
|
||||
}};
|
||||
auto more{attempt(sourced(
|
||||
logicalOp(".OR.", ".O.") >> applyLambda(logicalOr, orOperand)))};
|
||||
while (std::optional<Expr> next{more.Parse(state)}) {
|
||||
result = std::move(next);
|
||||
result->source.ExtendToCover(source);
|
||||
}
|
||||
}
|
||||
return result;
|
||||
}
|
||||
} equivOperand;
|
||||
|
||||
// R1017 level-5-expr -> [level-5-expr equiv-op] equiv-operand
|
||||
// R1021 equiv-op -> .EQV. | .NEQV.
|
||||
// Logical equivalence is left-associative.
|
||||
// Extension: .XOR. as synonym for .NEQV.
|
||||
constexpr struct Level5Expr {
|
||||
using resultType = Expr;
|
||||
constexpr Level5Expr() {}
|
||||
static inline std::optional<Expr> Parse(ParseState &state) {
|
||||
std::optional<Expr> result{equivOperand.Parse(state)};
|
||||
if (result) {
|
||||
auto source{result->source};
|
||||
std::function<Expr(Expr &&)> eqv{[&result](Expr &&right) {
|
||||
return Expr{Expr::EQV(std::move(result).value(), std::move(right))};
|
||||
}};
|
||||
std::function<Expr(Expr &&)> neqv{[&result](Expr &&right) {
|
||||
return Expr{Expr::NEQV(std::move(result).value(), std::move(right))};
|
||||
}};
|
||||
auto more{attempt(sourced(".EQV." >> applyLambda(eqv, equivOperand) ||
|
||||
(".NEQV."_tok ||
|
||||
extension<LanguageFeature::XOROperator>(
|
||||
logicalOp(".XOR.", ".X."))) >>
|
||||
applyLambda(neqv, equivOperand)))};
|
||||
while (std::optional<Expr> next{more.Parse(state)}) {
|
||||
result = std::move(next);
|
||||
result->source.ExtendToCover(source);
|
||||
}
|
||||
}
|
||||
return result;
|
||||
}
|
||||
} level5Expr;
|
||||
|
||||
// R1022 expr -> [expr defined-binary-op] level-5-expr
|
||||
// Defined binary operators associate leftwards.
|
||||
template<> std::optional<Expr> Parser<Expr>::Parse(ParseState &state) {
|
||||
std::optional<Expr> result{level5Expr.Parse(state)};
|
||||
if (result) {
|
||||
auto source{result->source};
|
||||
std::function<Expr(DefinedOpName &&, Expr &&)> defBinOp{
|
||||
[&result](DefinedOpName &&op, Expr &&right) {
|
||||
return Expr{Expr::DefinedBinary(
|
||||
std::move(op), std::move(result).value(), std::move(right))};
|
||||
}};
|
||||
auto more{
|
||||
attempt(sourced(applyLambda(defBinOp, definedOpName, level5Expr)))};
|
||||
while (std::optional<Expr> next{more.Parse(state)}) {
|
||||
result = std::move(next);
|
||||
result->source.ExtendToCover(source);
|
||||
}
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
// R1003 defined-unary-op -> . letter [letter]... .
|
||||
// R1023 defined-binary-op -> . letter [letter]... .
|
||||
// R1414 local-defined-operator -> defined-unary-op | defined-binary-op
|
||||
// R1415 use-defined-operator -> defined-unary-op | defined-binary-op
|
||||
// C1003 A defined operator must be distinct from logical literal constants
|
||||
// and intrinsic operator names; this is handled by attempting their parses
|
||||
// first, and by name resolution on their definitions, for best errors.
|
||||
// N.B. The name of the operator is captured with the dots around it.
|
||||
constexpr auto definedOpNameChar{
|
||||
letter || extension<LanguageFeature::PunctuationInNames>("$@"_ch)};
|
||||
TYPE_PARSER(
|
||||
space >> construct<DefinedOpName>(sourced("."_ch >>
|
||||
some(definedOpNameChar) >> construct<Name>() / "."_ch)))
|
||||
|
||||
// R1028 specification-expr -> scalar-int-expr
|
||||
TYPE_PARSER(construct<SpecificationExpr>(scalarIntExpr))
|
||||
|
||||
// R1032 assignment-stmt -> variable = expr
|
||||
TYPE_CONTEXT_PARSER("assignment statement"_en_US,
|
||||
construct<AssignmentStmt>(variable / "=", expr))
|
||||
|
||||
// R1033 pointer-assignment-stmt ->
|
||||
// data-pointer-object [( bounds-spec-list )] => data-target |
|
||||
// data-pointer-object ( bounds-remapping-list ) => data-target |
|
||||
// proc-pointer-object => proc-target
|
||||
// R1034 data-pointer-object ->
|
||||
// variable-name | scalar-variable % data-pointer-component-name
|
||||
// C1022 a scalar-variable shall be a data-ref
|
||||
// C1024 a data-pointer-object shall not be a coindexed object
|
||||
// R1038 proc-pointer-object -> proc-pointer-name | proc-component-ref
|
||||
//
|
||||
// A distinction can't be made at the time of the initial parse between
|
||||
// data-pointer-object and proc-pointer-object, or between data-target
|
||||
// and proc-target.
|
||||
TYPE_CONTEXT_PARSER("pointer assignment statement"_en_US,
|
||||
construct<PointerAssignmentStmt>(dataRef,
|
||||
parenthesized(nonemptyList(Parser<BoundsRemapping>{})), "=>" >> expr) ||
|
||||
construct<PointerAssignmentStmt>(dataRef,
|
||||
defaulted(parenthesized(nonemptyList(Parser<BoundsSpec>{}))),
|
||||
"=>" >> expr))
|
||||
|
||||
// R1035 bounds-spec -> lower-bound-expr :
|
||||
TYPE_PARSER(construct<BoundsSpec>(boundExpr / ":"))
|
||||
|
||||
// R1036 bounds-remapping -> lower-bound-expr : upper-bound-expr
|
||||
TYPE_PARSER(construct<BoundsRemapping>(boundExpr / ":", boundExpr))
|
||||
|
||||
// R1039 proc-component-ref -> scalar-variable % procedure-component-name
|
||||
// C1027 the scalar-variable must be a data-ref without coindices.
|
||||
TYPE_PARSER(construct<ProcComponentRef>(structureComponent))
|
||||
|
||||
// R1041 where-stmt -> WHERE ( mask-expr ) where-assignment-stmt
|
||||
// R1045 where-assignment-stmt -> assignment-stmt
|
||||
// R1046 mask-expr -> logical-expr
|
||||
TYPE_CONTEXT_PARSER("WHERE statement"_en_US,
|
||||
construct<WhereStmt>("WHERE" >> parenthesized(logicalExpr), assignmentStmt))
|
||||
|
||||
// R1042 where-construct ->
|
||||
// where-construct-stmt [where-body-construct]...
|
||||
// [masked-elsewhere-stmt [where-body-construct]...]...
|
||||
// [elsewhere-stmt [where-body-construct]...] end-where-stmt
|
||||
TYPE_CONTEXT_PARSER("WHERE construct"_en_US,
|
||||
construct<WhereConstruct>(statement(Parser<WhereConstructStmt>{}),
|
||||
many(whereBodyConstruct),
|
||||
many(construct<WhereConstruct::MaskedElsewhere>(
|
||||
statement(Parser<MaskedElsewhereStmt>{}),
|
||||
many(whereBodyConstruct))),
|
||||
maybe(construct<WhereConstruct::Elsewhere>(
|
||||
statement(Parser<ElsewhereStmt>{}), many(whereBodyConstruct))),
|
||||
statement(Parser<EndWhereStmt>{})))
|
||||
|
||||
// R1043 where-construct-stmt -> [where-construct-name :] WHERE ( mask-expr )
|
||||
TYPE_CONTEXT_PARSER("WHERE construct statement"_en_US,
|
||||
construct<WhereConstructStmt>(
|
||||
maybe(name / ":"), "WHERE" >> parenthesized(logicalExpr)))
|
||||
|
||||
// R1044 where-body-construct ->
|
||||
// where-assignment-stmt | where-stmt | where-construct
|
||||
TYPE_PARSER(construct<WhereBodyConstruct>(statement(assignmentStmt)) ||
|
||||
construct<WhereBodyConstruct>(statement(whereStmt)) ||
|
||||
construct<WhereBodyConstruct>(indirect(whereConstruct)))
|
||||
|
||||
// R1047 masked-elsewhere-stmt ->
|
||||
// ELSEWHERE ( mask-expr ) [where-construct-name]
|
||||
TYPE_CONTEXT_PARSER("masked ELSEWHERE statement"_en_US,
|
||||
construct<MaskedElsewhereStmt>(
|
||||
"ELSE WHERE" >> parenthesized(logicalExpr), maybe(name)))
|
||||
|
||||
// R1048 elsewhere-stmt -> ELSEWHERE [where-construct-name]
|
||||
TYPE_CONTEXT_PARSER("ELSEWHERE statement"_en_US,
|
||||
construct<ElsewhereStmt>("ELSE WHERE" >> maybe(name)))
|
||||
|
||||
// R1049 end-where-stmt -> ENDWHERE [where-construct-name]
|
||||
TYPE_CONTEXT_PARSER("END WHERE statement"_en_US,
|
||||
construct<EndWhereStmt>(
|
||||
recovery("END WHERE" >> maybe(name), endStmtErrorRecovery)))
|
||||
|
||||
// R1050 forall-construct ->
|
||||
// forall-construct-stmt [forall-body-construct]... end-forall-stmt
|
||||
TYPE_CONTEXT_PARSER("FORALL construct"_en_US,
|
||||
construct<ForallConstruct>(statement(Parser<ForallConstructStmt>{}),
|
||||
many(Parser<ForallBodyConstruct>{}),
|
||||
statement(Parser<EndForallStmt>{})))
|
||||
|
||||
// R1051 forall-construct-stmt ->
|
||||
// [forall-construct-name :] FORALL concurrent-header
|
||||
TYPE_CONTEXT_PARSER("FORALL construct statement"_en_US,
|
||||
construct<ForallConstructStmt>(
|
||||
maybe(name / ":"), "FORALL" >> indirect(concurrentHeader)))
|
||||
|
||||
// R1052 forall-body-construct ->
|
||||
// forall-assignment-stmt | where-stmt | where-construct |
|
||||
// forall-construct | forall-stmt
|
||||
TYPE_PARSER(construct<ForallBodyConstruct>(statement(forallAssignmentStmt)) ||
|
||||
construct<ForallBodyConstruct>(statement(whereStmt)) ||
|
||||
construct<ForallBodyConstruct>(whereConstruct) ||
|
||||
construct<ForallBodyConstruct>(indirect(forallConstruct)) ||
|
||||
construct<ForallBodyConstruct>(statement(forallStmt)))
|
||||
|
||||
// R1053 forall-assignment-stmt -> assignment-stmt | pointer-assignment-stmt
|
||||
TYPE_PARSER(construct<ForallAssignmentStmt>(assignmentStmt) ||
|
||||
construct<ForallAssignmentStmt>(pointerAssignmentStmt))
|
||||
|
||||
// R1054 end-forall-stmt -> END FORALL [forall-construct-name]
|
||||
TYPE_CONTEXT_PARSER("END FORALL statement"_en_US,
|
||||
construct<EndForallStmt>(
|
||||
recovery("END FORALL" >> maybe(name), endStmtErrorRecovery)))
|
||||
|
||||
// R1055 forall-stmt -> FORALL concurrent-header forall-assignment-stmt
|
||||
TYPE_CONTEXT_PARSER("FORALL statement"_en_US,
|
||||
construct<ForallStmt>("FORALL" >> indirect(concurrentHeader),
|
||||
unlabeledStatement(forallAssignmentStmt)))
|
||||
}
|
||||
|
|
@ -0,0 +1,111 @@
|
|||
// Copyright (c) 2018-2019, NVIDIA CORPORATION. All rights reserved.
|
||||
//
|
||||
// Licensed under the Apache License, Version 2.0 (the "License");
|
||||
// you may not use this file except in compliance with the License.
|
||||
// You may obtain a copy of the License at
|
||||
//
|
||||
// http://www.apache.org/licenses/LICENSE-2.0
|
||||
//
|
||||
// Unless required by applicable law or agreed to in writing, software
|
||||
// distributed under the License is distributed on an "AS IS" BASIS,
|
||||
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
// See the License for the specific language governing permissions and
|
||||
// limitations under the License.
|
||||
|
||||
#ifndef FORTRAN_PARSER_EXPR_PARSERS_H_
|
||||
#define FORTRAN_PARSER_EXPR_PARSERS_H_
|
||||
|
||||
#include "basic-parsers.h"
|
||||
#include "parse-tree.h"
|
||||
#include "token-parsers.h"
|
||||
#include "type-parsers.h"
|
||||
|
||||
namespace Fortran::parser {
|
||||
|
||||
// R403 scalar-xyz -> xyz
|
||||
// Also define constant-xyz, int-xyz, default-char-xyz.
|
||||
template<typename PA> inline constexpr auto scalar(const PA &p) {
|
||||
return construct<Scalar<typename PA::resultType>>(p); // scalar-p
|
||||
}
|
||||
|
||||
template<typename PA> inline constexpr auto constant(const PA &p) {
|
||||
return construct<Constant<typename PA::resultType>>(p); // constant-p
|
||||
}
|
||||
|
||||
template<typename PA> inline constexpr auto integer(const PA &p) {
|
||||
return construct<Integer<typename PA::resultType>>(p); // int-p
|
||||
}
|
||||
|
||||
template<typename PA> inline constexpr auto logical(const PA &p) {
|
||||
return construct<Logical<typename PA::resultType>>(p); // logical-p
|
||||
}
|
||||
|
||||
template<typename PA> inline constexpr auto defaultChar(const PA &p) {
|
||||
return construct<DefaultChar<typename PA::resultType>>(p); // default-char-p
|
||||
}
|
||||
|
||||
// N.B. charLiteralConstantWithoutKind does not skip preceding space.
|
||||
constexpr auto charLiteralConstantWithoutKind{
|
||||
"'"_ch >> CharLiteral<'\''>{} || "\""_ch >> CharLiteral<'"'>{}};
|
||||
|
||||
// R904 logical-variable -> variable
|
||||
// Appears only as part of scalar-logical-variable.
|
||||
constexpr auto scalarLogicalVariable{scalar(logical(variable))};
|
||||
|
||||
// R906 default-char-variable -> variable
|
||||
// Appears only as part of scalar-default-char-variable.
|
||||
constexpr auto scalarDefaultCharVariable{scalar(defaultChar(variable))};
|
||||
|
||||
// R907 int-variable -> variable
|
||||
// Appears only as part of scalar-int-variable.
|
||||
constexpr auto scalarIntVariable{scalar(integer(variable))};
|
||||
|
||||
// R930 errmsg-variable -> scalar-default-char-variable
|
||||
// R1207 iomsg-variable -> scalar-default-char-variable
|
||||
constexpr auto msgVariable{construct<MsgVariable>(scalarDefaultCharVariable)};
|
||||
|
||||
// R1024 logical-expr -> expr
|
||||
constexpr auto logicalExpr{logical(indirect(expr))};
|
||||
constexpr auto scalarLogicalExpr{scalar(logicalExpr)};
|
||||
|
||||
// R1025 default-char-expr -> expr
|
||||
constexpr auto defaultCharExpr{defaultChar(indirect(expr))};
|
||||
constexpr auto scalarDefaultCharExpr{scalar(defaultCharExpr)};
|
||||
|
||||
// R1026 int-expr -> expr
|
||||
constexpr auto intExpr{integer(indirect(expr))};
|
||||
constexpr auto scalarIntExpr{scalar(intExpr)};
|
||||
|
||||
// R1029 constant-expr -> expr
|
||||
constexpr auto constantExpr{constant(indirect(expr))};
|
||||
constexpr auto scalarExpr{scalar(indirect(expr))};
|
||||
|
||||
// R1030 default-char-constant-expr -> default-char-expr
|
||||
constexpr auto scalarDefaultCharConstantExpr{scalar(defaultChar(constantExpr))};
|
||||
|
||||
// R1031 int-constant-expr -> int-expr
|
||||
constexpr auto intConstantExpr{integer(constantExpr)};
|
||||
constexpr auto scalarIntConstantExpr{scalar(intConstantExpr)};
|
||||
|
||||
// R935 lower-bound-expr -> scalar-int-expr
|
||||
// R936 upper-bound-expr -> scalar-int-expr
|
||||
constexpr auto boundExpr{scalarIntExpr};
|
||||
|
||||
// R1115 team-value -> scalar-expr
|
||||
constexpr auto teamValue{scalar(indirect(expr))};
|
||||
|
||||
// R1124 do-variable -> scalar-int-variable-name
|
||||
constexpr auto doVariable{scalar(integer(name))};
|
||||
|
||||
// NOTE: In loop-control we allow REAL name and bounds too.
|
||||
// This means parse them without the integer constraint and check later.
|
||||
inline constexpr auto loopBounds(decltype(scalarExpr) &p) {
|
||||
return construct<LoopBounds<ScalarName, ScalarExpr>>(
|
||||
scalar(name) / "=", p / ",", p, maybe("," >> p));
|
||||
}
|
||||
template<typename PA> inline constexpr auto loopBounds(const PA &p) {
|
||||
return construct<LoopBounds<DoVariable, typename PA::resultType>>(
|
||||
doVariable / "=", p / ",", p, maybe("," >> p));
|
||||
}
|
||||
}
|
||||
#endif
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,668 @@
|
|||
// Copyright (c) 2018-2019, NVIDIA CORPORATION. All rights reserved.
|
||||
//
|
||||
// Licensed under the Apache License, Version 2.0 (the "License");
|
||||
// you may not use this file except in compliance with the License.
|
||||
// You may obtain a copy of the License at
|
||||
//
|
||||
// http://www.apache.org/licenses/LICENSE-2.0
|
||||
//
|
||||
// Unless required by applicable law or agreed to in writing, software
|
||||
// distributed under the License is distributed on an "AS IS" BASIS,
|
||||
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
// See the License for the specific language governing permissions and
|
||||
// limitations under the License.
|
||||
|
||||
#include "basic-parsers.h"
|
||||
#include "characters.h"
|
||||
#include "debug-parser.h"
|
||||
#include "expr-parsers.h"
|
||||
#include "misc-parsers.h"
|
||||
#include "parse-tree.h"
|
||||
#include "stmt-parser.h"
|
||||
#include "token-parsers.h"
|
||||
#include "type-parser-implementation.h"
|
||||
|
||||
namespace Fortran::parser {
|
||||
// R1201 io-unit -> file-unit-number | * | internal-file-variable
|
||||
// R1203 internal-file-variable -> char-variable
|
||||
// R905 char-variable -> variable
|
||||
// "char-variable" is attempted first since it's not type constrained but
|
||||
// syntactically ambiguous with "file-unit-number", which is constrained.
|
||||
TYPE_PARSER(construct<IoUnit>(variable / !"="_tok) ||
|
||||
construct<IoUnit>(fileUnitNumber) || construct<IoUnit>(star))
|
||||
|
||||
// R1202 file-unit-number -> scalar-int-expr
|
||||
TYPE_PARSER(construct<FileUnitNumber>(scalarIntExpr / !"="_tok))
|
||||
|
||||
// R1204 open-stmt -> OPEN ( connect-spec-list )
|
||||
TYPE_CONTEXT_PARSER("OPEN statement"_en_US,
|
||||
construct<OpenStmt>(
|
||||
"OPEN (" >> nonemptyList("expected connection specifications"_err_en_US,
|
||||
Parser<ConnectSpec>{}) /
|
||||
")"))
|
||||
|
||||
// R1206 file-name-expr -> scalar-default-char-expr
|
||||
constexpr auto fileNameExpr{scalarDefaultCharExpr};
|
||||
|
||||
// R1205 connect-spec ->
|
||||
// [UNIT =] file-unit-number | ACCESS = scalar-default-char-expr |
|
||||
// ACTION = scalar-default-char-expr |
|
||||
// ASYNCHRONOUS = scalar-default-char-expr |
|
||||
// BLANK = scalar-default-char-expr |
|
||||
// DECIMAL = scalar-default-char-expr |
|
||||
// DELIM = scalar-default-char-expr |
|
||||
// ENCODING = scalar-default-char-expr | ERR = label |
|
||||
// FILE = file-name-expr | FORM = scalar-default-char-expr |
|
||||
// IOMSG = iomsg-variable | IOSTAT = scalar-int-variable |
|
||||
// NEWUNIT = scalar-int-variable | PAD = scalar-default-char-expr |
|
||||
// POSITION = scalar-default-char-expr | RECL = scalar-int-expr |
|
||||
// ROUND = scalar-default-char-expr | SIGN = scalar-default-char-expr |
|
||||
// STATUS = scalar-default-char-expr
|
||||
// @ | CONVERT = scalar-default-char-variable
|
||||
// @ | DISPOSE = scalar-default-char-variable
|
||||
constexpr auto statusExpr{construct<StatusExpr>(scalarDefaultCharExpr)};
|
||||
constexpr auto errLabel{construct<ErrLabel>(label)};
|
||||
|
||||
TYPE_PARSER(first(construct<ConnectSpec>(maybe("UNIT ="_tok) >> fileUnitNumber),
|
||||
construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
|
||||
"ACCESS =" >> pure(ConnectSpec::CharExpr::Kind::Access),
|
||||
scalarDefaultCharExpr)),
|
||||
construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
|
||||
"ACTION =" >> pure(ConnectSpec::CharExpr::Kind::Action),
|
||||
scalarDefaultCharExpr)),
|
||||
construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
|
||||
"ASYNCHRONOUS =" >> pure(ConnectSpec::CharExpr::Kind::Asynchronous),
|
||||
scalarDefaultCharExpr)),
|
||||
construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
|
||||
"BLANK =" >> pure(ConnectSpec::CharExpr::Kind::Blank),
|
||||
scalarDefaultCharExpr)),
|
||||
construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
|
||||
"DECIMAL =" >> pure(ConnectSpec::CharExpr::Kind::Decimal),
|
||||
scalarDefaultCharExpr)),
|
||||
construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
|
||||
"DELIM =" >> pure(ConnectSpec::CharExpr::Kind::Delim),
|
||||
scalarDefaultCharExpr)),
|
||||
construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
|
||||
"ENCODING =" >> pure(ConnectSpec::CharExpr::Kind::Encoding),
|
||||
scalarDefaultCharExpr)),
|
||||
construct<ConnectSpec>("ERR =" >> errLabel),
|
||||
construct<ConnectSpec>("FILE =" >> fileNameExpr),
|
||||
extension<LanguageFeature::FileName>(
|
||||
construct<ConnectSpec>("NAME =" >> fileNameExpr)),
|
||||
construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
|
||||
"FORM =" >> pure(ConnectSpec::CharExpr::Kind::Form),
|
||||
scalarDefaultCharExpr)),
|
||||
construct<ConnectSpec>("IOMSG =" >> msgVariable),
|
||||
construct<ConnectSpec>("IOSTAT =" >> statVariable),
|
||||
construct<ConnectSpec>(construct<ConnectSpec::Newunit>(
|
||||
"NEWUNIT =" >> scalar(integer(variable)))),
|
||||
construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
|
||||
"PAD =" >> pure(ConnectSpec::CharExpr::Kind::Pad),
|
||||
scalarDefaultCharExpr)),
|
||||
construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
|
||||
"POSITION =" >> pure(ConnectSpec::CharExpr::Kind::Position),
|
||||
scalarDefaultCharExpr)),
|
||||
construct<ConnectSpec>(
|
||||
construct<ConnectSpec::Recl>("RECL =" >> scalarIntExpr)),
|
||||
construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
|
||||
"ROUND =" >> pure(ConnectSpec::CharExpr::Kind::Round),
|
||||
scalarDefaultCharExpr)),
|
||||
construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
|
||||
"SIGN =" >> pure(ConnectSpec::CharExpr::Kind::Sign),
|
||||
scalarDefaultCharExpr)),
|
||||
construct<ConnectSpec>("STATUS =" >> statusExpr),
|
||||
extension<LanguageFeature::Convert>(
|
||||
construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
|
||||
"CONVERT =" >> pure(ConnectSpec::CharExpr::Kind::Convert),
|
||||
scalarDefaultCharExpr))),
|
||||
extension<LanguageFeature::Dispose>(
|
||||
construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
|
||||
"DISPOSE =" >> pure(ConnectSpec::CharExpr::Kind::Dispose),
|
||||
scalarDefaultCharExpr)))))
|
||||
|
||||
// R1209 close-spec ->
|
||||
// [UNIT =] file-unit-number | IOSTAT = scalar-int-variable |
|
||||
// IOMSG = iomsg-variable | ERR = label |
|
||||
// STATUS = scalar-default-char-expr
|
||||
constexpr auto closeSpec{first(
|
||||
construct<CloseStmt::CloseSpec>(maybe("UNIT ="_tok) >> fileUnitNumber),
|
||||
construct<CloseStmt::CloseSpec>("IOSTAT =" >> statVariable),
|
||||
construct<CloseStmt::CloseSpec>("IOMSG =" >> msgVariable),
|
||||
construct<CloseStmt::CloseSpec>("ERR =" >> errLabel),
|
||||
construct<CloseStmt::CloseSpec>("STATUS =" >> statusExpr))};
|
||||
|
||||
// R1208 close-stmt -> CLOSE ( close-spec-list )
|
||||
TYPE_CONTEXT_PARSER("CLOSE statement"_en_US,
|
||||
construct<CloseStmt>("CLOSE" >> parenthesized(nonemptyList(closeSpec))))
|
||||
|
||||
// R1210 read-stmt ->
|
||||
// READ ( io-control-spec-list ) [input-item-list] |
|
||||
// READ format [, input-item-list]
|
||||
constexpr auto inputItemList{
|
||||
extension<LanguageFeature::IOListLeadingComma>(
|
||||
some("," >> inputItem)) || // legacy extension: leading comma
|
||||
optionalList(inputItem)};
|
||||
|
||||
TYPE_CONTEXT_PARSER("READ statement"_en_US,
|
||||
construct<ReadStmt>("READ (" >>
|
||||
construct<std::optional<IoUnit>>(maybe("UNIT ="_tok) >> ioUnit),
|
||||
"," >> construct<std::optional<Format>>(format),
|
||||
defaulted("," >> nonemptyList(ioControlSpec)) / ")", inputItemList) ||
|
||||
construct<ReadStmt>(
|
||||
"READ (" >> construct<std::optional<IoUnit>>(ioUnit),
|
||||
construct<std::optional<Format>>(),
|
||||
defaulted("," >> nonemptyList(ioControlSpec)) / ")",
|
||||
inputItemList) ||
|
||||
construct<ReadStmt>("READ" >> construct<std::optional<IoUnit>>(),
|
||||
construct<std::optional<Format>>(),
|
||||
parenthesized(nonemptyList(ioControlSpec)), inputItemList) ||
|
||||
construct<ReadStmt>("READ" >> construct<std::optional<IoUnit>>(),
|
||||
construct<std::optional<Format>>(format),
|
||||
construct<std::list<IoControlSpec>>(), many("," >> inputItem)))
|
||||
|
||||
// R1214 id-variable -> scalar-int-variable
|
||||
constexpr auto idVariable{construct<IdVariable>(scalarIntVariable)};
|
||||
|
||||
// R1213 io-control-spec ->
|
||||
// [UNIT =] io-unit | [FMT =] format | [NML =] namelist-group-name |
|
||||
// ADVANCE = scalar-default-char-expr |
|
||||
// ASYNCHRONOUS = scalar-default-char-constant-expr |
|
||||
// BLANK = scalar-default-char-expr |
|
||||
// DECIMAL = scalar-default-char-expr |
|
||||
// DELIM = scalar-default-char-expr | END = label | EOR = label |
|
||||
// ERR = label | ID = id-variable | IOMSG = iomsg-variable |
|
||||
// IOSTAT = scalar-int-variable | PAD = scalar-default-char-expr |
|
||||
// POS = scalar-int-expr | REC = scalar-int-expr |
|
||||
// ROUND = scalar-default-char-expr | SIGN = scalar-default-char-expr |
|
||||
// SIZE = scalar-int-variable
|
||||
constexpr auto endLabel{construct<EndLabel>(label)};
|
||||
constexpr auto eorLabel{construct<EorLabel>(label)};
|
||||
TYPE_PARSER(first(construct<IoControlSpec>("UNIT =" >> ioUnit),
|
||||
construct<IoControlSpec>("FMT =" >> format),
|
||||
construct<IoControlSpec>("NML =" >> name),
|
||||
construct<IoControlSpec>(
|
||||
"ADVANCE =" >> construct<IoControlSpec::CharExpr>(
|
||||
pure(IoControlSpec::CharExpr::Kind::Advance),
|
||||
scalarDefaultCharExpr)),
|
||||
construct<IoControlSpec>(construct<IoControlSpec::Asynchronous>(
|
||||
"ASYNCHRONOUS =" >> scalarDefaultCharConstantExpr)),
|
||||
construct<IoControlSpec>("BLANK =" >>
|
||||
construct<IoControlSpec::CharExpr>(
|
||||
pure(IoControlSpec::CharExpr::Kind::Blank), scalarDefaultCharExpr)),
|
||||
construct<IoControlSpec>(
|
||||
"DECIMAL =" >> construct<IoControlSpec::CharExpr>(
|
||||
pure(IoControlSpec::CharExpr::Kind::Decimal),
|
||||
scalarDefaultCharExpr)),
|
||||
construct<IoControlSpec>("DELIM =" >>
|
||||
construct<IoControlSpec::CharExpr>(
|
||||
pure(IoControlSpec::CharExpr::Kind::Delim), scalarDefaultCharExpr)),
|
||||
construct<IoControlSpec>("END =" >> endLabel),
|
||||
construct<IoControlSpec>("EOR =" >> eorLabel),
|
||||
construct<IoControlSpec>("ERR =" >> errLabel),
|
||||
construct<IoControlSpec>("ID =" >> idVariable),
|
||||
construct<IoControlSpec>("IOMSG = " >> msgVariable),
|
||||
construct<IoControlSpec>("IOSTAT = " >> statVariable),
|
||||
construct<IoControlSpec>("PAD =" >>
|
||||
construct<IoControlSpec::CharExpr>(
|
||||
pure(IoControlSpec::CharExpr::Kind::Pad), scalarDefaultCharExpr)),
|
||||
construct<IoControlSpec>(
|
||||
"POS =" >> construct<IoControlSpec::Pos>(scalarIntExpr)),
|
||||
construct<IoControlSpec>(
|
||||
"REC =" >> construct<IoControlSpec::Rec>(scalarIntExpr)),
|
||||
construct<IoControlSpec>("ROUND =" >>
|
||||
construct<IoControlSpec::CharExpr>(
|
||||
pure(IoControlSpec::CharExpr::Kind::Round), scalarDefaultCharExpr)),
|
||||
construct<IoControlSpec>("SIGN =" >>
|
||||
construct<IoControlSpec::CharExpr>(
|
||||
pure(IoControlSpec::CharExpr::Kind::Sign), scalarDefaultCharExpr)),
|
||||
construct<IoControlSpec>(
|
||||
"SIZE =" >> construct<IoControlSpec::Size>(scalarIntVariable))))
|
||||
|
||||
// R1211 write-stmt -> WRITE ( io-control-spec-list ) [output-item-list]
|
||||
constexpr auto outputItemList{
|
||||
extension<LanguageFeature::IOListLeadingComma>(
|
||||
some("," >> outputItem)) || // legacy: allow leading comma
|
||||
optionalList(outputItem)};
|
||||
|
||||
TYPE_CONTEXT_PARSER("WRITE statement"_en_US,
|
||||
construct<WriteStmt>("WRITE (" >>
|
||||
construct<std::optional<IoUnit>>(maybe("UNIT ="_tok) >> ioUnit),
|
||||
"," >> construct<std::optional<Format>>(format),
|
||||
defaulted("," >> nonemptyList(ioControlSpec)) / ")", outputItemList) ||
|
||||
construct<WriteStmt>(
|
||||
"WRITE (" >> construct<std::optional<IoUnit>>(ioUnit),
|
||||
construct<std::optional<Format>>(),
|
||||
defaulted("," >> nonemptyList(ioControlSpec)) / ")",
|
||||
outputItemList) ||
|
||||
construct<WriteStmt>("WRITE" >> construct<std::optional<IoUnit>>(),
|
||||
construct<std::optional<Format>>(),
|
||||
parenthesized(nonemptyList(ioControlSpec)), outputItemList))
|
||||
|
||||
// R1212 print-stmt PRINT format [, output-item-list]
|
||||
TYPE_CONTEXT_PARSER("PRINT statement"_en_US,
|
||||
construct<PrintStmt>(
|
||||
"PRINT" >> format, defaulted("," >> nonemptyList(outputItem))))
|
||||
|
||||
// R1215 format -> default-char-expr | label | *
|
||||
TYPE_PARSER(construct<Format>(label / !"_."_ch) ||
|
||||
construct<Format>(defaultCharExpr / !"="_tok) || construct<Format>(star))
|
||||
|
||||
// R1216 input-item -> variable | io-implied-do
|
||||
TYPE_PARSER(construct<InputItem>(variable) ||
|
||||
construct<InputItem>(indirect(inputImpliedDo)))
|
||||
|
||||
// R1217 output-item -> expr | io-implied-do
|
||||
TYPE_PARSER(construct<OutputItem>(expr) ||
|
||||
construct<OutputItem>(indirect(outputImpliedDo)))
|
||||
|
||||
// R1220 io-implied-do-control ->
|
||||
// do-variable = scalar-int-expr , scalar-int-expr [, scalar-int-expr]
|
||||
constexpr auto ioImpliedDoControl{loopBounds(scalarIntExpr)};
|
||||
|
||||
// R1218 io-implied-do -> ( io-implied-do-object-list , io-implied-do-control )
|
||||
// R1219 io-implied-do-object -> input-item | output-item
|
||||
TYPE_CONTEXT_PARSER("input implied DO"_en_US,
|
||||
parenthesized(
|
||||
construct<InputImpliedDo>(nonemptyList(inputItem / lookAhead(","_tok)),
|
||||
"," >> ioImpliedDoControl)))
|
||||
TYPE_CONTEXT_PARSER("output implied DO"_en_US,
|
||||
parenthesized(construct<OutputImpliedDo>(
|
||||
nonemptyList(outputItem / lookAhead(","_tok)),
|
||||
"," >> ioImpliedDoControl)))
|
||||
|
||||
// R1222 wait-stmt -> WAIT ( wait-spec-list )
|
||||
TYPE_CONTEXT_PARSER("WAIT statement"_en_US,
|
||||
"WAIT" >>
|
||||
parenthesized(construct<WaitStmt>(nonemptyList(Parser<WaitSpec>{}))))
|
||||
|
||||
// R1223 wait-spec ->
|
||||
// [UNIT =] file-unit-number | END = label | EOR = label | ERR = label |
|
||||
// ID = scalar-int-expr | IOMSG = iomsg-variable |
|
||||
// IOSTAT = scalar-int-variable
|
||||
constexpr auto idExpr{construct<IdExpr>(scalarIntExpr)};
|
||||
|
||||
TYPE_PARSER(first(construct<WaitSpec>(maybe("UNIT ="_tok) >> fileUnitNumber),
|
||||
construct<WaitSpec>("END =" >> endLabel),
|
||||
construct<WaitSpec>("EOR =" >> eorLabel),
|
||||
construct<WaitSpec>("ERR =" >> errLabel),
|
||||
construct<WaitSpec>("ID =" >> idExpr),
|
||||
construct<WaitSpec>("IOMSG =" >> msgVariable),
|
||||
construct<WaitSpec>("IOSTAT =" >> statVariable)))
|
||||
|
||||
template<typename A> common::IfNoLvalue<std::list<A>, A> singletonList(A &&x) {
|
||||
std::list<A> result;
|
||||
result.push_front(std::move(x));
|
||||
return result;
|
||||
}
|
||||
constexpr auto bareUnitNumberAsList{
|
||||
applyFunction(singletonList<PositionOrFlushSpec>,
|
||||
construct<PositionOrFlushSpec>(fileUnitNumber))};
|
||||
constexpr auto positionOrFlushSpecList{
|
||||
parenthesized(nonemptyList(positionOrFlushSpec)) || bareUnitNumberAsList};
|
||||
|
||||
// R1224 backspace-stmt ->
|
||||
// BACKSPACE file-unit-number | BACKSPACE ( position-spec-list )
|
||||
TYPE_CONTEXT_PARSER("BACKSPACE statement"_en_US,
|
||||
construct<BackspaceStmt>("BACKSPACE" >> positionOrFlushSpecList))
|
||||
|
||||
// R1225 endfile-stmt ->
|
||||
// ENDFILE file-unit-number | ENDFILE ( position-spec-list )
|
||||
TYPE_CONTEXT_PARSER("ENDFILE statement"_en_US,
|
||||
construct<EndfileStmt>("ENDFILE" >> positionOrFlushSpecList))
|
||||
|
||||
// R1226 rewind-stmt -> REWIND file-unit-number | REWIND ( position-spec-list )
|
||||
TYPE_CONTEXT_PARSER("REWIND statement"_en_US,
|
||||
construct<RewindStmt>("REWIND" >> positionOrFlushSpecList))
|
||||
|
||||
// R1227 position-spec ->
|
||||
// [UNIT =] file-unit-number | IOMSG = iomsg-variable |
|
||||
// IOSTAT = scalar-int-variable | ERR = label
|
||||
// R1229 flush-spec ->
|
||||
// [UNIT =] file-unit-number | IOSTAT = scalar-int-variable |
|
||||
// IOMSG = iomsg-variable | ERR = label
|
||||
TYPE_PARSER(
|
||||
construct<PositionOrFlushSpec>(maybe("UNIT ="_tok) >> fileUnitNumber) ||
|
||||
construct<PositionOrFlushSpec>("IOMSG =" >> msgVariable) ||
|
||||
construct<PositionOrFlushSpec>("IOSTAT =" >> statVariable) ||
|
||||
construct<PositionOrFlushSpec>("ERR =" >> errLabel))
|
||||
|
||||
// R1228 flush-stmt -> FLUSH file-unit-number | FLUSH ( flush-spec-list )
|
||||
TYPE_CONTEXT_PARSER("FLUSH statement"_en_US,
|
||||
construct<FlushStmt>("FLUSH" >> positionOrFlushSpecList))
|
||||
|
||||
// R1231 inquire-spec ->
|
||||
// [UNIT =] file-unit-number | FILE = file-name-expr |
|
||||
// ACCESS = scalar-default-char-variable |
|
||||
// ACTION = scalar-default-char-variable |
|
||||
// ASYNCHRONOUS = scalar-default-char-variable |
|
||||
// BLANK = scalar-default-char-variable |
|
||||
// DECIMAL = scalar-default-char-variable |
|
||||
// DELIM = scalar-default-char-variable |
|
||||
// ENCODING = scalar-default-char-variable |
|
||||
// ERR = label | EXIST = scalar-logical-variable |
|
||||
// FORM = scalar-default-char-variable |
|
||||
// FORMATTED = scalar-default-char-variable |
|
||||
// ID = scalar-int-expr | IOMSG = iomsg-variable |
|
||||
// IOSTAT = scalar-int-variable |
|
||||
// NAME = scalar-default-char-variable |
|
||||
// NAMED = scalar-logical-variable |
|
||||
// NEXTREC = scalar-int-variable | NUMBER = scalar-int-variable |
|
||||
// OPENED = scalar-logical-variable |
|
||||
// PAD = scalar-default-char-variable |
|
||||
// PENDING = scalar-logical-variable | POS = scalar-int-variable |
|
||||
// POSITION = scalar-default-char-variable |
|
||||
// READ = scalar-default-char-variable |
|
||||
// READWRITE = scalar-default-char-variable |
|
||||
// RECL = scalar-int-variable | ROUND = scalar-default-char-variable |
|
||||
// SEQUENTIAL = scalar-default-char-variable |
|
||||
// SIGN = scalar-default-char-variable |
|
||||
// SIZE = scalar-int-variable |
|
||||
// STREAM = scalar-default-char-variable |
|
||||
// STATUS = scalar-default-char-variable |
|
||||
// WRITE = scalar-default-char-variable
|
||||
// @ | CONVERT = scalar-default-char-variable
|
||||
// | DISPOSE = scalar-default-char-variable
|
||||
TYPE_PARSER(first(construct<InquireSpec>(maybe("UNIT ="_tok) >> fileUnitNumber),
|
||||
construct<InquireSpec>("FILE =" >> fileNameExpr),
|
||||
construct<InquireSpec>(
|
||||
"ACCESS =" >> construct<InquireSpec::CharVar>(
|
||||
pure(InquireSpec::CharVar::Kind::Access),
|
||||
scalarDefaultCharVariable)),
|
||||
construct<InquireSpec>(
|
||||
"ACTION =" >> construct<InquireSpec::CharVar>(
|
||||
pure(InquireSpec::CharVar::Kind::Action),
|
||||
scalarDefaultCharVariable)),
|
||||
construct<InquireSpec>(
|
||||
"ASYNCHRONOUS =" >> construct<InquireSpec::CharVar>(
|
||||
pure(InquireSpec::CharVar::Kind::Asynchronous),
|
||||
scalarDefaultCharVariable)),
|
||||
construct<InquireSpec>("BLANK =" >>
|
||||
construct<InquireSpec::CharVar>(pure(InquireSpec::CharVar::Kind::Blank),
|
||||
scalarDefaultCharVariable)),
|
||||
construct<InquireSpec>(
|
||||
"DECIMAL =" >> construct<InquireSpec::CharVar>(
|
||||
pure(InquireSpec::CharVar::Kind::Decimal),
|
||||
scalarDefaultCharVariable)),
|
||||
construct<InquireSpec>("DELIM =" >>
|
||||
construct<InquireSpec::CharVar>(pure(InquireSpec::CharVar::Kind::Delim),
|
||||
scalarDefaultCharVariable)),
|
||||
construct<InquireSpec>(
|
||||
"DIRECT =" >> construct<InquireSpec::CharVar>(
|
||||
pure(InquireSpec::CharVar::Kind::Direct),
|
||||
scalarDefaultCharVariable)),
|
||||
construct<InquireSpec>(
|
||||
"ENCODING =" >> construct<InquireSpec::CharVar>(
|
||||
pure(InquireSpec::CharVar::Kind::Encoding),
|
||||
scalarDefaultCharVariable)),
|
||||
construct<InquireSpec>("ERR =" >> errLabel),
|
||||
construct<InquireSpec>("EXIST =" >>
|
||||
construct<InquireSpec::LogVar>(
|
||||
pure(InquireSpec::LogVar::Kind::Exist), scalarLogicalVariable)),
|
||||
construct<InquireSpec>("FORM =" >>
|
||||
construct<InquireSpec::CharVar>(
|
||||
pure(InquireSpec::CharVar::Kind::Form), scalarDefaultCharVariable)),
|
||||
construct<InquireSpec>(
|
||||
"FORMATTED =" >> construct<InquireSpec::CharVar>(
|
||||
pure(InquireSpec::CharVar::Kind::Formatted),
|
||||
scalarDefaultCharVariable)),
|
||||
construct<InquireSpec>("ID =" >> idExpr),
|
||||
construct<InquireSpec>("IOMSG =" >>
|
||||
construct<InquireSpec::CharVar>(pure(InquireSpec::CharVar::Kind::Iomsg),
|
||||
scalarDefaultCharVariable)),
|
||||
construct<InquireSpec>("IOSTAT =" >>
|
||||
construct<InquireSpec::IntVar>(pure(InquireSpec::IntVar::Kind::Iostat),
|
||||
scalar(integer(variable)))),
|
||||
construct<InquireSpec>("NAME =" >>
|
||||
construct<InquireSpec::CharVar>(
|
||||
pure(InquireSpec::CharVar::Kind::Name), scalarDefaultCharVariable)),
|
||||
construct<InquireSpec>("NAMED =" >>
|
||||
construct<InquireSpec::LogVar>(
|
||||
pure(InquireSpec::LogVar::Kind::Named), scalarLogicalVariable)),
|
||||
construct<InquireSpec>("NEXTREC =" >>
|
||||
construct<InquireSpec::IntVar>(pure(InquireSpec::IntVar::Kind::Nextrec),
|
||||
scalar(integer(variable)))),
|
||||
construct<InquireSpec>("NUMBER =" >>
|
||||
construct<InquireSpec::IntVar>(pure(InquireSpec::IntVar::Kind::Number),
|
||||
scalar(integer(variable)))),
|
||||
construct<InquireSpec>("OPENED =" >>
|
||||
construct<InquireSpec::LogVar>(
|
||||
pure(InquireSpec::LogVar::Kind::Opened), scalarLogicalVariable)),
|
||||
construct<InquireSpec>("PAD =" >>
|
||||
construct<InquireSpec::CharVar>(
|
||||
pure(InquireSpec::CharVar::Kind::Pad), scalarDefaultCharVariable)),
|
||||
construct<InquireSpec>("PENDING =" >>
|
||||
construct<InquireSpec::LogVar>(
|
||||
pure(InquireSpec::LogVar::Kind::Pending), scalarLogicalVariable)),
|
||||
construct<InquireSpec>("POS =" >>
|
||||
construct<InquireSpec::IntVar>(
|
||||
pure(InquireSpec::IntVar::Kind::Pos), scalar(integer(variable)))),
|
||||
construct<InquireSpec>(
|
||||
"POSITION =" >> construct<InquireSpec::CharVar>(
|
||||
pure(InquireSpec::CharVar::Kind::Position),
|
||||
scalarDefaultCharVariable)),
|
||||
construct<InquireSpec>("READ =" >>
|
||||
construct<InquireSpec::CharVar>(
|
||||
pure(InquireSpec::CharVar::Kind::Read), scalarDefaultCharVariable)),
|
||||
construct<InquireSpec>(
|
||||
"READWRITE =" >> construct<InquireSpec::CharVar>(
|
||||
pure(InquireSpec::CharVar::Kind::Readwrite),
|
||||
scalarDefaultCharVariable)),
|
||||
construct<InquireSpec>("RECL =" >>
|
||||
construct<InquireSpec::IntVar>(
|
||||
pure(InquireSpec::IntVar::Kind::Recl), scalar(integer(variable)))),
|
||||
construct<InquireSpec>("ROUND =" >>
|
||||
construct<InquireSpec::CharVar>(pure(InquireSpec::CharVar::Kind::Round),
|
||||
scalarDefaultCharVariable)),
|
||||
construct<InquireSpec>(
|
||||
"SEQUENTIAL =" >> construct<InquireSpec::CharVar>(
|
||||
pure(InquireSpec::CharVar::Kind::Sequential),
|
||||
scalarDefaultCharVariable)),
|
||||
construct<InquireSpec>("SIGN =" >>
|
||||
construct<InquireSpec::CharVar>(
|
||||
pure(InquireSpec::CharVar::Kind::Sign), scalarDefaultCharVariable)),
|
||||
construct<InquireSpec>("SIZE =" >>
|
||||
construct<InquireSpec::IntVar>(
|
||||
pure(InquireSpec::IntVar::Kind::Size), scalar(integer(variable)))),
|
||||
construct<InquireSpec>(
|
||||
"STREAM =" >> construct<InquireSpec::CharVar>(
|
||||
pure(InquireSpec::CharVar::Kind::Stream),
|
||||
scalarDefaultCharVariable)),
|
||||
construct<InquireSpec>(
|
||||
"STATUS =" >> construct<InquireSpec::CharVar>(
|
||||
pure(InquireSpec::CharVar::Kind::Status),
|
||||
scalarDefaultCharVariable)),
|
||||
construct<InquireSpec>(
|
||||
"UNFORMATTED =" >> construct<InquireSpec::CharVar>(
|
||||
pure(InquireSpec::CharVar::Kind::Unformatted),
|
||||
scalarDefaultCharVariable)),
|
||||
construct<InquireSpec>("WRITE =" >>
|
||||
construct<InquireSpec::CharVar>(pure(InquireSpec::CharVar::Kind::Write),
|
||||
scalarDefaultCharVariable)),
|
||||
extension<LanguageFeature::Convert>(construct<InquireSpec>(
|
||||
"CONVERT =" >> construct<InquireSpec::CharVar>(
|
||||
pure(InquireSpec::CharVar::Kind::Convert),
|
||||
scalarDefaultCharVariable))),
|
||||
extension<LanguageFeature::Dispose>(construct<InquireSpec>(
|
||||
"DISPOSE =" >> construct<InquireSpec::CharVar>(
|
||||
pure(InquireSpec::CharVar::Kind::Dispose),
|
||||
scalarDefaultCharVariable)))))
|
||||
|
||||
// R1230 inquire-stmt ->
|
||||
// INQUIRE ( inquire-spec-list ) |
|
||||
// INQUIRE ( IOLENGTH = scalar-int-variable ) output-item-list
|
||||
TYPE_CONTEXT_PARSER("INQUIRE statement"_en_US,
|
||||
"INQUIRE" >>
|
||||
(construct<InquireStmt>(
|
||||
parenthesized(nonemptyList(Parser<InquireSpec>{}))) ||
|
||||
construct<InquireStmt>(construct<InquireStmt::Iolength>(
|
||||
parenthesized("IOLENGTH =" >> scalar(integer(variable))),
|
||||
nonemptyList(outputItem)))))
|
||||
|
||||
// R1301 format-stmt -> FORMAT format-specification
|
||||
// 13.2.1 allows spaces to appear "at any point" within a format specification
|
||||
// without effect, except of course within a character string edit descriptor.
|
||||
TYPE_CONTEXT_PARSER("FORMAT statement"_en_US,
|
||||
construct<FormatStmt>("FORMAT" >> Parser<format::FormatSpecification>{}))
|
||||
|
||||
// R1321 char-string-edit-desc
|
||||
// N.B. C1313 disallows any kind parameter on the character literal.
|
||||
constexpr auto charStringEditDesc{
|
||||
space >> (charLiteralConstantWithoutKind || rawHollerithLiteral)};
|
||||
|
||||
// R1303 format-items -> format-item [[,] format-item]...
|
||||
constexpr auto formatItems{
|
||||
nonemptySeparated(space >> Parser<format::FormatItem>{}, maybe(","_tok))};
|
||||
|
||||
// R1306 r -> digit-string
|
||||
constexpr DigitStringIgnoreSpaces repeat;
|
||||
|
||||
// R1304 format-item ->
|
||||
// [r] data-edit-desc | control-edit-desc | char-string-edit-desc |
|
||||
// [r] ( format-items )
|
||||
TYPE_PARSER(construct<format::FormatItem>(
|
||||
maybe(repeat), Parser<format::IntrinsicTypeDataEditDesc>{}) ||
|
||||
construct<format::FormatItem>(
|
||||
maybe(repeat), Parser<format::DerivedTypeDataEditDesc>{}) ||
|
||||
construct<format::FormatItem>(Parser<format::ControlEditDesc>{}) ||
|
||||
construct<format::FormatItem>(charStringEditDesc) ||
|
||||
construct<format::FormatItem>(maybe(repeat), parenthesized(formatItems)))
|
||||
|
||||
// R1302 format-specification ->
|
||||
// ( [format-items] ) | ( [format-items ,] unlimited-format-item )
|
||||
// R1305 unlimited-format-item -> * ( format-items )
|
||||
// minor extension: the comma is optional before the unlimited-format-item
|
||||
TYPE_PARSER(parenthesized(construct<format::FormatSpecification>(
|
||||
defaulted(formatItems / maybe(","_tok)),
|
||||
"*" >> parenthesized(formatItems)) ||
|
||||
construct<format::FormatSpecification>(defaulted(formatItems))))
|
||||
// R1308 w -> digit-string
|
||||
// R1309 m -> digit-string
|
||||
// R1310 d -> digit-string
|
||||
// R1311 e -> digit-string
|
||||
constexpr auto width{repeat};
|
||||
constexpr auto mandatoryWidth{construct<std::optional<int>>(width)};
|
||||
constexpr auto digits{repeat};
|
||||
constexpr auto noInt{construct<std::optional<int>>()};
|
||||
constexpr auto mandatoryDigits{construct<std::optional<int>>("." >> width)};
|
||||
|
||||
// R1307 data-edit-desc ->
|
||||
// I w [. m] | B w [. m] | O w [. m] | Z w [. m] | F w . d |
|
||||
// E w . d [E e] | EN w . d [E e] | ES w . d [E e] | EX w . d [E e] |
|
||||
// G w [. d [E e]] | L w | A [w] | D w . d |
|
||||
// DT [char-literal-constant] [( v-list )]
|
||||
// (part 1 of 2)
|
||||
TYPE_PARSER(construct<format::IntrinsicTypeDataEditDesc>(
|
||||
"I" >> pure(format::IntrinsicTypeDataEditDesc::Kind::I) ||
|
||||
"B" >> pure(format::IntrinsicTypeDataEditDesc::Kind::B) ||
|
||||
"O" >> pure(format::IntrinsicTypeDataEditDesc::Kind::O) ||
|
||||
"Z" >> pure(format::IntrinsicTypeDataEditDesc::Kind::Z),
|
||||
mandatoryWidth, maybe("." >> digits), noInt) ||
|
||||
construct<format::IntrinsicTypeDataEditDesc>(
|
||||
"F" >> pure(format::IntrinsicTypeDataEditDesc::Kind::F) ||
|
||||
"D" >> pure(format::IntrinsicTypeDataEditDesc::Kind::D),
|
||||
mandatoryWidth, mandatoryDigits, noInt) ||
|
||||
construct<format::IntrinsicTypeDataEditDesc>(
|
||||
"E" >> ("N" >> pure(format::IntrinsicTypeDataEditDesc::Kind::EN) ||
|
||||
"S" >> pure(format::IntrinsicTypeDataEditDesc::Kind::ES) ||
|
||||
"X" >> pure(format::IntrinsicTypeDataEditDesc::Kind::EX) ||
|
||||
pure(format::IntrinsicTypeDataEditDesc::Kind::E)),
|
||||
mandatoryWidth, mandatoryDigits, maybe("E" >> digits)) ||
|
||||
construct<format::IntrinsicTypeDataEditDesc>(
|
||||
"G" >> pure(format::IntrinsicTypeDataEditDesc::Kind::G), mandatoryWidth,
|
||||
mandatoryDigits, maybe("E" >> digits)) ||
|
||||
construct<format::IntrinsicTypeDataEditDesc>(
|
||||
"G" >> pure(format::IntrinsicTypeDataEditDesc::Kind::G) ||
|
||||
"L" >> pure(format::IntrinsicTypeDataEditDesc::Kind::L),
|
||||
mandatoryWidth, noInt, noInt) ||
|
||||
construct<format::IntrinsicTypeDataEditDesc>(
|
||||
"A" >> pure(format::IntrinsicTypeDataEditDesc::Kind::A), maybe(width),
|
||||
noInt, noInt) ||
|
||||
// PGI/Intel extension: omitting width (and all else that follows)
|
||||
extension<LanguageFeature::AbbreviatedEditDescriptor>(
|
||||
construct<format::IntrinsicTypeDataEditDesc>(
|
||||
"I" >> pure(format::IntrinsicTypeDataEditDesc::Kind::I) ||
|
||||
("B"_tok / !letter /* don't occlude BN & BZ */) >>
|
||||
pure(format::IntrinsicTypeDataEditDesc::Kind::B) ||
|
||||
"O" >> pure(format::IntrinsicTypeDataEditDesc::Kind::O) ||
|
||||
"Z" >> pure(format::IntrinsicTypeDataEditDesc::Kind::Z) ||
|
||||
"F" >> pure(format::IntrinsicTypeDataEditDesc::Kind::F) ||
|
||||
("D"_tok / !letter /* don't occlude DT, DC, & DP */) >>
|
||||
pure(format::IntrinsicTypeDataEditDesc::Kind::D) ||
|
||||
"E" >>
|
||||
("N" >> pure(format::IntrinsicTypeDataEditDesc::Kind::EN) ||
|
||||
"S" >>
|
||||
pure(format::IntrinsicTypeDataEditDesc::Kind::ES) ||
|
||||
"X" >>
|
||||
pure(format::IntrinsicTypeDataEditDesc::Kind::EX) ||
|
||||
pure(format::IntrinsicTypeDataEditDesc::Kind::E)) ||
|
||||
"G" >> pure(format::IntrinsicTypeDataEditDesc::Kind::G) ||
|
||||
"L" >> pure(format::IntrinsicTypeDataEditDesc::Kind::L),
|
||||
noInt, noInt, noInt)))
|
||||
|
||||
// R1307 data-edit-desc (part 2 of 2)
|
||||
// R1312 v -> [sign] digit-string
|
||||
constexpr SignedDigitStringIgnoreSpaces scaleFactor;
|
||||
TYPE_PARSER(construct<format::DerivedTypeDataEditDesc>(
|
||||
"D" >> "T"_tok >> defaulted(charLiteralConstantWithoutKind),
|
||||
defaulted(parenthesized(nonemptyList(scaleFactor)))))
|
||||
|
||||
// R1314 k -> [sign] digit-string
|
||||
constexpr PositiveDigitStringIgnoreSpaces count;
|
||||
|
||||
// R1313 control-edit-desc ->
|
||||
// position-edit-desc | [r] / | : | sign-edit-desc | k P |
|
||||
// blank-interp-edit-desc | round-edit-desc | decimal-edit-desc |
|
||||
// @ \ | $
|
||||
// R1315 position-edit-desc -> T n | TL n | TR n | n X
|
||||
// R1316 n -> digit-string
|
||||
// R1317 sign-edit-desc -> SS | SP | S
|
||||
// R1318 blank-interp-edit-desc -> BN | BZ
|
||||
// R1319 round-edit-desc -> RU | RD | RZ | RN | RC | RP
|
||||
// R1320 decimal-edit-desc -> DC | DP
|
||||
TYPE_PARSER(construct<format::ControlEditDesc>(
|
||||
"T" >> ("L" >> pure(format::ControlEditDesc::Kind::TL) ||
|
||||
"R" >> pure(format::ControlEditDesc::Kind::TR) ||
|
||||
pure(format::ControlEditDesc::Kind::T)),
|
||||
count) ||
|
||||
construct<format::ControlEditDesc>(count,
|
||||
"X" >> pure(format::ControlEditDesc::Kind::X) ||
|
||||
"/" >> pure(format::ControlEditDesc::Kind::Slash)) ||
|
||||
construct<format::ControlEditDesc>(
|
||||
"X" >> pure(format::ControlEditDesc::Kind::X) ||
|
||||
"/" >> pure(format::ControlEditDesc::Kind::Slash)) ||
|
||||
construct<format::ControlEditDesc>(
|
||||
scaleFactor, "P" >> pure(format::ControlEditDesc::Kind::P)) ||
|
||||
construct<format::ControlEditDesc>(
|
||||
":" >> pure(format::ControlEditDesc::Kind::Colon)) ||
|
||||
"S" >> ("S" >> construct<format::ControlEditDesc>(
|
||||
pure(format::ControlEditDesc::Kind::SS)) ||
|
||||
"P" >> construct<format::ControlEditDesc>(
|
||||
pure(format::ControlEditDesc::Kind::SP)) ||
|
||||
construct<format::ControlEditDesc>(
|
||||
pure(format::ControlEditDesc::Kind::S))) ||
|
||||
"B" >> ("N" >> construct<format::ControlEditDesc>(
|
||||
pure(format::ControlEditDesc::Kind::BN)) ||
|
||||
"Z" >> construct<format::ControlEditDesc>(
|
||||
pure(format::ControlEditDesc::Kind::BZ))) ||
|
||||
"R" >> ("U" >> construct<format::ControlEditDesc>(
|
||||
pure(format::ControlEditDesc::Kind::RU)) ||
|
||||
"D" >> construct<format::ControlEditDesc>(
|
||||
pure(format::ControlEditDesc::Kind::RD)) ||
|
||||
"Z" >> construct<format::ControlEditDesc>(
|
||||
pure(format::ControlEditDesc::Kind::RZ)) ||
|
||||
"N" >> construct<format::ControlEditDesc>(
|
||||
pure(format::ControlEditDesc::Kind::RN)) ||
|
||||
"C" >> construct<format::ControlEditDesc>(
|
||||
pure(format::ControlEditDesc::Kind::RC)) ||
|
||||
"P" >> construct<format::ControlEditDesc>(
|
||||
pure(format::ControlEditDesc::Kind::RP))) ||
|
||||
"D" >> ("C" >> construct<format::ControlEditDesc>(
|
||||
pure(format::ControlEditDesc::Kind::DC)) ||
|
||||
"P" >> construct<format::ControlEditDesc>(
|
||||
pure(format::ControlEditDesc::Kind::DP))) ||
|
||||
extension<LanguageFeature::AdditionalFormats>(
|
||||
"$" >> construct<format::ControlEditDesc>(
|
||||
pure(format::ControlEditDesc::Kind::Dollar)) ||
|
||||
"\\" >> construct<format::ControlEditDesc>(
|
||||
pure(format::ControlEditDesc::Kind::Backslash))))
|
||||
}
|
||||
|
|
@ -0,0 +1,62 @@
|
|||
// Copyright (c) 2018-2019, NVIDIA CORPORATION. All rights reserved.
|
||||
//
|
||||
// Licensed under the Apache License, Version 2.0 (the "License");
|
||||
// you may not use this file except in compliance with the License.
|
||||
// You may obtain a copy of the License at
|
||||
//
|
||||
// http://www.apache.org/licenses/LICENSE-2.0
|
||||
//
|
||||
// Unless required by applicable law or agreed to in writing, software
|
||||
// distributed under the License is distributed on an "AS IS" BASIS,
|
||||
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
// See the License for the specific language governing permissions and
|
||||
// limitations under the License.
|
||||
|
||||
// Parser templates and constexpr parsers shared by multiple
|
||||
// per-type parser implementation source files.
|
||||
|
||||
#ifndef FORTRAN_PARSER_MISC_PARSERS_H_
|
||||
#define FORTRAN_PARSER_MISC_PARSERS_H_
|
||||
|
||||
#include "basic-parsers.h"
|
||||
#include "message.h"
|
||||
#include "parse-tree.h"
|
||||
#include "token-parsers.h"
|
||||
#include "type-parsers.h"
|
||||
|
||||
namespace Fortran::parser {
|
||||
|
||||
// R401 xzy-list -> xzy [, xzy]...
|
||||
template<typename PA> inline constexpr auto nonemptyList(const PA &p) {
|
||||
return nonemptySeparated(p, ","_tok); // p-list
|
||||
}
|
||||
|
||||
template<typename PA>
|
||||
inline constexpr auto nonemptyList(MessageFixedText error, const PA &p) {
|
||||
return withMessage(error, nonemptySeparated(p, ","_tok)); // p-list
|
||||
}
|
||||
|
||||
template<typename PA> inline constexpr auto optionalList(const PA &p) {
|
||||
return defaulted(nonemptySeparated(p, ","_tok)); // [p-list]
|
||||
}
|
||||
|
||||
// R402 xzy-name -> name
|
||||
|
||||
// R516 keyword -> name
|
||||
constexpr auto keyword{construct<Keyword>(name)};
|
||||
|
||||
// R1101 block -> [execution-part-construct]...
|
||||
constexpr auto block{many(executionPartConstruct)};
|
||||
|
||||
constexpr auto listOfNames{nonemptyList("expected names"_err_en_US, name)};
|
||||
|
||||
constexpr auto star{construct<Star>("*"_tok)};
|
||||
constexpr auto allocatable{construct<Allocatable>("ALLOCATABLE"_tok)};
|
||||
constexpr auto contiguous{construct<Contiguous>("CONTIGUOUS"_tok)};
|
||||
constexpr auto optional{construct<Optional>("OPTIONAL"_tok)};
|
||||
constexpr auto pointer{construct<Pointer>("POINTER"_tok)};
|
||||
constexpr auto protectedAttr{construct<Protected>("PROTECTED"_tok)};
|
||||
constexpr auto save{construct<Save>("SAVE"_tok)};
|
||||
|
||||
}
|
||||
#endif
|
||||
|
|
@ -12,29 +12,16 @@
|
|||
// See the License for the specific language governing permissions and
|
||||
// limitations under the License.
|
||||
|
||||
#ifndef FORTRAN_PARSER_OPENMP_GRAMMAR_H_
|
||||
#define FORTRAN_PARSER_OPENMP_GRAMMAR_H_
|
||||
|
||||
// Top-level grammar specification for OpenMP.
|
||||
// See OpenMP-4.5-grammar.txt for documentation.
|
||||
|
||||
#include "basic-parsers.h"
|
||||
#include "characters.h"
|
||||
#include "debug-parser.h"
|
||||
#include "grammar.h"
|
||||
#include "expr-parsers.h"
|
||||
#include "misc-parsers.h"
|
||||
#include "parse-tree.h"
|
||||
#include "stmt-parser.h"
|
||||
#include "token-parsers.h"
|
||||
#include "type-parsers.h"
|
||||
#include "user-state.h"
|
||||
#include <cinttypes>
|
||||
#include <cstdio>
|
||||
#include <functional>
|
||||
#include <list>
|
||||
#include <optional>
|
||||
#include <string>
|
||||
#include <tuple>
|
||||
#include <utility>
|
||||
#include "type-parser-implementation.h"
|
||||
|
||||
// OpenMP Directives and Clauses
|
||||
namespace Fortran::parser {
|
||||
|
|
@ -544,4 +531,3 @@ TYPE_PARSER(
|
|||
TYPE_PARSER(construct<OpenMPLoopConstruct>(
|
||||
Parser<OmpBeginLoopDirective>{} / endOmpLine))
|
||||
}
|
||||
#endif // FORTRAN_PARSER_OPENMP_GRAMMAR_H_
|
||||
|
|
@ -13,14 +13,12 @@
|
|||
// limitations under the License.
|
||||
|
||||
#include "parsing.h"
|
||||
#include "grammar.h"
|
||||
#include "instrumented-parser.h"
|
||||
#include "message.h"
|
||||
#include "openmp-grammar.h"
|
||||
#include "preprocessor.h"
|
||||
#include "prescan.h"
|
||||
#include "provenance.h"
|
||||
#include "source.h"
|
||||
#include "type-parsers.h"
|
||||
#include <sstream>
|
||||
|
||||
namespace Fortran::parser {
|
||||
|
|
|
|||
|
|
@ -0,0 +1,563 @@
|
|||
// Copyright (c) 2018-2019, NVIDIA CORPORATION. All rights reserved.
|
||||
//
|
||||
// Licensed under the Apache License, Version 2.0 (the "License");
|
||||
// you may not use this file except in compliance with the License.
|
||||
// You may obtain a copy of the License at
|
||||
//
|
||||
// http://www.apache.org/licenses/LICENSE-2.0
|
||||
//
|
||||
// Unless required by applicable law or agreed to in writing, software
|
||||
// distributed under the License is distributed on an "AS IS" BASIS,
|
||||
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
// See the License for the specific language governing permissions and
|
||||
// limitations under the License.
|
||||
|
||||
#include "basic-parsers.h"
|
||||
#include "characters.h"
|
||||
#include "debug-parser.h"
|
||||
#include "expr-parsers.h"
|
||||
#include "misc-parsers.h"
|
||||
#include "parse-tree.h"
|
||||
#include "stmt-parser.h"
|
||||
#include "token-parsers.h"
|
||||
#include "type-parser-implementation.h"
|
||||
|
||||
namespace Fortran::parser {
|
||||
|
||||
// R501 program -> program-unit [program-unit]...
|
||||
// This is the top-level production for the Fortran language.
|
||||
// F'2018 6.3.1 defines a program unit as a sequence of one or more lines,
|
||||
// implying that a line can't be part of two distinct program units.
|
||||
// Consequently, a program unit END statement should be the last statement
|
||||
// on its line. We parse those END statements via unterminatedStatement()
|
||||
// and then skip over the end of the line here.
|
||||
TYPE_PARSER(construct<Program>(
|
||||
extension<LanguageFeature::EmptySourceFile>(skipStuffBeforeStatement >>
|
||||
!nextCh >> defaulted(cut >> some(Parser<ProgramUnit>{}))) ||
|
||||
some(StartNewSubprogram{} >> Parser<ProgramUnit>{} / skipMany(";"_tok) /
|
||||
space / recovery(endOfLine, SkipPast<'\n'>{})) /
|
||||
skipStuffBeforeStatement))
|
||||
|
||||
// R502 program-unit ->
|
||||
// main-program | external-subprogram | module | submodule | block-data
|
||||
// R503 external-subprogram -> function-subprogram | subroutine-subprogram
|
||||
// N.B. "module" must precede "external-subprogram" in this sequence of
|
||||
// alternatives to avoid ambiguity with the MODULE keyword prefix that
|
||||
// they recognize. I.e., "modulesubroutinefoo" should start a module
|
||||
// "subroutinefoo", not a subroutine "foo" with the MODULE prefix. The
|
||||
// ambiguity is exacerbated by the extension that accepts a function
|
||||
// statement without an otherwise empty list of dummy arguments. That
|
||||
// MODULE prefix is disallowed by a constraint (C1547) in this context,
|
||||
// so the standard language is not ambiguous, but disabling its misrecognition
|
||||
// here would require context-sensitive keyword recognition or (or via)
|
||||
// variant parsers for several productions; giving the "module" production
|
||||
// priority here is a cleaner solution, though regrettably subtle. Enforcing
|
||||
// C1547 is done in semantics.
|
||||
TYPE_PARSER(construct<ProgramUnit>(indirect(Parser<Module>{})) ||
|
||||
construct<ProgramUnit>(indirect(functionSubprogram)) ||
|
||||
construct<ProgramUnit>(indirect(subroutineSubprogram)) ||
|
||||
construct<ProgramUnit>(indirect(Parser<Submodule>{})) ||
|
||||
construct<ProgramUnit>(indirect(Parser<BlockData>{})) ||
|
||||
construct<ProgramUnit>(indirect(Parser<MainProgram>{})))
|
||||
|
||||
// R504 specification-part ->
|
||||
// [use-stmt]... [import-stmt]... [implicit-part]
|
||||
// [declaration-construct]...
|
||||
TYPE_CONTEXT_PARSER("specification part"_en_US,
|
||||
construct<SpecificationPart>(many(openmpDeclarativeConstruct),
|
||||
many(statement(indirect(Parser<UseStmt>{}))),
|
||||
many(unambiguousStatement(indirect(Parser<ImportStmt>{}))),
|
||||
implicitPart, many(declarationConstruct)))
|
||||
|
||||
// R507 declaration-construct ->
|
||||
// specification-construct | data-stmt | format-stmt |
|
||||
// entry-stmt | stmt-function-stmt
|
||||
// N.B. These parsers incorporate recognition of some other statements that
|
||||
// may have been misplaced in the sequence of statements that are acceptable
|
||||
// as a specification part in order to improve error recovery.
|
||||
// Also note that many instances of specification-part in the standard grammar
|
||||
// are in contexts that impose constraints on the kinds of statements that
|
||||
// are allowed, and so we have a variant production for declaration-construct
|
||||
// that implements those constraints.
|
||||
constexpr auto execPartLookAhead{
|
||||
first(actionStmt >> ok, ompEndLoopDirective >> ok, openmpConstruct >> ok,
|
||||
"ASSOCIATE ("_tok, "BLOCK"_tok, "SELECT"_tok, "CHANGE TEAM"_sptok,
|
||||
"CRITICAL"_tok, "DO"_tok, "IF ("_tok, "WHERE ("_tok, "FORALL ("_tok)};
|
||||
constexpr auto declErrorRecovery{
|
||||
stmtErrorRecoveryStart >> !execPartLookAhead >> skipStmtErrorRecovery};
|
||||
constexpr auto misplacedSpecificationStmt{Parser<UseStmt>{} >>
|
||||
fail<DeclarationConstruct>("misplaced USE statement"_err_en_US) ||
|
||||
Parser<ImportStmt>{} >>
|
||||
fail<DeclarationConstruct>(
|
||||
"IMPORT statements must follow any USE statements and precede all other declarations"_err_en_US) ||
|
||||
Parser<ImplicitStmt>{} >>
|
||||
fail<DeclarationConstruct>(
|
||||
"IMPLICIT statements must follow USE and IMPORT and precede all other declarations"_err_en_US)};
|
||||
|
||||
TYPE_PARSER(recovery(
|
||||
withMessage("expected declaration construct"_err_en_US,
|
||||
CONTEXT_PARSER("declaration construct"_en_US,
|
||||
first(construct<DeclarationConstruct>(specificationConstruct),
|
||||
construct<DeclarationConstruct>(statement(indirect(dataStmt))),
|
||||
construct<DeclarationConstruct>(
|
||||
statement(indirect(formatStmt))),
|
||||
construct<DeclarationConstruct>(statement(indirect(entryStmt))),
|
||||
construct<DeclarationConstruct>(
|
||||
statement(indirect(Parser<StmtFunctionStmt>{}))),
|
||||
misplacedSpecificationStmt))),
|
||||
construct<DeclarationConstruct>(declErrorRecovery)))
|
||||
|
||||
// R507 variant of declaration-construct for use in limitedSpecificationPart.
|
||||
constexpr auto invalidDeclarationStmt{formatStmt >>
|
||||
fail<DeclarationConstruct>(
|
||||
"FORMAT statements are not permitted in this specification part"_err_en_US) ||
|
||||
entryStmt >>
|
||||
fail<DeclarationConstruct>(
|
||||
"ENTRY statements are not permitted in this specification part"_err_en_US)};
|
||||
|
||||
constexpr auto limitedDeclarationConstruct{recovery(
|
||||
withMessage("expected declaration construct"_err_en_US,
|
||||
inContext("declaration construct"_en_US,
|
||||
first(construct<DeclarationConstruct>(specificationConstruct),
|
||||
construct<DeclarationConstruct>(statement(indirect(dataStmt))),
|
||||
misplacedSpecificationStmt, invalidDeclarationStmt))),
|
||||
construct<DeclarationConstruct>(
|
||||
stmtErrorRecoveryStart >> skipStmtErrorRecovery))};
|
||||
|
||||
// R504 variant for many contexts (modules, submodules, BLOCK DATA subprograms,
|
||||
// and interfaces) which have constraints on their specification parts that
|
||||
// preclude FORMAT, ENTRY, and statement functions, and benefit from
|
||||
// specialized error recovery in the event of a spurious executable
|
||||
// statement.
|
||||
constexpr auto limitedSpecificationPart{inContext("specification part"_en_US,
|
||||
construct<SpecificationPart>(many(openmpDeclarativeConstruct),
|
||||
many(statement(indirect(Parser<UseStmt>{}))),
|
||||
many(unambiguousStatement(indirect(Parser<ImportStmt>{}))),
|
||||
implicitPart, many(limitedDeclarationConstruct)))};
|
||||
|
||||
// R508 specification-construct ->
|
||||
// derived-type-def | enum-def | generic-stmt | interface-block |
|
||||
// parameter-stmt | procedure-declaration-stmt |
|
||||
// other-specification-stmt | type-declaration-stmt
|
||||
TYPE_CONTEXT_PARSER("specification construct"_en_US,
|
||||
first(construct<SpecificationConstruct>(indirect(Parser<DerivedTypeDef>{})),
|
||||
construct<SpecificationConstruct>(indirect(Parser<EnumDef>{})),
|
||||
construct<SpecificationConstruct>(
|
||||
statement(indirect(Parser<GenericStmt>{}))),
|
||||
construct<SpecificationConstruct>(indirect(interfaceBlock)),
|
||||
construct<SpecificationConstruct>(statement(indirect(parameterStmt))),
|
||||
construct<SpecificationConstruct>(
|
||||
statement(indirect(oldParameterStmt))),
|
||||
construct<SpecificationConstruct>(
|
||||
statement(indirect(Parser<ProcedureDeclarationStmt>{}))),
|
||||
construct<SpecificationConstruct>(
|
||||
statement(Parser<OtherSpecificationStmt>{})),
|
||||
construct<SpecificationConstruct>(
|
||||
statement(indirect(typeDeclarationStmt))),
|
||||
construct<SpecificationConstruct>(indirect(Parser<StructureDef>{})),
|
||||
construct<SpecificationConstruct>(indirect(openmpDeclarativeConstruct)),
|
||||
construct<SpecificationConstruct>(indirect(compilerDirective))))
|
||||
|
||||
// R513 other-specification-stmt ->
|
||||
// access-stmt | allocatable-stmt | asynchronous-stmt | bind-stmt |
|
||||
// codimension-stmt | contiguous-stmt | dimension-stmt | external-stmt |
|
||||
// intent-stmt | intrinsic-stmt | namelist-stmt | optional-stmt |
|
||||
// pointer-stmt | protected-stmt | save-stmt | target-stmt |
|
||||
// volatile-stmt | value-stmt | common-stmt | equivalence-stmt
|
||||
TYPE_PARSER(first(
|
||||
construct<OtherSpecificationStmt>(indirect(Parser<AccessStmt>{})),
|
||||
construct<OtherSpecificationStmt>(indirect(Parser<AllocatableStmt>{})),
|
||||
construct<OtherSpecificationStmt>(indirect(Parser<AsynchronousStmt>{})),
|
||||
construct<OtherSpecificationStmt>(indirect(Parser<BindStmt>{})),
|
||||
construct<OtherSpecificationStmt>(indirect(Parser<CodimensionStmt>{})),
|
||||
construct<OtherSpecificationStmt>(indirect(Parser<ContiguousStmt>{})),
|
||||
construct<OtherSpecificationStmt>(indirect(Parser<DimensionStmt>{})),
|
||||
construct<OtherSpecificationStmt>(indirect(Parser<ExternalStmt>{})),
|
||||
construct<OtherSpecificationStmt>(indirect(Parser<IntentStmt>{})),
|
||||
construct<OtherSpecificationStmt>(indirect(Parser<IntrinsicStmt>{})),
|
||||
construct<OtherSpecificationStmt>(indirect(Parser<NamelistStmt>{})),
|
||||
construct<OtherSpecificationStmt>(indirect(Parser<OptionalStmt>{})),
|
||||
construct<OtherSpecificationStmt>(indirect(Parser<PointerStmt>{})),
|
||||
construct<OtherSpecificationStmt>(indirect(Parser<ProtectedStmt>{})),
|
||||
construct<OtherSpecificationStmt>(indirect(Parser<SaveStmt>{})),
|
||||
construct<OtherSpecificationStmt>(indirect(Parser<TargetStmt>{})),
|
||||
construct<OtherSpecificationStmt>(indirect(Parser<ValueStmt>{})),
|
||||
construct<OtherSpecificationStmt>(indirect(Parser<VolatileStmt>{})),
|
||||
construct<OtherSpecificationStmt>(indirect(Parser<CommonStmt>{})),
|
||||
construct<OtherSpecificationStmt>(indirect(Parser<EquivalenceStmt>{})),
|
||||
construct<OtherSpecificationStmt>(indirect(Parser<BasedPointerStmt>{}))))
|
||||
|
||||
// R1401 main-program ->
|
||||
// [program-stmt] [specification-part] [execution-part]
|
||||
// [internal-subprogram-part] end-program-stmt
|
||||
TYPE_CONTEXT_PARSER("main program"_en_US,
|
||||
construct<MainProgram>(maybe(statement(Parser<ProgramStmt>{})),
|
||||
specificationPart, executionPart, maybe(internalSubprogramPart),
|
||||
unterminatedStatement(Parser<EndProgramStmt>{})))
|
||||
|
||||
// R1402 program-stmt -> PROGRAM program-name
|
||||
// PGI allows empty parentheses after the name.
|
||||
TYPE_CONTEXT_PARSER("PROGRAM statement"_en_US,
|
||||
construct<ProgramStmt>("PROGRAM" >> name /
|
||||
maybe(extension<LanguageFeature::ProgramParentheses>(
|
||||
parenthesized(ok)))))
|
||||
|
||||
// R1403 end-program-stmt -> END [PROGRAM [program-name]]
|
||||
TYPE_CONTEXT_PARSER("END PROGRAM statement"_en_US,
|
||||
construct<EndProgramStmt>(recovery(
|
||||
"END PROGRAM" >> maybe(name) || bareEnd, progUnitEndStmtErrorRecovery)))
|
||||
|
||||
// R1404 module ->
|
||||
// module-stmt [specification-part] [module-subprogram-part]
|
||||
// end-module-stmt
|
||||
TYPE_CONTEXT_PARSER("module"_en_US,
|
||||
construct<Module>(statement(Parser<ModuleStmt>{}), limitedSpecificationPart,
|
||||
maybe(Parser<ModuleSubprogramPart>{}),
|
||||
unterminatedStatement(Parser<EndModuleStmt>{})))
|
||||
|
||||
// R1405 module-stmt -> MODULE module-name
|
||||
TYPE_CONTEXT_PARSER(
|
||||
"MODULE statement"_en_US, construct<ModuleStmt>("MODULE" >> name))
|
||||
|
||||
// R1406 end-module-stmt -> END [MODULE [module-name]]
|
||||
TYPE_CONTEXT_PARSER("END MODULE statement"_en_US,
|
||||
construct<EndModuleStmt>(recovery(
|
||||
"END MODULE" >> maybe(name) || bareEnd, progUnitEndStmtErrorRecovery)))
|
||||
|
||||
// R1407 module-subprogram-part -> contains-stmt [module-subprogram]...
|
||||
TYPE_CONTEXT_PARSER("module subprogram part"_en_US,
|
||||
construct<ModuleSubprogramPart>(statement(containsStmt),
|
||||
many(StartNewSubprogram{} >> Parser<ModuleSubprogram>{})))
|
||||
|
||||
// R1408 module-subprogram ->
|
||||
// function-subprogram | subroutine-subprogram |
|
||||
// separate-module-subprogram
|
||||
TYPE_PARSER(construct<ModuleSubprogram>(indirect(functionSubprogram)) ||
|
||||
construct<ModuleSubprogram>(indirect(subroutineSubprogram)) ||
|
||||
construct<ModuleSubprogram>(indirect(Parser<SeparateModuleSubprogram>{})))
|
||||
|
||||
// R1410 module-nature -> INTRINSIC | NON_INTRINSIC
|
||||
constexpr auto moduleNature{
|
||||
"INTRINSIC" >> pure(UseStmt::ModuleNature::Intrinsic) ||
|
||||
"NON_INTRINSIC" >> pure(UseStmt::ModuleNature::Non_Intrinsic)};
|
||||
|
||||
// R1409 use-stmt ->
|
||||
// USE [[, module-nature] ::] module-name [, rename-list] |
|
||||
// USE [[, module-nature] ::] module-name , ONLY : [only-list]
|
||||
// N.B. Lookahead to the end of the statement is necessary to resolve
|
||||
// ambiguity with assignments and statement function definitions that
|
||||
// begin with the letters "USE".
|
||||
TYPE_PARSER(construct<UseStmt>("USE" >> optionalBeforeColons(moduleNature),
|
||||
name, ", ONLY :" >> optionalList(Parser<Only>{})) ||
|
||||
construct<UseStmt>("USE" >> optionalBeforeColons(moduleNature), name,
|
||||
defaulted("," >>
|
||||
nonemptyList("expected renamings"_err_en_US, Parser<Rename>{})) /
|
||||
lookAhead(endOfStmt)))
|
||||
|
||||
// R1411 rename ->
|
||||
// local-name => use-name |
|
||||
// OPERATOR ( local-defined-operator ) =>
|
||||
// OPERATOR ( use-defined-operator )
|
||||
TYPE_PARSER(construct<Rename>("OPERATOR (" >>
|
||||
construct<Rename::Operators>(
|
||||
definedOpName / ") => OPERATOR (", definedOpName / ")")) ||
|
||||
construct<Rename>(construct<Rename::Names>(name, "=>" >> name)))
|
||||
|
||||
// R1412 only -> generic-spec | only-use-name | rename
|
||||
// R1413 only-use-name -> use-name
|
||||
TYPE_PARSER(construct<Only>(Parser<Rename>{}) ||
|
||||
construct<Only>(indirect(genericSpec)) ||
|
||||
construct<Only>(name)) // TODO: ambiguous, accepted by genericSpec
|
||||
|
||||
// R1416 submodule ->
|
||||
// submodule-stmt [specification-part] [module-subprogram-part]
|
||||
// end-submodule-stmt
|
||||
TYPE_CONTEXT_PARSER("submodule"_en_US,
|
||||
construct<Submodule>(statement(Parser<SubmoduleStmt>{}),
|
||||
limitedSpecificationPart, maybe(Parser<ModuleSubprogramPart>{}),
|
||||
unterminatedStatement(Parser<EndSubmoduleStmt>{})))
|
||||
|
||||
// R1417 submodule-stmt -> SUBMODULE ( parent-identifier ) submodule-name
|
||||
TYPE_CONTEXT_PARSER("SUBMODULE statement"_en_US,
|
||||
construct<SubmoduleStmt>(
|
||||
"SUBMODULE" >> parenthesized(Parser<ParentIdentifier>{}), name))
|
||||
|
||||
// R1418 parent-identifier -> ancestor-module-name [: parent-submodule-name]
|
||||
TYPE_PARSER(construct<ParentIdentifier>(name, maybe(":" >> name)))
|
||||
|
||||
// R1419 end-submodule-stmt -> END [SUBMODULE [submodule-name]]
|
||||
TYPE_CONTEXT_PARSER("END SUBMODULE statement"_en_US,
|
||||
construct<EndSubmoduleStmt>(
|
||||
recovery("END SUBMODULE" >> maybe(name) || bareEnd,
|
||||
progUnitEndStmtErrorRecovery)))
|
||||
|
||||
// R1420 block-data -> block-data-stmt [specification-part] end-block-data-stmt
|
||||
TYPE_CONTEXT_PARSER("BLOCK DATA subprogram"_en_US,
|
||||
construct<BlockData>(statement(Parser<BlockDataStmt>{}),
|
||||
limitedSpecificationPart,
|
||||
unterminatedStatement(Parser<EndBlockDataStmt>{})))
|
||||
|
||||
// R1421 block-data-stmt -> BLOCK DATA [block-data-name]
|
||||
TYPE_CONTEXT_PARSER("BLOCK DATA statement"_en_US,
|
||||
construct<BlockDataStmt>("BLOCK DATA" >> maybe(name)))
|
||||
|
||||
// R1422 end-block-data-stmt -> END [BLOCK DATA [block-data-name]]
|
||||
TYPE_CONTEXT_PARSER("END BLOCK DATA statement"_en_US,
|
||||
construct<EndBlockDataStmt>(
|
||||
recovery("END BLOCK DATA" >> maybe(name) || bareEnd,
|
||||
progUnitEndStmtErrorRecovery)))
|
||||
|
||||
// R1501 interface-block ->
|
||||
// interface-stmt [interface-specification]... end-interface-stmt
|
||||
TYPE_PARSER(construct<InterfaceBlock>(statement(Parser<InterfaceStmt>{}),
|
||||
many(Parser<InterfaceSpecification>{}),
|
||||
statement(Parser<EndInterfaceStmt>{})))
|
||||
|
||||
// R1502 interface-specification -> interface-body | procedure-stmt
|
||||
TYPE_PARSER(construct<InterfaceSpecification>(Parser<InterfaceBody>{}) ||
|
||||
construct<InterfaceSpecification>(statement(Parser<ProcedureStmt>{})))
|
||||
|
||||
// R1503 interface-stmt -> INTERFACE [generic-spec] | ABSTRACT INTERFACE
|
||||
TYPE_PARSER(construct<InterfaceStmt>("INTERFACE" >> maybe(genericSpec)) ||
|
||||
construct<InterfaceStmt>(construct<Abstract>("ABSTRACT INTERFACE"_sptok)))
|
||||
|
||||
// R1504 end-interface-stmt -> END INTERFACE [generic-spec]
|
||||
TYPE_PARSER(construct<EndInterfaceStmt>("END INTERFACE" >> maybe(genericSpec)))
|
||||
|
||||
// R1505 interface-body ->
|
||||
// function-stmt [specification-part] end-function-stmt |
|
||||
// subroutine-stmt [specification-part] end-subroutine-stmt
|
||||
TYPE_CONTEXT_PARSER("interface body"_en_US,
|
||||
construct<InterfaceBody>(
|
||||
construct<InterfaceBody::Function>(statement(functionStmt),
|
||||
indirect(limitedSpecificationPart), statement(endFunctionStmt))) ||
|
||||
construct<InterfaceBody>(construct<InterfaceBody::Subroutine>(
|
||||
statement(subroutineStmt), indirect(limitedSpecificationPart),
|
||||
statement(endSubroutineStmt))))
|
||||
|
||||
// R1507 specific-procedure -> procedure-name
|
||||
constexpr auto specificProcedures{
|
||||
nonemptyList("expected specific procedure names"_err_en_US, name)};
|
||||
|
||||
// R1506 procedure-stmt -> [MODULE] PROCEDURE [::] specific-procedure-list
|
||||
TYPE_PARSER(construct<ProcedureStmt>("MODULE PROCEDURE"_sptok >>
|
||||
pure(ProcedureStmt::Kind::ModuleProcedure),
|
||||
maybe("::"_tok) >> specificProcedures) ||
|
||||
construct<ProcedureStmt>(
|
||||
"PROCEDURE" >> pure(ProcedureStmt::Kind::Procedure),
|
||||
maybe("::"_tok) >> specificProcedures))
|
||||
|
||||
// R1508 generic-spec ->
|
||||
// generic-name | OPERATOR ( defined-operator ) |
|
||||
// ASSIGNMENT ( = ) | defined-io-generic-spec
|
||||
// R1509 defined-io-generic-spec ->
|
||||
// READ ( FORMATTED ) | READ ( UNFORMATTED ) |
|
||||
// WRITE ( FORMATTED ) | WRITE ( UNFORMATTED )
|
||||
TYPE_PARSER(sourced(first(construct<GenericSpec>("OPERATOR" >>
|
||||
parenthesized(Parser<DefinedOperator>{})),
|
||||
construct<GenericSpec>(
|
||||
construct<GenericSpec::Assignment>("ASSIGNMENT ( = )"_tok)),
|
||||
construct<GenericSpec>(
|
||||
construct<GenericSpec::ReadFormatted>("READ ( FORMATTED )"_tok)),
|
||||
construct<GenericSpec>(
|
||||
construct<GenericSpec::ReadUnformatted>("READ ( UNFORMATTED )"_tok)),
|
||||
construct<GenericSpec>(
|
||||
construct<GenericSpec::WriteFormatted>("WRITE ( FORMATTED )"_tok)),
|
||||
construct<GenericSpec>(
|
||||
construct<GenericSpec::WriteUnformatted>("WRITE ( UNFORMATTED )"_tok)),
|
||||
construct<GenericSpec>(name))))
|
||||
|
||||
// R1510 generic-stmt ->
|
||||
// GENERIC [, access-spec] :: generic-spec => specific-procedure-list
|
||||
TYPE_PARSER(construct<GenericStmt>("GENERIC" >> maybe("," >> accessSpec),
|
||||
"::" >> genericSpec, "=>" >> specificProcedures))
|
||||
|
||||
// R1511 external-stmt -> EXTERNAL [::] external-name-list
|
||||
TYPE_PARSER(
|
||||
"EXTERNAL" >> maybe("::"_tok) >> construct<ExternalStmt>(listOfNames))
|
||||
|
||||
// R1512 procedure-declaration-stmt ->
|
||||
// PROCEDURE ( [proc-interface] ) [[, proc-attr-spec]... ::]
|
||||
// proc-decl-list
|
||||
TYPE_PARSER("PROCEDURE" >>
|
||||
construct<ProcedureDeclarationStmt>(parenthesized(maybe(procInterface)),
|
||||
optionalListBeforeColons(Parser<ProcAttrSpec>{}),
|
||||
nonemptyList("expected procedure declarations"_err_en_US, procDecl)))
|
||||
|
||||
// R1513 proc-interface -> interface-name | declaration-type-spec
|
||||
// R1516 interface-name -> name
|
||||
// N.B. Simple names of intrinsic types (e.g., "REAL") are not
|
||||
// ambiguous here - they take precedence over derived type names
|
||||
// thanks to C1516.
|
||||
TYPE_PARSER(
|
||||
construct<ProcInterface>(declarationTypeSpec / lookAhead(")"_tok)) ||
|
||||
construct<ProcInterface>(name))
|
||||
|
||||
// R1514 proc-attr-spec ->
|
||||
// access-spec | proc-language-binding-spec | INTENT ( intent-spec ) |
|
||||
// OPTIONAL | POINTER | PROTECTED | SAVE
|
||||
TYPE_PARSER(construct<ProcAttrSpec>(accessSpec) ||
|
||||
construct<ProcAttrSpec>(languageBindingSpec) ||
|
||||
construct<ProcAttrSpec>("INTENT" >> parenthesized(intentSpec)) ||
|
||||
construct<ProcAttrSpec>(optional) || construct<ProcAttrSpec>(pointer) ||
|
||||
construct<ProcAttrSpec>(protectedAttr) || construct<ProcAttrSpec>(save))
|
||||
|
||||
// R1515 proc-decl -> procedure-entity-name [=> proc-pointer-init]
|
||||
TYPE_PARSER(construct<ProcDecl>(name, maybe("=>" >> Parser<ProcPointerInit>{})))
|
||||
|
||||
// R1517 proc-pointer-init -> null-init | initial-proc-target
|
||||
// R1518 initial-proc-target -> procedure-name
|
||||
TYPE_PARSER(
|
||||
construct<ProcPointerInit>(nullInit) || construct<ProcPointerInit>(name))
|
||||
|
||||
// R1519 intrinsic-stmt -> INTRINSIC [::] intrinsic-procedure-name-list
|
||||
TYPE_PARSER(
|
||||
"INTRINSIC" >> maybe("::"_tok) >> construct<IntrinsicStmt>(listOfNames))
|
||||
|
||||
// R1520 function-reference -> procedure-designator ( [actual-arg-spec-list] )
|
||||
TYPE_CONTEXT_PARSER("function reference"_en_US,
|
||||
construct<FunctionReference>(
|
||||
sourced(construct<Call>(Parser<ProcedureDesignator>{},
|
||||
parenthesized(optionalList(actualArgSpec))))) /
|
||||
!"["_tok)
|
||||
|
||||
// R1521 call-stmt -> CALL procedure-designator [( [actual-arg-spec-list] )]
|
||||
TYPE_PARSER(construct<CallStmt>(
|
||||
sourced(construct<Call>("CALL" >> Parser<ProcedureDesignator>{},
|
||||
defaulted(parenthesized(optionalList(actualArgSpec)))))))
|
||||
|
||||
// R1522 procedure-designator ->
|
||||
// procedure-name | proc-component-ref | data-ref % binding-name
|
||||
TYPE_PARSER(construct<ProcedureDesignator>(Parser<ProcComponentRef>{}) ||
|
||||
construct<ProcedureDesignator>(name))
|
||||
|
||||
// R1523 actual-arg-spec -> [keyword =] actual-arg
|
||||
TYPE_PARSER(construct<ActualArgSpec>(
|
||||
maybe(keyword / "=" / !"="_ch), Parser<ActualArg>{}))
|
||||
|
||||
// R1524 actual-arg ->
|
||||
// expr | variable | procedure-name | proc-component-ref |
|
||||
// alt-return-spec
|
||||
// N.B. the "procedure-name" and "proc-component-ref" alternatives can't
|
||||
// yet be distinguished from "variable", many instances of which can't be
|
||||
// distinguished from "expr" anyway (to do so would misparse structure
|
||||
// constructors and function calls as array elements).
|
||||
// Semantics sorts it all out later.
|
||||
TYPE_PARSER(construct<ActualArg>(expr) ||
|
||||
construct<ActualArg>(Parser<AltReturnSpec>{}) ||
|
||||
extension<LanguageFeature::PercentRefAndVal>(construct<ActualArg>(
|
||||
construct<ActualArg::PercentRef>("%REF" >> parenthesized(variable)))) ||
|
||||
extension<LanguageFeature::PercentRefAndVal>(construct<ActualArg>(
|
||||
construct<ActualArg::PercentVal>("%VAL" >> parenthesized(expr)))))
|
||||
|
||||
// R1525 alt-return-spec -> * label
|
||||
TYPE_PARSER(construct<AltReturnSpec>(star >> label))
|
||||
|
||||
// R1527 prefix-spec ->
|
||||
// declaration-type-spec | ELEMENTAL | IMPURE | MODULE |
|
||||
// NON_RECURSIVE | PURE | RECURSIVE
|
||||
TYPE_PARSER(first(construct<PrefixSpec>(declarationTypeSpec),
|
||||
construct<PrefixSpec>(construct<PrefixSpec::Elemental>("ELEMENTAL"_tok)),
|
||||
construct<PrefixSpec>(construct<PrefixSpec::Impure>("IMPURE"_tok)),
|
||||
construct<PrefixSpec>(construct<PrefixSpec::Module>("MODULE"_tok)),
|
||||
construct<PrefixSpec>(
|
||||
construct<PrefixSpec::Non_Recursive>("NON_RECURSIVE"_tok)),
|
||||
construct<PrefixSpec>(construct<PrefixSpec::Pure>("PURE"_tok)),
|
||||
construct<PrefixSpec>(construct<PrefixSpec::Recursive>("RECURSIVE"_tok))))
|
||||
|
||||
// R1529 function-subprogram ->
|
||||
// function-stmt [specification-part] [execution-part]
|
||||
// [internal-subprogram-part] end-function-stmt
|
||||
TYPE_CONTEXT_PARSER("FUNCTION subprogram"_en_US,
|
||||
construct<FunctionSubprogram>(statement(functionStmt), specificationPart,
|
||||
executionPart, maybe(internalSubprogramPart),
|
||||
unterminatedStatement(endFunctionStmt)))
|
||||
|
||||
// R1530 function-stmt ->
|
||||
// [prefix] FUNCTION function-name ( [dummy-arg-name-list] ) [suffix]
|
||||
// R1526 prefix -> prefix-spec [prefix-spec]...
|
||||
// R1531 dummy-arg-name -> name
|
||||
TYPE_CONTEXT_PARSER("FUNCTION statement"_en_US,
|
||||
construct<FunctionStmt>(many(prefixSpec), "FUNCTION" >> name,
|
||||
parenthesized(optionalList(name)), maybe(suffix)) ||
|
||||
extension<LanguageFeature::OmitFunctionDummies>(
|
||||
construct<FunctionStmt>( // PGI & Intel accept "FUNCTION F"
|
||||
many(prefixSpec), "FUNCTION" >> name,
|
||||
construct<std::list<Name>>(),
|
||||
construct<std::optional<Suffix>>())))
|
||||
|
||||
// R1532 suffix ->
|
||||
// proc-language-binding-spec [RESULT ( result-name )] |
|
||||
// RESULT ( result-name ) [proc-language-binding-spec]
|
||||
TYPE_PARSER(construct<Suffix>(
|
||||
languageBindingSpec, maybe("RESULT" >> parenthesized(name))) ||
|
||||
construct<Suffix>(
|
||||
"RESULT" >> parenthesized(name), maybe(languageBindingSpec)))
|
||||
|
||||
// R1533 end-function-stmt -> END [FUNCTION [function-name]]
|
||||
TYPE_PARSER(construct<EndFunctionStmt>(recovery(
|
||||
"END FUNCTION" >> maybe(name) || bareEnd, progUnitEndStmtErrorRecovery)))
|
||||
|
||||
// R1534 subroutine-subprogram ->
|
||||
// subroutine-stmt [specification-part] [execution-part]
|
||||
// [internal-subprogram-part] end-subroutine-stmt
|
||||
TYPE_CONTEXT_PARSER("SUBROUTINE subprogram"_en_US,
|
||||
construct<SubroutineSubprogram>(statement(subroutineStmt),
|
||||
specificationPart, executionPart, maybe(internalSubprogramPart),
|
||||
unterminatedStatement(endSubroutineStmt)))
|
||||
|
||||
// R1535 subroutine-stmt ->
|
||||
// [prefix] SUBROUTINE subroutine-name [( [dummy-arg-list] )
|
||||
// [proc-language-binding-spec]]
|
||||
TYPE_PARSER(
|
||||
construct<SubroutineStmt>(many(prefixSpec), "SUBROUTINE" >> name,
|
||||
parenthesized(optionalList(dummyArg)), maybe(languageBindingSpec)) ||
|
||||
construct<SubroutineStmt>(many(prefixSpec), "SUBROUTINE" >> name,
|
||||
defaulted(cut >> many(dummyArg)),
|
||||
defaulted(cut >> maybe(languageBindingSpec))))
|
||||
|
||||
// R1536 dummy-arg -> dummy-arg-name | *
|
||||
TYPE_PARSER(construct<DummyArg>(name) || construct<DummyArg>(star))
|
||||
|
||||
// R1537 end-subroutine-stmt -> END [SUBROUTINE [subroutine-name]]
|
||||
TYPE_PARSER(construct<EndSubroutineStmt>(recovery(
|
||||
"END SUBROUTINE" >> maybe(name) || bareEnd, progUnitEndStmtErrorRecovery)))
|
||||
|
||||
// R1538 separate-module-subprogram ->
|
||||
// mp-subprogram-stmt [specification-part] [execution-part]
|
||||
// [internal-subprogram-part] end-mp-subprogram-stmt
|
||||
TYPE_CONTEXT_PARSER("separate module subprogram"_en_US,
|
||||
construct<SeparateModuleSubprogram>(statement(Parser<MpSubprogramStmt>{}),
|
||||
specificationPart, executionPart, maybe(internalSubprogramPart),
|
||||
statement(Parser<EndMpSubprogramStmt>{})))
|
||||
|
||||
// R1539 mp-subprogram-stmt -> MODULE PROCEDURE procedure-name
|
||||
TYPE_CONTEXT_PARSER("MODULE PROCEDURE statement"_en_US,
|
||||
construct<MpSubprogramStmt>("MODULE PROCEDURE"_sptok >> name))
|
||||
|
||||
// R1540 end-mp-subprogram-stmt -> END [PROCEDURE [procedure-name]]
|
||||
TYPE_CONTEXT_PARSER("END PROCEDURE statement"_en_US,
|
||||
construct<EndMpSubprogramStmt>(
|
||||
recovery("END PROCEDURE" >> maybe(name) || bareEnd,
|
||||
progUnitEndStmtErrorRecovery)))
|
||||
|
||||
// R1541 entry-stmt -> ENTRY entry-name [( [dummy-arg-list] ) [suffix]]
|
||||
TYPE_PARSER(
|
||||
"ENTRY" >> (construct<EntryStmt>(name,
|
||||
parenthesized(optionalList(dummyArg)), maybe(suffix)) ||
|
||||
construct<EntryStmt>(name, construct<std::list<DummyArg>>(),
|
||||
construct<std::optional<Suffix>>())))
|
||||
|
||||
// R1542 return-stmt -> RETURN [scalar-int-expr]
|
||||
TYPE_CONTEXT_PARSER("RETURN statement"_en_US,
|
||||
construct<ReturnStmt>("RETURN" >> maybe(scalarIntExpr)))
|
||||
|
||||
// R1543 contains-stmt -> CONTAINS
|
||||
TYPE_PARSER(construct<ContainsStmt>("CONTAINS"_tok))
|
||||
|
||||
// R1544 stmt-function-stmt ->
|
||||
// function-name ( [dummy-arg-name-list] ) = scalar-expr
|
||||
TYPE_CONTEXT_PARSER("statement function definition"_en_US,
|
||||
construct<StmtFunctionStmt>(
|
||||
name, parenthesized(optionalList(name)), "=" >> scalar(expr)))
|
||||
}
|
||||
|
|
@ -15,7 +15,7 @@
|
|||
#ifndef FORTRAN_PARSER_TOKEN_PARSERS_H_
|
||||
#define FORTRAN_PARSER_TOKEN_PARSERS_H_
|
||||
|
||||
// These parsers are driven by the Fortran grammar (grammar.h) to consume
|
||||
// These parsers are driven by the parsers of the Fortran grammar to consume
|
||||
// the prescanned character stream and recognize context-sensitive tokens.
|
||||
|
||||
#include "basic-parsers.h"
|
||||
|
|
@ -641,20 +641,14 @@ constexpr struct SkipStuffBeforeStatement {
|
|||
// R602 underscore -> _
|
||||
constexpr auto underscore{"_"_ch};
|
||||
|
||||
// R516 keyword -> name
|
||||
// R601 alphanumeric-character -> letter | digit | underscore
|
||||
// R603 name -> letter [alphanumeric-character]...
|
||||
// Characters besides letters and digits that may appear in names.
|
||||
// N.B. Don't accept an underscore if it is immediately followed by a
|
||||
// quotation mark, so that kindParameter_"character literal" is parsed properly.
|
||||
// quotation mark, so that kindParam_"character literal" is parsed properly.
|
||||
// PGI and ifort accept '$' in identifiers, even as the initial character.
|
||||
// Cray and gfortran accept '$', but not as the first character.
|
||||
// Cray accepts '@' as well.
|
||||
constexpr auto otherIdChar{underscore / !"'\""_ch ||
|
||||
extension<LanguageFeature::PunctuationInNames>("$@"_ch)};
|
||||
constexpr auto nonDigitIdChar{letter || otherIdChar};
|
||||
constexpr auto rawName{nonDigitIdChar >> many(nonDigitIdChar || digit)};
|
||||
TYPE_PARSER(space >> sourced(rawName >> construct<Name>()))
|
||||
constexpr auto keyword{construct<Keyword>(name)};
|
||||
|
||||
constexpr auto logicalTRUE{
|
||||
(".TRUE."_tok ||
|
||||
|
|
@ -665,18 +659,9 @@ constexpr auto logicalFALSE{
|
|||
extension<LanguageFeature::LogicalAbbreviations>(".F."_tok)) >>
|
||||
pure(false)};
|
||||
|
||||
// R1003 defined-unary-op -> . letter [letter]... .
|
||||
// R1023 defined-binary-op -> . letter [letter]... .
|
||||
// R1414 local-defined-operator -> defined-unary-op | defined-binary-op
|
||||
// R1415 use-defined-operator -> defined-unary-op | defined-binary-op
|
||||
// C1003 A defined operator must be distinct from logical literal constants
|
||||
// and intrinsic operator names; this is handled by attempting their parses
|
||||
// first, and by name resolution on their definitions, for best errors.
|
||||
// N.B. The name of the operator is captured with the dots around it.
|
||||
constexpr auto definedOpNameChar{
|
||||
letter || extension<LanguageFeature::PunctuationInNames>("$@"_ch)};
|
||||
TYPE_PARSER(
|
||||
space >> construct<DefinedOpName>(sourced("."_ch >>
|
||||
some(definedOpNameChar) >> construct<Name>() / "."_ch)))
|
||||
// deprecated: Hollerith literals
|
||||
constexpr auto rawHollerithLiteral{
|
||||
deprecated<LanguageFeature::Hollerith>(HollerithLiteral{})};
|
||||
|
||||
}
|
||||
#endif // FORTRAN_PARSER_TOKEN_PARSERS_H_
|
||||
|
|
|
|||
|
|
@ -0,0 +1,42 @@
|
|||
// Copyright (c) 2019, NVIDIA CORPORATION. All rights reserved.
|
||||
//
|
||||
// Licensed under the Apache License, Version 2.0 (the "License");
|
||||
// you may not use this file except in compliance with the License.
|
||||
// You may obtain a copy of the License at
|
||||
//
|
||||
// http://www.apache.org/licenses/LICENSE-2.0
|
||||
//
|
||||
// Unless required by applicable law or agreed to in writing, software
|
||||
// distributed under the License is distributed on an "AS IS" BASIS,ccc
|
||||
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
// See the License for the specific language governing permissions and
|
||||
// limitations under the License.
|
||||
|
||||
// Macros for implementing per-type parsers
|
||||
|
||||
#ifndef FORTRAN_PARSER_TYPE_PARSER_IMPLEMENTATION_H_
|
||||
#define FORTRAN_PARSER_TYPE_PARSER_IMPLEMENTATION_H_
|
||||
|
||||
#include "type-parsers.h"
|
||||
|
||||
#undef TYPE_PARSER
|
||||
#undef TYPE_CONTEXT_PARSER
|
||||
|
||||
// The result type of a parser combinator expression is determined
|
||||
// here via "decltype(attempt(pexpr))" to work around a g++ bug that
|
||||
// causes it to crash on "decltype(pexpr)" when pexpr's top-level
|
||||
// operator is an overridden || of parsing alternatives.
|
||||
#define TYPE_PARSER(pexpr) \
|
||||
template<> \
|
||||
auto Parser<typename decltype(attempt(pexpr))::resultType>::Parse( \
|
||||
ParseState &state) \
|
||||
->std::optional<resultType> { \
|
||||
static constexpr auto parser{(pexpr)}; \
|
||||
return parser.Parse(state); \
|
||||
}
|
||||
|
||||
#define TYPE_CONTEXT_PARSER(contextText, pexpr) \
|
||||
TYPE_PARSER(CONTEXT_PARSER((contextText), (pexpr)))
|
||||
|
||||
#endif
|
||||
|
||||
|
|
@ -15,7 +15,6 @@
|
|||
#ifndef FORTRAN_PARSER_TYPE_PARSERS_H_
|
||||
#define FORTRAN_PARSER_TYPE_PARSERS_H_
|
||||
|
||||
#include "basic-parsers.h"
|
||||
#include "instrumented-parser.h"
|
||||
#include "parse-tree.h"
|
||||
#include <optional>
|
||||
|
|
@ -31,27 +30,16 @@ template<typename A> struct Parser {
|
|||
using resultType = A;
|
||||
constexpr Parser() {}
|
||||
constexpr Parser(const Parser &) = default;
|
||||
static inline std::optional<resultType> Parse(ParseState &);
|
||||
static std::optional<resultType> Parse(ParseState &);
|
||||
};
|
||||
|
||||
// The result type of a parser combinator expression is determined
|
||||
// here via "decltype(attempt(pexpr))" to work around a g++ bug that
|
||||
// causes it to crash on "decltype(pexpr)" when pexpr's top-level
|
||||
// operator is an overridden || of parsing alternatives.
|
||||
#define TYPE_PARSER(pexpr) \
|
||||
template<> \
|
||||
inline auto Parser<typename decltype(attempt(pexpr))::resultType>::Parse( \
|
||||
ParseState &state) \
|
||||
->std::optional<resultType> { \
|
||||
static constexpr auto parser{(pexpr)}; \
|
||||
return parser.Parse(state); \
|
||||
}
|
||||
|
||||
#define CONTEXT_PARSER(contextText, pexpr) \
|
||||
instrumented((contextText), inContext((contextText), (pexpr)))
|
||||
|
||||
#define TYPE_CONTEXT_PARSER(contextText, pexpr) \
|
||||
TYPE_PARSER(CONTEXT_PARSER((contextText), (pexpr)))
|
||||
// To allow use of the Fortran grammar (or parts of it) outside the
|
||||
// context of constructing the actual parser.
|
||||
#define TYPE_PARSER(pexpr)
|
||||
#define TYPE_CONTEXT_PARSER(context, pexpr)
|
||||
|
||||
// Some specializations of Parser<> are used multiple times, or are
|
||||
// of some special importance, so we instantiate them once here and
|
||||
|
|
|
|||
|
|
@ -13,9 +13,6 @@
|
|||
// limitations under the License.
|
||||
|
||||
#include "user-state.h"
|
||||
#include "basic-parsers.h"
|
||||
#include "grammar.h"
|
||||
#include "openmp-grammar.h"
|
||||
#include "parse-state.h"
|
||||
#include "stmt-parser.h"
|
||||
#include "type-parsers.h"
|
||||
|
|
|
|||
Loading…
Reference in New Issue