1 // Copyright (c) 2018-2019, NVIDIA CORPORATION. All rights reserved.
2 //
3 // Licensed under the Apache License, Version 2.0 (the "License");
4 // you may not use this file except in compliance with the License.
5 // You may obtain a copy of the License at
6 //
7 // http://www.apache.org/licenses/LICENSE-2.0
8 //
9 // Unless required by applicable law or agreed to in writing, software
10 // distributed under the License is distributed on an "AS IS" BASIS,
11 // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12 // See the License for the specific language governing permissions and
13 // limitations under the License.
14
15 #ifndef FORTRAN_PARSER_GRAMMAR_H_
16 #define FORTRAN_PARSER_GRAMMAR_H_
17
18 // Top-level grammar specification for Fortran. These parsers drive
19 // the tokenization parsers in cooked-tokens.h to consume characters,
20 // recognize the productions of Fortran, and to construct a parse tree.
21 // See ParserCombinators.md for documentation on the parser combinator
22 // library used here to implement an LL recursive descent recognizer.
23
24 #include "basic-parsers.h"
25 #include "characters.h"
26 #include "debug-parser.h"
27 #include "parse-tree.h"
28 #include "stmt-parser.h"
29 #include "token-parsers.h"
30 #include "type-parsers.h"
31 #include "user-state.h"
32 #include <cinttypes>
33 #include <cstdio>
34 #include <functional>
35 #include <list>
36 #include <optional>
37 #include <string>
38 #include <tuple>
39 #include <utility>
40
41 namespace Fortran::parser {
42
43 // The productions that follow are derived from the draft Fortran 2018
44 // standard, with some necessary modifications to remove left recursion
45 // and some generalization in order to defer cases where parses depend
46 // on the definitions of symbols. The "Rxxx" numbers that appear in
47 // comments refer to these numbered requirements in the Fortran standard.
48
49 // R507 declaration-construct ->
50 // specification-construct | data-stmt | format-stmt |
51 // entry-stmt | stmt-function-stmt
52 // N.B. These parsers incorporate recognition of some other statements that
53 // may have been misplaced in the sequence of statements that are acceptable
54 // as a specification part in order to improve error recovery.
55 // Also note that many instances of specification-part in the standard grammar
56 // are in contexts that impose constraints on the kinds of statements that
57 // are allowed, and so we have a variant production for declaration-construct
58 // that implements those constraints.
59 constexpr auto execPartLookAhead{
60 first(actionStmt >> ok, ompEndLoopDirective >> ok, openmpConstruct >> ok,
61 "ASSOCIATE ("_tok, "BLOCK"_tok, "SELECT"_tok, "CHANGE TEAM"_sptok,
62 "CRITICAL"_tok, "DO"_tok, "IF ("_tok, "WHERE ("_tok, "FORALL ("_tok)};
63 constexpr auto declErrorRecovery{
64 stmtErrorRecoveryStart >> !execPartLookAhead >> skipStmtErrorRecovery};
65 constexpr auto misplacedSpecificationStmt{Parser<UseStmt>{} >>
66 fail<DeclarationConstruct>("misplaced USE statement"_err_en_US) ||
67 Parser<ImportStmt>{} >>
68 fail<DeclarationConstruct>(
69 "IMPORT statements must follow any USE statements and precede all other declarations"_err_en_US) ||
70 Parser<ImplicitStmt>{} >>
71 fail<DeclarationConstruct>(
72 "IMPLICIT statements must follow USE and IMPORT and precede all other declarations"_err_en_US)};
73
74 TYPE_PARSER(recovery(
75 withMessage("expected declaration construct"_err_en_US,
76 CONTEXT_PARSER("declaration construct"_en_US,
77 first(construct<DeclarationConstruct>(specificationConstruct),
78 construct<DeclarationConstruct>(statement(indirect(dataStmt))),
79 construct<DeclarationConstruct>(
80 statement(indirect(formatStmt))),
81 construct<DeclarationConstruct>(statement(indirect(entryStmt))),
82 construct<DeclarationConstruct>(
83 statement(indirect(Parser<StmtFunctionStmt>{}))),
84 misplacedSpecificationStmt))),
85 construct<DeclarationConstruct>(declErrorRecovery)))
86
87 // R507 variant of declaration-construct for use in limitedSpecificationPart.
88 constexpr auto invalidDeclarationStmt{formatStmt >>
89 fail<DeclarationConstruct>(
90 "FORMAT statements are not permitted in this specification part"_err_en_US) ||
91 entryStmt >>
92 fail<DeclarationConstruct>(
93 "ENTRY statements are not permitted in this specification part"_err_en_US)};
94
95 constexpr auto limitedDeclarationConstruct{recovery(
96 withMessage("expected declaration construct"_err_en_US,
97 inContext("declaration construct"_en_US,
98 first(construct<DeclarationConstruct>(specificationConstruct),
99 construct<DeclarationConstruct>(statement(indirect(dataStmt))),
100 misplacedSpecificationStmt, invalidDeclarationStmt))),
101 construct<DeclarationConstruct>(
102 stmtErrorRecoveryStart >> skipStmtErrorRecovery))};
103
104 // R508 specification-construct ->
105 // derived-type-def | enum-def | generic-stmt | interface-block |
106 // parameter-stmt | procedure-declaration-stmt |
107 // other-specification-stmt | type-declaration-stmt
108 TYPE_CONTEXT_PARSER("specification construct"_en_US,
109 first(construct<SpecificationConstruct>(indirect(Parser<DerivedTypeDef>{})),
110 construct<SpecificationConstruct>(indirect(Parser<EnumDef>{})),
111 construct<SpecificationConstruct>(
112 statement(indirect(Parser<GenericStmt>{}))),
113 construct<SpecificationConstruct>(indirect(interfaceBlock)),
114 construct<SpecificationConstruct>(statement(indirect(parameterStmt))),
115 construct<SpecificationConstruct>(
116 statement(indirect(oldParameterStmt))),
117 construct<SpecificationConstruct>(
118 statement(indirect(Parser<ProcedureDeclarationStmt>{}))),
119 construct<SpecificationConstruct>(
120 statement(Parser<OtherSpecificationStmt>{})),
121 construct<SpecificationConstruct>(
122 statement(indirect(typeDeclarationStmt))),
123 construct<SpecificationConstruct>(indirect(Parser<StructureDef>{})),
124 construct<SpecificationConstruct>(indirect(openmpDeclarativeConstruct)),
125 construct<SpecificationConstruct>(indirect(compilerDirective))))
126
127 // R513 other-specification-stmt ->
128 // access-stmt | allocatable-stmt | asynchronous-stmt | bind-stmt |
129 // codimension-stmt | contiguous-stmt | dimension-stmt | external-stmt |
130 // intent-stmt | intrinsic-stmt | namelist-stmt | optional-stmt |
131 // pointer-stmt | protected-stmt | save-stmt | target-stmt |
132 // volatile-stmt | value-stmt | common-stmt | equivalence-stmt
TYPE_PARSER(first (construct<OtherSpecificationStmt> (indirect (Parser<AccessStmt>{})),construct<OtherSpecificationStmt> (indirect (Parser<AllocatableStmt>{})),construct<OtherSpecificationStmt> (indirect (Parser<AsynchronousStmt>{})),construct<OtherSpecificationStmt> (indirect (Parser<BindStmt>{})),construct<OtherSpecificationStmt> (indirect (Parser<CodimensionStmt>{})),construct<OtherSpecificationStmt> (indirect (Parser<ContiguousStmt>{})),construct<OtherSpecificationStmt> (indirect (Parser<DimensionStmt>{})),construct<OtherSpecificationStmt> (indirect (Parser<ExternalStmt>{})),construct<OtherSpecificationStmt> (indirect (Parser<IntentStmt>{})),construct<OtherSpecificationStmt> (indirect (Parser<IntrinsicStmt>{})),construct<OtherSpecificationStmt> (indirect (Parser<NamelistStmt>{})),construct<OtherSpecificationStmt> (indirect (Parser<OptionalStmt>{})),construct<OtherSpecificationStmt> (indirect (Parser<PointerStmt>{})),construct<OtherSpecificationStmt> (indirect (Parser<ProtectedStmt>{})),construct<OtherSpecificationStmt> (indirect (Parser<SaveStmt>{})),construct<OtherSpecificationStmt> (indirect (Parser<TargetStmt>{})),construct<OtherSpecificationStmt> (indirect (Parser<ValueStmt>{})),construct<OtherSpecificationStmt> (indirect (Parser<VolatileStmt>{})),construct<OtherSpecificationStmt> (indirect (Parser<CommonStmt>{})),construct<OtherSpecificationStmt> (indirect (Parser<EquivalenceStmt>{})),construct<OtherSpecificationStmt> (indirect (Parser<BasedPointerStmt>{}))))133 TYPE_PARSER(first(
134 construct<OtherSpecificationStmt>(indirect(Parser<AccessStmt>{})),
135 construct<OtherSpecificationStmt>(indirect(Parser<AllocatableStmt>{})),
136 construct<OtherSpecificationStmt>(indirect(Parser<AsynchronousStmt>{})),
137 construct<OtherSpecificationStmt>(indirect(Parser<BindStmt>{})),
138 construct<OtherSpecificationStmt>(indirect(Parser<CodimensionStmt>{})),
139 construct<OtherSpecificationStmt>(indirect(Parser<ContiguousStmt>{})),
140 construct<OtherSpecificationStmt>(indirect(Parser<DimensionStmt>{})),
141 construct<OtherSpecificationStmt>(indirect(Parser<ExternalStmt>{})),
142 construct<OtherSpecificationStmt>(indirect(Parser<IntentStmt>{})),
143 construct<OtherSpecificationStmt>(indirect(Parser<IntrinsicStmt>{})),
144 construct<OtherSpecificationStmt>(indirect(Parser<NamelistStmt>{})),
145 construct<OtherSpecificationStmt>(indirect(Parser<OptionalStmt>{})),
146 construct<OtherSpecificationStmt>(indirect(Parser<PointerStmt>{})),
147 construct<OtherSpecificationStmt>(indirect(Parser<ProtectedStmt>{})),
148 construct<OtherSpecificationStmt>(indirect(Parser<SaveStmt>{})),
149 construct<OtherSpecificationStmt>(indirect(Parser<TargetStmt>{})),
150 construct<OtherSpecificationStmt>(indirect(Parser<ValueStmt>{})),
151 construct<OtherSpecificationStmt>(indirect(Parser<VolatileStmt>{})),
152 construct<OtherSpecificationStmt>(indirect(Parser<CommonStmt>{})),
153 construct<OtherSpecificationStmt>(indirect(Parser<EquivalenceStmt>{})),
154 construct<OtherSpecificationStmt>(indirect(Parser<BasedPointerStmt>{}))))
155
156 // R604 constant -> literal-constant | named-constant
157 // Used only via R607 int-constant and R845 data-stmt-constant.
158 // The look-ahead check prevents occlusion of constant-subobject in
159 // data-stmt-constant.
160 TYPE_PARSER(construct<ConstantValue>(literalConstant) ||
161 construct<ConstantValue>(namedConstant / !"%"_tok / !"("_tok))
162
163 // R608 intrinsic-operator ->
164 // power-op | mult-op | add-op | concat-op | rel-op |
165 // not-op | and-op | or-op | equiv-op
166 // R610 extended-intrinsic-op -> intrinsic-operator
167 // These parsers must be ordered carefully to avoid misrecognition.
168 constexpr auto namedIntrinsicOperator{
169 ".LT." >> pure(DefinedOperator::IntrinsicOperator::LT) ||
170 ".LE." >> pure(DefinedOperator::IntrinsicOperator::LE) ||
171 ".EQ." >> pure(DefinedOperator::IntrinsicOperator::EQ) ||
172 ".NE." >> pure(DefinedOperator::IntrinsicOperator::NE) ||
173 ".GE." >> pure(DefinedOperator::IntrinsicOperator::GE) ||
174 ".GT." >> pure(DefinedOperator::IntrinsicOperator::GT) ||
175 ".NOT." >> pure(DefinedOperator::IntrinsicOperator::NOT) ||
176 ".AND." >> pure(DefinedOperator::IntrinsicOperator::AND) ||
177 ".OR." >> pure(DefinedOperator::IntrinsicOperator::OR) ||
178 ".EQV." >> pure(DefinedOperator::IntrinsicOperator::EQV) ||
179 ".NEQV." >> pure(DefinedOperator::IntrinsicOperator::NEQV) ||
180 extension<LanguageFeature::XOROperator>(
181 ".XOR." >> pure(DefinedOperator::IntrinsicOperator::XOR)) ||
182 extension<LanguageFeature::LogicalAbbreviations>(
183 ".N." >> pure(DefinedOperator::IntrinsicOperator::NOT) ||
184 ".A." >> pure(DefinedOperator::IntrinsicOperator::AND) ||
185 ".O." >> pure(DefinedOperator::IntrinsicOperator::OR) ||
186 ".X." >> pure(DefinedOperator::IntrinsicOperator::XOR))};
187
188 constexpr auto intrinsicOperator{
189 "**" >> pure(DefinedOperator::IntrinsicOperator::Power) ||
190 "*" >> pure(DefinedOperator::IntrinsicOperator::Multiply) ||
191 "//" >> pure(DefinedOperator::IntrinsicOperator::Concat) ||
192 "/=" >> pure(DefinedOperator::IntrinsicOperator::NE) ||
193 "/" >> pure(DefinedOperator::IntrinsicOperator::Divide) ||
194 "+" >> pure(DefinedOperator::IntrinsicOperator::Add) ||
195 "-" >> pure(DefinedOperator::IntrinsicOperator::Subtract) ||
196 "<=" >> pure(DefinedOperator::IntrinsicOperator::LE) ||
197 extension<LanguageFeature::AlternativeNE>(
198 "<>" >> pure(DefinedOperator::IntrinsicOperator::NE)) ||
199 "<" >> pure(DefinedOperator::IntrinsicOperator::LT) ||
200 "==" >> pure(DefinedOperator::IntrinsicOperator::EQ) ||
201 ">=" >> pure(DefinedOperator::IntrinsicOperator::GE) ||
202 ">" >> pure(DefinedOperator::IntrinsicOperator::GT) ||
203 namedIntrinsicOperator};
204
205 // R609 defined-operator ->
206 // defined-unary-op | defined-binary-op | extended-intrinsic-op
207 TYPE_PARSER(construct<DefinedOperator>(intrinsicOperator) ||
208 construct<DefinedOperator>(definedOpName))
209
210 // R401 xzy-list -> xzy [, xzy]...
nonemptyList(const PA & p)211 template<typename PA> inline constexpr auto nonemptyList(const PA &p) {
212 return nonemptySeparated(p, ","_tok); // p-list
213 }
214
215 template<typename PA>
nonemptyList(MessageFixedText error,const PA & p)216 inline constexpr auto nonemptyList(MessageFixedText error, const PA &p) {
217 return withMessage(error, nonemptySeparated(p, ","_tok)); // p-list
218 }
219
optionalList(const PA & p)220 template<typename PA> inline constexpr auto optionalList(const PA &p) {
221 return defaulted(nonemptySeparated(p, ","_tok)); // [p-list]
222 }
223
224 // R402 xzy-name -> name
225
226 // R403 scalar-xyz -> xyz
227 // Also define constant-xyz, int-xyz, default-char-xyz.
scalar(const PA & p)228 template<typename PA> inline constexpr auto scalar(const PA &p) {
229 return construct<Scalar<typename PA::resultType>>(p); // scalar-p
230 }
231
constant(const PA & p)232 template<typename PA> inline constexpr auto constant(const PA &p) {
233 return construct<Constant<typename PA::resultType>>(p); // constant-p
234 }
235
integer(const PA & p)236 template<typename PA> inline constexpr auto integer(const PA &p) {
237 return construct<Integer<typename PA::resultType>>(p); // int-p
238 }
239
logical(const PA & p)240 template<typename PA> inline constexpr auto logical(const PA &p) {
241 return construct<Logical<typename PA::resultType>>(p); // logical-p
242 }
243
defaultChar(const PA & p)244 template<typename PA> inline constexpr auto defaultChar(const PA &p) {
245 return construct<DefaultChar<typename PA::resultType>>(p); // default-char-p
246 }
247
248 // R1024 logical-expr -> expr
249 constexpr auto logicalExpr{logical(indirect(expr))};
250 constexpr auto scalarLogicalExpr{scalar(logicalExpr)};
251
252 // R1025 default-char-expr -> expr
253 constexpr auto defaultCharExpr{defaultChar(indirect(expr))};
254 constexpr auto scalarDefaultCharExpr{scalar(defaultCharExpr)};
255
256 // R1026 int-expr -> expr
257 constexpr auto intExpr{integer(indirect(expr))};
258 constexpr auto scalarIntExpr{scalar(intExpr)};
259
260 // R1029 constant-expr -> expr
261 constexpr auto constantExpr{constant(indirect(expr))};
262 constexpr auto scalarExpr{scalar(indirect(expr))};
263
264 // R1030 default-char-constant-expr -> default-char-expr
265 constexpr auto scalarDefaultCharConstantExpr{scalar(defaultChar(constantExpr))};
266
267 // R1031 int-constant-expr -> int-expr
268 constexpr auto intConstantExpr{integer(constantExpr)};
269 constexpr auto scalarIntConstantExpr{scalar(intConstantExpr)};
270
271 // R501 program -> program-unit [program-unit]...
272 // This is the top-level production for the Fortran language.
273 // F'2018 6.3.1 defines a program unit as a sequence of one or more lines,
274 // implying that a line can't be part of two distinct program units.
275 // Consequently, a program unit END statement should be the last statement
276 // on its line. We parse those END statements via unterminatedStatement()
277 // and then skip over the end of the line here.
278 TYPE_PARSER(construct<Program>(some(StartNewSubprogram{} >>
279 Parser<ProgramUnit>{} / skipMany(";"_tok) / space /
280 recovery(endOfLine, SkipPast<'\n'>{}))) /
281 skipStuffBeforeStatement)
282
283 // R502 program-unit ->
284 // main-program | external-subprogram | module | submodule | block-data
285 // R503 external-subprogram -> function-subprogram | subroutine-subprogram
286 // N.B. "module" must precede "external-subprogram" in this sequence of
287 // alternatives to avoid ambiguity with the MODULE keyword prefix that
288 // they recognize. I.e., "modulesubroutinefoo" should start a module
289 // "subroutinefoo", not a subroutine "foo" with the MODULE prefix. The
290 // ambiguity is exacerbated by the extension that accepts a function
291 // statement without an otherwise empty list of dummy arguments. That
292 // MODULE prefix is disallowed by a constraint (C1547) in this context,
293 // so the standard language is not ambiguous, but disabling its misrecognition
294 // here would require context-sensitive keyword recognition or (or via)
295 // variant parsers for several productions; giving the "module" production
296 // priority here is a cleaner solution, though regrettably subtle. Enforcing
297 // C1547 is done in semantics.
298 TYPE_PARSER(construct<ProgramUnit>(indirect(Parser<Module>{})) ||
299 construct<ProgramUnit>(indirect(functionSubprogram)) ||
300 construct<ProgramUnit>(indirect(subroutineSubprogram)) ||
301 construct<ProgramUnit>(indirect(Parser<Submodule>{})) ||
302 construct<ProgramUnit>(indirect(Parser<BlockData>{})) ||
303 construct<ProgramUnit>(indirect(Parser<MainProgram>{})))
304
305 // R504 specification-part ->
306 // [use-stmt]... [import-stmt]... [implicit-part]
307 // [declaration-construct]...
308 TYPE_CONTEXT_PARSER("specification part"_en_US,
309 construct<SpecificationPart>(many(openmpDeclarativeConstruct),
310 many(statement(indirect(Parser<UseStmt>{}))),
311 many(unambiguousStatement(indirect(Parser<ImportStmt>{}))),
312 implicitPart, many(declarationConstruct)))
313
314 // R504 variant for many contexts (modules, submodules, BLOCK DATA subprograms,
315 // and interfaces) which have constraints on their specification parts that
316 // preclude FORMAT, ENTRY, and statement functions, and benefit from
317 // specialized error recovery in the event of a spurious executable
318 // statement.
319 constexpr auto limitedSpecificationPart{inContext("specification part"_en_US,
320 construct<SpecificationPart>(many(openmpDeclarativeConstruct),
321 many(statement(indirect(Parser<UseStmt>{}))),
322 many(unambiguousStatement(indirect(Parser<ImportStmt>{}))),
323 implicitPart, many(limitedDeclarationConstruct)))};
324
325 // R505 implicit-part -> [implicit-part-stmt]... implicit-stmt
326 // TODO: Can overshoot; any trailing PARAMETER, FORMAT, & ENTRY
327 // statements after the last IMPLICIT should be transferred to the
328 // list of declaration-constructs.
329 TYPE_CONTEXT_PARSER("implicit part"_en_US,
330 construct<ImplicitPart>(many(Parser<ImplicitPartStmt>{})))
331
332 // R506 implicit-part-stmt ->
333 // implicit-stmt | parameter-stmt | format-stmt | entry-stmt
TYPE_PARSER(first (construct<ImplicitPartStmt> (statement (indirect (Parser<ImplicitStmt>{}))),construct<ImplicitPartStmt> (statement (indirect (parameterStmt))),construct<ImplicitPartStmt> (statement (indirect (oldParameterStmt))),construct<ImplicitPartStmt> (statement (indirect (formatStmt))),construct<ImplicitPartStmt> (statement (indirect (entryStmt)))))334 TYPE_PARSER(first(
335 construct<ImplicitPartStmt>(statement(indirect(Parser<ImplicitStmt>{}))),
336 construct<ImplicitPartStmt>(statement(indirect(parameterStmt))),
337 construct<ImplicitPartStmt>(statement(indirect(oldParameterStmt))),
338 construct<ImplicitPartStmt>(statement(indirect(formatStmt))),
339 construct<ImplicitPartStmt>(statement(indirect(entryStmt)))))
340
341 // R512 internal-subprogram -> function-subprogram | subroutine-subprogram
342 // Internal subprograms are not program units, so their END statements
343 // can be followed by ';' and another statement on the same line.
344 TYPE_CONTEXT_PARSER("internal subprogram"_en_US,
345 (construct<InternalSubprogram>(indirect(functionSubprogram)) ||
346 construct<InternalSubprogram>(indirect(subroutineSubprogram))) /
347 forceEndOfStmt)
348
349 // R511 internal-subprogram-part -> contains-stmt [internal-subprogram]...
350 TYPE_CONTEXT_PARSER("internal subprogram part"_en_US,
351 construct<InternalSubprogramPart>(statement(containsStmt),
352 many(StartNewSubprogram{} >> Parser<InternalSubprogram>{})))
353
354 // R515 action-stmt ->
355 // allocate-stmt | assignment-stmt | backspace-stmt | call-stmt |
356 // close-stmt | continue-stmt | cycle-stmt | deallocate-stmt |
357 // endfile-stmt | error-stop-stmt | event-post-stmt | event-wait-stmt |
358 // exit-stmt | fail-image-stmt | flush-stmt | form-team-stmt |
359 // goto-stmt | if-stmt | inquire-stmt | lock-stmt | nullify-stmt |
360 // open-stmt | pointer-assignment-stmt | print-stmt | read-stmt |
361 // return-stmt | rewind-stmt | stop-stmt | sync-all-stmt |
362 // sync-images-stmt | sync-memory-stmt | sync-team-stmt | unlock-stmt |
363 // wait-stmt | where-stmt | write-stmt | computed-goto-stmt | forall-stmt
364 // R1159 continue-stmt -> CONTINUE
365 // R1163 fail-image-stmt -> FAIL IMAGE
366 TYPE_PARSER(first(construct<ActionStmt>(indirect(Parser<AllocateStmt>{})),
367 construct<ActionStmt>(indirect(assignmentStmt)),
368 construct<ActionStmt>(indirect(pointerAssignmentStmt)),
369 construct<ActionStmt>(indirect(Parser<BackspaceStmt>{})),
370 construct<ActionStmt>(indirect(Parser<CallStmt>{})),
371 construct<ActionStmt>(indirect(Parser<CloseStmt>{})),
372 construct<ActionStmt>(construct<ContinueStmt>("CONTINUE"_tok)),
373 construct<ActionStmt>(indirect(Parser<CycleStmt>{})),
374 construct<ActionStmt>(indirect(Parser<DeallocateStmt>{})),
375 construct<ActionStmt>(indirect(Parser<EndfileStmt>{})),
376 construct<ActionStmt>(indirect(Parser<EventPostStmt>{})),
377 construct<ActionStmt>(indirect(Parser<EventWaitStmt>{})),
378 construct<ActionStmt>(indirect(Parser<ExitStmt>{})),
379 construct<ActionStmt>(construct<FailImageStmt>("FAIL IMAGE"_sptok)),
380 construct<ActionStmt>(indirect(Parser<FlushStmt>{})),
381 construct<ActionStmt>(indirect(Parser<FormTeamStmt>{})),
382 construct<ActionStmt>(indirect(Parser<GotoStmt>{})),
383 construct<ActionStmt>(indirect(Parser<IfStmt>{})),
384 construct<ActionStmt>(indirect(Parser<InquireStmt>{})),
385 construct<ActionStmt>(indirect(Parser<LockStmt>{})),
386 construct<ActionStmt>(indirect(Parser<NullifyStmt>{})),
387 construct<ActionStmt>(indirect(Parser<OpenStmt>{})),
388 construct<ActionStmt>(indirect(Parser<PrintStmt>{})),
389 construct<ActionStmt>(indirect(Parser<ReadStmt>{})),
390 construct<ActionStmt>(indirect(Parser<ReturnStmt>{})),
391 construct<ActionStmt>(indirect(Parser<RewindStmt>{})),
392 construct<ActionStmt>(indirect(Parser<StopStmt>{})), // & error-stop-stmt
393 construct<ActionStmt>(indirect(Parser<SyncAllStmt>{})),
394 construct<ActionStmt>(indirect(Parser<SyncImagesStmt>{})),
395 construct<ActionStmt>(indirect(Parser<SyncMemoryStmt>{})),
396 construct<ActionStmt>(indirect(Parser<SyncTeamStmt>{})),
397 construct<ActionStmt>(indirect(Parser<UnlockStmt>{})),
398 construct<ActionStmt>(indirect(Parser<WaitStmt>{})),
399 construct<ActionStmt>(indirect(whereStmt)),
400 construct<ActionStmt>(indirect(Parser<WriteStmt>{})),
401 construct<ActionStmt>(indirect(Parser<ComputedGotoStmt>{})),
402 construct<ActionStmt>(indirect(forallStmt)),
403 construct<ActionStmt>(indirect(Parser<ArithmeticIfStmt>{})),
404 construct<ActionStmt>(indirect(Parser<AssignStmt>{})),
405 construct<ActionStmt>(indirect(Parser<AssignedGotoStmt>{})),
406 construct<ActionStmt>(indirect(Parser<PauseStmt>{}))))
407
408 // Fortran allows the statement with the corresponding label at the end of
409 // a do-construct that begins with an old-style label-do-stmt to be a
410 // new-style END DO statement; e.g., DO 10 I=1,N; ...; 10 END DO. Usually,
411 // END DO statements appear only at the ends of do-constructs that begin
412 // with a nonlabel-do-stmt, so care must be taken to recognize this case and
413 // essentially treat them like CONTINUE statements.
414
415 // R514 executable-construct ->
416 // action-stmt | associate-construct | block-construct |
417 // case-construct | change-team-construct | critical-construct |
418 // do-construct | if-construct | select-rank-construct |
419 // select-type-construct | where-construct | forall-construct
420 constexpr auto executableConstruct{
421 first(construct<ExecutableConstruct>(CapturedLabelDoStmt{}),
422 construct<ExecutableConstruct>(EndDoStmtForCapturedLabelDoStmt{}),
423 construct<ExecutableConstruct>(indirect(Parser<DoConstruct>{})),
424 // Attempt DO statements before assignment statements for better
425 // error messages in cases like "DO10I=1,(error)".
426 construct<ExecutableConstruct>(statement(actionStmt)),
427 construct<ExecutableConstruct>(indirect(Parser<AssociateConstruct>{})),
428 construct<ExecutableConstruct>(indirect(Parser<BlockConstruct>{})),
429 construct<ExecutableConstruct>(indirect(Parser<CaseConstruct>{})),
430 construct<ExecutableConstruct>(indirect(Parser<ChangeTeamConstruct>{})),
431 construct<ExecutableConstruct>(indirect(Parser<CriticalConstruct>{})),
432 construct<ExecutableConstruct>(indirect(Parser<IfConstruct>{})),
433 construct<ExecutableConstruct>(indirect(Parser<SelectRankConstruct>{})),
434 construct<ExecutableConstruct>(indirect(Parser<SelectTypeConstruct>{})),
435 construct<ExecutableConstruct>(indirect(whereConstruct)),
436 construct<ExecutableConstruct>(indirect(forallConstruct)),
437 construct<ExecutableConstruct>(indirect(ompEndLoopDirective)),
438 construct<ExecutableConstruct>(indirect(openmpConstruct)),
439 construct<ExecutableConstruct>(indirect(compilerDirective)))};
440
441 // R510 execution-part-construct ->
442 // executable-construct | format-stmt | entry-stmt | data-stmt
443 // Extension (PGI/Intel): also accept NAMELIST in execution part
444 constexpr auto obsoleteExecutionPartConstruct{recovery(ignoredStatementPrefix >>
445 fail<ExecutionPartConstruct>(
446 "obsolete legacy extension is not supported"_err_en_US),
447 construct<ExecutionPartConstruct>(construct<ErrorRecovery>(ok /
448 statement("REDIMENSION" >> name /
449 parenthesized(nonemptyList(Parser<AllocateShapeSpec>{}))))))};
450
451 TYPE_PARSER(recovery(
452 withMessage("expected execution part construct"_err_en_US,
453 CONTEXT_PARSER("execution part construct"_en_US,
454 first(construct<ExecutionPartConstruct>(executableConstruct),
455 construct<ExecutionPartConstruct>(
456 statement(indirect(formatStmt))),
457 construct<ExecutionPartConstruct>(
458 statement(indirect(entryStmt))),
459 construct<ExecutionPartConstruct>(
460 statement(indirect(dataStmt))),
461 extension<LanguageFeature::ExecutionPartNamelist>(
462 construct<ExecutionPartConstruct>(
463 statement(indirect(Parser<NamelistStmt>{})))),
464 obsoleteExecutionPartConstruct))),
465 construct<ExecutionPartConstruct>(executionPartErrorRecovery)))
466
467 // R509 execution-part -> executable-construct [execution-part-construct]...
468 TYPE_CONTEXT_PARSER("execution part"_en_US,
469 construct<ExecutionPart>(many(executionPartConstruct)))
470
471 // R605 literal-constant ->
472 // int-literal-constant | real-literal-constant |
473 // complex-literal-constant | logical-literal-constant |
474 // char-literal-constant | boz-literal-constant
TYPE_PARSER(first (construct<LiteralConstant> (Parser<HollerithLiteralConstant>{}),construct<LiteralConstant> (realLiteralConstant),construct<LiteralConstant> (intLiteralConstant),construct<LiteralConstant> (Parser<ComplexLiteralConstant>{}),construct<LiteralConstant> (Parser<BOZLiteralConstant>{}),construct<LiteralConstant> (charLiteralConstant),construct<LiteralConstant> (Parser<LogicalLiteralConstant>{})))475 TYPE_PARSER(
476 first(construct<LiteralConstant>(Parser<HollerithLiteralConstant>{}),
477 construct<LiteralConstant>(realLiteralConstant),
478 construct<LiteralConstant>(intLiteralConstant),
479 construct<LiteralConstant>(Parser<ComplexLiteralConstant>{}),
480 construct<LiteralConstant>(Parser<BOZLiteralConstant>{}),
481 construct<LiteralConstant>(charLiteralConstant),
482 construct<LiteralConstant>(Parser<LogicalLiteralConstant>{})))
483
484 // R606 named-constant -> name
485 TYPE_PARSER(construct<NamedConstant>(name))
486
487 // R701 type-param-value -> scalar-int-expr | * | :
488 constexpr auto star{construct<Star>("*"_tok)};
489 TYPE_PARSER(construct<TypeParamValue>(scalarIntExpr) ||
490 construct<TypeParamValue>(star) ||
491 construct<TypeParamValue>(construct<TypeParamValue::Deferred>(":"_tok)))
492
493 // R702 type-spec -> intrinsic-type-spec | derived-type-spec
494 // N.B. This type-spec production is one of two instances in the Fortran
495 // grammar where intrinsic types and bare derived type names can clash;
496 // the other is below in R703 declaration-type-spec. Look-ahead is required
497 // to disambiguate the cases where a derived type name begins with the name
498 // of an intrinsic type, e.g., REALITY.
499 TYPE_CONTEXT_PARSER("type spec"_en_US,
500 construct<TypeSpec>(intrinsicTypeSpec / lookAhead("::"_tok || ")"_tok)) ||
501 construct<TypeSpec>(derivedTypeSpec))
502
503 // R703 declaration-type-spec ->
504 // intrinsic-type-spec | TYPE ( intrinsic-type-spec ) |
505 // TYPE ( derived-type-spec ) | CLASS ( derived-type-spec ) |
506 // CLASS ( * ) | TYPE ( * )
507 // N.B. It is critical to distribute "parenthesized()" over the alternatives
508 // for TYPE (...), rather than putting the alternatives within it, which
509 // would fail on "TYPE(real_derived)" with a misrecognition of "real" as an
510 // intrinsic-type-spec.
511 TYPE_CONTEXT_PARSER("declaration type spec"_en_US,
512 construct<DeclarationTypeSpec>(intrinsicTypeSpec) ||
513 "TYPE" >>
514 (parenthesized(construct<DeclarationTypeSpec>(intrinsicTypeSpec)) ||
515 parenthesized(construct<DeclarationTypeSpec>(
516 construct<DeclarationTypeSpec::Type>(derivedTypeSpec))) ||
517 construct<DeclarationTypeSpec>(
518 "( * )" >> construct<DeclarationTypeSpec::TypeStar>())) ||
519 "CLASS" >> parenthesized(construct<DeclarationTypeSpec>(
520 construct<DeclarationTypeSpec::Class>(
521 derivedTypeSpec)) ||
522 construct<DeclarationTypeSpec>("*" >>
523 construct<DeclarationTypeSpec::ClassStar>())) ||
524 extension<LanguageFeature::DECStructures>(
525 construct<DeclarationTypeSpec>(
526 construct<DeclarationTypeSpec::Record>(
527 "RECORD /" >> name / "/"))))
528
529 // R704 intrinsic-type-spec ->
530 // integer-type-spec | REAL [kind-selector] | DOUBLE PRECISION |
531 // COMPLEX [kind-selector] | CHARACTER [char-selector] |
532 // LOGICAL [kind-selector]
533 // Extensions: DOUBLE COMPLEX, BYTE
534 TYPE_CONTEXT_PARSER("intrinsic type spec"_en_US,
535 first(construct<IntrinsicTypeSpec>(integerTypeSpec),
536 construct<IntrinsicTypeSpec>(
537 construct<IntrinsicTypeSpec::Real>("REAL" >> maybe(kindSelector))),
538 construct<IntrinsicTypeSpec>("DOUBLE PRECISION" >>
539 construct<IntrinsicTypeSpec::DoublePrecision>()),
540 construct<IntrinsicTypeSpec>(construct<IntrinsicTypeSpec::Complex>(
541 "COMPLEX" >> maybe(kindSelector))),
542 construct<IntrinsicTypeSpec>(construct<IntrinsicTypeSpec::Character>(
543 "CHARACTER" >> maybe(Parser<CharSelector>{}))),
544 construct<IntrinsicTypeSpec>(construct<IntrinsicTypeSpec::Logical>(
545 "LOGICAL" >> maybe(kindSelector))),
546 construct<IntrinsicTypeSpec>("DOUBLE COMPLEX" >>
547 extension<LanguageFeature::DoubleComplex>(
548 construct<IntrinsicTypeSpec::DoubleComplex>())),
549 extension<LanguageFeature::Byte>(
550 construct<IntrinsicTypeSpec>(construct<IntegerTypeSpec>(
551 "BYTE" >> construct<std::optional<KindSelector>>(pure(1)))))))
552
553 // R705 integer-type-spec -> INTEGER [kind-selector]
554 TYPE_PARSER(construct<IntegerTypeSpec>("INTEGER" >> maybe(kindSelector)))
555
556 // R706 kind-selector -> ( [KIND =] scalar-int-constant-expr )
557 // Legacy extension: kind-selector -> * digit-string
558 TYPE_PARSER(construct<KindSelector>(
559 parenthesized(maybe("KIND ="_tok) >> scalarIntConstantExpr)) ||
560 extension<LanguageFeature::StarKind>(construct<KindSelector>(
561 construct<KindSelector::StarSize>("*" >> digitString64 / spaceCheck))))
562
563 // R707 signed-int-literal-constant -> [sign] int-literal-constant
564 TYPE_PARSER(sourced(construct<SignedIntLiteralConstant>(
565 SignedIntLiteralConstantWithoutKind{}, maybe(underscore >> kindParam))))
566
567 // R708 int-literal-constant -> digit-string [_ kind-param]
568 // The negated look-ahead for a trailing underscore prevents misrecognition
569 // when the digit string is a numeric kind parameter of a character literal.
570 TYPE_PARSER(construct<IntLiteralConstant>(
571 space >> digitString, maybe(underscore >> kindParam) / !underscore))
572
573 // R709 kind-param -> digit-string | scalar-int-constant-name
574 TYPE_PARSER(construct<KindParam>(digitString64) ||
575 construct<KindParam>(scalar(integer(constant(name)))))
576
577 // R712 sign -> + | -
578 // N.B. A sign constitutes a whole token, so a space is allowed in free form
579 // after the sign and before a real-literal-constant or
580 // complex-literal-constant. A sign is not a unary operator in these contexts.
581 constexpr auto sign{
582 "+"_tok >> pure(Sign::Positive) || "-"_tok >> pure(Sign::Negative)};
583
584 // R713 signed-real-literal-constant -> [sign] real-literal-constant
585 constexpr auto signedRealLiteralConstant{
586 construct<SignedRealLiteralConstant>(maybe(sign), realLiteralConstant)};
587
588 // R714 real-literal-constant ->
589 // significand [exponent-letter exponent] [_ kind-param] |
590 // digit-string exponent-letter exponent [_ kind-param]
591 // R715 significand -> digit-string . [digit-string] | . digit-string
592 // R716 exponent-letter -> E | D
593 // Extension: Q
594 // R717 exponent -> signed-digit-string
595 constexpr auto exponentPart{
596 ("ed"_ch || extension<LanguageFeature::QuadPrecision>("q"_ch)) >>
597 SignedDigitString{}};
598
599 TYPE_CONTEXT_PARSER("REAL literal constant"_en_US,
600 space >>
601 construct<RealLiteralConstant>(
602 sourced((digitString >> "."_ch >>
603 !(some(letter) >>
604 "."_ch /* don't misinterpret 1.AND. */) >>
605 maybe(digitString) >> maybe(exponentPart) >> ok ||
606 "."_ch >> digitString >> maybe(exponentPart) >> ok ||
607 digitString >> exponentPart >> ok) >>
608 construct<RealLiteralConstant::Real>()),
609 maybe(underscore >> kindParam)))
610
611 // R718 complex-literal-constant -> ( real-part , imag-part )
612 TYPE_CONTEXT_PARSER("COMPLEX literal constant"_en_US,
613 parenthesized(construct<ComplexLiteralConstant>(
614 Parser<ComplexPart>{} / ",", Parser<ComplexPart>{})))
615
616 // PGI/Intel extension: signed complex literal constant
TYPE_PARSER(construct<SignedComplexLiteralConstant> (sign,Parser<ComplexLiteralConstant>{}))617 TYPE_PARSER(construct<SignedComplexLiteralConstant>(
618 sign, Parser<ComplexLiteralConstant>{}))
619
620 // R719 real-part ->
621 // signed-int-literal-constant | signed-real-literal-constant |
622 // named-constant
623 // R720 imag-part ->
624 // signed-int-literal-constant | signed-real-literal-constant |
625 // named-constant
626 TYPE_PARSER(construct<ComplexPart>(signedRealLiteralConstant) ||
627 construct<ComplexPart>(signedIntLiteralConstant) ||
628 construct<ComplexPart>(namedConstant))
629
630 // R721 char-selector ->
631 // length-selector |
632 // ( LEN = type-param-value , KIND = scalar-int-constant-expr ) |
633 // ( type-param-value , [KIND =] scalar-int-constant-expr ) |
634 // ( KIND = scalar-int-constant-expr [, LEN = type-param-value] )
635 TYPE_PARSER(construct<CharSelector>(Parser<LengthSelector>{}) ||
636 parenthesized(construct<CharSelector>(
637 "LEN =" >> typeParamValue, ", KIND =" >> scalarIntConstantExpr)) ||
638 parenthesized(construct<CharSelector>(
639 typeParamValue / ",", maybe("KIND ="_tok) >> scalarIntConstantExpr)) ||
640 parenthesized(construct<CharSelector>(
641 "KIND =" >> scalarIntConstantExpr, maybe(", LEN =" >> typeParamValue))))
642
643 // R722 length-selector -> ( [LEN =] type-param-value ) | * char-length [,]
644 // N.B. The trailing [,] in the production is permitted by the Standard
645 // only in the context of a type-declaration-stmt, but even with that
646 // limitation, it would seem to be unnecessary and buggy to consume the comma
647 // here.
648 TYPE_PARSER(construct<LengthSelector>(
649 parenthesized(maybe("LEN ="_tok) >> typeParamValue)) ||
650 construct<LengthSelector>("*" >> charLength /* / maybe(","_tok) */))
651
652 // R723 char-length -> ( type-param-value ) | digit-string
653 TYPE_PARSER(construct<CharLength>(parenthesized(typeParamValue)) ||
654 construct<CharLength>(space >> digitString64 / spaceCheck))
655
656 // R724 char-literal-constant ->
657 // [kind-param _] ' [rep-char]... ' |
658 // [kind-param _] " [rep-char]... "
659 // "rep-char" is any non-control character. Doubled interior quotes are
660 // combined. Backslash escapes can be enabled.
661 // N.B. charLiteralConstantWithoutKind does not skip preceding space.
662 // N.B. the parsing of "name" takes care to not consume the '_'.
663 constexpr auto charLiteralConstantWithoutKind{
664 "'"_ch >> CharLiteral<'\''>{} || "\""_ch >> CharLiteral<'"'>{}};
665
666 TYPE_CONTEXT_PARSER("CHARACTER literal constant"_en_US,
667 construct<CharLiteralConstant>(
668 kindParam / underscore, charLiteralConstantWithoutKind) ||
669 construct<CharLiteralConstant>(construct<std::optional<KindParam>>(),
670 space >> charLiteralConstantWithoutKind))
671
672 // deprecated: Hollerith literals
673 constexpr auto rawHollerithLiteral{
674 deprecated<LanguageFeature::Hollerith>(HollerithLiteral{})};
675
676 TYPE_CONTEXT_PARSER(
677 "Hollerith"_en_US, construct<HollerithLiteralConstant>(rawHollerithLiteral))
678
679 // R725 logical-literal-constant ->
680 // .TRUE. [_ kind-param] | .FALSE. [_ kind-param]
681 // Also accept .T. and .F. as extensions.
682 TYPE_PARSER(construct<LogicalLiteralConstant>(
683 logicalTRUE, maybe(underscore >> kindParam)) ||
684 construct<LogicalLiteralConstant>(
685 logicalFALSE, maybe(underscore >> kindParam)))
686
687 // R726 derived-type-def ->
688 // derived-type-stmt [type-param-def-stmt]...
689 // [private-or-sequence]... [component-part]
690 // [type-bound-procedure-part] end-type-stmt
691 // R735 component-part -> [component-def-stmt]...
692 TYPE_CONTEXT_PARSER("derived type definition"_en_US,
693 construct<DerivedTypeDef>(statement(Parser<DerivedTypeStmt>{}),
694 many(unambiguousStatement(Parser<TypeParamDefStmt>{})),
695 many(statement(Parser<PrivateOrSequence>{})),
696 many(inContext("component"_en_US,
697 unambiguousStatement(Parser<ComponentDefStmt>{}))),
698 maybe(Parser<TypeBoundProcedurePart>{}),
699 statement(Parser<EndTypeStmt>{})))
700
701 // R727 derived-type-stmt ->
702 // TYPE [[, type-attr-spec-list] ::] type-name [(
703 // type-param-name-list )]
704 constexpr auto listOfNames{nonemptyList("expected names"_err_en_US, name)};
705 TYPE_CONTEXT_PARSER("TYPE statement"_en_US,
706 construct<DerivedTypeStmt>(
707 "TYPE" >> optionalListBeforeColons(Parser<TypeAttrSpec>{}), name,
708 defaulted(parenthesized(nonemptyList(name)))))
709
710 // R728 type-attr-spec ->
711 // ABSTRACT | access-spec | BIND(C) | EXTENDS ( parent-type-name )
712 TYPE_PARSER(construct<TypeAttrSpec>(construct<Abstract>("ABSTRACT"_tok)) ||
713 construct<TypeAttrSpec>(construct<TypeAttrSpec::BindC>("BIND ( C )"_tok)) ||
714 construct<TypeAttrSpec>(
715 construct<TypeAttrSpec::Extends>("EXTENDS" >> parenthesized(name))) ||
716 construct<TypeAttrSpec>(accessSpec))
717
718 // R729 private-or-sequence -> private-components-stmt | sequence-stmt
719 TYPE_PARSER(construct<PrivateOrSequence>(Parser<PrivateStmt>{}) ||
720 construct<PrivateOrSequence>(Parser<SequenceStmt>{}))
721
722 // R730 end-type-stmt -> END TYPE [type-name]
723 TYPE_PARSER(construct<EndTypeStmt>(
724 recovery("END TYPE" >> maybe(name), endStmtErrorRecovery)))
725
726 // R731 sequence-stmt -> SEQUENCE
727 TYPE_PARSER(construct<SequenceStmt>("SEQUENCE"_tok))
728
729 // R732 type-param-def-stmt ->
730 // integer-type-spec , type-param-attr-spec :: type-param-decl-list
731 // R734 type-param-attr-spec -> KIND | LEN
732 constexpr auto kindOrLen{"KIND" >> pure(common::TypeParamAttr::Kind) ||
733 "LEN" >> pure(common::TypeParamAttr::Len)};
734 TYPE_PARSER(construct<TypeParamDefStmt>(integerTypeSpec / ",", kindOrLen,
735 "::" >> nonemptyList("expected type parameter declarations"_err_en_US,
736 Parser<TypeParamDecl>{})))
737
738 // R733 type-param-decl -> type-param-name [= scalar-int-constant-expr]
739 TYPE_PARSER(construct<TypeParamDecl>(name, maybe("=" >> scalarIntConstantExpr)))
740
741 // R736 component-def-stmt -> data-component-def-stmt |
742 // proc-component-def-stmt
743 // Accidental extension not enabled here: PGI accepts type-param-def-stmt in
744 // component-part of derived-type-def.
745 TYPE_PARSER(recovery(
746 withMessage("expected component definition"_err_en_US,
747 first(construct<ComponentDefStmt>(Parser<DataComponentDefStmt>{}),
748 construct<ComponentDefStmt>(Parser<ProcComponentDefStmt>{}))),
749 construct<ComponentDefStmt>(inStmtErrorRecovery)))
750
751 // R737 data-component-def-stmt ->
752 // declaration-type-spec [[, component-attr-spec-list] ::]
753 // component-decl-list
754 // N.B. The standard requires double colons if there's an initializer.
755 TYPE_PARSER(construct<DataComponentDefStmt>(declarationTypeSpec,
756 optionalListBeforeColons(Parser<ComponentAttrSpec>{}),
757 nonemptyList(
758 "expected component declarations"_err_en_US, Parser<ComponentDecl>{})))
759
760 // R738 component-attr-spec ->
761 // access-spec | ALLOCATABLE |
762 // CODIMENSION lbracket coarray-spec rbracket |
763 // CONTIGUOUS | DIMENSION ( component-array-spec ) | POINTER
764 constexpr auto allocatable{construct<Allocatable>("ALLOCATABLE"_tok)};
765 constexpr auto contiguous{construct<Contiguous>("CONTIGUOUS"_tok)};
766 constexpr auto pointer{construct<Pointer>("POINTER"_tok)};
767 TYPE_PARSER(construct<ComponentAttrSpec>(accessSpec) ||
768 construct<ComponentAttrSpec>(allocatable) ||
769 construct<ComponentAttrSpec>("CODIMENSION" >> coarraySpec) ||
770 construct<ComponentAttrSpec>(contiguous) ||
771 construct<ComponentAttrSpec>("DIMENSION" >> Parser<ComponentArraySpec>{}) ||
772 construct<ComponentAttrSpec>(pointer) ||
773 construct<ComponentAttrSpec>(recovery(
774 fail<ErrorRecovery>(
775 "type parameter definitions must appear before component declarations"_err_en_US),
776 kindOrLen >> construct<ErrorRecovery>())))
777
778 // R739 component-decl ->
779 // component-name [( component-array-spec )]
780 // [lbracket coarray-spec rbracket] [* char-length]
781 // [component-initialization]
782 TYPE_CONTEXT_PARSER("component declaration"_en_US,
783 construct<ComponentDecl>(name, maybe(Parser<ComponentArraySpec>{}),
784 maybe(coarraySpec), maybe("*" >> charLength), maybe(initialization)))
785
786 // R740 component-array-spec ->
787 // explicit-shape-spec-list | deferred-shape-spec-list
788 // N.B. Parenthesized here rather than around references to this production.
789 TYPE_PARSER(construct<ComponentArraySpec>(parenthesized(
790 nonemptyList("expected explicit shape specifications"_err_en_US,
791 explicitShapeSpec))) ||
792 construct<ComponentArraySpec>(parenthesized(deferredShapeSpecList)))
793
794 // R741 proc-component-def-stmt ->
795 // PROCEDURE ( [proc-interface] ) , proc-component-attr-spec-list
796 // :: proc-decl-list
797 TYPE_CONTEXT_PARSER("PROCEDURE component definition statement"_en_US,
798 construct<ProcComponentDefStmt>(
799 "PROCEDURE" >> parenthesized(maybe(procInterface)),
800 localRecovery("expected PROCEDURE component attributes"_err_en_US,
801 "," >> nonemptyList(Parser<ProcComponentAttrSpec>{}), ok),
802 localRecovery("expected PROCEDURE declarations"_err_en_US,
803 "::" >> nonemptyList(procDecl), SkipTo<'\n'>{})))
804
805 // R742 proc-component-attr-spec ->
806 // access-spec | NOPASS | PASS [(arg-name)] | POINTER
807 constexpr auto noPass{construct<NoPass>("NOPASS"_tok)};
808 constexpr auto pass{construct<Pass>("PASS" >> maybe(parenthesized(name)))};
809 TYPE_PARSER(construct<ProcComponentAttrSpec>(accessSpec) ||
810 construct<ProcComponentAttrSpec>(noPass) ||
811 construct<ProcComponentAttrSpec>(pass) ||
812 construct<ProcComponentAttrSpec>(pointer))
813
814 // R744 initial-data-target -> designator
815 constexpr auto initialDataTarget{indirect(designator)};
816
817 // R743 component-initialization ->
818 // = constant-expr | => null-init | => initial-data-target
819 // R805 initialization ->
820 // = constant-expr | => null-init | => initial-data-target
821 // Universal extension: initialization -> / data-stmt-value-list /
822 TYPE_PARSER(construct<Initialization>("=>" >> nullInit) ||
823 construct<Initialization>("=>" >> initialDataTarget) ||
824 construct<Initialization>("=" >> constantExpr) ||
825 extension<LanguageFeature::SlashInitialization>(construct<Initialization>(
826 "/" >> nonemptyList("expected values"_err_en_US,
827 indirect(Parser<DataStmtValue>{})) /
828 "/")))
829
830 // R745 private-components-stmt -> PRIVATE
831 // R747 binding-private-stmt -> PRIVATE
832 TYPE_PARSER(construct<PrivateStmt>("PRIVATE"_tok))
833
834 // R746 type-bound-procedure-part ->
835 // contains-stmt [binding-private-stmt] [type-bound-proc-binding]...
836 TYPE_CONTEXT_PARSER("type bound procedure part"_en_US,
837 construct<TypeBoundProcedurePart>(statement(containsStmt),
838 maybe(statement(Parser<PrivateStmt>{})),
839 many(statement(Parser<TypeBoundProcBinding>{}))))
840
841 // R748 type-bound-proc-binding ->
842 // type-bound-procedure-stmt | type-bound-generic-stmt |
843 // final-procedure-stmt
844 TYPE_CONTEXT_PARSER("type bound procedure binding"_en_US,
845 recovery(
846 first(construct<TypeBoundProcBinding>(Parser<TypeBoundProcedureStmt>{}),
847 construct<TypeBoundProcBinding>(Parser<TypeBoundGenericStmt>{}),
848 construct<TypeBoundProcBinding>(Parser<FinalProcedureStmt>{})),
849 construct<TypeBoundProcBinding>(
850 !"END"_tok >> SkipTo<'\n'>{} >> construct<ErrorRecovery>())))
851
852 // R749 type-bound-procedure-stmt ->
853 // PROCEDURE [[, bind-attr-list] ::] type-bound-proc-decl-list |
854 // PROCEDURE ( interface-name ) , bind-attr-list :: binding-name-list
855 TYPE_CONTEXT_PARSER("type bound PROCEDURE statement"_en_US,
856 "PROCEDURE" >>
857 (construct<TypeBoundProcedureStmt>(
858 construct<TypeBoundProcedureStmt::WithInterface>(
859 parenthesized(name),
860 localRecovery("expected list of binding attributes"_err_en_US,
861 "," >> nonemptyList(Parser<BindAttr>{}), ok),
862 localRecovery("expected list of binding names"_err_en_US,
863 "::" >> listOfNames, SkipTo<'\n'>{}))) ||
864 construct<TypeBoundProcedureStmt>(
865 construct<TypeBoundProcedureStmt::WithoutInterface>(
866 optionalListBeforeColons(Parser<BindAttr>{}),
867 nonemptyList(
868 "expected type bound procedure declarations"_err_en_US,
869 Parser<TypeBoundProcDecl>{})))))
870
871 // R750 type-bound-proc-decl -> binding-name [=> procedure-name]
872 TYPE_PARSER(construct<TypeBoundProcDecl>(name, maybe("=>" >> name)))
873
874 // R751 type-bound-generic-stmt ->
875 // GENERIC [, access-spec] :: generic-spec => binding-name-list
876 TYPE_CONTEXT_PARSER("type bound GENERIC statement"_en_US,
877 construct<TypeBoundGenericStmt>("GENERIC" >> maybe("," >> accessSpec),
878 "::" >> indirect(genericSpec), "=>" >> listOfNames))
879
880 // R752 bind-attr ->
881 // access-spec | DEFERRED | NON_OVERRIDABLE | NOPASS | PASS [(arg-name)]
882 TYPE_PARSER(construct<BindAttr>(accessSpec) ||
883 construct<BindAttr>(construct<BindAttr::Deferred>("DEFERRED"_tok)) ||
884 construct<BindAttr>(
885 construct<BindAttr::Non_Overridable>("NON_OVERRIDABLE"_tok)) ||
886 construct<BindAttr>(noPass) || construct<BindAttr>(pass))
887
888 // R753 final-procedure-stmt -> FINAL [::] final-subroutine-name-list
889 TYPE_CONTEXT_PARSER("FINAL statement"_en_US,
890 construct<FinalProcedureStmt>("FINAL" >> maybe("::"_tok) >> listOfNames))
891
892 // R754 derived-type-spec -> type-name [(type-param-spec-list)]
893 TYPE_PARSER(construct<DerivedTypeSpec>(name,
894 defaulted(parenthesized(nonemptyList(
895 "expected type parameters"_err_en_US, Parser<TypeParamSpec>{})))))
896
897 // R755 type-param-spec -> [keyword =] type-param-value
898 TYPE_PARSER(construct<TypeParamSpec>(maybe(keyword / "="), typeParamValue))
899
900 // R756 structure-constructor -> derived-type-spec ( [component-spec-list] )
901 TYPE_PARSER((construct<StructureConstructor>(derivedTypeSpec,
902 parenthesized(optionalList(Parser<ComponentSpec>{}))) ||
903 // This alternative corrects misrecognition of the
904 // component-spec-list as the type-param-spec-list in
905 // derived-type-spec.
906 construct<StructureConstructor>(
907 construct<DerivedTypeSpec>(
908 name, construct<std::list<TypeParamSpec>>()),
909 parenthesized(optionalList(Parser<ComponentSpec>{})))) /
910 !"("_tok)
911
912 // R757 component-spec -> [keyword =] component-data-source
913 TYPE_PARSER(construct<ComponentSpec>(
914 maybe(keyword / "="), Parser<ComponentDataSource>{}))
915
916 // R758 component-data-source -> expr | data-target | proc-target
TYPE_PARSER(construct<ComponentDataSource> (indirect (expr)))917 TYPE_PARSER(construct<ComponentDataSource>(indirect(expr)))
918
919 // R759 enum-def ->
920 // enum-def-stmt enumerator-def-stmt [enumerator-def-stmt]...
921 // end-enum-stmt
922 TYPE_CONTEXT_PARSER("enum definition"_en_US,
923 construct<EnumDef>(statement(Parser<EnumDefStmt>{}),
924 some(unambiguousStatement(Parser<EnumeratorDefStmt>{})),
925 statement(Parser<EndEnumStmt>{})))
926
927 // R760 enum-def-stmt -> ENUM, BIND(C)
928 TYPE_PARSER(construct<EnumDefStmt>("ENUM , BIND ( C )"_tok))
929
930 // R761 enumerator-def-stmt -> ENUMERATOR [::] enumerator-list
931 TYPE_CONTEXT_PARSER("ENUMERATOR statement"_en_US,
932 construct<EnumeratorDefStmt>("ENUMERATOR" >> maybe("::"_tok) >>
933 nonemptyList("expected enumerators"_err_en_US, Parser<Enumerator>{})))
934
935 // R762 enumerator -> named-constant [= scalar-int-constant-expr]
936 TYPE_PARSER(
937 construct<Enumerator>(namedConstant, maybe("=" >> scalarIntConstantExpr)))
938
939 // R763 end-enum-stmt -> END ENUM
940 TYPE_PARSER(recovery("END ENUM"_tok, "END" >> SkipPast<'\n'>{}) >>
941 construct<EndEnumStmt>())
942
943 // R764 boz-literal-constant -> binary-constant | octal-constant | hex-constant
944 // R765 binary-constant -> B ' digit [digit]... ' | B " digit [digit]... "
945 // R766 octal-constant -> O ' digit [digit]... ' | O " digit [digit]... "
946 // R767 hex-constant ->
947 // Z ' hex-digit [hex-digit]... ' | Z " hex-digit [hex-digit]... "
948 // extension: X accepted for Z
949 // extension: BOZX suffix accepted
950 TYPE_PARSER(construct<BOZLiteralConstant>(BOZLiteral{}))
951
952 // R1124 do-variable -> scalar-int-variable-name
953 constexpr auto doVariable{scalar(integer(name))};
954
955 // NOTE: In loop-control we allow REAL name and bounds too.
956 // This means parse them without the integer constraint and check later.
957
loopBounds(decltype (scalarExpr)& p)958 inline constexpr auto loopBounds(decltype(scalarExpr) &p) {
959 return construct<LoopBounds<ScalarName, ScalarExpr>>(
960 scalar(name) / "=", p / ",", p, maybe("," >> p));
961 }
loopBounds(const PA & p)962 template<typename PA> inline constexpr auto loopBounds(const PA &p) {
963 return construct<LoopBounds<DoVariable, typename PA::resultType>>(
964 doVariable / "=", p / ",", p, maybe("," >> p));
965 }
966
967 // R769 array-constructor -> (/ ac-spec /) | lbracket ac-spec rbracket
968 TYPE_CONTEXT_PARSER("array constructor"_en_US,
969 construct<ArrayConstructor>(
970 "(/" >> Parser<AcSpec>{} / "/)" || bracketed(Parser<AcSpec>{})))
971
972 // R770 ac-spec -> type-spec :: | [type-spec ::] ac-value-list
973 TYPE_PARSER(construct<AcSpec>(maybe(typeSpec / "::"),
974 nonemptyList("expected array constructor values"_err_en_US,
975 Parser<AcValue>{})) ||
976 construct<AcSpec>(typeSpec / "::"))
977
978 // R773 ac-value -> expr | ac-implied-do
979 TYPE_PARSER(
980 // PGI/Intel extension: accept triplets in array constructors
981 extension<LanguageFeature::TripletInArrayConstructor>(
982 construct<AcValue>(construct<AcValue::Triplet>(scalarIntExpr,
983 ":" >> scalarIntExpr, maybe(":" >> scalarIntExpr)))) ||
984 construct<AcValue>(indirect(expr)) ||
985 construct<AcValue>(indirect(Parser<AcImpliedDo>{})))
986
987 // R774 ac-implied-do -> ( ac-value-list , ac-implied-do-control )
988 TYPE_PARSER(parenthesized(
989 construct<AcImpliedDo>(nonemptyList(Parser<AcValue>{} / lookAhead(","_tok)),
990 "," >> Parser<AcImpliedDoControl>{})))
991
992 // R775 ac-implied-do-control ->
993 // [integer-type-spec ::] ac-do-variable = scalar-int-expr ,
994 // scalar-int-expr [, scalar-int-expr]
995 // R776 ac-do-variable -> do-variable
996 TYPE_PARSER(construct<AcImpliedDoControl>(
997 maybe(integerTypeSpec / "::"), loopBounds(scalarIntExpr)))
998
999 // R801 type-declaration-stmt ->
1000 // declaration-type-spec [[, attr-spec]... ::] entity-decl-list
1001 TYPE_PARSER(
1002 construct<TypeDeclarationStmt>(declarationTypeSpec,
1003 defaulted("," >> nonemptyList(Parser<AttrSpec>{})) / "::",
1004 nonemptyList("expected entity declarations"_err_en_US, entityDecl)) ||
1005 // C806: no initializers allowed without colons ("REALA=1" is ambiguous)
1006 construct<TypeDeclarationStmt>(declarationTypeSpec,
1007 construct<std::list<AttrSpec>>(),
1008 nonemptyList(
1009 "expected entity declarations"_err_en_US, entityDeclWithoutInit)) ||
1010 // PGI-only extension: comma in place of doubled colons
1011 extension<LanguageFeature::MissingColons>(construct<TypeDeclarationStmt>(
1012 declarationTypeSpec, defaulted("," >> nonemptyList(Parser<AttrSpec>{})),
1013 withMessage("expected entity declarations"_err_en_US,
1014 "," >> nonemptyList(entityDecl)))))
1015
1016 // R802 attr-spec ->
1017 // access-spec | ALLOCATABLE | ASYNCHRONOUS |
1018 // CODIMENSION lbracket coarray-spec rbracket | CONTIGUOUS |
1019 // DIMENSION ( array-spec ) | EXTERNAL | INTENT ( intent-spec ) |
1020 // INTRINSIC | language-binding-spec | OPTIONAL | PARAMETER | POINTER |
1021 // PROTECTED | SAVE | TARGET | VALUE | VOLATILE
1022 constexpr auto optional{construct<Optional>("OPTIONAL"_tok)};
1023 constexpr auto protectedAttr{construct<Protected>("PROTECTED"_tok)};
1024 constexpr auto save{construct<Save>("SAVE"_tok)};
1025 TYPE_PARSER(construct<AttrSpec>(accessSpec) ||
1026 construct<AttrSpec>(allocatable) ||
1027 construct<AttrSpec>(construct<Asynchronous>("ASYNCHRONOUS"_tok)) ||
1028 construct<AttrSpec>("CODIMENSION" >> coarraySpec) ||
1029 construct<AttrSpec>(contiguous) ||
1030 construct<AttrSpec>("DIMENSION" >> arraySpec) ||
1031 construct<AttrSpec>(construct<External>("EXTERNAL"_tok)) ||
1032 construct<AttrSpec>("INTENT" >> parenthesized(intentSpec)) ||
1033 construct<AttrSpec>(construct<Intrinsic>("INTRINSIC"_tok)) ||
1034 construct<AttrSpec>(languageBindingSpec) || construct<AttrSpec>(optional) ||
1035 construct<AttrSpec>(construct<Parameter>("PARAMETER"_tok)) ||
1036 construct<AttrSpec>(pointer) || construct<AttrSpec>(protectedAttr) ||
1037 construct<AttrSpec>(save) ||
1038 construct<AttrSpec>(construct<Target>("TARGET"_tok)) ||
1039 construct<AttrSpec>(construct<Value>("VALUE"_tok)) ||
1040 construct<AttrSpec>(construct<Volatile>("VOLATILE"_tok)))
1041
1042 // R804 object-name -> name
1043 constexpr auto objectName{name};
1044
1045 // R803 entity-decl ->
1046 // object-name [( array-spec )] [lbracket coarray-spec rbracket]
1047 // [* char-length] [initialization] |
1048 // function-name [* char-length]
1049 TYPE_PARSER(construct<EntityDecl>(objectName, maybe(arraySpec),
1050 maybe(coarraySpec), maybe("*" >> charLength), maybe(initialization)))
1051
1052 // R806 null-init -> function-reference
1053 // TODO: confirm in semantics that NULL still intrinsic in this scope
1054 TYPE_PARSER(construct<NullInit>("NULL ( )"_tok) / !"("_tok)
1055
1056 // R807 access-spec -> PUBLIC | PRIVATE
1057 TYPE_PARSER(construct<AccessSpec>("PUBLIC" >> pure(AccessSpec::Kind::Public)) ||
1058 construct<AccessSpec>("PRIVATE" >> pure(AccessSpec::Kind::Private)))
1059
1060 // R808 language-binding-spec ->
1061 // BIND ( C [, NAME = scalar-default-char-constant-expr] )
1062 // R1528 proc-language-binding-spec -> language-binding-spec
1063 TYPE_PARSER(construct<LanguageBindingSpec>(
1064 "BIND ( C" >> maybe(", NAME =" >> scalarDefaultCharConstantExpr) / ")"))
1065
1066 // R809 coarray-spec -> deferred-coshape-spec-list | explicit-coshape-spec
1067 // N.B. Bracketed here rather than around references, for consistency with
1068 // array-spec.
1069 TYPE_PARSER(
1070 construct<CoarraySpec>(bracketed(Parser<DeferredCoshapeSpecList>{})) ||
1071 construct<CoarraySpec>(bracketed(Parser<ExplicitCoshapeSpec>{})))
1072
1073 // R810 deferred-coshape-spec -> :
1074 // deferred-coshape-spec-list - just a list of colons
listLength(std::list<Success> && xs)1075 inline int listLength(std::list<Success> &&xs) { return xs.size(); }
1076
1077 TYPE_PARSER(construct<DeferredCoshapeSpecList>(
1078 applyFunction(listLength, nonemptyList(":"_tok))))
1079
1080 // R811 explicit-coshape-spec ->
1081 // [[lower-cobound :] upper-cobound ,]... [lower-cobound :] *
1082 // R812 lower-cobound -> specification-expr
1083 // R813 upper-cobound -> specification-expr
1084 TYPE_PARSER(construct<ExplicitCoshapeSpec>(
1085 many(explicitShapeSpec / ","), maybe(specificationExpr / ":") / "*"))
1086
1087 // R815 array-spec ->
1088 // explicit-shape-spec-list | assumed-shape-spec-list |
1089 // deferred-shape-spec-list | assumed-size-spec | implied-shape-spec |
1090 // implied-shape-or-assumed-size-spec | assumed-rank-spec
1091 // N.B. Parenthesized here rather than around references to avoid
1092 // a need for forced look-ahead.
1093 // Shape specs that could be deferred-shape-spec or assumed-shape-spec
1094 // (e.g. '(:,:)') are parsed as the former.
1095 TYPE_PARSER(
1096 construct<ArraySpec>(parenthesized(nonemptyList(explicitShapeSpec))) ||
1097 construct<ArraySpec>(parenthesized(deferredShapeSpecList)) ||
1098 construct<ArraySpec>(
1099 parenthesized(nonemptyList(Parser<AssumedShapeSpec>{}))) ||
1100 construct<ArraySpec>(parenthesized(Parser<AssumedSizeSpec>{})) ||
1101 construct<ArraySpec>(parenthesized(Parser<ImpliedShapeSpec>{})) ||
1102 construct<ArraySpec>(parenthesized(Parser<AssumedRankSpec>{})))
1103
1104 // R816 explicit-shape-spec -> [lower-bound :] upper-bound
1105 // R817 lower-bound -> specification-expr
1106 // R818 upper-bound -> specification-expr
1107 TYPE_PARSER(construct<ExplicitShapeSpec>(
1108 maybe(specificationExpr / ":"), specificationExpr))
1109
1110 // R819 assumed-shape-spec -> [lower-bound] :
1111 TYPE_PARSER(construct<AssumedShapeSpec>(maybe(specificationExpr) / ":"))
1112
1113 // R820 deferred-shape-spec -> :
1114 // deferred-shape-spec-list - just a list of colons
1115 TYPE_PARSER(construct<DeferredShapeSpecList>(
1116 applyFunction(listLength, nonemptyList(":"_tok))))
1117
1118 // R821 assumed-implied-spec -> [lower-bound :] *
1119 TYPE_PARSER(construct<AssumedImpliedSpec>(maybe(specificationExpr / ":") / "*"))
1120
1121 // R822 assumed-size-spec -> explicit-shape-spec-list , assumed-implied-spec
1122 TYPE_PARSER(construct<AssumedSizeSpec>(
1123 nonemptyList(explicitShapeSpec) / ",", assumedImpliedSpec))
1124
1125 // R823 implied-shape-or-assumed-size-spec -> assumed-implied-spec
1126 // R824 implied-shape-spec -> assumed-implied-spec , assumed-implied-spec-list
1127 // I.e., when the assumed-implied-spec-list has a single item, it constitutes an
1128 // implied-shape-or-assumed-size-spec; otherwise, an implied-shape-spec.
TYPE_PARSER(construct<ImpliedShapeSpec> (nonemptyList (assumedImpliedSpec)))1129 TYPE_PARSER(construct<ImpliedShapeSpec>(nonemptyList(assumedImpliedSpec)))
1130
1131 // R825 assumed-rank-spec -> ..
1132 TYPE_PARSER(construct<AssumedRankSpec>(".."_tok))
1133
1134 // R826 intent-spec -> IN | OUT | INOUT
1135 TYPE_PARSER(construct<IntentSpec>("IN OUT" >> pure(IntentSpec::Intent::InOut) ||
1136 "IN" >> pure(IntentSpec::Intent::In) ||
1137 "OUT" >> pure(IntentSpec::Intent::Out)))
1138
1139 // R827 access-stmt -> access-spec [[::] access-id-list]
1140 TYPE_PARSER(construct<AccessStmt>(accessSpec,
1141 defaulted(maybe("::"_tok) >>
1142 nonemptyList("expected names and generic specifications"_err_en_US,
1143 Parser<AccessId>{}))))
1144
1145 // R828 access-id -> access-name | generic-spec
1146 TYPE_PARSER(construct<AccessId>(indirect(genericSpec)) ||
1147 construct<AccessId>(name)) // initially ambiguous with genericSpec
1148
1149 // R829 allocatable-stmt -> ALLOCATABLE [::] allocatable-decl-list
1150 TYPE_PARSER(construct<AllocatableStmt>("ALLOCATABLE" >> maybe("::"_tok) >>
1151 nonemptyList(
1152 "expected object declarations"_err_en_US, Parser<ObjectDecl>{})))
1153
1154 // R830 allocatable-decl ->
1155 // object-name [( array-spec )] [lbracket coarray-spec rbracket]
1156 // R860 target-decl ->
1157 // object-name [( array-spec )] [lbracket coarray-spec rbracket]
1158 TYPE_PARSER(
1159 construct<ObjectDecl>(objectName, maybe(arraySpec), maybe(coarraySpec)))
1160
1161 // R831 asynchronous-stmt -> ASYNCHRONOUS [::] object-name-list
1162 TYPE_PARSER(construct<AsynchronousStmt>("ASYNCHRONOUS" >> maybe("::"_tok) >>
1163 nonemptyList("expected object names"_err_en_US, objectName)))
1164
1165 // R832 bind-stmt -> language-binding-spec [::] bind-entity-list
1166 TYPE_PARSER(construct<BindStmt>(languageBindingSpec / maybe("::"_tok),
1167 nonemptyList("expected bind entities"_err_en_US, Parser<BindEntity>{})))
1168
1169 // R833 bind-entity -> entity-name | / common-block-name /
1170 TYPE_PARSER(construct<BindEntity>(pure(BindEntity::Kind::Object), name) ||
1171 construct<BindEntity>("/" >> pure(BindEntity::Kind::Common), name / "/"))
1172
1173 // R834 codimension-stmt -> CODIMENSION [::] codimension-decl-list
1174 TYPE_PARSER(construct<CodimensionStmt>("CODIMENSION" >> maybe("::"_tok) >>
1175 nonemptyList("expected codimension declarations"_err_en_US,
1176 Parser<CodimensionDecl>{})))
1177
1178 // R835 codimension-decl -> coarray-name lbracket coarray-spec rbracket
1179 TYPE_PARSER(construct<CodimensionDecl>(name, coarraySpec))
1180
1181 // R836 contiguous-stmt -> CONTIGUOUS [::] object-name-list
1182 TYPE_PARSER(construct<ContiguousStmt>("CONTIGUOUS" >> maybe("::"_tok) >>
1183 nonemptyList("expected object names"_err_en_US, objectName)))
1184
1185 // R837 data-stmt -> DATA data-stmt-set [[,] data-stmt-set]...
1186 TYPE_CONTEXT_PARSER("DATA statement"_en_US,
1187 construct<DataStmt>(
1188 "DATA" >> nonemptySeparated(Parser<DataStmtSet>{}, maybe(","_tok))))
1189
1190 // R838 data-stmt-set -> data-stmt-object-list / data-stmt-value-list /
1191 TYPE_PARSER(construct<DataStmtSet>(
1192 nonemptyList(
1193 "expected DATA statement objects"_err_en_US, Parser<DataStmtObject>{}),
1194 withMessage("expected DATA statement value list"_err_en_US,
1195 "/"_tok >> nonemptyList("expected DATA statement values"_err_en_US,
1196 Parser<DataStmtValue>{})) /
1197 "/"))
1198
1199 // R839 data-stmt-object -> variable | data-implied-do
1200 TYPE_PARSER(construct<DataStmtObject>(indirect(variable)) ||
1201 construct<DataStmtObject>(dataImpliedDo))
1202
1203 // R840 data-implied-do ->
1204 // ( data-i-do-object-list , [integer-type-spec ::] data-i-do-variable
1205 // = scalar-int-constant-expr , scalar-int-constant-expr
1206 // [, scalar-int-constant-expr] )
1207 // R842 data-i-do-variable -> do-variable
1208 TYPE_PARSER(parenthesized(construct<DataImpliedDo>(
1209 nonemptyList(Parser<DataIDoObject>{} / lookAhead(","_tok)) / ",",
1210 maybe(integerTypeSpec / "::"), loopBounds(scalarIntConstantExpr))))
1211
1212 // R841 data-i-do-object ->
1213 // array-element | scalar-structure-component | data-implied-do
1214 TYPE_PARSER(construct<DataIDoObject>(scalar(indirect(designator))) ||
1215 construct<DataIDoObject>(indirect(dataImpliedDo)))
1216
1217 // R843 data-stmt-value -> [data-stmt-repeat *] data-stmt-constant
1218 TYPE_PARSER(construct<DataStmtValue>(
1219 maybe(Parser<DataStmtRepeat>{} / "*"), Parser<DataStmtConstant>{}))
1220
1221 // R847 constant-subobject -> designator
1222 // R846 int-constant-subobject -> constant-subobject
1223 constexpr auto constantSubobject{constant(indirect(designator))};
1224
1225 // R844 data-stmt-repeat -> scalar-int-constant | scalar-int-constant-subobject
1226 // R607 int-constant -> constant
1227 // Factored into:
1228 // constant -> literal-constant -> int-literal-constant and
1229 // constant -> named-constant
1230 TYPE_PARSER(construct<DataStmtRepeat>(intLiteralConstant) ||
1231 construct<DataStmtRepeat>(scalar(integer(constantSubobject))) ||
1232 construct<DataStmtRepeat>(scalar(integer(namedConstant))))
1233
1234 // R845 data-stmt-constant ->
1235 // scalar-constant | scalar-constant-subobject |
1236 // signed-int-literal-constant | signed-real-literal-constant |
1237 // null-init | initial-data-target | structure-constructor
1238 // TODO: Some structure constructors can be misrecognized as array
1239 // references into constant subobjects.
TYPE_PARSER(first (construct<DataStmtConstant> (scalar (Parser<ConstantValue>{})),construct<DataStmtConstant> (nullInit),construct<DataStmtConstant> (Parser<StructureConstructor>{}),construct<DataStmtConstant> (scalar (constantSubobject)),construct<DataStmtConstant> (signedRealLiteralConstant),construct<DataStmtConstant> (signedIntLiteralConstant),extension<LanguageFeature::SignedComplexLiteral> (construct<DataStmtConstant> (Parser<SignedComplexLiteralConstant>{})),construct<DataStmtConstant> (initialDataTarget)))1240 TYPE_PARSER(first(construct<DataStmtConstant>(scalar(Parser<ConstantValue>{})),
1241 construct<DataStmtConstant>(nullInit),
1242 construct<DataStmtConstant>(Parser<StructureConstructor>{}),
1243 construct<DataStmtConstant>(scalar(constantSubobject)),
1244 construct<DataStmtConstant>(signedRealLiteralConstant),
1245 construct<DataStmtConstant>(signedIntLiteralConstant),
1246 extension<LanguageFeature::SignedComplexLiteral>(
1247 construct<DataStmtConstant>(Parser<SignedComplexLiteralConstant>{})),
1248 construct<DataStmtConstant>(initialDataTarget)))
1249
1250 // R848 dimension-stmt ->
1251 // DIMENSION [::] array-name ( array-spec )
1252 // [, array-name ( array-spec )]...
1253 TYPE_CONTEXT_PARSER("DIMENSION statement"_en_US,
1254 construct<DimensionStmt>("DIMENSION" >> maybe("::"_tok) >>
1255 nonemptyList("expected array specifications"_err_en_US,
1256 construct<DimensionStmt::Declaration>(name, arraySpec))))
1257
1258 // R849 intent-stmt -> INTENT ( intent-spec ) [::] dummy-arg-name-list
1259 TYPE_CONTEXT_PARSER("INTENT statement"_en_US,
1260 construct<IntentStmt>(
1261 "INTENT" >> parenthesized(intentSpec) / maybe("::"_tok), listOfNames))
1262
1263 // R850 optional-stmt -> OPTIONAL [::] dummy-arg-name-list
1264 TYPE_PARSER(
1265 construct<OptionalStmt>("OPTIONAL" >> maybe("::"_tok) >> listOfNames))
1266
1267 // R851 parameter-stmt -> PARAMETER ( named-constant-def-list )
1268 // Legacy extension: omitted parentheses, no implicit typing from names
1269 TYPE_CONTEXT_PARSER("PARAMETER statement"_en_US,
1270 construct<ParameterStmt>(
1271 "PARAMETER" >> parenthesized(nonemptyList(Parser<NamedConstantDef>{}))))
1272 TYPE_CONTEXT_PARSER("old style PARAMETER statement"_en_US,
1273 extension<LanguageFeature::OldStyleParameter>(construct<OldParameterStmt>(
1274 "PARAMETER" >> nonemptyList(Parser<NamedConstantDef>{}))))
1275
1276 // R852 named-constant-def -> named-constant = constant-expr
1277 TYPE_PARSER(construct<NamedConstantDef>(namedConstant, "=" >> constantExpr))
1278
1279 // R853 pointer-stmt -> POINTER [::] pointer-decl-list
1280 TYPE_PARSER(construct<PointerStmt>("POINTER" >> maybe("::"_tok) >>
1281 nonemptyList(
1282 "expected pointer declarations"_err_en_US, Parser<PointerDecl>{})))
1283
1284 // R854 pointer-decl ->
1285 // object-name [( deferred-shape-spec-list )] | proc-entity-name
1286 TYPE_PARSER(
1287 construct<PointerDecl>(name, maybe(parenthesized(deferredShapeSpecList))))
1288
1289 // R855 protected-stmt -> PROTECTED [::] entity-name-list
1290 TYPE_PARSER(
1291 construct<ProtectedStmt>("PROTECTED" >> maybe("::"_tok) >> listOfNames))
1292
1293 // R856 save-stmt -> SAVE [[::] saved-entity-list]
1294 TYPE_PARSER(construct<SaveStmt>(
1295 "SAVE" >> defaulted(maybe("::"_tok) >>
1296 nonemptyList("expected SAVE entities"_err_en_US,
1297 Parser<SavedEntity>{}))))
1298
1299 // R857 saved-entity -> object-name | proc-pointer-name | / common-block-name /
1300 // R858 proc-pointer-name -> name
1301 TYPE_PARSER(construct<SavedEntity>(pure(SavedEntity::Kind::Entity), name) ||
1302 construct<SavedEntity>("/" >> pure(SavedEntity::Kind::Common), name / "/"))
1303
1304 // R859 target-stmt -> TARGET [::] target-decl-list
1305 TYPE_PARSER(construct<TargetStmt>("TARGET" >> maybe("::"_tok) >>
1306 nonemptyList("expected objects"_err_en_US, Parser<ObjectDecl>{})))
1307
1308 // R861 value-stmt -> VALUE [::] dummy-arg-name-list
1309 TYPE_PARSER(construct<ValueStmt>("VALUE" >> maybe("::"_tok) >> listOfNames))
1310
1311 // R862 volatile-stmt -> VOLATILE [::] object-name-list
1312 TYPE_PARSER(construct<VolatileStmt>("VOLATILE" >> maybe("::"_tok) >>
1313 nonemptyList("expected object names"_err_en_US, objectName)))
1314
1315 // R866 implicit-name-spec -> EXTERNAL | TYPE
1316 constexpr auto implicitNameSpec{
1317 "EXTERNAL" >> pure(ImplicitStmt::ImplicitNoneNameSpec::External) ||
1318 "TYPE" >> pure(ImplicitStmt::ImplicitNoneNameSpec::Type)};
1319
1320 // R863 implicit-stmt ->
1321 // IMPLICIT implicit-spec-list |
1322 // IMPLICIT NONE [( [implicit-name-spec-list] )]
1323 TYPE_CONTEXT_PARSER("IMPLICIT statement"_en_US,
1324 construct<ImplicitStmt>(
1325 "IMPLICIT" >> nonemptyList("expected IMPLICIT specifications"_err_en_US,
1326 Parser<ImplicitSpec>{})) ||
1327 construct<ImplicitStmt>("IMPLICIT NONE"_sptok >>
1328 defaulted(parenthesized(optionalList(implicitNameSpec)))))
1329
1330 // R864 implicit-spec -> declaration-type-spec ( letter-spec-list )
1331 // The variant form of declarationTypeSpec is meant to avoid misrecognition
1332 // of a letter-spec as a simple parenthesized expression for kind or character
1333 // length, e.g., PARAMETER(I=5,N=1); IMPLICIT REAL(I-N)(O-Z) vs.
1334 // IMPLICIT REAL(I-N). The variant form needs to attempt to reparse only
1335 // types with optional parenthesized kind/length expressions, so derived
1336 // type specs, DOUBLE PRECISION, and DOUBLE COMPLEX need not be considered.
1337 constexpr auto noKindSelector{construct<std::optional<KindSelector>>()};
1338 constexpr auto implicitSpecDeclarationTypeSpecRetry{
1339 construct<DeclarationTypeSpec>(first(
1340 construct<IntrinsicTypeSpec>(
1341 construct<IntegerTypeSpec>("INTEGER" >> noKindSelector)),
1342 construct<IntrinsicTypeSpec>(
1343 construct<IntrinsicTypeSpec::Real>("REAL" >> noKindSelector)),
1344 construct<IntrinsicTypeSpec>(
1345 construct<IntrinsicTypeSpec::Complex>("COMPLEX" >> noKindSelector)),
1346 construct<IntrinsicTypeSpec>(construct<IntrinsicTypeSpec::Character>(
1347 "CHARACTER" >> construct<std::optional<CharSelector>>())),
1348 construct<IntrinsicTypeSpec>(construct<IntrinsicTypeSpec::Logical>(
1349 "LOGICAL" >> noKindSelector))))};
1350
1351 TYPE_PARSER(construct<ImplicitSpec>(declarationTypeSpec,
1352 parenthesized(nonemptyList(Parser<LetterSpec>{}))) ||
1353 construct<ImplicitSpec>(implicitSpecDeclarationTypeSpecRetry,
1354 parenthesized(nonemptyList(Parser<LetterSpec>{}))))
1355
1356 // R865 letter-spec -> letter [- letter]
1357 TYPE_PARSER(space >> (construct<LetterSpec>(letter, maybe("-" >> letter)) ||
1358 construct<LetterSpec>(otherIdChar,
1359 construct<std::optional<const char *>>())))
1360
1361 // R867 import-stmt ->
1362 // IMPORT [[::] import-name-list] |
1363 // IMPORT , ONLY : import-name-list | IMPORT , NONE | IMPORT , ALL
1364 TYPE_CONTEXT_PARSER("IMPORT statement"_en_US,
1365 construct<ImportStmt>(
1366 "IMPORT , ONLY :" >> pure(common::ImportKind::Only), listOfNames) ||
1367 construct<ImportStmt>(
1368 "IMPORT , NONE" >> pure(common::ImportKind::None)) ||
1369 construct<ImportStmt>(
1370 "IMPORT , ALL" >> pure(common::ImportKind::All)) ||
1371 construct<ImportStmt>(
1372 "IMPORT" >> maybe("::"_tok) >> optionalList(name)))
1373
1374 // R868 namelist-stmt ->
1375 // NAMELIST / namelist-group-name / namelist-group-object-list
1376 // [[,] / namelist-group-name / namelist-group-object-list]...
1377 // R869 namelist-group-object -> variable-name
1378 TYPE_PARSER(construct<NamelistStmt>("NAMELIST" >>
1379 nonemptySeparated(
1380 construct<NamelistStmt::Group>("/" >> name / "/", listOfNames),
1381 maybe(","_tok))))
1382
1383 // R870 equivalence-stmt -> EQUIVALENCE equivalence-set-list
1384 // R871 equivalence-set -> ( equivalence-object , equivalence-object-list )
1385 TYPE_PARSER(construct<EquivalenceStmt>("EQUIVALENCE" >>
1386 nonemptyList(
1387 parenthesized(nonemptyList("expected EQUIVALENCE objects"_err_en_US,
1388 Parser<EquivalenceObject>{})))))
1389
1390 // R872 equivalence-object -> variable-name | array-element | substring
TYPE_PARSER(construct<EquivalenceObject> (indirect (designator)))1391 TYPE_PARSER(construct<EquivalenceObject>(indirect(designator)))
1392
1393 // R873 common-stmt ->
1394 // COMMON [/ [common-block-name] /] common-block-object-list
1395 // [[,] / [common-block-name] / common-block-object-list]...
1396 TYPE_PARSER(
1397 construct<CommonStmt>("COMMON" >> defaulted("/" >> maybe(name) / "/"),
1398 nonemptyList("expected COMMON block objects"_err_en_US,
1399 Parser<CommonBlockObject>{}),
1400 many(maybe(","_tok) >>
1401 construct<CommonStmt::Block>("/" >> maybe(name) / "/",
1402 nonemptyList("expected COMMON block objects"_err_en_US,
1403 Parser<CommonBlockObject>{})))))
1404
1405 // R874 common-block-object -> variable-name [( array-spec )]
1406 TYPE_PARSER(construct<CommonBlockObject>(name, maybe(arraySpec)))
1407
1408 // R901 designator -> object-name | array-element | array-section |
1409 // coindexed-named-object | complex-part-designator |
1410 // structure-component | substring
1411 // The Standard's productions for designator and its alternatives are
1412 // ambiguous without recourse to a symbol table. Many of the alternatives
1413 // for designator (viz., array-element, coindexed-named-object,
1414 // and structure-component) are all syntactically just data-ref.
1415 // What designator boils down to is this:
1416 // It starts with either a name or a character literal.
1417 // If it starts with a character literal, it must be a substring.
1418 // If it starts with a name, it's a sequence of %-separated parts;
1419 // each part is a name, maybe a (section-subscript-list), and
1420 // maybe an [image-selector].
1421 // If it's a substring, it ends with (substring-range).
1422 TYPE_CONTEXT_PARSER("designator"_en_US,
1423 sourced(construct<Designator>(substring) || construct<Designator>(dataRef)))
1424
1425 constexpr auto percentOrDot{"%"_tok ||
1426 // legacy VAX extension for RECORD field access
1427 extension<LanguageFeature::DECStructures>(
1428 "."_tok / lookAhead(OldStructureComponentName{}))};
1429
1430 // R902 variable -> designator | function-reference
1431 // This production appears to be left-recursive in the grammar via
1432 // function-reference -> procedure-designator -> proc-component-ref ->
1433 // scalar-variable
1434 // and would be so if we were to allow functions to be called via procedure
1435 // pointer components within derived type results of other function references
1436 // (a reasonable extension, esp. in the case of procedure pointer components
1437 // that are NOPASS). However, Fortran constrains the use of a variable in a
1438 // proc-component-ref to be a data-ref without coindices (C1027).
1439 // Some array element references will be misrecognized as function references.
1440 constexpr auto noMoreAddressing{!"("_tok >> !"["_tok >> !percentOrDot};
1441 TYPE_CONTEXT_PARSER("variable"_en_US,
1442 construct<Variable>(indirect(functionReference / noMoreAddressing)) ||
1443 construct<Variable>(indirect(designator)))
1444
1445 // R904 logical-variable -> variable
1446 // Appears only as part of scalar-logical-variable.
1447 constexpr auto scalarLogicalVariable{scalar(logical(variable))};
1448
1449 // R906 default-char-variable -> variable
1450 // Appears only as part of scalar-default-char-variable.
1451 constexpr auto scalarDefaultCharVariable{scalar(defaultChar(variable))};
1452
1453 // R907 int-variable -> variable
1454 // Appears only as part of scalar-int-variable.
1455 constexpr auto scalarIntVariable{scalar(integer(variable))};
1456
1457 // R908 substring -> parent-string ( substring-range )
1458 // R909 parent-string ->
1459 // scalar-variable-name | array-element | coindexed-named-object |
1460 // scalar-structure-component | scalar-char-literal-constant |
1461 // scalar-named-constant
1462 TYPE_PARSER(
1463 construct<Substring>(dataRef, parenthesized(Parser<SubstringRange>{})))
1464
TYPE_PARSER(construct<CharLiteralConstantSubstring> (charLiteralConstant,parenthesized (Parser<SubstringRange>{})))1465 TYPE_PARSER(construct<CharLiteralConstantSubstring>(
1466 charLiteralConstant, parenthesized(Parser<SubstringRange>{})))
1467
1468 // R910 substring-range -> [scalar-int-expr] : [scalar-int-expr]
1469 TYPE_PARSER(construct<SubstringRange>(
1470 maybe(scalarIntExpr), ":" >> maybe(scalarIntExpr)))
1471
1472 // R911 data-ref -> part-ref [% part-ref]...
1473 // R914 coindexed-named-object -> data-ref
1474 // R917 array-element -> data-ref
1475 TYPE_PARSER(
1476 construct<DataRef>(nonemptySeparated(Parser<PartRef>{}, percentOrDot)))
1477
1478 // R912 part-ref -> part-name [( section-subscript-list )] [image-selector]
1479 TYPE_PARSER(construct<PartRef>(name,
1480 defaulted(
1481 parenthesized(nonemptyList(Parser<SectionSubscript>{})) / !"=>"_tok),
1482 maybe(Parser<ImageSelector>{})))
1483
1484 // R913 structure-component -> data-ref
1485 TYPE_PARSER(construct<StructureComponent>(
1486 construct<DataRef>(some(Parser<PartRef>{} / percentOrDot)), name))
1487
1488 // R919 subscript -> scalar-int-expr
1489 constexpr auto subscript{scalarIntExpr};
1490
1491 // R920 section-subscript -> subscript | subscript-triplet | vector-subscript
1492 // R923 vector-subscript -> int-expr
1493 // N.B. The distinction that needs to be made between "subscript" and
1494 // "vector-subscript" is deferred to semantic analysis.
1495 TYPE_PARSER(construct<SectionSubscript>(Parser<SubscriptTriplet>{}) ||
1496 construct<SectionSubscript>(intExpr))
1497
1498 // R921 subscript-triplet -> [subscript] : [subscript] [: stride]
1499 TYPE_PARSER(construct<SubscriptTriplet>(
1500 maybe(subscript), ":" >> maybe(subscript), maybe(":" >> subscript)))
1501
1502 // R925 cosubscript -> scalar-int-expr
1503 constexpr auto cosubscript{scalarIntExpr};
1504
1505 // R924 image-selector ->
1506 // lbracket cosubscript-list [, image-selector-spec-list] rbracket
1507 TYPE_CONTEXT_PARSER("image selector"_en_US,
1508 construct<ImageSelector>("[" >> nonemptyList(cosubscript / !"="_tok),
1509 defaulted("," >> nonemptyList(Parser<ImageSelectorSpec>{})) / "]"))
1510
1511 // R1115 team-value -> scalar-expr
1512 constexpr auto teamValue{scalar(indirect(expr))};
1513
1514 // R926 image-selector-spec ->
1515 // STAT = stat-variable | TEAM = team-value |
1516 // TEAM_NUMBER = scalar-int-expr
1517 TYPE_PARSER(construct<ImageSelectorSpec>(construct<ImageSelectorSpec::Stat>(
1518 "STAT =" >> scalar(integer(indirect(variable))))) ||
1519 construct<ImageSelectorSpec>(construct<TeamValue>("TEAM =" >> teamValue)) ||
1520 construct<ImageSelectorSpec>(construct<ImageSelectorSpec::Team_Number>(
1521 "TEAM_NUMBER =" >> scalarIntExpr)))
1522
1523 // R927 allocate-stmt ->
1524 // ALLOCATE ( [type-spec ::] allocation-list [, alloc-opt-list] )
1525 TYPE_CONTEXT_PARSER("ALLOCATE statement"_en_US,
1526 construct<AllocateStmt>("ALLOCATE (" >> maybe(typeSpec / "::"),
1527 nonemptyList(Parser<Allocation>{}),
1528 defaulted("," >> nonemptyList(Parser<AllocOpt>{})) / ")"))
1529
1530 // R928 alloc-opt ->
1531 // ERRMSG = errmsg-variable | MOLD = source-expr |
1532 // SOURCE = source-expr | STAT = stat-variable
1533 // R931 source-expr -> expr
1534 TYPE_PARSER(construct<AllocOpt>(
1535 construct<AllocOpt::Mold>("MOLD =" >> indirect(expr))) ||
1536 construct<AllocOpt>(
1537 construct<AllocOpt::Source>("SOURCE =" >> indirect(expr))) ||
1538 construct<AllocOpt>(statOrErrmsg))
1539
1540 // R929 stat-variable -> scalar-int-variable
TYPE_PARSER(construct<StatVariable> (scalar (integer (variable))))1541 TYPE_PARSER(construct<StatVariable>(scalar(integer(variable))))
1542
1543 // R930 errmsg-variable -> scalar-default-char-variable
1544 // R1207 iomsg-variable -> scalar-default-char-variable
1545 constexpr auto msgVariable{construct<MsgVariable>(scalarDefaultCharVariable)};
1546
1547 // R932 allocation ->
1548 // allocate-object [( allocate-shape-spec-list )]
1549 // [lbracket allocate-coarray-spec rbracket]
1550 // TODO: allocate-shape-spec-list might be misrecognized as
1551 // the final list of subscripts in allocate-object.
1552 TYPE_PARSER(construct<Allocation>(Parser<AllocateObject>{},
1553 defaulted(parenthesized(nonemptyList(Parser<AllocateShapeSpec>{}))),
1554 maybe(bracketed(Parser<AllocateCoarraySpec>{}))))
1555
1556 // R933 allocate-object -> variable-name | structure-component
1557 TYPE_PARSER(construct<AllocateObject>(structureComponent) ||
1558 construct<AllocateObject>(name / !"="_tok))
1559
1560 // R935 lower-bound-expr -> scalar-int-expr
1561 // R936 upper-bound-expr -> scalar-int-expr
1562 constexpr auto boundExpr{scalarIntExpr};
1563
1564 // R934 allocate-shape-spec -> [lower-bound-expr :] upper-bound-expr
1565 // R938 allocate-coshape-spec -> [lower-bound-expr :] upper-bound-expr
1566 TYPE_PARSER(construct<AllocateShapeSpec>(maybe(boundExpr / ":"), boundExpr))
1567
1568 // R937 allocate-coarray-spec ->
1569 // [allocate-coshape-spec-list ,] [lower-bound-expr :] *
1570 TYPE_PARSER(construct<AllocateCoarraySpec>(
1571 defaulted(nonemptyList(Parser<AllocateShapeSpec>{}) / ","),
1572 maybe(boundExpr / ":") / "*"))
1573
1574 // R939 nullify-stmt -> NULLIFY ( pointer-object-list )
1575 TYPE_CONTEXT_PARSER("NULLIFY statement"_en_US,
1576 "NULLIFY" >> parenthesized(construct<NullifyStmt>(
1577 nonemptyList(Parser<PointerObject>{}))))
1578
1579 // R940 pointer-object ->
1580 // variable-name | structure-component | proc-pointer-name
1581 TYPE_PARSER(construct<PointerObject>(structureComponent) ||
1582 construct<PointerObject>(name))
1583
1584 // R941 deallocate-stmt ->
1585 // DEALLOCATE ( allocate-object-list [, dealloc-opt-list] )
1586 TYPE_CONTEXT_PARSER("DEALLOCATE statement"_en_US,
1587 construct<DeallocateStmt>(
1588 "DEALLOCATE (" >> nonemptyList(Parser<AllocateObject>{}),
1589 defaulted("," >> nonemptyList(statOrErrmsg)) / ")"))
1590
1591 // R942 dealloc-opt -> STAT = stat-variable | ERRMSG = errmsg-variable
1592 // R1165 sync-stat -> STAT = stat-variable | ERRMSG = errmsg-variable
1593 TYPE_PARSER(construct<StatOrErrmsg>("STAT =" >> statVariable) ||
1594 construct<StatOrErrmsg>("ERRMSG =" >> msgVariable))
1595
1596 // R1001 primary ->
1597 // literal-constant | designator | array-constructor |
1598 // structure-constructor | function-reference | type-param-inquiry |
1599 // type-param-name | ( expr )
1600 // N.B. type-param-inquiry is parsed as a structure component
1601 constexpr auto primary{instrumented("primary"_en_US,
1602 first(construct<Expr>(indirect(Parser<CharLiteralConstantSubstring>{})),
1603 construct<Expr>(literalConstant),
1604 construct<Expr>(construct<Expr::Parentheses>(parenthesized(expr))),
1605 construct<Expr>(indirect(functionReference) / !"("_tok),
1606 construct<Expr>(designator / !"("_tok),
1607 construct<Expr>(Parser<StructureConstructor>{}),
1608 construct<Expr>(Parser<ArrayConstructor>{}),
1609 // PGI/XLF extension: COMPLEX constructor (x,y)
1610 extension<LanguageFeature::ComplexConstructor>(
1611 construct<Expr>(parenthesized(
1612 construct<Expr::ComplexConstructor>(expr, "," >> expr)))),
1613 extension<LanguageFeature::PercentLOC>(construct<Expr>("%LOC" >>
1614 parenthesized(construct<Expr::PercentLoc>(indirect(variable)))))))};
1615
1616 // R1002 level-1-expr -> [defined-unary-op] primary
1617 // TODO: Reasonable extension: permit multiple defined-unary-ops
1618 constexpr auto level1Expr{sourced(
1619 first(primary, // must come before define op to resolve .TRUE._8 ambiguity
1620 construct<Expr>(construct<Expr::DefinedUnary>(definedOpName, primary)),
1621 extension<LanguageFeature::SignedPrimary>(
1622 construct<Expr>(construct<Expr::UnaryPlus>("+" >> primary))),
1623 extension<LanguageFeature::SignedPrimary>(
1624 construct<Expr>(construct<Expr::Negate>("-" >> primary)))))};
1625
1626 // R1004 mult-operand -> level-1-expr [power-op mult-operand]
1627 // R1007 power-op -> **
1628 // Exponentiation (**) is Fortran's only right-associative binary operation.
1629 struct MultOperand {
1630 using resultType = Expr;
MultOperandMultOperand1631 constexpr MultOperand() {}
1632 static inline std::optional<Expr> Parse(ParseState &);
1633 };
1634
1635 static constexpr auto multOperand{sourced(MultOperand{})};
1636
Parse(ParseState & state)1637 inline std::optional<Expr> MultOperand::Parse(ParseState &state) {
1638 std::optional<Expr> result{level1Expr.Parse(state)};
1639 if (result) {
1640 static constexpr auto op{attempt("**"_tok)};
1641 if (op.Parse(state)) {
1642 std::function<Expr(Expr &&)> power{[&result](Expr &&right) {
1643 return Expr{Expr::Power(std::move(result).value(), std::move(right))};
1644 }};
1645 return applyLambda(power, multOperand).Parse(state); // right-recursive
1646 }
1647 }
1648 return result;
1649 }
1650
1651 // R1005 add-operand -> [add-operand mult-op] mult-operand
1652 // R1008 mult-op -> * | /
1653 // The left recursion in the grammar is implemented iteratively.
1654 constexpr struct AddOperand {
1655 using resultType = Expr;
AddOperandAddOperand1656 constexpr AddOperand() {}
ParseAddOperand1657 static inline std::optional<Expr> Parse(ParseState &state) {
1658 std::optional<Expr> result{multOperand.Parse(state)};
1659 if (result) {
1660 auto source{result->source};
1661 std::function<Expr(Expr &&)> multiply{[&result](Expr &&right) {
1662 return Expr{
1663 Expr::Multiply(std::move(result).value(), std::move(right))};
1664 }};
1665 std::function<Expr(Expr &&)> divide{[&result](Expr &&right) {
1666 return Expr{Expr::Divide(std::move(result).value(), std::move(right))};
1667 }};
1668 auto more{attempt(sourced("*" >> applyLambda(multiply, multOperand) ||
1669 "/" >> applyLambda(divide, multOperand)))};
1670 while (std::optional<Expr> next{more.Parse(state)}) {
1671 result = std::move(next);
1672 result->source.ExtendToCover(source);
1673 }
1674 }
1675 return result;
1676 }
1677 } addOperand;
1678
1679 // R1006 level-2-expr -> [[level-2-expr] add-op] add-operand
1680 // R1009 add-op -> + | -
1681 // These are left-recursive productions, implemented iteratively.
1682 // Note that standard Fortran admits a unary + or - to appear only here,
1683 // by means of a missing first operand; e.g., 2*-3 is valid in C but not
1684 // standard Fortran. We accept unary + and - to appear before any primary
1685 // as an extension.
1686 constexpr struct Level2Expr {
1687 using resultType = Expr;
Level2ExprLevel2Expr1688 constexpr Level2Expr() {}
ParseLevel2Expr1689 static inline std::optional<Expr> Parse(ParseState &state) {
1690 static constexpr auto unary{
1691 sourced(
1692 construct<Expr>(construct<Expr::UnaryPlus>("+" >> addOperand)) ||
1693 construct<Expr>(construct<Expr::Negate>("-" >> addOperand))) ||
1694 addOperand};
1695 std::optional<Expr> result{unary.Parse(state)};
1696 if (result) {
1697 auto source{result->source};
1698 std::function<Expr(Expr &&)> add{[&result](Expr &&right) {
1699 return Expr{Expr::Add(std::move(result).value(), std::move(right))};
1700 }};
1701 std::function<Expr(Expr &&)> subtract{[&result](Expr &&right) {
1702 return Expr{
1703 Expr::Subtract(std::move(result).value(), std::move(right))};
1704 }};
1705 auto more{attempt(sourced("+" >> applyLambda(add, addOperand) ||
1706 "-" >> applyLambda(subtract, addOperand)))};
1707 while (std::optional<Expr> next{more.Parse(state)}) {
1708 result = std::move(next);
1709 result->source.ExtendToCover(source);
1710 }
1711 }
1712 return result;
1713 }
1714 } level2Expr;
1715
1716 // R1010 level-3-expr -> [level-3-expr concat-op] level-2-expr
1717 // R1011 concat-op -> //
1718 // Concatenation (//) is left-associative for parsing performance, although
1719 // one would never notice if it were right-associated.
1720 constexpr struct Level3Expr {
1721 using resultType = Expr;
Level3ExprLevel3Expr1722 constexpr Level3Expr() {}
ParseLevel3Expr1723 static inline std::optional<Expr> Parse(ParseState &state) {
1724 std::optional<Expr> result{level2Expr.Parse(state)};
1725 if (result) {
1726 auto source{result->source};
1727 std::function<Expr(Expr &&)> concat{[&result](Expr &&right) {
1728 return Expr{Expr::Concat(std::move(result).value(), std::move(right))};
1729 }};
1730 auto more{attempt(sourced("//" >> applyLambda(concat, level2Expr)))};
1731 while (std::optional<Expr> next{more.Parse(state)}) {
1732 result = std::move(next);
1733 result->source.ExtendToCover(source);
1734 }
1735 }
1736 return result;
1737 }
1738 } level3Expr;
1739
1740 // R1012 level-4-expr -> [level-3-expr rel-op] level-3-expr
1741 // R1013 rel-op ->
1742 // .EQ. | .NE. | .LT. | .LE. | .GT. | .GE. |
1743 // == | /= | < | <= | > | >= @ | <>
1744 // N.B. relations are not recursive (i.e., LOGICAL is not ordered)
1745 constexpr struct Level4Expr {
1746 using resultType = Expr;
Level4ExprLevel4Expr1747 constexpr Level4Expr() {}
ParseLevel4Expr1748 static inline std::optional<Expr> Parse(ParseState &state) {
1749 std::optional<Expr> result{level3Expr.Parse(state)};
1750 if (result) {
1751 auto source{result->source};
1752 std::function<Expr(Expr &&)> lt{[&result](Expr &&right) {
1753 return Expr{Expr::LT(std::move(result).value(), std::move(right))};
1754 }};
1755 std::function<Expr(Expr &&)> le{[&result](Expr &&right) {
1756 return Expr{Expr::LE(std::move(result).value(), std::move(right))};
1757 }};
1758 std::function<Expr(Expr &&)> eq{[&result](Expr &&right) {
1759 return Expr{Expr::EQ(std::move(result).value(), std::move(right))};
1760 }};
1761 std::function<Expr(Expr &&)> ne{[&result](Expr &&right) {
1762 return Expr{Expr::NE(std::move(result).value(), std::move(right))};
1763 }};
1764 std::function<Expr(Expr &&)> ge{[&result](Expr &&right) {
1765 return Expr{Expr::GE(std::move(result).value(), std::move(right))};
1766 }};
1767 std::function<Expr(Expr &&)> gt{[&result](Expr &&right) {
1768 return Expr{Expr::GT(std::move(result).value(), std::move(right))};
1769 }};
1770 auto more{attempt(
1771 sourced((".LT."_tok || "<"_tok) >> applyLambda(lt, level3Expr) ||
1772 (".LE."_tok || "<="_tok) >> applyLambda(le, level3Expr) ||
1773 (".EQ."_tok || "=="_tok) >> applyLambda(eq, level3Expr) ||
1774 (".NE."_tok || "/="_tok ||
1775 extension<LanguageFeature::AlternativeNE>(
1776 "<>"_tok /* PGI/Cray extension; Cray also has .LG. */)) >>
1777 applyLambda(ne, level3Expr) ||
1778 (".GE."_tok || ">="_tok) >> applyLambda(ge, level3Expr) ||
1779 (".GT."_tok || ">"_tok) >> applyLambda(gt, level3Expr)))};
1780 if (std::optional<Expr> next{more.Parse(state)}) {
1781 next->source.ExtendToCover(source);
1782 return next;
1783 }
1784 }
1785 return result;
1786 }
1787 } level4Expr;
1788
1789 // R1014 and-operand -> [not-op] level-4-expr
1790 // R1018 not-op -> .NOT.
1791 // N.B. Fortran's .NOT. binds less tightly than its comparison operators do.
1792 // PGI/Intel extension: accept multiple .NOT. operators
1793 constexpr struct AndOperand {
1794 using resultType = Expr;
AndOperandAndOperand1795 constexpr AndOperand() {}
1796 static inline std::optional<Expr> Parse(ParseState &);
1797 } andOperand;
1798
Parse(ParseState & state)1799 inline std::optional<Expr> AndOperand::Parse(ParseState &state) {
1800 static constexpr auto notOp{attempt(".NOT."_tok >> andOperand)};
1801 if (std::optional<Expr> negation{notOp.Parse(state)}) {
1802 return Expr{Expr::NOT{std::move(*negation)}};
1803 } else {
1804 return level4Expr.Parse(state);
1805 }
1806 }
1807
1808 // R1015 or-operand -> [or-operand and-op] and-operand
1809 // R1019 and-op -> .AND.
1810 // .AND. is left-associative
1811 constexpr struct OrOperand {
1812 using resultType = Expr;
OrOperandOrOperand1813 constexpr OrOperand() {}
ParseOrOperand1814 static inline std::optional<Expr> Parse(ParseState &state) {
1815 static constexpr auto operand{sourced(andOperand)};
1816 std::optional<Expr> result{operand.Parse(state)};
1817 if (result) {
1818 auto source{result->source};
1819 std::function<Expr(Expr &&)> logicalAnd{[&result](Expr &&right) {
1820 return Expr{Expr::AND(std::move(result).value(), std::move(right))};
1821 }};
1822 auto more{
1823 attempt(sourced(".AND." >> applyLambda(logicalAnd, andOperand)))};
1824 while (std::optional<Expr> next{more.Parse(state)}) {
1825 result = std::move(next);
1826 result->source.ExtendToCover(source);
1827 }
1828 }
1829 return result;
1830 }
1831 } orOperand;
1832
1833 // R1016 equiv-operand -> [equiv-operand or-op] or-operand
1834 // R1020 or-op -> .OR.
1835 // .OR. is left-associative
1836 constexpr struct EquivOperand {
1837 using resultType = Expr;
EquivOperandEquivOperand1838 constexpr EquivOperand() {}
ParseEquivOperand1839 static inline std::optional<Expr> Parse(ParseState &state) {
1840 std::optional<Expr> result{orOperand.Parse(state)};
1841 if (result) {
1842 auto source{result->source};
1843 std::function<Expr(Expr &&)> logicalOr{[&result](Expr &&right) {
1844 return Expr{Expr::OR(std::move(result).value(), std::move(right))};
1845 }};
1846 auto more{attempt(sourced(".OR." >> applyLambda(logicalOr, orOperand)))};
1847 while (std::optional<Expr> next{more.Parse(state)}) {
1848 result = std::move(next);
1849 result->source.ExtendToCover(source);
1850 }
1851 }
1852 return result;
1853 }
1854 } equivOperand;
1855
1856 // R1017 level-5-expr -> [level-5-expr equiv-op] equiv-operand
1857 // R1021 equiv-op -> .EQV. | .NEQV.
1858 // Logical equivalence is left-associative.
1859 // Extension: .XOR. as synonym for .NEQV.
1860 constexpr struct Level5Expr {
1861 using resultType = Expr;
Level5ExprLevel5Expr1862 constexpr Level5Expr() {}
ParseLevel5Expr1863 static inline std::optional<Expr> Parse(ParseState &state) {
1864 std::optional<Expr> result{equivOperand.Parse(state)};
1865 if (result) {
1866 auto source{result->source};
1867 std::function<Expr(Expr &&)> eqv{[&result](Expr &&right) {
1868 return Expr{Expr::EQV(std::move(result).value(), std::move(right))};
1869 }};
1870 std::function<Expr(Expr &&)> neqv{[&result](Expr &&right) {
1871 return Expr{Expr::NEQV(std::move(result).value(), std::move(right))};
1872 }};
1873 std::function<Expr(Expr &&)> logicalXor{[&result](Expr &&right) {
1874 return Expr{Expr::XOR(std::move(result).value(), std::move(right))};
1875 }};
1876 auto more{attempt(sourced(".EQV." >> applyLambda(eqv, equivOperand) ||
1877 ".NEQV." >> applyLambda(neqv, equivOperand) ||
1878 extension<LanguageFeature::XOROperator>(
1879 ".XOR." >> applyLambda(logicalXor, equivOperand))))};
1880 while (std::optional<Expr> next{more.Parse(state)}) {
1881 result = std::move(next);
1882 result->source.ExtendToCover(source);
1883 }
1884 }
1885 return result;
1886 }
1887 } level5Expr;
1888
1889 // R1022 expr -> [expr defined-binary-op] level-5-expr
1890 // Defined binary operators associate leftwards.
Parse(ParseState & state)1891 template<> inline std::optional<Expr> Parser<Expr>::Parse(ParseState &state) {
1892 std::optional<Expr> result{level5Expr.Parse(state)};
1893 if (result) {
1894 auto source{result->source};
1895 std::function<Expr(DefinedOpName &&, Expr &&)> defBinOp{
1896 [&result](DefinedOpName &&op, Expr &&right) {
1897 return Expr{Expr::DefinedBinary(
1898 std::move(op), std::move(result).value(), std::move(right))};
1899 }};
1900 auto more{
1901 attempt(sourced(applyLambda(defBinOp, definedOpName, level5Expr)))};
1902 while (std::optional<Expr> next{more.Parse(state)}) {
1903 result = std::move(next);
1904 result->source.ExtendToCover(source);
1905 }
1906 }
1907 return result;
1908 }
1909
1910 // R1028 specification-expr -> scalar-int-expr
1911 TYPE_PARSER(construct<SpecificationExpr>(scalarIntExpr))
1912
1913 // R1032 assignment-stmt -> variable = expr
1914 TYPE_CONTEXT_PARSER("assignment statement"_en_US,
1915 construct<AssignmentStmt>(variable / "=", expr))
1916
1917 // R1033 pointer-assignment-stmt ->
1918 // data-pointer-object [( bounds-spec-list )] => data-target |
1919 // data-pointer-object ( bounds-remapping-list ) => data-target |
1920 // proc-pointer-object => proc-target
1921 // R1034 data-pointer-object ->
1922 // variable-name | scalar-variable % data-pointer-component-name
1923 // C1022 a scalar-variable shall be a data-ref
1924 // C1024 a data-pointer-object shall not be a coindexed object
1925 // R1038 proc-pointer-object -> proc-pointer-name | proc-component-ref
1926 //
1927 // A distinction can't be made at the time of the initial parse between
1928 // data-pointer-object and proc-pointer-object, or between data-target
1929 // and proc-target.
1930 TYPE_CONTEXT_PARSER("pointer assignment statement"_en_US,
1931 construct<PointerAssignmentStmt>(dataRef,
1932 parenthesized(nonemptyList(Parser<BoundsRemapping>{})), "=>" >> expr) ||
1933 construct<PointerAssignmentStmt>(dataRef,
1934 defaulted(parenthesized(nonemptyList(Parser<BoundsSpec>{}))),
1935 "=>" >> expr))
1936
1937 // R1035 bounds-spec -> lower-bound-expr :
1938 TYPE_PARSER(construct<BoundsSpec>(boundExpr / ":"))
1939
1940 // R1036 bounds-remapping -> lower-bound-expr : upper-bound-expr
1941 TYPE_PARSER(construct<BoundsRemapping>(boundExpr / ":", boundExpr))
1942
1943 // R1039 proc-component-ref -> scalar-variable % procedure-component-name
1944 // C1027 the scalar-variable must be a data-ref without coindices.
TYPE_PARSER(construct<ProcComponentRef> (structureComponent))1945 TYPE_PARSER(construct<ProcComponentRef>(structureComponent))
1946
1947 // R1041 where-stmt -> WHERE ( mask-expr ) where-assignment-stmt
1948 // R1045 where-assignment-stmt -> assignment-stmt
1949 // R1046 mask-expr -> logical-expr
1950 TYPE_CONTEXT_PARSER("WHERE statement"_en_US,
1951 construct<WhereStmt>("WHERE" >> parenthesized(logicalExpr), assignmentStmt))
1952
1953 // R1042 where-construct ->
1954 // where-construct-stmt [where-body-construct]...
1955 // [masked-elsewhere-stmt [where-body-construct]...]...
1956 // [elsewhere-stmt [where-body-construct]...] end-where-stmt
1957 TYPE_CONTEXT_PARSER("WHERE construct"_en_US,
1958 construct<WhereConstruct>(statement(Parser<WhereConstructStmt>{}),
1959 many(whereBodyConstruct),
1960 many(construct<WhereConstruct::MaskedElsewhere>(
1961 statement(Parser<MaskedElsewhereStmt>{}),
1962 many(whereBodyConstruct))),
1963 maybe(construct<WhereConstruct::Elsewhere>(
1964 statement(Parser<ElsewhereStmt>{}), many(whereBodyConstruct))),
1965 statement(Parser<EndWhereStmt>{})))
1966
1967 // R1043 where-construct-stmt -> [where-construct-name :] WHERE ( mask-expr )
1968 TYPE_CONTEXT_PARSER("WHERE construct statement"_en_US,
1969 construct<WhereConstructStmt>(
1970 maybe(name / ":"), "WHERE" >> parenthesized(logicalExpr)))
1971
1972 // R1044 where-body-construct ->
1973 // where-assignment-stmt | where-stmt | where-construct
1974 TYPE_PARSER(construct<WhereBodyConstruct>(statement(assignmentStmt)) ||
1975 construct<WhereBodyConstruct>(statement(whereStmt)) ||
1976 construct<WhereBodyConstruct>(indirect(whereConstruct)))
1977
1978 // R1047 masked-elsewhere-stmt ->
1979 // ELSEWHERE ( mask-expr ) [where-construct-name]
1980 TYPE_CONTEXT_PARSER("masked ELSEWHERE statement"_en_US,
1981 construct<MaskedElsewhereStmt>(
1982 "ELSE WHERE" >> parenthesized(logicalExpr), maybe(name)))
1983
1984 // R1048 elsewhere-stmt -> ELSEWHERE [where-construct-name]
1985 TYPE_CONTEXT_PARSER("ELSEWHERE statement"_en_US,
1986 construct<ElsewhereStmt>("ELSE WHERE" >> maybe(name)))
1987
1988 // R1049 end-where-stmt -> ENDWHERE [where-construct-name]
1989 TYPE_CONTEXT_PARSER("END WHERE statement"_en_US,
1990 construct<EndWhereStmt>(
1991 recovery("END WHERE" >> maybe(name), endStmtErrorRecovery)))
1992
1993 // R1050 forall-construct ->
1994 // forall-construct-stmt [forall-body-construct]... end-forall-stmt
1995 TYPE_CONTEXT_PARSER("FORALL construct"_en_US,
1996 construct<ForallConstruct>(statement(Parser<ForallConstructStmt>{}),
1997 many(Parser<ForallBodyConstruct>{}),
1998 statement(Parser<EndForallStmt>{})))
1999
2000 // R1051 forall-construct-stmt ->
2001 // [forall-construct-name :] FORALL concurrent-header
2002 TYPE_CONTEXT_PARSER("FORALL construct statement"_en_US,
2003 construct<ForallConstructStmt>(
2004 maybe(name / ":"), "FORALL" >> indirect(concurrentHeader)))
2005
2006 // R1052 forall-body-construct ->
2007 // forall-assignment-stmt | where-stmt | where-construct |
2008 // forall-construct | forall-stmt
2009 TYPE_PARSER(construct<ForallBodyConstruct>(statement(forallAssignmentStmt)) ||
2010 construct<ForallBodyConstruct>(statement(whereStmt)) ||
2011 construct<ForallBodyConstruct>(whereConstruct) ||
2012 construct<ForallBodyConstruct>(indirect(forallConstruct)) ||
2013 construct<ForallBodyConstruct>(statement(forallStmt)))
2014
2015 // R1053 forall-assignment-stmt -> assignment-stmt | pointer-assignment-stmt
2016 TYPE_PARSER(construct<ForallAssignmentStmt>(assignmentStmt) ||
2017 construct<ForallAssignmentStmt>(pointerAssignmentStmt))
2018
2019 // R1054 end-forall-stmt -> END FORALL [forall-construct-name]
2020 TYPE_CONTEXT_PARSER("END FORALL statement"_en_US,
2021 construct<EndForallStmt>(
2022 recovery("END FORALL" >> maybe(name), endStmtErrorRecovery)))
2023
2024 // R1055 forall-stmt -> FORALL concurrent-header forall-assignment-stmt
2025 TYPE_CONTEXT_PARSER("FORALL statement"_en_US,
2026 construct<ForallStmt>("FORALL" >> indirect(concurrentHeader),
2027 unlabeledStatement(forallAssignmentStmt)))
2028
2029 // R1101 block -> [execution-part-construct]...
2030 constexpr auto block{many(executionPartConstruct)};
2031
2032 // R1102 associate-construct -> associate-stmt block end-associate-stmt
2033 TYPE_CONTEXT_PARSER("ASSOCIATE construct"_en_US,
2034 construct<AssociateConstruct>(statement(Parser<AssociateStmt>{}), block,
2035 statement(Parser<EndAssociateStmt>{})))
2036
2037 // R1103 associate-stmt ->
2038 // [associate-construct-name :] ASSOCIATE ( association-list )
2039 TYPE_CONTEXT_PARSER("ASSOCIATE statement"_en_US,
2040 construct<AssociateStmt>(maybe(name / ":"),
2041 "ASSOCIATE" >> parenthesized(nonemptyList(Parser<Association>{}))))
2042
2043 // R1104 association -> associate-name => selector
2044 TYPE_PARSER(construct<Association>(name, "=>" >> selector))
2045
2046 // R1105 selector -> expr | variable
2047 TYPE_PARSER(construct<Selector>(variable) / lookAhead(","_tok || ")"_tok) ||
2048 construct<Selector>(expr))
2049
2050 // R1106 end-associate-stmt -> END ASSOCIATE [associate-construct-name]
2051 TYPE_PARSER(construct<EndAssociateStmt>(
2052 recovery("END ASSOCIATE" >> maybe(name), endStmtErrorRecovery)))
2053
2054 // R1107 block-construct ->
2055 // block-stmt [block-specification-part] block end-block-stmt
2056 TYPE_CONTEXT_PARSER("BLOCK construct"_en_US,
2057 construct<BlockConstruct>(statement(Parser<BlockStmt>{}),
2058 Parser<BlockSpecificationPart>{}, // can be empty
2059 block, statement(Parser<EndBlockStmt>{})))
2060
2061 // R1108 block-stmt -> [block-construct-name :] BLOCK
2062 TYPE_PARSER(construct<BlockStmt>(maybe(name / ":") / "BLOCK"))
2063
2064 // R1109 block-specification-part ->
2065 // [use-stmt]... [import-stmt]... [implicit-part]
2066 // [[declaration-construct]... specification-construct]
2067 // C1107 prohibits COMMON, EQUIVALENCE, INTENT, NAMELIST, OPTIONAL, VALUE,
2068 // and statement function definitions. C1108 prohibits SAVE /common/.
2069 // C1570 indirectly prohibits ENTRY. These constraints are best enforced later.
2070 // The odd grammar rule above would have the effect of forcing any
2071 // trailing FORMAT and DATA statements after the last specification-construct
2072 // to be recognized as part of the block-construct's block part rather than
2073 // its block-specification-part, a distinction without any apparent difference.
TYPE_PARSER(construct<BlockSpecificationPart> (specificationPart))2074 TYPE_PARSER(construct<BlockSpecificationPart>(specificationPart))
2075
2076 // R1110 end-block-stmt -> END BLOCK [block-construct-name]
2077 TYPE_PARSER(construct<EndBlockStmt>(
2078 recovery("END BLOCK" >> maybe(name), endStmtErrorRecovery)))
2079
2080 // R1111 change-team-construct -> change-team-stmt block end-change-team-stmt
2081 TYPE_CONTEXT_PARSER("CHANGE TEAM construct"_en_US,
2082 construct<ChangeTeamConstruct>(statement(Parser<ChangeTeamStmt>{}), block,
2083 statement(Parser<EndChangeTeamStmt>{})))
2084
2085 // R1112 change-team-stmt ->
2086 // [team-construct-name :] CHANGE TEAM
2087 // ( team-value [, coarray-association-list] [, sync-stat-list] )
2088 TYPE_CONTEXT_PARSER("CHANGE TEAM statement"_en_US,
2089 construct<ChangeTeamStmt>(maybe(name / ":"),
2090 "CHANGE TEAM"_sptok >> "("_tok >> teamValue,
2091 defaulted("," >> nonemptyList(Parser<CoarrayAssociation>{})),
2092 defaulted("," >> nonemptyList(statOrErrmsg))) /
2093 ")")
2094
2095 // R1113 coarray-association -> codimension-decl => selector
2096 TYPE_PARSER(
2097 construct<CoarrayAssociation>(Parser<CodimensionDecl>{}, "=>" >> selector))
2098
2099 // R1114 end-change-team-stmt ->
2100 // END TEAM [( [sync-stat-list] )] [team-construct-name]
2101 TYPE_CONTEXT_PARSER("END TEAM statement"_en_US,
2102 construct<EndChangeTeamStmt>(
2103 "END TEAM" >> defaulted(parenthesized(optionalList(statOrErrmsg))),
2104 maybe(name)))
2105
2106 // R1117 critical-stmt ->
2107 // [critical-construct-name :] CRITICAL [( [sync-stat-list] )]
2108 TYPE_CONTEXT_PARSER("CRITICAL statement"_en_US,
2109 construct<CriticalStmt>(maybe(name / ":"),
2110 "CRITICAL" >> defaulted(parenthesized(optionalList(statOrErrmsg)))))
2111
2112 // R1116 critical-construct -> critical-stmt block end-critical-stmt
2113 TYPE_CONTEXT_PARSER("CRITICAL construct"_en_US,
2114 construct<CriticalConstruct>(statement(Parser<CriticalStmt>{}), block,
2115 statement(Parser<EndCriticalStmt>{})))
2116
2117 // R1118 end-critical-stmt -> END CRITICAL [critical-construct-name]
2118 TYPE_PARSER(construct<EndCriticalStmt>(
2119 recovery("END CRITICAL" >> maybe(name), endStmtErrorRecovery)))
2120
2121 // R1119 do-construct -> do-stmt block end-do
2122 // R1120 do-stmt -> nonlabel-do-stmt | label-do-stmt
2123 TYPE_CONTEXT_PARSER("DO construct"_en_US,
2124 construct<DoConstruct>(
2125 statement(Parser<NonLabelDoStmt>{}) / EnterNonlabelDoConstruct{}, block,
2126 statement(Parser<EndDoStmt>{}) / LeaveDoConstruct{}))
2127
2128 // R1125 concurrent-header ->
2129 // ( [integer-type-spec ::] concurrent-control-list
2130 // [, scalar-mask-expr] )
2131 TYPE_PARSER(parenthesized(construct<ConcurrentHeader>(
2132 maybe(integerTypeSpec / "::"), nonemptyList(Parser<ConcurrentControl>{}),
2133 maybe("," >> scalarLogicalExpr))))
2134
2135 // R1126 concurrent-control ->
2136 // index-name = concurrent-limit : concurrent-limit [: concurrent-step]
2137 // R1127 concurrent-limit -> scalar-int-expr
2138 // R1128 concurrent-step -> scalar-int-expr
2139 TYPE_PARSER(construct<ConcurrentControl>(name / "=", scalarIntExpr / ":",
2140 scalarIntExpr, maybe(":" >> scalarIntExpr)))
2141
2142 // R1130 locality-spec ->
2143 // LOCAL ( variable-name-list ) | LOCAL_INIT ( variable-name-list ) |
2144 // SHARED ( variable-name-list ) | DEFAULT ( NONE )
2145 TYPE_PARSER(construct<LocalitySpec>(construct<LocalitySpec::Local>(
2146 "LOCAL" >> parenthesized(listOfNames))) ||
2147 construct<LocalitySpec>(construct<LocalitySpec::LocalInit>(
2148 "LOCAL_INIT"_sptok >> parenthesized(listOfNames))) ||
2149 construct<LocalitySpec>(construct<LocalitySpec::Shared>(
2150 "SHARED" >> parenthesized(listOfNames))) ||
2151 construct<LocalitySpec>(
2152 construct<LocalitySpec::DefaultNone>("DEFAULT ( NONE )"_tok)))
2153
2154 // R1123 loop-control ->
2155 // [,] do-variable = scalar-int-expr , scalar-int-expr
2156 // [, scalar-int-expr] |
2157 // [,] WHILE ( scalar-logical-expr ) |
2158 // [,] CONCURRENT concurrent-header concurrent-locality
2159 // R1129 concurrent-locality -> [locality-spec]...
2160 TYPE_CONTEXT_PARSER("loop control"_en_US,
2161 maybe(","_tok) >>
2162 (construct<LoopControl>(loopBounds(scalarExpr)) ||
2163 construct<LoopControl>(
2164 "WHILE" >> parenthesized(scalarLogicalExpr)) ||
2165 construct<LoopControl>(construct<LoopControl::Concurrent>(
2166 "CONCURRENT" >> concurrentHeader,
2167 many(Parser<LocalitySpec>{})))))
2168
2169 // R1121 label-do-stmt -> [do-construct-name :] DO label [loop-control]
2170 TYPE_CONTEXT_PARSER("label DO statement"_en_US,
2171 construct<LabelDoStmt>(
2172 maybe(name / ":"), "DO" >> label, maybe(loopControl)))
2173
2174 // R1122 nonlabel-do-stmt -> [do-construct-name :] DO [loop-control]
2175 TYPE_CONTEXT_PARSER("nonlabel DO statement"_en_US,
2176 construct<NonLabelDoStmt>(maybe(name / ":"), "DO" >> maybe(loopControl)))
2177
2178 // R1132 end-do-stmt -> END DO [do-construct-name]
2179 TYPE_CONTEXT_PARSER("END DO statement"_en_US,
2180 construct<EndDoStmt>(
2181 recovery("END DO" >> maybe(name), endStmtErrorRecovery)))
2182
2183 // R1133 cycle-stmt -> CYCLE [do-construct-name]
2184 TYPE_CONTEXT_PARSER(
2185 "CYCLE statement"_en_US, construct<CycleStmt>("CYCLE" >> maybe(name)))
2186
2187 // R1134 if-construct ->
2188 // if-then-stmt block [else-if-stmt block]...
2189 // [else-stmt block] end-if-stmt
2190 // R1135 if-then-stmt -> [if-construct-name :] IF ( scalar-logical-expr )
2191 // THEN R1136 else-if-stmt ->
2192 // ELSE IF ( scalar-logical-expr ) THEN [if-construct-name]
2193 // R1137 else-stmt -> ELSE [if-construct-name]
2194 // R1138 end-if-stmt -> END IF [if-construct-name]
2195 TYPE_CONTEXT_PARSER("IF construct"_en_US,
2196 construct<IfConstruct>(
2197 statement(construct<IfThenStmt>(maybe(name / ":"),
2198 "IF" >> parenthesized(scalarLogicalExpr) / "THEN")),
2199 block,
2200 many(construct<IfConstruct::ElseIfBlock>(
2201 unambiguousStatement(construct<ElseIfStmt>(
2202 "ELSE IF" >> parenthesized(scalarLogicalExpr),
2203 "THEN" >> maybe(name))),
2204 block)),
2205 maybe(construct<IfConstruct::ElseBlock>(
2206 statement(construct<ElseStmt>("ELSE" >> maybe(name))), block)),
2207 statement(construct<EndIfStmt>(
2208 recovery("END IF" >> maybe(name), endStmtErrorRecovery)))))
2209
2210 // R1139 if-stmt -> IF ( scalar-logical-expr ) action-stmt
2211 TYPE_CONTEXT_PARSER("IF statement"_en_US,
2212 construct<IfStmt>("IF" >> parenthesized(scalarLogicalExpr),
2213 unlabeledStatement(actionStmt)))
2214
2215 // R1140 case-construct ->
2216 // select-case-stmt [case-stmt block]... end-select-stmt
2217 TYPE_CONTEXT_PARSER("SELECT CASE construct"_en_US,
2218 construct<CaseConstruct>(statement(Parser<SelectCaseStmt>{}),
2219 many(construct<CaseConstruct::Case>(
2220 unambiguousStatement(Parser<CaseStmt>{}), block)),
2221 statement(endSelectStmt)))
2222
2223 // R1141 select-case-stmt -> [case-construct-name :] SELECT CASE ( case-expr
2224 // ) R1144 case-expr -> scalar-expr
2225 TYPE_CONTEXT_PARSER("SELECT CASE statement"_en_US,
2226 construct<SelectCaseStmt>(
2227 maybe(name / ":"), "SELECT CASE" >> parenthesized(scalar(expr))))
2228
2229 // R1142 case-stmt -> CASE case-selector [case-construct-name]
2230 TYPE_CONTEXT_PARSER("CASE statement"_en_US,
2231 construct<CaseStmt>("CASE" >> Parser<CaseSelector>{}, maybe(name)))
2232
2233 // R1143 end-select-stmt -> END SELECT [case-construct-name]
2234 // R1151 end-select-rank-stmt -> END SELECT [select-construct-name]
2235 // R1155 end-select-type-stmt -> END SELECT [select-construct-name]
2236 TYPE_PARSER(construct<EndSelectStmt>(
2237 recovery("END SELECT" >> maybe(name), endStmtErrorRecovery)))
2238
2239 // R1145 case-selector -> ( case-value-range-list ) | DEFAULT
2240 constexpr auto defaultKeyword{construct<Default>("DEFAULT"_tok)};
parenthesized(construct<CaseSelector> (nonemptyList (Parser<CaseValueRange>{})))2241 TYPE_PARSER(parenthesized(construct<CaseSelector>(
2242 nonemptyList(Parser<CaseValueRange>{}))) ||
2243 construct<CaseSelector>(defaultKeyword))
2244
2245 // R1147 case-value -> scalar-constant-expr
2246 constexpr auto caseValue{scalar(constantExpr)};
2247
2248 // R1146 case-value-range ->
2249 // case-value | case-value : | : case-value | case-value : case-value
2250 TYPE_PARSER(construct<CaseValueRange>(construct<CaseValueRange::Range>(
2251 construct<std::optional<CaseValue>>(caseValue),
2252 ":" >> maybe(caseValue))) ||
2253 construct<CaseValueRange>(
2254 construct<CaseValueRange::Range>(construct<std::optional<CaseValue>>(),
2255 ":" >> construct<std::optional<CaseValue>>(caseValue))) ||
2256 construct<CaseValueRange>(caseValue))
2257
2258 // R1148 select-rank-construct ->
2259 // select-rank-stmt [select-rank-case-stmt block]...
2260 // end-select-rank-stmt
2261 TYPE_CONTEXT_PARSER("SELECT RANK construct"_en_US,
2262 construct<SelectRankConstruct>(statement(Parser<SelectRankStmt>{}),
2263 many(construct<SelectRankConstruct::RankCase>(
2264 unambiguousStatement(Parser<SelectRankCaseStmt>{}), block)),
2265 statement(endSelectStmt)))
2266
2267 // R1149 select-rank-stmt ->
2268 // [select-construct-name :] SELECT RANK
2269 // ( [associate-name =>] selector )
2270 TYPE_CONTEXT_PARSER("SELECT RANK statement"_en_US,
2271 construct<SelectRankStmt>(maybe(name / ":"),
2272 "SELECT RANK"_sptok >> "("_tok >> maybe(name / "=>"), selector / ")"))
2273
2274 // R1150 select-rank-case-stmt ->
2275 // RANK ( scalar-int-constant-expr ) [select-construct-name] |
2276 // RANK ( * ) [select-construct-name] |
2277 // RANK DEFAULT [select-construct-name]
2278 TYPE_CONTEXT_PARSER("RANK case statement"_en_US,
2279 "RANK" >> (construct<SelectRankCaseStmt>(
2280 parenthesized(construct<SelectRankCaseStmt::Rank>(
2281 scalarIntConstantExpr) ||
2282 construct<SelectRankCaseStmt::Rank>(star)) ||
2283 construct<SelectRankCaseStmt::Rank>(defaultKeyword),
2284 maybe(name))))
2285
2286 // R1152 select-type-construct ->
2287 // select-type-stmt [type-guard-stmt block]... end-select-type-stmt
2288 TYPE_CONTEXT_PARSER("SELECT TYPE construct"_en_US,
2289 construct<SelectTypeConstruct>(statement(Parser<SelectTypeStmt>{}),
2290 many(construct<SelectTypeConstruct::TypeCase>(
2291 unambiguousStatement(Parser<TypeGuardStmt>{}), block)),
2292 statement(endSelectStmt)))
2293
2294 // R1153 select-type-stmt ->
2295 // [select-construct-name :] SELECT TYPE
2296 // ( [associate-name =>] selector )
2297 TYPE_CONTEXT_PARSER("SELECT TYPE statement"_en_US,
2298 construct<SelectTypeStmt>(maybe(name / ":"),
2299 "SELECT TYPE (" >> maybe(name / "=>"), selector / ")"))
2300
2301 // R1154 type-guard-stmt ->
2302 // TYPE IS ( type-spec ) [select-construct-name] |
2303 // CLASS IS ( derived-type-spec ) [select-construct-name] |
2304 // CLASS DEFAULT [select-construct-name]
2305 TYPE_CONTEXT_PARSER("type guard statement"_en_US,
2306 construct<TypeGuardStmt>("TYPE IS"_sptok >>
2307 parenthesized(construct<TypeGuardStmt::Guard>(typeSpec)) ||
2308 "CLASS IS"_sptok >> parenthesized(construct<TypeGuardStmt::Guard>(
2309 derivedTypeSpec)) ||
2310 construct<TypeGuardStmt::Guard>("CLASS" >> defaultKeyword),
2311 maybe(name)))
2312
2313 // R1156 exit-stmt -> EXIT [construct-name]
2314 TYPE_CONTEXT_PARSER(
2315 "EXIT statement"_en_US, construct<ExitStmt>("EXIT" >> maybe(name)))
2316
2317 // R1157 goto-stmt -> GO TO label
2318 TYPE_CONTEXT_PARSER(
2319 "GOTO statement"_en_US, construct<GotoStmt>("GO TO" >> label))
2320
2321 // R1158 computed-goto-stmt -> GO TO ( label-list ) [,] scalar-int-expr
2322 TYPE_CONTEXT_PARSER("computed GOTO statement"_en_US,
2323 construct<ComputedGotoStmt>("GO TO" >> parenthesized(nonemptyList(label)),
2324 maybe(","_tok) >> scalarIntExpr))
2325
2326 // R1160 stop-stmt -> STOP [stop-code] [, QUIET = scalar-logical-expr]
2327 // R1161 error-stop-stmt ->
2328 // ERROR STOP [stop-code] [, QUIET = scalar-logical-expr]
2329 TYPE_CONTEXT_PARSER("STOP statement"_en_US,
2330 construct<StopStmt>("STOP" >> pure(StopStmt::Kind::Stop) ||
2331 "ERROR STOP"_sptok >> pure(StopStmt::Kind::ErrorStop),
2332 maybe(Parser<StopCode>{}), maybe(", QUIET =" >> scalarLogicalExpr)))
2333
2334 // R1162 stop-code -> scalar-default-char-expr | scalar-int-expr
2335 // The two alternatives for stop-code can't be distinguished at
2336 // parse time.
TYPE_PARSER(construct<StopCode> (scalar (expr)))2337 TYPE_PARSER(construct<StopCode>(scalar(expr)))
2338
2339 // R1164 sync-all-stmt -> SYNC ALL [( [sync-stat-list] )]
2340 TYPE_CONTEXT_PARSER("SYNC ALL statement"_en_US,
2341 construct<SyncAllStmt>("SYNC ALL"_sptok >>
2342 defaulted(parenthesized(optionalList(statOrErrmsg)))))
2343
2344 // R1166 sync-images-stmt -> SYNC IMAGES ( image-set [, sync-stat-list] )
2345 // R1167 image-set -> int-expr | *
2346 TYPE_CONTEXT_PARSER("SYNC IMAGES statement"_en_US,
2347 "SYNC IMAGES"_sptok >> parenthesized(construct<SyncImagesStmt>(
2348 construct<SyncImagesStmt::ImageSet>(intExpr) ||
2349 construct<SyncImagesStmt::ImageSet>(star),
2350 defaulted("," >> nonemptyList(statOrErrmsg)))))
2351
2352 // R1168 sync-memory-stmt -> SYNC MEMORY [( [sync-stat-list] )]
2353 TYPE_CONTEXT_PARSER("SYNC MEMORY statement"_en_US,
2354 construct<SyncMemoryStmt>("SYNC MEMORY"_sptok >>
2355 defaulted(parenthesized(optionalList(statOrErrmsg)))))
2356
2357 // R1169 sync-team-stmt -> SYNC TEAM ( team-value [, sync-stat-list] )
2358 TYPE_CONTEXT_PARSER("SYNC TEAM statement"_en_US,
2359 construct<SyncTeamStmt>("SYNC TEAM"_sptok >> "("_tok >> teamValue,
2360 defaulted("," >> nonemptyList(statOrErrmsg)) / ")"))
2361
2362 // R1170 event-post-stmt -> EVENT POST ( event-variable [, sync-stat-list] )
2363 // R1171 event-variable -> scalar-variable
2364 TYPE_CONTEXT_PARSER("EVENT POST statement"_en_US,
2365 construct<EventPostStmt>("EVENT POST"_sptok >> "("_tok >> scalar(variable),
2366 defaulted("," >> nonemptyList(statOrErrmsg)) / ")"))
2367
2368 // R1172 event-wait-stmt ->
2369 // EVENT WAIT ( event-variable [, event-wait-spec-list] )
2370 TYPE_CONTEXT_PARSER("EVENT WAIT statement"_en_US,
2371 construct<EventWaitStmt>("EVENT WAIT"_sptok >> "("_tok >> scalar(variable),
2372 defaulted("," >> nonemptyList(Parser<EventWaitStmt::EventWaitSpec>{})) /
2373 ")"))
2374
2375 // R1174 until-spec -> UNTIL_COUNT = scalar-int-expr
2376 constexpr auto untilSpec{"UNTIL_COUNT =" >> scalarIntExpr};
2377
2378 // R1173 event-wait-spec -> until-spec | sync-stat
2379 TYPE_PARSER(construct<EventWaitStmt::EventWaitSpec>(untilSpec) ||
2380 construct<EventWaitStmt::EventWaitSpec>(statOrErrmsg))
2381
2382 // R1177 team-variable -> scalar-variable
2383 constexpr auto teamVariable{scalar(variable)};
2384
2385 // R1175 form-team-stmt ->
2386 // FORM TEAM ( team-number , team-variable [, form-team-spec-list] )
2387 // R1176 team-number -> scalar-int-expr
2388 TYPE_CONTEXT_PARSER("FORM TEAM statement"_en_US,
2389 construct<FormTeamStmt>("FORM TEAM"_sptok >> "("_tok >> scalarIntExpr,
2390 "," >> teamVariable,
2391 defaulted("," >> nonemptyList(Parser<FormTeamStmt::FormTeamSpec>{})) /
2392 ")"))
2393
2394 // R1178 form-team-spec -> NEW_INDEX = scalar-int-expr | sync-stat
2395 TYPE_PARSER(
2396 construct<FormTeamStmt::FormTeamSpec>("NEW_INDEX =" >> scalarIntExpr) ||
2397 construct<FormTeamStmt::FormTeamSpec>(statOrErrmsg))
2398
2399 // R1182 lock-variable -> scalar-variable
2400 constexpr auto lockVariable{scalar(variable)};
2401
2402 // R1179 lock-stmt -> LOCK ( lock-variable [, lock-stat-list] )
2403 TYPE_CONTEXT_PARSER("LOCK statement"_en_US,
2404 construct<LockStmt>("LOCK (" >> lockVariable,
2405 defaulted("," >> nonemptyList(Parser<LockStmt::LockStat>{})) / ")"))
2406
2407 // R1180 lock-stat -> ACQUIRED_LOCK = scalar-logical-variable | sync-stat
2408 TYPE_PARSER(
2409 construct<LockStmt::LockStat>("ACQUIRED_LOCK =" >> scalarLogicalVariable) ||
2410 construct<LockStmt::LockStat>(statOrErrmsg))
2411
2412 // R1181 unlock-stmt -> UNLOCK ( lock-variable [, sync-stat-list] )
2413 TYPE_CONTEXT_PARSER("UNLOCK statement"_en_US,
2414 construct<UnlockStmt>("UNLOCK (" >> lockVariable,
2415 defaulted("," >> nonemptyList(statOrErrmsg)) / ")"))
2416
2417 // R1201 io-unit -> file-unit-number | * | internal-file-variable
2418 // R1203 internal-file-variable -> char-variable
2419 // R905 char-variable -> variable
2420 // "char-variable" is attempted first since it's not type constrained but
2421 // syntactically ambiguous with "file-unit-number", which is constrained.
2422 TYPE_PARSER(construct<IoUnit>(variable / !"="_tok) ||
2423 construct<IoUnit>(fileUnitNumber) || construct<IoUnit>(star))
2424
2425 // R1202 file-unit-number -> scalar-int-expr
2426 TYPE_PARSER(construct<FileUnitNumber>(scalarIntExpr / !"="_tok))
2427
2428 // R1204 open-stmt -> OPEN ( connect-spec-list )
2429 TYPE_CONTEXT_PARSER("OPEN statement"_en_US,
2430 construct<OpenStmt>(
2431 "OPEN (" >> nonemptyList("expected connection specifications"_err_en_US,
2432 Parser<ConnectSpec>{}) /
2433 ")"))
2434
2435 // R1206 file-name-expr -> scalar-default-char-expr
2436 constexpr auto fileNameExpr{scalarDefaultCharExpr};
2437
2438 // R1205 connect-spec ->
2439 // [UNIT =] file-unit-number | ACCESS = scalar-default-char-expr |
2440 // ACTION = scalar-default-char-expr |
2441 // ASYNCHRONOUS = scalar-default-char-expr |
2442 // BLANK = scalar-default-char-expr |
2443 // DECIMAL = scalar-default-char-expr |
2444 // DELIM = scalar-default-char-expr |
2445 // ENCODING = scalar-default-char-expr | ERR = label |
2446 // FILE = file-name-expr | FORM = scalar-default-char-expr |
2447 // IOMSG = iomsg-variable | IOSTAT = scalar-int-variable |
2448 // NEWUNIT = scalar-int-variable | PAD = scalar-default-char-expr |
2449 // POSITION = scalar-default-char-expr | RECL = scalar-int-expr |
2450 // ROUND = scalar-default-char-expr | SIGN = scalar-default-char-expr |
2451 // STATUS = scalar-default-char-expr
2452 // @ | CONVERT = scalar-default-char-variable
2453 // @ | DISPOSE = scalar-default-char-variable
2454 constexpr auto statusExpr{construct<StatusExpr>(scalarDefaultCharExpr)};
2455 constexpr auto errLabel{construct<ErrLabel>(label)};
2456
2457 TYPE_PARSER(first(construct<ConnectSpec>(maybe("UNIT ="_tok) >> fileUnitNumber),
2458 construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
2459 "ACCESS =" >> pure(ConnectSpec::CharExpr::Kind::Access),
2460 scalarDefaultCharExpr)),
2461 construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
2462 "ACTION =" >> pure(ConnectSpec::CharExpr::Kind::Action),
2463 scalarDefaultCharExpr)),
2464 construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
2465 "ASYNCHRONOUS =" >> pure(ConnectSpec::CharExpr::Kind::Asynchronous),
2466 scalarDefaultCharExpr)),
2467 construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
2468 "BLANK =" >> pure(ConnectSpec::CharExpr::Kind::Blank),
2469 scalarDefaultCharExpr)),
2470 construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
2471 "DECIMAL =" >> pure(ConnectSpec::CharExpr::Kind::Decimal),
2472 scalarDefaultCharExpr)),
2473 construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
2474 "DELIM =" >> pure(ConnectSpec::CharExpr::Kind::Delim),
2475 scalarDefaultCharExpr)),
2476 construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
2477 "ENCODING =" >> pure(ConnectSpec::CharExpr::Kind::Encoding),
2478 scalarDefaultCharExpr)),
2479 construct<ConnectSpec>("ERR =" >> errLabel),
2480 construct<ConnectSpec>("FILE =" >> fileNameExpr),
2481 extension<LanguageFeature::FileName>(
2482 construct<ConnectSpec>("NAME =" >> fileNameExpr)),
2483 construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
2484 "FORM =" >> pure(ConnectSpec::CharExpr::Kind::Form),
2485 scalarDefaultCharExpr)),
2486 construct<ConnectSpec>("IOMSG =" >> msgVariable),
2487 construct<ConnectSpec>("IOSTAT =" >> statVariable),
2488 construct<ConnectSpec>(construct<ConnectSpec::Newunit>(
2489 "NEWUNIT =" >> scalar(integer(variable)))),
2490 construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
2491 "PAD =" >> pure(ConnectSpec::CharExpr::Kind::Pad),
2492 scalarDefaultCharExpr)),
2493 construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
2494 "POSITION =" >> pure(ConnectSpec::CharExpr::Kind::Position),
2495 scalarDefaultCharExpr)),
2496 construct<ConnectSpec>(
2497 construct<ConnectSpec::Recl>("RECL =" >> scalarIntExpr)),
2498 construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
2499 "ROUND =" >> pure(ConnectSpec::CharExpr::Kind::Round),
2500 scalarDefaultCharExpr)),
2501 construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
2502 "SIGN =" >> pure(ConnectSpec::CharExpr::Kind::Sign),
2503 scalarDefaultCharExpr)),
2504 construct<ConnectSpec>("STATUS =" >> statusExpr),
2505 extension<LanguageFeature::Convert>(
2506 construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
2507 "CONVERT =" >> pure(ConnectSpec::CharExpr::Kind::Convert),
2508 scalarDefaultCharExpr))),
2509 extension<LanguageFeature::Dispose>(
2510 construct<ConnectSpec>(construct<ConnectSpec::CharExpr>(
2511 "DISPOSE =" >> pure(ConnectSpec::CharExpr::Kind::Dispose),
2512 scalarDefaultCharExpr)))))
2513
2514 // R1209 close-spec ->
2515 // [UNIT =] file-unit-number | IOSTAT = scalar-int-variable |
2516 // IOMSG = iomsg-variable | ERR = label |
2517 // STATUS = scalar-default-char-expr
2518 constexpr auto closeSpec{first(
2519 construct<CloseStmt::CloseSpec>(maybe("UNIT ="_tok) >> fileUnitNumber),
2520 construct<CloseStmt::CloseSpec>("IOSTAT =" >> statVariable),
2521 construct<CloseStmt::CloseSpec>("IOMSG =" >> msgVariable),
2522 construct<CloseStmt::CloseSpec>("ERR =" >> errLabel),
2523 construct<CloseStmt::CloseSpec>("STATUS =" >> statusExpr))};
2524
2525 // R1208 close-stmt -> CLOSE ( close-spec-list )
2526 TYPE_CONTEXT_PARSER("CLOSE statement"_en_US,
2527 construct<CloseStmt>("CLOSE" >> parenthesized(nonemptyList(closeSpec))))
2528
2529 // R1210 read-stmt ->
2530 // READ ( io-control-spec-list ) [input-item-list] |
2531 // READ format [, input-item-list]
2532 constexpr auto inputItemList{
2533 extension<LanguageFeature::IOListLeadingComma>(
2534 some("," >> inputItem)) || // legacy extension: leading comma
2535 optionalList(inputItem)};
2536
2537 TYPE_CONTEXT_PARSER("READ statement"_en_US,
2538 construct<ReadStmt>("READ (" >>
2539 construct<std::optional<IoUnit>>(maybe("UNIT ="_tok) >> ioUnit),
2540 "," >> construct<std::optional<Format>>(format),
2541 defaulted("," >> nonemptyList(ioControlSpec)) / ")", inputItemList) ||
2542 construct<ReadStmt>(
2543 "READ (" >> construct<std::optional<IoUnit>>(ioUnit),
2544 construct<std::optional<Format>>(),
2545 defaulted("," >> nonemptyList(ioControlSpec)) / ")",
2546 inputItemList) ||
2547 construct<ReadStmt>("READ" >> construct<std::optional<IoUnit>>(),
2548 construct<std::optional<Format>>(),
2549 parenthesized(nonemptyList(ioControlSpec)), inputItemList) ||
2550 construct<ReadStmt>("READ" >> construct<std::optional<IoUnit>>(),
2551 construct<std::optional<Format>>(format),
2552 construct<std::list<IoControlSpec>>(), many("," >> inputItem)))
2553
2554 // R1214 id-variable -> scalar-int-variable
2555 constexpr auto idVariable{construct<IdVariable>(scalarIntVariable)};
2556
2557 // R1213 io-control-spec ->
2558 // [UNIT =] io-unit | [FMT =] format | [NML =] namelist-group-name |
2559 // ADVANCE = scalar-default-char-expr |
2560 // ASYNCHRONOUS = scalar-default-char-constant-expr |
2561 // BLANK = scalar-default-char-expr |
2562 // DECIMAL = scalar-default-char-expr |
2563 // DELIM = scalar-default-char-expr | END = label | EOR = label |
2564 // ERR = label | ID = id-variable | IOMSG = iomsg-variable |
2565 // IOSTAT = scalar-int-variable | PAD = scalar-default-char-expr |
2566 // POS = scalar-int-expr | REC = scalar-int-expr |
2567 // ROUND = scalar-default-char-expr | SIGN = scalar-default-char-expr |
2568 // SIZE = scalar-int-variable
2569 constexpr auto endLabel{construct<EndLabel>(label)};
2570 constexpr auto eorLabel{construct<EorLabel>(label)};
2571 TYPE_PARSER(first(construct<IoControlSpec>("UNIT =" >> ioUnit),
2572 construct<IoControlSpec>("FMT =" >> format),
2573 construct<IoControlSpec>("NML =" >> name),
2574 construct<IoControlSpec>(
2575 "ADVANCE =" >> construct<IoControlSpec::CharExpr>(
2576 pure(IoControlSpec::CharExpr::Kind::Advance),
2577 scalarDefaultCharExpr)),
2578 construct<IoControlSpec>(construct<IoControlSpec::Asynchronous>(
2579 "ASYNCHRONOUS =" >> scalarDefaultCharConstantExpr)),
2580 construct<IoControlSpec>("BLANK =" >>
2581 construct<IoControlSpec::CharExpr>(
2582 pure(IoControlSpec::CharExpr::Kind::Blank), scalarDefaultCharExpr)),
2583 construct<IoControlSpec>(
2584 "DECIMAL =" >> construct<IoControlSpec::CharExpr>(
2585 pure(IoControlSpec::CharExpr::Kind::Decimal),
2586 scalarDefaultCharExpr)),
2587 construct<IoControlSpec>("DELIM =" >>
2588 construct<IoControlSpec::CharExpr>(
2589 pure(IoControlSpec::CharExpr::Kind::Delim), scalarDefaultCharExpr)),
2590 construct<IoControlSpec>("END =" >> endLabel),
2591 construct<IoControlSpec>("EOR =" >> eorLabel),
2592 construct<IoControlSpec>("ERR =" >> errLabel),
2593 construct<IoControlSpec>("ID =" >> idVariable),
2594 construct<IoControlSpec>("IOMSG = " >> msgVariable),
2595 construct<IoControlSpec>("IOSTAT = " >> statVariable),
2596 construct<IoControlSpec>("PAD =" >>
2597 construct<IoControlSpec::CharExpr>(
2598 pure(IoControlSpec::CharExpr::Kind::Pad), scalarDefaultCharExpr)),
2599 construct<IoControlSpec>(
2600 "POS =" >> construct<IoControlSpec::Pos>(scalarIntExpr)),
2601 construct<IoControlSpec>(
2602 "REC =" >> construct<IoControlSpec::Rec>(scalarIntExpr)),
2603 construct<IoControlSpec>("ROUND =" >>
2604 construct<IoControlSpec::CharExpr>(
2605 pure(IoControlSpec::CharExpr::Kind::Round), scalarDefaultCharExpr)),
2606 construct<IoControlSpec>("SIGN =" >>
2607 construct<IoControlSpec::CharExpr>(
2608 pure(IoControlSpec::CharExpr::Kind::Sign), scalarDefaultCharExpr)),
2609 construct<IoControlSpec>(
2610 "SIZE =" >> construct<IoControlSpec::Size>(scalarIntVariable))))
2611
2612 // R1211 write-stmt -> WRITE ( io-control-spec-list ) [output-item-list]
2613 constexpr auto outputItemList{
2614 extension<LanguageFeature::IOListLeadingComma>(
2615 some("," >> outputItem)) || // legacy: allow leading comma
2616 optionalList(outputItem)};
2617
2618 TYPE_CONTEXT_PARSER("WRITE statement"_en_US,
2619 construct<WriteStmt>("WRITE (" >>
2620 construct<std::optional<IoUnit>>(maybe("UNIT ="_tok) >> ioUnit),
2621 "," >> construct<std::optional<Format>>(format),
2622 defaulted("," >> nonemptyList(ioControlSpec)) / ")", outputItemList) ||
2623 construct<WriteStmt>(
2624 "WRITE (" >> construct<std::optional<IoUnit>>(ioUnit),
2625 construct<std::optional<Format>>(),
2626 defaulted("," >> nonemptyList(ioControlSpec)) / ")",
2627 outputItemList) ||
2628 construct<WriteStmt>("WRITE" >> construct<std::optional<IoUnit>>(),
2629 construct<std::optional<Format>>(),
2630 parenthesized(nonemptyList(ioControlSpec)), outputItemList))
2631
2632 // R1212 print-stmt PRINT format [, output-item-list]
2633 TYPE_CONTEXT_PARSER("PRINT statement"_en_US,
2634 construct<PrintStmt>(
2635 "PRINT" >> format, defaulted("," >> nonemptyList(outputItem))))
2636
2637 // R1215 format -> default-char-expr | label | *
2638 TYPE_PARSER(construct<Format>(label / !"_."_ch) ||
2639 construct<Format>(defaultCharExpr / !"="_tok) || construct<Format>(star))
2640
2641 // R1216 input-item -> variable | io-implied-do
2642 TYPE_PARSER(construct<InputItem>(variable) ||
2643 construct<InputItem>(indirect(inputImpliedDo)))
2644
2645 // R1217 output-item -> expr | io-implied-do
2646 TYPE_PARSER(construct<OutputItem>(expr) ||
2647 construct<OutputItem>(indirect(outputImpliedDo)))
2648
2649 // R1220 io-implied-do-control ->
2650 // do-variable = scalar-int-expr , scalar-int-expr [, scalar-int-expr]
2651 constexpr auto ioImpliedDoControl{loopBounds(scalarIntExpr)};
2652
2653 // R1218 io-implied-do -> ( io-implied-do-object-list , io-implied-do-control )
2654 // R1219 io-implied-do-object -> input-item | output-item
2655 TYPE_CONTEXT_PARSER("input implied DO"_en_US,
2656 parenthesized(
2657 construct<InputImpliedDo>(nonemptyList(inputItem / lookAhead(","_tok)),
2658 "," >> ioImpliedDoControl)))
2659 TYPE_CONTEXT_PARSER("output implied DO"_en_US,
2660 parenthesized(construct<OutputImpliedDo>(
2661 nonemptyList(outputItem / lookAhead(","_tok)),
2662 "," >> ioImpliedDoControl)))
2663
2664 // R1222 wait-stmt -> WAIT ( wait-spec-list )
2665 TYPE_CONTEXT_PARSER("WAIT statement"_en_US,
2666 "WAIT" >>
2667 parenthesized(construct<WaitStmt>(nonemptyList(Parser<WaitSpec>{}))))
2668
2669 // R1223 wait-spec ->
2670 // [UNIT =] file-unit-number | END = label | EOR = label | ERR = label |
2671 // ID = scalar-int-expr | IOMSG = iomsg-variable |
2672 // IOSTAT = scalar-int-variable
2673 constexpr auto idExpr{construct<IdExpr>(scalarIntExpr)};
2674
2675 TYPE_PARSER(first(construct<WaitSpec>(maybe("UNIT ="_tok) >> fileUnitNumber),
2676 construct<WaitSpec>("END =" >> endLabel),
2677 construct<WaitSpec>("EOR =" >> eorLabel),
2678 construct<WaitSpec>("ERR =" >> errLabel),
2679 construct<WaitSpec>("ID =" >> idExpr),
2680 construct<WaitSpec>("IOMSG =" >> msgVariable),
2681 construct<WaitSpec>("IOSTAT =" >> statVariable)))
2682
singletonList(A && x)2683 template<typename A> common::IfNoLvalue<std::list<A>, A> singletonList(A &&x) {
2684 std::list<A> result;
2685 result.push_front(std::move(x));
2686 return result;
2687 }
2688 constexpr auto bareUnitNumberAsList{
2689 applyFunction(singletonList<PositionOrFlushSpec>,
2690 construct<PositionOrFlushSpec>(fileUnitNumber))};
2691 constexpr auto positionOrFlushSpecList{
2692 parenthesized(nonemptyList(positionOrFlushSpec)) || bareUnitNumberAsList};
2693
2694 // R1224 backspace-stmt ->
2695 // BACKSPACE file-unit-number | BACKSPACE ( position-spec-list )
2696 TYPE_CONTEXT_PARSER("BACKSPACE statement"_en_US,
2697 construct<BackspaceStmt>("BACKSPACE" >> positionOrFlushSpecList))
2698
2699 // R1225 endfile-stmt ->
2700 // ENDFILE file-unit-number | ENDFILE ( position-spec-list )
2701 TYPE_CONTEXT_PARSER("ENDFILE statement"_en_US,
2702 construct<EndfileStmt>("ENDFILE" >> positionOrFlushSpecList))
2703
2704 // R1226 rewind-stmt -> REWIND file-unit-number | REWIND ( position-spec-list )
2705 TYPE_CONTEXT_PARSER("REWIND statement"_en_US,
2706 construct<RewindStmt>("REWIND" >> positionOrFlushSpecList))
2707
2708 // R1227 position-spec ->
2709 // [UNIT =] file-unit-number | IOMSG = iomsg-variable |
2710 // IOSTAT = scalar-int-variable | ERR = label
2711 // R1229 flush-spec ->
2712 // [UNIT =] file-unit-number | IOSTAT = scalar-int-variable |
2713 // IOMSG = iomsg-variable | ERR = label
2714 TYPE_PARSER(
2715 construct<PositionOrFlushSpec>(maybe("UNIT ="_tok) >> fileUnitNumber) ||
2716 construct<PositionOrFlushSpec>("IOMSG =" >> msgVariable) ||
2717 construct<PositionOrFlushSpec>("IOSTAT =" >> statVariable) ||
2718 construct<PositionOrFlushSpec>("ERR =" >> errLabel))
2719
2720 // R1228 flush-stmt -> FLUSH file-unit-number | FLUSH ( flush-spec-list )
2721 TYPE_CONTEXT_PARSER("FLUSH statement"_en_US,
2722 construct<FlushStmt>("FLUSH" >> positionOrFlushSpecList))
2723
2724 // R1231 inquire-spec ->
2725 // [UNIT =] file-unit-number | FILE = file-name-expr |
2726 // ACCESS = scalar-default-char-variable |
2727 // ACTION = scalar-default-char-variable |
2728 // ASYNCHRONOUS = scalar-default-char-variable |
2729 // BLANK = scalar-default-char-variable |
2730 // DECIMAL = scalar-default-char-variable |
2731 // DELIM = scalar-default-char-variable |
2732 // ENCODING = scalar-default-char-variable |
2733 // ERR = label | EXIST = scalar-logical-variable |
2734 // FORM = scalar-default-char-variable |
2735 // FORMATTED = scalar-default-char-variable |
2736 // ID = scalar-int-expr | IOMSG = iomsg-variable |
2737 // IOSTAT = scalar-int-variable |
2738 // NAME = scalar-default-char-variable |
2739 // NAMED = scalar-logical-variable |
2740 // NEXTREC = scalar-int-variable | NUMBER = scalar-int-variable |
2741 // OPENED = scalar-logical-variable |
2742 // PAD = scalar-default-char-variable |
2743 // PENDING = scalar-logical-variable | POS = scalar-int-variable |
2744 // POSITION = scalar-default-char-variable |
2745 // READ = scalar-default-char-variable |
2746 // READWRITE = scalar-default-char-variable |
2747 // RECL = scalar-int-variable | ROUND = scalar-default-char-variable |
2748 // SEQUENTIAL = scalar-default-char-variable |
2749 // SIGN = scalar-default-char-variable |
2750 // SIZE = scalar-int-variable |
2751 // STREAM = scalar-default-char-variable |
2752 // STATUS = scalar-default-char-variable |
2753 // WRITE = scalar-default-char-variable
2754 // @ | CONVERT = scalar-default-char-variable
2755 // | DISPOSE = scalar-default-char-variable
2756 TYPE_PARSER(first(construct<InquireSpec>(maybe("UNIT ="_tok) >> fileUnitNumber),
2757 construct<InquireSpec>("FILE =" >> fileNameExpr),
2758 construct<InquireSpec>(
2759 "ACCESS =" >> construct<InquireSpec::CharVar>(
2760 pure(InquireSpec::CharVar::Kind::Access),
2761 scalarDefaultCharVariable)),
2762 construct<InquireSpec>(
2763 "ACTION =" >> construct<InquireSpec::CharVar>(
2764 pure(InquireSpec::CharVar::Kind::Action),
2765 scalarDefaultCharVariable)),
2766 construct<InquireSpec>(
2767 "ASYNCHRONOUS =" >> construct<InquireSpec::CharVar>(
2768 pure(InquireSpec::CharVar::Kind::Asynchronous),
2769 scalarDefaultCharVariable)),
2770 construct<InquireSpec>("BLANK =" >>
2771 construct<InquireSpec::CharVar>(pure(InquireSpec::CharVar::Kind::Blank),
2772 scalarDefaultCharVariable)),
2773 construct<InquireSpec>(
2774 "DECIMAL =" >> construct<InquireSpec::CharVar>(
2775 pure(InquireSpec::CharVar::Kind::Decimal),
2776 scalarDefaultCharVariable)),
2777 construct<InquireSpec>("DELIM =" >>
2778 construct<InquireSpec::CharVar>(pure(InquireSpec::CharVar::Kind::Delim),
2779 scalarDefaultCharVariable)),
2780 construct<InquireSpec>(
2781 "DIRECT =" >> construct<InquireSpec::CharVar>(
2782 pure(InquireSpec::CharVar::Kind::Direct),
2783 scalarDefaultCharVariable)),
2784 construct<InquireSpec>(
2785 "ENCODING =" >> construct<InquireSpec::CharVar>(
2786 pure(InquireSpec::CharVar::Kind::Encoding),
2787 scalarDefaultCharVariable)),
2788 construct<InquireSpec>("ERR =" >> errLabel),
2789 construct<InquireSpec>("EXIST =" >>
2790 construct<InquireSpec::LogVar>(
2791 pure(InquireSpec::LogVar::Kind::Exist), scalarLogicalVariable)),
2792 construct<InquireSpec>("FORM =" >>
2793 construct<InquireSpec::CharVar>(
2794 pure(InquireSpec::CharVar::Kind::Form), scalarDefaultCharVariable)),
2795 construct<InquireSpec>(
2796 "FORMATTED =" >> construct<InquireSpec::CharVar>(
2797 pure(InquireSpec::CharVar::Kind::Formatted),
2798 scalarDefaultCharVariable)),
2799 construct<InquireSpec>("ID =" >> idExpr),
2800 construct<InquireSpec>("IOMSG =" >>
2801 construct<InquireSpec::CharVar>(pure(InquireSpec::CharVar::Kind::Iomsg),
2802 scalarDefaultCharVariable)),
2803 construct<InquireSpec>("IOSTAT =" >>
2804 construct<InquireSpec::IntVar>(pure(InquireSpec::IntVar::Kind::Iostat),
2805 scalar(integer(variable)))),
2806 construct<InquireSpec>("NAME =" >>
2807 construct<InquireSpec::CharVar>(
2808 pure(InquireSpec::CharVar::Kind::Name), scalarDefaultCharVariable)),
2809 construct<InquireSpec>("NAMED =" >>
2810 construct<InquireSpec::LogVar>(
2811 pure(InquireSpec::LogVar::Kind::Named), scalarLogicalVariable)),
2812 construct<InquireSpec>("NEXTREC =" >>
2813 construct<InquireSpec::IntVar>(pure(InquireSpec::IntVar::Kind::Nextrec),
2814 scalar(integer(variable)))),
2815 construct<InquireSpec>("NUMBER =" >>
2816 construct<InquireSpec::IntVar>(pure(InquireSpec::IntVar::Kind::Number),
2817 scalar(integer(variable)))),
2818 construct<InquireSpec>("OPENED =" >>
2819 construct<InquireSpec::LogVar>(
2820 pure(InquireSpec::LogVar::Kind::Opened), scalarLogicalVariable)),
2821 construct<InquireSpec>("PAD =" >>
2822 construct<InquireSpec::CharVar>(
2823 pure(InquireSpec::CharVar::Kind::Pad), scalarDefaultCharVariable)),
2824 construct<InquireSpec>("PENDING =" >>
2825 construct<InquireSpec::LogVar>(
2826 pure(InquireSpec::LogVar::Kind::Pending), scalarLogicalVariable)),
2827 construct<InquireSpec>("POS =" >>
2828 construct<InquireSpec::IntVar>(
2829 pure(InquireSpec::IntVar::Kind::Pos), scalar(integer(variable)))),
2830 construct<InquireSpec>(
2831 "POSITION =" >> construct<InquireSpec::CharVar>(
2832 pure(InquireSpec::CharVar::Kind::Position),
2833 scalarDefaultCharVariable)),
2834 construct<InquireSpec>("READ =" >>
2835 construct<InquireSpec::CharVar>(
2836 pure(InquireSpec::CharVar::Kind::Read), scalarDefaultCharVariable)),
2837 construct<InquireSpec>(
2838 "READWRITE =" >> construct<InquireSpec::CharVar>(
2839 pure(InquireSpec::CharVar::Kind::Readwrite),
2840 scalarDefaultCharVariable)),
2841 construct<InquireSpec>("RECL =" >>
2842 construct<InquireSpec::IntVar>(
2843 pure(InquireSpec::IntVar::Kind::Recl), scalar(integer(variable)))),
2844 construct<InquireSpec>("ROUND =" >>
2845 construct<InquireSpec::CharVar>(pure(InquireSpec::CharVar::Kind::Round),
2846 scalarDefaultCharVariable)),
2847 construct<InquireSpec>(
2848 "SEQUENTIAL =" >> construct<InquireSpec::CharVar>(
2849 pure(InquireSpec::CharVar::Kind::Sequential),
2850 scalarDefaultCharVariable)),
2851 construct<InquireSpec>("SIGN =" >>
2852 construct<InquireSpec::CharVar>(
2853 pure(InquireSpec::CharVar::Kind::Sign), scalarDefaultCharVariable)),
2854 construct<InquireSpec>("SIZE =" >>
2855 construct<InquireSpec::IntVar>(
2856 pure(InquireSpec::IntVar::Kind::Size), scalar(integer(variable)))),
2857 construct<InquireSpec>(
2858 "STREAM =" >> construct<InquireSpec::CharVar>(
2859 pure(InquireSpec::CharVar::Kind::Stream),
2860 scalarDefaultCharVariable)),
2861 construct<InquireSpec>(
2862 "STATUS =" >> construct<InquireSpec::CharVar>(
2863 pure(InquireSpec::CharVar::Kind::Status),
2864 scalarDefaultCharVariable)),
2865 construct<InquireSpec>(
2866 "UNFORMATTED =" >> construct<InquireSpec::CharVar>(
2867 pure(InquireSpec::CharVar::Kind::Unformatted),
2868 scalarDefaultCharVariable)),
2869 construct<InquireSpec>("WRITE =" >>
2870 construct<InquireSpec::CharVar>(pure(InquireSpec::CharVar::Kind::Write),
2871 scalarDefaultCharVariable)),
2872 extension<LanguageFeature::Convert>(construct<InquireSpec>(
2873 "CONVERT =" >> construct<InquireSpec::CharVar>(
2874 pure(InquireSpec::CharVar::Kind::Convert),
2875 scalarDefaultCharVariable))),
2876 extension<LanguageFeature::Dispose>(construct<InquireSpec>(
2877 "DISPOSE =" >> construct<InquireSpec::CharVar>(
2878 pure(InquireSpec::CharVar::Kind::Dispose),
2879 scalarDefaultCharVariable)))))
2880
2881 // R1230 inquire-stmt ->
2882 // INQUIRE ( inquire-spec-list ) |
2883 // INQUIRE ( IOLENGTH = scalar-int-variable ) output-item-list
2884 TYPE_CONTEXT_PARSER("INQUIRE statement"_en_US,
2885 "INQUIRE" >>
2886 (construct<InquireStmt>(
2887 parenthesized(nonemptyList(Parser<InquireSpec>{}))) ||
2888 construct<InquireStmt>(construct<InquireStmt::Iolength>(
2889 parenthesized("IOLENGTH =" >> scalar(integer(variable))),
2890 nonemptyList(outputItem)))))
2891
2892 // R1301 format-stmt -> FORMAT format-specification
2893 // 13.2.1 allows spaces to appear "at any point" within a format specification
2894 // without effect, except of course within a character string edit descriptor.
2895 TYPE_CONTEXT_PARSER("FORMAT statement"_en_US,
2896 construct<FormatStmt>("FORMAT" >> Parser<format::FormatSpecification>{}))
2897
2898 // R1321 char-string-edit-desc
2899 // N.B. C1313 disallows any kind parameter on the character literal.
2900 constexpr auto charStringEditDesc{
2901 space >> (charLiteralConstantWithoutKind || rawHollerithLiteral)};
2902
2903 // R1303 format-items -> format-item [[,] format-item]...
2904 constexpr auto formatItems{
2905 nonemptySeparated(space >> Parser<format::FormatItem>{}, maybe(","_tok))};
2906
2907 // R1306 r -> digit-string
2908 constexpr DigitStringIgnoreSpaces repeat;
2909
2910 // R1304 format-item ->
2911 // [r] data-edit-desc | control-edit-desc | char-string-edit-desc |
2912 // [r] ( format-items )
2913 TYPE_PARSER(construct<format::FormatItem>(
2914 maybe(repeat), Parser<format::IntrinsicTypeDataEditDesc>{}) ||
2915 construct<format::FormatItem>(
2916 maybe(repeat), Parser<format::DerivedTypeDataEditDesc>{}) ||
2917 construct<format::FormatItem>(Parser<format::ControlEditDesc>{}) ||
2918 construct<format::FormatItem>(charStringEditDesc) ||
2919 construct<format::FormatItem>(maybe(repeat), parenthesized(formatItems)))
2920
2921 // R1302 format-specification ->
2922 // ( [format-items] ) | ( [format-items ,] unlimited-format-item )
2923 // R1305 unlimited-format-item -> * ( format-items )
2924 // minor extension: the comma is optional before the unlimited-format-item
2925 TYPE_PARSER(parenthesized(construct<format::FormatSpecification>(
2926 defaulted(formatItems / maybe(","_tok)),
2927 "*" >> parenthesized(formatItems)) ||
2928 construct<format::FormatSpecification>(defaulted(formatItems))))
2929 // R1308 w -> digit-string
2930 // R1309 m -> digit-string
2931 // R1310 d -> digit-string
2932 // R1311 e -> digit-string
2933 constexpr auto width{repeat};
2934 constexpr auto mandatoryWidth{construct<std::optional<int>>(width)};
2935 constexpr auto digits{repeat};
2936 constexpr auto noInt{construct<std::optional<int>>()};
2937 constexpr auto mandatoryDigits{construct<std::optional<int>>("." >> width)};
2938
2939 // R1307 data-edit-desc ->
2940 // I w [. m] | B w [. m] | O w [. m] | Z w [. m] | F w . d |
2941 // E w . d [E e] | EN w . d [E e] | ES w . d [E e] | EX w . d [E e] |
2942 // G w [. d [E e]] | L w | A [w] | D w . d |
2943 // DT [char-literal-constant] [( v-list )]
2944 // (part 1 of 2)
2945 TYPE_PARSER(construct<format::IntrinsicTypeDataEditDesc>(
2946 "I" >> pure(format::IntrinsicTypeDataEditDesc::Kind::I) ||
2947 "B" >> pure(format::IntrinsicTypeDataEditDesc::Kind::B) ||
2948 "O" >> pure(format::IntrinsicTypeDataEditDesc::Kind::O) ||
2949 "Z" >> pure(format::IntrinsicTypeDataEditDesc::Kind::Z),
2950 mandatoryWidth, maybe("." >> digits), noInt) ||
2951 construct<format::IntrinsicTypeDataEditDesc>(
2952 "F" >> pure(format::IntrinsicTypeDataEditDesc::Kind::F) ||
2953 "D" >> pure(format::IntrinsicTypeDataEditDesc::Kind::D),
2954 mandatoryWidth, mandatoryDigits, noInt) ||
2955 construct<format::IntrinsicTypeDataEditDesc>(
2956 "E" >> ("N" >> pure(format::IntrinsicTypeDataEditDesc::Kind::EN) ||
2957 "S" >> pure(format::IntrinsicTypeDataEditDesc::Kind::ES) ||
2958 "X" >> pure(format::IntrinsicTypeDataEditDesc::Kind::EX) ||
2959 pure(format::IntrinsicTypeDataEditDesc::Kind::E)),
2960 mandatoryWidth, mandatoryDigits, maybe("E" >> digits)) ||
2961 construct<format::IntrinsicTypeDataEditDesc>(
2962 "G" >> pure(format::IntrinsicTypeDataEditDesc::Kind::G), mandatoryWidth,
2963 mandatoryDigits, maybe("E" >> digits)) ||
2964 construct<format::IntrinsicTypeDataEditDesc>(
2965 "G" >> pure(format::IntrinsicTypeDataEditDesc::Kind::G) ||
2966 "L" >> pure(format::IntrinsicTypeDataEditDesc::Kind::L),
2967 mandatoryWidth, noInt, noInt) ||
2968 construct<format::IntrinsicTypeDataEditDesc>(
2969 "A" >> pure(format::IntrinsicTypeDataEditDesc::Kind::A), maybe(width),
2970 noInt, noInt) ||
2971 // PGI/Intel extension: omitting width (and all else that follows)
2972 extension<LanguageFeature::AbbreviatedEditDescriptor>(
2973 construct<format::IntrinsicTypeDataEditDesc>(
2974 "I" >> pure(format::IntrinsicTypeDataEditDesc::Kind::I) ||
2975 ("B"_tok / !letter /* don't occlude BN & BZ */) >>
2976 pure(format::IntrinsicTypeDataEditDesc::Kind::B) ||
2977 "O" >> pure(format::IntrinsicTypeDataEditDesc::Kind::O) ||
2978 "Z" >> pure(format::IntrinsicTypeDataEditDesc::Kind::Z) ||
2979 "F" >> pure(format::IntrinsicTypeDataEditDesc::Kind::F) ||
2980 ("D"_tok / !letter /* don't occlude DT, DC, & DP */) >>
2981 pure(format::IntrinsicTypeDataEditDesc::Kind::D) ||
2982 "E" >>
2983 ("N" >> pure(format::IntrinsicTypeDataEditDesc::Kind::EN) ||
2984 "S" >>
2985 pure(format::IntrinsicTypeDataEditDesc::Kind::ES) ||
2986 "X" >>
2987 pure(format::IntrinsicTypeDataEditDesc::Kind::EX) ||
2988 pure(format::IntrinsicTypeDataEditDesc::Kind::E)) ||
2989 "G" >> pure(format::IntrinsicTypeDataEditDesc::Kind::G) ||
2990 "L" >> pure(format::IntrinsicTypeDataEditDesc::Kind::L),
2991 noInt, noInt, noInt)))
2992
2993 // R1307 data-edit-desc (part 2 of 2)
2994 // R1312 v -> [sign] digit-string
2995 constexpr SignedDigitStringIgnoreSpaces scaleFactor;
2996 TYPE_PARSER(construct<format::DerivedTypeDataEditDesc>(
2997 "D" >> "T"_tok >> defaulted(charLiteralConstantWithoutKind),
2998 defaulted(parenthesized(nonemptyList(scaleFactor)))))
2999
3000 // R1314 k -> [sign] digit-string
3001 constexpr PositiveDigitStringIgnoreSpaces count;
3002
3003 // R1313 control-edit-desc ->
3004 // position-edit-desc | [r] / | : | sign-edit-desc | k P |
3005 // blank-interp-edit-desc | round-edit-desc | decimal-edit-desc |
3006 // @ \ | $
3007 // R1315 position-edit-desc -> T n | TL n | TR n | n X
3008 // R1316 n -> digit-string
3009 // R1317 sign-edit-desc -> SS | SP | S
3010 // R1318 blank-interp-edit-desc -> BN | BZ
3011 // R1319 round-edit-desc -> RU | RD | RZ | RN | RC | RP
3012 // R1320 decimal-edit-desc -> DC | DP
3013 TYPE_PARSER(construct<format::ControlEditDesc>(
3014 "T" >> ("L" >> pure(format::ControlEditDesc::Kind::TL) ||
3015 "R" >> pure(format::ControlEditDesc::Kind::TR) ||
3016 pure(format::ControlEditDesc::Kind::T)),
3017 count) ||
3018 construct<format::ControlEditDesc>(count,
3019 "X" >> pure(format::ControlEditDesc::Kind::X) ||
3020 "/" >> pure(format::ControlEditDesc::Kind::Slash)) ||
3021 construct<format::ControlEditDesc>(
3022 "X" >> pure(format::ControlEditDesc::Kind::X) ||
3023 "/" >> pure(format::ControlEditDesc::Kind::Slash)) ||
3024 construct<format::ControlEditDesc>(
3025 scaleFactor, "P" >> pure(format::ControlEditDesc::Kind::P)) ||
3026 construct<format::ControlEditDesc>(
3027 ":" >> pure(format::ControlEditDesc::Kind::Colon)) ||
3028 "S" >> ("S" >> construct<format::ControlEditDesc>(
3029 pure(format::ControlEditDesc::Kind::SS)) ||
3030 "P" >> construct<format::ControlEditDesc>(
3031 pure(format::ControlEditDesc::Kind::SP)) ||
3032 construct<format::ControlEditDesc>(
3033 pure(format::ControlEditDesc::Kind::S))) ||
3034 "B" >> ("N" >> construct<format::ControlEditDesc>(
3035 pure(format::ControlEditDesc::Kind::BN)) ||
3036 "Z" >> construct<format::ControlEditDesc>(
3037 pure(format::ControlEditDesc::Kind::BZ))) ||
3038 "R" >> ("U" >> construct<format::ControlEditDesc>(
3039 pure(format::ControlEditDesc::Kind::RU)) ||
3040 "D" >> construct<format::ControlEditDesc>(
3041 pure(format::ControlEditDesc::Kind::RD)) ||
3042 "Z" >> construct<format::ControlEditDesc>(
3043 pure(format::ControlEditDesc::Kind::RZ)) ||
3044 "N" >> construct<format::ControlEditDesc>(
3045 pure(format::ControlEditDesc::Kind::RN)) ||
3046 "C" >> construct<format::ControlEditDesc>(
3047 pure(format::ControlEditDesc::Kind::RC)) ||
3048 "P" >> construct<format::ControlEditDesc>(
3049 pure(format::ControlEditDesc::Kind::RP))) ||
3050 "D" >> ("C" >> construct<format::ControlEditDesc>(
3051 pure(format::ControlEditDesc::Kind::DC)) ||
3052 "P" >> construct<format::ControlEditDesc>(
3053 pure(format::ControlEditDesc::Kind::DP))) ||
3054 extension<LanguageFeature::AdditionalFormats>(
3055 "$" >> construct<format::ControlEditDesc>(
3056 pure(format::ControlEditDesc::Kind::Dollar)) ||
3057 "\\" >> construct<format::ControlEditDesc>(
3058 pure(format::ControlEditDesc::Kind::Backslash))))
3059
3060 // R1401 main-program ->
3061 // [program-stmt] [specification-part] [execution-part]
3062 // [internal-subprogram-part] end-program-stmt
3063 TYPE_CONTEXT_PARSER("main program"_en_US,
3064 construct<MainProgram>(maybe(statement(Parser<ProgramStmt>{})),
3065 specificationPart, executionPart, maybe(internalSubprogramPart),
3066 unterminatedStatement(Parser<EndProgramStmt>{})))
3067
3068 // R1402 program-stmt -> PROGRAM program-name
3069 // PGI allows empty parentheses after the name.
3070 TYPE_CONTEXT_PARSER("PROGRAM statement"_en_US,
3071 construct<ProgramStmt>("PROGRAM" >> name /
3072 maybe(extension<LanguageFeature::ProgramParentheses>(
3073 parenthesized(ok)))))
3074
3075 // R1403 end-program-stmt -> END [PROGRAM [program-name]]
3076 TYPE_CONTEXT_PARSER("END PROGRAM statement"_en_US,
3077 construct<EndProgramStmt>(recovery(
3078 "END PROGRAM" >> maybe(name) || bareEnd, progUnitEndStmtErrorRecovery)))
3079
3080 // R1404 module ->
3081 // module-stmt [specification-part] [module-subprogram-part]
3082 // end-module-stmt
3083 TYPE_CONTEXT_PARSER("module"_en_US,
3084 construct<Module>(statement(Parser<ModuleStmt>{}), limitedSpecificationPart,
3085 maybe(Parser<ModuleSubprogramPart>{}),
3086 unterminatedStatement(Parser<EndModuleStmt>{})))
3087
3088 // R1405 module-stmt -> MODULE module-name
3089 TYPE_CONTEXT_PARSER(
3090 "MODULE statement"_en_US, construct<ModuleStmt>("MODULE" >> name))
3091
3092 // R1406 end-module-stmt -> END [MODULE [module-name]]
3093 TYPE_CONTEXT_PARSER("END MODULE statement"_en_US,
3094 construct<EndModuleStmt>(recovery(
3095 "END MODULE" >> maybe(name) || bareEnd, progUnitEndStmtErrorRecovery)))
3096
3097 // R1407 module-subprogram-part -> contains-stmt [module-subprogram]...
3098 TYPE_CONTEXT_PARSER("module subprogram part"_en_US,
3099 construct<ModuleSubprogramPart>(statement(containsStmt),
3100 many(StartNewSubprogram{} >> Parser<ModuleSubprogram>{})))
3101
3102 // R1408 module-subprogram ->
3103 // function-subprogram | subroutine-subprogram |
3104 // separate-module-subprogram
3105 TYPE_PARSER(construct<ModuleSubprogram>(indirect(functionSubprogram)) ||
3106 construct<ModuleSubprogram>(indirect(subroutineSubprogram)) ||
3107 construct<ModuleSubprogram>(indirect(Parser<SeparateModuleSubprogram>{})))
3108
3109 // R1410 module-nature -> INTRINSIC | NON_INTRINSIC
3110 constexpr auto moduleNature{
3111 "INTRINSIC" >> pure(UseStmt::ModuleNature::Intrinsic) ||
3112 "NON_INTRINSIC" >> pure(UseStmt::ModuleNature::Non_Intrinsic)};
3113
3114 // R1409 use-stmt ->
3115 // USE [[, module-nature] ::] module-name [, rename-list] |
3116 // USE [[, module-nature] ::] module-name , ONLY : [only-list]
3117 // N.B. Lookahead to the end of the statement is necessary to resolve
3118 // ambiguity with assignments and statement function definitions that
3119 // begin with the letters "USE".
3120 TYPE_PARSER(construct<UseStmt>("USE" >> optionalBeforeColons(moduleNature),
3121 name, ", ONLY :" >> optionalList(Parser<Only>{})) ||
3122 construct<UseStmt>("USE" >> optionalBeforeColons(moduleNature), name,
3123 defaulted("," >>
3124 nonemptyList("expected renamings"_err_en_US, Parser<Rename>{})) /
3125 lookAhead(endOfStmt)))
3126
3127 // R1411 rename ->
3128 // local-name => use-name |
3129 // OPERATOR ( local-defined-operator ) =>
3130 // OPERATOR ( use-defined-operator )
3131 TYPE_PARSER(construct<Rename>("OPERATOR (" >>
3132 construct<Rename::Operators>(
3133 definedOpName / ") => OPERATOR (", definedOpName / ")")) ||
3134 construct<Rename>(construct<Rename::Names>(name, "=>" >> name)))
3135
3136 // R1412 only -> generic-spec | only-use-name | rename
3137 // R1413 only-use-name -> use-name
3138 TYPE_PARSER(construct<Only>(Parser<Rename>{}) ||
3139 construct<Only>(indirect(genericSpec)) ||
3140 construct<Only>(name)) // TODO: ambiguous, accepted by genericSpec
3141
3142 // R1416 submodule ->
3143 // submodule-stmt [specification-part] [module-subprogram-part]
3144 // end-submodule-stmt
3145 TYPE_CONTEXT_PARSER("submodule"_en_US,
3146 construct<Submodule>(statement(Parser<SubmoduleStmt>{}),
3147 limitedSpecificationPart, maybe(Parser<ModuleSubprogramPart>{}),
3148 unterminatedStatement(Parser<EndSubmoduleStmt>{})))
3149
3150 // R1417 submodule-stmt -> SUBMODULE ( parent-identifier ) submodule-name
3151 TYPE_CONTEXT_PARSER("SUBMODULE statement"_en_US,
3152 construct<SubmoduleStmt>(
3153 "SUBMODULE" >> parenthesized(Parser<ParentIdentifier>{}), name))
3154
3155 // R1418 parent-identifier -> ancestor-module-name [: parent-submodule-name]
3156 TYPE_PARSER(construct<ParentIdentifier>(name, maybe(":" >> name)))
3157
3158 // R1419 end-submodule-stmt -> END [SUBMODULE [submodule-name]]
3159 TYPE_CONTEXT_PARSER("END SUBMODULE statement"_en_US,
3160 construct<EndSubmoduleStmt>(
3161 recovery("END SUBMODULE" >> maybe(name) || bareEnd,
3162 progUnitEndStmtErrorRecovery)))
3163
3164 // R1420 block-data -> block-data-stmt [specification-part] end-block-data-stmt
3165 TYPE_CONTEXT_PARSER("BLOCK DATA subprogram"_en_US,
3166 construct<BlockData>(statement(Parser<BlockDataStmt>{}),
3167 limitedSpecificationPart,
3168 unterminatedStatement(Parser<EndBlockDataStmt>{})))
3169
3170 // R1421 block-data-stmt -> BLOCK DATA [block-data-name]
3171 TYPE_CONTEXT_PARSER("BLOCK DATA statement"_en_US,
3172 construct<BlockDataStmt>("BLOCK DATA" >> maybe(name)))
3173
3174 // R1422 end-block-data-stmt -> END [BLOCK DATA [block-data-name]]
3175 TYPE_CONTEXT_PARSER("END BLOCK DATA statement"_en_US,
3176 construct<EndBlockDataStmt>(
3177 recovery("END BLOCK DATA" >> maybe(name) || bareEnd,
3178 progUnitEndStmtErrorRecovery)))
3179
3180 // R1501 interface-block ->
3181 // interface-stmt [interface-specification]... end-interface-stmt
TYPE_PARSER(construct<InterfaceBlock> (statement (Parser<InterfaceStmt>{}),many (Parser<InterfaceSpecification>{}),statement (Parser<EndInterfaceStmt>{})))3182 TYPE_PARSER(construct<InterfaceBlock>(statement(Parser<InterfaceStmt>{}),
3183 many(Parser<InterfaceSpecification>{}),
3184 statement(Parser<EndInterfaceStmt>{})))
3185
3186 // R1502 interface-specification -> interface-body | procedure-stmt
3187 TYPE_PARSER(construct<InterfaceSpecification>(Parser<InterfaceBody>{}) ||
3188 construct<InterfaceSpecification>(statement(Parser<ProcedureStmt>{})))
3189
3190 // R1503 interface-stmt -> INTERFACE [generic-spec] | ABSTRACT INTERFACE
3191 TYPE_PARSER(construct<InterfaceStmt>("INTERFACE" >> maybe(genericSpec)) ||
3192 construct<InterfaceStmt>(construct<Abstract>("ABSTRACT INTERFACE"_sptok)))
3193
3194 // R1504 end-interface-stmt -> END INTERFACE [generic-spec]
3195 TYPE_PARSER(construct<EndInterfaceStmt>("END INTERFACE" >> maybe(genericSpec)))
3196
3197 // R1505 interface-body ->
3198 // function-stmt [specification-part] end-function-stmt |
3199 // subroutine-stmt [specification-part] end-subroutine-stmt
3200 TYPE_CONTEXT_PARSER("interface body"_en_US,
3201 construct<InterfaceBody>(
3202 construct<InterfaceBody::Function>(statement(functionStmt),
3203 indirect(limitedSpecificationPart), statement(endFunctionStmt))) ||
3204 construct<InterfaceBody>(construct<InterfaceBody::Subroutine>(
3205 statement(subroutineStmt), indirect(limitedSpecificationPart),
3206 statement(endSubroutineStmt))))
3207
3208 // R1507 specific-procedure -> procedure-name
3209 constexpr auto specificProcedures{
3210 nonemptyList("expected specific procedure names"_err_en_US, name)};
3211
3212 // R1506 procedure-stmt -> [MODULE] PROCEDURE [::] specific-procedure-list
3213 TYPE_PARSER(construct<ProcedureStmt>("MODULE PROCEDURE"_sptok >>
3214 pure(ProcedureStmt::Kind::ModuleProcedure),
3215 maybe("::"_tok) >> specificProcedures) ||
3216 construct<ProcedureStmt>(
3217 "PROCEDURE" >> pure(ProcedureStmt::Kind::Procedure),
3218 maybe("::"_tok) >> specificProcedures))
3219
3220 // R1508 generic-spec ->
3221 // generic-name | OPERATOR ( defined-operator ) |
3222 // ASSIGNMENT ( = ) | defined-io-generic-spec
3223 // R1509 defined-io-generic-spec ->
3224 // READ ( FORMATTED ) | READ ( UNFORMATTED ) |
3225 // WRITE ( FORMATTED ) | WRITE ( UNFORMATTED )
3226 TYPE_PARSER(sourced(first(construct<GenericSpec>("OPERATOR" >>
3227 parenthesized(Parser<DefinedOperator>{})),
3228 construct<GenericSpec>(
3229 construct<GenericSpec::Assignment>("ASSIGNMENT ( = )"_tok)),
3230 construct<GenericSpec>(
3231 construct<GenericSpec::ReadFormatted>("READ ( FORMATTED )"_tok)),
3232 construct<GenericSpec>(
3233 construct<GenericSpec::ReadUnformatted>("READ ( UNFORMATTED )"_tok)),
3234 construct<GenericSpec>(
3235 construct<GenericSpec::WriteFormatted>("WRITE ( FORMATTED )"_tok)),
3236 construct<GenericSpec>(
3237 construct<GenericSpec::WriteUnformatted>("WRITE ( UNFORMATTED )"_tok)),
3238 construct<GenericSpec>(name))))
3239
3240 // R1510 generic-stmt ->
3241 // GENERIC [, access-spec] :: generic-spec => specific-procedure-list
3242 TYPE_PARSER(construct<GenericStmt>("GENERIC" >> maybe("," >> accessSpec),
3243 "::" >> genericSpec, "=>" >> specificProcedures))
3244
3245 // R1511 external-stmt -> EXTERNAL [::] external-name-list
3246 TYPE_PARSER(
3247 "EXTERNAL" >> maybe("::"_tok) >> construct<ExternalStmt>(listOfNames))
3248
3249 // R1512 procedure-declaration-stmt ->
3250 // PROCEDURE ( [proc-interface] ) [[, proc-attr-spec]... ::]
3251 // proc-decl-list
3252 TYPE_PARSER("PROCEDURE" >>
3253 construct<ProcedureDeclarationStmt>(parenthesized(maybe(procInterface)),
3254 optionalListBeforeColons(Parser<ProcAttrSpec>{}),
3255 nonemptyList("expected procedure declarations"_err_en_US, procDecl)))
3256
3257 // R1513 proc-interface -> interface-name | declaration-type-spec
3258 // R1516 interface-name -> name
3259 // N.B. Simple names of intrinsic types (e.g., "REAL") are not
3260 // ambiguous here - they take precedence over derived type names
3261 // thanks to C1516.
3262 TYPE_PARSER(
3263 construct<ProcInterface>(declarationTypeSpec / lookAhead(")"_tok)) ||
3264 construct<ProcInterface>(name))
3265
3266 // R1514 proc-attr-spec ->
3267 // access-spec | proc-language-binding-spec | INTENT ( intent-spec ) |
3268 // OPTIONAL | POINTER | PROTECTED | SAVE
3269 TYPE_PARSER(construct<ProcAttrSpec>(accessSpec) ||
3270 construct<ProcAttrSpec>(languageBindingSpec) ||
3271 construct<ProcAttrSpec>("INTENT" >> parenthesized(intentSpec)) ||
3272 construct<ProcAttrSpec>(optional) || construct<ProcAttrSpec>(pointer) ||
3273 construct<ProcAttrSpec>(protectedAttr) || construct<ProcAttrSpec>(save))
3274
3275 // R1515 proc-decl -> procedure-entity-name [=> proc-pointer-init]
3276 TYPE_PARSER(construct<ProcDecl>(name, maybe("=>" >> Parser<ProcPointerInit>{})))
3277
3278 // R1517 proc-pointer-init -> null-init | initial-proc-target
3279 // R1518 initial-proc-target -> procedure-name
3280 TYPE_PARSER(
3281 construct<ProcPointerInit>(nullInit) || construct<ProcPointerInit>(name))
3282
3283 // R1519 intrinsic-stmt -> INTRINSIC [::] intrinsic-procedure-name-list
3284 TYPE_PARSER(
3285 "INTRINSIC" >> maybe("::"_tok) >> construct<IntrinsicStmt>(listOfNames))
3286
3287 // R1520 function-reference -> procedure-designator ( [actual-arg-spec-list] )
3288 TYPE_CONTEXT_PARSER("function reference"_en_US,
3289 construct<FunctionReference>(
3290 sourced(construct<Call>(Parser<ProcedureDesignator>{},
3291 parenthesized(optionalList(actualArgSpec))))) /
3292 !"["_tok)
3293
3294 // R1521 call-stmt -> CALL procedure-designator [( [actual-arg-spec-list] )]
3295 TYPE_PARSER(construct<CallStmt>(
3296 sourced(construct<Call>("CALL" >> Parser<ProcedureDesignator>{},
3297 defaulted(parenthesized(optionalList(actualArgSpec)))))))
3298
3299 // R1522 procedure-designator ->
3300 // procedure-name | proc-component-ref | data-ref % binding-name
3301 TYPE_PARSER(construct<ProcedureDesignator>(Parser<ProcComponentRef>{}) ||
3302 construct<ProcedureDesignator>(name))
3303
3304 // R1523 actual-arg-spec -> [keyword =] actual-arg
3305 TYPE_PARSER(construct<ActualArgSpec>(
3306 maybe(keyword / "=" / !"="_ch), Parser<ActualArg>{}))
3307
3308 // R1524 actual-arg ->
3309 // expr | variable | procedure-name | proc-component-ref |
3310 // alt-return-spec
3311 // N.B. the "procedure-name" and "proc-component-ref" alternatives can't
3312 // yet be distinguished from "variable", many instances of which can't be
3313 // distinguished from "expr" anyway (to do so would misparse structure
3314 // constructors and function calls as array elements).
3315 // Semantics sorts it all out later.
3316 TYPE_PARSER(construct<ActualArg>(expr) ||
3317 construct<ActualArg>(Parser<AltReturnSpec>{}) ||
3318 extension<LanguageFeature::PercentRefAndVal>(construct<ActualArg>(
3319 construct<ActualArg::PercentRef>("%REF" >> parenthesized(variable)))) ||
3320 extension<LanguageFeature::PercentRefAndVal>(construct<ActualArg>(
3321 construct<ActualArg::PercentVal>("%VAL" >> parenthesized(expr)))))
3322
3323 // R1525 alt-return-spec -> * label
3324 TYPE_PARSER(construct<AltReturnSpec>(star >> label))
3325
3326 // R1527 prefix-spec ->
3327 // declaration-type-spec | ELEMENTAL | IMPURE | MODULE |
3328 // NON_RECURSIVE | PURE | RECURSIVE
3329 TYPE_PARSER(first(construct<PrefixSpec>(declarationTypeSpec),
3330 construct<PrefixSpec>(construct<PrefixSpec::Elemental>("ELEMENTAL"_tok)),
3331 construct<PrefixSpec>(construct<PrefixSpec::Impure>("IMPURE"_tok)),
3332 construct<PrefixSpec>(construct<PrefixSpec::Module>("MODULE"_tok)),
3333 construct<PrefixSpec>(
3334 construct<PrefixSpec::Non_Recursive>("NON_RECURSIVE"_tok)),
3335 construct<PrefixSpec>(construct<PrefixSpec::Pure>("PURE"_tok)),
3336 construct<PrefixSpec>(construct<PrefixSpec::Recursive>("RECURSIVE"_tok))))
3337
3338 // R1529 function-subprogram ->
3339 // function-stmt [specification-part] [execution-part]
3340 // [internal-subprogram-part] end-function-stmt
3341 TYPE_CONTEXT_PARSER("FUNCTION subprogram"_en_US,
3342 construct<FunctionSubprogram>(statement(functionStmt), specificationPart,
3343 executionPart, maybe(internalSubprogramPart),
3344 unterminatedStatement(endFunctionStmt)))
3345
3346 // R1530 function-stmt ->
3347 // [prefix] FUNCTION function-name ( [dummy-arg-name-list] ) [suffix]
3348 // R1526 prefix -> prefix-spec [prefix-spec]...
3349 // R1531 dummy-arg-name -> name
3350 TYPE_CONTEXT_PARSER("FUNCTION statement"_en_US,
3351 construct<FunctionStmt>(many(prefixSpec), "FUNCTION" >> name,
3352 parenthesized(optionalList(name)), maybe(suffix)) ||
3353 extension<LanguageFeature::OmitFunctionDummies>(
3354 construct<FunctionStmt>( // PGI & Intel accept "FUNCTION F"
3355 many(prefixSpec), "FUNCTION" >> name,
3356 construct<std::list<Name>>(),
3357 construct<std::optional<Suffix>>())))
3358
3359 // R1532 suffix ->
3360 // proc-language-binding-spec [RESULT ( result-name )] |
3361 // RESULT ( result-name ) [proc-language-binding-spec]
3362 TYPE_PARSER(construct<Suffix>(
3363 languageBindingSpec, maybe("RESULT" >> parenthesized(name))) ||
3364 construct<Suffix>(
3365 "RESULT" >> parenthesized(name), maybe(languageBindingSpec)))
3366
3367 // R1533 end-function-stmt -> END [FUNCTION [function-name]]
3368 TYPE_PARSER(construct<EndFunctionStmt>(recovery(
3369 "END FUNCTION" >> maybe(name) || bareEnd, progUnitEndStmtErrorRecovery)))
3370
3371 // R1534 subroutine-subprogram ->
3372 // subroutine-stmt [specification-part] [execution-part]
3373 // [internal-subprogram-part] end-subroutine-stmt
3374 TYPE_CONTEXT_PARSER("SUBROUTINE subprogram"_en_US,
3375 construct<SubroutineSubprogram>(statement(subroutineStmt),
3376 specificationPart, executionPart, maybe(internalSubprogramPart),
3377 unterminatedStatement(endSubroutineStmt)))
3378
3379 // R1535 subroutine-stmt ->
3380 // [prefix] SUBROUTINE subroutine-name [( [dummy-arg-list] )
3381 // [proc-language-binding-spec]]
3382 TYPE_PARSER(
3383 construct<SubroutineStmt>(many(prefixSpec), "SUBROUTINE" >> name,
3384 parenthesized(optionalList(dummyArg)), maybe(languageBindingSpec)) ||
3385 construct<SubroutineStmt>(many(prefixSpec), "SUBROUTINE" >> name,
3386 defaulted(cut >> many(dummyArg)),
3387 defaulted(cut >> maybe(languageBindingSpec))))
3388
3389 // R1536 dummy-arg -> dummy-arg-name | *
3390 TYPE_PARSER(construct<DummyArg>(name) || construct<DummyArg>(star))
3391
3392 // R1537 end-subroutine-stmt -> END [SUBROUTINE [subroutine-name]]
3393 TYPE_PARSER(construct<EndSubroutineStmt>(recovery(
3394 "END SUBROUTINE" >> maybe(name) || bareEnd, progUnitEndStmtErrorRecovery)))
3395
3396 // R1538 separate-module-subprogram ->
3397 // mp-subprogram-stmt [specification-part] [execution-part]
3398 // [internal-subprogram-part] end-mp-subprogram-stmt
3399 TYPE_CONTEXT_PARSER("separate module subprogram"_en_US,
3400 construct<SeparateModuleSubprogram>(statement(Parser<MpSubprogramStmt>{}),
3401 specificationPart, executionPart, maybe(internalSubprogramPart),
3402 statement(Parser<EndMpSubprogramStmt>{})))
3403
3404 // R1539 mp-subprogram-stmt -> MODULE PROCEDURE procedure-name
3405 TYPE_CONTEXT_PARSER("MODULE PROCEDURE statement"_en_US,
3406 construct<MpSubprogramStmt>("MODULE PROCEDURE"_sptok >> name))
3407
3408 // R1540 end-mp-subprogram-stmt -> END [PROCEDURE [procedure-name]]
3409 TYPE_CONTEXT_PARSER("END PROCEDURE statement"_en_US,
3410 construct<EndMpSubprogramStmt>(
3411 recovery("END PROCEDURE" >> maybe(name) || bareEnd,
3412 progUnitEndStmtErrorRecovery)))
3413
3414 // R1541 entry-stmt -> ENTRY entry-name [( [dummy-arg-list] ) [suffix]]
3415 TYPE_PARSER(
3416 "ENTRY" >> (construct<EntryStmt>(name,
3417 parenthesized(optionalList(dummyArg)), maybe(suffix)) ||
3418 construct<EntryStmt>(name, construct<std::list<DummyArg>>(),
3419 construct<std::optional<Suffix>>())))
3420
3421 // R1542 return-stmt -> RETURN [scalar-int-expr]
3422 TYPE_CONTEXT_PARSER("RETURN statement"_en_US,
3423 construct<ReturnStmt>("RETURN" >> maybe(scalarIntExpr)))
3424
3425 // R1543 contains-stmt -> CONTAINS
3426 TYPE_PARSER(construct<ContainsStmt>("CONTAINS"_tok))
3427
3428 // R1544 stmt-function-stmt ->
3429 // function-name ( [dummy-arg-name-list] ) = scalar-expr
3430 TYPE_CONTEXT_PARSER("statement function definition"_en_US,
3431 construct<StmtFunctionStmt>(
3432 name, parenthesized(optionalList(name)), "=" >> scalar(expr)))
3433
3434 // Directives, extensions, and deprecated statements
3435 // !DIR$ IGNORE_TKR [ [(tkr...)] name ]...
3436 // !DIR$ name...
3437 constexpr auto beginDirective{skipStuffBeforeStatement >> "!"_ch};
3438 constexpr auto endDirective{space >> endOfLine};
3439 constexpr auto ignore_tkr{
3440 "DIR$ IGNORE_TKR" >> optionalList(construct<CompilerDirective::IgnoreTKR>(
3441 defaulted(parenthesized(some("tkr"_ch))), name))};
3442 TYPE_PARSER(
3443 beginDirective >> sourced(construct<CompilerDirective>(ignore_tkr) ||
3444 construct<CompilerDirective>("DIR$" >> many(name))) /
3445 endDirective)
3446
3447 TYPE_PARSER(extension<LanguageFeature::CrayPointer>(construct<BasedPointerStmt>(
3448 "POINTER" >> nonemptyList("expected POINTER associations"_err_en_US,
3449 construct<BasedPointer>("(" >> objectName / ",",
3450 objectName, maybe(Parser<ArraySpec>{}) / ")")))))
3451
3452 TYPE_PARSER(construct<StructureStmt>("STRUCTURE /" >> name / "/", pure(true),
3453 optionalList(entityDecl)) ||
3454 construct<StructureStmt>(
3455 "STRUCTURE" >> name, pure(false), defaulted(cut >> many(entityDecl))))
3456
3457 TYPE_PARSER(construct<StructureField>(statement(StructureComponents{})) ||
3458 construct<StructureField>(indirect(Parser<Union>{})) ||
3459 construct<StructureField>(indirect(Parser<StructureDef>{})))
3460
3461 TYPE_CONTEXT_PARSER("STRUCTURE definition"_en_US,
3462 extension<LanguageFeature::DECStructures>(construct<StructureDef>(
3463 statement(Parser<StructureStmt>{}), many(Parser<StructureField>{}),
3464 statement(
3465 construct<StructureDef::EndStructureStmt>("END STRUCTURE"_tok)))))
3466
3467 TYPE_CONTEXT_PARSER("UNION definition"_en_US,
3468 construct<Union>(statement(construct<Union::UnionStmt>("UNION"_tok)),
3469 many(Parser<Map>{}),
3470 statement(construct<Union::EndUnionStmt>("END UNION"_tok))))
3471
3472 TYPE_CONTEXT_PARSER("MAP definition"_en_US,
3473 construct<Map>(statement(construct<Map::MapStmt>("MAP"_tok)),
3474 many(Parser<StructureField>{}),
3475 statement(construct<Map::EndMapStmt>("END MAP"_tok))))
3476
3477 TYPE_CONTEXT_PARSER("arithmetic IF statement"_en_US,
3478 deprecated<LanguageFeature::ArithmeticIF>(construct<ArithmeticIfStmt>(
3479 "IF" >> parenthesized(expr), label / ",", label / ",", label)))
3480
3481 TYPE_CONTEXT_PARSER("ASSIGN statement"_en_US,
3482 deprecated<LanguageFeature::Assign>(
3483 construct<AssignStmt>("ASSIGN" >> label, "TO" >> name)))
3484
3485 TYPE_CONTEXT_PARSER("assigned GOTO statement"_en_US,
3486 deprecated<LanguageFeature::AssignedGOTO>(construct<AssignedGotoStmt>(
3487 "GO TO" >> name,
3488 defaulted(maybe(","_tok) >>
3489 parenthesized(nonemptyList("expected labels"_err_en_US, label))))))
3490
3491 TYPE_CONTEXT_PARSER("PAUSE statement"_en_US,
3492 deprecated<LanguageFeature::Pause>(
3493 construct<PauseStmt>("PAUSE" >> maybe(Parser<StopCode>{}))))
3494
3495 // These requirement productions are defined by the Fortran standard but never
3496 // used directly by the grammar:
3497 // R620 delimiter -> ( | ) | / | [ | ] | (/ | /)
3498 // R1027 numeric-expr -> expr
3499 // R1031 int-constant-expr -> int-expr
3500 // R1221 dtv-type-spec -> TYPE ( derived-type-spec ) |
3501 // CLASS ( derived-type-spec )
3502 //
3503 // These requirement productions are defined and used, but need not be
3504 // defined independently here in this file:
3505 // R771 lbracket -> [
3506 // R772 rbracket -> ]
3507 //
3508 // Further note that:
3509 // R607 int-constant -> constant
3510 // is used only once via R844 scalar-int-constant
3511 // R904 logical-variable -> variable
3512 // is used only via scalar-logical-variable
3513 // R906 default-char-variable -> variable
3514 // is used only via scalar-default-char-variable
3515 // R907 int-variable -> variable
3516 // is used only via scalar-int-variable
3517 // R915 complex-part-designator -> designator % RE | designator % IM
3518 // %RE and %IM are initially recognized as structure components
3519 // R916 type-param-inquiry -> designator % type-param-name
3520 // is occulted by structure component designators
3521 // R918 array-section ->
3522 // data-ref [( substring-range )] | complex-part-designator
3523 // is not used because parsing is not sensitive to rank
3524 // R1030 default-char-constant-expr -> default-char-expr
3525 // is only used via scalar-default-char-constant-expr
3526 }
3527 #endif // FORTRAN_PARSER_GRAMMAR_H_
3528