OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [par-ch4.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.