File : par-ch4.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P A R . C H 4 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 pragma Style_Checks (All_Checks);
27 -- Turn off subprogram body ordering check. Subprograms are in order
28 -- by RM section rather than alphabetical
29
30 with Stringt; use Stringt;
31
32 separate (Par)
33 package body Ch4 is
34
35 -- Attributes that cannot have arguments
36
37 Is_Parameterless_Attribute : constant Attribute_Class_Array :=
38 (Attribute_Base => True,
39 Attribute_Body_Version => True,
40 Attribute_Class => True,
41 Attribute_External_Tag => True,
42 Attribute_Img => True,
43 Attribute_Loop_Entry => True,
44 Attribute_Old => True,
45 Attribute_Result => True,
46 Attribute_Stub_Type => True,
47 Attribute_Version => True,
48 Attribute_Type_Key => True,
49 others => False);
50 -- This map contains True for parameterless attributes that return a
51 -- string or a type. For those attributes, a left parenthesis after
52 -- the attribute should not be analyzed as the beginning of a parameters
53 -- list because it may denote a slice operation (X'Img (1 .. 2)) or
54 -- a type conversion (X'Class (Y)). The Ada2012 attribute 'Old is in
55 -- this category.
56
57 -- Note: Loop_Entry is in this list because, although it can take an
58 -- optional argument (the loop name), we can't distinguish that at parse
59 -- time from the case where no loop name is given and a legitimate index
60 -- expression is present. So we parse the argument as an indexed component
61 -- and the semantic analysis sorts out this syntactic ambiguity based on
62 -- the type and form of the expression.
63
64 -- Note that this map designates the minimum set of attributes where a
65 -- construct in parentheses that is not an argument can appear right
66 -- after the attribute. For attributes like 'Size, we do not put them
67 -- in the map. If someone writes X'Size (3), that's illegal in any case,
68 -- but we get a better error message by parsing the (3) as an illegal
69 -- argument to the attribute, rather than some meaningless junk that
70 -- follows the attribute.
71
72 -----------------------
73 -- Local Subprograms --
74 -----------------------
75
76 function P_Aggregate_Or_Paren_Expr return Node_Id;
77 function P_Allocator return Node_Id;
78 function P_Case_Expression_Alternative return Node_Id;
79 function P_Record_Or_Array_Component_Association return Node_Id;
80 function P_Factor return Node_Id;
81 function P_Primary return Node_Id;
82 function P_Relation return Node_Id;
83 function P_Term return Node_Id;
84
85 function P_Binary_Adding_Operator return Node_Kind;
86 function P_Logical_Operator return Node_Kind;
87 function P_Multiplying_Operator return Node_Kind;
88 function P_Relational_Operator return Node_Kind;
89 function P_Unary_Adding_Operator return Node_Kind;
90
91 procedure Bad_Range_Attribute (Loc : Source_Ptr);
92 -- Called to place complaint about bad range attribute at the given
93 -- source location. Terminates by raising Error_Resync.
94
95 procedure Check_Bad_Exp;
96 -- Called after scanning a**b, posts error if ** detected
97
98 procedure P_Membership_Test (N : Node_Id);
99 -- N is the node for a N_In or N_Not_In node whose right operand has not
100 -- yet been processed. It is called just after scanning out the IN keyword.
101 -- On return, either Right_Opnd or Alternatives is set, as appropriate.
102
103 function P_Range_Attribute_Reference (Prefix_Node : Node_Id) return Node_Id;
104 -- Scan a range attribute reference. The caller has scanned out the
105 -- prefix. The current token is known to be an apostrophe and the
106 -- following token is known to be RANGE.
107
108 function P_Unparen_Cond_Case_Quant_Expression return Node_Id;
109 -- This function is called with Token pointing to IF, CASE, or FOR, in a
110 -- context that allows a case, conditional, or quantified expression if
111 -- it is surrounded by parentheses. If not surrounded by parentheses, the
112 -- expression is still returned, but an error message is issued.
113
114 -------------------------
115 -- Bad_Range_Attribute --
116 -------------------------
117
118 procedure Bad_Range_Attribute (Loc : Source_Ptr) is
119 begin
120 Error_Msg ("range attribute cannot be used in expression!", Loc);
121 Resync_Expression;
122 end Bad_Range_Attribute;
123
124 -------------------
125 -- Check_Bad_Exp --
126 -------------------
127
128 procedure Check_Bad_Exp is
129 begin
130 if Token = Tok_Double_Asterisk then
131 Error_Msg_SC ("parenthesization required for '*'*");
132 Scan; -- past **
133 Discard_Junk_Node (P_Primary);
134 Check_Bad_Exp;
135 end if;
136 end Check_Bad_Exp;
137
138 --------------------------
139 -- 4.1 Name (also 6.4) --
140 --------------------------
141
142 -- NAME ::=
143 -- DIRECT_NAME | EXPLICIT_DEREFERENCE
144 -- | INDEXED_COMPONENT | SLICE
145 -- | SELECTED_COMPONENT | ATTRIBUTE
146 -- | TYPE_CONVERSION | FUNCTION_CALL
147 -- | CHARACTER_LITERAL
148
149 -- DIRECT_NAME ::= IDENTIFIER | OPERATOR_SYMBOL
150
151 -- PREFIX ::= NAME | IMPLICIT_DEREFERENCE
152
153 -- EXPLICIT_DEREFERENCE ::= NAME . all
154
155 -- IMPLICIT_DEREFERENCE ::= NAME
156
157 -- INDEXED_COMPONENT ::= PREFIX (EXPRESSION {, EXPRESSION})
158
159 -- SLICE ::= PREFIX (DISCRETE_RANGE)
160
161 -- SELECTED_COMPONENT ::= PREFIX . SELECTOR_NAME
162
163 -- SELECTOR_NAME ::= IDENTIFIER | CHARACTER_LITERAL | OPERATOR_SYMBOL
164
165 -- ATTRIBUTE_REFERENCE ::= PREFIX ' ATTRIBUTE_DESIGNATOR
166
167 -- ATTRIBUTE_DESIGNATOR ::=
168 -- IDENTIFIER [(static_EXPRESSION)]
169 -- | access | delta | digits
170
171 -- FUNCTION_CALL ::=
172 -- function_NAME
173 -- | function_PREFIX ACTUAL_PARAMETER_PART
174
175 -- ACTUAL_PARAMETER_PART ::=
176 -- (PARAMETER_ASSOCIATION {,PARAMETER_ASSOCIATION})
177
178 -- PARAMETER_ASSOCIATION ::=
179 -- [formal_parameter_SELECTOR_NAME =>] EXPLICIT_ACTUAL_PARAMETER
180
181 -- EXPLICIT_ACTUAL_PARAMETER ::= EXPRESSION | variable_NAME
182
183 -- Note: syntactically a procedure call looks just like a function call,
184 -- so this routine is in practice used to scan out procedure calls as well.
185
186 -- On return, Expr_Form is set to either EF_Name or EF_Simple_Name
187
188 -- Error recovery: can raise Error_Resync
189
190 -- Note: if on return Token = Tok_Apostrophe, then the apostrophe must be
191 -- followed by either a left paren (qualified expression case), or by
192 -- range (range attribute case). All other uses of apostrophe (i.e. all
193 -- other attributes) are handled in this routine.
194
195 -- Error recovery: can raise Error_Resync
196
197 function P_Name return Node_Id is
198 Scan_State : Saved_Scan_State;
199 Name_Node : Node_Id;
200 Prefix_Node : Node_Id;
201 Ident_Node : Node_Id;
202 Expr_Node : Node_Id;
203 Range_Node : Node_Id;
204 Arg_Node : Node_Id;
205
206 Arg_List : List_Id := No_List; -- kill junk warning
207 Attr_Name : Name_Id := No_Name; -- kill junk warning
208
209 begin
210 -- Case of not a name
211
212 if Token not in Token_Class_Name then
213
214 -- If it looks like start of expression, complain and scan expression
215
216 if Token in Token_Class_Literal
217 or else Token = Tok_Left_Paren
218 then
219 Error_Msg_SC ("name expected");
220 return P_Expression;
221
222 -- Otherwise some other junk, not much we can do
223
224 else
225 Error_Msg_AP ("name expected");
226 raise Error_Resync;
227 end if;
228 end if;
229
230 -- Loop through designators in qualified name
231
232 Name_Node := Token_Node;
233
234 loop
235 Scan; -- past designator
236 exit when Token /= Tok_Dot;
237 Save_Scan_State (Scan_State); -- at dot
238 Scan; -- past dot
239
240 -- If we do not have another designator after the dot, then join
241 -- the normal circuit to handle a dot extension (may be .all or
242 -- character literal case). Otherwise loop back to scan the next
243 -- designator.
244
245 if Token not in Token_Class_Desig then
246 goto Scan_Name_Extension_Dot;
247 else
248 Prefix_Node := Name_Node;
249 Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
250 Set_Prefix (Name_Node, Prefix_Node);
251 Set_Selector_Name (Name_Node, Token_Node);
252 end if;
253 end loop;
254
255 -- We have now scanned out a qualified designator. If the last token is
256 -- an operator symbol, then we certainly do not have the Snam case, so
257 -- we can just use the normal name extension check circuit
258
259 if Prev_Token = Tok_Operator_Symbol then
260 goto Scan_Name_Extension;
261 end if;
262
263 -- We have scanned out a qualified simple name, check for name extension
264 -- Note that we know there is no dot here at this stage, so the only
265 -- possible cases of name extension are apostrophe and left paren.
266
267 if Token = Tok_Apostrophe then
268 Save_Scan_State (Scan_State); -- at apostrophe
269 Scan; -- past apostrophe
270
271 -- Qualified expression in Ada 2012 mode (treated as a name)
272
273 if Ada_Version >= Ada_2012 and then Token = Tok_Left_Paren then
274 goto Scan_Name_Extension_Apostrophe;
275
276 -- If left paren not in Ada 2012, then it is not part of the name,
277 -- since qualified expressions are not names in prior versions of
278 -- Ada, so return with Token backed up to point to the apostrophe.
279 -- The treatment for the range attribute is similar (we do not
280 -- consider x'range to be a name in this grammar).
281
282 elsif Token = Tok_Left_Paren or else Token = Tok_Range then
283 Restore_Scan_State (Scan_State); -- to apostrophe
284 Expr_Form := EF_Simple_Name;
285 return Name_Node;
286
287 -- Otherwise we have the case of a name extended by an attribute
288
289 else
290 goto Scan_Name_Extension_Apostrophe;
291 end if;
292
293 -- Check case of qualified simple name extended by a left parenthesis
294
295 elsif Token = Tok_Left_Paren then
296 Scan; -- past left paren
297 goto Scan_Name_Extension_Left_Paren;
298
299 -- Otherwise the qualified simple name is not extended, so return
300
301 else
302 Expr_Form := EF_Simple_Name;
303 return Name_Node;
304 end if;
305
306 -- Loop scanning past name extensions. A label is used for control
307 -- transfer for this loop for ease of interfacing with the finite state
308 -- machine in the parenthesis scanning circuit, and also to allow for
309 -- passing in control to the appropriate point from the above code.
310
311 <<Scan_Name_Extension>>
312
313 -- Character literal used as name cannot be extended. Also this
314 -- cannot be a call, since the name for a call must be a designator.
315 -- Return in these cases, or if there is no name extension
316
317 if Token not in Token_Class_Namext
318 or else Prev_Token = Tok_Char_Literal
319 then
320 Expr_Form := EF_Name;
321 return Name_Node;
322 end if;
323
324 -- Merge here when we know there is a name extension
325
326 <<Scan_Name_Extension_OK>>
327
328 if Token = Tok_Left_Paren then
329 Scan; -- past left paren
330 goto Scan_Name_Extension_Left_Paren;
331
332 elsif Token = Tok_Apostrophe then
333 Save_Scan_State (Scan_State); -- at apostrophe
334 Scan; -- past apostrophe
335 goto Scan_Name_Extension_Apostrophe;
336
337 else -- Token = Tok_Dot
338 Save_Scan_State (Scan_State); -- at dot
339 Scan; -- past dot
340 goto Scan_Name_Extension_Dot;
341 end if;
342
343 -- Case of name extended by dot (selection), dot is already skipped
344 -- and the scan state at the point of the dot is saved in Scan_State.
345
346 <<Scan_Name_Extension_Dot>>
347
348 -- Explicit dereference case
349
350 if Token = Tok_All then
351 Prefix_Node := Name_Node;
352 Name_Node := New_Node (N_Explicit_Dereference, Token_Ptr);
353 Set_Prefix (Name_Node, Prefix_Node);
354 Scan; -- past ALL
355 goto Scan_Name_Extension;
356
357 -- Selected component case
358
359 elsif Token in Token_Class_Name then
360 Prefix_Node := Name_Node;
361 Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
362 Set_Prefix (Name_Node, Prefix_Node);
363 Set_Selector_Name (Name_Node, Token_Node);
364 Scan; -- past selector
365 goto Scan_Name_Extension;
366
367 -- Reserved identifier as selector
368
369 elsif Is_Reserved_Identifier then
370 Scan_Reserved_Identifier (Force_Msg => False);
371 Prefix_Node := Name_Node;
372 Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
373 Set_Prefix (Name_Node, Prefix_Node);
374 Set_Selector_Name (Name_Node, Token_Node);
375 Scan; -- past identifier used as selector
376 goto Scan_Name_Extension;
377
378 -- If dot is at end of line and followed by nothing legal,
379 -- then assume end of name and quit (dot will be taken as
380 -- an incorrect form of some other punctuation by our caller).
381
382 elsif Token_Is_At_Start_Of_Line then
383 Restore_Scan_State (Scan_State);
384 return Name_Node;
385
386 -- Here if nothing legal after the dot
387
388 else
389 Error_Msg_AP ("selector expected");
390 raise Error_Resync;
391 end if;
392
393 -- Here for an apostrophe as name extension. The scan position at the
394 -- apostrophe has already been saved, and the apostrophe scanned out.
395
396 <<Scan_Name_Extension_Apostrophe>>
397
398 Scan_Apostrophe : declare
399 function Apostrophe_Should_Be_Semicolon return Boolean;
400 -- Checks for case where apostrophe should probably be
401 -- a semicolon, and if so, gives appropriate message,
402 -- resets the scan pointer to the apostrophe, changes
403 -- the current token to Tok_Semicolon, and returns True.
404 -- Otherwise returns False.
405
406 ------------------------------------
407 -- Apostrophe_Should_Be_Semicolon --
408 ------------------------------------
409
410 function Apostrophe_Should_Be_Semicolon return Boolean is
411 begin
412 if Token_Is_At_Start_Of_Line then
413 Restore_Scan_State (Scan_State); -- to apostrophe
414 Error_Msg_SC ("|""''"" should be "";""");
415 Token := Tok_Semicolon;
416 return True;
417 else
418 return False;
419 end if;
420 end Apostrophe_Should_Be_Semicolon;
421
422 -- Start of processing for Scan_Apostrophe
423
424 begin
425 -- Check for qualified expression case in Ada 2012 mode
426
427 if Ada_Version >= Ada_2012 and then Token = Tok_Left_Paren then
428 Name_Node := P_Qualified_Expression (Name_Node);
429 goto Scan_Name_Extension;
430
431 -- If range attribute after apostrophe, then return with Token
432 -- pointing to the apostrophe. Note that in this case the prefix
433 -- need not be a simple name (cases like A.all'range). Similarly
434 -- if there is a left paren after the apostrophe, then we also
435 -- return with Token pointing to the apostrophe (this is the
436 -- aggregate case, or some error case).
437
438 elsif Token = Tok_Range or else Token = Tok_Left_Paren then
439 Restore_Scan_State (Scan_State); -- to apostrophe
440 Expr_Form := EF_Name;
441 return Name_Node;
442
443 -- Here for cases where attribute designator is an identifier
444
445 elsif Token = Tok_Identifier then
446 Attr_Name := Token_Name;
447
448 if not Is_Attribute_Name (Attr_Name) then
449 if Apostrophe_Should_Be_Semicolon then
450 Expr_Form := EF_Name;
451 return Name_Node;
452
453 -- Here for a bad attribute name
454
455 else
456 Signal_Bad_Attribute;
457 Scan; -- past bad identifier
458
459 if Token = Tok_Left_Paren then
460 Scan; -- past left paren
461
462 loop
463 Discard_Junk_Node (P_Expression_If_OK);
464 exit when not Comma_Present;
465 end loop;
466
467 T_Right_Paren;
468 end if;
469
470 return Error;
471 end if;
472 end if;
473
474 if Style_Check then
475 Style.Check_Attribute_Name (False);
476 end if;
477
478 -- Here for case of attribute designator is not an identifier
479
480 else
481 if Token = Tok_Delta then
482 Attr_Name := Name_Delta;
483
484 elsif Token = Tok_Digits then
485 Attr_Name := Name_Digits;
486
487 elsif Token = Tok_Access then
488 Attr_Name := Name_Access;
489
490 elsif Token = Tok_Mod and then Ada_Version >= Ada_95 then
491 Attr_Name := Name_Mod;
492
493 elsif Apostrophe_Should_Be_Semicolon then
494 Expr_Form := EF_Name;
495 return Name_Node;
496
497 else
498 Error_Msg_AP ("attribute designator expected");
499 raise Error_Resync;
500 end if;
501
502 if Style_Check then
503 Style.Check_Attribute_Name (True);
504 end if;
505 end if;
506
507 -- We come here with an OK attribute scanned, and corresponding
508 -- Attribute identifier node stored in Ident_Node.
509
510 Prefix_Node := Name_Node;
511 Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr);
512 Scan; -- past attribute designator
513 Set_Prefix (Name_Node, Prefix_Node);
514 Set_Attribute_Name (Name_Node, Attr_Name);
515
516 -- Scan attribute arguments/designator. We skip this if we know
517 -- that the attribute cannot have an argument (see documentation
518 -- of Is_Parameterless_Attribute for further details).
519
520 if Token = Tok_Left_Paren
521 and then not
522 Is_Parameterless_Attribute (Get_Attribute_Id (Attr_Name))
523 then
524 -- Attribute Update contains an array or record association
525 -- list which provides new values for various components or
526 -- elements. The list is parsed as an aggregate, and we get
527 -- better error handling by knowing that in the parser.
528
529 if Attr_Name = Name_Update then
530 Set_Expressions (Name_Node, New_List);
531 Append (P_Aggregate, Expressions (Name_Node));
532
533 -- All other cases of parsing attribute arguments
534
535 else
536 Set_Expressions (Name_Node, New_List);
537 Scan; -- past left paren
538
539 loop
540 declare
541 Expr : constant Node_Id := P_Expression_If_OK;
542 Rnam : Node_Id;
543
544 begin
545 -- Case of => for named notation
546
547 if Token = Tok_Arrow then
548
549 -- Named notation allowed only for the special
550 -- case of System'Restriction_Set (No_Dependence =>
551 -- unit_NAME), in which case construct a parameter
552 -- assocation node and append to the arguments.
553
554 if Attr_Name = Name_Restriction_Set
555 and then Nkind (Expr) = N_Identifier
556 and then Chars (Expr) = Name_No_Dependence
557 then
558 Scan; -- past arrow
559 Rnam := P_Name;
560 Append_To (Expressions (Name_Node),
561 Make_Parameter_Association (Sloc (Rnam),
562 Selector_Name => Expr,
563 Explicit_Actual_Parameter => Rnam));
564 exit;
565
566 -- For all other cases named notation is illegal
567
568 else
569 Error_Msg_SC
570 ("named parameters not permitted "
571 & "for attributes");
572 Scan; -- past junk arrow
573 end if;
574
575 -- Here for normal case (not => for named parameter)
576
577 else
578 Append (Expr, Expressions (Name_Node));
579 exit when not Comma_Present;
580 end if;
581 end;
582 end loop;
583
584 T_Right_Paren;
585 end if;
586 end if;
587
588 goto Scan_Name_Extension;
589 end Scan_Apostrophe;
590
591 -- Here for left parenthesis extending name (left paren skipped)
592
593 <<Scan_Name_Extension_Left_Paren>>
594
595 -- We now have to scan through a list of items, terminated by a
596 -- right parenthesis. The scan is handled by a finite state
597 -- machine. The possibilities are:
598
599 -- (discrete_range)
600
601 -- This is a slice. This case is handled in LP_State_Init
602
603 -- (expression, expression, ..)
604
605 -- This is interpreted as an indexed component, i.e. as a
606 -- case of a name which can be extended in the normal manner.
607 -- This case is handled by LP_State_Name or LP_State_Expr.
608
609 -- Note: if and case expressions (without an extra level of
610 -- parentheses) are permitted in this context).
611
612 -- (..., identifier => expression , ...)
613
614 -- If there is at least one occurrence of identifier => (but
615 -- none of the other cases apply), then we have a call.
616
617 -- Test for Id => case
618
619 if Token = Tok_Identifier then
620 Save_Scan_State (Scan_State); -- at Id
621 Scan; -- past Id
622
623 -- Test for => (allow := as an error substitute)
624
625 if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
626 Restore_Scan_State (Scan_State); -- to Id
627 Arg_List := New_List;
628 goto LP_State_Call;
629
630 else
631 Restore_Scan_State (Scan_State); -- to Id
632 end if;
633 end if;
634
635 -- Here we have an expression after all
636
637 Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
638
639 -- Check cases of discrete range for a slice
640
641 -- First possibility: Range_Attribute_Reference
642
643 if Expr_Form = EF_Range_Attr then
644 Range_Node := Expr_Node;
645
646 -- Second possibility: Simple_expression .. Simple_expression
647
648 elsif Token = Tok_Dot_Dot then
649 Check_Simple_Expression (Expr_Node);
650 Range_Node := New_Node (N_Range, Token_Ptr);
651 Set_Low_Bound (Range_Node, Expr_Node);
652 Scan; -- past ..
653 Expr_Node := P_Expression;
654 Check_Simple_Expression (Expr_Node);
655 Set_High_Bound (Range_Node, Expr_Node);
656
657 -- Third possibility: Type_name range Range
658
659 elsif Token = Tok_Range then
660 if Expr_Form /= EF_Simple_Name then
661 Error_Msg_SC ("subtype mark must precede RANGE");
662 raise Error_Resync;
663 end if;
664
665 Range_Node := P_Subtype_Indication (Expr_Node);
666
667 -- Otherwise we just have an expression. It is true that we might
668 -- have a subtype mark without a range constraint but this case
669 -- is syntactically indistinguishable from the expression case.
670
671 else
672 Arg_List := New_List;
673 goto LP_State_Expr;
674 end if;
675
676 -- Fall through here with unmistakable Discrete range scanned,
677 -- which means that we definitely have the case of a slice. The
678 -- Discrete range is in Range_Node.
679
680 if Token = Tok_Comma then
681 Error_Msg_SC ("slice cannot have more than one dimension");
682 raise Error_Resync;
683
684 elsif Token /= Tok_Right_Paren then
685 if Token = Tok_Arrow then
686
687 -- This may be an aggregate that is missing a qualification
688
689 Error_Msg_SC
690 ("context of aggregate must be a qualified expression");
691 raise Error_Resync;
692
693 else
694 T_Right_Paren;
695 raise Error_Resync;
696 end if;
697
698 else
699 Scan; -- past right paren
700 Prefix_Node := Name_Node;
701 Name_Node := New_Node (N_Slice, Sloc (Prefix_Node));
702 Set_Prefix (Name_Node, Prefix_Node);
703 Set_Discrete_Range (Name_Node, Range_Node);
704
705 -- An operator node is legal as a prefix to other names,
706 -- but not for a slice.
707
708 if Nkind (Prefix_Node) = N_Operator_Symbol then
709 Error_Msg_N ("illegal prefix for slice", Prefix_Node);
710 end if;
711
712 -- If we have a name extension, go scan it
713
714 if Token in Token_Class_Namext then
715 goto Scan_Name_Extension_OK;
716
717 -- Otherwise return (a slice is a name, but is not a call)
718
719 else
720 Expr_Form := EF_Name;
721 return Name_Node;
722 end if;
723 end if;
724
725 -- In LP_State_Expr, we have scanned one or more expressions, and
726 -- so we have a call or an indexed component which is a name. On
727 -- entry we have the expression just scanned in Expr_Node and
728 -- Arg_List contains the list of expressions encountered so far
729
730 <<LP_State_Expr>>
731 Append (Expr_Node, Arg_List);
732
733 if Token = Tok_Arrow then
734 Error_Msg
735 ("expect identifier in parameter association", Sloc (Expr_Node));
736 Scan; -- past arrow
737
738 elsif not Comma_Present then
739 T_Right_Paren;
740
741 Prefix_Node := Name_Node;
742 Name_Node := New_Node (N_Indexed_Component, Sloc (Prefix_Node));
743 Set_Prefix (Name_Node, Prefix_Node);
744 Set_Expressions (Name_Node, Arg_List);
745
746 goto Scan_Name_Extension;
747 end if;
748
749 -- Comma present (and scanned out), test for identifier => case
750 -- Test for identifier => case
751
752 if Token = Tok_Identifier then
753 Save_Scan_State (Scan_State); -- at Id
754 Scan; -- past Id
755
756 -- Test for => (allow := as error substitute)
757
758 if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
759 Restore_Scan_State (Scan_State); -- to Id
760 goto LP_State_Call;
761
762 -- Otherwise it's just an expression after all, so backup
763
764 else
765 Restore_Scan_State (Scan_State); -- to Id
766 end if;
767 end if;
768
769 -- Here we have an expression after all, so stay in this state
770
771 Expr_Node := P_Expression_If_OK;
772 goto LP_State_Expr;
773
774 -- LP_State_Call corresponds to the situation in which at least one
775 -- instance of Id => Expression has been encountered, so we know that
776 -- we do not have a name, but rather a call. We enter it with the
777 -- scan pointer pointing to the next argument to scan, and Arg_List
778 -- containing the list of arguments scanned so far.
779
780 <<LP_State_Call>>
781
782 -- Test for case of Id => Expression (named parameter)
783
784 if Token = Tok_Identifier then
785 Save_Scan_State (Scan_State); -- at Id
786 Ident_Node := Token_Node;
787 Scan; -- past Id
788
789 -- Deal with => (allow := as incorrect substitute)
790
791 if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
792 Arg_Node := New_Node (N_Parameter_Association, Prev_Token_Ptr);
793 Set_Selector_Name (Arg_Node, Ident_Node);
794 T_Arrow;
795 Set_Explicit_Actual_Parameter (Arg_Node, P_Expression);
796 Append (Arg_Node, Arg_List);
797
798 -- If a comma follows, go back and scan next entry
799
800 if Comma_Present then
801 goto LP_State_Call;
802
803 -- Otherwise we have the end of a call
804
805 else
806 Prefix_Node := Name_Node;
807 Name_Node := New_Node (N_Function_Call, Sloc (Prefix_Node));
808 Set_Name (Name_Node, Prefix_Node);
809 Set_Parameter_Associations (Name_Node, Arg_List);
810 T_Right_Paren;
811
812 if Token in Token_Class_Namext then
813 goto Scan_Name_Extension_OK;
814
815 -- This is a case of a call which cannot be a name
816
817 else
818 Expr_Form := EF_Name;
819 return Name_Node;
820 end if;
821 end if;
822
823 -- Not named parameter: Id started an expression after all
824
825 else
826 Restore_Scan_State (Scan_State); -- to Id
827 end if;
828 end if;
829
830 -- Here if entry did not start with Id => which means that it
831 -- is a positional parameter, which is not allowed, since we
832 -- have seen at least one named parameter already.
833
834 Error_Msg_SC
835 ("positional parameter association " &
836 "not allowed after named one");
837
838 Expr_Node := P_Expression_If_OK;
839
840 -- Leaving the '>' in an association is not unusual, so suggest
841 -- a possible fix.
842
843 if Nkind (Expr_Node) = N_Op_Eq then
844 Error_Msg_N ("\maybe `='>` was intended", Expr_Node);
845 end if;
846
847 -- We go back to scanning out expressions, so that we do not get
848 -- multiple error messages when several positional parameters
849 -- follow a named parameter.
850
851 goto LP_State_Expr;
852
853 -- End of treatment for name extensions starting with left paren
854
855 -- End of loop through name extensions
856
857 end P_Name;
858
859 -- This function parses a restricted form of Names which are either
860 -- designators, or designators preceded by a sequence of prefixes
861 -- that are direct names.
862
863 -- Error recovery: cannot raise Error_Resync
864
865 function P_Function_Name return Node_Id is
866 Designator_Node : Node_Id;
867 Prefix_Node : Node_Id;
868 Selector_Node : Node_Id;
869 Dot_Sloc : Source_Ptr := No_Location;
870
871 begin
872 -- Prefix_Node is set to the gathered prefix so far, Empty means that
873 -- no prefix has been scanned. This allows us to build up the result
874 -- in the required right recursive manner.
875
876 Prefix_Node := Empty;
877
878 -- Loop through prefixes
879
880 loop
881 Designator_Node := Token_Node;
882
883 if Token not in Token_Class_Desig then
884 return P_Identifier; -- let P_Identifier issue the error message
885
886 else -- Token in Token_Class_Desig
887 Scan; -- past designator
888 exit when Token /= Tok_Dot;
889 end if;
890
891 -- Here at a dot, with token just before it in Designator_Node
892
893 if No (Prefix_Node) then
894 Prefix_Node := Designator_Node;
895 else
896 Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
897 Set_Prefix (Selector_Node, Prefix_Node);
898 Set_Selector_Name (Selector_Node, Designator_Node);
899 Prefix_Node := Selector_Node;
900 end if;
901
902 Dot_Sloc := Token_Ptr;
903 Scan; -- past dot
904 end loop;
905
906 -- Fall out of the loop having just scanned a designator
907
908 if No (Prefix_Node) then
909 return Designator_Node;
910 else
911 Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
912 Set_Prefix (Selector_Node, Prefix_Node);
913 Set_Selector_Name (Selector_Node, Designator_Node);
914 return Selector_Node;
915 end if;
916
917 exception
918 when Error_Resync =>
919 return Error;
920 end P_Function_Name;
921
922 -- This function parses a restricted form of Names which are either
923 -- identifiers, or identifiers preceded by a sequence of prefixes
924 -- that are direct names.
925
926 -- Error recovery: cannot raise Error_Resync
927
928 function P_Qualified_Simple_Name return Node_Id is
929 Designator_Node : Node_Id;
930 Prefix_Node : Node_Id;
931 Selector_Node : Node_Id;
932 Dot_Sloc : Source_Ptr := No_Location;
933
934 begin
935 -- Prefix node is set to the gathered prefix so far, Empty means that
936 -- no prefix has been scanned. This allows us to build up the result
937 -- in the required right recursive manner.
938
939 Prefix_Node := Empty;
940
941 -- Loop through prefixes
942
943 loop
944 Designator_Node := Token_Node;
945
946 if Token = Tok_Identifier then
947 Scan; -- past identifier
948 exit when Token /= Tok_Dot;
949
950 elsif Token not in Token_Class_Desig then
951 return P_Identifier; -- let P_Identifier issue the error message
952
953 else
954 Scan; -- past designator
955
956 if Token /= Tok_Dot then
957 Error_Msg_SP ("identifier expected");
958 return Error;
959 end if;
960 end if;
961
962 -- Here at a dot, with token just before it in Designator_Node
963
964 if No (Prefix_Node) then
965 Prefix_Node := Designator_Node;
966 else
967 Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
968 Set_Prefix (Selector_Node, Prefix_Node);
969 Set_Selector_Name (Selector_Node, Designator_Node);
970 Prefix_Node := Selector_Node;
971 end if;
972
973 Dot_Sloc := Token_Ptr;
974 Scan; -- past dot
975 end loop;
976
977 -- Fall out of the loop having just scanned an identifier
978
979 if No (Prefix_Node) then
980 return Designator_Node;
981 else
982 Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
983 Set_Prefix (Selector_Node, Prefix_Node);
984 Set_Selector_Name (Selector_Node, Designator_Node);
985 return Selector_Node;
986 end if;
987
988 exception
989 when Error_Resync =>
990 return Error;
991 end P_Qualified_Simple_Name;
992
993 -- This procedure differs from P_Qualified_Simple_Name only in that it
994 -- raises Error_Resync if any error is encountered. It only returns after
995 -- scanning a valid qualified simple name.
996
997 -- Error recovery: can raise Error_Resync
998
999 function P_Qualified_Simple_Name_Resync return Node_Id is
1000 Designator_Node : Node_Id;
1001 Prefix_Node : Node_Id;
1002 Selector_Node : Node_Id;
1003 Dot_Sloc : Source_Ptr := No_Location;
1004
1005 begin
1006 Prefix_Node := Empty;
1007
1008 -- Loop through prefixes
1009
1010 loop
1011 Designator_Node := Token_Node;
1012
1013 if Token = Tok_Identifier then
1014 Scan; -- past identifier
1015 exit when Token /= Tok_Dot;
1016
1017 elsif Token not in Token_Class_Desig then
1018 Discard_Junk_Node (P_Identifier); -- to issue the error message
1019 raise Error_Resync;
1020
1021 else
1022 Scan; -- past designator
1023
1024 if Token /= Tok_Dot then
1025 Error_Msg_SP ("identifier expected");
1026 raise Error_Resync;
1027 end if;
1028 end if;
1029
1030 -- Here at a dot, with token just before it in Designator_Node
1031
1032 if No (Prefix_Node) then
1033 Prefix_Node := Designator_Node;
1034 else
1035 Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
1036 Set_Prefix (Selector_Node, Prefix_Node);
1037 Set_Selector_Name (Selector_Node, Designator_Node);
1038 Prefix_Node := Selector_Node;
1039 end if;
1040
1041 Dot_Sloc := Token_Ptr;
1042 Scan; -- past period
1043 end loop;
1044
1045 -- Fall out of the loop having just scanned an identifier
1046
1047 if No (Prefix_Node) then
1048 return Designator_Node;
1049 else
1050 Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
1051 Set_Prefix (Selector_Node, Prefix_Node);
1052 Set_Selector_Name (Selector_Node, Designator_Node);
1053 return Selector_Node;
1054 end if;
1055 end P_Qualified_Simple_Name_Resync;
1056
1057 ----------------------
1058 -- 4.1 Direct_Name --
1059 ----------------------
1060
1061 -- Parsed by P_Name and other functions in section 4.1
1062
1063 -----------------
1064 -- 4.1 Prefix --
1065 -----------------
1066
1067 -- Parsed by P_Name (4.1)
1068
1069 -------------------------------
1070 -- 4.1 Explicit Dereference --
1071 -------------------------------
1072
1073 -- Parsed by P_Name (4.1)
1074
1075 -------------------------------
1076 -- 4.1 Implicit_Dereference --
1077 -------------------------------
1078
1079 -- Parsed by P_Name (4.1)
1080
1081 ----------------------------
1082 -- 4.1 Indexed Component --
1083 ----------------------------
1084
1085 -- Parsed by P_Name (4.1)
1086
1087 ----------------
1088 -- 4.1 Slice --
1089 ----------------
1090
1091 -- Parsed by P_Name (4.1)
1092
1093 -----------------------------
1094 -- 4.1 Selected_Component --
1095 -----------------------------
1096
1097 -- Parsed by P_Name (4.1)
1098
1099 ------------------------
1100 -- 4.1 Selector Name --
1101 ------------------------
1102
1103 -- Parsed by P_Name (4.1)
1104
1105 ------------------------------
1106 -- 4.1 Attribute Reference --
1107 ------------------------------
1108
1109 -- Parsed by P_Name (4.1)
1110
1111 -------------------------------
1112 -- 4.1 Attribute Designator --
1113 -------------------------------
1114
1115 -- Parsed by P_Name (4.1)
1116
1117 --------------------------------------
1118 -- 4.1.4 Range Attribute Reference --
1119 --------------------------------------
1120
1121 -- RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR
1122
1123 -- RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]
1124
1125 -- In the grammar, a RANGE attribute is simply a name, but its use is
1126 -- highly restricted, so in the parser, we do not regard it as a name.
1127 -- Instead, P_Name returns without scanning the 'RANGE part of the
1128 -- attribute, and the caller uses the following function to construct
1129 -- a range attribute in places where it is appropriate.
1130
1131 -- Note that RANGE here is treated essentially as an identifier,
1132 -- rather than a reserved word.
1133
1134 -- The caller has parsed the prefix, i.e. a name, and Token points to
1135 -- the apostrophe. The token after the apostrophe is known to be RANGE
1136 -- at this point. The prefix node becomes the prefix of the attribute.
1137
1138 -- Error_Recovery: Cannot raise Error_Resync
1139
1140 function P_Range_Attribute_Reference
1141 (Prefix_Node : Node_Id)
1142 return Node_Id
1143 is
1144 Attr_Node : Node_Id;
1145
1146 begin
1147 Attr_Node := New_Node (N_Attribute_Reference, Token_Ptr);
1148 Set_Prefix (Attr_Node, Prefix_Node);
1149 Scan; -- past apostrophe
1150
1151 if Style_Check then
1152 Style.Check_Attribute_Name (True);
1153 end if;
1154
1155 Set_Attribute_Name (Attr_Node, Name_Range);
1156 Scan; -- past RANGE
1157
1158 if Token = Tok_Left_Paren then
1159 Scan; -- past left paren
1160 Set_Expressions (Attr_Node, New_List (P_Expression_If_OK));
1161 T_Right_Paren;
1162 end if;
1163
1164 return Attr_Node;
1165 end P_Range_Attribute_Reference;
1166
1167 ---------------------------------------
1168 -- 4.1.4 Range Attribute Designator --
1169 ---------------------------------------
1170
1171 -- Parsed by P_Range_Attribute_Reference (4.4)
1172
1173 --------------------
1174 -- 4.3 Aggregate --
1175 --------------------
1176
1177 -- AGGREGATE ::= RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE
1178
1179 -- Parsed by P_Aggregate_Or_Paren_Expr (4.3), except in the case where
1180 -- an aggregate is known to be required (code statement, extension
1181 -- aggregate), in which cases this routine performs the necessary check
1182 -- that we have an aggregate rather than a parenthesized expression
1183
1184 -- Error recovery: can raise Error_Resync
1185
1186 function P_Aggregate return Node_Id is
1187 Aggr_Sloc : constant Source_Ptr := Token_Ptr;
1188 Aggr_Node : constant Node_Id := P_Aggregate_Or_Paren_Expr;
1189
1190 begin
1191 if Nkind (Aggr_Node) /= N_Aggregate
1192 and then
1193 Nkind (Aggr_Node) /= N_Extension_Aggregate
1194 then
1195 Error_Msg
1196 ("aggregate may not have single positional component", Aggr_Sloc);
1197 return Error;
1198 else
1199 return Aggr_Node;
1200 end if;
1201 end P_Aggregate;
1202
1203 ------------------------------------------------
1204 -- 4.3 Aggregate or Parenthesized Expression --
1205 ------------------------------------------------
1206
1207 -- This procedure parses out either an aggregate or a parenthesized
1208 -- expression (these two constructs are closely related, since a
1209 -- parenthesized expression looks like an aggregate with a single
1210 -- positional component).
1211
1212 -- AGGREGATE ::=
1213 -- RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE
1214
1215 -- RECORD_AGGREGATE ::= (RECORD_COMPONENT_ASSOCIATION_LIST)
1216
1217 -- RECORD_COMPONENT_ASSOCIATION_LIST ::=
1218 -- RECORD_COMPONENT_ASSOCIATION {, RECORD_COMPONENT_ASSOCIATION}
1219 -- | null record
1220
1221 -- RECORD_COMPONENT_ASSOCIATION ::=
1222 -- [COMPONENT_CHOICE_LIST =>] EXPRESSION
1223
1224 -- COMPONENT_CHOICE_LIST ::=
1225 -- component_SELECTOR_NAME {| component_SELECTOR_NAME}
1226 -- | others
1227
1228 -- EXTENSION_AGGREGATE ::=
1229 -- (ANCESTOR_PART with RECORD_COMPONENT_ASSOCIATION_LIST)
1230
1231 -- ANCESTOR_PART ::= EXPRESSION | SUBTYPE_MARK
1232
1233 -- ARRAY_AGGREGATE ::=
1234 -- POSITIONAL_ARRAY_AGGREGATE | NAMED_ARRAY_AGGREGATE
1235
1236 -- POSITIONAL_ARRAY_AGGREGATE ::=
1237 -- (EXPRESSION, EXPRESSION {, EXPRESSION})
1238 -- | (EXPRESSION {, EXPRESSION}, others => EXPRESSION)
1239 -- | (EXPRESSION {, EXPRESSION}, others => <>)
1240
1241 -- NAMED_ARRAY_AGGREGATE ::=
1242 -- (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION})
1243
1244 -- PRIMARY ::= (EXPRESSION);
1245
1246 -- Error recovery: can raise Error_Resync
1247
1248 -- Note: POSITIONAL_ARRAY_AGGREGATE rule has been extended to give support
1249 -- to Ada 2005 limited aggregates (AI-287)
1250
1251 function P_Aggregate_Or_Paren_Expr return Node_Id is
1252 Aggregate_Node : Node_Id;
1253 Expr_List : List_Id;
1254 Assoc_List : List_Id;
1255 Expr_Node : Node_Id;
1256 Lparen_Sloc : Source_Ptr;
1257 Scan_State : Saved_Scan_State;
1258
1259 procedure Box_Error;
1260 -- Called if <> is encountered as positional aggregate element. Issues
1261 -- error message and sets Expr_Node to Error.
1262
1263 ---------------
1264 -- Box_Error --
1265 ---------------
1266
1267 procedure Box_Error is
1268 begin
1269 if Ada_Version < Ada_2005 then
1270 Error_Msg_SC ("box in aggregate is an Ada 2005 extension");
1271 end if;
1272
1273 -- Ada 2005 (AI-287): The box notation is allowed only with named
1274 -- notation because positional notation might be error prone. For
1275 -- example, in "(X, <>, Y, <>)", there is no type associated with
1276 -- the boxes, so you might not be leaving out the components you
1277 -- thought you were leaving out.
1278
1279 Error_Msg_SC ("(Ada 2005) box only allowed with named notation");
1280 Scan; -- past box
1281 Expr_Node := Error;
1282 end Box_Error;
1283
1284 -- Start of processing for P_Aggregate_Or_Paren_Expr
1285
1286 begin
1287 Lparen_Sloc := Token_Ptr;
1288 T_Left_Paren;
1289
1290 -- Note on parentheses count. For cases like an if expression, the
1291 -- parens here really count as real parentheses for the paren count,
1292 -- so we adjust the paren count accordingly after scanning the expr.
1293
1294 -- If expression
1295
1296 if Token = Tok_If then
1297 Expr_Node := P_If_Expression;
1298 T_Right_Paren;
1299 Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
1300 return Expr_Node;
1301
1302 -- Case expression
1303
1304 elsif Token = Tok_Case then
1305 Expr_Node := P_Case_Expression;
1306 T_Right_Paren;
1307 Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
1308 return Expr_Node;
1309
1310 -- Quantified expression
1311
1312 elsif Token = Tok_For then
1313 Expr_Node := P_Quantified_Expression;
1314 T_Right_Paren;
1315 Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
1316 return Expr_Node;
1317
1318 -- Note: the mechanism used here of rescanning the initial expression
1319 -- is distinctly unpleasant, but it saves a lot of fiddling in scanning
1320 -- out the discrete choice list.
1321
1322 -- Deal with expression and extension aggregates first
1323
1324 elsif Token /= Tok_Others then
1325 Save_Scan_State (Scan_State); -- at start of expression
1326
1327 -- Deal with (NULL RECORD)
1328
1329 if Token = Tok_Null then
1330 Scan; -- past NULL
1331
1332 if Token = Tok_Record then
1333 Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
1334 Set_Null_Record_Present (Aggregate_Node, True);
1335 Scan; -- past RECORD
1336 T_Right_Paren;
1337 return Aggregate_Node;
1338 else
1339 Restore_Scan_State (Scan_State); -- to NULL that must be expr
1340 end if;
1341 end if;
1342
1343 -- Scan expression, handling box appearing as positional argument
1344
1345 if Token = Tok_Box then
1346 Box_Error;
1347 else
1348 Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
1349 end if;
1350
1351 -- Extension aggregate
1352
1353 if Token = Tok_With then
1354 if Nkind (Expr_Node) = N_Attribute_Reference
1355 and then Attribute_Name (Expr_Node) = Name_Range
1356 then
1357 Bad_Range_Attribute (Sloc (Expr_Node));
1358 return Error;
1359 end if;
1360
1361 if Ada_Version = Ada_83 then
1362 Error_Msg_SC ("(Ada 83) extension aggregate not allowed");
1363 end if;
1364
1365 Aggregate_Node := New_Node (N_Extension_Aggregate, Lparen_Sloc);
1366 Set_Ancestor_Part (Aggregate_Node, Expr_Node);
1367 Scan; -- past WITH
1368
1369 -- Deal with WITH NULL RECORD case
1370
1371 if Token = Tok_Null then
1372 Save_Scan_State (Scan_State); -- at NULL
1373 Scan; -- past NULL
1374
1375 if Token = Tok_Record then
1376 Scan; -- past RECORD
1377 Set_Null_Record_Present (Aggregate_Node, True);
1378 T_Right_Paren;
1379 return Aggregate_Node;
1380
1381 else
1382 Restore_Scan_State (Scan_State); -- to NULL that must be expr
1383 end if;
1384 end if;
1385
1386 if Token /= Tok_Others then
1387 Save_Scan_State (Scan_State);
1388 Expr_Node := P_Expression;
1389 else
1390 Expr_Node := Empty;
1391 end if;
1392
1393 -- Expression
1394
1395 elsif Token = Tok_Right_Paren or else Token in Token_Class_Eterm then
1396 if Nkind (Expr_Node) = N_Attribute_Reference
1397 and then Attribute_Name (Expr_Node) = Name_Range
1398 then
1399 Error_Msg
1400 ("|parentheses not allowed for range attribute", Lparen_Sloc);
1401 Scan; -- past right paren
1402 return Expr_Node;
1403 end if;
1404
1405 -- Bump paren count of expression
1406
1407 if Expr_Node /= Error then
1408 Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
1409 end if;
1410
1411 T_Right_Paren; -- past right paren (error message if none)
1412 return Expr_Node;
1413
1414 -- Normal aggregate
1415
1416 else
1417 Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
1418 end if;
1419
1420 -- Others
1421
1422 else
1423 Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
1424 Expr_Node := Empty;
1425 end if;
1426
1427 -- Prepare to scan list of component associations
1428
1429 Expr_List := No_List; -- don't set yet, maybe all named entries
1430 Assoc_List := No_List; -- don't set yet, maybe all positional entries
1431
1432 -- This loop scans through component associations. On entry to the
1433 -- loop, an expression has been scanned at the start of the current
1434 -- association unless initial token was OTHERS, in which case
1435 -- Expr_Node is set to Empty.
1436
1437 loop
1438 -- Deal with others association first. This is a named association
1439
1440 if No (Expr_Node) then
1441 if No (Assoc_List) then
1442 Assoc_List := New_List;
1443 end if;
1444
1445 Append (P_Record_Or_Array_Component_Association, Assoc_List);
1446
1447 -- Improper use of WITH
1448
1449 elsif Token = Tok_With then
1450 Error_Msg_SC ("WITH must be preceded by single expression in " &
1451 "extension aggregate");
1452 raise Error_Resync;
1453
1454 -- Range attribute can only appear as part of a discrete choice list
1455
1456 elsif Nkind (Expr_Node) = N_Attribute_Reference
1457 and then Attribute_Name (Expr_Node) = Name_Range
1458 and then Token /= Tok_Arrow
1459 and then Token /= Tok_Vertical_Bar
1460 then
1461 Bad_Range_Attribute (Sloc (Expr_Node));
1462 return Error;
1463
1464 -- Assume positional case if comma, right paren, or literal or
1465 -- identifier or OTHERS follows (the latter cases are missing
1466 -- comma cases). Also assume positional if a semicolon follows,
1467 -- which can happen if there are missing parens
1468
1469 elsif Token = Tok_Comma
1470 or else Token = Tok_Right_Paren
1471 or else Token = Tok_Others
1472 or else Token in Token_Class_Lit_Or_Name
1473 or else Token = Tok_Semicolon
1474 then
1475 if Present (Assoc_List) then
1476 Error_Msg_BC -- CODEFIX
1477 ("""='>"" expected (positional association cannot follow " &
1478 "named association)");
1479 end if;
1480
1481 if No (Expr_List) then
1482 Expr_List := New_List;
1483 end if;
1484
1485 Append (Expr_Node, Expr_List);
1486
1487 -- Check for aggregate followed by left parent, maybe missing comma
1488
1489 elsif Nkind (Expr_Node) = N_Aggregate
1490 and then Token = Tok_Left_Paren
1491 then
1492 T_Comma;
1493
1494 if No (Expr_List) then
1495 Expr_List := New_List;
1496 end if;
1497
1498 Append (Expr_Node, Expr_List);
1499
1500 -- Anything else is assumed to be a named association
1501
1502 else
1503 Restore_Scan_State (Scan_State); -- to start of expression
1504
1505 if No (Assoc_List) then
1506 Assoc_List := New_List;
1507 end if;
1508
1509 Append (P_Record_Or_Array_Component_Association, Assoc_List);
1510 end if;
1511
1512 exit when not Comma_Present;
1513
1514 -- If we are at an expression terminator, something is seriously
1515 -- wrong, so let's get out now, before we start eating up stuff
1516 -- that doesn't belong to us.
1517
1518 if Token in Token_Class_Eterm then
1519 Error_Msg_AP
1520 ("expecting expression or component association");
1521 exit;
1522 end if;
1523
1524 -- Deal with misused box
1525
1526 if Token = Tok_Box then
1527 Box_Error;
1528
1529 -- Otherwise initiate for reentry to top of loop by scanning an
1530 -- initial expression, unless the first token is OTHERS.
1531
1532 elsif Token = Tok_Others then
1533 Expr_Node := Empty;
1534
1535 else
1536 Save_Scan_State (Scan_State); -- at start of expression
1537 Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
1538
1539 end if;
1540 end loop;
1541
1542 -- All component associations (positional and named) have been scanned
1543
1544 T_Right_Paren;
1545 Set_Expressions (Aggregate_Node, Expr_List);
1546 Set_Component_Associations (Aggregate_Node, Assoc_List);
1547 return Aggregate_Node;
1548 end P_Aggregate_Or_Paren_Expr;
1549
1550 ------------------------------------------------
1551 -- 4.3 Record or Array Component Association --
1552 ------------------------------------------------
1553
1554 -- RECORD_COMPONENT_ASSOCIATION ::=
1555 -- [COMPONENT_CHOICE_LIST =>] EXPRESSION
1556 -- | COMPONENT_CHOICE_LIST => <>
1557
1558 -- COMPONENT_CHOICE_LIST =>
1559 -- component_SELECTOR_NAME {| component_SELECTOR_NAME}
1560 -- | others
1561
1562 -- ARRAY_COMPONENT_ASSOCIATION ::=
1563 -- DISCRETE_CHOICE_LIST => EXPRESSION
1564 -- | DISCRETE_CHOICE_LIST => <>
1565
1566 -- Note: this routine only handles the named cases, including others.
1567 -- Cases where the component choice list is not present have already
1568 -- been handled directly.
1569
1570 -- Error recovery: can raise Error_Resync
1571
1572 -- Note: RECORD_COMPONENT_ASSOCIATION and ARRAY_COMPONENT_ASSOCIATION
1573 -- rules have been extended to give support to Ada 2005 limited
1574 -- aggregates (AI-287)
1575
1576 function P_Record_Or_Array_Component_Association return Node_Id is
1577 Assoc_Node : Node_Id;
1578
1579 begin
1580 Assoc_Node := New_Node (N_Component_Association, Token_Ptr);
1581 Set_Choices (Assoc_Node, P_Discrete_Choice_List);
1582 Set_Sloc (Assoc_Node, Token_Ptr);
1583 TF_Arrow;
1584
1585 if Token = Tok_Box then
1586
1587 -- Ada 2005(AI-287): The box notation is used to indicate the
1588 -- default initialization of aggregate components
1589
1590 if Ada_Version < Ada_2005 then
1591 Error_Msg_SP
1592 ("component association with '<'> is an Ada 2005 extension");
1593 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1594 end if;
1595
1596 Set_Box_Present (Assoc_Node);
1597 Scan; -- Past box
1598 else
1599 Set_Expression (Assoc_Node, P_Expression);
1600 end if;
1601
1602 return Assoc_Node;
1603 end P_Record_Or_Array_Component_Association;
1604
1605 -----------------------------
1606 -- 4.3.1 Record Aggregate --
1607 -----------------------------
1608
1609 -- Case of enumeration aggregate is parsed by P_Aggregate (4.3)
1610 -- All other cases are parsed by P_Aggregate_Or_Paren_Expr (4.3)
1611
1612 ----------------------------------------------
1613 -- 4.3.1 Record Component Association List --
1614 ----------------------------------------------
1615
1616 -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1617
1618 ----------------------------------
1619 -- 4.3.1 Component Choice List --
1620 ----------------------------------
1621
1622 -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1623
1624 --------------------------------
1625 -- 4.3.1 Extension Aggregate --
1626 --------------------------------
1627
1628 -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1629
1630 --------------------------
1631 -- 4.3.1 Ancestor Part --
1632 --------------------------
1633
1634 -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1635
1636 ----------------------------
1637 -- 4.3.1 Array Aggregate --
1638 ----------------------------
1639
1640 -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1641
1642 ---------------------------------------
1643 -- 4.3.1 Positional Array Aggregate --
1644 ---------------------------------------
1645
1646 -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1647
1648 ----------------------------------
1649 -- 4.3.1 Named Array Aggregate --
1650 ----------------------------------
1651
1652 -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1653
1654 ----------------------------------------
1655 -- 4.3.1 Array Component Association --
1656 ----------------------------------------
1657
1658 -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1659
1660 ---------------------
1661 -- 4.4 Expression --
1662 ---------------------
1663
1664 -- This procedure parses EXPRESSION or CHOICE_EXPRESSION
1665
1666 -- EXPRESSION ::=
1667 -- RELATION {LOGICAL_OPERATOR RELATION}
1668
1669 -- CHOICE_EXPRESSION ::=
1670 -- CHOICE_RELATION {LOGICAL_OPERATOR CHOICE_RELATION}
1671
1672 -- LOGICAL_OPERATOR ::= and | and then | or | or else | xor
1673
1674 -- On return, Expr_Form indicates the categorization of the expression
1675 -- EF_Range_Attr is not a possible value (if a range attribute is found,
1676 -- an error message is given, and Error is returned).
1677
1678 -- Error recovery: cannot raise Error_Resync
1679
1680 function P_Expression return Node_Id is
1681 Logical_Op : Node_Kind;
1682 Prev_Logical_Op : Node_Kind;
1683 Op_Location : Source_Ptr;
1684 Node1 : Node_Id;
1685 Node2 : Node_Id;
1686
1687 begin
1688 Node1 := P_Relation;
1689
1690 if Token in Token_Class_Logop then
1691 Prev_Logical_Op := N_Empty;
1692
1693 loop
1694 Op_Location := Token_Ptr;
1695 Logical_Op := P_Logical_Operator;
1696
1697 if Prev_Logical_Op /= N_Empty and then
1698 Logical_Op /= Prev_Logical_Op
1699 then
1700 Error_Msg
1701 ("mixed logical operators in expression", Op_Location);
1702 Prev_Logical_Op := N_Empty;
1703 else
1704 Prev_Logical_Op := Logical_Op;
1705 end if;
1706
1707 Node2 := Node1;
1708 Node1 := New_Op_Node (Logical_Op, Op_Location);
1709 Set_Left_Opnd (Node1, Node2);
1710 Set_Right_Opnd (Node1, P_Relation);
1711
1712 -- Check for case of errant comma or semicolon
1713
1714 if Token = Tok_Comma or else Token = Tok_Semicolon then
1715 declare
1716 Com : constant Boolean := Token = Tok_Comma;
1717 Scan_State : Saved_Scan_State;
1718 Logop : Node_Kind;
1719
1720 begin
1721 Save_Scan_State (Scan_State); -- at comma/semicolon
1722 Scan; -- past comma/semicolon
1723
1724 -- Check for AND THEN or OR ELSE after comma/semicolon. We
1725 -- do not deal with AND/OR because those cases get mixed up
1726 -- with the select alternatives case.
1727
1728 if Token = Tok_And or else Token = Tok_Or then
1729 Logop := P_Logical_Operator;
1730 Restore_Scan_State (Scan_State); -- to comma/semicolon
1731
1732 if Nkind_In (Logop, N_And_Then, N_Or_Else) then
1733 Scan; -- past comma/semicolon
1734
1735 if Com then
1736 Error_Msg_SP -- CODEFIX
1737 ("|extra "","" ignored");
1738 else
1739 Error_Msg_SP -- CODEFIX
1740 ("|extra "";"" ignored");
1741 end if;
1742
1743 else
1744 Restore_Scan_State (Scan_State); -- to comma/semicolon
1745 end if;
1746
1747 else
1748 Restore_Scan_State (Scan_State); -- to comma/semicolon
1749 end if;
1750 end;
1751 end if;
1752
1753 exit when Token not in Token_Class_Logop;
1754 end loop;
1755
1756 Expr_Form := EF_Non_Simple;
1757 end if;
1758
1759 if Token = Tok_Apostrophe then
1760 Bad_Range_Attribute (Token_Ptr);
1761 return Error;
1762 else
1763 return Node1;
1764 end if;
1765 end P_Expression;
1766
1767 -- This function is identical to the normal P_Expression, except that it
1768 -- also permits the appearance of a case, conditional, or quantified
1769 -- expression if the call immediately follows a left paren, and followed
1770 -- by a right parenthesis. These forms are allowed if these conditions
1771 -- are not met, but an error message will be issued.
1772
1773 function P_Expression_If_OK return Node_Id is
1774 begin
1775 -- Case of conditional, case or quantified expression
1776
1777 if Token = Tok_Case or else Token = Tok_If or else Token = Tok_For then
1778 return P_Unparen_Cond_Case_Quant_Expression;
1779
1780 -- Normal case, not case/conditional/quantified expression
1781
1782 else
1783 return P_Expression;
1784 end if;
1785 end P_Expression_If_OK;
1786
1787 -- This function is identical to the normal P_Expression, except that it
1788 -- checks that the expression scan did not stop on a right paren. It is
1789 -- called in all contexts where a right parenthesis cannot legitimately
1790 -- follow an expression.
1791
1792 -- Error recovery: can not raise Error_Resync
1793
1794 function P_Expression_No_Right_Paren return Node_Id is
1795 Expr : constant Node_Id := P_Expression;
1796 begin
1797 Ignore (Tok_Right_Paren);
1798 return Expr;
1799 end P_Expression_No_Right_Paren;
1800
1801 ----------------------------------------
1802 -- 4.4 Expression_Or_Range_Attribute --
1803 ----------------------------------------
1804
1805 -- EXPRESSION ::=
1806 -- RELATION {and RELATION} | RELATION {and then RELATION}
1807 -- | RELATION {or RELATION} | RELATION {or else RELATION}
1808 -- | RELATION {xor RELATION}
1809
1810 -- RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR
1811
1812 -- RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]
1813
1814 -- On return, Expr_Form indicates the categorization of the expression
1815 -- and EF_Range_Attr is one of the possibilities.
1816
1817 -- Error recovery: cannot raise Error_Resync
1818
1819 -- In the grammar, a RANGE attribute is simply a name, but its use is
1820 -- highly restricted, so in the parser, we do not regard it as a name.
1821 -- Instead, P_Name returns without scanning the 'RANGE part of the
1822 -- attribute, and P_Expression_Or_Range_Attribute handles the range
1823 -- attribute reference. In the normal case where a range attribute is
1824 -- not allowed, an error message is issued by P_Expression.
1825
1826 function P_Expression_Or_Range_Attribute return Node_Id is
1827 Logical_Op : Node_Kind;
1828 Prev_Logical_Op : Node_Kind;
1829 Op_Location : Source_Ptr;
1830 Node1 : Node_Id;
1831 Node2 : Node_Id;
1832 Attr_Node : Node_Id;
1833
1834 begin
1835 Node1 := P_Relation;
1836
1837 if Token = Tok_Apostrophe then
1838 Attr_Node := P_Range_Attribute_Reference (Node1);
1839 Expr_Form := EF_Range_Attr;
1840 return Attr_Node;
1841
1842 elsif Token in Token_Class_Logop then
1843 Prev_Logical_Op := N_Empty;
1844
1845 loop
1846 Op_Location := Token_Ptr;
1847 Logical_Op := P_Logical_Operator;
1848
1849 if Prev_Logical_Op /= N_Empty and then
1850 Logical_Op /= Prev_Logical_Op
1851 then
1852 Error_Msg
1853 ("mixed logical operators in expression", Op_Location);
1854 Prev_Logical_Op := N_Empty;
1855 else
1856 Prev_Logical_Op := Logical_Op;
1857 end if;
1858
1859 Node2 := Node1;
1860 Node1 := New_Op_Node (Logical_Op, Op_Location);
1861 Set_Left_Opnd (Node1, Node2);
1862 Set_Right_Opnd (Node1, P_Relation);
1863 exit when Token not in Token_Class_Logop;
1864 end loop;
1865
1866 Expr_Form := EF_Non_Simple;
1867 end if;
1868
1869 if Token = Tok_Apostrophe then
1870 Bad_Range_Attribute (Token_Ptr);
1871 return Error;
1872 else
1873 return Node1;
1874 end if;
1875 end P_Expression_Or_Range_Attribute;
1876
1877 -- Version that allows a non-parenthesized case, conditional, or quantified
1878 -- expression if the call immediately follows a left paren, and followed
1879 -- by a right parenthesis. These forms are allowed if these conditions
1880 -- are not met, but an error message will be issued.
1881
1882 function P_Expression_Or_Range_Attribute_If_OK return Node_Id is
1883 begin
1884 -- Case of conditional, case or quantified expression
1885
1886 if Token = Tok_Case or else Token = Tok_If or else Token = Tok_For then
1887 return P_Unparen_Cond_Case_Quant_Expression;
1888
1889 -- Normal case, not one of the above expression types
1890
1891 else
1892 return P_Expression_Or_Range_Attribute;
1893 end if;
1894 end P_Expression_Or_Range_Attribute_If_OK;
1895
1896 -------------------
1897 -- 4.4 Relation --
1898 -------------------
1899
1900 -- This procedure scans both relations and choice relations
1901
1902 -- CHOICE_RELATION ::=
1903 -- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION]
1904
1905 -- RELATION ::=
1906 -- SIMPLE_EXPRESSION [not] in MEMBERSHIP_CHOICE_LIST
1907 -- | RAISE_EXPRESSION
1908
1909 -- MEMBERSHIP_CHOICE_LIST ::=
1910 -- MEMBERSHIP_CHOICE {'|' MEMBERSHIP CHOICE}
1911
1912 -- MEMBERSHIP_CHOICE ::=
1913 -- CHOICE_EXPRESSION | RANGE | SUBTYPE_MARK
1914
1915 -- RAISE_EXPRESSION ::= raise exception_NAME [with string_EXPRESSION]
1916
1917 -- On return, Expr_Form indicates the categorization of the expression
1918
1919 -- Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to
1920 -- EF_Simple_Name and the following token is RANGE (range attribute case).
1921
1922 -- Error recovery: cannot raise Error_Resync. If an error occurs within an
1923 -- expression, then tokens are scanned until either a non-expression token,
1924 -- a right paren (not matched by a left paren) or a comma, is encountered.
1925
1926 function P_Relation return Node_Id is
1927 Node1, Node2 : Node_Id;
1928 Optok : Source_Ptr;
1929
1930 begin
1931 -- First check for raise expression
1932
1933 if Token = Tok_Raise then
1934 Expr_Form := EF_Non_Simple;
1935 return P_Raise_Expression;
1936 end if;
1937
1938 -- All other cases
1939
1940 Node1 := P_Simple_Expression;
1941
1942 if Token not in Token_Class_Relop then
1943 return Node1;
1944
1945 else
1946 -- Here we have a relational operator following. If so then scan it
1947 -- out. Note that the assignment symbol := is treated as a relational
1948 -- operator to improve the error recovery when it is misused for =.
1949 -- P_Relational_Operator also parses the IN and NOT IN operations.
1950
1951 Optok := Token_Ptr;
1952 Node2 := New_Op_Node (P_Relational_Operator, Optok);
1953 Set_Left_Opnd (Node2, Node1);
1954
1955 -- Case of IN or NOT IN
1956
1957 if Prev_Token = Tok_In then
1958 P_Membership_Test (Node2);
1959
1960 -- Case of relational operator (= /= < <= > >=)
1961
1962 else
1963 Set_Right_Opnd (Node2, P_Simple_Expression);
1964 end if;
1965
1966 Expr_Form := EF_Non_Simple;
1967
1968 if Token in Token_Class_Relop then
1969 Error_Msg_SC ("unexpected relational operator");
1970 raise Error_Resync;
1971 end if;
1972
1973 return Node2;
1974 end if;
1975
1976 -- If any error occurs, then scan to the next expression terminator symbol
1977 -- or comma or right paren at the outer (i.e. current) parentheses level.
1978 -- The flags are set to indicate a normal simple expression.
1979
1980 exception
1981 when Error_Resync =>
1982 Resync_Expression;
1983 Expr_Form := EF_Simple;
1984 return Error;
1985 end P_Relation;
1986
1987 ----------------------------
1988 -- 4.4 Simple Expression --
1989 ----------------------------
1990
1991 -- SIMPLE_EXPRESSION ::=
1992 -- [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM}
1993
1994 -- On return, Expr_Form indicates the categorization of the expression
1995
1996 -- Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to
1997 -- EF_Simple_Name and the following token is RANGE (range attribute case).
1998
1999 -- Error recovery: cannot raise Error_Resync. If an error occurs within an
2000 -- expression, then tokens are scanned until either a non-expression token,
2001 -- a right paren (not matched by a left paren) or a comma, is encountered.
2002
2003 -- Note: P_Simple_Expression is called only internally by higher level
2004 -- expression routines. In cases in the grammar where a simple expression
2005 -- is required, the approach is to scan an expression, and then post an
2006 -- appropriate error message if the expression obtained is not simple. This
2007 -- gives better error recovery and treatment.
2008
2009 function P_Simple_Expression return Node_Id is
2010 Scan_State : Saved_Scan_State;
2011 Node1 : Node_Id;
2012 Node2 : Node_Id;
2013 Tokptr : Source_Ptr;
2014
2015 function At_Start_Of_Attribute return Boolean;
2016 -- Tests if we have quote followed by attribute name, if so, return True
2017 -- otherwise return False.
2018
2019 ---------------------------
2020 -- At_Start_Of_Attribute --
2021 ---------------------------
2022
2023 function At_Start_Of_Attribute return Boolean is
2024 begin
2025 if Token /= Tok_Apostrophe then
2026 return False;
2027
2028 else
2029 declare
2030 Scan_State : Saved_Scan_State;
2031
2032 begin
2033 Save_Scan_State (Scan_State);
2034 Scan; -- past quote
2035
2036 if Token = Tok_Identifier
2037 and then Is_Attribute_Name (Chars (Token_Node))
2038 then
2039 Restore_Scan_State (Scan_State);
2040 return True;
2041 else
2042 Restore_Scan_State (Scan_State);
2043 return False;
2044 end if;
2045 end;
2046 end if;
2047 end At_Start_Of_Attribute;
2048
2049 -- Start of processing for P_Simple_Expression
2050
2051 begin
2052 -- Check for cases starting with a name. There are two reasons for
2053 -- special casing. First speed things up by catching a common case
2054 -- without going through several routine layers. Second the caller must
2055 -- be informed via Expr_Form when the simple expression is a name.
2056
2057 if Token in Token_Class_Name then
2058 Node1 := P_Name;
2059
2060 -- Deal with apostrophe cases
2061
2062 if Token = Tok_Apostrophe then
2063 Save_Scan_State (Scan_State); -- at apostrophe
2064 Scan; -- past apostrophe
2065
2066 -- If qualified expression, scan it out and fall through
2067
2068 if Token = Tok_Left_Paren then
2069 Node1 := P_Qualified_Expression (Node1);
2070 Expr_Form := EF_Simple;
2071
2072 -- If range attribute, then we return with Token pointing to the
2073 -- apostrophe. Note: avoid the normal error check on exit. We
2074 -- know that the expression really is complete in this case.
2075
2076 else -- Token = Tok_Range then
2077 Restore_Scan_State (Scan_State); -- to apostrophe
2078 Expr_Form := EF_Simple_Name;
2079 return Node1;
2080 end if;
2081 end if;
2082
2083 -- If an expression terminator follows, the previous processing
2084 -- completely scanned out the expression (a common case), and
2085 -- left Expr_Form set appropriately for returning to our caller.
2086
2087 if Token in Token_Class_Sterm then
2088 null;
2089
2090 -- If we do not have an expression terminator, then complete the
2091 -- scan of a simple expression. This code duplicates the code
2092 -- found in P_Term and P_Factor.
2093
2094 else
2095 if Token = Tok_Double_Asterisk then
2096 if Style_Check then
2097 Style.Check_Exponentiation_Operator;
2098 end if;
2099
2100 Node2 := New_Op_Node (N_Op_Expon, Token_Ptr);
2101 Scan; -- past **
2102 Set_Left_Opnd (Node2, Node1);
2103 Set_Right_Opnd (Node2, P_Primary);
2104 Check_Bad_Exp;
2105 Node1 := Node2;
2106 end if;
2107
2108 loop
2109 exit when Token not in Token_Class_Mulop;
2110 Tokptr := Token_Ptr;
2111 Node2 := New_Op_Node (P_Multiplying_Operator, Tokptr);
2112
2113 if Style_Check then
2114 Style.Check_Binary_Operator;
2115 end if;
2116
2117 Scan; -- past operator
2118 Set_Left_Opnd (Node2, Node1);
2119 Set_Right_Opnd (Node2, P_Factor);
2120 Node1 := Node2;
2121 end loop;
2122
2123 loop
2124 exit when Token not in Token_Class_Binary_Addop;
2125 Tokptr := Token_Ptr;
2126 Node2 := New_Op_Node (P_Binary_Adding_Operator, Tokptr);
2127
2128 if Style_Check then
2129 Style.Check_Binary_Operator;
2130 end if;
2131
2132 Scan; -- past operator
2133 Set_Left_Opnd (Node2, Node1);
2134 Set_Right_Opnd (Node2, P_Term);
2135 Node1 := Node2;
2136 end loop;
2137
2138 Expr_Form := EF_Simple;
2139 end if;
2140
2141 -- Cases where simple expression does not start with a name
2142
2143 else
2144 -- Scan initial sign and initial Term
2145
2146 if Token in Token_Class_Unary_Addop then
2147 Tokptr := Token_Ptr;
2148 Node1 := New_Op_Node (P_Unary_Adding_Operator, Tokptr);
2149
2150 if Style_Check then
2151 Style.Check_Unary_Plus_Or_Minus (Inside_Depends);
2152 end if;
2153
2154 Scan; -- past operator
2155 Set_Right_Opnd (Node1, P_Term);
2156 else
2157 Node1 := P_Term;
2158 end if;
2159
2160 -- In the following, we special-case a sequence of concatenations of
2161 -- string literals, such as "aaa" & "bbb" & ... & "ccc", with nothing
2162 -- else mixed in. For such a sequence, we return a tree representing
2163 -- "" & "aaabbb...ccc" (a single concatenation). This is done only if
2164 -- the number of concatenations is large. If semantic analysis
2165 -- resolves the "&" to a predefined one, then this folding gives the
2166 -- right answer. Otherwise, semantic analysis will complain about a
2167 -- capacity-exceeded error. The purpose of this trick is to avoid
2168 -- creating a deeply nested tree, which would cause deep recursion
2169 -- during semantics, causing stack overflow. This way, we can handle
2170 -- enormous concatenations in the normal case of predefined "&". We
2171 -- first build up the normal tree, and then rewrite it if
2172 -- appropriate.
2173
2174 declare
2175 Num_Concats_Threshold : constant Positive := 1000;
2176 -- Arbitrary threshold value to enable optimization
2177
2178 First_Node : constant Node_Id := Node1;
2179 Is_Strlit_Concat : Boolean;
2180 -- True iff we've parsed a sequence of concatenations of string
2181 -- literals, with nothing else mixed in.
2182
2183 Num_Concats : Natural;
2184 -- Number of "&" operators if Is_Strlit_Concat is True
2185
2186 begin
2187 Is_Strlit_Concat :=
2188 Nkind (Node1) = N_String_Literal
2189 and then Token = Tok_Ampersand;
2190 Num_Concats := 0;
2191
2192 -- Scan out sequence of terms separated by binary adding operators
2193
2194 loop
2195 exit when Token not in Token_Class_Binary_Addop;
2196 Tokptr := Token_Ptr;
2197 Node2 := New_Op_Node (P_Binary_Adding_Operator, Tokptr);
2198
2199 if Style_Check and then not Debug_Flag_Dot_QQ then
2200 Style.Check_Binary_Operator;
2201 end if;
2202
2203 Scan; -- past operator
2204 Set_Left_Opnd (Node2, Node1);
2205 Node1 := P_Term;
2206 Set_Right_Opnd (Node2, Node1);
2207
2208 -- Check if we're still concatenating string literals
2209
2210 Is_Strlit_Concat :=
2211 Is_Strlit_Concat
2212 and then Nkind (Node2) = N_Op_Concat
2213 and then Nkind (Node1) = N_String_Literal;
2214
2215 if Is_Strlit_Concat then
2216 Num_Concats := Num_Concats + 1;
2217 end if;
2218
2219 Node1 := Node2;
2220 end loop;
2221
2222 -- If we have an enormous series of concatenations of string
2223 -- literals, rewrite as explained above. The Is_Folded_In_Parser
2224 -- flag tells semantic analysis that if the "&" is not predefined,
2225 -- the folded value is wrong.
2226
2227 if Is_Strlit_Concat
2228 and then Num_Concats >= Num_Concats_Threshold
2229 then
2230 declare
2231 Empty_String_Val : String_Id;
2232 -- String_Id for ""
2233
2234 Strlit_Concat_Val : String_Id;
2235 -- Contains the folded value (which will be correct if the
2236 -- "&" operators are the predefined ones).
2237
2238 Cur_Node : Node_Id;
2239 -- For walking up the tree
2240
2241 New_Node : Node_Id;
2242 -- Folded node to replace Node1
2243
2244 Loc : constant Source_Ptr := Sloc (First_Node);
2245
2246 begin
2247 -- Walk up the tree starting at the leftmost string literal
2248 -- (First_Node), building up the Strlit_Concat_Val as we
2249 -- go. Note that we do not use recursion here -- the whole
2250 -- point is to avoid recursively walking that enormous tree.
2251
2252 Start_String;
2253 Store_String_Chars (Strval (First_Node));
2254
2255 Cur_Node := Parent (First_Node);
2256 while Present (Cur_Node) loop
2257 pragma Assert (Nkind (Cur_Node) = N_Op_Concat and then
2258 Nkind (Right_Opnd (Cur_Node)) = N_String_Literal);
2259
2260 Store_String_Chars (Strval (Right_Opnd (Cur_Node)));
2261 Cur_Node := Parent (Cur_Node);
2262 end loop;
2263
2264 Strlit_Concat_Val := End_String;
2265
2266 -- Create new folded node, and rewrite result with a concat-
2267 -- enation of an empty string literal and the folded node.
2268
2269 Start_String;
2270 Empty_String_Val := End_String;
2271 New_Node :=
2272 Make_Op_Concat (Loc,
2273 Make_String_Literal (Loc, Empty_String_Val),
2274 Make_String_Literal (Loc, Strlit_Concat_Val,
2275 Is_Folded_In_Parser => True));
2276 Rewrite (Node1, New_Node);
2277 end;
2278 end if;
2279 end;
2280
2281 -- All done, we clearly do not have name or numeric literal so this
2282 -- is a case of a simple expression which is some other possibility.
2283
2284 Expr_Form := EF_Simple;
2285 end if;
2286
2287 -- Come here at end of simple expression, where we do a couple of
2288 -- special checks to improve error recovery.
2289
2290 -- Special test to improve error recovery. If the current token
2291 -- is a period, then someone is trying to do selection on something
2292 -- that is not a name, e.g. a qualified expression.
2293
2294 if Token = Tok_Dot then
2295 Error_Msg_SC ("prefix for selection is not a name");
2296
2297 -- If qualified expression, comment and continue, otherwise something
2298 -- is pretty nasty so do an Error_Resync call.
2299
2300 if Ada_Version < Ada_2012
2301 and then Nkind (Node1) = N_Qualified_Expression
2302 then
2303 Error_Msg_SC ("\would be legal in Ada 2012 mode");
2304 else
2305 raise Error_Resync;
2306 end if;
2307 end if;
2308
2309 -- Special test to improve error recovery: If the current token is
2310 -- not the first token on a line (as determined by checking the
2311 -- previous token position with the start of the current line),
2312 -- then we insist that we have an appropriate terminating token.
2313 -- Consider the following two examples:
2314
2315 -- 1) if A nad B then ...
2316
2317 -- 2) A := B
2318 -- C := D
2319
2320 -- In the first example, we would like to issue a binary operator
2321 -- expected message and resynchronize to the then. In the second
2322 -- example, we do not want to issue a binary operator message, so
2323 -- that instead we will get the missing semicolon message. This
2324 -- distinction is of course a heuristic which does not always work,
2325 -- but in practice it is quite effective.
2326
2327 -- Note: the one case in which we do not go through this circuit is
2328 -- when we have scanned a range attribute and want to return with
2329 -- Token pointing to the apostrophe. The apostrophe is not normally
2330 -- an expression terminator, and is not in Token_Class_Sterm, but
2331 -- in this special case we know that the expression is complete.
2332
2333 if not Token_Is_At_Start_Of_Line
2334 and then Token not in Token_Class_Sterm
2335 then
2336 -- Normally the right error message is indeed that we expected a
2337 -- binary operator, but in the case of being between a right and left
2338 -- paren, e.g. in an aggregate, a more likely error is missing comma.
2339
2340 if Prev_Token = Tok_Right_Paren and then Token = Tok_Left_Paren then
2341 T_Comma;
2342
2343 -- And if we have a quote, we may have a bad attribute
2344
2345 elsif At_Start_Of_Attribute then
2346 Error_Msg_SC ("prefix of attribute must be a name");
2347
2348 if Ada_Version >= Ada_2012 then
2349 Error_Msg_SC ("\qualify expression to turn it into a name");
2350 end if;
2351
2352 -- Normal case for binary operator expected message
2353
2354 else
2355 Error_Msg_AP ("binary operator expected");
2356 end if;
2357
2358 raise Error_Resync;
2359
2360 else
2361 return Node1;
2362 end if;
2363
2364 -- If any error occurs, then scan to next expression terminator symbol
2365 -- or comma, right paren or vertical bar at the outer (i.e. current) paren
2366 -- level. Expr_Form is set to indicate a normal simple expression.
2367
2368 exception
2369 when Error_Resync =>
2370 Resync_Expression;
2371 Expr_Form := EF_Simple;
2372 return Error;
2373 end P_Simple_Expression;
2374
2375 -----------------------------------------------
2376 -- 4.4 Simple Expression or Range Attribute --
2377 -----------------------------------------------
2378
2379 -- SIMPLE_EXPRESSION ::=
2380 -- [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM}
2381
2382 -- RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR
2383
2384 -- RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]
2385
2386 -- Error recovery: cannot raise Error_Resync
2387
2388 function P_Simple_Expression_Or_Range_Attribute return Node_Id is
2389 Sexpr : Node_Id;
2390 Attr_Node : Node_Id;
2391
2392 begin
2393 -- We don't just want to roar ahead and call P_Simple_Expression
2394 -- here, since we want to handle the case of a parenthesized range
2395 -- attribute cleanly.
2396
2397 if Token = Tok_Left_Paren then
2398 declare
2399 Lptr : constant Source_Ptr := Token_Ptr;
2400 Scan_State : Saved_Scan_State;
2401
2402 begin
2403 Save_Scan_State (Scan_State);
2404 Scan; -- past left paren
2405 Sexpr := P_Simple_Expression;
2406
2407 if Token = Tok_Apostrophe then
2408 Attr_Node := P_Range_Attribute_Reference (Sexpr);
2409 Expr_Form := EF_Range_Attr;
2410
2411 if Token = Tok_Right_Paren then
2412 Scan; -- scan past right paren if present
2413 end if;
2414
2415 Error_Msg ("parentheses not allowed for range attribute", Lptr);
2416
2417 return Attr_Node;
2418 end if;
2419
2420 Restore_Scan_State (Scan_State);
2421 end;
2422 end if;
2423
2424 -- Here after dealing with parenthesized range attribute
2425
2426 Sexpr := P_Simple_Expression;
2427
2428 if Token = Tok_Apostrophe then
2429 Attr_Node := P_Range_Attribute_Reference (Sexpr);
2430 Expr_Form := EF_Range_Attr;
2431 return Attr_Node;
2432
2433 else
2434 return Sexpr;
2435 end if;
2436 end P_Simple_Expression_Or_Range_Attribute;
2437
2438 ---------------
2439 -- 4.4 Term --
2440 ---------------
2441
2442 -- TERM ::= FACTOR {MULTIPLYING_OPERATOR FACTOR}
2443
2444 -- Error recovery: can raise Error_Resync
2445
2446 function P_Term return Node_Id is
2447 Node1, Node2 : Node_Id;
2448 Tokptr : Source_Ptr;
2449
2450 begin
2451 Node1 := P_Factor;
2452
2453 loop
2454 exit when Token not in Token_Class_Mulop;
2455 Tokptr := Token_Ptr;
2456 Node2 := New_Op_Node (P_Multiplying_Operator, Tokptr);
2457
2458 if Style_Check and then not Debug_Flag_Dot_QQ then
2459 Style.Check_Binary_Operator;
2460 end if;
2461
2462 Scan; -- past operator
2463 Set_Left_Opnd (Node2, Node1);
2464 Set_Right_Opnd (Node2, P_Factor);
2465 Node1 := Node2;
2466 end loop;
2467
2468 return Node1;
2469 end P_Term;
2470
2471 -----------------
2472 -- 4.4 Factor --
2473 -----------------
2474
2475 -- FACTOR ::= PRIMARY [** PRIMARY] | abs PRIMARY | not PRIMARY
2476
2477 -- Error recovery: can raise Error_Resync
2478
2479 function P_Factor return Node_Id is
2480 Node1 : Node_Id;
2481 Node2 : Node_Id;
2482
2483 begin
2484 if Token = Tok_Abs then
2485 Node1 := New_Op_Node (N_Op_Abs, Token_Ptr);
2486
2487 if Style_Check then
2488 Style.Check_Abs_Not;
2489 end if;
2490
2491 Scan; -- past ABS
2492 Set_Right_Opnd (Node1, P_Primary);
2493 return Node1;
2494
2495 elsif Token = Tok_Not then
2496 Node1 := New_Op_Node (N_Op_Not, Token_Ptr);
2497
2498 if Style_Check then
2499 Style.Check_Abs_Not;
2500 end if;
2501
2502 Scan; -- past NOT
2503 Set_Right_Opnd (Node1, P_Primary);
2504 return Node1;
2505
2506 else
2507 Node1 := P_Primary;
2508
2509 if Token = Tok_Double_Asterisk then
2510 Node2 := New_Op_Node (N_Op_Expon, Token_Ptr);
2511 Scan; -- past **
2512 Set_Left_Opnd (Node2, Node1);
2513 Set_Right_Opnd (Node2, P_Primary);
2514 Check_Bad_Exp;
2515 return Node2;
2516 else
2517 return Node1;
2518 end if;
2519 end if;
2520 end P_Factor;
2521
2522 ------------------
2523 -- 4.4 Primary --
2524 ------------------
2525
2526 -- PRIMARY ::=
2527 -- NUMERIC_LITERAL | null
2528 -- | STRING_LITERAL | AGGREGATE
2529 -- | NAME | QUALIFIED_EXPRESSION
2530 -- | ALLOCATOR | (EXPRESSION) | QUANTIFIED_EXPRESSION
2531
2532 -- Error recovery: can raise Error_Resync
2533
2534 function P_Primary return Node_Id is
2535 Scan_State : Saved_Scan_State;
2536 Node1 : Node_Id;
2537
2538 Lparen : constant Boolean := Prev_Token = Tok_Left_Paren;
2539 -- Remember if previous token is a left parenthesis. This is used to
2540 -- deal with checking whether IF/CASE/FOR expressions appearing as
2541 -- primaries require extra parenthesization.
2542
2543 begin
2544 -- The loop runs more than once only if misplaced pragmas are found
2545 -- or if a misplaced unary minus is skipped.
2546
2547 loop
2548 case Token is
2549
2550 -- Name token can start a name, call or qualified expression, all
2551 -- of which are acceptable possibilities for primary. Note also
2552 -- that string literal is included in name (as operator symbol)
2553 -- and type conversion is included in name (as indexed component).
2554
2555 when Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier =>
2556 Node1 := P_Name;
2557
2558 -- All done unless apostrophe follows
2559
2560 if Token /= Tok_Apostrophe then
2561 return Node1;
2562
2563 -- Apostrophe following means that we have either just parsed
2564 -- the subtype mark of a qualified expression, or the prefix
2565 -- or a range attribute.
2566
2567 else -- Token = Tok_Apostrophe
2568 Save_Scan_State (Scan_State); -- at apostrophe
2569 Scan; -- past apostrophe
2570
2571 -- If range attribute, then this is always an error, since
2572 -- the only legitimate case (where the scanned expression is
2573 -- a qualified simple name) is handled at the level of the
2574 -- Simple_Expression processing. This case corresponds to a
2575 -- usage such as 3 + A'Range, which is always illegal.
2576
2577 if Token = Tok_Range then
2578 Restore_Scan_State (Scan_State); -- to apostrophe
2579 Bad_Range_Attribute (Token_Ptr);
2580 return Error;
2581
2582 -- If left paren, then we have a qualified expression.
2583 -- Note that P_Name guarantees that in this case, where
2584 -- Token = Tok_Apostrophe on return, the only two possible
2585 -- tokens following the apostrophe are left paren and
2586 -- RANGE, so we know we have a left paren here.
2587
2588 else -- Token = Tok_Left_Paren
2589 return P_Qualified_Expression (Node1);
2590
2591 end if;
2592 end if;
2593
2594 -- Numeric or string literal
2595
2596 when Tok_Integer_Literal |
2597 Tok_Real_Literal |
2598 Tok_String_Literal =>
2599
2600 Node1 := Token_Node;
2601 Scan; -- past number
2602 return Node1;
2603
2604 -- Left paren, starts aggregate or parenthesized expression
2605
2606 when Tok_Left_Paren =>
2607 declare
2608 Expr : constant Node_Id := P_Aggregate_Or_Paren_Expr;
2609
2610 begin
2611 if Nkind (Expr) = N_Attribute_Reference
2612 and then Attribute_Name (Expr) = Name_Range
2613 then
2614 Bad_Range_Attribute (Sloc (Expr));
2615 end if;
2616
2617 return Expr;
2618 end;
2619
2620 -- Allocator
2621
2622 when Tok_New =>
2623 return P_Allocator;
2624
2625 -- Null
2626
2627 when Tok_Null =>
2628 Scan; -- past NULL
2629 return New_Node (N_Null, Prev_Token_Ptr);
2630
2631 -- Pragma, not allowed here, so just skip past it
2632
2633 when Tok_Pragma =>
2634 P_Pragmas_Misplaced;
2635
2636 -- Deal with IF (possible unparenthesized if expression)
2637
2638 when Tok_If =>
2639
2640 -- If this looks like a real if, defined as an IF appearing at
2641 -- the start of a new line, then we consider we have a missing
2642 -- operand. If in Ada 2012 and the IF is not properly indented
2643 -- for a statement, we prefer to issue a message about an ill-
2644 -- parenthesized if expression.
2645
2646 if Token_Is_At_Start_Of_Line
2647 and then not
2648 (Ada_Version >= Ada_2012
2649 and then Style_Check_Indentation /= 0
2650 and then Start_Column rem Style_Check_Indentation /= 0)
2651 then
2652 Error_Msg_AP ("missing operand");
2653 return Error;
2654
2655 -- If this looks like an if expression, then treat it that way
2656 -- with an error message if not explicitly surrounded by
2657 -- parentheses.
2658
2659 elsif Ada_Version >= Ada_2012 then
2660 Node1 := P_If_Expression;
2661
2662 if not (Lparen and then Token = Tok_Right_Paren) then
2663 Error_Msg
2664 ("if expression must be parenthesized", Sloc (Node1));
2665 end if;
2666
2667 return Node1;
2668
2669 -- Otherwise treat as misused identifier
2670
2671 else
2672 return P_Identifier;
2673 end if;
2674
2675 -- Deal with CASE (possible unparenthesized case expression)
2676
2677 when Tok_Case =>
2678
2679 -- If this looks like a real case, defined as a CASE appearing
2680 -- the start of a new line, then we consider we have a missing
2681 -- operand. If in Ada 2012 and the CASE is not properly
2682 -- indented for a statement, we prefer to issue a message about
2683 -- an ill-parenthesized case expression.
2684
2685 if Token_Is_At_Start_Of_Line
2686 and then not
2687 (Ada_Version >= Ada_2012
2688 and then Style_Check_Indentation /= 0
2689 and then Start_Column rem Style_Check_Indentation /= 0)
2690 then
2691 Error_Msg_AP ("missing operand");
2692 return Error;
2693
2694 -- If this looks like a case expression, then treat it that way
2695 -- with an error message if not within parentheses.
2696
2697 elsif Ada_Version >= Ada_2012 then
2698 Node1 := P_Case_Expression;
2699
2700 if not (Lparen and then Token = Tok_Right_Paren) then
2701 Error_Msg
2702 ("case expression must be parenthesized", Sloc (Node1));
2703 end if;
2704
2705 return Node1;
2706
2707 -- Otherwise treat as misused identifier
2708
2709 else
2710 return P_Identifier;
2711 end if;
2712
2713 -- For [all | some] indicates a quantified expression
2714
2715 when Tok_For =>
2716 if Token_Is_At_Start_Of_Line then
2717 Error_Msg_AP ("misplaced loop");
2718 return Error;
2719
2720 elsif Ada_Version >= Ada_2012 then
2721 Node1 := P_Quantified_Expression;
2722
2723 if not (Lparen and then Token = Tok_Right_Paren) then
2724 Error_Msg
2725 ("quantified expression must be parenthesized",
2726 Sloc (Node1));
2727 end if;
2728
2729 return Node1;
2730
2731 -- Otherwise treat as misused identifier
2732
2733 else
2734 return P_Identifier;
2735 end if;
2736
2737 -- Minus may well be an improper attempt at a unary minus. Give
2738 -- a message, skip the minus and keep going.
2739
2740 when Tok_Minus =>
2741 Error_Msg_SC ("parentheses required for unary minus");
2742 Scan; -- past minus
2743
2744 -- Anything else is illegal as the first token of a primary, but
2745 -- we test for some common errors, to improve error messages.
2746
2747 when others =>
2748 if Is_Reserved_Identifier then
2749 return P_Identifier;
2750
2751 elsif Prev_Token = Tok_Comma then
2752 Error_Msg_SP -- CODEFIX
2753 ("|extra "","" ignored");
2754 raise Error_Resync;
2755
2756 else
2757 Error_Msg_AP ("missing operand");
2758 raise Error_Resync;
2759 end if;
2760
2761 end case;
2762 end loop;
2763 end P_Primary;
2764
2765 -------------------------------
2766 -- 4.4 Quantified_Expression --
2767 -------------------------------
2768
2769 -- QUANTIFIED_EXPRESSION ::=
2770 -- for QUANTIFIER LOOP_PARAMETER_SPECIFICATION => PREDICATE |
2771 -- for QUANTIFIER ITERATOR_SPECIFICATION => PREDICATE
2772
2773 function P_Quantified_Expression return Node_Id is
2774 I_Spec : Node_Id;
2775 Node1 : Node_Id;
2776
2777 begin
2778 Error_Msg_Ada_2012_Feature ("quantified expression", Token_Ptr);
2779 Scan; -- past FOR
2780 Node1 := New_Node (N_Quantified_Expression, Prev_Token_Ptr);
2781
2782 if Token = Tok_All then
2783 Set_All_Present (Node1);
2784 elsif Token /= Tok_Some then
2785 Error_Msg_AP ("missing quantifier");
2786 raise Error_Resync;
2787 end if;
2788
2789 Scan; -- past SOME
2790 I_Spec := P_Loop_Parameter_Specification;
2791
2792 if Nkind (I_Spec) = N_Loop_Parameter_Specification then
2793 Set_Loop_Parameter_Specification (Node1, I_Spec);
2794 else
2795 Set_Iterator_Specification (Node1, I_Spec);
2796 end if;
2797
2798 if Token = Tok_Arrow then
2799 Scan;
2800 Set_Condition (Node1, P_Expression);
2801 return Node1;
2802 else
2803 Error_Msg_AP ("missing arrow");
2804 raise Error_Resync;
2805 end if;
2806 end P_Quantified_Expression;
2807
2808 ---------------------------
2809 -- 4.5 Logical Operator --
2810 ---------------------------
2811
2812 -- LOGICAL_OPERATOR ::= and | or | xor
2813
2814 -- Note: AND THEN and OR ELSE are also treated as logical operators
2815 -- by the parser (even though they are not operators semantically)
2816
2817 -- The value returned is the appropriate Node_Kind code for the operator
2818 -- On return, Token points to the token following the scanned operator.
2819
2820 -- The caller has checked that the first token is a legitimate logical
2821 -- operator token (i.e. is either XOR, AND, OR).
2822
2823 -- Error recovery: cannot raise Error_Resync
2824
2825 function P_Logical_Operator return Node_Kind is
2826 begin
2827 if Token = Tok_And then
2828 if Style_Check then
2829 Style.Check_Binary_Operator;
2830 end if;
2831
2832 Scan; -- past AND
2833
2834 if Token = Tok_Then then
2835 Scan; -- past THEN
2836 return N_And_Then;
2837 else
2838 return N_Op_And;
2839 end if;
2840
2841 elsif Token = Tok_Or then
2842 if Style_Check then
2843 Style.Check_Binary_Operator;
2844 end if;
2845
2846 Scan; -- past OR
2847
2848 if Token = Tok_Else then
2849 Scan; -- past ELSE
2850 return N_Or_Else;
2851 else
2852 return N_Op_Or;
2853 end if;
2854
2855 else -- Token = Tok_Xor
2856 if Style_Check then
2857 Style.Check_Binary_Operator;
2858 end if;
2859
2860 Scan; -- past XOR
2861 return N_Op_Xor;
2862 end if;
2863 end P_Logical_Operator;
2864
2865 ------------------------------
2866 -- 4.5 Relational Operator --
2867 ------------------------------
2868
2869 -- RELATIONAL_OPERATOR ::= = | /= | < | <= | > | >=
2870
2871 -- The value returned is the appropriate Node_Kind code for the operator.
2872 -- On return, Token points to the operator token, NOT past it.
2873
2874 -- The caller has checked that the first token is a legitimate relational
2875 -- operator token (i.e. is one of the operator tokens listed above).
2876
2877 -- Error recovery: cannot raise Error_Resync
2878
2879 function P_Relational_Operator return Node_Kind is
2880 Op_Kind : Node_Kind;
2881 Relop_Node : constant array (Token_Class_Relop) of Node_Kind :=
2882 (Tok_Less => N_Op_Lt,
2883 Tok_Equal => N_Op_Eq,
2884 Tok_Greater => N_Op_Gt,
2885 Tok_Not_Equal => N_Op_Ne,
2886 Tok_Greater_Equal => N_Op_Ge,
2887 Tok_Less_Equal => N_Op_Le,
2888 Tok_In => N_In,
2889 Tok_Not => N_Not_In,
2890 Tok_Box => N_Op_Ne);
2891
2892 begin
2893 if Token = Tok_Box then
2894 Error_Msg_SC -- CODEFIX
2895 ("|""'<'>"" should be ""/=""");
2896 end if;
2897
2898 Op_Kind := Relop_Node (Token);
2899
2900 if Style_Check then
2901 Style.Check_Binary_Operator;
2902 end if;
2903
2904 Scan; -- past operator token
2905
2906 -- Deal with NOT IN, if previous token was NOT, we must have IN now
2907
2908 if Prev_Token = Tok_Not then
2909
2910 -- Style check, for NOT IN, we require one space between NOT and IN
2911
2912 if Style_Check and then Token = Tok_In then
2913 Style.Check_Not_In;
2914 end if;
2915
2916 T_In;
2917 end if;
2918
2919 return Op_Kind;
2920 end P_Relational_Operator;
2921
2922 ---------------------------------
2923 -- 4.5 Binary Adding Operator --
2924 ---------------------------------
2925
2926 -- BINARY_ADDING_OPERATOR ::= + | - | &
2927
2928 -- The value returned is the appropriate Node_Kind code for the operator.
2929 -- On return, Token points to the operator token (NOT past it).
2930
2931 -- The caller has checked that the first token is a legitimate adding
2932 -- operator token (i.e. is one of the operator tokens listed above).
2933
2934 -- Error recovery: cannot raise Error_Resync
2935
2936 function P_Binary_Adding_Operator return Node_Kind is
2937 Addop_Node : constant array (Token_Class_Binary_Addop) of Node_Kind :=
2938 (Tok_Ampersand => N_Op_Concat,
2939 Tok_Minus => N_Op_Subtract,
2940 Tok_Plus => N_Op_Add);
2941 begin
2942 return Addop_Node (Token);
2943 end P_Binary_Adding_Operator;
2944
2945 --------------------------------
2946 -- 4.5 Unary Adding Operator --
2947 --------------------------------
2948
2949 -- UNARY_ADDING_OPERATOR ::= + | -
2950
2951 -- The value returned is the appropriate Node_Kind code for the operator.
2952 -- On return, Token points to the operator token (NOT past it).
2953
2954 -- The caller has checked that the first token is a legitimate adding
2955 -- operator token (i.e. is one of the operator tokens listed above).
2956
2957 -- Error recovery: cannot raise Error_Resync
2958
2959 function P_Unary_Adding_Operator return Node_Kind is
2960 Addop_Node : constant array (Token_Class_Unary_Addop) of Node_Kind :=
2961 (Tok_Minus => N_Op_Minus,
2962 Tok_Plus => N_Op_Plus);
2963 begin
2964 return Addop_Node (Token);
2965 end P_Unary_Adding_Operator;
2966
2967 -------------------------------
2968 -- 4.5 Multiplying Operator --
2969 -------------------------------
2970
2971 -- MULTIPLYING_OPERATOR ::= * | / | mod | rem
2972
2973 -- The value returned is the appropriate Node_Kind code for the operator.
2974 -- On return, Token points to the operator token (NOT past it).
2975
2976 -- The caller has checked that the first token is a legitimate multiplying
2977 -- operator token (i.e. is one of the operator tokens listed above).
2978
2979 -- Error recovery: cannot raise Error_Resync
2980
2981 function P_Multiplying_Operator return Node_Kind is
2982 Mulop_Node : constant array (Token_Class_Mulop) of Node_Kind :=
2983 (Tok_Asterisk => N_Op_Multiply,
2984 Tok_Mod => N_Op_Mod,
2985 Tok_Rem => N_Op_Rem,
2986 Tok_Slash => N_Op_Divide);
2987 begin
2988 return Mulop_Node (Token);
2989 end P_Multiplying_Operator;
2990
2991 --------------------------------------
2992 -- 4.5 Highest Precedence Operator --
2993 --------------------------------------
2994
2995 -- Parsed by P_Factor (4.4)
2996
2997 -- Note: this rule is not in fact used by the grammar at any point
2998
2999 --------------------------
3000 -- 4.6 Type Conversion --
3001 --------------------------
3002
3003 -- Parsed by P_Primary as a Name (4.1)
3004
3005 -------------------------------
3006 -- 4.7 Qualified Expression --
3007 -------------------------------
3008
3009 -- QUALIFIED_EXPRESSION ::=
3010 -- SUBTYPE_MARK ' (EXPRESSION) | SUBTYPE_MARK ' AGGREGATE
3011
3012 -- The caller has scanned the name which is the Subtype_Mark parameter
3013 -- and scanned past the single quote following the subtype mark. The
3014 -- caller has not checked that this name is in fact appropriate for
3015 -- a subtype mark name (i.e. it is a selected component or identifier).
3016
3017 -- Error_Recovery: cannot raise Error_Resync
3018
3019 function P_Qualified_Expression (Subtype_Mark : Node_Id) return Node_Id is
3020 Qual_Node : Node_Id;
3021 begin
3022 Qual_Node := New_Node (N_Qualified_Expression, Prev_Token_Ptr);
3023 Set_Subtype_Mark (Qual_Node, Check_Subtype_Mark (Subtype_Mark));
3024 Set_Expression (Qual_Node, P_Aggregate_Or_Paren_Expr);
3025 return Qual_Node;
3026 end P_Qualified_Expression;
3027
3028 --------------------
3029 -- 4.8 Allocator --
3030 --------------------
3031
3032 -- ALLOCATOR ::=
3033 -- new [SUBPOOL_SPECIFICATION] SUBTYPE_INDICATION
3034 -- | new [SUBPOOL_SPECIFICATION] QUALIFIED_EXPRESSION
3035 --
3036 -- SUBPOOL_SPECIFICATION ::= (subpool_handle_NAME)
3037
3038 -- The caller has checked that the initial token is NEW
3039
3040 -- Error recovery: can raise Error_Resync
3041
3042 function P_Allocator return Node_Id is
3043 Alloc_Node : Node_Id;
3044 Type_Node : Node_Id;
3045 Null_Exclusion_Present : Boolean;
3046
3047 begin
3048 Alloc_Node := New_Node (N_Allocator, Token_Ptr);
3049 T_New;
3050
3051 -- Scan subpool_specification if present (Ada 2012 (AI05-0111-3))
3052
3053 -- Scan Null_Exclusion if present (Ada 2005 (AI-231))
3054
3055 if Token = Tok_Left_Paren then
3056 Scan; -- past (
3057 Set_Subpool_Handle_Name (Alloc_Node, P_Name);
3058 T_Right_Paren;
3059
3060 Error_Msg_Ada_2012_Feature
3061 ("|subpool specification",
3062 Sloc (Subpool_Handle_Name (Alloc_Node)));
3063 end if;
3064
3065 Null_Exclusion_Present := P_Null_Exclusion;
3066 Set_Null_Exclusion_Present (Alloc_Node, Null_Exclusion_Present);
3067 Type_Node := P_Subtype_Mark_Resync;
3068
3069 if Token = Tok_Apostrophe then
3070 Scan; -- past apostrophe
3071 Set_Expression (Alloc_Node, P_Qualified_Expression (Type_Node));
3072 else
3073 Set_Expression
3074 (Alloc_Node,
3075 P_Subtype_Indication (Type_Node, Null_Exclusion_Present));
3076
3077 -- AI05-0104: An explicit null exclusion is not allowed for an
3078 -- allocator without initialization. In previous versions of the
3079 -- language it just raises constraint error.
3080
3081 if Ada_Version >= Ada_2012 and then Null_Exclusion_Present then
3082 Error_Msg_N
3083 ("an allocator with a subtype indication "
3084 & "cannot have a null exclusion", Alloc_Node);
3085 end if;
3086 end if;
3087
3088 return Alloc_Node;
3089 end P_Allocator;
3090
3091 -----------------------
3092 -- P_Case_Expression --
3093 -----------------------
3094
3095 function P_Case_Expression return Node_Id is
3096 Loc : constant Source_Ptr := Token_Ptr;
3097 Case_Node : Node_Id;
3098 Save_State : Saved_Scan_State;
3099
3100 begin
3101 Error_Msg_Ada_2012_Feature ("|case expression", Token_Ptr);
3102 Scan; -- past CASE
3103 Case_Node :=
3104 Make_Case_Expression (Loc,
3105 Expression => P_Expression_No_Right_Paren,
3106 Alternatives => New_List);
3107 T_Is;
3108
3109 -- We now have scanned out CASE expression IS, scan alternatives
3110
3111 loop
3112 T_When;
3113 Append_To (Alternatives (Case_Node), P_Case_Expression_Alternative);
3114
3115 -- Missing comma if WHEN (more alternatives present)
3116
3117 if Token = Tok_When then
3118 T_Comma;
3119
3120 -- If comma/WHEN, skip comma and we have another alternative
3121
3122 elsif Token = Tok_Comma then
3123 Save_Scan_State (Save_State);
3124 Scan; -- past comma
3125
3126 if Token /= Tok_When then
3127 Restore_Scan_State (Save_State);
3128 exit;
3129 end if;
3130
3131 -- If no comma or WHEN, definitely done
3132
3133 else
3134 exit;
3135 end if;
3136 end loop;
3137
3138 -- If we have an END CASE, diagnose as not needed
3139
3140 if Token = Tok_End then
3141 Error_Msg_SC ("`END CASE` not allowed at end of case expression");
3142 Scan; -- past END
3143
3144 if Token = Tok_Case then
3145 Scan; -- past CASE;
3146 end if;
3147 end if;
3148
3149 -- Return the Case_Expression node
3150
3151 return Case_Node;
3152 end P_Case_Expression;
3153
3154 -----------------------------------
3155 -- P_Case_Expression_Alternative --
3156 -----------------------------------
3157
3158 -- CASE_STATEMENT_ALTERNATIVE ::=
3159 -- when DISCRETE_CHOICE_LIST =>
3160 -- EXPRESSION
3161
3162 -- The caller has checked that and scanned past the initial WHEN token
3163 -- Error recovery: can raise Error_Resync
3164
3165 function P_Case_Expression_Alternative return Node_Id is
3166 Case_Alt_Node : Node_Id;
3167 begin
3168 Case_Alt_Node := New_Node (N_Case_Expression_Alternative, Token_Ptr);
3169 Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List);
3170 TF_Arrow;
3171 Set_Expression (Case_Alt_Node, P_Expression);
3172 return Case_Alt_Node;
3173 end P_Case_Expression_Alternative;
3174
3175 ---------------------
3176 -- P_If_Expression --
3177 ---------------------
3178
3179 function P_If_Expression return Node_Id is
3180
3181 function P_If_Expression_Internal
3182 (Loc : Source_Ptr;
3183 Cond : Node_Id) return Node_Id;
3184 -- This is the internal recursive routine that does all the work, it is
3185 -- recursive since it is used to process ELSIF parts, which internally
3186 -- are N_If_Expression nodes with the Is_Elsif flag set. The calling
3187 -- sequence is like the outer function except that the caller passes
3188 -- the conditional expression (scanned using P_Expression), and the
3189 -- scan pointer points just past this expression. Loc points to the
3190 -- IF or ELSIF token.
3191
3192 ------------------------------
3193 -- P_If_Expression_Internal --
3194 ------------------------------
3195
3196 function P_If_Expression_Internal
3197 (Loc : Source_Ptr;
3198 Cond : Node_Id) return Node_Id
3199 is
3200 Exprs : constant List_Id := New_List;
3201 Expr : Node_Id;
3202 State : Saved_Scan_State;
3203 Eptr : Source_Ptr;
3204
3205 begin
3206 -- All cases except where we are at right paren
3207
3208 if Token /= Tok_Right_Paren then
3209 TF_Then;
3210 Append_To (Exprs, P_Condition (Cond));
3211 Append_To (Exprs, P_Expression);
3212
3213 -- Case of right paren (missing THEN phrase). Note that we know this
3214 -- is the IF case, since the caller dealt with this possibility in
3215 -- the ELSIF case.
3216
3217 else
3218 Error_Msg_BC ("missing THEN phrase");
3219 Append_To (Exprs, P_Condition (Cond));
3220 end if;
3221
3222 -- We now have scanned out IF expr THEN expr
3223
3224 -- Check for common error of semicolon before the ELSE
3225
3226 if Token = Tok_Semicolon then
3227 Save_Scan_State (State);
3228 Scan; -- past semicolon
3229
3230 if Token = Tok_Else or else Token = Tok_Elsif then
3231 Error_Msg_SP -- CODEFIX
3232 ("|extra "";"" ignored");
3233
3234 else
3235 Restore_Scan_State (State);
3236 end if;
3237 end if;
3238
3239 -- Scan out ELSIF sequence if present
3240
3241 if Token = Tok_Elsif then
3242 Eptr := Token_Ptr;
3243 Scan; -- past ELSIF
3244 Expr := P_Expression;
3245
3246 -- If we are at a right paren, we assume the ELSIF should be ELSE
3247
3248 if Token = Tok_Right_Paren then
3249 Error_Msg ("ELSIF should be ELSE", Eptr);
3250 Append_To (Exprs, Expr);
3251
3252 -- Otherwise we have an OK ELSIF
3253
3254 else
3255 Expr := P_If_Expression_Internal (Eptr, Expr);
3256 Set_Is_Elsif (Expr);
3257 Append_To (Exprs, Expr);
3258 end if;
3259
3260 -- Scan out ELSE phrase if present
3261
3262 elsif Token = Tok_Else then
3263
3264 -- Scan out ELSE expression
3265
3266 Scan; -- Past ELSE
3267 Append_To (Exprs, P_Expression);
3268
3269 -- Skip redundant ELSE parts
3270
3271 while Token = Tok_Else loop
3272 Error_Msg_SC ("only one ELSE part is allowed");
3273 Scan; -- past ELSE
3274 Discard_Junk_Node (P_Expression);
3275 end loop;
3276
3277 -- Two expression case (implied True, filled in during semantics)
3278
3279 else
3280 null;
3281 end if;
3282
3283 -- If we have an END IF, diagnose as not needed
3284
3285 if Token = Tok_End then
3286 Error_Msg_SC ("`END IF` not allowed at end of if expression");
3287 Scan; -- past END
3288
3289 if Token = Tok_If then
3290 Scan; -- past IF;
3291 end if;
3292 end if;
3293
3294 -- Return the If_Expression node
3295
3296 return Make_If_Expression (Loc, Expressions => Exprs);
3297 end P_If_Expression_Internal;
3298
3299 -- Local variables
3300
3301 Loc : constant Source_Ptr := Token_Ptr;
3302 If_Expr : Node_Id;
3303
3304 -- Start of processing for P_If_Expression
3305
3306 begin
3307 Error_Msg_Ada_2012_Feature ("|if expression", Token_Ptr);
3308 Scan; -- past IF
3309 Inside_If_Expression := Inside_If_Expression + 1;
3310 If_Expr := P_If_Expression_Internal (Loc, P_Expression);
3311 Inside_If_Expression := Inside_If_Expression - 1;
3312 return If_Expr;
3313 end P_If_Expression;
3314
3315 -----------------------
3316 -- P_Membership_Test --
3317 -----------------------
3318
3319 -- MEMBERSHIP_CHOICE_LIST ::= MEMBERHIP_CHOICE {'|' MEMBERSHIP_CHOICE}
3320 -- MEMBERSHIP_CHOICE ::= CHOICE_EXPRESSION | range | subtype_mark
3321
3322 procedure P_Membership_Test (N : Node_Id) is
3323 Alt : constant Node_Id :=
3324 P_Range_Or_Subtype_Mark
3325 (Allow_Simple_Expression => (Ada_Version >= Ada_2012));
3326
3327 begin
3328 -- Set case
3329
3330 if Token = Tok_Vertical_Bar then
3331 Error_Msg_Ada_2012_Feature ("set notation", Token_Ptr);
3332 Set_Alternatives (N, New_List (Alt));
3333 Set_Right_Opnd (N, Empty);
3334
3335 -- Loop to accumulate alternatives
3336
3337 while Token = Tok_Vertical_Bar loop
3338 Scan; -- past vertical bar
3339 Append_To
3340 (Alternatives (N),
3341 P_Range_Or_Subtype_Mark (Allow_Simple_Expression => True));
3342 end loop;
3343
3344 -- Not set case
3345
3346 else
3347 Set_Right_Opnd (N, Alt);
3348 Set_Alternatives (N, No_List);
3349 end if;
3350 end P_Membership_Test;
3351
3352 ------------------------------------------
3353 -- P_Unparen_Cond_Case_Quant_Expression --
3354 ------------------------------------------
3355
3356 function P_Unparen_Cond_Case_Quant_Expression return Node_Id is
3357 Lparen : constant Boolean := Prev_Token = Tok_Left_Paren;
3358 Result : Node_Id;
3359
3360 begin
3361 -- Case expression
3362
3363 if Token = Tok_Case then
3364 Result := P_Case_Expression;
3365
3366 if not (Lparen and then Token = Tok_Right_Paren) then
3367 Error_Msg_N ("case expression must be parenthesized!", Result);
3368 end if;
3369
3370 -- If expression
3371
3372 elsif Token = Tok_If then
3373 Result := P_If_Expression;
3374
3375 if not (Lparen and then Token = Tok_Right_Paren) then
3376 Error_Msg_N ("if expression must be parenthesized!", Result);
3377 end if;
3378
3379 -- Quantified expression
3380
3381 elsif Token = Tok_For then
3382 Result := P_Quantified_Expression;
3383
3384 if not (Lparen and then Token = Tok_Right_Paren) then
3385 Error_Msg_N
3386 ("quantified expression must be parenthesized!", Result);
3387 end if;
3388
3389 -- No other possibility should exist (caller was supposed to check)
3390
3391 else
3392 raise Program_Error;
3393 end if;
3394
3395 -- Return expression (possibly after having given message)
3396
3397 return Result;
3398 end P_Unparen_Cond_Case_Quant_Expression;
3399
3400 end Ch4;