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
20namespace 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
35constexpr 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
61constexpr 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
68TYPE_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]...
85TYPE_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
100TYPE_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
144TYPE_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 )
150TYPE_CONTEXT_PARSER("ASSOCIATE statement"_en_US,
151 construct<AssociateStmt>(maybe(name / ":"),
152 "ASSOCIATE" >> parenthesized(nonemptyList(Parser<Association>{}))))
153
154// R1104 association -> associate-name => selector
155TYPE_PARSER(construct<Association>(name, "=>" >> selector))
156
157// R1105 selector -> expr | variable
158TYPE_PARSER(construct<Selector>(variable) / lookAhead(","_tok || ")"_tok) ||
159 construct<Selector>(expr))
160
161// R1106 end-associate-stmt -> END ASSOCIATE [associate-construct-name]
162TYPE_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
167TYPE_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
173TYPE_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.
185TYPE_PARSER(construct<BlockSpecificationPart>(specificationPart))
186
187// R1110 end-block-stmt -> END BLOCK [block-construct-name]
188TYPE_PARSER(construct<EndBlockStmt>(
189 recovery("END BLOCK" >> maybe(name), namedConstructEndStmtErrorRecovery)))
190
191// R1111 change-team-construct -> change-team-stmt block end-change-team-stmt
192TYPE_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] )
199TYPE_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
207TYPE_PARSER(
208 construct<CoarrayAssociation>(Parser<CodimensionDecl>{}, "=>" >> selector))
209
210// R1114 end-change-team-stmt ->
211// END TEAM [( [sync-stat-list] )] [team-construct-name]
212TYPE_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] )]
219TYPE_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
224TYPE_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]
229TYPE_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
234TYPE_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] )
242TYPE_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
250TYPE_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 )
257TYPE_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]...
275TYPE_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.
288static 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.
295TYPE_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]
299TYPE_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]
306TYPE_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]
311TYPE_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]
322TYPE_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
339TYPE_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
345TYPE_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
353TYPE_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]
358TYPE_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]
364TYPE_PARSER(construct<EndSelectStmt>(
365 recovery("END SELECT" >> maybe(name), namedConstructEndStmtErrorRecovery)))
366
367// R1145 case-selector -> ( case-value-range-list ) | DEFAULT
368constexpr auto defaultKeyword{construct<Default>("DEFAULT"_tok)};
369TYPE_PARSER(parenthesized(construct<CaseSelector>(
370 nonemptyList(Parser<CaseValueRange>{}))) ||
371 construct<CaseSelector>(defaultKeyword))
372
373// R1147 case-value -> scalar-constant-expr
374constexpr auto caseValue{scalar(constantExpr)};
375
376// R1146 case-value-range ->
377// case-value | case-value : | : case-value | case-value : case-value
378TYPE_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
389TYPE_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 )
398TYPE_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]
406TYPE_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
416TYPE_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 )
425TYPE_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]
433TYPE_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]
442TYPE_CONTEXT_PARSER(
443 "EXIT statement"_en_US, construct<ExitStmt>("EXIT" >> maybe(name)))
444
445// R1157 goto-stmt -> GO TO label
446TYPE_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
450TYPE_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]
457TYPE_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.
465TYPE_PARSER(construct<StopCode>(scalar(expr)))
466
467// F2030: R1166 notify-wait-stmt ->
468// NOTIFY WAIT ( notify-variable [, event-wait-spec-list] )
469TYPE_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] )]
475TYPE_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 | *
481TYPE_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] )]
488TYPE_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] )
493TYPE_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
499TYPE_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] )
505TYPE_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
510constexpr auto untilSpec{"UNTIL_COUNT =" >> scalarIntExpr};
511
512// R1173 event-wait-spec -> until-spec | sync-stat
513TYPE_PARSER(construct<EventWaitSpec>(untilSpec) ||
514 construct<EventWaitSpec>(statOrErrmsg))
515
516// R1177 team-variable -> scalar-variable
517constexpr 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
522TYPE_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
529TYPE_PARSER(
530 construct<FormTeamStmt::FormTeamSpec>("NEW_INDEX =" >> scalarIntExpr) ||
531 construct<FormTeamStmt::FormTeamSpec>(statOrErrmsg))
532
533// R1182 lock-variable -> scalar-variable
534constexpr auto lockVariable{scalar(variable)};
535
536// R1179 lock-stmt -> LOCK ( lock-variable [, lock-stat-list] )
537TYPE_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
542TYPE_PARSER(
543 construct<LockStmt::LockStat>("ACQUIRED_LOCK =" >> scalarLogicalVariable) ||
544 construct<LockStmt::LockStat>(statOrErrmsg))
545
546// R1181 unlock-stmt -> UNLOCK ( lock-variable [, sync-stat-list] )
547TYPE_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
563constexpr auto starOrExpr{construct<CUFKernelDoConstruct::StarOrExpr>(
564 "*" >> pure<std::optional<ScalarIntExpr>>() ||
565 applyFunction(presentOptional<ScalarIntExpr>, scalarIntExpr))};
566constexpr auto gridOrBlock{parenthesized(nonemptyList(starOrExpr)) ||
567 applyFunction(singletonList<CUFKernelDoConstruct::StarOrExpr>, starOrExpr)};
568
569TYPE_PARSER(("REDUCTION"_tok || "REDUCE"_tok) >>
570 parenthesized(construct<CUFReduction>(Parser<CUFReduction::Operator>{},
571 ":" >> nonemptyList(scalar(variable)))))
572
573TYPE_PARSER("<<<" >>
574 construct<CUFKernelDoConstruct::LaunchConfiguration>(gridOrBlock,
575 "," >> gridOrBlock,
576 maybe((", 0 ,"_tok || ", STREAM ="_tok) >> scalarIntExpr) / ">>>"))
577
578TYPE_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)))
583TYPE_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
589

source code of flang/lib/Parser/executable-parsers.cpp