PR target/58115
[official-gcc.git] / gcc / ada / par-ch4.adb
blobcdf0dab653ab64071f3c566b6b5af3e4364b7783
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-2013, 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 ------------------------------------------------------------------------------
26 pragma Style_Checks (All_Checks);
27 -- Turn off subprogram body ordering check. Subprograms are in order
28 -- by RM section rather than alphabetical
30 with Stringt; use Stringt;
32 separate (Par)
33 package body Ch4 is
35 -- Attributes that cannot have arguments
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_Stub_Type => True,
45 Attribute_Version => True,
46 Attribute_Type_Key => True,
47 others => False);
48 -- This map contains True for parameterless attributes that return a
49 -- string or a type. For those attributes, a left parenthesis after
50 -- the attribute should not be analyzed as the beginning of a parameters
51 -- list because it may denote a slice operation (X'Img (1 .. 2)) or
52 -- a type conversion (X'Class (Y)).
54 -- Note: Loop_Entry is in this list because, although it can take an
55 -- optional argument (the loop name), we can't distinguish that at parse
56 -- time from the case where no loop name is given and a legitimate index
57 -- expression is present. So we parse the argument as an indexed component
58 -- and the semantic analysis sorts out this syntactic ambiguity based on
59 -- the type and form of the expression.
61 -- Note that this map designates the minimum set of attributes where a
62 -- construct in parentheses that is not an argument can appear right
63 -- after the attribute. For attributes like 'Size, we do not put them
64 -- in the map. If someone writes X'Size (3), that's illegal in any case,
65 -- but we get a better error message by parsing the (3) as an illegal
66 -- argument to the attribute, rather than some meaningless junk that
67 -- follows the attribute.
69 -----------------------
70 -- Local Subprograms --
71 -----------------------
73 function P_Aggregate_Or_Paren_Expr return Node_Id;
74 function P_Allocator return Node_Id;
75 function P_Case_Expression_Alternative return Node_Id;
76 function P_Record_Or_Array_Component_Association return Node_Id;
77 function P_Factor return Node_Id;
78 function P_Primary return Node_Id;
79 function P_Relation return Node_Id;
80 function P_Term return Node_Id;
82 function P_Binary_Adding_Operator return Node_Kind;
83 function P_Logical_Operator return Node_Kind;
84 function P_Multiplying_Operator return Node_Kind;
85 function P_Relational_Operator return Node_Kind;
86 function P_Unary_Adding_Operator return Node_Kind;
88 procedure Bad_Range_Attribute (Loc : Source_Ptr);
89 -- Called to place complaint about bad range attribute at the given
90 -- source location. Terminates by raising Error_Resync.
92 procedure Check_Bad_Exp;
93 -- Called after scanning a**b, posts error if ** detected
95 procedure P_Membership_Test (N : Node_Id);
96 -- N is the node for a N_In or N_Not_In node whose right operand has not
97 -- yet been processed. It is called just after scanning out the IN keyword.
98 -- On return, either Right_Opnd or Alternatives is set, as appropriate.
100 function P_Range_Attribute_Reference (Prefix_Node : Node_Id) return Node_Id;
101 -- Scan a range attribute reference. The caller has scanned out the
102 -- prefix. The current token is known to be an apostrophe and the
103 -- following token is known to be RANGE.
105 function P_Unparen_Cond_Case_Quant_Expression return Node_Id;
106 -- This function is called with Token pointing to IF, CASE, or FOR, in a
107 -- context that allows a case, conditional, or quantified expression if
108 -- it is surrounded by parentheses. If not surrounded by parentheses, the
109 -- expression is still returned, but an error message is issued.
111 -------------------------
112 -- Bad_Range_Attribute --
113 -------------------------
115 procedure Bad_Range_Attribute (Loc : Source_Ptr) is
116 begin
117 Error_Msg ("range attribute cannot be used in expression!", Loc);
118 Resync_Expression;
119 end Bad_Range_Attribute;
121 -------------------
122 -- Check_Bad_Exp --
123 -------------------
125 procedure Check_Bad_Exp is
126 begin
127 if Token = Tok_Double_Asterisk then
128 Error_Msg_SC ("parenthesization required for '*'*");
129 Scan; -- past **
130 Discard_Junk_Node (P_Primary);
131 Check_Bad_Exp;
132 end if;
133 end Check_Bad_Exp;
135 --------------------------
136 -- 4.1 Name (also 6.4) --
137 --------------------------
139 -- NAME ::=
140 -- DIRECT_NAME | EXPLICIT_DEREFERENCE
141 -- | INDEXED_COMPONENT | SLICE
142 -- | SELECTED_COMPONENT | ATTRIBUTE
143 -- | TYPE_CONVERSION | FUNCTION_CALL
144 -- | CHARACTER_LITERAL
146 -- DIRECT_NAME ::= IDENTIFIER | OPERATOR_SYMBOL
148 -- PREFIX ::= NAME | IMPLICIT_DEREFERENCE
150 -- EXPLICIT_DEREFERENCE ::= NAME . all
152 -- IMPLICIT_DEREFERENCE ::= NAME
154 -- INDEXED_COMPONENT ::= PREFIX (EXPRESSION {, EXPRESSION})
156 -- SLICE ::= PREFIX (DISCRETE_RANGE)
158 -- SELECTED_COMPONENT ::= PREFIX . SELECTOR_NAME
160 -- SELECTOR_NAME ::= IDENTIFIER | CHARACTER_LITERAL | OPERATOR_SYMBOL
162 -- ATTRIBUTE_REFERENCE ::= PREFIX ' ATTRIBUTE_DESIGNATOR
164 -- ATTRIBUTE_DESIGNATOR ::=
165 -- IDENTIFIER [(static_EXPRESSION)]
166 -- | access | delta | digits
168 -- FUNCTION_CALL ::=
169 -- function_NAME
170 -- | function_PREFIX ACTUAL_PARAMETER_PART
172 -- ACTUAL_PARAMETER_PART ::=
173 -- (PARAMETER_ASSOCIATION {,PARAMETER_ASSOCIATION})
175 -- PARAMETER_ASSOCIATION ::=
176 -- [formal_parameter_SELECTOR_NAME =>] EXPLICIT_ACTUAL_PARAMETER
178 -- EXPLICIT_ACTUAL_PARAMETER ::= EXPRESSION | variable_NAME
180 -- Note: syntactically a procedure call looks just like a function call,
181 -- so this routine is in practice used to scan out procedure calls as well.
183 -- On return, Expr_Form is set to either EF_Name or EF_Simple_Name
185 -- Error recovery: can raise Error_Resync
187 -- Note: if on return Token = Tok_Apostrophe, then the apostrophe must be
188 -- followed by either a left paren (qualified expression case), or by
189 -- range (range attribute case). All other uses of apostrophe (i.e. all
190 -- other attributes) are handled in this routine.
192 -- Error recovery: can raise Error_Resync
194 function P_Name return Node_Id is
195 Scan_State : Saved_Scan_State;
196 Name_Node : Node_Id;
197 Prefix_Node : Node_Id;
198 Ident_Node : Node_Id;
199 Expr_Node : Node_Id;
200 Range_Node : Node_Id;
201 Arg_Node : Node_Id;
203 Arg_List : List_Id := No_List; -- kill junk warning
204 Attr_Name : Name_Id := No_Name; -- kill junk warning
206 begin
207 -- Case of not a name
209 if Token not in Token_Class_Name then
211 -- If it looks like start of expression, complain and scan expression
213 if Token in Token_Class_Literal
214 or else Token = Tok_Left_Paren
215 then
216 Error_Msg_SC ("name expected");
217 return P_Expression;
219 -- Otherwise some other junk, not much we can do
221 else
222 Error_Msg_AP ("name expected");
223 raise Error_Resync;
224 end if;
225 end if;
227 -- Loop through designators in qualified name
229 Name_Node := Token_Node;
231 loop
232 Scan; -- past designator
233 exit when Token /= Tok_Dot;
234 Save_Scan_State (Scan_State); -- at dot
235 Scan; -- past dot
237 -- If we do not have another designator after the dot, then join
238 -- the normal circuit to handle a dot extension (may be .all or
239 -- character literal case). Otherwise loop back to scan the next
240 -- designator.
242 if Token not in Token_Class_Desig then
243 goto Scan_Name_Extension_Dot;
244 else
245 Prefix_Node := Name_Node;
246 Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
247 Set_Prefix (Name_Node, Prefix_Node);
248 Set_Selector_Name (Name_Node, Token_Node);
249 end if;
250 end loop;
252 -- We have now scanned out a qualified designator. If the last token is
253 -- an operator symbol, then we certainly do not have the Snam case, so
254 -- we can just use the normal name extension check circuit
256 if Prev_Token = Tok_Operator_Symbol then
257 goto Scan_Name_Extension;
258 end if;
260 -- We have scanned out a qualified simple name, check for name extension
261 -- Note that we know there is no dot here at this stage, so the only
262 -- possible cases of name extension are apostrophe and left paren.
264 if Token = Tok_Apostrophe then
265 Save_Scan_State (Scan_State); -- at apostrophe
266 Scan; -- past apostrophe
268 -- Qualified expression in Ada 2012 mode (treated as a name)
270 if Ada_Version >= Ada_2012 and then Token = Tok_Left_Paren then
271 goto Scan_Name_Extension_Apostrophe;
273 -- If left paren not in Ada 2012, then it is not part of the name,
274 -- since qualified expressions are not names in prior versions of
275 -- Ada, so return with Token backed up to point to the apostrophe.
276 -- The treatment for the range attribute is similar (we do not
277 -- consider x'range to be a name in this grammar).
279 elsif Token = Tok_Left_Paren or else Token = Tok_Range then
280 Restore_Scan_State (Scan_State); -- to apostrophe
281 Expr_Form := EF_Simple_Name;
282 return Name_Node;
284 -- Otherwise we have the case of a name extended by an attribute
286 else
287 goto Scan_Name_Extension_Apostrophe;
288 end if;
290 -- Check case of qualified simple name extended by a left parenthesis
292 elsif Token = Tok_Left_Paren then
293 Scan; -- past left paren
294 goto Scan_Name_Extension_Left_Paren;
296 -- Otherwise the qualified simple name is not extended, so return
298 else
299 Expr_Form := EF_Simple_Name;
300 return Name_Node;
301 end if;
303 -- Loop scanning past name extensions. A label is used for control
304 -- transfer for this loop for ease of interfacing with the finite state
305 -- machine in the parenthesis scanning circuit, and also to allow for
306 -- passing in control to the appropriate point from the above code.
308 <<Scan_Name_Extension>>
310 -- Character literal used as name cannot be extended. Also this
311 -- cannot be a call, since the name for a call must be a designator.
312 -- Return in these cases, or if there is no name extension
314 if Token not in Token_Class_Namext
315 or else Prev_Token = Tok_Char_Literal
316 then
317 Expr_Form := EF_Name;
318 return Name_Node;
319 end if;
321 -- Merge here when we know there is a name extension
323 <<Scan_Name_Extension_OK>>
325 if Token = Tok_Left_Paren then
326 Scan; -- past left paren
327 goto Scan_Name_Extension_Left_Paren;
329 elsif Token = Tok_Apostrophe then
330 Save_Scan_State (Scan_State); -- at apostrophe
331 Scan; -- past apostrophe
332 goto Scan_Name_Extension_Apostrophe;
334 else -- Token = Tok_Dot
335 Save_Scan_State (Scan_State); -- at dot
336 Scan; -- past dot
337 goto Scan_Name_Extension_Dot;
338 end if;
340 -- Case of name extended by dot (selection), dot is already skipped
341 -- and the scan state at the point of the dot is saved in Scan_State.
343 <<Scan_Name_Extension_Dot>>
345 -- Explicit dereference case
347 if Token = Tok_All then
348 Prefix_Node := Name_Node;
349 Name_Node := New_Node (N_Explicit_Dereference, Token_Ptr);
350 Set_Prefix (Name_Node, Prefix_Node);
351 Scan; -- past ALL
352 goto Scan_Name_Extension;
354 -- Selected component case
356 elsif Token in Token_Class_Name then
357 Prefix_Node := Name_Node;
358 Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
359 Set_Prefix (Name_Node, Prefix_Node);
360 Set_Selector_Name (Name_Node, Token_Node);
361 Scan; -- past selector
362 goto Scan_Name_Extension;
364 -- Reserved identifier as selector
366 elsif Is_Reserved_Identifier then
367 Scan_Reserved_Identifier (Force_Msg => False);
368 Prefix_Node := Name_Node;
369 Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
370 Set_Prefix (Name_Node, Prefix_Node);
371 Set_Selector_Name (Name_Node, Token_Node);
372 Scan; -- past identifier used as selector
373 goto Scan_Name_Extension;
375 -- If dot is at end of line and followed by nothing legal,
376 -- then assume end of name and quit (dot will be taken as
377 -- an erroneous form of some other punctuation by our caller).
379 elsif Token_Is_At_Start_Of_Line then
380 Restore_Scan_State (Scan_State);
381 return Name_Node;
383 -- Here if nothing legal after the dot
385 else
386 Error_Msg_AP ("selector expected");
387 raise Error_Resync;
388 end if;
390 -- Here for an apostrophe as name extension. The scan position at the
391 -- apostrophe has already been saved, and the apostrophe scanned out.
393 <<Scan_Name_Extension_Apostrophe>>
395 Scan_Apostrophe : declare
396 function Apostrophe_Should_Be_Semicolon return Boolean;
397 -- Checks for case where apostrophe should probably be
398 -- a semicolon, and if so, gives appropriate message,
399 -- resets the scan pointer to the apostrophe, changes
400 -- the current token to Tok_Semicolon, and returns True.
401 -- Otherwise returns False.
403 ------------------------------------
404 -- Apostrophe_Should_Be_Semicolon --
405 ------------------------------------
407 function Apostrophe_Should_Be_Semicolon return Boolean is
408 begin
409 if Token_Is_At_Start_Of_Line then
410 Restore_Scan_State (Scan_State); -- to apostrophe
411 Error_Msg_SC ("|""''"" should be "";""");
412 Token := Tok_Semicolon;
413 return True;
414 else
415 return False;
416 end if;
417 end Apostrophe_Should_Be_Semicolon;
419 -- Start of processing for Scan_Apostrophe
421 begin
422 -- Check for qualified expression case in Ada 2012 mode
424 if Ada_Version >= Ada_2012 and then Token = Tok_Left_Paren then
425 Name_Node := P_Qualified_Expression (Name_Node);
426 goto Scan_Name_Extension;
428 -- If range attribute after apostrophe, then return with Token
429 -- pointing to the apostrophe. Note that in this case the prefix
430 -- need not be a simple name (cases like A.all'range). Similarly
431 -- if there is a left paren after the apostrophe, then we also
432 -- return with Token pointing to the apostrophe (this is the
433 -- aggregate case, or some error case).
435 elsif Token = Tok_Range or else Token = Tok_Left_Paren then
436 Restore_Scan_State (Scan_State); -- to apostrophe
437 Expr_Form := EF_Name;
438 return Name_Node;
440 -- Here for cases where attribute designator is an identifier
442 elsif Token = Tok_Identifier then
443 Attr_Name := Token_Name;
445 if not Is_Attribute_Name (Attr_Name) then
446 if Apostrophe_Should_Be_Semicolon then
447 Expr_Form := EF_Name;
448 return Name_Node;
450 -- Here for a bad attribute name
452 else
453 Signal_Bad_Attribute;
454 Scan; -- past bad identifier
456 if Token = Tok_Left_Paren then
457 Scan; -- past left paren
459 loop
460 Discard_Junk_Node (P_Expression_If_OK);
461 exit when not Comma_Present;
462 end loop;
464 T_Right_Paren;
465 end if;
467 return Error;
468 end if;
469 end if;
471 if Style_Check then
472 Style.Check_Attribute_Name (False);
473 end if;
475 -- Here for case of attribute designator is not an identifier
477 else
478 if Token = Tok_Delta then
479 Attr_Name := Name_Delta;
481 elsif Token = Tok_Digits then
482 Attr_Name := Name_Digits;
484 elsif Token = Tok_Access then
485 Attr_Name := Name_Access;
487 elsif Token = Tok_Mod and then Ada_Version >= Ada_95 then
488 Attr_Name := Name_Mod;
490 elsif Apostrophe_Should_Be_Semicolon then
491 Expr_Form := EF_Name;
492 return Name_Node;
494 else
495 Error_Msg_AP ("attribute designator expected");
496 raise Error_Resync;
497 end if;
499 if Style_Check then
500 Style.Check_Attribute_Name (True);
501 end if;
502 end if;
504 -- We come here with an OK attribute scanned, and corresponding
505 -- Attribute identifier node stored in Ident_Node.
507 Prefix_Node := Name_Node;
508 Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr);
509 Scan; -- past attribute designator
510 Set_Prefix (Name_Node, Prefix_Node);
511 Set_Attribute_Name (Name_Node, Attr_Name);
513 -- Scan attribute arguments/designator. We skip this if we know
514 -- that the attribute cannot have an argument (see documentation
515 -- of Is_Parameterless_Attribute for further details).
517 if Token = Tok_Left_Paren
518 and then not
519 Is_Parameterless_Attribute (Get_Attribute_Id (Attr_Name))
520 then
521 -- Attribute Update contains an array or record association
522 -- list which provides new values for various components or
523 -- elements. The list is parsed as an aggregate, and we get
524 -- better error handling by knowing that in the parser.
526 if Attr_Name = Name_Update then
527 Set_Expressions (Name_Node, New_List);
528 Append (P_Aggregate, Expressions (Name_Node));
530 -- All other cases of parsing attribute arguments
532 else
533 Set_Expressions (Name_Node, New_List);
534 Scan; -- past left paren
536 loop
537 declare
538 Expr : constant Node_Id := P_Expression_If_OK;
539 Rnam : Node_Id;
541 begin
542 -- Case of => for named notation
544 if Token = Tok_Arrow then
546 -- Named notation allowed only for the special
547 -- case of System'Restriction_Set (No_Dependence =>
548 -- unit_NAME), in which case construct a parameter
549 -- assocation node and append to the arguments.
551 if Attr_Name = Name_Restriction_Set
552 and then Nkind (Expr) = N_Identifier
553 and then Chars (Expr) = Name_No_Dependence
554 then
555 Scan; -- past arrow
556 Rnam := P_Name;
557 Append_To (Expressions (Name_Node),
558 Make_Parameter_Association (Sloc (Rnam),
559 Selector_Name => Expr,
560 Explicit_Actual_Parameter => Rnam));
561 exit;
563 -- For all other cases named notation is illegal
565 else
566 Error_Msg_SC
567 ("named parameters not permitted "
568 & "for attributes");
569 Scan; -- past junk arrow
570 end if;
572 -- Here for normal case (not => for named parameter)
574 else
575 Append (Expr, Expressions (Name_Node));
576 exit when not Comma_Present;
577 end if;
578 end;
579 end loop;
581 T_Right_Paren;
582 end if;
583 end if;
585 goto Scan_Name_Extension;
586 end Scan_Apostrophe;
588 -- Here for left parenthesis extending name (left paren skipped)
590 <<Scan_Name_Extension_Left_Paren>>
592 -- We now have to scan through a list of items, terminated by a
593 -- right parenthesis. The scan is handled by a finite state
594 -- machine. The possibilities are:
596 -- (discrete_range)
598 -- This is a slice. This case is handled in LP_State_Init
600 -- (expression, expression, ..)
602 -- This is interpreted as an indexed component, i.e. as a
603 -- case of a name which can be extended in the normal manner.
604 -- This case is handled by LP_State_Name or LP_State_Expr.
606 -- Note: if and case expressions (without an extra level of
607 -- parentheses) are permitted in this context).
609 -- (..., identifier => expression , ...)
611 -- If there is at least one occurrence of identifier => (but
612 -- none of the other cases apply), then we have a call.
614 -- Test for Id => case
616 if Token = Tok_Identifier then
617 Save_Scan_State (Scan_State); -- at Id
618 Scan; -- past Id
620 -- Test for => (allow := as an error substitute)
622 if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
623 Restore_Scan_State (Scan_State); -- to Id
624 Arg_List := New_List;
625 goto LP_State_Call;
627 else
628 Restore_Scan_State (Scan_State); -- to Id
629 end if;
630 end if;
632 -- Here we have an expression after all
634 Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
636 -- Check cases of discrete range for a slice
638 -- First possibility: Range_Attribute_Reference
640 if Expr_Form = EF_Range_Attr then
641 Range_Node := Expr_Node;
643 -- Second possibility: Simple_expression .. Simple_expression
645 elsif Token = Tok_Dot_Dot then
646 Check_Simple_Expression (Expr_Node);
647 Range_Node := New_Node (N_Range, Token_Ptr);
648 Set_Low_Bound (Range_Node, Expr_Node);
649 Scan; -- past ..
650 Expr_Node := P_Expression;
651 Check_Simple_Expression (Expr_Node);
652 Set_High_Bound (Range_Node, Expr_Node);
654 -- Third possibility: Type_name range Range
656 elsif Token = Tok_Range then
657 if Expr_Form /= EF_Simple_Name then
658 Error_Msg_SC ("subtype mark must precede RANGE");
659 raise Error_Resync;
660 end if;
662 Range_Node := P_Subtype_Indication (Expr_Node);
664 -- Otherwise we just have an expression. It is true that we might
665 -- have a subtype mark without a range constraint but this case
666 -- is syntactically indistinguishable from the expression case.
668 else
669 Arg_List := New_List;
670 goto LP_State_Expr;
671 end if;
673 -- Fall through here with unmistakable Discrete range scanned,
674 -- which means that we definitely have the case of a slice. The
675 -- Discrete range is in Range_Node.
677 if Token = Tok_Comma then
678 Error_Msg_SC ("slice cannot have more than one dimension");
679 raise Error_Resync;
681 elsif Token /= Tok_Right_Paren then
682 if Token = Tok_Arrow then
684 -- This may be an aggregate that is missing a qualification
686 Error_Msg_SC
687 ("context of aggregate must be a qualified expression");
688 raise Error_Resync;
690 else
691 T_Right_Paren;
692 raise Error_Resync;
693 end if;
695 else
696 Scan; -- past right paren
697 Prefix_Node := Name_Node;
698 Name_Node := New_Node (N_Slice, Sloc (Prefix_Node));
699 Set_Prefix (Name_Node, Prefix_Node);
700 Set_Discrete_Range (Name_Node, Range_Node);
702 -- An operator node is legal as a prefix to other names,
703 -- but not for a slice.
705 if Nkind (Prefix_Node) = N_Operator_Symbol then
706 Error_Msg_N ("illegal prefix for slice", Prefix_Node);
707 end if;
709 -- If we have a name extension, go scan it
711 if Token in Token_Class_Namext then
712 goto Scan_Name_Extension_OK;
714 -- Otherwise return (a slice is a name, but is not a call)
716 else
717 Expr_Form := EF_Name;
718 return Name_Node;
719 end if;
720 end if;
722 -- In LP_State_Expr, we have scanned one or more expressions, and
723 -- so we have a call or an indexed component which is a name. On
724 -- entry we have the expression just scanned in Expr_Node and
725 -- Arg_List contains the list of expressions encountered so far
727 <<LP_State_Expr>>
728 Append (Expr_Node, Arg_List);
730 if Token = Tok_Arrow then
731 Error_Msg
732 ("expect identifier in parameter association", Sloc (Expr_Node));
733 Scan; -- past arrow
735 elsif not Comma_Present then
736 T_Right_Paren;
738 Prefix_Node := Name_Node;
739 Name_Node := New_Node (N_Indexed_Component, Sloc (Prefix_Node));
740 Set_Prefix (Name_Node, Prefix_Node);
741 Set_Expressions (Name_Node, Arg_List);
743 goto Scan_Name_Extension;
744 end if;
746 -- Comma present (and scanned out), test for identifier => case
747 -- Test for identifier => case
749 if Token = Tok_Identifier then
750 Save_Scan_State (Scan_State); -- at Id
751 Scan; -- past Id
753 -- Test for => (allow := as error substitute)
755 if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
756 Restore_Scan_State (Scan_State); -- to Id
757 goto LP_State_Call;
759 -- Otherwise it's just an expression after all, so backup
761 else
762 Restore_Scan_State (Scan_State); -- to Id
763 end if;
764 end if;
766 -- Here we have an expression after all, so stay in this state
768 Expr_Node := P_Expression_If_OK;
769 goto LP_State_Expr;
771 -- LP_State_Call corresponds to the situation in which at least
772 -- one instance of Id => Expression has been encountered, so we
773 -- know that we do not have a name, but rather a call. We enter
774 -- it with the scan pointer pointing to the next argument to scan,
775 -- and Arg_List containing the list of arguments scanned so far.
777 <<LP_State_Call>>
779 -- Test for case of Id => Expression (named parameter)
781 if Token = Tok_Identifier then
782 Save_Scan_State (Scan_State); -- at Id
783 Ident_Node := Token_Node;
784 Scan; -- past Id
786 -- Deal with => (allow := as erroneous substitute)
788 if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
789 Arg_Node := New_Node (N_Parameter_Association, Prev_Token_Ptr);
790 Set_Selector_Name (Arg_Node, Ident_Node);
791 T_Arrow;
792 Set_Explicit_Actual_Parameter (Arg_Node, P_Expression);
793 Append (Arg_Node, Arg_List);
795 -- If a comma follows, go back and scan next entry
797 if Comma_Present then
798 goto LP_State_Call;
800 -- Otherwise we have the end of a call
802 else
803 Prefix_Node := Name_Node;
804 Name_Node := New_Node (N_Function_Call, Sloc (Prefix_Node));
805 Set_Name (Name_Node, Prefix_Node);
806 Set_Parameter_Associations (Name_Node, Arg_List);
807 T_Right_Paren;
809 if Token in Token_Class_Namext then
810 goto Scan_Name_Extension_OK;
812 -- This is a case of a call which cannot be a name
814 else
815 Expr_Form := EF_Name;
816 return Name_Node;
817 end if;
818 end if;
820 -- Not named parameter: Id started an expression after all
822 else
823 Restore_Scan_State (Scan_State); -- to Id
824 end if;
825 end if;
827 -- Here if entry did not start with Id => which means that it
828 -- is a positional parameter, which is not allowed, since we
829 -- have seen at least one named parameter already.
831 Error_Msg_SC
832 ("positional parameter association " &
833 "not allowed after named one");
835 Expr_Node := P_Expression_If_OK;
837 -- Leaving the '>' in an association is not unusual, so suggest
838 -- a possible fix.
840 if Nkind (Expr_Node) = N_Op_Eq then
841 Error_Msg_N ("\maybe `='>` was intended", Expr_Node);
842 end if;
844 -- We go back to scanning out expressions, so that we do not get
845 -- multiple error messages when several positional parameters
846 -- follow a named parameter.
848 goto LP_State_Expr;
850 -- End of treatment for name extensions starting with left paren
852 -- End of loop through name extensions
854 end P_Name;
856 -- This function parses a restricted form of Names which are either
857 -- designators, or designators preceded by a sequence of prefixes
858 -- that are direct names.
860 -- Error recovery: cannot raise Error_Resync
862 function P_Function_Name return Node_Id is
863 Designator_Node : Node_Id;
864 Prefix_Node : Node_Id;
865 Selector_Node : Node_Id;
866 Dot_Sloc : Source_Ptr := No_Location;
868 begin
869 -- Prefix_Node is set to the gathered prefix so far, Empty means that
870 -- no prefix has been scanned. This allows us to build up the result
871 -- in the required right recursive manner.
873 Prefix_Node := Empty;
875 -- Loop through prefixes
877 loop
878 Designator_Node := Token_Node;
880 if Token not in Token_Class_Desig then
881 return P_Identifier; -- let P_Identifier issue the error message
883 else -- Token in Token_Class_Desig
884 Scan; -- past designator
885 exit when Token /= Tok_Dot;
886 end if;
888 -- Here at a dot, with token just before it in Designator_Node
890 if No (Prefix_Node) then
891 Prefix_Node := Designator_Node;
892 else
893 Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
894 Set_Prefix (Selector_Node, Prefix_Node);
895 Set_Selector_Name (Selector_Node, Designator_Node);
896 Prefix_Node := Selector_Node;
897 end if;
899 Dot_Sloc := Token_Ptr;
900 Scan; -- past dot
901 end loop;
903 -- Fall out of the loop having just scanned a designator
905 if No (Prefix_Node) then
906 return Designator_Node;
907 else
908 Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
909 Set_Prefix (Selector_Node, Prefix_Node);
910 Set_Selector_Name (Selector_Node, Designator_Node);
911 return Selector_Node;
912 end if;
914 exception
915 when Error_Resync =>
916 return Error;
917 end P_Function_Name;
919 -- This function parses a restricted form of Names which are either
920 -- identifiers, or identifiers preceded by a sequence of prefixes
921 -- that are direct names.
923 -- Error recovery: cannot raise Error_Resync
925 function P_Qualified_Simple_Name return Node_Id is
926 Designator_Node : Node_Id;
927 Prefix_Node : Node_Id;
928 Selector_Node : Node_Id;
929 Dot_Sloc : Source_Ptr := No_Location;
931 begin
932 -- Prefix node is set to the gathered prefix so far, Empty means that
933 -- no prefix has been scanned. This allows us to build up the result
934 -- in the required right recursive manner.
936 Prefix_Node := Empty;
938 -- Loop through prefixes
940 loop
941 Designator_Node := Token_Node;
943 if Token = Tok_Identifier then
944 Scan; -- past identifier
945 exit when Token /= Tok_Dot;
947 elsif Token not in Token_Class_Desig then
948 return P_Identifier; -- let P_Identifier issue the error message
950 else
951 Scan; -- past designator
953 if Token /= Tok_Dot then
954 Error_Msg_SP ("identifier expected");
955 return Error;
956 end if;
957 end if;
959 -- Here at a dot, with token just before it in Designator_Node
961 if No (Prefix_Node) then
962 Prefix_Node := Designator_Node;
963 else
964 Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
965 Set_Prefix (Selector_Node, Prefix_Node);
966 Set_Selector_Name (Selector_Node, Designator_Node);
967 Prefix_Node := Selector_Node;
968 end if;
970 Dot_Sloc := Token_Ptr;
971 Scan; -- past dot
972 end loop;
974 -- Fall out of the loop having just scanned an identifier
976 if No (Prefix_Node) then
977 return Designator_Node;
978 else
979 Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
980 Set_Prefix (Selector_Node, Prefix_Node);
981 Set_Selector_Name (Selector_Node, Designator_Node);
982 return Selector_Node;
983 end if;
985 exception
986 when Error_Resync =>
987 return Error;
988 end P_Qualified_Simple_Name;
990 -- This procedure differs from P_Qualified_Simple_Name only in that it
991 -- raises Error_Resync if any error is encountered. It only returns after
992 -- scanning a valid qualified simple name.
994 -- Error recovery: can raise Error_Resync
996 function P_Qualified_Simple_Name_Resync return Node_Id is
997 Designator_Node : Node_Id;
998 Prefix_Node : Node_Id;
999 Selector_Node : Node_Id;
1000 Dot_Sloc : Source_Ptr := No_Location;
1002 begin
1003 Prefix_Node := Empty;
1005 -- Loop through prefixes
1007 loop
1008 Designator_Node := Token_Node;
1010 if Token = Tok_Identifier then
1011 Scan; -- past identifier
1012 exit when Token /= Tok_Dot;
1014 elsif Token not in Token_Class_Desig then
1015 Discard_Junk_Node (P_Identifier); -- to issue the error message
1016 raise Error_Resync;
1018 else
1019 Scan; -- past designator
1021 if Token /= Tok_Dot then
1022 Error_Msg_SP ("identifier expected");
1023 raise Error_Resync;
1024 end if;
1025 end if;
1027 -- Here at a dot, with token just before it in Designator_Node
1029 if No (Prefix_Node) then
1030 Prefix_Node := Designator_Node;
1031 else
1032 Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
1033 Set_Prefix (Selector_Node, Prefix_Node);
1034 Set_Selector_Name (Selector_Node, Designator_Node);
1035 Prefix_Node := Selector_Node;
1036 end if;
1038 Dot_Sloc := Token_Ptr;
1039 Scan; -- past period
1040 end loop;
1042 -- Fall out of the loop having just scanned an identifier
1044 if No (Prefix_Node) then
1045 return Designator_Node;
1046 else
1047 Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
1048 Set_Prefix (Selector_Node, Prefix_Node);
1049 Set_Selector_Name (Selector_Node, Designator_Node);
1050 return Selector_Node;
1051 end if;
1052 end P_Qualified_Simple_Name_Resync;
1054 ----------------------
1055 -- 4.1 Direct_Name --
1056 ----------------------
1058 -- Parsed by P_Name and other functions in section 4.1
1060 -----------------
1061 -- 4.1 Prefix --
1062 -----------------
1064 -- Parsed by P_Name (4.1)
1066 -------------------------------
1067 -- 4.1 Explicit Dereference --
1068 -------------------------------
1070 -- Parsed by P_Name (4.1)
1072 -------------------------------
1073 -- 4.1 Implicit_Dereference --
1074 -------------------------------
1076 -- Parsed by P_Name (4.1)
1078 ----------------------------
1079 -- 4.1 Indexed Component --
1080 ----------------------------
1082 -- Parsed by P_Name (4.1)
1084 ----------------
1085 -- 4.1 Slice --
1086 ----------------
1088 -- Parsed by P_Name (4.1)
1090 -----------------------------
1091 -- 4.1 Selected_Component --
1092 -----------------------------
1094 -- Parsed by P_Name (4.1)
1096 ------------------------
1097 -- 4.1 Selector Name --
1098 ------------------------
1100 -- Parsed by P_Name (4.1)
1102 ------------------------------
1103 -- 4.1 Attribute Reference --
1104 ------------------------------
1106 -- Parsed by P_Name (4.1)
1108 -------------------------------
1109 -- 4.1 Attribute Designator --
1110 -------------------------------
1112 -- Parsed by P_Name (4.1)
1114 --------------------------------------
1115 -- 4.1.4 Range Attribute Reference --
1116 --------------------------------------
1118 -- RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR
1120 -- RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]
1122 -- In the grammar, a RANGE attribute is simply a name, but its use is
1123 -- highly restricted, so in the parser, we do not regard it as a name.
1124 -- Instead, P_Name returns without scanning the 'RANGE part of the
1125 -- attribute, and the caller uses the following function to construct
1126 -- a range attribute in places where it is appropriate.
1128 -- Note that RANGE here is treated essentially as an identifier,
1129 -- rather than a reserved word.
1131 -- The caller has parsed the prefix, i.e. a name, and Token points to
1132 -- the apostrophe. The token after the apostrophe is known to be RANGE
1133 -- at this point. The prefix node becomes the prefix of the attribute.
1135 -- Error_Recovery: Cannot raise Error_Resync
1137 function P_Range_Attribute_Reference
1138 (Prefix_Node : Node_Id)
1139 return Node_Id
1141 Attr_Node : Node_Id;
1143 begin
1144 Attr_Node := New_Node (N_Attribute_Reference, Token_Ptr);
1145 Set_Prefix (Attr_Node, Prefix_Node);
1146 Scan; -- past apostrophe
1148 if Style_Check then
1149 Style.Check_Attribute_Name (True);
1150 end if;
1152 Set_Attribute_Name (Attr_Node, Name_Range);
1153 Scan; -- past RANGE
1155 if Token = Tok_Left_Paren then
1156 Scan; -- past left paren
1157 Set_Expressions (Attr_Node, New_List (P_Expression_If_OK));
1158 T_Right_Paren;
1159 end if;
1161 return Attr_Node;
1162 end P_Range_Attribute_Reference;
1164 ---------------------------------------
1165 -- 4.1.4 Range Attribute Designator --
1166 ---------------------------------------
1168 -- Parsed by P_Range_Attribute_Reference (4.4)
1170 --------------------
1171 -- 4.3 Aggregate --
1172 --------------------
1174 -- AGGREGATE ::= RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE
1176 -- Parsed by P_Aggregate_Or_Paren_Expr (4.3), except in the case where
1177 -- an aggregate is known to be required (code statement, extension
1178 -- aggregate), in which cases this routine performs the necessary check
1179 -- that we have an aggregate rather than a parenthesized expression
1181 -- Error recovery: can raise Error_Resync
1183 function P_Aggregate return Node_Id is
1184 Aggr_Sloc : constant Source_Ptr := Token_Ptr;
1185 Aggr_Node : constant Node_Id := P_Aggregate_Or_Paren_Expr;
1187 begin
1188 if Nkind (Aggr_Node) /= N_Aggregate
1189 and then
1190 Nkind (Aggr_Node) /= N_Extension_Aggregate
1191 then
1192 Error_Msg
1193 ("aggregate may not have single positional component", Aggr_Sloc);
1194 return Error;
1195 else
1196 return Aggr_Node;
1197 end if;
1198 end P_Aggregate;
1200 ------------------------------------------------
1201 -- 4.3 Aggregate or Parenthesized Expression --
1202 ------------------------------------------------
1204 -- This procedure parses out either an aggregate or a parenthesized
1205 -- expression (these two constructs are closely related, since a
1206 -- parenthesized expression looks like an aggregate with a single
1207 -- positional component).
1209 -- AGGREGATE ::=
1210 -- RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE
1212 -- RECORD_AGGREGATE ::= (RECORD_COMPONENT_ASSOCIATION_LIST)
1214 -- RECORD_COMPONENT_ASSOCIATION_LIST ::=
1215 -- RECORD_COMPONENT_ASSOCIATION {, RECORD_COMPONENT_ASSOCIATION}
1216 -- | null record
1218 -- RECORD_COMPONENT_ASSOCIATION ::=
1219 -- [COMPONENT_CHOICE_LIST =>] EXPRESSION
1221 -- COMPONENT_CHOICE_LIST ::=
1222 -- component_SELECTOR_NAME {| component_SELECTOR_NAME}
1223 -- | others
1225 -- EXTENSION_AGGREGATE ::=
1226 -- (ANCESTOR_PART with RECORD_COMPONENT_ASSOCIATION_LIST)
1228 -- ANCESTOR_PART ::= EXPRESSION | SUBTYPE_MARK
1230 -- ARRAY_AGGREGATE ::=
1231 -- POSITIONAL_ARRAY_AGGREGATE | NAMED_ARRAY_AGGREGATE
1233 -- POSITIONAL_ARRAY_AGGREGATE ::=
1234 -- (EXPRESSION, EXPRESSION {, EXPRESSION})
1235 -- | (EXPRESSION {, EXPRESSION}, others => EXPRESSION)
1236 -- | (EXPRESSION {, EXPRESSION}, others => <>)
1238 -- NAMED_ARRAY_AGGREGATE ::=
1239 -- (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION})
1241 -- PRIMARY ::= (EXPRESSION);
1243 -- Error recovery: can raise Error_Resync
1245 -- Note: POSITIONAL_ARRAY_AGGREGATE rule has been extended to give support
1246 -- to Ada 2005 limited aggregates (AI-287)
1248 function P_Aggregate_Or_Paren_Expr return Node_Id is
1249 Aggregate_Node : Node_Id;
1250 Expr_List : List_Id;
1251 Assoc_List : List_Id;
1252 Expr_Node : Node_Id;
1253 Lparen_Sloc : Source_Ptr;
1254 Scan_State : Saved_Scan_State;
1256 procedure Box_Error;
1257 -- Called if <> is encountered as positional aggregate element. Issues
1258 -- error message and sets Expr_Node to Error.
1260 ---------------
1261 -- Box_Error --
1262 ---------------
1264 procedure Box_Error is
1265 begin
1266 if Ada_Version < Ada_2005 then
1267 Error_Msg_SC ("box in aggregate is an Ada 2005 extension");
1268 end if;
1270 -- Ada 2005 (AI-287): The box notation is allowed only with named
1271 -- notation because positional notation might be error prone. For
1272 -- example, in "(X, <>, Y, <>)", there is no type associated with
1273 -- the boxes, so you might not be leaving out the components you
1274 -- thought you were leaving out.
1276 Error_Msg_SC ("(Ada 2005) box only allowed with named notation");
1277 Scan; -- past box
1278 Expr_Node := Error;
1279 end Box_Error;
1281 -- Start of processing for P_Aggregate_Or_Paren_Expr
1283 begin
1284 Lparen_Sloc := Token_Ptr;
1285 T_Left_Paren;
1287 -- Note on parentheses count. For cases like an if expression, the
1288 -- parens here really count as real parentheses for the paren count,
1289 -- so we adjust the paren count accordingly after scanning the expr.
1291 -- If expression
1293 if Token = Tok_If then
1294 Expr_Node := P_If_Expression;
1295 T_Right_Paren;
1296 Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
1297 return Expr_Node;
1299 -- Case expression
1301 elsif Token = Tok_Case then
1302 Expr_Node := P_Case_Expression;
1303 T_Right_Paren;
1304 Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
1305 return Expr_Node;
1307 -- Quantified expression
1309 elsif Token = Tok_For then
1310 Expr_Node := P_Quantified_Expression;
1311 T_Right_Paren;
1312 Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
1313 return Expr_Node;
1315 -- Note: the mechanism used here of rescanning the initial expression
1316 -- is distinctly unpleasant, but it saves a lot of fiddling in scanning
1317 -- out the discrete choice list.
1319 -- Deal with expression and extension aggregates first
1321 elsif Token /= Tok_Others then
1322 Save_Scan_State (Scan_State); -- at start of expression
1324 -- Deal with (NULL RECORD)
1326 if Token = Tok_Null then
1327 Scan; -- past NULL
1329 if Token = Tok_Record then
1330 Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
1331 Set_Null_Record_Present (Aggregate_Node, True);
1332 Scan; -- past RECORD
1333 T_Right_Paren;
1334 return Aggregate_Node;
1335 else
1336 Restore_Scan_State (Scan_State); -- to NULL that must be expr
1337 end if;
1338 end if;
1340 -- Scan expression, handling box appearing as positional argument
1342 if Token = Tok_Box then
1343 Box_Error;
1344 else
1345 Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
1346 end if;
1348 -- Extension aggregate
1350 if Token = Tok_With then
1351 if Nkind (Expr_Node) = N_Attribute_Reference
1352 and then Attribute_Name (Expr_Node) = Name_Range
1353 then
1354 Bad_Range_Attribute (Sloc (Expr_Node));
1355 return Error;
1356 end if;
1358 if Ada_Version = Ada_83 then
1359 Error_Msg_SC ("(Ada 83) extension aggregate not allowed");
1360 end if;
1362 Aggregate_Node := New_Node (N_Extension_Aggregate, Lparen_Sloc);
1363 Set_Ancestor_Part (Aggregate_Node, Expr_Node);
1364 Scan; -- past WITH
1366 -- Deal with WITH NULL RECORD case
1368 if Token = Tok_Null then
1369 Save_Scan_State (Scan_State); -- at NULL
1370 Scan; -- past NULL
1372 if Token = Tok_Record then
1373 Scan; -- past RECORD
1374 Set_Null_Record_Present (Aggregate_Node, True);
1375 T_Right_Paren;
1376 return Aggregate_Node;
1378 else
1379 Restore_Scan_State (Scan_State); -- to NULL that must be expr
1380 end if;
1381 end if;
1383 if Token /= Tok_Others then
1384 Save_Scan_State (Scan_State);
1385 Expr_Node := P_Expression;
1386 else
1387 Expr_Node := Empty;
1388 end if;
1390 -- Expression
1392 elsif Token = Tok_Right_Paren or else Token in Token_Class_Eterm then
1393 if Nkind (Expr_Node) = N_Attribute_Reference
1394 and then Attribute_Name (Expr_Node) = Name_Range
1395 then
1396 Error_Msg
1397 ("|parentheses not allowed for range attribute", Lparen_Sloc);
1398 Scan; -- past right paren
1399 return Expr_Node;
1400 end if;
1402 -- Bump paren count of expression
1404 if Expr_Node /= Error then
1405 Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
1406 end if;
1408 T_Right_Paren; -- past right paren (error message if none)
1409 return Expr_Node;
1411 -- Normal aggregate
1413 else
1414 Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
1415 end if;
1417 -- Others
1419 else
1420 Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
1421 Expr_Node := Empty;
1422 end if;
1424 -- Prepare to scan list of component associations
1426 Expr_List := No_List; -- don't set yet, maybe all named entries
1427 Assoc_List := No_List; -- don't set yet, maybe all positional entries
1429 -- This loop scans through component associations. On entry to the
1430 -- loop, an expression has been scanned at the start of the current
1431 -- association unless initial token was OTHERS, in which case
1432 -- Expr_Node is set to Empty.
1434 loop
1435 -- Deal with others association first. This is a named association
1437 if No (Expr_Node) then
1438 if No (Assoc_List) then
1439 Assoc_List := New_List;
1440 end if;
1442 Append (P_Record_Or_Array_Component_Association, Assoc_List);
1444 -- Improper use of WITH
1446 elsif Token = Tok_With then
1447 Error_Msg_SC ("WITH must be preceded by single expression in " &
1448 "extension aggregate");
1449 raise Error_Resync;
1451 -- Range attribute can only appear as part of a discrete choice list
1453 elsif Nkind (Expr_Node) = N_Attribute_Reference
1454 and then Attribute_Name (Expr_Node) = Name_Range
1455 and then Token /= Tok_Arrow
1456 and then Token /= Tok_Vertical_Bar
1457 then
1458 Bad_Range_Attribute (Sloc (Expr_Node));
1459 return Error;
1461 -- Assume positional case if comma, right paren, or literal or
1462 -- identifier or OTHERS follows (the latter cases are missing
1463 -- comma cases). Also assume positional if a semicolon follows,
1464 -- which can happen if there are missing parens
1466 elsif Token = Tok_Comma
1467 or else Token = Tok_Right_Paren
1468 or else Token = Tok_Others
1469 or else Token in Token_Class_Lit_Or_Name
1470 or else Token = Tok_Semicolon
1471 then
1472 if Present (Assoc_List) then
1473 Error_Msg_BC -- CODEFIX
1474 ("""='>"" expected (positional association cannot follow " &
1475 "named association)");
1476 end if;
1478 if No (Expr_List) then
1479 Expr_List := New_List;
1480 end if;
1482 Append (Expr_Node, Expr_List);
1484 -- Check for aggregate followed by left parent, maybe missing comma
1486 elsif Nkind (Expr_Node) = N_Aggregate
1487 and then Token = Tok_Left_Paren
1488 then
1489 T_Comma;
1491 if No (Expr_List) then
1492 Expr_List := New_List;
1493 end if;
1495 Append (Expr_Node, Expr_List);
1497 -- Anything else is assumed to be a named association
1499 else
1500 Restore_Scan_State (Scan_State); -- to start of expression
1502 if No (Assoc_List) then
1503 Assoc_List := New_List;
1504 end if;
1506 Append (P_Record_Or_Array_Component_Association, Assoc_List);
1507 end if;
1509 exit when not Comma_Present;
1511 -- If we are at an expression terminator, something is seriously
1512 -- wrong, so let's get out now, before we start eating up stuff
1513 -- that doesn't belong to us!
1515 if Token in Token_Class_Eterm then
1516 Error_Msg_AP
1517 ("expecting expression or component association");
1518 exit;
1519 end if;
1521 -- Deal with misused box
1523 if Token = Tok_Box then
1524 Box_Error;
1526 -- Otherwise initiate for reentry to top of loop by scanning an
1527 -- initial expression, unless the first token is OTHERS.
1529 elsif Token = Tok_Others then
1530 Expr_Node := Empty;
1532 else
1533 Save_Scan_State (Scan_State); -- at start of expression
1534 Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
1536 end if;
1537 end loop;
1539 -- All component associations (positional and named) have been scanned
1541 T_Right_Paren;
1542 Set_Expressions (Aggregate_Node, Expr_List);
1543 Set_Component_Associations (Aggregate_Node, Assoc_List);
1544 return Aggregate_Node;
1545 end P_Aggregate_Or_Paren_Expr;
1547 ------------------------------------------------
1548 -- 4.3 Record or Array Component Association --
1549 ------------------------------------------------
1551 -- RECORD_COMPONENT_ASSOCIATION ::=
1552 -- [COMPONENT_CHOICE_LIST =>] EXPRESSION
1553 -- | COMPONENT_CHOICE_LIST => <>
1555 -- COMPONENT_CHOICE_LIST =>
1556 -- component_SELECTOR_NAME {| component_SELECTOR_NAME}
1557 -- | others
1559 -- ARRAY_COMPONENT_ASSOCIATION ::=
1560 -- DISCRETE_CHOICE_LIST => EXPRESSION
1561 -- | DISCRETE_CHOICE_LIST => <>
1563 -- Note: this routine only handles the named cases, including others.
1564 -- Cases where the component choice list is not present have already
1565 -- been handled directly.
1567 -- Error recovery: can raise Error_Resync
1569 -- Note: RECORD_COMPONENT_ASSOCIATION and ARRAY_COMPONENT_ASSOCIATION
1570 -- rules have been extended to give support to Ada 2005 limited
1571 -- aggregates (AI-287)
1573 function P_Record_Or_Array_Component_Association return Node_Id is
1574 Assoc_Node : Node_Id;
1576 begin
1577 Assoc_Node := New_Node (N_Component_Association, Token_Ptr);
1578 Set_Choices (Assoc_Node, P_Discrete_Choice_List);
1579 Set_Sloc (Assoc_Node, Token_Ptr);
1580 TF_Arrow;
1582 if Token = Tok_Box then
1584 -- Ada 2005(AI-287): The box notation is used to indicate the
1585 -- default initialization of aggregate components
1587 if Ada_Version < Ada_2005 then
1588 Error_Msg_SP
1589 ("component association with '<'> is an Ada 2005 extension");
1590 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1591 end if;
1593 Set_Box_Present (Assoc_Node);
1594 Scan; -- Past box
1595 else
1596 Set_Expression (Assoc_Node, P_Expression);
1597 end if;
1599 return Assoc_Node;
1600 end P_Record_Or_Array_Component_Association;
1602 -----------------------------
1603 -- 4.3.1 Record Aggregate --
1604 -----------------------------
1606 -- Case of enumeration aggregate is parsed by P_Aggregate (4.3)
1607 -- All other cases are parsed by P_Aggregate_Or_Paren_Expr (4.3)
1609 ----------------------------------------------
1610 -- 4.3.1 Record Component Association List --
1611 ----------------------------------------------
1613 -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1615 ----------------------------------
1616 -- 4.3.1 Component Choice List --
1617 ----------------------------------
1619 -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1621 --------------------------------
1622 -- 4.3.1 Extension Aggregate --
1623 --------------------------------
1625 -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1627 --------------------------
1628 -- 4.3.1 Ancestor Part --
1629 --------------------------
1631 -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1633 ----------------------------
1634 -- 4.3.1 Array Aggregate --
1635 ----------------------------
1637 -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1639 ---------------------------------------
1640 -- 4.3.1 Positional Array Aggregate --
1641 ---------------------------------------
1643 -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1645 ----------------------------------
1646 -- 4.3.1 Named Array Aggregate --
1647 ----------------------------------
1649 -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1651 ----------------------------------------
1652 -- 4.3.1 Array Component Association --
1653 ----------------------------------------
1655 -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
1657 ---------------------
1658 -- 4.4 Expression --
1659 ---------------------
1661 -- This procedure parses EXPRESSION or CHOICE_EXPRESSION
1663 -- EXPRESSION ::=
1664 -- RELATION {LOGICAL_OPERATOR RELATION}
1666 -- CHOICE_EXPRESSION ::=
1667 -- CHOICE_RELATION {LOGICAL_OPERATOR CHOICE_RELATION}
1669 -- LOGICAL_OPERATOR ::= and | and then | or | or else | xor
1671 -- On return, Expr_Form indicates the categorization of the expression
1672 -- EF_Range_Attr is not a possible value (if a range attribute is found,
1673 -- an error message is given, and Error is returned).
1675 -- Error recovery: cannot raise Error_Resync
1677 function P_Expression return Node_Id is
1678 Logical_Op : Node_Kind;
1679 Prev_Logical_Op : Node_Kind;
1680 Op_Location : Source_Ptr;
1681 Node1 : Node_Id;
1682 Node2 : Node_Id;
1684 begin
1685 Node1 := P_Relation;
1687 if Token in Token_Class_Logop then
1688 Prev_Logical_Op := N_Empty;
1690 loop
1691 Op_Location := Token_Ptr;
1692 Logical_Op := P_Logical_Operator;
1694 if Prev_Logical_Op /= N_Empty and then
1695 Logical_Op /= Prev_Logical_Op
1696 then
1697 Error_Msg
1698 ("mixed logical operators in expression", Op_Location);
1699 Prev_Logical_Op := N_Empty;
1700 else
1701 Prev_Logical_Op := Logical_Op;
1702 end if;
1704 Node2 := Node1;
1705 Node1 := New_Op_Node (Logical_Op, Op_Location);
1706 Set_Left_Opnd (Node1, Node2);
1707 Set_Right_Opnd (Node1, P_Relation);
1708 exit when Token not in Token_Class_Logop;
1709 end loop;
1711 Expr_Form := EF_Non_Simple;
1712 end if;
1714 if Token = Tok_Apostrophe then
1715 Bad_Range_Attribute (Token_Ptr);
1716 return Error;
1717 else
1718 return Node1;
1719 end if;
1720 end P_Expression;
1722 -- This function is identical to the normal P_Expression, except that it
1723 -- also permits the appearance of a case, conditional, or quantified
1724 -- expression if the call immediately follows a left paren, and followed
1725 -- by a right parenthesis. These forms are allowed if these conditions
1726 -- are not met, but an error message will be issued.
1728 function P_Expression_If_OK return Node_Id is
1729 begin
1730 -- Case of conditional, case or quantified expression
1732 if Token = Tok_Case or else Token = Tok_If or else Token = Tok_For then
1733 return P_Unparen_Cond_Case_Quant_Expression;
1735 -- Normal case, not case/conditional/quantified expression
1737 else
1738 return P_Expression;
1739 end if;
1740 end P_Expression_If_OK;
1742 -- This function is identical to the normal P_Expression, except that it
1743 -- checks that the expression scan did not stop on a right paren. It is
1744 -- called in all contexts where a right parenthesis cannot legitimately
1745 -- follow an expression.
1747 -- Error recovery: can not raise Error_Resync
1749 function P_Expression_No_Right_Paren return Node_Id is
1750 Expr : constant Node_Id := P_Expression;
1751 begin
1752 Ignore (Tok_Right_Paren);
1753 return Expr;
1754 end P_Expression_No_Right_Paren;
1756 ----------------------------------------
1757 -- 4.4 Expression_Or_Range_Attribute --
1758 ----------------------------------------
1760 -- EXPRESSION ::=
1761 -- RELATION {and RELATION} | RELATION {and then RELATION}
1762 -- | RELATION {or RELATION} | RELATION {or else RELATION}
1763 -- | RELATION {xor RELATION}
1765 -- RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR
1767 -- RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]
1769 -- On return, Expr_Form indicates the categorization of the expression
1770 -- and EF_Range_Attr is one of the possibilities.
1772 -- Error recovery: cannot raise Error_Resync
1774 -- In the grammar, a RANGE attribute is simply a name, but its use is
1775 -- highly restricted, so in the parser, we do not regard it as a name.
1776 -- Instead, P_Name returns without scanning the 'RANGE part of the
1777 -- attribute, and P_Expression_Or_Range_Attribute handles the range
1778 -- attribute reference. In the normal case where a range attribute is
1779 -- not allowed, an error message is issued by P_Expression.
1781 function P_Expression_Or_Range_Attribute return Node_Id is
1782 Logical_Op : Node_Kind;
1783 Prev_Logical_Op : Node_Kind;
1784 Op_Location : Source_Ptr;
1785 Node1 : Node_Id;
1786 Node2 : Node_Id;
1787 Attr_Node : Node_Id;
1789 begin
1790 Node1 := P_Relation;
1792 if Token = Tok_Apostrophe then
1793 Attr_Node := P_Range_Attribute_Reference (Node1);
1794 Expr_Form := EF_Range_Attr;
1795 return Attr_Node;
1797 elsif Token in Token_Class_Logop then
1798 Prev_Logical_Op := N_Empty;
1800 loop
1801 Op_Location := Token_Ptr;
1802 Logical_Op := P_Logical_Operator;
1804 if Prev_Logical_Op /= N_Empty and then
1805 Logical_Op /= Prev_Logical_Op
1806 then
1807 Error_Msg
1808 ("mixed logical operators in expression", Op_Location);
1809 Prev_Logical_Op := N_Empty;
1810 else
1811 Prev_Logical_Op := Logical_Op;
1812 end if;
1814 Node2 := Node1;
1815 Node1 := New_Op_Node (Logical_Op, Op_Location);
1816 Set_Left_Opnd (Node1, Node2);
1817 Set_Right_Opnd (Node1, P_Relation);
1818 exit when Token not in Token_Class_Logop;
1819 end loop;
1821 Expr_Form := EF_Non_Simple;
1822 end if;
1824 if Token = Tok_Apostrophe then
1825 Bad_Range_Attribute (Token_Ptr);
1826 return Error;
1827 else
1828 return Node1;
1829 end if;
1830 end P_Expression_Or_Range_Attribute;
1832 -- Version that allows a non-parenthesized case, conditional, or quantified
1833 -- expression if the call immediately follows a left paren, and followed
1834 -- by a right parenthesis. These forms are allowed if these conditions
1835 -- are not met, but an error message will be issued.
1837 function P_Expression_Or_Range_Attribute_If_OK return Node_Id is
1838 begin
1839 -- Case of conditional, case or quantified expression
1841 if Token = Tok_Case or else Token = Tok_If or else Token = Tok_For then
1842 return P_Unparen_Cond_Case_Quant_Expression;
1844 -- Normal case, not one of the above expression types
1846 else
1847 return P_Expression_Or_Range_Attribute;
1848 end if;
1849 end P_Expression_Or_Range_Attribute_If_OK;
1851 -------------------
1852 -- 4.4 Relation --
1853 -------------------
1855 -- This procedure scans both relations and choice relations
1857 -- CHOICE_RELATION ::=
1858 -- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION]
1860 -- RELATION ::=
1861 -- SIMPLE_EXPRESSION [not] in MEMBERSHIP_CHOICE_LIST
1862 -- | RAISE_EXPRESSION
1864 -- MEMBERSHIP_CHOICE_LIST ::=
1865 -- MEMBERSHIP_CHOICE {'|' MEMBERSHIP CHOICE}
1867 -- MEMBERSHIP_CHOICE ::=
1868 -- CHOICE_EXPRESSION | RANGE | SUBTYPE_MARK
1870 -- RAISE_EXPRESSION ::= raise exception_NAME [with string_EXPRESSION]
1872 -- On return, Expr_Form indicates the categorization of the expression
1874 -- Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to
1875 -- EF_Simple_Name and the following token is RANGE (range attribute case).
1877 -- Error recovery: cannot raise Error_Resync. If an error occurs within an
1878 -- expression, then tokens are scanned until either a non-expression token,
1879 -- a right paren (not matched by a left paren) or a comma, is encountered.
1881 function P_Relation return Node_Id is
1882 Node1, Node2 : Node_Id;
1883 Optok : Source_Ptr;
1885 begin
1886 -- First check for raise expression
1888 if Token = Tok_Raise then
1889 Expr_Form := EF_Non_Simple;
1890 return P_Raise_Expression;
1891 end if;
1893 -- All other cases
1895 Node1 := P_Simple_Expression;
1897 if Token not in Token_Class_Relop then
1898 return Node1;
1900 else
1901 -- Here we have a relational operator following. If so then scan it
1902 -- out. Note that the assignment symbol := is treated as a relational
1903 -- operator to improve the error recovery when it is misused for =.
1904 -- P_Relational_Operator also parses the IN and NOT IN operations.
1906 Optok := Token_Ptr;
1907 Node2 := New_Op_Node (P_Relational_Operator, Optok);
1908 Set_Left_Opnd (Node2, Node1);
1910 -- Case of IN or NOT IN
1912 if Prev_Token = Tok_In then
1913 P_Membership_Test (Node2);
1915 -- Case of relational operator (= /= < <= > >=)
1917 else
1918 Set_Right_Opnd (Node2, P_Simple_Expression);
1919 end if;
1921 Expr_Form := EF_Non_Simple;
1923 if Token in Token_Class_Relop then
1924 Error_Msg_SC ("unexpected relational operator");
1925 raise Error_Resync;
1926 end if;
1928 return Node2;
1929 end if;
1931 -- If any error occurs, then scan to the next expression terminator symbol
1932 -- or comma or right paren at the outer (i.e. current) parentheses level.
1933 -- The flags are set to indicate a normal simple expression.
1935 exception
1936 when Error_Resync =>
1937 Resync_Expression;
1938 Expr_Form := EF_Simple;
1939 return Error;
1940 end P_Relation;
1942 ----------------------------
1943 -- 4.4 Simple Expression --
1944 ----------------------------
1946 -- SIMPLE_EXPRESSION ::=
1947 -- [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM}
1949 -- On return, Expr_Form indicates the categorization of the expression
1951 -- Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to
1952 -- EF_Simple_Name and the following token is RANGE (range attribute case).
1954 -- Error recovery: cannot raise Error_Resync. If an error occurs within an
1955 -- expression, then tokens are scanned until either a non-expression token,
1956 -- a right paren (not matched by a left paren) or a comma, is encountered.
1958 -- Note: P_Simple_Expression is called only internally by higher level
1959 -- expression routines. In cases in the grammar where a simple expression
1960 -- is required, the approach is to scan an expression, and then post an
1961 -- appropriate error message if the expression obtained is not simple. This
1962 -- gives better error recovery and treatment.
1964 function P_Simple_Expression return Node_Id is
1965 Scan_State : Saved_Scan_State;
1966 Node1 : Node_Id;
1967 Node2 : Node_Id;
1968 Tokptr : Source_Ptr;
1970 begin
1971 -- Check for cases starting with a name. There are two reasons for
1972 -- special casing. First speed things up by catching a common case
1973 -- without going through several routine layers. Second the caller must
1974 -- be informed via Expr_Form when the simple expression is a name.
1976 if Token in Token_Class_Name then
1977 Node1 := P_Name;
1979 -- Deal with apostrophe cases
1981 if Token = Tok_Apostrophe then
1982 Save_Scan_State (Scan_State); -- at apostrophe
1983 Scan; -- past apostrophe
1985 -- If qualified expression, scan it out and fall through
1987 if Token = Tok_Left_Paren then
1988 Node1 := P_Qualified_Expression (Node1);
1989 Expr_Form := EF_Simple;
1991 -- If range attribute, then we return with Token pointing to the
1992 -- apostrophe. Note: avoid the normal error check on exit. We
1993 -- know that the expression really is complete in this case!
1995 else -- Token = Tok_Range then
1996 Restore_Scan_State (Scan_State); -- to apostrophe
1997 Expr_Form := EF_Simple_Name;
1998 return Node1;
1999 end if;
2000 end if;
2002 -- If an expression terminator follows, the previous processing
2003 -- completely scanned out the expression (a common case), and
2004 -- left Expr_Form set appropriately for returning to our caller.
2006 if Token in Token_Class_Sterm then
2007 null;
2009 -- If we do not have an expression terminator, then complete the
2010 -- scan of a simple expression. This code duplicates the code
2011 -- found in P_Term and P_Factor.
2013 else
2014 if Token = Tok_Double_Asterisk then
2015 if Style_Check then
2016 Style.Check_Exponentiation_Operator;
2017 end if;
2019 Node2 := New_Op_Node (N_Op_Expon, Token_Ptr);
2020 Scan; -- past **
2021 Set_Left_Opnd (Node2, Node1);
2022 Set_Right_Opnd (Node2, P_Primary);
2023 Check_Bad_Exp;
2024 Node1 := Node2;
2025 end if;
2027 loop
2028 exit when Token not in Token_Class_Mulop;
2029 Tokptr := Token_Ptr;
2030 Node2 := New_Op_Node (P_Multiplying_Operator, Tokptr);
2032 if Style_Check then
2033 Style.Check_Binary_Operator;
2034 end if;
2036 Scan; -- past operator
2037 Set_Left_Opnd (Node2, Node1);
2038 Set_Right_Opnd (Node2, P_Factor);
2039 Node1 := Node2;
2040 end loop;
2042 loop
2043 exit when Token not in Token_Class_Binary_Addop;
2044 Tokptr := Token_Ptr;
2045 Node2 := New_Op_Node (P_Binary_Adding_Operator, Tokptr);
2047 if Style_Check then
2048 Style.Check_Binary_Operator;
2049 end if;
2051 Scan; -- past operator
2052 Set_Left_Opnd (Node2, Node1);
2053 Set_Right_Opnd (Node2, P_Term);
2054 Node1 := Node2;
2055 end loop;
2057 Expr_Form := EF_Simple;
2058 end if;
2060 -- Cases where simple expression does not start with a name
2062 else
2063 -- Scan initial sign and initial Term
2065 if Token in Token_Class_Unary_Addop then
2066 Tokptr := Token_Ptr;
2067 Node1 := New_Op_Node (P_Unary_Adding_Operator, Tokptr);
2069 if Style_Check then
2070 Style.Check_Unary_Plus_Or_Minus;
2071 end if;
2073 Scan; -- past operator
2074 Set_Right_Opnd (Node1, P_Term);
2075 else
2076 Node1 := P_Term;
2077 end if;
2079 -- In the following, we special-case a sequence of concatenations of
2080 -- string literals, such as "aaa" & "bbb" & ... & "ccc", with nothing
2081 -- else mixed in. For such a sequence, we return a tree representing
2082 -- "" & "aaabbb...ccc" (a single concatenation). This is done only if
2083 -- the number of concatenations is large. If semantic analysis
2084 -- resolves the "&" to a predefined one, then this folding gives the
2085 -- right answer. Otherwise, semantic analysis will complain about a
2086 -- capacity-exceeded error. The purpose of this trick is to avoid
2087 -- creating a deeply nested tree, which would cause deep recursion
2088 -- during semantics, causing stack overflow. This way, we can handle
2089 -- enormous concatenations in the normal case of predefined "&". We
2090 -- first build up the normal tree, and then rewrite it if
2091 -- appropriate.
2093 declare
2094 Num_Concats_Threshold : constant Positive := 1000;
2095 -- Arbitrary threshold value to enable optimization
2097 First_Node : constant Node_Id := Node1;
2098 Is_Strlit_Concat : Boolean;
2099 -- True iff we've parsed a sequence of concatenations of string
2100 -- literals, with nothing else mixed in.
2102 Num_Concats : Natural;
2103 -- Number of "&" operators if Is_Strlit_Concat is True
2105 begin
2106 Is_Strlit_Concat :=
2107 Nkind (Node1) = N_String_Literal
2108 and then Token = Tok_Ampersand;
2109 Num_Concats := 0;
2111 -- Scan out sequence of terms separated by binary adding operators
2113 loop
2114 exit when Token not in Token_Class_Binary_Addop;
2115 Tokptr := Token_Ptr;
2116 Node2 := New_Op_Node (P_Binary_Adding_Operator, Tokptr);
2117 Scan; -- past operator
2118 Set_Left_Opnd (Node2, Node1);
2119 Node1 := P_Term;
2120 Set_Right_Opnd (Node2, Node1);
2122 -- Check if we're still concatenating string literals
2124 Is_Strlit_Concat :=
2125 Is_Strlit_Concat
2126 and then Nkind (Node2) = N_Op_Concat
2127 and then Nkind (Node1) = N_String_Literal;
2129 if Is_Strlit_Concat then
2130 Num_Concats := Num_Concats + 1;
2131 end if;
2133 Node1 := Node2;
2134 end loop;
2136 -- If we have an enormous series of concatenations of string
2137 -- literals, rewrite as explained above. The Is_Folded_In_Parser
2138 -- flag tells semantic analysis that if the "&" is not predefined,
2139 -- the folded value is wrong.
2141 if Is_Strlit_Concat
2142 and then Num_Concats >= Num_Concats_Threshold
2143 then
2144 declare
2145 Empty_String_Val : String_Id;
2146 -- String_Id for ""
2148 Strlit_Concat_Val : String_Id;
2149 -- Contains the folded value (which will be correct if the
2150 -- "&" operators are the predefined ones).
2152 Cur_Node : Node_Id;
2153 -- For walking up the tree
2155 New_Node : Node_Id;
2156 -- Folded node to replace Node1
2158 Loc : constant Source_Ptr := Sloc (First_Node);
2160 begin
2161 -- Walk up the tree starting at the leftmost string literal
2162 -- (First_Node), building up the Strlit_Concat_Val as we
2163 -- go. Note that we do not use recursion here -- the whole
2164 -- point is to avoid recursively walking that enormous tree.
2166 Start_String;
2167 Store_String_Chars (Strval (First_Node));
2169 Cur_Node := Parent (First_Node);
2170 while Present (Cur_Node) loop
2171 pragma Assert (Nkind (Cur_Node) = N_Op_Concat and then
2172 Nkind (Right_Opnd (Cur_Node)) = N_String_Literal);
2174 Store_String_Chars (Strval (Right_Opnd (Cur_Node)));
2175 Cur_Node := Parent (Cur_Node);
2176 end loop;
2178 Strlit_Concat_Val := End_String;
2180 -- Create new folded node, and rewrite result with a concat-
2181 -- enation of an empty string literal and the folded node.
2183 Start_String;
2184 Empty_String_Val := End_String;
2185 New_Node :=
2186 Make_Op_Concat (Loc,
2187 Make_String_Literal (Loc, Empty_String_Val),
2188 Make_String_Literal (Loc, Strlit_Concat_Val,
2189 Is_Folded_In_Parser => True));
2190 Rewrite (Node1, New_Node);
2191 end;
2192 end if;
2193 end;
2195 -- All done, we clearly do not have name or numeric literal so this
2196 -- is a case of a simple expression which is some other possibility.
2198 Expr_Form := EF_Simple;
2199 end if;
2201 -- Come here at end of simple expression, where we do a couple of
2202 -- special checks to improve error recovery.
2204 -- Special test to improve error recovery. If the current token
2205 -- is a period, then someone is trying to do selection on something
2206 -- that is not a name, e.g. a qualified expression.
2208 if Token = Tok_Dot then
2209 Error_Msg_SC ("prefix for selection is not a name");
2211 -- If qualified expression, comment and continue, otherwise something
2212 -- is pretty nasty so do an Error_Resync call.
2214 if Ada_Version < Ada_2012
2215 and then Nkind (Node1) = N_Qualified_Expression
2216 then
2217 Error_Msg_SC ("\would be legal in Ada 2012 mode");
2218 else
2219 raise Error_Resync;
2220 end if;
2221 end if;
2223 -- Special test to improve error recovery: If the current token is
2224 -- not the first token on a line (as determined by checking the
2225 -- previous token position with the start of the current line),
2226 -- then we insist that we have an appropriate terminating token.
2227 -- Consider the following two examples:
2229 -- 1) if A nad B then ...
2231 -- 2) A := B
2232 -- C := D
2234 -- In the first example, we would like to issue a binary operator
2235 -- expected message and resynchronize to the then. In the second
2236 -- example, we do not want to issue a binary operator message, so
2237 -- that instead we will get the missing semicolon message. This
2238 -- distinction is of course a heuristic which does not always work,
2239 -- but in practice it is quite effective.
2241 -- Note: the one case in which we do not go through this circuit is
2242 -- when we have scanned a range attribute and want to return with
2243 -- Token pointing to the apostrophe. The apostrophe is not normally
2244 -- an expression terminator, and is not in Token_Class_Sterm, but
2245 -- in this special case we know that the expression is complete.
2247 if not Token_Is_At_Start_Of_Line
2248 and then Token not in Token_Class_Sterm
2249 then
2250 -- Normally the right error message is indeed that we expected a
2251 -- binary operator, but in the case of being between a right and left
2252 -- paren, e.g. in an aggregate, a more likely error is missing comma.
2254 if Prev_Token = Tok_Right_Paren and then Token = Tok_Left_Paren then
2255 T_Comma;
2256 else
2257 Error_Msg_AP ("binary operator expected");
2258 end if;
2260 raise Error_Resync;
2262 else
2263 return Node1;
2264 end if;
2266 -- If any error occurs, then scan to next expression terminator symbol
2267 -- or comma, right paren or vertical bar at the outer (i.e. current) paren
2268 -- level. Expr_Form is set to indicate a normal simple expression.
2270 exception
2271 when Error_Resync =>
2272 Resync_Expression;
2273 Expr_Form := EF_Simple;
2274 return Error;
2275 end P_Simple_Expression;
2277 -----------------------------------------------
2278 -- 4.4 Simple Expression or Range Attribute --
2279 -----------------------------------------------
2281 -- SIMPLE_EXPRESSION ::=
2282 -- [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM}
2284 -- RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR
2286 -- RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]
2288 -- Error recovery: cannot raise Error_Resync
2290 function P_Simple_Expression_Or_Range_Attribute return Node_Id is
2291 Sexpr : Node_Id;
2292 Attr_Node : Node_Id;
2294 begin
2295 -- We don't just want to roar ahead and call P_Simple_Expression
2296 -- here, since we want to handle the case of a parenthesized range
2297 -- attribute cleanly.
2299 if Token = Tok_Left_Paren then
2300 declare
2301 Lptr : constant Source_Ptr := Token_Ptr;
2302 Scan_State : Saved_Scan_State;
2304 begin
2305 Save_Scan_State (Scan_State);
2306 Scan; -- past left paren
2307 Sexpr := P_Simple_Expression;
2309 if Token = Tok_Apostrophe then
2310 Attr_Node := P_Range_Attribute_Reference (Sexpr);
2311 Expr_Form := EF_Range_Attr;
2313 if Token = Tok_Right_Paren then
2314 Scan; -- scan past right paren if present
2315 end if;
2317 Error_Msg ("parentheses not allowed for range attribute", Lptr);
2319 return Attr_Node;
2320 end if;
2322 Restore_Scan_State (Scan_State);
2323 end;
2324 end if;
2326 -- Here after dealing with parenthesized range attribute
2328 Sexpr := P_Simple_Expression;
2330 if Token = Tok_Apostrophe then
2331 Attr_Node := P_Range_Attribute_Reference (Sexpr);
2332 Expr_Form := EF_Range_Attr;
2333 return Attr_Node;
2335 else
2336 return Sexpr;
2337 end if;
2338 end P_Simple_Expression_Or_Range_Attribute;
2340 ---------------
2341 -- 4.4 Term --
2342 ---------------
2344 -- TERM ::= FACTOR {MULTIPLYING_OPERATOR FACTOR}
2346 -- Error recovery: can raise Error_Resync
2348 function P_Term return Node_Id is
2349 Node1, Node2 : Node_Id;
2350 Tokptr : Source_Ptr;
2352 begin
2353 Node1 := P_Factor;
2355 loop
2356 exit when Token not in Token_Class_Mulop;
2357 Tokptr := Token_Ptr;
2358 Node2 := New_Op_Node (P_Multiplying_Operator, Tokptr);
2359 Scan; -- past operator
2360 Set_Left_Opnd (Node2, Node1);
2361 Set_Right_Opnd (Node2, P_Factor);
2362 Node1 := Node2;
2363 end loop;
2365 return Node1;
2366 end P_Term;
2368 -----------------
2369 -- 4.4 Factor --
2370 -----------------
2372 -- FACTOR ::= PRIMARY [** PRIMARY] | abs PRIMARY | not PRIMARY
2374 -- Error recovery: can raise Error_Resync
2376 function P_Factor return Node_Id is
2377 Node1 : Node_Id;
2378 Node2 : Node_Id;
2380 begin
2381 if Token = Tok_Abs then
2382 Node1 := New_Op_Node (N_Op_Abs, Token_Ptr);
2384 if Style_Check then
2385 Style.Check_Abs_Not;
2386 end if;
2388 Scan; -- past ABS
2389 Set_Right_Opnd (Node1, P_Primary);
2390 return Node1;
2392 elsif Token = Tok_Not then
2393 Node1 := New_Op_Node (N_Op_Not, Token_Ptr);
2395 if Style_Check then
2396 Style.Check_Abs_Not;
2397 end if;
2399 Scan; -- past NOT
2400 Set_Right_Opnd (Node1, P_Primary);
2401 return Node1;
2403 else
2404 Node1 := P_Primary;
2406 if Token = Tok_Double_Asterisk then
2407 Node2 := New_Op_Node (N_Op_Expon, Token_Ptr);
2408 Scan; -- past **
2409 Set_Left_Opnd (Node2, Node1);
2410 Set_Right_Opnd (Node2, P_Primary);
2411 Check_Bad_Exp;
2412 return Node2;
2413 else
2414 return Node1;
2415 end if;
2416 end if;
2417 end P_Factor;
2419 ------------------
2420 -- 4.4 Primary --
2421 ------------------
2423 -- PRIMARY ::=
2424 -- NUMERIC_LITERAL | null
2425 -- | STRING_LITERAL | AGGREGATE
2426 -- | NAME | QUALIFIED_EXPRESSION
2427 -- | ALLOCATOR | (EXPRESSION) | QUANTIFIED_EXPRESSION
2429 -- Error recovery: can raise Error_Resync
2431 function P_Primary return Node_Id is
2432 Scan_State : Saved_Scan_State;
2433 Node1 : Node_Id;
2435 Lparen : constant Boolean := Prev_Token = Tok_Left_Paren;
2436 -- Remember if previous token is a left parenthesis. This is used to
2437 -- deal with checking whether IF/CASE/FOR expressions appearing as
2438 -- primaries require extra parenthesization.
2440 begin
2441 -- The loop runs more than once only if misplaced pragmas are found
2442 -- or if a misplaced unary minus is skipped.
2444 loop
2445 case Token is
2447 -- Name token can start a name, call or qualified expression, all
2448 -- of which are acceptable possibilities for primary. Note also
2449 -- that string literal is included in name (as operator symbol)
2450 -- and type conversion is included in name (as indexed component).
2452 when Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier =>
2453 Node1 := P_Name;
2455 -- All done unless apostrophe follows
2457 if Token /= Tok_Apostrophe then
2458 return Node1;
2460 -- Apostrophe following means that we have either just parsed
2461 -- the subtype mark of a qualified expression, or the prefix
2462 -- or a range attribute.
2464 else -- Token = Tok_Apostrophe
2465 Save_Scan_State (Scan_State); -- at apostrophe
2466 Scan; -- past apostrophe
2468 -- If range attribute, then this is always an error, since
2469 -- the only legitimate case (where the scanned expression is
2470 -- a qualified simple name) is handled at the level of the
2471 -- Simple_Expression processing. This case corresponds to a
2472 -- usage such as 3 + A'Range, which is always illegal.
2474 if Token = Tok_Range then
2475 Restore_Scan_State (Scan_State); -- to apostrophe
2476 Bad_Range_Attribute (Token_Ptr);
2477 return Error;
2479 -- If left paren, then we have a qualified expression.
2480 -- Note that P_Name guarantees that in this case, where
2481 -- Token = Tok_Apostrophe on return, the only two possible
2482 -- tokens following the apostrophe are left paren and
2483 -- RANGE, so we know we have a left paren here.
2485 else -- Token = Tok_Left_Paren
2486 return P_Qualified_Expression (Node1);
2488 end if;
2489 end if;
2491 -- Numeric or string literal
2493 when Tok_Integer_Literal |
2494 Tok_Real_Literal |
2495 Tok_String_Literal =>
2497 Node1 := Token_Node;
2498 Scan; -- past number
2499 return Node1;
2501 -- Left paren, starts aggregate or parenthesized expression
2503 when Tok_Left_Paren =>
2504 declare
2505 Expr : constant Node_Id := P_Aggregate_Or_Paren_Expr;
2507 begin
2508 if Nkind (Expr) = N_Attribute_Reference
2509 and then Attribute_Name (Expr) = Name_Range
2510 then
2511 Bad_Range_Attribute (Sloc (Expr));
2512 end if;
2514 return Expr;
2515 end;
2517 -- Allocator
2519 when Tok_New =>
2520 return P_Allocator;
2522 -- Null
2524 when Tok_Null =>
2525 Scan; -- past NULL
2526 return New_Node (N_Null, Prev_Token_Ptr);
2528 -- Pragma, not allowed here, so just skip past it
2530 when Tok_Pragma =>
2531 P_Pragmas_Misplaced;
2533 -- Deal with IF (possible unparenthesized if expression)
2535 when Tok_If =>
2537 -- If this looks like a real if, defined as an IF appearing at
2538 -- the start of a new line, then we consider we have a missing
2539 -- operand. If in Ada 2012 and the IF is not properly indented
2540 -- for a statement, we prefer to issue a message about an ill-
2541 -- parenthesized if expression.
2543 if Token_Is_At_Start_Of_Line
2544 and then not
2545 (Ada_Version >= Ada_2012
2546 and then Style_Check_Indentation /= 0
2547 and then Start_Column rem Style_Check_Indentation /= 0)
2548 then
2549 Error_Msg_AP ("missing operand");
2550 return Error;
2552 -- If this looks like an if expression, then treat it that way
2553 -- with an error message if not explicitly surrounded by
2554 -- parentheses.
2556 elsif Ada_Version >= Ada_2012 then
2557 Node1 := P_If_Expression;
2559 if not (Lparen and then Token = Tok_Right_Paren) then
2560 Error_Msg
2561 ("if expression must be parenthesized", Sloc (Node1));
2562 end if;
2564 return Node1;
2566 -- Otherwise treat as misused identifier
2568 else
2569 return P_Identifier;
2570 end if;
2572 -- Deal with CASE (possible unparenthesized case expression)
2574 when Tok_Case =>
2576 -- If this looks like a real case, defined as a CASE appearing
2577 -- the start of a new line, then we consider we have a missing
2578 -- operand. If in Ada 2012 and the CASE is not properly
2579 -- indented for a statement, we prefer to issue a message about
2580 -- an ill-parenthesized case expression.
2582 if Token_Is_At_Start_Of_Line
2583 and then not
2584 (Ada_Version >= Ada_2012
2585 and then Style_Check_Indentation /= 0
2586 and then Start_Column rem Style_Check_Indentation /= 0)
2587 then
2588 Error_Msg_AP ("missing operand");
2589 return Error;
2591 -- If this looks like a case expression, then treat it that way
2592 -- with an error message if not within parentheses.
2594 elsif Ada_Version >= Ada_2012 then
2595 Node1 := P_Case_Expression;
2597 if not (Lparen and then Token = Tok_Right_Paren) then
2598 Error_Msg
2599 ("case expression must be parenthesized", Sloc (Node1));
2600 end if;
2602 return Node1;
2604 -- Otherwise treat as misused identifier
2606 else
2607 return P_Identifier;
2608 end if;
2610 -- For [all | some] indicates a quantified expression
2612 when Tok_For =>
2613 if Token_Is_At_Start_Of_Line then
2614 Error_Msg_AP ("misplaced loop");
2615 return Error;
2617 elsif Ada_Version >= Ada_2012 then
2618 Node1 := P_Quantified_Expression;
2620 if not (Lparen and then Token = Tok_Right_Paren) then
2621 Error_Msg
2622 ("quantified expression must be parenthesized",
2623 Sloc (Node1));
2624 end if;
2626 return Node1;
2628 -- Otherwise treat as misused identifier
2630 else
2631 return P_Identifier;
2632 end if;
2634 -- Minus may well be an improper attempt at a unary minus. Give
2635 -- a message, skip the minus and keep going!
2637 when Tok_Minus =>
2638 Error_Msg_SC ("parentheses required for unary minus");
2639 Scan; -- past minus
2641 -- Anything else is illegal as the first token of a primary, but
2642 -- we test for some common errors, to improve error messages.
2644 when others =>
2645 if Is_Reserved_Identifier then
2646 return P_Identifier;
2648 elsif Prev_Token = Tok_Comma then
2649 Error_Msg_SP -- CODEFIX
2650 ("|extra "","" ignored");
2651 raise Error_Resync;
2653 else
2654 Error_Msg_AP ("missing operand");
2655 raise Error_Resync;
2656 end if;
2658 end case;
2659 end loop;
2660 end P_Primary;
2662 -------------------------------
2663 -- 4.4 Quantified_Expression --
2664 -------------------------------
2666 -- QUANTIFIED_EXPRESSION ::=
2667 -- for QUANTIFIER LOOP_PARAMETER_SPECIFICATION => PREDICATE |
2668 -- for QUANTIFIER ITERATOR_SPECIFICATION => PREDICATE
2670 function P_Quantified_Expression return Node_Id is
2671 I_Spec : Node_Id;
2672 Node1 : Node_Id;
2674 begin
2675 Error_Msg_Ada_2012_Feature ("quantified expression", Token_Ptr);
2676 Scan; -- past FOR
2677 Node1 := New_Node (N_Quantified_Expression, Prev_Token_Ptr);
2679 if Token = Tok_All then
2680 Set_All_Present (Node1);
2681 elsif Token /= Tok_Some then
2682 Error_Msg_AP ("missing quantifier");
2683 raise Error_Resync;
2684 end if;
2686 Scan; -- past SOME
2687 I_Spec := P_Loop_Parameter_Specification;
2689 if Nkind (I_Spec) = N_Loop_Parameter_Specification then
2690 Set_Loop_Parameter_Specification (Node1, I_Spec);
2691 else
2692 Set_Iterator_Specification (Node1, I_Spec);
2693 end if;
2695 if Token = Tok_Arrow then
2696 Scan;
2697 Set_Condition (Node1, P_Expression);
2698 return Node1;
2699 else
2700 Error_Msg_AP ("missing arrow");
2701 raise Error_Resync;
2702 end if;
2703 end P_Quantified_Expression;
2705 ---------------------------
2706 -- 4.5 Logical Operator --
2707 ---------------------------
2709 -- LOGICAL_OPERATOR ::= and | or | xor
2711 -- Note: AND THEN and OR ELSE are also treated as logical operators
2712 -- by the parser (even though they are not operators semantically)
2714 -- The value returned is the appropriate Node_Kind code for the operator
2715 -- On return, Token points to the token following the scanned operator.
2717 -- The caller has checked that the first token is a legitimate logical
2718 -- operator token (i.e. is either XOR, AND, OR).
2720 -- Error recovery: cannot raise Error_Resync
2722 function P_Logical_Operator return Node_Kind is
2723 begin
2724 if Token = Tok_And then
2725 if Style_Check then
2726 Style.Check_Binary_Operator;
2727 end if;
2729 Scan; -- past AND
2731 if Token = Tok_Then then
2732 Scan; -- past THEN
2733 return N_And_Then;
2734 else
2735 return N_Op_And;
2736 end if;
2738 elsif Token = Tok_Or then
2739 if Style_Check then
2740 Style.Check_Binary_Operator;
2741 end if;
2743 Scan; -- past OR
2745 if Token = Tok_Else then
2746 Scan; -- past ELSE
2747 return N_Or_Else;
2748 else
2749 return N_Op_Or;
2750 end if;
2752 else -- Token = Tok_Xor
2753 if Style_Check then
2754 Style.Check_Binary_Operator;
2755 end if;
2757 Scan; -- past XOR
2758 return N_Op_Xor;
2759 end if;
2760 end P_Logical_Operator;
2762 ------------------------------
2763 -- 4.5 Relational Operator --
2764 ------------------------------
2766 -- RELATIONAL_OPERATOR ::= = | /= | < | <= | > | >=
2768 -- The value returned is the appropriate Node_Kind code for the operator.
2769 -- On return, Token points to the operator token, NOT past it.
2771 -- The caller has checked that the first token is a legitimate relational
2772 -- operator token (i.e. is one of the operator tokens listed above).
2774 -- Error recovery: cannot raise Error_Resync
2776 function P_Relational_Operator return Node_Kind is
2777 Op_Kind : Node_Kind;
2778 Relop_Node : constant array (Token_Class_Relop) of Node_Kind :=
2779 (Tok_Less => N_Op_Lt,
2780 Tok_Equal => N_Op_Eq,
2781 Tok_Greater => N_Op_Gt,
2782 Tok_Not_Equal => N_Op_Ne,
2783 Tok_Greater_Equal => N_Op_Ge,
2784 Tok_Less_Equal => N_Op_Le,
2785 Tok_In => N_In,
2786 Tok_Not => N_Not_In,
2787 Tok_Box => N_Op_Ne);
2789 begin
2790 if Token = Tok_Box then
2791 Error_Msg_SC -- CODEFIX
2792 ("|""'<'>"" should be ""/=""");
2793 end if;
2795 Op_Kind := Relop_Node (Token);
2797 if Style_Check then
2798 Style.Check_Binary_Operator;
2799 end if;
2801 Scan; -- past operator token
2803 -- Deal with NOT IN, if previous token was NOT, we must have IN now
2805 if Prev_Token = Tok_Not then
2807 -- Style check, for NOT IN, we require one space between NOT and IN
2809 if Style_Check and then Token = Tok_In then
2810 Style.Check_Not_In;
2811 end if;
2813 T_In;
2814 end if;
2816 return Op_Kind;
2817 end P_Relational_Operator;
2819 ---------------------------------
2820 -- 4.5 Binary Adding Operator --
2821 ---------------------------------
2823 -- BINARY_ADDING_OPERATOR ::= + | - | &
2825 -- The value returned is the appropriate Node_Kind code for the operator.
2826 -- On return, Token points to the operator token (NOT past it).
2828 -- The caller has checked that the first token is a legitimate adding
2829 -- operator token (i.e. is one of the operator tokens listed above).
2831 -- Error recovery: cannot raise Error_Resync
2833 function P_Binary_Adding_Operator return Node_Kind is
2834 Addop_Node : constant array (Token_Class_Binary_Addop) of Node_Kind :=
2835 (Tok_Ampersand => N_Op_Concat,
2836 Tok_Minus => N_Op_Subtract,
2837 Tok_Plus => N_Op_Add);
2838 begin
2839 return Addop_Node (Token);
2840 end P_Binary_Adding_Operator;
2842 --------------------------------
2843 -- 4.5 Unary Adding Operator --
2844 --------------------------------
2846 -- UNARY_ADDING_OPERATOR ::= + | -
2848 -- The value returned is the appropriate Node_Kind code for the operator.
2849 -- On return, Token points to the operator token (NOT past it).
2851 -- The caller has checked that the first token is a legitimate adding
2852 -- operator token (i.e. is one of the operator tokens listed above).
2854 -- Error recovery: cannot raise Error_Resync
2856 function P_Unary_Adding_Operator return Node_Kind is
2857 Addop_Node : constant array (Token_Class_Unary_Addop) of Node_Kind :=
2858 (Tok_Minus => N_Op_Minus,
2859 Tok_Plus => N_Op_Plus);
2860 begin
2861 return Addop_Node (Token);
2862 end P_Unary_Adding_Operator;
2864 -------------------------------
2865 -- 4.5 Multiplying Operator --
2866 -------------------------------
2868 -- MULTIPLYING_OPERATOR ::= * | / | mod | rem
2870 -- The value returned is the appropriate Node_Kind code for the operator.
2871 -- On return, Token points to the operator token (NOT past it).
2873 -- The caller has checked that the first token is a legitimate multiplying
2874 -- operator token (i.e. is one of the operator tokens listed above).
2876 -- Error recovery: cannot raise Error_Resync
2878 function P_Multiplying_Operator return Node_Kind is
2879 Mulop_Node : constant array (Token_Class_Mulop) of Node_Kind :=
2880 (Tok_Asterisk => N_Op_Multiply,
2881 Tok_Mod => N_Op_Mod,
2882 Tok_Rem => N_Op_Rem,
2883 Tok_Slash => N_Op_Divide);
2884 begin
2885 return Mulop_Node (Token);
2886 end P_Multiplying_Operator;
2888 --------------------------------------
2889 -- 4.5 Highest Precedence Operator --
2890 --------------------------------------
2892 -- Parsed by P_Factor (4.4)
2894 -- Note: this rule is not in fact used by the grammar at any point!
2896 --------------------------
2897 -- 4.6 Type Conversion --
2898 --------------------------
2900 -- Parsed by P_Primary as a Name (4.1)
2902 -------------------------------
2903 -- 4.7 Qualified Expression --
2904 -------------------------------
2906 -- QUALIFIED_EXPRESSION ::=
2907 -- SUBTYPE_MARK ' (EXPRESSION) | SUBTYPE_MARK ' AGGREGATE
2909 -- The caller has scanned the name which is the Subtype_Mark parameter
2910 -- and scanned past the single quote following the subtype mark. The
2911 -- caller has not checked that this name is in fact appropriate for
2912 -- a subtype mark name (i.e. it is a selected component or identifier).
2914 -- Error_Recovery: cannot raise Error_Resync
2916 function P_Qualified_Expression (Subtype_Mark : Node_Id) return Node_Id is
2917 Qual_Node : Node_Id;
2918 begin
2919 Qual_Node := New_Node (N_Qualified_Expression, Prev_Token_Ptr);
2920 Set_Subtype_Mark (Qual_Node, Check_Subtype_Mark (Subtype_Mark));
2921 Set_Expression (Qual_Node, P_Aggregate_Or_Paren_Expr);
2922 return Qual_Node;
2923 end P_Qualified_Expression;
2925 --------------------
2926 -- 4.8 Allocator --
2927 --------------------
2929 -- ALLOCATOR ::=
2930 -- new [SUBPOOL_SPECIFICATION] SUBTYPE_INDICATION
2931 -- | new [SUBPOOL_SPECIFICATION] QUALIFIED_EXPRESSION
2933 -- SUBPOOL_SPECIFICATION ::= (subpool_handle_NAME)
2935 -- The caller has checked that the initial token is NEW
2937 -- Error recovery: can raise Error_Resync
2939 function P_Allocator return Node_Id is
2940 Alloc_Node : Node_Id;
2941 Type_Node : Node_Id;
2942 Null_Exclusion_Present : Boolean;
2944 begin
2945 Alloc_Node := New_Node (N_Allocator, Token_Ptr);
2946 T_New;
2948 -- Scan subpool_specification if present (Ada 2012 (AI05-0111-3))
2950 -- Scan Null_Exclusion if present (Ada 2005 (AI-231))
2952 if Token = Tok_Left_Paren then
2953 Scan; -- past (
2954 Set_Subpool_Handle_Name (Alloc_Node, P_Name);
2955 T_Right_Paren;
2957 Error_Msg_Ada_2012_Feature
2958 ("|subpool specification",
2959 Sloc (Subpool_Handle_Name (Alloc_Node)));
2960 end if;
2962 Null_Exclusion_Present := P_Null_Exclusion;
2963 Set_Null_Exclusion_Present (Alloc_Node, Null_Exclusion_Present);
2964 Type_Node := P_Subtype_Mark_Resync;
2966 if Token = Tok_Apostrophe then
2967 Scan; -- past apostrophe
2968 Set_Expression (Alloc_Node, P_Qualified_Expression (Type_Node));
2969 else
2970 Set_Expression
2971 (Alloc_Node,
2972 P_Subtype_Indication (Type_Node, Null_Exclusion_Present));
2974 -- AI05-0104: An explicit null exclusion is not allowed for an
2975 -- allocator without initialization. In previous versions of the
2976 -- language it just raises constraint error.
2978 if Ada_Version >= Ada_2012 and then Null_Exclusion_Present then
2979 Error_Msg_N
2980 ("an allocator with a subtype indication "
2981 & "cannot have a null exclusion", Alloc_Node);
2982 end if;
2983 end if;
2985 return Alloc_Node;
2986 end P_Allocator;
2988 -----------------------
2989 -- P_Case_Expression --
2990 -----------------------
2992 function P_Case_Expression return Node_Id is
2993 Loc : constant Source_Ptr := Token_Ptr;
2994 Case_Node : Node_Id;
2995 Save_State : Saved_Scan_State;
2997 begin
2998 Error_Msg_Ada_2012_Feature ("|case expression", Token_Ptr);
2999 Scan; -- past CASE
3000 Case_Node :=
3001 Make_Case_Expression (Loc,
3002 Expression => P_Expression_No_Right_Paren,
3003 Alternatives => New_List);
3004 T_Is;
3006 -- We now have scanned out CASE expression IS, scan alternatives
3008 loop
3009 T_When;
3010 Append_To (Alternatives (Case_Node), P_Case_Expression_Alternative);
3012 -- Missing comma if WHEN (more alternatives present)
3014 if Token = Tok_When then
3015 T_Comma;
3017 -- If comma/WHEN, skip comma and we have another alternative
3019 elsif Token = Tok_Comma then
3020 Save_Scan_State (Save_State);
3021 Scan; -- past comma
3023 if Token /= Tok_When then
3024 Restore_Scan_State (Save_State);
3025 exit;
3026 end if;
3028 -- If no comma or WHEN, definitely done
3030 else
3031 exit;
3032 end if;
3033 end loop;
3035 -- If we have an END CASE, diagnose as not needed
3037 if Token = Tok_End then
3038 Error_Msg_SC ("`END CASE` not allowed at end of case expression");
3039 Scan; -- past END
3041 if Token = Tok_Case then
3042 Scan; -- past CASE;
3043 end if;
3044 end if;
3046 -- Return the Case_Expression node
3048 return Case_Node;
3049 end P_Case_Expression;
3051 -----------------------------------
3052 -- P_Case_Expression_Alternative --
3053 -----------------------------------
3055 -- CASE_STATEMENT_ALTERNATIVE ::=
3056 -- when DISCRETE_CHOICE_LIST =>
3057 -- EXPRESSION
3059 -- The caller has checked that and scanned past the initial WHEN token
3060 -- Error recovery: can raise Error_Resync
3062 function P_Case_Expression_Alternative return Node_Id is
3063 Case_Alt_Node : Node_Id;
3064 begin
3065 Case_Alt_Node := New_Node (N_Case_Expression_Alternative, Token_Ptr);
3066 Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List);
3067 TF_Arrow;
3068 Set_Expression (Case_Alt_Node, P_Expression);
3069 return Case_Alt_Node;
3070 end P_Case_Expression_Alternative;
3072 ---------------------
3073 -- P_If_Expression --
3074 ---------------------
3076 function P_If_Expression return Node_Id is
3077 Exprs : constant List_Id := New_List;
3078 Loc : constant Source_Ptr := Token_Ptr;
3079 Expr : Node_Id;
3080 State : Saved_Scan_State;
3082 begin
3083 Inside_If_Expression := Inside_If_Expression + 1;
3084 Error_Msg_Ada_2012_Feature ("|if expression", Token_Ptr);
3085 Scan; -- past IF or ELSIF
3086 Append_To (Exprs, P_Condition);
3087 TF_Then;
3088 Append_To (Exprs, P_Expression);
3090 -- We now have scanned out IF expr THEN expr
3092 -- Check for common error of semicolon before the ELSE
3094 if Token = Tok_Semicolon then
3095 Save_Scan_State (State);
3096 Scan; -- past semicolon
3098 if Token = Tok_Else or else Token = Tok_Elsif then
3099 Error_Msg_SP -- CODEFIX
3100 ("|extra "";"" ignored");
3102 else
3103 Restore_Scan_State (State);
3104 end if;
3105 end if;
3107 -- Scan out ELSIF sequence if present
3109 if Token = Tok_Elsif then
3110 Expr := P_If_Expression;
3111 Set_Is_Elsif (Expr);
3112 Append_To (Exprs, Expr);
3114 -- Scan out ELSE phrase if present
3116 elsif Token = Tok_Else then
3118 -- Scan out ELSE expression
3120 Scan; -- Past ELSE
3121 Append_To (Exprs, P_Expression);
3123 -- Skip redundant ELSE parts
3125 while Token = Tok_Else loop
3126 Error_Msg_SC ("only one ELSE part is allowed");
3127 Scan; -- past ELSE
3128 Discard_Junk_Node (P_Expression);
3129 end loop;
3131 -- Two expression case (implied True, filled in during semantics)
3133 else
3134 null;
3135 end if;
3137 -- If we have an END IF, diagnose as not needed
3139 if Token = Tok_End then
3140 Error_Msg_SC ("`END IF` not allowed at end of if expression");
3141 Scan; -- past END
3143 if Token = Tok_If then
3144 Scan; -- past IF;
3145 end if;
3146 end if;
3148 Inside_If_Expression := Inside_If_Expression - 1;
3150 -- Return the If_Expression node
3152 return
3153 Make_If_Expression (Loc,
3154 Expressions => Exprs);
3155 end P_If_Expression;
3157 -----------------------
3158 -- P_Membership_Test --
3159 -----------------------
3161 -- MEMBERSHIP_CHOICE_LIST ::= MEMBERHIP_CHOICE {'|' MEMBERSHIP_CHOICE}
3162 -- MEMBERSHIP_CHOICE ::= CHOICE_EXPRESSION | range | subtype_mark
3164 procedure P_Membership_Test (N : Node_Id) is
3165 Alt : constant Node_Id :=
3166 P_Range_Or_Subtype_Mark
3167 (Allow_Simple_Expression => (Ada_Version >= Ada_2012));
3169 begin
3170 -- Set case
3172 if Token = Tok_Vertical_Bar then
3173 Error_Msg_Ada_2012_Feature ("set notation", Token_Ptr);
3174 Set_Alternatives (N, New_List (Alt));
3175 Set_Right_Opnd (N, Empty);
3177 -- Loop to accumulate alternatives
3179 while Token = Tok_Vertical_Bar loop
3180 Scan; -- past vertical bar
3181 Append_To
3182 (Alternatives (N),
3183 P_Range_Or_Subtype_Mark (Allow_Simple_Expression => True));
3184 end loop;
3186 -- Not set case
3188 else
3189 Set_Right_Opnd (N, Alt);
3190 Set_Alternatives (N, No_List);
3191 end if;
3192 end P_Membership_Test;
3194 ------------------------------------------
3195 -- P_Unparen_Cond_Case_Quant_Expression --
3196 ------------------------------------------
3198 function P_Unparen_Cond_Case_Quant_Expression return Node_Id is
3199 Lparen : constant Boolean := Prev_Token = Tok_Left_Paren;
3200 Result : Node_Id;
3202 begin
3203 -- Case expression
3205 if Token = Tok_Case then
3206 Result := P_Case_Expression;
3208 if not (Lparen and then Token = Tok_Right_Paren) then
3209 Error_Msg_N ("case expression must be parenthesized!", Result);
3210 end if;
3212 -- If expression
3214 elsif Token = Tok_If then
3215 Result := P_If_Expression;
3217 if not (Lparen and then Token = Tok_Right_Paren) then
3218 Error_Msg_N ("if expression must be parenthesized!", Result);
3219 end if;
3221 -- Quantified expression
3223 elsif Token = Tok_For then
3224 Result := P_Quantified_Expression;
3226 if not (Lparen and then Token = Tok_Right_Paren) then
3227 Error_Msg_N
3228 ("quantified expression must be parenthesized!", Result);
3229 end if;
3231 -- No other possibility should exist (caller was supposed to check)
3233 else
3234 raise Program_Error;
3235 end if;
3237 -- Return expression (possibly after having given message)
3239 return Result;
3240 end P_Unparen_Cond_Case_Quant_Expression;
3242 end Ch4;