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 "debug-parser.h"
  13 #include "expr-parsers.h"
  14 #include "misc-parsers.h"
  15 #include "stmt-parser.h"
  16 #include "token-parsers.h"
  17 #include "type-parser-implementation.h"
  18 #include "flang/Parser/characters.h"
  19 #include "flang/Parser/parse-tree.h"
  20
  21 namespace Fortran::parser {
  22
  23 // Fortran allows the statement with the corresponding label at the end of
  24 // a do-construct that begins with an old-style label-do-stmt to be a
  25 // new-style END DO statement; e.g., DO 10 I=1,N; ...; 10 END DO.  Usually,
  26 // END DO statements appear only at the ends of do-constructs that begin
  27 // with a nonlabel-do-stmt, so care must be taken to recognize this case and
  28 // essentially treat them like CONTINUE statements.
  29
  30 // R514 executable-construct ->
  31 //        action-stmt | associate-construct | block-construct |
  32 //        case-construct | change-team-construct | critical-construct |
  33 //        do-construct | if-construct | select-rank-construct |
  34 //        select-type-construct | where-construct | forall-construct
  35 constexpr auto executableConstruct{
  36     first(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(accEndCombinedDirective)),
  55         construct<ExecutableConstruct>(indirect(openaccConstruct)),
  56         construct<ExecutableConstruct>(indirect(compilerDirective)))};
  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     withMessage("expected execution part construct"_err_en_US,
  70         CONTEXT_PARSER("execution part construct"_en_US,
  71             first(construct<ExecutionPartConstruct>(executableConstruct),
  72                 construct<ExecutionPartConstruct>(
  73                     statement(indirect(formatStmt))),
  74                 construct<ExecutionPartConstruct>(
  75                     statement(indirect(entryStmt))),
  76                 construct<ExecutionPartConstruct>(
  77                     statement(indirect(dataStmt))),
  78                 extension<LanguageFeature::ExecutionPartNamelist>(
  79                     construct<ExecutionPartConstruct>(
  80                         statement(indirect(Parser<NamelistStmt>{})))),
  81                 obsoleteExecutionPartConstruct))),
  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 | nullify-stmt |
  94 //        open-stmt | pointer-assignment-stmt | print-stmt | read-stmt |
  95 //        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<NullifyStmt>{})),
 121     construct<ActionStmt>(indirect(Parser<OpenStmt>{})),
 122     construct<ActionStmt>(indirect(Parser<PrintStmt>{})),
 123     construct<ActionStmt>(indirect(Parser<ReadStmt>{})),
 124     construct<ActionStmt>(indirect(Parser<ReturnStmt>{})),
 125     construct<ActionStmt>(indirect(Parser<RewindStmt>{})),
 126     construct<ActionStmt>(indirect(Parser<StopStmt>{})), // & error-stop-stmt
 127     construct<ActionStmt>(indirect(Parser<SyncAllStmt>{})),
 128     construct<ActionStmt>(indirect(Parser<SyncImagesStmt>{})),
 129     construct<ActionStmt>(indirect(Parser<SyncMemoryStmt>{})),
 130     construct<ActionStmt>(indirect(Parser<SyncTeamStmt>{})),
 131     construct<ActionStmt>(indirect(Parser<UnlockStmt>{})),
 132     construct<ActionStmt>(indirect(Parser<WaitStmt>{})),
 133     construct<ActionStmt>(indirect(whereStmt)),
 134     construct<ActionStmt>(indirect(Parser<WriteStmt>{})),
 135     construct<ActionStmt>(indirect(Parser<ComputedGotoStmt>{})),
 136     construct<ActionStmt>(indirect(forallStmt)),
 137     construct<ActionStmt>(indirect(Parser<ArithmeticIfStmt>{})),
 138     construct<ActionStmt>(indirect(Parser<AssignStmt>{})),
 139     construct<ActionStmt>(indirect(Parser<AssignedGotoStmt>{})),
 140     construct<ActionStmt>(indirect(Parser<PauseStmt>{}))))
 141
 142 // R1102 associate-construct -> associate-stmt block end-associate-stmt
 143 TYPE_CONTEXT_PARSER("ASSOCIATE construct"_en_US,
 144     construct<AssociateConstruct>(statement(Parser<AssociateStmt>{}), block,
 145         statement(Parser<EndAssociateStmt>{})))
 146
 147 // R1103 associate-stmt ->
 148 //        [associate-construct-name :] ASSOCIATE ( association-list )
 149 TYPE_CONTEXT_PARSER("ASSOCIATE statement"_en_US,
 150     construct<AssociateStmt>(maybe(name / ":"),
 151         "ASSOCIATE" >> parenthesized(nonemptyList(Parser<Association>{}))))
 152
 153 // R1104 association -> associate-name => selector
 154 TYPE_PARSER(construct<Association>(name, "=>" >> selector))
 155
 156 // R1105 selector -> expr | variable
 157 TYPE_PARSER(construct<Selector>(variable) / lookAhead(","_tok || ")"_tok) ||
 158     construct<Selector>(expr))
 159
 160 // R1106 end-associate-stmt -> END ASSOCIATE [associate-construct-name]
 161 TYPE_PARSER(construct<EndAssociateStmt>(
 162     recovery("END ASSOCIATE" >> maybe(name), endStmtErrorRecovery)))
 163
 164 // R1107 block-construct ->
 165 //         block-stmt [block-specification-part] block end-block-stmt
 166 TYPE_CONTEXT_PARSER("BLOCK construct"_en_US,
 167     construct<BlockConstruct>(statement(Parser<BlockStmt>{}),
 168         Parser<BlockSpecificationPart>{}, // can be empty
 169         block, statement(Parser<EndBlockStmt>{})))
 170
 171 // R1108 block-stmt -> [block-construct-name :] BLOCK
 172 TYPE_PARSER(construct<BlockStmt>(maybe(name / ":") / "BLOCK"))
 173
 174 // R1109 block-specification-part ->
 175 //         [use-stmt]... [import-stmt]... [implicit-part]
 176 //         [[declaration-construct]... specification-construct]
 177 // C1107 prohibits COMMON, EQUIVALENCE, INTENT, NAMELIST, OPTIONAL, VALUE,
 178 // and statement function definitions.  C1108 prohibits SAVE /common/.
 179 // C1570 indirectly prohibits ENTRY.  These constraints are best enforced later.
 180 // The odd grammar rule above would have the effect of forcing any
 181 // trailing FORMAT and DATA statements after the last specification-construct
 182 // to be recognized as part of the block-construct's block part rather than
 183 // its block-specification-part, a distinction without any apparent difference.
 184 TYPE_PARSER(construct<BlockSpecificationPart>(specificationPart))
 185
 186 // R1110 end-block-stmt -> END BLOCK [block-construct-name]
 187 TYPE_PARSER(construct<EndBlockStmt>(
 188     recovery("END BLOCK" >> maybe(name), endStmtErrorRecovery)))
 189
 190 // R1111 change-team-construct -> change-team-stmt block end-change-team-stmt
 191 TYPE_CONTEXT_PARSER("CHANGE TEAM construct"_en_US,
 192     construct<ChangeTeamConstruct>(statement(Parser<ChangeTeamStmt>{}), block,
 193         statement(Parser<EndChangeTeamStmt>{})))
 194
 195 // R1112 change-team-stmt ->
 196 //         [team-construct-name :] CHANGE TEAM
 197 //         ( team-value [, coarray-association-list] [, sync-stat-list] )
 198 TYPE_CONTEXT_PARSER("CHANGE TEAM statement"_en_US,
 199     construct<ChangeTeamStmt>(maybe(name / ":"),
 200         "CHANGE TEAM"_sptok >> "("_tok >> teamValue,
 201         defaulted("," >> nonemptyList(Parser<CoarrayAssociation>{})),
 202         defaulted("," >> nonemptyList(statOrErrmsg))) /
 203         ")")
 204
 205 // R1113 coarray-association -> codimension-decl => selector
 206 TYPE_PARSER(
 207     construct<CoarrayAssociation>(Parser<CodimensionDecl>{}, "=>" >> selector))
 208
 209 // R1114 end-change-team-stmt ->
 210 //         END TEAM [( [sync-stat-list] )] [team-construct-name]
 211 TYPE_CONTEXT_PARSER("END TEAM statement"_en_US,
 212     construct<EndChangeTeamStmt>(
 213         "END TEAM" >> defaulted(parenthesized(optionalList(statOrErrmsg))),
 214         maybe(name)))
 215
 216 // R1117 critical-stmt ->
 217 //         [critical-construct-name :] CRITICAL [( [sync-stat-list] )]
 218 TYPE_CONTEXT_PARSER("CRITICAL statement"_en_US,
 219     construct<CriticalStmt>(maybe(name / ":"),
 220         "CRITICAL" >> defaulted(parenthesized(optionalList(statOrErrmsg)))))
 221
 222 // R1116 critical-construct -> critical-stmt block end-critical-stmt
 223 TYPE_CONTEXT_PARSER("CRITICAL construct"_en_US,
 224     construct<CriticalConstruct>(statement(Parser<CriticalStmt>{}), block,
 225         statement(Parser<EndCriticalStmt>{})))
 226
 227 // R1118 end-critical-stmt -> END CRITICAL [critical-construct-name]
 228 TYPE_PARSER(construct<EndCriticalStmt>(
 229     recovery("END CRITICAL" >> maybe(name), endStmtErrorRecovery)))
 230
 231 // R1119 do-construct -> do-stmt block end-do
 232 // R1120 do-stmt -> nonlabel-do-stmt | label-do-stmt
 233 TYPE_CONTEXT_PARSER("DO construct"_en_US,
 234     construct<DoConstruct>(
 235         statement(Parser<NonLabelDoStmt>{}) / EnterNonlabelDoConstruct{}, block,
 236         statement(Parser<EndDoStmt>{}) / LeaveDoConstruct{}))
 237
 238 // R1125 concurrent-header ->
 239 //         ( [integer-type-spec ::] concurrent-control-list
 240 //         [, scalar-mask-expr] )
 241 TYPE_PARSER(parenthesized(construct<ConcurrentHeader>(
 242     maybe(integerTypeSpec / "::"), nonemptyList(Parser<ConcurrentControl>{}),
 243     maybe("," >> scalarLogicalExpr))))
 244
 245 // R1126 concurrent-control ->
 246 //         index-name = concurrent-limit : concurrent-limit [: concurrent-step]
 247 // R1127 concurrent-limit -> scalar-int-expr
 248 // R1128 concurrent-step -> scalar-int-expr
 249 TYPE_PARSER(construct<ConcurrentControl>(name / "=", scalarIntExpr / ":",
 250     scalarIntExpr, maybe(":" >> scalarIntExpr)))
 251
 252 // R1130 locality-spec ->
 253 //         LOCAL ( variable-name-list ) | LOCAL_INIT ( variable-name-list ) |
 254 //         SHARED ( variable-name-list ) | DEFAULT ( NONE )
 255 TYPE_PARSER(construct<LocalitySpec>(construct<LocalitySpec::Local>(
 256                 "LOCAL" >> parenthesized(listOfNames))) ||
 257     construct<LocalitySpec>(construct<LocalitySpec::LocalInit>(
 258         "LOCAL_INIT"_sptok >> parenthesized(listOfNames))) ||
 259     construct<LocalitySpec>(construct<LocalitySpec::Shared>(
 260         "SHARED" >> parenthesized(listOfNames))) ||
 261     construct<LocalitySpec>(
 262         construct<LocalitySpec::DefaultNone>("DEFAULT ( NONE )"_tok)))
 263
 264 // R1123 loop-control ->
 265 //         [,] do-variable = scalar-int-expr , scalar-int-expr
 266 //           [, scalar-int-expr] |
 267 //         [,] WHILE ( scalar-logical-expr ) |
 268 //         [,] CONCURRENT concurrent-header concurrent-locality
 269 // R1129 concurrent-locality -> [locality-spec]...
 270 TYPE_CONTEXT_PARSER("loop control"_en_US,
 271     maybe(","_tok) >>
 272         (construct<LoopControl>(loopBounds(scalarExpr)) ||
 273             construct<LoopControl>(
 274                 "WHILE" >> parenthesized(scalarLogicalExpr)) ||
 275             construct<LoopControl>(construct<LoopControl::Concurrent>(
 276                 "CONCURRENT" >> concurrentHeader,
 277                 many(Parser<LocalitySpec>{})))))
 278
 279 // R1121 label-do-stmt -> [do-construct-name :] DO label [loop-control]
 280 TYPE_CONTEXT_PARSER("label DO statement"_en_US,
 281     construct<LabelDoStmt>(
 282         maybe(name / ":"), "DO" >> label, maybe(loopControl)))
 283
 284 // R1122 nonlabel-do-stmt -> [do-construct-name :] DO [loop-control]
 285 TYPE_CONTEXT_PARSER("nonlabel DO statement"_en_US,
 286     construct<NonLabelDoStmt>(maybe(name / ":"), "DO" >> maybe(loopControl)))
 287
 288 // R1132 end-do-stmt -> END DO [do-construct-name]
 289 TYPE_CONTEXT_PARSER("END DO statement"_en_US,
 290     construct<EndDoStmt>(
 291         recovery("END DO" >> maybe(name), endStmtErrorRecovery)))
 292
 293 // R1133 cycle-stmt -> CYCLE [do-construct-name]
 294 TYPE_CONTEXT_PARSER(
 295     "CYCLE statement"_en_US, construct<CycleStmt>("CYCLE" >> maybe(name)))
 296
 297 // R1134 if-construct ->
 298 //         if-then-stmt block [else-if-stmt block]...
 299 //         [else-stmt block] end-if-stmt
 300 // R1135 if-then-stmt -> [if-construct-name :] IF ( scalar-logical-expr )
 301 // THEN R1136 else-if-stmt ->
 302 //         ELSE IF ( scalar-logical-expr ) THEN [if-construct-name]
 303 // R1137 else-stmt -> ELSE [if-construct-name]
 304 // R1138 end-if-stmt -> END IF [if-construct-name]
 305 TYPE_CONTEXT_PARSER("IF construct"_en_US,
 306     construct<IfConstruct>(
 307         statement(construct<IfThenStmt>(maybe(name / ":"),
 308             "IF" >> parenthesized(scalarLogicalExpr) / "THEN")),
 309         block,
 310         many(construct<IfConstruct::ElseIfBlock>(
 311             unambiguousStatement(construct<ElseIfStmt>(
 312                 "ELSE IF" >> parenthesized(scalarLogicalExpr),
 313                 "THEN" >> maybe(name))),
 314             block)),
 315         maybe(construct<IfConstruct::ElseBlock>(
 316             statement(construct<ElseStmt>("ELSE" >> maybe(name))), block)),
 317         statement(construct<EndIfStmt>(
 318             recovery("END IF" >> maybe(name), endStmtErrorRecovery)))))
 319
 320 // R1139 if-stmt -> IF ( scalar-logical-expr ) action-stmt
 321 TYPE_CONTEXT_PARSER("IF statement"_en_US,
 322     construct<IfStmt>("IF" >> parenthesized(scalarLogicalExpr),
 323         unlabeledStatement(actionStmt)))
 324
 325 // R1140 case-construct ->
 326 //         select-case-stmt [case-stmt block]... end-select-stmt
 327 TYPE_CONTEXT_PARSER("SELECT CASE construct"_en_US,
 328     construct<CaseConstruct>(statement(Parser<SelectCaseStmt>{}),
 329         many(construct<CaseConstruct::Case>(
 330             unambiguousStatement(Parser<CaseStmt>{}), block)),
 331         statement(endSelectStmt)))
 332
 333 // R1141 select-case-stmt -> [case-construct-name :] SELECT CASE ( case-expr
 334 // ) R1144 case-expr -> scalar-expr
 335 TYPE_CONTEXT_PARSER("SELECT CASE statement"_en_US,
 336     construct<SelectCaseStmt>(
 337         maybe(name / ":"), "SELECT CASE" >> parenthesized(scalar(expr))))
 338
 339 // R1142 case-stmt -> CASE case-selector [case-construct-name]
 340 TYPE_CONTEXT_PARSER("CASE statement"_en_US,
 341     construct<CaseStmt>("CASE" >> Parser<CaseSelector>{}, maybe(name)))
 342
 343 // R1143 end-select-stmt -> END SELECT [case-construct-name]
 344 // R1151 end-select-rank-stmt -> END SELECT [select-construct-name]
 345 // R1155 end-select-type-stmt -> END SELECT [select-construct-name]
 346 TYPE_PARSER(construct<EndSelectStmt>(
 347     recovery("END SELECT" >> maybe(name), endStmtErrorRecovery)))
 348
 349 // R1145 case-selector -> ( case-value-range-list ) | DEFAULT
 350 constexpr auto defaultKeyword{construct<Default>("DEFAULT"_tok)};
 351 TYPE_PARSER(parenthesized(construct<CaseSelector>(
 352                 nonemptyList(Parser<CaseValueRange>{}))) ||
 353     construct<CaseSelector>(defaultKeyword))
 354
 355 // R1147 case-value -> scalar-constant-expr
 356 constexpr auto caseValue{scalar(constantExpr)};
 357
 358 // R1146 case-value-range ->
 359 //         case-value | case-value : | : case-value | case-value : case-value
 360 TYPE_PARSER(construct<CaseValueRange>(construct<CaseValueRange::Range>(
 361                 construct<std::optional<CaseValue>>(caseValue),
 362                 ":" >> maybe(caseValue))) ||
 363     construct<CaseValueRange>(
 364         construct<CaseValueRange::Range>(construct<std::optional<CaseValue>>(),
 365             ":" >> construct<std::optional<CaseValue>>(caseValue))) ||
 366     construct<CaseValueRange>(caseValue))
 367
 368 // R1148 select-rank-construct ->
 369 //         select-rank-stmt [select-rank-case-stmt block]...
 370 //         end-select-rank-stmt
 371 TYPE_CONTEXT_PARSER("SELECT RANK construct"_en_US,
 372     construct<SelectRankConstruct>(statement(Parser<SelectRankStmt>{}),
 373         many(construct<SelectRankConstruct::RankCase>(
 374             unambiguousStatement(Parser<SelectRankCaseStmt>{}), block)),
 375         statement(endSelectStmt)))
 376
 377 // R1149 select-rank-stmt ->
 378 //         [select-construct-name :] SELECT RANK
 379 //         ( [associate-name =>] selector )
 380 TYPE_CONTEXT_PARSER("SELECT RANK statement"_en_US,
 381     construct<SelectRankStmt>(maybe(name / ":"),
 382         "SELECT RANK"_sptok >> "("_tok >> maybe(name / "=>"), selector / ")"))
 383
 384 // R1150 select-rank-case-stmt ->
 385 //         RANK ( scalar-int-constant-expr ) [select-construct-name] |
 386 //         RANK ( * ) [select-construct-name] |
 387 //         RANK DEFAULT [select-construct-name]
 388 TYPE_CONTEXT_PARSER("RANK case statement"_en_US,
 389     "RANK" >> (construct<SelectRankCaseStmt>(
 390                   parenthesized(construct<SelectRankCaseStmt::Rank>(
 391                                     scalarIntConstantExpr) ||
 392                       construct<SelectRankCaseStmt::Rank>(star)) ||
 393                       construct<SelectRankCaseStmt::Rank>(defaultKeyword),
 394                   maybe(name))))
 395
 396 // R1152 select-type-construct ->
 397 //         select-type-stmt [type-guard-stmt block]... end-select-type-stmt
 398 TYPE_CONTEXT_PARSER("SELECT TYPE construct"_en_US,
 399     construct<SelectTypeConstruct>(statement(Parser<SelectTypeStmt>{}),
 400         many(construct<SelectTypeConstruct::TypeCase>(
 401             unambiguousStatement(Parser<TypeGuardStmt>{}), block)),
 402         statement(endSelectStmt)))
 403
 404 // R1153 select-type-stmt ->
 405 //         [select-construct-name :] SELECT TYPE
 406 //         ( [associate-name =>] selector )
 407 TYPE_CONTEXT_PARSER("SELECT TYPE statement"_en_US,
 408     construct<SelectTypeStmt>(maybe(name / ":"),
 409         "SELECT TYPE (" >> maybe(name / "=>"), selector / ")"))
 410
 411 // R1154 type-guard-stmt ->
 412 //         TYPE IS ( type-spec ) [select-construct-name] |
 413 //         CLASS IS ( derived-type-spec ) [select-construct-name] |
 414 //         CLASS DEFAULT [select-construct-name]
 415 TYPE_CONTEXT_PARSER("type guard statement"_en_US,
 416     construct<TypeGuardStmt>("TYPE IS"_sptok >>
 417                 parenthesized(construct<TypeGuardStmt::Guard>(typeSpec)) ||
 418             "CLASS IS"_sptok >> parenthesized(construct<TypeGuardStmt::Guard>(
 419                                     derivedTypeSpec)) ||
 420             construct<TypeGuardStmt::Guard>("CLASS" >> defaultKeyword),
 421         maybe(name)))
 422
 423 // R1156 exit-stmt -> EXIT [construct-name]
 424 TYPE_CONTEXT_PARSER(
 425     "EXIT statement"_en_US, construct<ExitStmt>("EXIT" >> maybe(name)))
 426
 427 // R1157 goto-stmt -> GO TO label
 428 TYPE_CONTEXT_PARSER(
 429     "GOTO statement"_en_US, construct<GotoStmt>("GO TO" >> label))
 430
 431 // R1158 computed-goto-stmt -> GO TO ( label-list ) [,] scalar-int-expr
 432 TYPE_CONTEXT_PARSER("computed GOTO statement"_en_US,
 433     construct<ComputedGotoStmt>("GO TO" >> parenthesized(nonemptyList(label)),
 434         maybe(","_tok) >> scalarIntExpr))
 435
 436 // R1160 stop-stmt -> STOP [stop-code] [, QUIET = scalar-logical-expr]
 437 // R1161 error-stop-stmt ->
 438 //         ERROR STOP [stop-code] [, QUIET = scalar-logical-expr]
 439 TYPE_CONTEXT_PARSER("STOP statement"_en_US,
 440     construct<StopStmt>("STOP" >> pure(StopStmt::Kind::Stop) ||
 441             "ERROR STOP"_sptok >> pure(StopStmt::Kind::ErrorStop),
 442         maybe(Parser<StopCode>{}), maybe(", QUIET =" >> scalarLogicalExpr)))
 443
 444 // R1162 stop-code -> scalar-default-char-expr | scalar-int-expr
 445 // The two alternatives for stop-code can't be distinguished at
 446 // parse time.
 447 TYPE_PARSER(construct<StopCode>(scalar(expr)))
 448
 449 // R1164 sync-all-stmt -> SYNC ALL [( [sync-stat-list] )]
 450 TYPE_CONTEXT_PARSER("SYNC ALL statement"_en_US,
 451     construct<SyncAllStmt>("SYNC ALL"_sptok >>
 452         defaulted(parenthesized(optionalList(statOrErrmsg)))))
 453
 454 // R1166 sync-images-stmt -> SYNC IMAGES ( image-set [, sync-stat-list] )
 455 // R1167 image-set -> int-expr | *
 456 TYPE_CONTEXT_PARSER("SYNC IMAGES statement"_en_US,
 457     "SYNC IMAGES"_sptok >> parenthesized(construct<SyncImagesStmt>(
 458                                construct<SyncImagesStmt::ImageSet>(intExpr) ||
 459                                    construct<SyncImagesStmt::ImageSet>(star),
 460                                defaulted("," >> nonemptyList(statOrErrmsg)))))
 461
 462 // R1168 sync-memory-stmt -> SYNC MEMORY [( [sync-stat-list] )]
 463 TYPE_CONTEXT_PARSER("SYNC MEMORY statement"_en_US,
 464     construct<SyncMemoryStmt>("SYNC MEMORY"_sptok >>
 465         defaulted(parenthesized(optionalList(statOrErrmsg)))))
 466
 467 // R1169 sync-team-stmt -> SYNC TEAM ( team-value [, sync-stat-list] )
 468 TYPE_CONTEXT_PARSER("SYNC TEAM statement"_en_US,
 469     construct<SyncTeamStmt>("SYNC TEAM"_sptok >> "("_tok >> teamValue,
 470         defaulted("," >> nonemptyList(statOrErrmsg)) / ")"))
 471
 472 // R1170 event-post-stmt -> EVENT POST ( event-variable [, sync-stat-list] )
 473 // R1171 event-variable -> scalar-variable
 474 TYPE_CONTEXT_PARSER("EVENT POST statement"_en_US,
 475     construct<EventPostStmt>("EVENT POST"_sptok >> "("_tok >> scalar(variable),
 476         defaulted("," >> nonemptyList(statOrErrmsg)) / ")"))
 477
 478 // R1172 event-wait-stmt ->
 479 //         EVENT WAIT ( event-variable [, event-wait-spec-list] )
 480 TYPE_CONTEXT_PARSER("EVENT WAIT statement"_en_US,
 481     construct<EventWaitStmt>("EVENT WAIT"_sptok >> "("_tok >> scalar(variable),
 482         defaulted("," >> nonemptyList(Parser<EventWaitStmt::EventWaitSpec>{})) /
 483             ")"))
 484
 485 // R1174 until-spec -> UNTIL_COUNT = scalar-int-expr
 486 constexpr auto untilSpec{"UNTIL_COUNT =" >> scalarIntExpr};
 487
 488 // R1173 event-wait-spec -> until-spec | sync-stat
 489 TYPE_PARSER(construct<EventWaitStmt::EventWaitSpec>(untilSpec) ||
 490     construct<EventWaitStmt::EventWaitSpec>(statOrErrmsg))
 491
 492 // R1177 team-variable -> scalar-variable
 493 constexpr auto teamVariable{scalar(variable)};
 494
 495 // R1175 form-team-stmt ->
 496 //         FORM TEAM ( team-number , team-variable [, form-team-spec-list] )
 497 // R1176 team-number -> scalar-int-expr
 498 TYPE_CONTEXT_PARSER("FORM TEAM statement"_en_US,
 499     construct<FormTeamStmt>("FORM TEAM"_sptok >> "("_tok >> scalarIntExpr,
 500         "," >> teamVariable,
 501         defaulted("," >> nonemptyList(Parser<FormTeamStmt::FormTeamSpec>{})) /
 502             ")"))
 503
 504 // R1178 form-team-spec -> NEW_INDEX = scalar-int-expr | sync-stat
 505 TYPE_PARSER(
 506     construct<FormTeamStmt::FormTeamSpec>("NEW_INDEX =" >> scalarIntExpr) ||
 507     construct<FormTeamStmt::FormTeamSpec>(statOrErrmsg))
 508
 509 // R1182 lock-variable -> scalar-variable
 510 constexpr auto lockVariable{scalar(variable)};
 511
 512 // R1179 lock-stmt -> LOCK ( lock-variable [, lock-stat-list] )
 513 TYPE_CONTEXT_PARSER("LOCK statement"_en_US,
 514     construct<LockStmt>("LOCK (" >> lockVariable,
 515         defaulted("," >> nonemptyList(Parser<LockStmt::LockStat>{})) / ")"))
 516
 517 // R1180 lock-stat -> ACQUIRED_LOCK = scalar-logical-variable | sync-stat
 518 TYPE_PARSER(
 519     construct<LockStmt::LockStat>("ACQUIRED_LOCK =" >> scalarLogicalVariable) ||
 520     construct<LockStmt::LockStat>(statOrErrmsg))
 521
 522 // R1181 unlock-stmt -> UNLOCK ( lock-variable [, sync-stat-list] )
 523 TYPE_CONTEXT_PARSER("UNLOCK statement"_en_US,
 524     construct<UnlockStmt>("UNLOCK (" >> lockVariable,
 525         defaulted("," >> nonemptyList(statOrErrmsg)) / ")"))
 526
 527 } // namespace Fortran::parser