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