595 lines · cpp
1//===-- lib/Parser/executable-parsers.cpp ---------------------------------===//2//3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.4// See https://llvm.org/LICENSE.txt for license information.5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception6//7//===----------------------------------------------------------------------===//8 9// Per-type parsers for executable statements10 11#include "basic-parsers.h"12#include "expr-parsers.h"13#include "misc-parsers.h"14#include "stmt-parser.h"15#include "token-parsers.h"16#include "type-parser-implementation.h"17#include "flang/Parser/characters.h"18#include "flang/Parser/parse-tree.h"19 20namespace Fortran::parser {21 22// Fortran allows the statement with the corresponding label at the end of23// a do-construct that begins with an old-style label-do-stmt to be a24// new-style END DO statement; e.g., DO 10 I=1,N; ...; 10 END DO. Usually,25// END DO statements appear only at the ends of do-constructs that begin26// with a nonlabel-do-stmt, so care must be taken to recognize this case and27// essentially treat them like CONTINUE statements.28 29// R514 executable-construct ->30// action-stmt | associate-construct | block-construct |31// case-construct | change-team-construct | critical-construct |32// do-construct | if-construct | select-rank-construct |33// select-type-construct | where-construct | forall-construct |34// (CUDA) CUF-kernel-do-construct35constexpr auto executableConstruct{first(36 construct<ExecutableConstruct>(CapturedLabelDoStmt{}),37 construct<ExecutableConstruct>(EndDoStmtForCapturedLabelDoStmt{}),38 construct<ExecutableConstruct>(indirect(Parser<DoConstruct>{})),39 // Attempt DO statements before assignment statements for better40 // error messages in cases like "DO10I=1,(error)".41 construct<ExecutableConstruct>(statement(actionStmt)),42 construct<ExecutableConstruct>(indirect(Parser<AssociateConstruct>{})),43 construct<ExecutableConstruct>(indirect(Parser<BlockConstruct>{})),44 construct<ExecutableConstruct>(indirect(Parser<CaseConstruct>{})),45 construct<ExecutableConstruct>(indirect(Parser<ChangeTeamConstruct>{})),46 construct<ExecutableConstruct>(indirect(Parser<CriticalConstruct>{})),47 construct<ExecutableConstruct>(indirect(Parser<IfConstruct>{})),48 construct<ExecutableConstruct>(indirect(Parser<SelectRankConstruct>{})),49 construct<ExecutableConstruct>(indirect(Parser<SelectTypeConstruct>{})),50 construct<ExecutableConstruct>(indirect(whereConstruct)),51 construct<ExecutableConstruct>(indirect(forallConstruct)),52 construct<ExecutableConstruct>(indirect(openmpConstruct)),53 construct<ExecutableConstruct>(indirect(openmpMisplacedEndDirective)),54 construct<ExecutableConstruct>(indirect(openmpInvalidDirective)),55 construct<ExecutableConstruct>(indirect(Parser<OpenACCConstruct>{})),56 construct<ExecutableConstruct>(indirect(compilerDirective)),57 construct<ExecutableConstruct>(indirect(Parser<CUFKernelDoConstruct>{})))};58 59// R510 execution-part-construct ->60// executable-construct | format-stmt | entry-stmt | data-stmt61// Extension (PGI/Intel): also accept NAMELIST in execution part62constexpr auto obsoleteExecutionPartConstruct{recovery(ignoredStatementPrefix >>63 fail<ExecutionPartConstruct>(64 "obsolete legacy extension is not supported"_err_en_US),65 construct<ExecutionPartConstruct>(construct<ErrorRecovery>(ok /66 statement("REDIMENSION" >> name /67 parenthesized(nonemptyList(Parser<AllocateShapeSpec>{}))))))};68 69// The "!consumedAllInput >>" test prevents a cascade of errors at EOF.70TYPE_PARSER(!consumedAllInput >>71 recovery(72 CONTEXT_PARSER("execution part construct"_en_US,73 first(construct<ExecutionPartConstruct>(executableConstruct),74 construct<ExecutionPartConstruct>(75 statement(indirect(formatStmt))),76 construct<ExecutionPartConstruct>(77 statement(indirect(entryStmt))),78 construct<ExecutionPartConstruct>(79 statement(indirect(dataStmt))),80 extension<LanguageFeature::ExecutionPartNamelist>(81 "nonstandard usage: NAMELIST in execution part"_port_en_US,82 construct<ExecutionPartConstruct>(83 statement(indirect(Parser<NamelistStmt>{})))),84 obsoleteExecutionPartConstruct,85 lookAhead(declarationConstruct) >> SkipTo<'\n'>{} >>86 fail<ExecutionPartConstruct>(87 "misplaced declaration in the execution part"_err_en_US))),88 construct<ExecutionPartConstruct>(executionPartErrorRecovery)))89 90// R509 execution-part -> executable-construct [execution-part-construct]...91TYPE_CONTEXT_PARSER("execution part"_en_US,92 construct<ExecutionPart>(many(executionPartConstruct)))93 94// R515 action-stmt ->95// allocate-stmt | assignment-stmt | backspace-stmt | call-stmt |96// close-stmt | continue-stmt | cycle-stmt | deallocate-stmt |97// endfile-stmt | error-stop-stmt | event-post-stmt | event-wait-stmt |98// exit-stmt | fail-image-stmt | flush-stmt | form-team-stmt |99// goto-stmt | if-stmt | inquire-stmt | lock-stmt | notify-wait-stmt |100// nullify-stmt | open-stmt | pointer-assignment-stmt | print-stmt |101// read-stmt | return-stmt | rewind-stmt | stop-stmt | sync-all-stmt |102// sync-images-stmt | sync-memory-stmt | sync-team-stmt | unlock-stmt |103// wait-stmt | where-stmt | write-stmt | computed-goto-stmt | forall-stmt104// R1159 continue-stmt -> CONTINUE105// R1163 fail-image-stmt -> FAIL IMAGE106TYPE_PARSER(first(construct<ActionStmt>(indirect(Parser<AllocateStmt>{})),107 construct<ActionStmt>(indirect(assignmentStmt)),108 construct<ActionStmt>(indirect(pointerAssignmentStmt)),109 construct<ActionStmt>(indirect(Parser<BackspaceStmt>{})),110 construct<ActionStmt>(indirect(Parser<CallStmt>{})),111 construct<ActionStmt>(indirect(Parser<CloseStmt>{})),112 construct<ActionStmt>(construct<ContinueStmt>("CONTINUE"_tok)),113 construct<ActionStmt>(indirect(Parser<CycleStmt>{})),114 construct<ActionStmt>(indirect(Parser<DeallocateStmt>{})),115 construct<ActionStmt>(indirect(Parser<EndfileStmt>{})),116 construct<ActionStmt>(indirect(Parser<EventPostStmt>{})),117 construct<ActionStmt>(indirect(Parser<EventWaitStmt>{})),118 construct<ActionStmt>(indirect(Parser<ExitStmt>{})),119 construct<ActionStmt>(construct<FailImageStmt>("FAIL IMAGE"_sptok)),120 construct<ActionStmt>(indirect(Parser<FlushStmt>{})),121 construct<ActionStmt>(indirect(Parser<FormTeamStmt>{})),122 construct<ActionStmt>(indirect(Parser<GotoStmt>{})),123 construct<ActionStmt>(indirect(Parser<IfStmt>{})),124 construct<ActionStmt>(indirect(Parser<InquireStmt>{})),125 construct<ActionStmt>(indirect(Parser<LockStmt>{})),126 construct<ActionStmt>(indirect(Parser<NotifyWaitStmt>{})),127 construct<ActionStmt>(indirect(Parser<NullifyStmt>{})),128 construct<ActionStmt>(indirect(Parser<OpenStmt>{})),129 construct<ActionStmt>(indirect(Parser<PrintStmt>{})),130 construct<ActionStmt>(indirect(Parser<ReadStmt>{})),131 construct<ActionStmt>(indirect(Parser<ReturnStmt>{})),132 construct<ActionStmt>(indirect(Parser<RewindStmt>{})),133 construct<ActionStmt>(indirect(Parser<StopStmt>{})), // & error-stop-stmt134 construct<ActionStmt>(indirect(Parser<SyncAllStmt>{})),135 construct<ActionStmt>(indirect(Parser<SyncImagesStmt>{})),136 construct<ActionStmt>(indirect(Parser<SyncMemoryStmt>{})),137 construct<ActionStmt>(indirect(Parser<SyncTeamStmt>{})),138 construct<ActionStmt>(indirect(Parser<UnlockStmt>{})),139 construct<ActionStmt>(indirect(Parser<WaitStmt>{})),140 construct<ActionStmt>(indirect(whereStmt)),141 construct<ActionStmt>(indirect(Parser<WriteStmt>{})),142 construct<ActionStmt>(indirect(Parser<ComputedGotoStmt>{})),143 construct<ActionStmt>(indirect(forallStmt)),144 construct<ActionStmt>(indirect(Parser<ArithmeticIfStmt>{})),145 construct<ActionStmt>(indirect(Parser<AssignStmt>{})),146 construct<ActionStmt>(indirect(Parser<AssignedGotoStmt>{})),147 construct<ActionStmt>(indirect(Parser<PauseStmt>{}))))148 149// R1102 associate-construct -> associate-stmt block end-associate-stmt150TYPE_CONTEXT_PARSER("ASSOCIATE construct"_en_US,151 construct<AssociateConstruct>(statement(Parser<AssociateStmt>{}), block,152 statement(Parser<EndAssociateStmt>{})))153 154// R1103 associate-stmt ->155// [associate-construct-name :] ASSOCIATE ( association-list )156TYPE_CONTEXT_PARSER("ASSOCIATE statement"_en_US,157 construct<AssociateStmt>(maybe(name / ":"),158 "ASSOCIATE" >> parenthesized(nonemptyList(Parser<Association>{}))))159 160// R1104 association -> associate-name => selector161TYPE_PARSER(construct<Association>(name, "=>" >> selector))162 163// R1105 selector -> expr | variable164TYPE_PARSER(construct<Selector>(variable) / lookAhead(","_tok || ")"_tok) ||165 construct<Selector>(expr))166 167// R1106 end-associate-stmt -> END ASSOCIATE [associate-construct-name]168TYPE_PARSER(construct<EndAssociateStmt>(recovery(169 "END ASSOCIATE" >> maybe(name), namedConstructEndStmtErrorRecovery)))170 171// R1107 block-construct ->172// block-stmt [block-specification-part] block end-block-stmt173TYPE_CONTEXT_PARSER("BLOCK construct"_en_US,174 construct<BlockConstruct>(statement(Parser<BlockStmt>{}),175 Parser<BlockSpecificationPart>{}, // can be empty176 block, statement(Parser<EndBlockStmt>{})))177 178// R1108 block-stmt -> [block-construct-name :] BLOCK179TYPE_PARSER(construct<BlockStmt>(maybe(name / ":") / "BLOCK"))180 181// R1109 block-specification-part ->182// [use-stmt]... [import-stmt]... [implicit-part]183// [[declaration-construct]... specification-construct]184// C1107 prohibits COMMON, EQUIVALENCE, INTENT, NAMELIST, OPTIONAL, VALUE,185// and statement function definitions. C1108 prohibits SAVE /common/.186// C1570 indirectly prohibits ENTRY. These constraints are best enforced later.187// The odd grammar rule above would have the effect of forcing any188// trailing FORMAT and DATA statements after the last specification-construct189// to be recognized as part of the block-construct's block part rather than190// its block-specification-part, a distinction without any apparent difference.191TYPE_PARSER(construct<BlockSpecificationPart>(specificationPart))192 193// R1110 end-block-stmt -> END BLOCK [block-construct-name]194TYPE_PARSER(construct<EndBlockStmt>(195 recovery("END BLOCK" >> maybe(name), namedConstructEndStmtErrorRecovery)))196 197// R1111 change-team-construct -> change-team-stmt block end-change-team-stmt198TYPE_CONTEXT_PARSER("CHANGE TEAM construct"_en_US,199 construct<ChangeTeamConstruct>(statement(Parser<ChangeTeamStmt>{}), block,200 statement(Parser<EndChangeTeamStmt>{})))201 202// R1112 change-team-stmt ->203// [team-construct-name :] CHANGE TEAM204// ( team-value [, coarray-association-list] [, sync-stat-list] )205TYPE_CONTEXT_PARSER("CHANGE TEAM statement"_en_US,206 construct<ChangeTeamStmt>(maybe(name / ":"),207 "CHANGE TEAM"_sptok >> "("_tok >> teamValue,208 defaulted("," >> nonemptyList(Parser<CoarrayAssociation>{})),209 defaulted("," >> nonemptyList(statOrErrmsg))) /210 ")")211 212// R1113 coarray-association -> codimension-decl => selector213TYPE_PARSER(214 construct<CoarrayAssociation>(Parser<CodimensionDecl>{}, "=>" >> selector))215 216// R1114 end-change-team-stmt ->217// END TEAM [( [sync-stat-list] )] [team-construct-name]218TYPE_CONTEXT_PARSER("END TEAM statement"_en_US,219 construct<EndChangeTeamStmt>(220 "END TEAM" >> defaulted(parenthesized(optionalList(statOrErrmsg))),221 maybe(name)))222 223// R1117 critical-stmt ->224// [critical-construct-name :] CRITICAL [( [sync-stat-list] )]225TYPE_CONTEXT_PARSER("CRITICAL statement"_en_US,226 construct<CriticalStmt>(maybe(name / ":"),227 "CRITICAL" >> defaulted(parenthesized(optionalList(statOrErrmsg)))))228 229// R1116 critical-construct -> critical-stmt block end-critical-stmt230TYPE_CONTEXT_PARSER("CRITICAL construct"_en_US,231 construct<CriticalConstruct>(statement(Parser<CriticalStmt>{}), block,232 statement(Parser<EndCriticalStmt>{})))233 234// R1118 end-critical-stmt -> END CRITICAL [critical-construct-name]235TYPE_PARSER(construct<EndCriticalStmt>(recovery(236 "END CRITICAL" >> maybe(name), namedConstructEndStmtErrorRecovery)))237 238// R1119 do-construct -> do-stmt block end-do239// R1120 do-stmt -> nonlabel-do-stmt | label-do-stmt240TYPE_CONTEXT_PARSER("DO construct"_en_US,241 construct<DoConstruct>(242 statement(Parser<NonLabelDoStmt>{}) / EnterNonlabelDoConstruct{}, block,243 statement(Parser<EndDoStmt>{}) / LeaveDoConstruct{}))244 245// R1125 concurrent-header ->246// ( [integer-type-spec ::] concurrent-control-list247// [, scalar-mask-expr] )248TYPE_PARSER(parenthesized(construct<ConcurrentHeader>(249 maybe(integerTypeSpec / "::"), nonemptyList(Parser<ConcurrentControl>{}),250 maybe("," >> scalarLogicalExpr))))251 252// R1126 concurrent-control ->253// index-name = concurrent-limit : concurrent-limit [: concurrent-step]254// R1127 concurrent-limit -> scalar-int-expr255// R1128 concurrent-step -> scalar-int-expr256TYPE_PARSER(construct<ConcurrentControl>(name / "=", scalarIntExpr / ":",257 scalarIntExpr, maybe(":" >> scalarIntExpr)))258 259// R1130 locality-spec ->260// LOCAL ( variable-name-list ) | LOCAL_INIT ( variable-name-list ) |261// REDUCE ( reduce-operation : variable-name-list ) |262// SHARED ( variable-name-list ) | DEFAULT ( NONE )263TYPE_PARSER(construct<LocalitySpec>(construct<LocalitySpec::Local>(264 "LOCAL" >> parenthesized(listOfNames))) ||265 construct<LocalitySpec>(construct<LocalitySpec::LocalInit>(266 "LOCAL_INIT"_sptok >> parenthesized(listOfNames))) ||267 construct<LocalitySpec>(construct<LocalitySpec::Reduce>(268 "REDUCE (" >> Parser<LocalitySpec::Reduce::Operator>{} / ":",269 listOfNames / ")")) ||270 construct<LocalitySpec>(construct<LocalitySpec::Shared>(271 "SHARED" >> parenthesized(listOfNames))) ||272 construct<LocalitySpec>(273 construct<LocalitySpec::DefaultNone>("DEFAULT ( NONE )"_tok)))274 275// R1123 loop-control ->276// [,] do-variable = scalar-int-expr , scalar-int-expr277// [, scalar-int-expr] |278// [,] WHILE ( scalar-logical-expr ) |279// [,] CONCURRENT concurrent-header concurrent-locality280// R1129 concurrent-locality -> [locality-spec]...281TYPE_CONTEXT_PARSER("loop control"_en_US,282 maybe(","_tok) >>283 (construct<LoopControl>(loopBounds(scalarExpr)) ||284 construct<LoopControl>(285 "WHILE" >> parenthesized(scalarLogicalExpr)) ||286 construct<LoopControl>(construct<LoopControl::Concurrent>(287 "CONCURRENT" >> concurrentHeader,288 many(Parser<LocalitySpec>{})))))289 290// "DO" is a valid statement, so the loop control is optional; but for291// better recovery from errors in the loop control, don't parse a292// DO statement with a bad loop control as a DO statement that has293// no loop control and is followed by garbage.294static constexpr auto loopControlOrEndOfStmt{295 construct<std::optional<LoopControl>>(Parser<LoopControl>{}) ||296 lookAhead(";\n"_ch) >> construct<std::optional<LoopControl>>()};297 298// R1121 label-do-stmt -> [do-construct-name :] DO label [loop-control]299// A label-do-stmt with a do-construct-name is parsed as a nonlabel-do-stmt300// with an optional label.301TYPE_CONTEXT_PARSER("label DO statement"_en_US,302 construct<LabelDoStmt>("DO" >> label, loopControlOrEndOfStmt))303 304// R1122 nonlabel-do-stmt -> [do-construct-name :] DO [loop-control]305TYPE_CONTEXT_PARSER("nonlabel DO statement"_en_US,306 construct<NonLabelDoStmt>(307 name / ":", "DO" >> maybe(label), loopControlOrEndOfStmt) ||308 construct<NonLabelDoStmt>(construct<std::optional<Name>>(),309 construct<std::optional<Label>>(), "DO" >> loopControlOrEndOfStmt))310 311// R1132 end-do-stmt -> END DO [do-construct-name]312TYPE_CONTEXT_PARSER("END DO statement"_en_US,313 construct<EndDoStmt>(314 recovery("END DO" >> maybe(name), namedConstructEndStmtErrorRecovery)))315 316// R1133 cycle-stmt -> CYCLE [do-construct-name]317TYPE_CONTEXT_PARSER(318 "CYCLE statement"_en_US, construct<CycleStmt>("CYCLE" >> maybe(name)))319 320// R1134 if-construct ->321// if-then-stmt block [else-if-stmt block]...322// [else-stmt block] end-if-stmt323// R1135 if-then-stmt -> [if-construct-name :] IF ( scalar-logical-expr )324// THEN R1136 else-if-stmt ->325// ELSE IF ( scalar-logical-expr ) THEN [if-construct-name]326// R1137 else-stmt -> ELSE [if-construct-name]327// R1138 end-if-stmt -> END IF [if-construct-name]328TYPE_CONTEXT_PARSER("IF construct"_en_US,329 construct<IfConstruct>(330 statement(construct<IfThenStmt>(maybe(name / ":"),331 "IF" >> parenthesized(scalarLogicalExpr) /332 recovery("THEN"_tok, lookAhead(endOfStmt)))),333 block,334 many(construct<IfConstruct::ElseIfBlock>(335 unambiguousStatement(construct<ElseIfStmt>(336 "ELSE IF" >> parenthesized(scalarLogicalExpr),337 recovery("THEN"_tok, ok) >> maybe(name))),338 block)),339 maybe(construct<IfConstruct::ElseBlock>(340 statement(construct<ElseStmt>("ELSE" >> maybe(name))), block)),341 statement(construct<EndIfStmt>(recovery(342 "END IF" >> maybe(name), namedConstructEndStmtErrorRecovery)))))343 344// R1139 if-stmt -> IF ( scalar-logical-expr ) action-stmt345TYPE_CONTEXT_PARSER("IF statement"_en_US,346 construct<IfStmt>("IF" >> parenthesized(scalarLogicalExpr),347 unlabeledStatement(actionStmt)))348 349// R1140 case-construct ->350// select-case-stmt [case-stmt block]... end-select-stmt351TYPE_CONTEXT_PARSER("SELECT CASE construct"_en_US,352 construct<CaseConstruct>(statement(Parser<SelectCaseStmt>{}),353 many(construct<CaseConstruct::Case>(354 unambiguousStatement(Parser<CaseStmt>{}), block)),355 statement(endSelectStmt)))356 357// R1141 select-case-stmt -> [case-construct-name :] SELECT CASE ( case-expr358// ) R1144 case-expr -> scalar-expr359TYPE_CONTEXT_PARSER("SELECT CASE statement"_en_US,360 construct<SelectCaseStmt>(361 maybe(name / ":"), "SELECT CASE" >> parenthesized(scalar(expr))))362 363// R1142 case-stmt -> CASE case-selector [case-construct-name]364TYPE_CONTEXT_PARSER("CASE statement"_en_US,365 construct<CaseStmt>("CASE" >> Parser<CaseSelector>{}, maybe(name)))366 367// R1143 end-select-stmt -> END SELECT [case-construct-name]368// R1151 end-select-rank-stmt -> END SELECT [select-construct-name]369// R1155 end-select-type-stmt -> END SELECT [select-construct-name]370TYPE_PARSER(construct<EndSelectStmt>(371 recovery("END SELECT" >> maybe(name), namedConstructEndStmtErrorRecovery)))372 373// R1145 case-selector -> ( case-value-range-list ) | DEFAULT374constexpr auto defaultKeyword{construct<Default>("DEFAULT"_tok)};375TYPE_PARSER(parenthesized(construct<CaseSelector>(376 nonemptyList(Parser<CaseValueRange>{}))) ||377 construct<CaseSelector>(defaultKeyword))378 379// R1147 case-value -> scalar-constant-expr380constexpr auto caseValue{scalar(constantExpr)};381 382// R1146 case-value-range ->383// case-value | case-value : | : case-value | case-value : case-value384TYPE_PARSER(construct<CaseValueRange>(construct<CaseValueRange::Range>(385 construct<std::optional<CaseValue>>(caseValue),386 ":" >> maybe(caseValue))) ||387 construct<CaseValueRange>(388 construct<CaseValueRange::Range>(construct<std::optional<CaseValue>>(),389 ":" >> construct<std::optional<CaseValue>>(caseValue))) ||390 construct<CaseValueRange>(caseValue))391 392// R1148 select-rank-construct ->393// select-rank-stmt [select-rank-case-stmt block]...394// end-select-rank-stmt395TYPE_CONTEXT_PARSER("SELECT RANK construct"_en_US,396 construct<SelectRankConstruct>(statement(Parser<SelectRankStmt>{}),397 many(construct<SelectRankConstruct::RankCase>(398 unambiguousStatement(Parser<SelectRankCaseStmt>{}), block)),399 statement(endSelectStmt)))400 401// R1149 select-rank-stmt ->402// [select-construct-name :] SELECT RANK403// ( [associate-name =>] selector )404TYPE_CONTEXT_PARSER("SELECT RANK statement"_en_US,405 construct<SelectRankStmt>(maybe(name / ":"),406 "SELECT RANK"_sptok >> "("_tok >> maybe(name / "=>"), selector / ")"))407 408// R1150 select-rank-case-stmt ->409// RANK ( scalar-int-constant-expr ) [select-construct-name] |410// RANK ( * ) [select-construct-name] |411// RANK DEFAULT [select-construct-name]412TYPE_CONTEXT_PARSER("RANK case statement"_en_US,413 "RANK" >> (construct<SelectRankCaseStmt>(414 parenthesized(construct<SelectRankCaseStmt::Rank>(415 scalarIntConstantExpr) ||416 construct<SelectRankCaseStmt::Rank>(star)) ||417 construct<SelectRankCaseStmt::Rank>(defaultKeyword),418 maybe(name))))419 420// R1152 select-type-construct ->421// select-type-stmt [type-guard-stmt block]... end-select-type-stmt422TYPE_CONTEXT_PARSER("SELECT TYPE construct"_en_US,423 construct<SelectTypeConstruct>(statement(Parser<SelectTypeStmt>{}),424 many(construct<SelectTypeConstruct::TypeCase>(425 unambiguousStatement(Parser<TypeGuardStmt>{}), block)),426 statement(endSelectStmt)))427 428// R1153 select-type-stmt ->429// [select-construct-name :] SELECT TYPE430// ( [associate-name =>] selector )431TYPE_CONTEXT_PARSER("SELECT TYPE statement"_en_US,432 construct<SelectTypeStmt>(maybe(name / ":"),433 "SELECT TYPE (" >> maybe(name / "=>"), selector / ")"))434 435// R1154 type-guard-stmt ->436// TYPE IS ( type-spec ) [select-construct-name] |437// CLASS IS ( derived-type-spec ) [select-construct-name] |438// CLASS DEFAULT [select-construct-name]439TYPE_CONTEXT_PARSER("type guard statement"_en_US,440 construct<TypeGuardStmt>("TYPE IS"_sptok >>441 parenthesized(construct<TypeGuardStmt::Guard>(typeSpec)) ||442 "CLASS IS"_sptok >> parenthesized(construct<TypeGuardStmt::Guard>(443 derivedTypeSpec)) ||444 construct<TypeGuardStmt::Guard>("CLASS" >> defaultKeyword),445 maybe(name)))446 447// R1156 exit-stmt -> EXIT [construct-name]448TYPE_CONTEXT_PARSER(449 "EXIT statement"_en_US, construct<ExitStmt>("EXIT" >> maybe(name)))450 451// R1157 goto-stmt -> GO TO label452TYPE_CONTEXT_PARSER(453 "GOTO statement"_en_US, construct<GotoStmt>("GO TO" >> label))454 455// R1158 computed-goto-stmt -> GO TO ( label-list ) [,] scalar-int-expr456TYPE_CONTEXT_PARSER("computed GOTO statement"_en_US,457 construct<ComputedGotoStmt>("GO TO" >> parenthesized(nonemptyList(label)),458 maybe(","_tok) >> scalarIntExpr))459 460// R1160 stop-stmt -> STOP [stop-code] [, QUIET = scalar-logical-expr]461// R1161 error-stop-stmt ->462// ERROR STOP [stop-code] [, QUIET = scalar-logical-expr]463TYPE_CONTEXT_PARSER("STOP statement"_en_US,464 construct<StopStmt>("STOP" >> pure(StopStmt::Kind::Stop) ||465 "ERROR STOP"_sptok >> pure(StopStmt::Kind::ErrorStop),466 maybe(Parser<StopCode>{}), maybe(", QUIET =" >> scalarLogicalExpr)))467 468// R1162 stop-code -> scalar-default-char-expr | scalar-int-expr469// The two alternatives for stop-code can't be distinguished at470// parse time.471TYPE_PARSER(construct<StopCode>(scalar(expr)))472 473// F2030: R1166 notify-wait-stmt ->474// NOTIFY WAIT ( notify-variable [, event-wait-spec-list] )475TYPE_CONTEXT_PARSER("NOTIFY WAIT statement"_en_US,476 construct<NotifyWaitStmt>(477 "NOTIFY WAIT"_sptok >> "("_tok >> scalar(variable),478 defaulted("," >> nonemptyList(Parser<EventWaitSpec>{})) / ")"))479 480// R1164 sync-all-stmt -> SYNC ALL [( [sync-stat-list] )]481TYPE_CONTEXT_PARSER("SYNC ALL statement"_en_US,482 construct<SyncAllStmt>("SYNC ALL"_sptok >>483 defaulted(parenthesized(optionalList(statOrErrmsg)))))484 485// R1166 sync-images-stmt -> SYNC IMAGES ( image-set [, sync-stat-list] )486// R1167 image-set -> int-expr | *487TYPE_CONTEXT_PARSER("SYNC IMAGES statement"_en_US,488 "SYNC IMAGES"_sptok >> parenthesized(construct<SyncImagesStmt>(489 construct<SyncImagesStmt::ImageSet>(intExpr) ||490 construct<SyncImagesStmt::ImageSet>(star),491 defaulted("," >> nonemptyList(statOrErrmsg)))))492 493// R1168 sync-memory-stmt -> SYNC MEMORY [( [sync-stat-list] )]494TYPE_CONTEXT_PARSER("SYNC MEMORY statement"_en_US,495 construct<SyncMemoryStmt>("SYNC MEMORY"_sptok >>496 defaulted(parenthesized(optionalList(statOrErrmsg)))))497 498// R1169 sync-team-stmt -> SYNC TEAM ( team-value [, sync-stat-list] )499TYPE_CONTEXT_PARSER("SYNC TEAM statement"_en_US,500 construct<SyncTeamStmt>("SYNC TEAM"_sptok >> "("_tok >> teamValue,501 defaulted("," >> nonemptyList(statOrErrmsg)) / ")"))502 503// R1170 event-post-stmt -> EVENT POST ( event-variable [, sync-stat-list] )504// R1171 event-variable -> scalar-variable505TYPE_CONTEXT_PARSER("EVENT POST statement"_en_US,506 construct<EventPostStmt>("EVENT POST"_sptok >> "("_tok >> scalar(variable),507 defaulted("," >> nonemptyList(statOrErrmsg)) / ")"))508 509// R1172 event-wait-stmt ->510// EVENT WAIT ( event-variable [, event-wait-spec-list] )511TYPE_CONTEXT_PARSER("EVENT WAIT statement"_en_US,512 construct<EventWaitStmt>("EVENT WAIT"_sptok >> "("_tok >> scalar(variable),513 defaulted("," >> nonemptyList(Parser<EventWaitSpec>{})) / ")"))514 515// R1174 until-spec -> UNTIL_COUNT = scalar-int-expr516constexpr auto untilSpec{"UNTIL_COUNT =" >> scalarIntExpr};517 518// R1173 event-wait-spec -> until-spec | sync-stat519TYPE_PARSER(construct<EventWaitSpec>(untilSpec) ||520 construct<EventWaitSpec>(statOrErrmsg))521 522// R1177 team-variable -> scalar-variable523constexpr auto teamVariable{scalar(variable)};524 525// R1175 form-team-stmt ->526// FORM TEAM ( team-number , team-variable [, form-team-spec-list] )527// R1176 team-number -> scalar-int-expr528TYPE_CONTEXT_PARSER("FORM TEAM statement"_en_US,529 construct<FormTeamStmt>("FORM TEAM"_sptok >> "("_tok >> scalarIntExpr,530 "," >> teamVariable,531 defaulted("," >> nonemptyList(Parser<FormTeamStmt::FormTeamSpec>{})) /532 ")"))533 534// R1178 form-team-spec -> NEW_INDEX = scalar-int-expr | sync-stat535TYPE_PARSER(536 construct<FormTeamStmt::FormTeamSpec>("NEW_INDEX =" >> scalarIntExpr) ||537 construct<FormTeamStmt::FormTeamSpec>(statOrErrmsg))538 539// R1182 lock-variable -> scalar-variable540constexpr auto lockVariable{scalar(variable)};541 542// R1179 lock-stmt -> LOCK ( lock-variable [, lock-stat-list] )543TYPE_CONTEXT_PARSER("LOCK statement"_en_US,544 construct<LockStmt>("LOCK (" >> lockVariable,545 defaulted("," >> nonemptyList(Parser<LockStmt::LockStat>{})) / ")"))546 547// R1180 lock-stat -> ACQUIRED_LOCK = scalar-logical-variable | sync-stat548TYPE_PARSER(549 construct<LockStmt::LockStat>("ACQUIRED_LOCK =" >> scalarLogicalVariable) ||550 construct<LockStmt::LockStat>(statOrErrmsg))551 552// R1181 unlock-stmt -> UNLOCK ( lock-variable [, sync-stat-list] )553TYPE_CONTEXT_PARSER("UNLOCK statement"_en_US,554 construct<UnlockStmt>("UNLOCK (" >> lockVariable,555 defaulted("," >> nonemptyList(statOrErrmsg)) / ")"))556 557// CUF-kernel-do-construct ->558// !$CUF KERNEL DO [ (scalar-int-constant-expr) ]559// <<< grid, block [, stream] >>>560// [ cuf-reduction... ]561// do-construct562// star-or-expr -> * | scalar-int-expr563// grid -> * | scalar-int-expr | ( star-or-expr-list )564// block -> * | scalar-int-expr | ( star-or-expr-list )565// stream -> 0, scalar-int-expr | STREAM = scalar-int-expr566// cuf-reduction -> [ REDUCTION | REDUCE ] (567// acc-reduction-op : scalar-variable-list )568 569constexpr auto starOrExpr{construct<CUFKernelDoConstruct::StarOrExpr>(570 "*" >> pure<std::optional<ScalarIntExpr>>() ||571 applyFunction(presentOptional<ScalarIntExpr>, scalarIntExpr))};572constexpr auto gridOrBlock{parenthesized(nonemptyList(starOrExpr)) ||573 applyFunction(singletonList<CUFKernelDoConstruct::StarOrExpr>, starOrExpr)};574 575TYPE_PARSER(("REDUCTION"_tok || "REDUCE"_tok) >>576 parenthesized(construct<CUFReduction>(Parser<CUFReduction::Operator>{},577 ":" >> nonemptyList(scalar(variable)))))578 579TYPE_PARSER("<<<" >>580 construct<CUFKernelDoConstruct::LaunchConfiguration>(gridOrBlock,581 "," >> gridOrBlock,582 maybe((", 0 ,"_tok || ", STREAM ="_tok) >> scalarIntExpr) / ">>>"))583 584TYPE_PARSER(sourced(beginDirective >> "$CUF KERNEL DO"_tok >>585 construct<CUFKernelDoConstruct::Directive>(586 maybe(parenthesized(scalarIntConstantExpr)),587 maybe(Parser<CUFKernelDoConstruct::LaunchConfiguration>{}),588 many(Parser<CUFReduction>{}) / endDirective)))589TYPE_CONTEXT_PARSER("!$CUF KERNEL DO construct"_en_US,590 extension<LanguageFeature::CUDA>(construct<CUFKernelDoConstruct>(591 Parser<CUFKernelDoConstruct::Directive>{},592 maybe(Parser<DoConstruct>{}))))593 594} // namespace Fortran::parser595