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