llvm-project

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
// (CUDA) CUF-kernel-do-construct
36
constexpr auto executableConstruct{first(
37
    construct<ExecutableConstruct>(CapturedLabelDoStmt{}),
38
    construct<ExecutableConstruct>(EndDoStmtForCapturedLabelDoStmt{}),
39
    construct<ExecutableConstruct>(indirect(Parser<DoConstruct>{})),
40
    // Attempt DO statements before assignment statements for better
41
    // error messages in cases like "DO10I=1,(error)".
42
    construct<ExecutableConstruct>(statement(actionStmt)),
43
    construct<ExecutableConstruct>(indirect(Parser<AssociateConstruct>{})),
44
    construct<ExecutableConstruct>(indirect(Parser<BlockConstruct>{})),
45
    construct<ExecutableConstruct>(indirect(Parser<CaseConstruct>{})),
46
    construct<ExecutableConstruct>(indirect(Parser<ChangeTeamConstruct>{})),
47
    construct<ExecutableConstruct>(indirect(Parser<CriticalConstruct>{})),
48
    construct<ExecutableConstruct>(indirect(Parser<IfConstruct>{})),
49
    construct<ExecutableConstruct>(indirect(Parser<SelectRankConstruct>{})),
50
    construct<ExecutableConstruct>(indirect(Parser<SelectTypeConstruct>{})),
51
    construct<ExecutableConstruct>(indirect(whereConstruct)),
52
    construct<ExecutableConstruct>(indirect(forallConstruct)),
53
    construct<ExecutableConstruct>(indirect(ompEndLoopDirective)),
54
    construct<ExecutableConstruct>(indirect(openmpConstruct)),
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-stmt
61
// Extension (PGI/Intel): also accept NAMELIST in execution part
62
constexpr 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
TYPE_PARSER(recovery(
70
    withMessage("expected execution part construct"_err_en_US,
71
        CONTEXT_PARSER("execution part construct"_en_US,
72
            first(construct<ExecutionPartConstruct>(executableConstruct),
73
                construct<ExecutionPartConstruct>(
74
                    statement(indirect(formatStmt))),
75
                construct<ExecutionPartConstruct>(
76
                    statement(indirect(entryStmt))),
77
                construct<ExecutionPartConstruct>(
78
                    statement(indirect(dataStmt))),
79
                extension<LanguageFeature::ExecutionPartNamelist>(
80
                    "nonstandard usage: NAMELIST in execution part"_port_en_US,
81
                    construct<ExecutionPartConstruct>(
82
                        statement(indirect(Parser<NamelistStmt>{})))),
83
                obsoleteExecutionPartConstruct))),
84
    construct<ExecutionPartConstruct>(executionPartErrorRecovery)))
85

86
// R509 execution-part -> executable-construct [execution-part-construct]...
87
TYPE_CONTEXT_PARSER("execution part"_en_US,
88
    construct<ExecutionPart>(many(executionPartConstruct)))
89

90
// R515 action-stmt ->
91
//        allocate-stmt | assignment-stmt | backspace-stmt | call-stmt |
92
//        close-stmt | continue-stmt | cycle-stmt | deallocate-stmt |
93
//        endfile-stmt | error-stop-stmt | event-post-stmt | event-wait-stmt |
94
//        exit-stmt | fail-image-stmt | flush-stmt | form-team-stmt |
95
//        goto-stmt | if-stmt | inquire-stmt | lock-stmt | notify-wait-stmt |
96
//        nullify-stmt | open-stmt | pointer-assignment-stmt | print-stmt |
97
//        read-stmt | return-stmt | rewind-stmt | stop-stmt | sync-all-stmt |
98
//        sync-images-stmt | sync-memory-stmt | sync-team-stmt | unlock-stmt |
99
//        wait-stmt | where-stmt | write-stmt | computed-goto-stmt | forall-stmt
100
// R1159 continue-stmt -> CONTINUE
101
// R1163 fail-image-stmt -> FAIL IMAGE
102
TYPE_PARSER(first(construct<ActionStmt>(indirect(Parser<AllocateStmt>{})),
103
    construct<ActionStmt>(indirect(assignmentStmt)),
104
    construct<ActionStmt>(indirect(pointerAssignmentStmt)),
105
    construct<ActionStmt>(indirect(Parser<BackspaceStmt>{})),
106
    construct<ActionStmt>(indirect(Parser<CallStmt>{})),
107
    construct<ActionStmt>(indirect(Parser<CloseStmt>{})),
108
    construct<ActionStmt>(construct<ContinueStmt>("CONTINUE"_tok)),
109
    construct<ActionStmt>(indirect(Parser<CycleStmt>{})),
110
    construct<ActionStmt>(indirect(Parser<DeallocateStmt>{})),
111
    construct<ActionStmt>(indirect(Parser<EndfileStmt>{})),
112
    construct<ActionStmt>(indirect(Parser<EventPostStmt>{})),
113
    construct<ActionStmt>(indirect(Parser<EventWaitStmt>{})),
114
    construct<ActionStmt>(indirect(Parser<ExitStmt>{})),
115
    construct<ActionStmt>(construct<FailImageStmt>("FAIL IMAGE"_sptok)),
116
    construct<ActionStmt>(indirect(Parser<FlushStmt>{})),
117
    construct<ActionStmt>(indirect(Parser<FormTeamStmt>{})),
118
    construct<ActionStmt>(indirect(Parser<GotoStmt>{})),
119
    construct<ActionStmt>(indirect(Parser<IfStmt>{})),
120
    construct<ActionStmt>(indirect(Parser<InquireStmt>{})),
121
    construct<ActionStmt>(indirect(Parser<LockStmt>{})),
122
    construct<ActionStmt>(indirect(Parser<NotifyWaitStmt>{})),
123
    construct<ActionStmt>(indirect(Parser<NullifyStmt>{})),
124
    construct<ActionStmt>(indirect(Parser<OpenStmt>{})),
125
    construct<ActionStmt>(indirect(Parser<PrintStmt>{})),
126
    construct<ActionStmt>(indirect(Parser<ReadStmt>{})),
127
    construct<ActionStmt>(indirect(Parser<ReturnStmt>{})),
128
    construct<ActionStmt>(indirect(Parser<RewindStmt>{})),
129
    construct<ActionStmt>(indirect(Parser<StopStmt>{})), // & error-stop-stmt
130
    construct<ActionStmt>(indirect(Parser<SyncAllStmt>{})),
131
    construct<ActionStmt>(indirect(Parser<SyncImagesStmt>{})),
132
    construct<ActionStmt>(indirect(Parser<SyncMemoryStmt>{})),
133
    construct<ActionStmt>(indirect(Parser<SyncTeamStmt>{})),
134
    construct<ActionStmt>(indirect(Parser<UnlockStmt>{})),
135
    construct<ActionStmt>(indirect(Parser<WaitStmt>{})),
136
    construct<ActionStmt>(indirect(whereStmt)),
137
    construct<ActionStmt>(indirect(Parser<WriteStmt>{})),
138
    construct<ActionStmt>(indirect(Parser<ComputedGotoStmt>{})),
139
    construct<ActionStmt>(indirect(forallStmt)),
140
    construct<ActionStmt>(indirect(Parser<ArithmeticIfStmt>{})),
141
    construct<ActionStmt>(indirect(Parser<AssignStmt>{})),
142
    construct<ActionStmt>(indirect(Parser<AssignedGotoStmt>{})),
143
    construct<ActionStmt>(indirect(Parser<PauseStmt>{}))))
144

145
// R1102 associate-construct -> associate-stmt block end-associate-stmt
146
TYPE_CONTEXT_PARSER("ASSOCIATE construct"_en_US,
147
    construct<AssociateConstruct>(statement(Parser<AssociateStmt>{}), block,
148
        statement(Parser<EndAssociateStmt>{})))
149

150
// R1103 associate-stmt ->
151
//        [associate-construct-name :] ASSOCIATE ( association-list )
152
TYPE_CONTEXT_PARSER("ASSOCIATE statement"_en_US,
153
    construct<AssociateStmt>(maybe(name / ":"),
154
        "ASSOCIATE" >> parenthesized(nonemptyList(Parser<Association>{}))))
155

156
// R1104 association -> associate-name => selector
157
TYPE_PARSER(construct<Association>(name, "=>" >> selector))
158

159
// R1105 selector -> expr | variable
160
TYPE_PARSER(construct<Selector>(variable) / lookAhead(","_tok || ")"_tok) ||
161
    construct<Selector>(expr))
162

163
// R1106 end-associate-stmt -> END ASSOCIATE [associate-construct-name]
164
TYPE_PARSER(construct<EndAssociateStmt>(recovery(
165
    "END ASSOCIATE" >> maybe(name), namedConstructEndStmtErrorRecovery)))
166

167
// R1107 block-construct ->
168
//         block-stmt [block-specification-part] block end-block-stmt
169
TYPE_CONTEXT_PARSER("BLOCK construct"_en_US,
170
    construct<BlockConstruct>(statement(Parser<BlockStmt>{}),
171
        Parser<BlockSpecificationPart>{}, // can be empty
172
        block, statement(Parser<EndBlockStmt>{})))
173

174
// R1108 block-stmt -> [block-construct-name :] BLOCK
175
TYPE_PARSER(construct<BlockStmt>(maybe(name / ":") / "BLOCK"))
176

177
// R1109 block-specification-part ->
178
//         [use-stmt]... [import-stmt]... [implicit-part]
179
//         [[declaration-construct]... specification-construct]
180
// C1107 prohibits COMMON, EQUIVALENCE, INTENT, NAMELIST, OPTIONAL, VALUE,
181
// and statement function definitions.  C1108 prohibits SAVE /common/.
182
// C1570 indirectly prohibits ENTRY.  These constraints are best enforced later.
183
// The odd grammar rule above would have the effect of forcing any
184
// trailing FORMAT and DATA statements after the last specification-construct
185
// to be recognized as part of the block-construct's block part rather than
186
// its block-specification-part, a distinction without any apparent difference.
187
TYPE_PARSER(construct<BlockSpecificationPart>(specificationPart))
188

189
// R1110 end-block-stmt -> END BLOCK [block-construct-name]
190
TYPE_PARSER(construct<EndBlockStmt>(
191
    recovery("END BLOCK" >> maybe(name), namedConstructEndStmtErrorRecovery)))
192

193
// R1111 change-team-construct -> change-team-stmt block end-change-team-stmt
194
TYPE_CONTEXT_PARSER("CHANGE TEAM construct"_en_US,
195
    construct<ChangeTeamConstruct>(statement(Parser<ChangeTeamStmt>{}), block,
196
        statement(Parser<EndChangeTeamStmt>{})))
197

198
// R1112 change-team-stmt ->
199
//         [team-construct-name :] CHANGE TEAM
200
//         ( team-value [, coarray-association-list] [, sync-stat-list] )
201
TYPE_CONTEXT_PARSER("CHANGE TEAM statement"_en_US,
202
    construct<ChangeTeamStmt>(maybe(name / ":"),
203
        "CHANGE TEAM"_sptok >> "("_tok >> teamValue,
204
        defaulted("," >> nonemptyList(Parser<CoarrayAssociation>{})),
205
        defaulted("," >> nonemptyList(statOrErrmsg))) /
206
        ")")
207

208
// R1113 coarray-association -> codimension-decl => selector
209
TYPE_PARSER(
210
    construct<CoarrayAssociation>(Parser<CodimensionDecl>{}, "=>" >> selector))
211

212
// R1114 end-change-team-stmt ->
213
//         END TEAM [( [sync-stat-list] )] [team-construct-name]
214
TYPE_CONTEXT_PARSER("END TEAM statement"_en_US,
215
    construct<EndChangeTeamStmt>(
216
        "END TEAM" >> defaulted(parenthesized(optionalList(statOrErrmsg))),
217
        maybe(name)))
218

219
// R1117 critical-stmt ->
220
//         [critical-construct-name :] CRITICAL [( [sync-stat-list] )]
221
TYPE_CONTEXT_PARSER("CRITICAL statement"_en_US,
222
    construct<CriticalStmt>(maybe(name / ":"),
223
        "CRITICAL" >> defaulted(parenthesized(optionalList(statOrErrmsg)))))
224

225
// R1116 critical-construct -> critical-stmt block end-critical-stmt
226
TYPE_CONTEXT_PARSER("CRITICAL construct"_en_US,
227
    construct<CriticalConstruct>(statement(Parser<CriticalStmt>{}), block,
228
        statement(Parser<EndCriticalStmt>{})))
229

230
// R1118 end-critical-stmt -> END CRITICAL [critical-construct-name]
231
TYPE_PARSER(construct<EndCriticalStmt>(recovery(
232
    "END CRITICAL" >> maybe(name), namedConstructEndStmtErrorRecovery)))
233

234
// R1119 do-construct -> do-stmt block end-do
235
// R1120 do-stmt -> nonlabel-do-stmt | label-do-stmt
236
TYPE_CONTEXT_PARSER("DO construct"_en_US,
237
    construct<DoConstruct>(
238
        statement(Parser<NonLabelDoStmt>{}) / EnterNonlabelDoConstruct{}, block,
239
        statement(Parser<EndDoStmt>{}) / LeaveDoConstruct{}))
240

241
// R1125 concurrent-header ->
242
//         ( [integer-type-spec ::] concurrent-control-list
243
//         [, scalar-mask-expr] )
244
TYPE_PARSER(parenthesized(construct<ConcurrentHeader>(
245
    maybe(integerTypeSpec / "::"), nonemptyList(Parser<ConcurrentControl>{}),
246
    maybe("," >> scalarLogicalExpr))))
247

248
// R1126 concurrent-control ->
249
//         index-name = concurrent-limit : concurrent-limit [: concurrent-step]
250
// R1127 concurrent-limit -> scalar-int-expr
251
// R1128 concurrent-step -> scalar-int-expr
252
TYPE_PARSER(construct<ConcurrentControl>(name / "=", scalarIntExpr / ":",
253
    scalarIntExpr, maybe(":" >> scalarIntExpr)))
254

255
// R1130 locality-spec ->
256
//         LOCAL ( variable-name-list ) | LOCAL_INIT ( variable-name-list ) |
257
//         REDUCE ( reduce-operation : variable-name-list ) |
258
//         SHARED ( variable-name-list ) | DEFAULT ( NONE )
259
TYPE_PARSER(construct<LocalitySpec>(construct<LocalitySpec::Local>(
260
                "LOCAL" >> parenthesized(listOfNames))) ||
261
    construct<LocalitySpec>(construct<LocalitySpec::LocalInit>(
262
        "LOCAL_INIT"_sptok >> parenthesized(listOfNames))) ||
263
    construct<LocalitySpec>(construct<LocalitySpec::Reduce>(
264
        "REDUCE (" >> Parser<LocalitySpec::Reduce::Operator>{} / ":",
265
        listOfNames / ")")) ||
266
    construct<LocalitySpec>(construct<LocalitySpec::Shared>(
267
        "SHARED" >> parenthesized(listOfNames))) ||
268
    construct<LocalitySpec>(
269
        construct<LocalitySpec::DefaultNone>("DEFAULT ( NONE )"_tok)))
270

271
// R1123 loop-control ->
272
//         [,] do-variable = scalar-int-expr , scalar-int-expr
273
//           [, scalar-int-expr] |
274
//         [,] WHILE ( scalar-logical-expr ) |
275
//         [,] CONCURRENT concurrent-header concurrent-locality
276
// R1129 concurrent-locality -> [locality-spec]...
277
TYPE_CONTEXT_PARSER("loop control"_en_US,
278
    maybe(","_tok) >>
279
        (construct<LoopControl>(loopBounds(scalarExpr)) ||
280
            construct<LoopControl>(
281
                "WHILE" >> parenthesized(scalarLogicalExpr)) ||
282
            construct<LoopControl>(construct<LoopControl::Concurrent>(
283
                "CONCURRENT" >> concurrentHeader,
284
                many(Parser<LocalitySpec>{})))))
285

286
// R1121 label-do-stmt -> [do-construct-name :] DO label [loop-control]
287
// A label-do-stmt with a do-construct-name is parsed as a nonlabel-do-stmt
288
// with an optional label.
289
TYPE_CONTEXT_PARSER("label DO statement"_en_US,
290
    construct<LabelDoStmt>("DO" >> label, maybe(loopControl)))
291

292
// R1122 nonlabel-do-stmt -> [do-construct-name :] DO [loop-control]
293
TYPE_CONTEXT_PARSER("nonlabel DO statement"_en_US,
294
    construct<NonLabelDoStmt>(
295
        name / ":", "DO" >> maybe(label), maybe(loopControl)) ||
296
        construct<NonLabelDoStmt>(construct<std::optional<Name>>(),
297
            construct<std::optional<Label>>(), "DO" >> maybe(loopControl)))
298

299
// R1132 end-do-stmt -> END DO [do-construct-name]
300
TYPE_CONTEXT_PARSER("END DO statement"_en_US,
301
    construct<EndDoStmt>(
302
        recovery("END DO" >> maybe(name), namedConstructEndStmtErrorRecovery)))
303

304
// R1133 cycle-stmt -> CYCLE [do-construct-name]
305
TYPE_CONTEXT_PARSER(
306
    "CYCLE statement"_en_US, construct<CycleStmt>("CYCLE" >> maybe(name)))
307

308
// R1134 if-construct ->
309
//         if-then-stmt block [else-if-stmt block]...
310
//         [else-stmt block] end-if-stmt
311
// R1135 if-then-stmt -> [if-construct-name :] IF ( scalar-logical-expr )
312
// THEN R1136 else-if-stmt ->
313
//         ELSE IF ( scalar-logical-expr ) THEN [if-construct-name]
314
// R1137 else-stmt -> ELSE [if-construct-name]
315
// R1138 end-if-stmt -> END IF [if-construct-name]
316
TYPE_CONTEXT_PARSER("IF construct"_en_US,
317
    construct<IfConstruct>(
318
        statement(construct<IfThenStmt>(maybe(name / ":"),
319
            "IF" >> parenthesized(scalarLogicalExpr) /
320
                    recovery("THEN"_tok, lookAhead(endOfStmt)))),
321
        block,
322
        many(construct<IfConstruct::ElseIfBlock>(
323
            unambiguousStatement(construct<ElseIfStmt>(
324
                "ELSE IF" >> parenthesized(scalarLogicalExpr),
325
                recovery("THEN"_tok, ok) >> maybe(name))),
326
            block)),
327
        maybe(construct<IfConstruct::ElseBlock>(
328
            statement(construct<ElseStmt>("ELSE" >> maybe(name))), block)),
329
        statement(construct<EndIfStmt>(recovery(
330
            "END IF" >> maybe(name), namedConstructEndStmtErrorRecovery)))))
331

332
// R1139 if-stmt -> IF ( scalar-logical-expr ) action-stmt
333
TYPE_CONTEXT_PARSER("IF statement"_en_US,
334
    construct<IfStmt>("IF" >> parenthesized(scalarLogicalExpr),
335
        unlabeledStatement(actionStmt)))
336

337
// R1140 case-construct ->
338
//         select-case-stmt [case-stmt block]... end-select-stmt
339
TYPE_CONTEXT_PARSER("SELECT CASE construct"_en_US,
340
    construct<CaseConstruct>(statement(Parser<SelectCaseStmt>{}),
341
        many(construct<CaseConstruct::Case>(
342
            unambiguousStatement(Parser<CaseStmt>{}), block)),
343
        statement(endSelectStmt)))
344

345
// R1141 select-case-stmt -> [case-construct-name :] SELECT CASE ( case-expr
346
// ) R1144 case-expr -> scalar-expr
347
TYPE_CONTEXT_PARSER("SELECT CASE statement"_en_US,
348
    construct<SelectCaseStmt>(
349
        maybe(name / ":"), "SELECT CASE" >> parenthesized(scalar(expr))))
350

351
// R1142 case-stmt -> CASE case-selector [case-construct-name]
352
TYPE_CONTEXT_PARSER("CASE statement"_en_US,
353
    construct<CaseStmt>("CASE" >> Parser<CaseSelector>{}, maybe(name)))
354

355
// R1143 end-select-stmt -> END SELECT [case-construct-name]
356
// R1151 end-select-rank-stmt -> END SELECT [select-construct-name]
357
// R1155 end-select-type-stmt -> END SELECT [select-construct-name]
358
TYPE_PARSER(construct<EndSelectStmt>(
359
    recovery("END SELECT" >> maybe(name), namedConstructEndStmtErrorRecovery)))
360

361
// R1145 case-selector -> ( case-value-range-list ) | DEFAULT
362
constexpr auto defaultKeyword{construct<Default>("DEFAULT"_tok)};
363
TYPE_PARSER(parenthesized(construct<CaseSelector>(
364
                nonemptyList(Parser<CaseValueRange>{}))) ||
365
    construct<CaseSelector>(defaultKeyword))
366

367
// R1147 case-value -> scalar-constant-expr
368
constexpr auto caseValue{scalar(constantExpr)};
369

370
// R1146 case-value-range ->
371
//         case-value | case-value : | : case-value | case-value : case-value
372
TYPE_PARSER(construct<CaseValueRange>(construct<CaseValueRange::Range>(
373
                construct<std::optional<CaseValue>>(caseValue),
374
                ":" >> maybe(caseValue))) ||
375
    construct<CaseValueRange>(
376
        construct<CaseValueRange::Range>(construct<std::optional<CaseValue>>(),
377
            ":" >> construct<std::optional<CaseValue>>(caseValue))) ||
378
    construct<CaseValueRange>(caseValue))
379

380
// R1148 select-rank-construct ->
381
//         select-rank-stmt [select-rank-case-stmt block]...
382
//         end-select-rank-stmt
383
TYPE_CONTEXT_PARSER("SELECT RANK construct"_en_US,
384
    construct<SelectRankConstruct>(statement(Parser<SelectRankStmt>{}),
385
        many(construct<SelectRankConstruct::RankCase>(
386
            unambiguousStatement(Parser<SelectRankCaseStmt>{}), block)),
387
        statement(endSelectStmt)))
388

389
// R1149 select-rank-stmt ->
390
//         [select-construct-name :] SELECT RANK
391
//         ( [associate-name =>] selector )
392
TYPE_CONTEXT_PARSER("SELECT RANK statement"_en_US,
393
    construct<SelectRankStmt>(maybe(name / ":"),
394
        "SELECT RANK"_sptok >> "("_tok >> maybe(name / "=>"), selector / ")"))
395

396
// R1150 select-rank-case-stmt ->
397
//         RANK ( scalar-int-constant-expr ) [select-construct-name] |
398
//         RANK ( * ) [select-construct-name] |
399
//         RANK DEFAULT [select-construct-name]
400
TYPE_CONTEXT_PARSER("RANK case statement"_en_US,
401
    "RANK" >> (construct<SelectRankCaseStmt>(
402
                  parenthesized(construct<SelectRankCaseStmt::Rank>(
403
                                    scalarIntConstantExpr) ||
404
                      construct<SelectRankCaseStmt::Rank>(star)) ||
405
                      construct<SelectRankCaseStmt::Rank>(defaultKeyword),
406
                  maybe(name))))
407

408
// R1152 select-type-construct ->
409
//         select-type-stmt [type-guard-stmt block]... end-select-type-stmt
410
TYPE_CONTEXT_PARSER("SELECT TYPE construct"_en_US,
411
    construct<SelectTypeConstruct>(statement(Parser<SelectTypeStmt>{}),
412
        many(construct<SelectTypeConstruct::TypeCase>(
413
            unambiguousStatement(Parser<TypeGuardStmt>{}), block)),
414
        statement(endSelectStmt)))
415

416
// R1153 select-type-stmt ->
417
//         [select-construct-name :] SELECT TYPE
418
//         ( [associate-name =>] selector )
419
TYPE_CONTEXT_PARSER("SELECT TYPE statement"_en_US,
420
    construct<SelectTypeStmt>(maybe(name / ":"),
421
        "SELECT TYPE (" >> maybe(name / "=>"), selector / ")"))
422

423
// R1154 type-guard-stmt ->
424
//         TYPE IS ( type-spec ) [select-construct-name] |
425
//         CLASS IS ( derived-type-spec ) [select-construct-name] |
426
//         CLASS DEFAULT [select-construct-name]
427
TYPE_CONTEXT_PARSER("type guard statement"_en_US,
428
    construct<TypeGuardStmt>("TYPE IS"_sptok >>
429
                parenthesized(construct<TypeGuardStmt::Guard>(typeSpec)) ||
430
            "CLASS IS"_sptok >> parenthesized(construct<TypeGuardStmt::Guard>(
431
                                    derivedTypeSpec)) ||
432
            construct<TypeGuardStmt::Guard>("CLASS" >> defaultKeyword),
433
        maybe(name)))
434

435
// R1156 exit-stmt -> EXIT [construct-name]
436
TYPE_CONTEXT_PARSER(
437
    "EXIT statement"_en_US, construct<ExitStmt>("EXIT" >> maybe(name)))
438

439
// R1157 goto-stmt -> GO TO label
440
TYPE_CONTEXT_PARSER(
441
    "GOTO statement"_en_US, construct<GotoStmt>("GO TO" >> label))
442

443
// R1158 computed-goto-stmt -> GO TO ( label-list ) [,] scalar-int-expr
444
TYPE_CONTEXT_PARSER("computed GOTO statement"_en_US,
445
    construct<ComputedGotoStmt>("GO TO" >> parenthesized(nonemptyList(label)),
446
        maybe(","_tok) >> scalarIntExpr))
447

448
// R1160 stop-stmt -> STOP [stop-code] [, QUIET = scalar-logical-expr]
449
// R1161 error-stop-stmt ->
450
//         ERROR STOP [stop-code] [, QUIET = scalar-logical-expr]
451
TYPE_CONTEXT_PARSER("STOP statement"_en_US,
452
    construct<StopStmt>("STOP" >> pure(StopStmt::Kind::Stop) ||
453
            "ERROR STOP"_sptok >> pure(StopStmt::Kind::ErrorStop),
454
        maybe(Parser<StopCode>{}), maybe(", QUIET =" >> scalarLogicalExpr)))
455

456
// R1162 stop-code -> scalar-default-char-expr | scalar-int-expr
457
// The two alternatives for stop-code can't be distinguished at
458
// parse time.
459
TYPE_PARSER(construct<StopCode>(scalar(expr)))
460

461
// F2030: R1166 notify-wait-stmt ->
462
//         NOTIFY WAIT ( notify-variable [, event-wait-spec-list] )
463
TYPE_CONTEXT_PARSER("NOTIFY WAIT statement"_en_US,
464
    construct<NotifyWaitStmt>(
465
        "NOTIFY WAIT"_sptok >> "("_tok >> scalar(variable),
466
        defaulted("," >> nonemptyList(Parser<EventWaitSpec>{})) / ")"))
467

468
// R1164 sync-all-stmt -> SYNC ALL [( [sync-stat-list] )]
469
TYPE_CONTEXT_PARSER("SYNC ALL statement"_en_US,
470
    construct<SyncAllStmt>("SYNC ALL"_sptok >>
471
        defaulted(parenthesized(optionalList(statOrErrmsg)))))
472

473
// R1166 sync-images-stmt -> SYNC IMAGES ( image-set [, sync-stat-list] )
474
// R1167 image-set -> int-expr | *
475
TYPE_CONTEXT_PARSER("SYNC IMAGES statement"_en_US,
476
    "SYNC IMAGES"_sptok >> parenthesized(construct<SyncImagesStmt>(
477
                               construct<SyncImagesStmt::ImageSet>(intExpr) ||
478
                                   construct<SyncImagesStmt::ImageSet>(star),
479
                               defaulted("," >> nonemptyList(statOrErrmsg)))))
480

481
// R1168 sync-memory-stmt -> SYNC MEMORY [( [sync-stat-list] )]
482
TYPE_CONTEXT_PARSER("SYNC MEMORY statement"_en_US,
483
    construct<SyncMemoryStmt>("SYNC MEMORY"_sptok >>
484
        defaulted(parenthesized(optionalList(statOrErrmsg)))))
485

486
// R1169 sync-team-stmt -> SYNC TEAM ( team-value [, sync-stat-list] )
487
TYPE_CONTEXT_PARSER("SYNC TEAM statement"_en_US,
488
    construct<SyncTeamStmt>("SYNC TEAM"_sptok >> "("_tok >> teamValue,
489
        defaulted("," >> nonemptyList(statOrErrmsg)) / ")"))
490

491
// R1170 event-post-stmt -> EVENT POST ( event-variable [, sync-stat-list] )
492
// R1171 event-variable -> scalar-variable
493
TYPE_CONTEXT_PARSER("EVENT POST statement"_en_US,
494
    construct<EventPostStmt>("EVENT POST"_sptok >> "("_tok >> scalar(variable),
495
        defaulted("," >> nonemptyList(statOrErrmsg)) / ")"))
496

497
// R1172 event-wait-stmt ->
498
//         EVENT WAIT ( event-variable [, event-wait-spec-list] )
499
TYPE_CONTEXT_PARSER("EVENT WAIT statement"_en_US,
500
    construct<EventWaitStmt>("EVENT WAIT"_sptok >> "("_tok >> scalar(variable),
501
        defaulted("," >> nonemptyList(Parser<EventWaitSpec>{})) / ")"))
502

503
// R1174 until-spec -> UNTIL_COUNT = scalar-int-expr
504
constexpr auto untilSpec{"UNTIL_COUNT =" >> scalarIntExpr};
505

506
// R1173 event-wait-spec -> until-spec | sync-stat
507
TYPE_PARSER(construct<EventWaitSpec>(untilSpec) ||
508
    construct<EventWaitSpec>(statOrErrmsg))
509

510
// R1177 team-variable -> scalar-variable
511
constexpr auto teamVariable{scalar(variable)};
512

513
// R1175 form-team-stmt ->
514
//         FORM TEAM ( team-number , team-variable [, form-team-spec-list] )
515
// R1176 team-number -> scalar-int-expr
516
TYPE_CONTEXT_PARSER("FORM TEAM statement"_en_US,
517
    construct<FormTeamStmt>("FORM TEAM"_sptok >> "("_tok >> scalarIntExpr,
518
        "," >> teamVariable,
519
        defaulted("," >> nonemptyList(Parser<FormTeamStmt::FormTeamSpec>{})) /
520
            ")"))
521

522
// R1178 form-team-spec -> NEW_INDEX = scalar-int-expr | sync-stat
523
TYPE_PARSER(
524
    construct<FormTeamStmt::FormTeamSpec>("NEW_INDEX =" >> scalarIntExpr) ||
525
    construct<FormTeamStmt::FormTeamSpec>(statOrErrmsg))
526

527
// R1182 lock-variable -> scalar-variable
528
constexpr auto lockVariable{scalar(variable)};
529

530
// R1179 lock-stmt -> LOCK ( lock-variable [, lock-stat-list] )
531
TYPE_CONTEXT_PARSER("LOCK statement"_en_US,
532
    construct<LockStmt>("LOCK (" >> lockVariable,
533
        defaulted("," >> nonemptyList(Parser<LockStmt::LockStat>{})) / ")"))
534

535
// R1180 lock-stat -> ACQUIRED_LOCK = scalar-logical-variable | sync-stat
536
TYPE_PARSER(
537
    construct<LockStmt::LockStat>("ACQUIRED_LOCK =" >> scalarLogicalVariable) ||
538
    construct<LockStmt::LockStat>(statOrErrmsg))
539

540
// R1181 unlock-stmt -> UNLOCK ( lock-variable [, sync-stat-list] )
541
TYPE_CONTEXT_PARSER("UNLOCK statement"_en_US,
542
    construct<UnlockStmt>("UNLOCK (" >> lockVariable,
543
        defaulted("," >> nonemptyList(statOrErrmsg)) / ")"))
544

545
// CUF-kernel-do-construct ->
546
//   !$CUF KERNEL DO [ (scalar-int-constant-expr) ]
547
//      <<< grid, block [, stream] >>>
548
//      [ cuf-reduction... ]
549
//      do-construct
550
// star-or-expr -> * | scalar-int-expr
551
// grid -> * | scalar-int-expr | ( star-or-expr-list )
552
// block -> * | scalar-int-expr | ( star-or-expr-list )
553
// stream -> 0, scalar-int-expr | STREAM = scalar-int-expr
554
// cuf-reduction -> [ REDUCTION | REDUCE ] (
555
//                  acc-reduction-op : scalar-variable-list )
556

557
constexpr auto starOrExpr{construct<CUFKernelDoConstruct::StarOrExpr>(
558
    "*" >> pure<std::optional<ScalarIntExpr>>() ||
559
    applyFunction(presentOptional<ScalarIntExpr>, scalarIntExpr))};
560
constexpr auto gridOrBlock{parenthesized(nonemptyList(starOrExpr)) ||
561
    applyFunction(singletonList<CUFKernelDoConstruct::StarOrExpr>, starOrExpr)};
562

563
TYPE_PARSER(("REDUCTION"_tok || "REDUCE"_tok) >>
564
    parenthesized(construct<CUFReduction>(Parser<CUFReduction::Operator>{},
565
        ":" >> nonemptyList(scalar(variable)))))
566

567
TYPE_PARSER(sourced(beginDirective >> "$CUF KERNEL DO"_tok >>
568
    construct<CUFKernelDoConstruct::Directive>(
569
        maybe(parenthesized(scalarIntConstantExpr)), "<<<" >> gridOrBlock,
570
        "," >> gridOrBlock,
571
        maybe((", 0 ,"_tok || ", STREAM ="_tok) >> scalarIntExpr) / ">>>",
572
        many(Parser<CUFReduction>{}) / endDirective)))
573
TYPE_CONTEXT_PARSER("!$CUF KERNEL DO construct"_en_US,
574
    extension<LanguageFeature::CUDA>(construct<CUFKernelDoConstruct>(
575
        Parser<CUFKernelDoConstruct::Directive>{},
576
        maybe(Parser<DoConstruct>{}))))
577

578
} // namespace Fortran::parser
579