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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [par-ch3.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 3                               --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2012, 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 Sinfo.CN; use Sinfo.CN;
31
 
32
separate (Par)
33
 
34
---------
35
-- Ch3 --
36
---------
37
 
38
package body Ch3 is
39
 
40
   -----------------------
41
   -- Local Subprograms --
42
   -----------------------
43
 
44
   function P_Component_List                               return Node_Id;
45
   function P_Defining_Character_Literal                   return Node_Id;
46
   function P_Delta_Constraint                             return Node_Id;
47
   function P_Derived_Type_Def_Or_Private_Ext_Decl         return Node_Id;
48
   function P_Digits_Constraint                            return Node_Id;
49
   function P_Discriminant_Association                     return Node_Id;
50
   function P_Enumeration_Literal_Specification            return Node_Id;
51
   function P_Enumeration_Type_Definition                  return Node_Id;
52
   function P_Fixed_Point_Definition                       return Node_Id;
53
   function P_Floating_Point_Definition                    return Node_Id;
54
   function P_Index_Or_Discriminant_Constraint             return Node_Id;
55
   function P_Real_Range_Specification_Opt                 return Node_Id;
56
   function P_Subtype_Declaration                          return Node_Id;
57
   function P_Type_Declaration                             return Node_Id;
58
   function P_Modular_Type_Definition                      return Node_Id;
59
   function P_Variant                                      return Node_Id;
60
   function P_Variant_Part                                 return Node_Id;
61
 
62
   procedure Check_Restricted_Expression (N : Node_Id);
63
   --  Check that the expression N meets the Restricted_Expression syntax.
64
   --  The syntax is as follows:
65
   --
66
   --    RESTRICTED_EXPRESSION ::=
67
   --        RESTRICTED_RELATION {and RESTRICTED_RELATION}
68
   --      | RESTRICTED_RELATION {and then RESTRICTED_RELATION}
69
   --      | RESTRICTED_RELATION {or RESTRICTED_RELATION}
70
   --      | RESTRICTED_RELATION {or else RESTRICTED_RELATION}
71
   --      | RESTRICTED_RELATION {xor RESTRICTED_RELATION}
72
   --
73
   --    RESTRICTED_RELATION ::=
74
   --       SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION]
75
   --
76
   --  This syntax is used for choices when extensions (and set notations)
77
   --  are enabled, to remove the ambiguity of "when X in A | B". We consider
78
   --  it very unlikely that this will ever arise in practice.
79
 
80
   procedure P_Declarative_Items
81
     (Decls   : List_Id;
82
      Done    : out Boolean;
83
      In_Spec : Boolean);
84
   --  Scans out a single declarative item, or, in the case of a declaration
85
   --  with a list of identifiers, a list of declarations, one for each of the
86
   --  identifiers in the list. The declaration or declarations scanned are
87
   --  appended to the given list. Done indicates whether or not there may be
88
   --  additional declarative items to scan. If Done is True, then a decision
89
   --  has been made that there are no more items to scan. If Done is False,
90
   --  then there may be additional declarations to scan. In_Spec is true if
91
   --  we are scanning a package declaration, and is used to generate an
92
   --  appropriate message if a statement is encountered in such a context.
93
 
94
   procedure P_Identifier_Declarations
95
     (Decls   : List_Id;
96
      Done    : out Boolean;
97
      In_Spec : Boolean);
98
   --  Scans out a set of declarations for an identifier or list of
99
   --  identifiers, and appends them to the given list. The parameters have
100
   --  the same significance as for P_Declarative_Items.
101
 
102
   procedure Statement_When_Declaration_Expected
103
     (Decls   : List_Id;
104
      Done    : out Boolean;
105
      In_Spec : Boolean);
106
   --  Called when a statement is found at a point where a declaration was
107
   --  expected. The parameters are as described for P_Declarative_Items.
108
 
109
   procedure Set_Declaration_Expected;
110
   --  Posts a "declaration expected" error messages at the start of the
111
   --  current token, and if this is the first such message issued, saves
112
   --  the message id in Missing_Begin_Msg, for possible later replacement.
113
 
114
   ---------------------------------
115
   -- Check_Restricted_Expression --
116
   ---------------------------------
117
 
118
   procedure Check_Restricted_Expression (N : Node_Id) is
119
   begin
120
      if Nkind_In (N, N_Op_And, N_Op_Or, N_Op_Xor, N_And_Then, N_Or_Else) then
121
         Check_Restricted_Expression (Left_Opnd (N));
122
         Check_Restricted_Expression (Right_Opnd (N));
123
 
124
      elsif Nkind_In (N, N_In, N_Not_In)
125
        and then Paren_Count (N) = 0
126
      then
127
         Error_Msg_N ("|this expression must be parenthesized!", N);
128
      end if;
129
   end Check_Restricted_Expression;
130
 
131
   -------------------
132
   -- Init_Expr_Opt --
133
   -------------------
134
 
135
   function Init_Expr_Opt (P : Boolean := False) return Node_Id is
136
   begin
137
      --  For colon, assume it means := unless it is at the end of
138
      --  a line, in which case guess that it means a semicolon.
139
 
140
      if Token = Tok_Colon then
141
         if Token_Is_At_End_Of_Line then
142
            T_Semicolon;
143
            return Empty;
144
         end if;
145
 
146
      --  Here if := or something that we will take as equivalent
147
 
148
      elsif Token = Tok_Colon_Equal
149
        or else Token = Tok_Equal
150
        or else Token = Tok_Is
151
      then
152
         null;
153
 
154
      --  Another possibility. If we have a literal followed by a semicolon,
155
      --  we assume that we have a missing colon-equal.
156
 
157
      elsif Token in Token_Class_Literal then
158
         declare
159
            Scan_State : Saved_Scan_State;
160
 
161
         begin
162
            Save_Scan_State (Scan_State);
163
            Scan; -- past literal or identifier
164
 
165
            if Token = Tok_Semicolon then
166
               Restore_Scan_State (Scan_State);
167
            else
168
               Restore_Scan_State (Scan_State);
169
               return Empty;
170
            end if;
171
         end;
172
 
173
      --  Otherwise we definitely have no initialization expression
174
 
175
      else
176
         return Empty;
177
      end if;
178
 
179
      --  Merge here if we have an initialization expression
180
 
181
      T_Colon_Equal;
182
 
183
      if P then
184
         return P_Expression;
185
      else
186
         return P_Expression_No_Right_Paren;
187
      end if;
188
   end Init_Expr_Opt;
189
 
190
   ----------------------------
191
   -- 3.1  Basic Declaration --
192
   ----------------------------
193
 
194
   --  Parsed by P_Basic_Declarative_Items (3.9)
195
 
196
   ------------------------------
197
   -- 3.1  Defining Identifier --
198
   ------------------------------
199
 
200
   --  DEFINING_IDENTIFIER ::= IDENTIFIER
201
 
202
   --  Error recovery: can raise Error_Resync
203
 
204
   function P_Defining_Identifier (C : Id_Check := None) return Node_Id is
205
      Ident_Node : Node_Id;
206
 
207
   begin
208
      --  Scan out the identifier. Note that this code is essentially identical
209
      --  to P_Identifier, except that in the call to Scan_Reserved_Identifier
210
      --  we set Force_Msg to True, since we want at least one message for each
211
      --  separate declaration (but not use) of a reserved identifier.
212
 
213
      --  Duplication should be removed, common code should be factored???
214
 
215
      if Token = Tok_Identifier then
216
         Check_Future_Keyword;
217
 
218
      --  If we have a reserved identifier, manufacture an identifier with
219
      --  a corresponding name after posting an appropriate error message
220
 
221
      elsif Is_Reserved_Identifier (C) then
222
         Scan_Reserved_Identifier (Force_Msg => True);
223
 
224
      --  Otherwise we have junk that cannot be interpreted as an identifier
225
 
226
      else
227
         T_Identifier; -- to give message
228
         raise Error_Resync;
229
      end if;
230
 
231
      Ident_Node := Token_Node;
232
      Scan; -- past the reserved identifier
233
 
234
      --  If we already have a defining identifier, clean it out and make
235
      --  a new clean identifier. This situation arises in some error cases
236
      --  and we need to fix it.
237
 
238
      if Nkind (Ident_Node) = N_Defining_Identifier then
239
         Ident_Node := Make_Identifier (Sloc (Ident_Node), Chars (Ident_Node));
240
      end if;
241
 
242
      --  Change identifier to defining identifier if not in error
243
 
244
      if Ident_Node /= Error then
245
         Change_Identifier_To_Defining_Identifier (Ident_Node);
246
      end if;
247
 
248
      return Ident_Node;
249
   end P_Defining_Identifier;
250
 
251
   -----------------------------
252
   -- 3.2.1  Type Declaration --
253
   -----------------------------
254
 
255
   --  TYPE_DECLARATION ::=
256
   --    FULL_TYPE_DECLARATION
257
   --  | INCOMPLETE_TYPE_DECLARATION
258
   --  | PRIVATE_TYPE_DECLARATION
259
   --  | PRIVATE_EXTENSION_DECLARATION
260
 
261
   --  FULL_TYPE_DECLARATION ::=
262
   --    type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION
263
   --      [ASPECT_SPECIFICATIONS];
264
   --  | CONCURRENT_TYPE_DECLARATION
265
 
266
   --  INCOMPLETE_TYPE_DECLARATION ::=
267
   --    type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [is tagged];
268
 
269
   --  PRIVATE_TYPE_DECLARATION ::=
270
   --    type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
271
   --      is [abstract] [tagged] [limited] private;
272
 
273
   --  PRIVATE_EXTENSION_DECLARATION ::=
274
   --    type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
275
   --      [abstract] [limited | synchronized]
276
   --        new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
277
   --          with private;
278
 
279
   --  TYPE_DEFINITION ::=
280
   --    ENUMERATION_TYPE_DEFINITION  | INTEGER_TYPE_DEFINITION
281
   --  | REAL_TYPE_DEFINITION         | ARRAY_TYPE_DEFINITION
282
   --  | RECORD_TYPE_DEFINITION       | ACCESS_TYPE_DEFINITION
283
   --  | DERIVED_TYPE_DEFINITION      | INTERFACE_TYPE_DEFINITION
284
 
285
   --  INTEGER_TYPE_DEFINITION ::=
286
   --    SIGNED_INTEGER_TYPE_DEFINITION
287
   --    MODULAR_TYPE_DEFINITION
288
 
289
   --  INTERFACE_TYPE_DEFINITION ::=
290
   --    [limited | task | protected | synchronized ] interface
291
   --      [and INTERFACE_LIST]
292
 
293
   --  Error recovery: can raise Error_Resync
294
 
295
   --  The processing for full type declarations, incomplete type declarations,
296
   --  private type declarations and type definitions is included in this
297
   --  function. The processing for concurrent type declarations is NOT here,
298
   --  but rather in chapter 9 (this function handles only declarations
299
   --  starting with TYPE).
300
 
301
   function P_Type_Declaration return Node_Id is
302
      Abstract_Present : Boolean := False;
303
      Abstract_Loc     : Source_Ptr := No_Location;
304
      Decl_Node        : Node_Id;
305
      Discr_List       : List_Id;
306
      Discr_Sloc       : Source_Ptr;
307
      End_Labl         : Node_Id;
308
      Ident_Node       : Node_Id;
309
      Is_Derived_Iface : Boolean := False;
310
      Type_Loc         : Source_Ptr;
311
      Type_Start_Col   : Column_Number;
312
      Unknown_Dis      : Boolean;
313
 
314
      Typedef_Node : Node_Id;
315
      --  Normally holds type definition, except in the case of a private
316
      --  extension declaration, in which case it holds the declaration itself
317
 
318
   begin
319
      Type_Loc := Token_Ptr;
320
      Type_Start_Col := Start_Column;
321
 
322
      --  If we have TYPE, then proceed ahead and scan identifier
323
 
324
      if Token = Tok_Type then
325
         Type_Token_Location := Type_Loc;
326
         Scan; -- past TYPE
327
         Ident_Node := P_Defining_Identifier (C_Is);
328
 
329
      --  Otherwise this is an error case
330
 
331
      else
332
         T_Type;
333
         Type_Token_Location := Type_Loc;
334
         Ident_Node := P_Defining_Identifier (C_Is);
335
      end if;
336
 
337
      Discr_Sloc := Token_Ptr;
338
 
339
      if P_Unknown_Discriminant_Part_Opt then
340
         Unknown_Dis := True;
341
         Discr_List := No_List;
342
      else
343
         Unknown_Dis := False;
344
         Discr_List := P_Known_Discriminant_Part_Opt;
345
      end if;
346
 
347
      --  Incomplete type declaration. We complete the processing for this
348
      --  case here and return the resulting incomplete type declaration node
349
 
350
      if Token = Tok_Semicolon then
351
         Scan; -- past ;
352
         Decl_Node := New_Node (N_Incomplete_Type_Declaration, Type_Loc);
353
         Set_Defining_Identifier (Decl_Node, Ident_Node);
354
         Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
355
         Set_Discriminant_Specifications (Decl_Node, Discr_List);
356
         return Decl_Node;
357
 
358
      else
359
         Decl_Node := Empty;
360
      end if;
361
 
362
      --  Full type declaration or private type declaration, must have IS
363
 
364
      if Token = Tok_Equal then
365
         TF_Is;
366
         Scan; -- past = used in place of IS
367
 
368
      elsif Token = Tok_Renames then
369
         Error_Msg_SC  -- CODEFIX
370
           ("RENAMES should be IS");
371
         Scan; -- past RENAMES used in place of IS
372
 
373
      else
374
         TF_Is;
375
      end if;
376
 
377
      --  First an error check, if we have two identifiers in a row, a likely
378
      --  possibility is that the first of the identifiers is an incorrectly
379
      --  spelled keyword.
380
 
381
      if Token = Tok_Identifier then
382
         declare
383
            SS : Saved_Scan_State;
384
            I2 : Boolean;
385
 
386
         begin
387
            Save_Scan_State (SS);
388
            Scan; -- past initial identifier
389
            I2 := (Token = Tok_Identifier);
390
            Restore_Scan_State (SS);
391
 
392
            if I2
393
              and then
394
                (Bad_Spelling_Of (Tok_Abstract) or else
395
                 Bad_Spelling_Of (Tok_Access)   or else
396
                 Bad_Spelling_Of (Tok_Aliased)  or else
397
                 Bad_Spelling_Of (Tok_Constant))
398
            then
399
               null;
400
            end if;
401
         end;
402
      end if;
403
 
404
      --  Check for misuse of Ada 95 keyword abstract in Ada 83 mode
405
 
406
      if Token_Name = Name_Abstract then
407
         Check_95_Keyword (Tok_Abstract, Tok_Tagged);
408
         Check_95_Keyword (Tok_Abstract, Tok_New);
409
      end if;
410
 
411
      --  Check cases of misuse of ABSTRACT
412
 
413
      if Token = Tok_Abstract then
414
         Abstract_Present := True;
415
         Abstract_Loc     := Token_Ptr;
416
         Scan; -- past ABSTRACT
417
 
418
         --  Ada 2005 (AI-419): AARM 3.4 (2/2)
419
 
420
         if (Ada_Version < Ada_2005 and then Token = Tok_Limited)
421
           or else Token = Tok_Private
422
           or else Token = Tok_Record
423
           or else Token = Tok_Null
424
         then
425
            Error_Msg_AP ("TAGGED expected");
426
         end if;
427
      end if;
428
 
429
      --  Check for misuse of Ada 95 keyword Tagged
430
 
431
      if Token_Name = Name_Tagged then
432
         Check_95_Keyword (Tok_Tagged, Tok_Private);
433
         Check_95_Keyword (Tok_Tagged, Tok_Limited);
434
         Check_95_Keyword (Tok_Tagged, Tok_Record);
435
      end if;
436
 
437
      --  Special check for misuse of Aliased
438
 
439
      if Token = Tok_Aliased or else Token_Name = Name_Aliased then
440
         Error_Msg_SC ("ALIASED not allowed in type definition");
441
         Scan; -- past ALIASED
442
      end if;
443
 
444
      --  The following processing deals with either a private type declaration
445
      --  or a full type declaration. In the private type case, we build the
446
      --  N_Private_Type_Declaration node, setting its Tagged_Present and
447
      --  Limited_Present flags, on encountering the Private keyword, and
448
      --  leave Typedef_Node set to Empty. For the full type declaration
449
      --  case, Typedef_Node gets set to the type definition.
450
 
451
      Typedef_Node := Empty;
452
 
453
      --  Switch on token following the IS. The loop normally runs once. It
454
      --  only runs more than once if an error is detected, to try again after
455
      --  detecting and fixing up the error.
456
 
457
      loop
458
         case Token is
459
 
460
            when Tok_Access |
461
                 Tok_Not    => --  Ada 2005 (AI-231)
462
               Typedef_Node := P_Access_Type_Definition;
463
               exit;
464
 
465
            when Tok_Array =>
466
               Typedef_Node := P_Array_Type_Definition;
467
               exit;
468
 
469
            when Tok_Delta =>
470
               Typedef_Node := P_Fixed_Point_Definition;
471
               exit;
472
 
473
            when Tok_Digits =>
474
               Typedef_Node := P_Floating_Point_Definition;
475
               exit;
476
 
477
            when Tok_In =>
478
               Ignore (Tok_In);
479
 
480
            when Tok_Integer_Literal =>
481
               T_Range;
482
               Typedef_Node := P_Signed_Integer_Type_Definition;
483
               exit;
484
 
485
            when Tok_Null =>
486
               Typedef_Node := P_Record_Definition;
487
               exit;
488
 
489
            when Tok_Left_Paren =>
490
               Typedef_Node := P_Enumeration_Type_Definition;
491
 
492
               End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node));
493
               Set_Comes_From_Source (End_Labl, False);
494
 
495
               Set_End_Label (Typedef_Node, End_Labl);
496
               exit;
497
 
498
            when Tok_Mod =>
499
               Typedef_Node := P_Modular_Type_Definition;
500
               exit;
501
 
502
            when Tok_New =>
503
               Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
504
 
505
               if Nkind (Typedef_Node) = N_Derived_Type_Definition
506
                 and then Present (Record_Extension_Part (Typedef_Node))
507
               then
508
                  End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node));
509
                  Set_Comes_From_Source (End_Labl, False);
510
 
511
                  Set_End_Label
512
                    (Record_Extension_Part (Typedef_Node), End_Labl);
513
               end if;
514
 
515
               exit;
516
 
517
            when Tok_Range =>
518
               Typedef_Node := P_Signed_Integer_Type_Definition;
519
               exit;
520
 
521
            when Tok_Record =>
522
               Typedef_Node := P_Record_Definition;
523
 
524
               End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node));
525
               Set_Comes_From_Source (End_Labl, False);
526
 
527
               Set_End_Label (Typedef_Node, End_Labl);
528
               exit;
529
 
530
            when Tok_Tagged =>
531
               Scan; -- past TAGGED
532
 
533
               --  Ada 2005 (AI-326): If the words IS TAGGED appear, the type
534
               --  is a tagged incomplete type.
535
 
536
               if Ada_Version >= Ada_2005
537
                 and then Token = Tok_Semicolon
538
               then
539
                  Scan; -- past ;
540
 
541
                  Decl_Node :=
542
                    New_Node (N_Incomplete_Type_Declaration, Type_Loc);
543
                  Set_Defining_Identifier           (Decl_Node, Ident_Node);
544
                  Set_Tagged_Present                (Decl_Node);
545
                  Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
546
                  Set_Discriminant_Specifications   (Decl_Node, Discr_List);
547
 
548
                  return Decl_Node;
549
               end if;
550
 
551
               if Token = Tok_Abstract then
552
                  Error_Msg_SC -- CODEFIX
553
                    ("ABSTRACT must come before TAGGED");
554
                  Abstract_Present := True;
555
                  Abstract_Loc := Token_Ptr;
556
                  Scan; -- past ABSTRACT
557
               end if;
558
 
559
               if Token = Tok_Limited then
560
                  Scan; -- past LIMITED
561
 
562
                  --  TAGGED LIMITED PRIVATE case
563
 
564
                  if Token = Tok_Private then
565
                     Decl_Node :=
566
                       New_Node (N_Private_Type_Declaration, Type_Loc);
567
                     Set_Tagged_Present (Decl_Node, True);
568
                     Set_Limited_Present (Decl_Node, True);
569
                     Scan; -- past PRIVATE
570
 
571
                  --  TAGGED LIMITED RECORD
572
 
573
                  else
574
                     Typedef_Node := P_Record_Definition;
575
                     Set_Tagged_Present (Typedef_Node, True);
576
                     Set_Limited_Present (Typedef_Node, True);
577
 
578
                     End_Labl :=
579
                       Make_Identifier (Token_Ptr, Chars (Ident_Node));
580
                     Set_Comes_From_Source (End_Labl, False);
581
 
582
                     Set_End_Label (Typedef_Node, End_Labl);
583
                  end if;
584
 
585
               else
586
                  --  TAGGED PRIVATE
587
 
588
                  if Token = Tok_Private then
589
                     Decl_Node :=
590
                       New_Node (N_Private_Type_Declaration, Type_Loc);
591
                     Set_Tagged_Present (Decl_Node, True);
592
                     Scan; -- past PRIVATE
593
 
594
                  --  TAGGED RECORD
595
 
596
                  else
597
                     Typedef_Node := P_Record_Definition;
598
                     Set_Tagged_Present (Typedef_Node, True);
599
 
600
                     End_Labl :=
601
                       Make_Identifier (Token_Ptr, Chars (Ident_Node));
602
                     Set_Comes_From_Source (End_Labl, False);
603
 
604
                     Set_End_Label (Typedef_Node, End_Labl);
605
                  end if;
606
               end if;
607
 
608
               exit;
609
 
610
            when Tok_Limited =>
611
               Scan; -- past LIMITED
612
 
613
               loop
614
                  if Token = Tok_Tagged then
615
                     Error_Msg_SC -- CODEFIX
616
                       ("TAGGED must come before LIMITED");
617
                     Scan; -- past TAGGED
618
 
619
                  elsif Token = Tok_Abstract then
620
                     Error_Msg_SC -- CODEFIX
621
                       ("ABSTRACT must come before LIMITED");
622
                     Scan; -- past ABSTRACT
623
 
624
                  else
625
                     exit;
626
                  end if;
627
               end loop;
628
 
629
               --  LIMITED RECORD or LIMITED NULL RECORD
630
 
631
               if Token = Tok_Record or else Token = Tok_Null then
632
                  if Ada_Version = Ada_83 then
633
                     Error_Msg_SP
634
                       ("(Ada 83) limited record declaration not allowed!");
635
 
636
                  --  In Ada 2005, "abstract limited" can appear before "new",
637
                  --  but it cannot be part of an untagged record declaration.
638
 
639
                  elsif Abstract_Present
640
                    and then Prev_Token /= Tok_Tagged
641
                  then
642
                     Error_Msg_SP ("TAGGED expected");
643
                  end if;
644
 
645
                  Typedef_Node := P_Record_Definition;
646
                  Set_Limited_Present (Typedef_Node, True);
647
 
648
               --  Ada 2005 (AI-251): LIMITED INTERFACE
649
 
650
               --  If we are compiling in Ada 83 or Ada 95 mode, "interface"
651
               --  is not a reserved word but we force its analysis to
652
               --  generate the corresponding usage error.
653
 
654
               elsif Token = Tok_Interface
655
                 or else (Token = Tok_Identifier
656
                           and then Chars (Token_Node) = Name_Interface)
657
               then
658
                  Typedef_Node :=
659
                    P_Interface_Type_Definition (Abstract_Present);
660
                  Abstract_Present := True;
661
                  Set_Limited_Present (Typedef_Node);
662
 
663
                  if Nkind (Typedef_Node) = N_Derived_Type_Definition then
664
                     Is_Derived_Iface := True;
665
                  end if;
666
 
667
                  --  Ada 2005 (AI-419): LIMITED NEW
668
 
669
               elsif Token = Tok_New then
670
                  if Ada_Version < Ada_2005 then
671
                     Error_Msg_SP
672
                       ("LIMITED in derived type is an Ada 2005 extension");
673
                     Error_Msg_SP
674
                       ("\unit must be compiled with -gnat05 switch");
675
                  end if;
676
 
677
                  Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
678
                  Set_Limited_Present (Typedef_Node);
679
 
680
                  if Nkind (Typedef_Node) = N_Derived_Type_Definition
681
                    and then Present (Record_Extension_Part (Typedef_Node))
682
                  then
683
                     End_Labl :=
684
                       Make_Identifier (Token_Ptr, Chars (Ident_Node));
685
                     Set_Comes_From_Source (End_Labl, False);
686
 
687
                     Set_End_Label
688
                       (Record_Extension_Part (Typedef_Node), End_Labl);
689
                  end if;
690
 
691
               --  LIMITED PRIVATE is the only remaining possibility here
692
 
693
               else
694
                  Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
695
                  Set_Limited_Present (Decl_Node, True);
696
                  T_Private; -- past PRIVATE (or complain if not there!)
697
               end if;
698
 
699
               exit;
700
 
701
            --  Here we have an identifier after the IS, which is certainly
702
            --  wrong and which might be one of several different mistakes.
703
 
704
            when Tok_Identifier =>
705
 
706
               --  First case, if identifier is on same line, then probably we
707
               --  have something like "type X is Integer .." and the best
708
               --  diagnosis is a missing NEW. Note: the missing new message
709
               --  will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl.
710
 
711
               if not Token_Is_At_Start_Of_Line then
712
                  Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
713
 
714
               --  If the identifier is at the start of the line, and is in the
715
               --  same column as the type declaration itself then we consider
716
               --  that we had a missing type definition on the previous line
717
 
718
               elsif Start_Column <= Type_Start_Col then
719
                  Error_Msg_AP ("type definition expected");
720
                  Typedef_Node := Error;
721
 
722
               --  If the identifier is at the start of the line, and is in
723
               --  a column to the right of the type declaration line, then we
724
               --  may have something like:
725
 
726
               --    type x is
727
               --       r : integer
728
 
729
               --  and the best diagnosis is a missing record keyword
730
 
731
               else
732
                  Typedef_Node := P_Record_Definition;
733
               end if;
734
 
735
               exit;
736
 
737
            --  Ada 2005 (AI-251): INTERFACE
738
 
739
            when Tok_Interface =>
740
               Typedef_Node := P_Interface_Type_Definition (Abstract_Present);
741
               Abstract_Present := True;
742
               exit;
743
 
744
            when Tok_Private =>
745
               Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
746
               Scan; -- past PRIVATE
747
 
748
               --  Check error cases of private [abstract] tagged
749
 
750
               if Token = Tok_Abstract then
751
                  Error_Msg_SC ("`ABSTRACT TAGGED` must come before PRIVATE");
752
                  Scan; -- past ABSTRACT
753
 
754
                  if Token = Tok_Tagged then
755
                     Scan; -- past TAGGED
756
                  end if;
757
 
758
               elsif Token = Tok_Tagged then
759
                  Error_Msg_SC ("TAGGED must come before PRIVATE");
760
                  Scan; -- past TAGGED
761
               end if;
762
 
763
               exit;
764
 
765
            --  Ada 2005 (AI-345): Protected, synchronized or task interface
766
            --  or Ada 2005 (AI-443): Synchronized private extension.
767
 
768
            when Tok_Protected    |
769
                 Tok_Synchronized |
770
                 Tok_Task         =>
771
 
772
               declare
773
                  Saved_Token : constant Token_Type := Token;
774
 
775
               begin
776
                  Scan; -- past TASK, PROTECTED or SYNCHRONIZED
777
 
778
                  --  Synchronized private extension
779
 
780
                  if Token = Tok_New then
781
                     Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
782
 
783
                     if Saved_Token = Tok_Synchronized then
784
                        if Nkind (Typedef_Node) =
785
                          N_Derived_Type_Definition
786
                        then
787
                           Error_Msg_N
788
                             ("SYNCHRONIZED not allowed for record extension",
789
                              Typedef_Node);
790
                        else
791
                           Set_Synchronized_Present (Typedef_Node);
792
                        end if;
793
 
794
                     else
795
                        Error_Msg_SC ("invalid kind of private extension");
796
                     end if;
797
 
798
                  --  Interface
799
 
800
                  else
801
                     if Token /= Tok_Interface then
802
                        Error_Msg_SC ("NEW or INTERFACE expected");
803
                     end if;
804
 
805
                     Typedef_Node :=
806
                       P_Interface_Type_Definition (Abstract_Present);
807
                     Abstract_Present := True;
808
 
809
                     case Saved_Token is
810
                        when Tok_Task =>
811
                           Set_Task_Present         (Typedef_Node);
812
 
813
                        when Tok_Protected =>
814
                           Set_Protected_Present    (Typedef_Node);
815
 
816
                        when Tok_Synchronized =>
817
                           Set_Synchronized_Present (Typedef_Node);
818
 
819
                        when others =>
820
                           pragma Assert (False);
821
                           null;
822
                     end case;
823
                  end if;
824
               end;
825
 
826
               exit;
827
 
828
            --  Anything else is an error
829
 
830
            when others =>
831
               if Bad_Spelling_Of (Tok_Access)
832
                    or else
833
                  Bad_Spelling_Of (Tok_Array)
834
                    or else
835
                  Bad_Spelling_Of (Tok_Delta)
836
                    or else
837
                  Bad_Spelling_Of (Tok_Digits)
838
                    or else
839
                  Bad_Spelling_Of (Tok_Limited)
840
                    or else
841
                  Bad_Spelling_Of (Tok_Private)
842
                    or else
843
                  Bad_Spelling_Of (Tok_Range)
844
                    or else
845
                  Bad_Spelling_Of (Tok_Record)
846
                    or else
847
                  Bad_Spelling_Of (Tok_Tagged)
848
               then
849
                  null;
850
 
851
               else
852
                  Error_Msg_AP ("type definition expected");
853
                  raise Error_Resync;
854
               end if;
855
 
856
         end case;
857
      end loop;
858
 
859
      --  For the private type declaration case, the private type declaration
860
      --  node has been built, with the Tagged_Present and Limited_Present
861
      --  flags set as needed, and Typedef_Node is left set to Empty.
862
 
863
      if No (Typedef_Node) then
864
         Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
865
         Set_Abstract_Present (Decl_Node, Abstract_Present);
866
 
867
      --  For a private extension declaration, Typedef_Node contains the
868
      --  N_Private_Extension_Declaration node, which we now complete. Note
869
      --  that the private extension declaration, unlike a full type
870
      --  declaration, does permit unknown discriminants.
871
 
872
      elsif Nkind (Typedef_Node) = N_Private_Extension_Declaration then
873
         Decl_Node := Typedef_Node;
874
         Set_Sloc (Decl_Node, Type_Loc);
875
         Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
876
         Set_Abstract_Present (Typedef_Node, Abstract_Present);
877
 
878
      --  In the full type declaration case, Typedef_Node has the type
879
      --  definition and here is where we build the full type declaration
880
      --  node. This is also where we check for improper use of an unknown
881
      --  discriminant part (not allowed for full type declaration).
882
 
883
      else
884
         if Nkind (Typedef_Node) = N_Record_Definition
885
           or else (Nkind (Typedef_Node) = N_Derived_Type_Definition
886
                      and then Present (Record_Extension_Part (Typedef_Node)))
887
           or else Is_Derived_Iface
888
         then
889
            Set_Abstract_Present (Typedef_Node, Abstract_Present);
890
 
891
         elsif Abstract_Present then
892
            Error_Msg ("ABSTRACT not allowed here, ignored", Abstract_Loc);
893
         end if;
894
 
895
         Decl_Node := New_Node (N_Full_Type_Declaration, Type_Loc);
896
         Set_Type_Definition (Decl_Node, Typedef_Node);
897
 
898
         if Unknown_Dis then
899
            Error_Msg
900
              ("Full type declaration cannot have unknown discriminants",
901
                Discr_Sloc);
902
         end if;
903
      end if;
904
 
905
      --  Remaining processing is common for all three cases
906
 
907
      Set_Defining_Identifier (Decl_Node, Ident_Node);
908
      Set_Discriminant_Specifications (Decl_Node, Discr_List);
909
      P_Aspect_Specifications (Decl_Node);
910
      return Decl_Node;
911
   end P_Type_Declaration;
912
 
913
   ----------------------------------
914
   -- 3.2.1  Full Type Declaration --
915
   ----------------------------------
916
 
917
   --  Parsed by P_Type_Declaration (3.2.1)
918
 
919
   ----------------------------
920
   -- 3.2.1  Type Definition --
921
   ----------------------------
922
 
923
   --  Parsed by P_Type_Declaration (3.2.1)
924
 
925
   --------------------------------
926
   -- 3.2.2  Subtype Declaration --
927
   --------------------------------
928
 
929
   --  SUBTYPE_DECLARATION ::=
930
   --    subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION
931
   --    {ASPECT_SPECIFICATIONS];
932
 
933
   --  The caller has checked that the initial token is SUBTYPE
934
 
935
   --  Error recovery: can raise Error_Resync
936
 
937
   function P_Subtype_Declaration return Node_Id is
938
      Decl_Node        : Node_Id;
939
      Not_Null_Present : Boolean := False;
940
 
941
   begin
942
      Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr);
943
      Scan; -- past SUBTYPE
944
      Set_Defining_Identifier (Decl_Node, P_Defining_Identifier (C_Is));
945
      TF_Is;
946
 
947
      if Token = Tok_New then
948
         Error_Msg_SC  -- CODEFIX
949
           ("NEW ignored (only allowed in type declaration)");
950
         Scan; -- past NEW
951
      end if;
952
 
953
      Not_Null_Present := P_Null_Exclusion; --  Ada 2005 (AI-231)
954
      Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
955
 
956
      Set_Subtype_Indication
957
        (Decl_Node, P_Subtype_Indication (Not_Null_Present));
958
      P_Aspect_Specifications (Decl_Node);
959
      return Decl_Node;
960
   end P_Subtype_Declaration;
961
 
962
   -------------------------------
963
   -- 3.2.2  Subtype Indication --
964
   -------------------------------
965
 
966
   --  SUBTYPE_INDICATION ::=
967
   --    [not null] SUBTYPE_MARK [CONSTRAINT]
968
 
969
   --  Error recovery: can raise Error_Resync
970
 
971
   function P_Null_Exclusion
972
     (Allow_Anonymous_In_95 : Boolean := False) return Boolean
973
   is
974
      Not_Loc : constant Source_Ptr := Token_Ptr;
975
      --  Source position of "not", if present
976
 
977
   begin
978
      if Token /= Tok_Not then
979
         return False;
980
 
981
      else
982
         Scan; --  past NOT
983
 
984
         if Token = Tok_Null then
985
            Scan; --  past NULL
986
 
987
            --  Ada 2005 (AI-441, AI-447): null_exclusion is illegal in Ada 95,
988
            --  except in the case of anonymous access types.
989
 
990
            --  Allow_Anonymous_In_95 will be True if we're parsing a formal
991
            --  parameter or discriminant, which are the only places where
992
            --  anonymous access types occur in Ada 95. "Formal : not null
993
            --  access ..." is legal in Ada 95, whereas "Formal : not null
994
            --  Named_Access_Type" is not.
995
 
996
            if Ada_Version >= Ada_2005
997
              or else (Ada_Version >= Ada_95
998
                        and then Allow_Anonymous_In_95
999
                        and then Token = Tok_Access)
1000
            then
1001
               null; -- OK
1002
 
1003
            else
1004
               Error_Msg
1005
                 ("`NOT NULL` access type is an Ada 2005 extension", Not_Loc);
1006
               Error_Msg
1007
                 ("\unit should be compiled with -gnat05 switch", Not_Loc);
1008
            end if;
1009
 
1010
         else
1011
            Error_Msg_SP ("NULL expected");
1012
         end if;
1013
 
1014
         if Token = Tok_New then
1015
            Error_Msg ("`NOT NULL` comes after NEW, not before", Not_Loc);
1016
         end if;
1017
 
1018
         return True;
1019
      end if;
1020
   end P_Null_Exclusion;
1021
 
1022
   function P_Subtype_Indication
1023
     (Not_Null_Present : Boolean := False) return Node_Id
1024
   is
1025
      Type_Node : Node_Id;
1026
 
1027
   begin
1028
      if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
1029
         Type_Node := P_Subtype_Mark;
1030
         return P_Subtype_Indication (Type_Node, Not_Null_Present);
1031
 
1032
      else
1033
         --  Check for error of using record definition and treat it nicely,
1034
         --  otherwise things are really messed up, so resynchronize.
1035
 
1036
         if Token = Tok_Record then
1037
            Error_Msg_SC ("anonymous record definitions are not permitted");
1038
            Discard_Junk_Node (P_Record_Definition);
1039
            return Error;
1040
 
1041
         else
1042
            Error_Msg_AP ("subtype indication expected");
1043
            raise Error_Resync;
1044
         end if;
1045
      end if;
1046
   end P_Subtype_Indication;
1047
 
1048
   --  The following function is identical except that it is called with
1049
   --  the subtype mark already scanned out, and it scans out the constraint
1050
 
1051
   --  Error recovery: can raise Error_Resync
1052
 
1053
   function P_Subtype_Indication
1054
     (Subtype_Mark     : Node_Id;
1055
      Not_Null_Present : Boolean := False) return Node_Id
1056
   is
1057
      Indic_Node  : Node_Id;
1058
      Constr_Node : Node_Id;
1059
 
1060
   begin
1061
      Constr_Node := P_Constraint_Opt;
1062
 
1063
      if No (Constr_Node)
1064
        or else
1065
          (Nkind (Constr_Node) = N_Range_Constraint
1066
             and then Nkind (Range_Expression (Constr_Node)) = N_Error)
1067
      then
1068
         return Subtype_Mark;
1069
      else
1070
         if Not_Null_Present then
1071
            Error_Msg_SP ("`NOT NULL` not allowed if constraint given");
1072
         end if;
1073
 
1074
         Indic_Node := New_Node (N_Subtype_Indication, Sloc (Subtype_Mark));
1075
         Set_Subtype_Mark (Indic_Node, Check_Subtype_Mark (Subtype_Mark));
1076
         Set_Constraint (Indic_Node, Constr_Node);
1077
         return Indic_Node;
1078
      end if;
1079
   end P_Subtype_Indication;
1080
 
1081
   -------------------------
1082
   -- 3.2.2  Subtype Mark --
1083
   -------------------------
1084
 
1085
   --  SUBTYPE_MARK ::= subtype_NAME;
1086
 
1087
   --  Note: The subtype mark which appears after an IN or NOT IN
1088
   --  operator is parsed by P_Range_Or_Subtype_Mark (3.5)
1089
 
1090
   --  Error recovery: cannot raise Error_Resync
1091
 
1092
   function P_Subtype_Mark return Node_Id is
1093
   begin
1094
      return P_Subtype_Mark_Resync;
1095
   exception
1096
      when Error_Resync =>
1097
         return Error;
1098
   end P_Subtype_Mark;
1099
 
1100
   --  This routine differs from P_Subtype_Mark in that it insists that an
1101
   --  identifier be present, and if it is not, it raises Error_Resync.
1102
 
1103
   --  Error recovery: can raise Error_Resync
1104
 
1105
   function P_Subtype_Mark_Resync return Node_Id is
1106
      Type_Node : Node_Id;
1107
 
1108
   begin
1109
      if Token = Tok_Access then
1110
         Error_Msg_SC ("anonymous access type definition not allowed here");
1111
         Scan; -- past ACCESS
1112
      end if;
1113
 
1114
      if Token = Tok_Array then
1115
         Error_Msg_SC ("anonymous array definition not allowed here");
1116
         Discard_Junk_Node (P_Array_Type_Definition);
1117
         return Error;
1118
 
1119
      else
1120
         Type_Node := P_Qualified_Simple_Name_Resync;
1121
 
1122
         --  Check for a subtype mark attribute. The only valid possibilities
1123
         --  are 'CLASS and 'BASE. Anything else is a definite error. We may
1124
         --  as well catch it here.
1125
 
1126
         if Token = Tok_Apostrophe then
1127
            return P_Subtype_Mark_Attribute (Type_Node);
1128
         else
1129
            return Type_Node;
1130
         end if;
1131
      end if;
1132
   end P_Subtype_Mark_Resync;
1133
 
1134
   --  The following function is called to scan out a subtype mark attribute.
1135
   --  The caller has already scanned out the subtype mark, which is passed in
1136
   --  as the argument, and has checked that the current token is apostrophe.
1137
 
1138
   --  Only a special subclass of attributes, called type attributes
1139
   --  (see Snames package) are allowed in this syntactic position.
1140
 
1141
   --  Note: if the apostrophe is followed by other than an identifier, then
1142
   --  the input expression is returned unchanged, and the scan pointer is
1143
   --  left pointing to the apostrophe.
1144
 
1145
   --  Error recovery: can raise Error_Resync
1146
 
1147
   function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id is
1148
      Attr_Node  : Node_Id := Empty;
1149
      Scan_State : Saved_Scan_State;
1150
      Prefix     : Node_Id;
1151
 
1152
   begin
1153
      Prefix := Check_Subtype_Mark (Type_Node);
1154
 
1155
      if Prefix = Error then
1156
         raise Error_Resync;
1157
      end if;
1158
 
1159
      --  Loop through attributes appearing (more than one can appear as for
1160
      --  for example in X'Base'Class). We are at an apostrophe on entry to
1161
      --  this loop, and it runs once for each attribute parsed, with
1162
      --  Prefix being the current possible prefix if it is an attribute.
1163
 
1164
      loop
1165
         Save_Scan_State (Scan_State); -- at Apostrophe
1166
         Scan; -- past apostrophe
1167
 
1168
         if Token /= Tok_Identifier then
1169
            Restore_Scan_State (Scan_State); -- to apostrophe
1170
            return Prefix; -- no attribute after all
1171
 
1172
         elsif not Is_Type_Attribute_Name (Token_Name) then
1173
            Error_Msg_N
1174
              ("attribute & may not be used in a subtype mark", Token_Node);
1175
            raise Error_Resync;
1176
 
1177
         else
1178
            Attr_Node :=
1179
              Make_Attribute_Reference (Prev_Token_Ptr,
1180
                Prefix => Prefix,
1181
                Attribute_Name => Token_Name);
1182
            Scan; -- past type attribute identifier
1183
         end if;
1184
 
1185
         exit when Token /= Tok_Apostrophe;
1186
         Prefix := Attr_Node;
1187
      end loop;
1188
 
1189
      --  Fall through here after scanning type attribute
1190
 
1191
      return Attr_Node;
1192
   end P_Subtype_Mark_Attribute;
1193
 
1194
   -----------------------
1195
   -- 3.2.2  Constraint --
1196
   -----------------------
1197
 
1198
   --  CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
1199
 
1200
   --  SCALAR_CONSTRAINT ::=
1201
   --    RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
1202
 
1203
   --  COMPOSITE_CONSTRAINT ::=
1204
   --    INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
1205
 
1206
   --  If no constraint is present, this function returns Empty
1207
 
1208
   --  Error recovery: can raise Error_Resync
1209
 
1210
   function P_Constraint_Opt return Node_Id is
1211
   begin
1212
      if Token = Tok_Range
1213
        or else Bad_Spelling_Of (Tok_Range)
1214
      then
1215
         return P_Range_Constraint;
1216
 
1217
      elsif Token = Tok_Digits
1218
        or else Bad_Spelling_Of (Tok_Digits)
1219
      then
1220
         return P_Digits_Constraint;
1221
 
1222
      elsif Token = Tok_Delta
1223
        or else Bad_Spelling_Of (Tok_Delta)
1224
      then
1225
         return P_Delta_Constraint;
1226
 
1227
      elsif Token = Tok_Left_Paren then
1228
         return P_Index_Or_Discriminant_Constraint;
1229
 
1230
      elsif Token = Tok_In then
1231
         Ignore (Tok_In);
1232
         return P_Constraint_Opt;
1233
 
1234
      else
1235
         return Empty;
1236
      end if;
1237
   end P_Constraint_Opt;
1238
 
1239
   ------------------------------
1240
   -- 3.2.2  Scalar Constraint --
1241
   ------------------------------
1242
 
1243
   --  Parsed by P_Constraint_Opt (3.2.2)
1244
 
1245
   ---------------------------------
1246
   -- 3.2.2  Composite Constraint --
1247
   ---------------------------------
1248
 
1249
   --  Parsed by P_Constraint_Opt (3.2.2)
1250
 
1251
   --------------------------------------------------------
1252
   -- 3.3  Identifier Declarations (Also 7.4, 8.5, 11.1) --
1253
   --------------------------------------------------------
1254
 
1255
   --  This routine scans out a declaration starting with an identifier:
1256
 
1257
   --  OBJECT_DECLARATION ::=
1258
   --    DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1259
   --      [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION]
1260
   --        [ASPECT_SPECIFICATIONS];
1261
   --  | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1262
   --      ACCESS_DEFINITION [:= EXPRESSION]
1263
   --        [ASPECT_SPECIFICATIONS];
1264
   --  | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1265
   --      ARRAY_TYPE_DEFINITION [:= EXPRESSION]
1266
   --        [ASPECT_SPECIFICATIONS];
1267
 
1268
   --  NUMBER_DECLARATION ::=
1269
   --    DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
1270
 
1271
   --  OBJECT_RENAMING_DECLARATION ::=
1272
   --    DEFINING_IDENTIFIER :
1273
   --      [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
1274
   --  | DEFINING_IDENTIFIER :
1275
   --      ACCESS_DEFINITION renames object_NAME;
1276
 
1277
   --  EXCEPTION_RENAMING_DECLARATION ::=
1278
   --    DEFINING_IDENTIFIER : exception renames exception_NAME;
1279
 
1280
   --  EXCEPTION_DECLARATION ::=
1281
   --    DEFINING_IDENTIFIER_LIST : exception
1282
   --      [ASPECT_SPECIFICATIONS];
1283
 
1284
   --  Note that the ALIASED indication in an object declaration is
1285
   --  marked by a flag in the parent node.
1286
 
1287
   --  The caller has checked that the initial token is an identifier
1288
 
1289
   --  The value returned is a list of declarations, one for each identifier
1290
   --  in the list (as described in Sinfo, we always split up multiple
1291
   --  declarations into the equivalent sequence of single declarations
1292
   --  using the More_Ids and Prev_Ids flags to preserve the source).
1293
 
1294
   --  If the identifier turns out to be a probable statement rather than
1295
   --  an identifier, then the scan is left pointing to the identifier and
1296
   --  No_List is returned.
1297
 
1298
   --  Error recovery: can raise Error_Resync
1299
 
1300
   procedure P_Identifier_Declarations
1301
     (Decls   : List_Id;
1302
      Done    : out Boolean;
1303
      In_Spec : Boolean)
1304
   is
1305
      Acc_Node         : Node_Id;
1306
      Decl_Node        : Node_Id;
1307
      Type_Node        : Node_Id;
1308
      Ident_Sloc       : Source_Ptr;
1309
      Scan_State       : Saved_Scan_State;
1310
      List_OK          : Boolean := True;
1311
      Ident            : Nat;
1312
      Init_Expr        : Node_Id;
1313
      Init_Loc         : Source_Ptr;
1314
      Con_Loc          : Source_Ptr;
1315
      Not_Null_Present : Boolean := False;
1316
 
1317
      Idents : array (Int range 1 .. 4096) of Entity_Id;
1318
      --  Used to save identifiers in the identifier list. The upper bound
1319
      --  of 4096 is expected to be infinite in practice, and we do not even
1320
      --  bother to check if this upper bound is exceeded.
1321
 
1322
      Num_Idents : Nat := 1;
1323
      --  Number of identifiers stored in Idents
1324
 
1325
      procedure No_List;
1326
      --  This procedure is called in renames cases to make sure that we do
1327
      --  not have more than one identifier. If we do have more than one
1328
      --  then an error message is issued (and the declaration is split into
1329
      --  multiple declarations)
1330
 
1331
      function Token_Is_Renames return Boolean;
1332
      --  Checks if current token is RENAMES, and if so, scans past it and
1333
      --  returns True, otherwise returns False. Includes checking for some
1334
      --  common error cases.
1335
 
1336
      -------------
1337
      -- No_List --
1338
      -------------
1339
 
1340
      procedure No_List is
1341
      begin
1342
         if Num_Idents > 1 then
1343
            Error_Msg
1344
              ("identifier list not allowed for RENAMES",
1345
               Sloc (Idents (2)));
1346
         end if;
1347
 
1348
         List_OK := False;
1349
      end No_List;
1350
 
1351
      ----------------------
1352
      -- Token_Is_Renames --
1353
      ----------------------
1354
 
1355
      function Token_Is_Renames return Boolean is
1356
         At_Colon : Saved_Scan_State;
1357
 
1358
      begin
1359
         if Token = Tok_Colon then
1360
            Save_Scan_State (At_Colon);
1361
            Scan; -- past colon
1362
            Check_Misspelling_Of (Tok_Renames);
1363
 
1364
            if Token = Tok_Renames then
1365
               Error_Msg_SP -- CODEFIX
1366
                 ("|extra "":"" ignored");
1367
               Scan; -- past RENAMES
1368
               return True;
1369
            else
1370
               Restore_Scan_State (At_Colon);
1371
               return False;
1372
            end if;
1373
 
1374
         else
1375
            Check_Misspelling_Of (Tok_Renames);
1376
 
1377
            if Token = Tok_Renames then
1378
               Scan; -- past RENAMES
1379
               return True;
1380
            else
1381
               return False;
1382
            end if;
1383
         end if;
1384
      end Token_Is_Renames;
1385
 
1386
   --  Start of processing for P_Identifier_Declarations
1387
 
1388
   begin
1389
      Ident_Sloc := Token_Ptr;
1390
      Save_Scan_State (Scan_State); -- at first identifier
1391
      Idents (1) := P_Defining_Identifier (C_Comma_Colon);
1392
 
1393
      --  If we have a colon after the identifier, then we can assume that
1394
      --  this is in fact a valid identifier declaration and can steam ahead.
1395
 
1396
      if Token = Tok_Colon then
1397
         Scan; -- past colon
1398
 
1399
      --  If we have a comma, then scan out the list of identifiers
1400
 
1401
      elsif Token = Tok_Comma then
1402
         while Comma_Present loop
1403
            Num_Idents := Num_Idents + 1;
1404
            Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
1405
         end loop;
1406
 
1407
         Save_Scan_State (Scan_State); -- at colon
1408
         T_Colon;
1409
 
1410
      --  If we have identifier followed by := then we assume that what is
1411
      --  really meant is an assignment statement. The assignment statement
1412
      --  is scanned out and added to the list of declarations. An exception
1413
      --  occurs if the := is followed by the keyword constant, in which case
1414
      --  we assume it was meant to be a colon.
1415
 
1416
      elsif Token = Tok_Colon_Equal then
1417
         Scan; -- past :=
1418
 
1419
         if Token = Tok_Constant then
1420
            Error_Msg_SP ("colon expected");
1421
 
1422
         else
1423
            Restore_Scan_State (Scan_State);
1424
            Statement_When_Declaration_Expected (Decls, Done, In_Spec);
1425
            return;
1426
         end if;
1427
 
1428
      --  If we have an IS keyword, then assume the TYPE keyword was missing
1429
 
1430
      elsif Token = Tok_Is then
1431
         Restore_Scan_State (Scan_State);
1432
         Append_To (Decls, P_Type_Declaration);
1433
         Done := False;
1434
         return;
1435
 
1436
      --  Otherwise we have an error situation
1437
 
1438
      else
1439
         Restore_Scan_State (Scan_State);
1440
 
1441
         --  First case is possible misuse of PROTECTED in Ada 83 mode. If
1442
         --  so, fix the keyword and return to scan the protected declaration.
1443
 
1444
         if Token_Name = Name_Protected then
1445
            Check_95_Keyword (Tok_Protected, Tok_Identifier);
1446
            Check_95_Keyword (Tok_Protected, Tok_Type);
1447
            Check_95_Keyword (Tok_Protected, Tok_Body);
1448
 
1449
            if Token = Tok_Protected then
1450
               Done := False;
1451
               return;
1452
            end if;
1453
 
1454
         --  Check misspelling possibilities. If so, correct the misspelling
1455
         --  and return to scan out the resulting declaration.
1456
 
1457
         elsif Bad_Spelling_Of (Tok_Function)
1458
           or else Bad_Spelling_Of (Tok_Procedure)
1459
           or else Bad_Spelling_Of (Tok_Package)
1460
           or else Bad_Spelling_Of (Tok_Pragma)
1461
           or else Bad_Spelling_Of (Tok_Protected)
1462
           or else Bad_Spelling_Of (Tok_Generic)
1463
           or else Bad_Spelling_Of (Tok_Subtype)
1464
           or else Bad_Spelling_Of (Tok_Type)
1465
           or else Bad_Spelling_Of (Tok_Task)
1466
           or else Bad_Spelling_Of (Tok_Use)
1467
           or else Bad_Spelling_Of (Tok_For)
1468
         then
1469
            Done := False;
1470
            return;
1471
 
1472
         --  Otherwise we definitely have an ordinary identifier with a junk
1473
         --  token after it. Just complain that we expect a declaration, and
1474
         --  skip to a semicolon
1475
 
1476
         else
1477
            Set_Declaration_Expected;
1478
            Resync_Past_Semicolon;
1479
            Done := False;
1480
            return;
1481
         end if;
1482
      end if;
1483
 
1484
      --  Come here with an identifier list and colon scanned out. We now
1485
      --  build the nodes for the declarative items. One node is built for
1486
      --  each identifier in the list, with the type information being
1487
      --  repeated by rescanning the appropriate section of source.
1488
 
1489
      --  First an error check, if we have two identifiers in a row, a likely
1490
      --  possibility is that the first of the identifiers is an incorrectly
1491
      --  spelled keyword.
1492
 
1493
      if Token = Tok_Identifier then
1494
         declare
1495
            SS : Saved_Scan_State;
1496
            I2 : Boolean;
1497
 
1498
         begin
1499
            Save_Scan_State (SS);
1500
            Scan; -- past initial identifier
1501
            I2 := (Token = Tok_Identifier);
1502
            Restore_Scan_State (SS);
1503
 
1504
            if I2
1505
              and then
1506
                (Bad_Spelling_Of (Tok_Access)   or else
1507
                 Bad_Spelling_Of (Tok_Aliased)  or else
1508
                 Bad_Spelling_Of (Tok_Constant))
1509
            then
1510
               null;
1511
            end if;
1512
         end;
1513
      end if;
1514
 
1515
      --  Loop through identifiers
1516
 
1517
      Ident := 1;
1518
      Ident_Loop : loop
1519
 
1520
         --  Check for some cases of misused Ada 95 keywords
1521
 
1522
         if Token_Name = Name_Aliased then
1523
            Check_95_Keyword (Tok_Aliased, Tok_Array);
1524
            Check_95_Keyword (Tok_Aliased, Tok_Identifier);
1525
            Check_95_Keyword (Tok_Aliased, Tok_Constant);
1526
         end if;
1527
 
1528
         --  Constant cases
1529
 
1530
         if Token = Tok_Constant then
1531
            Con_Loc := Token_Ptr;
1532
            Scan; -- past CONSTANT
1533
 
1534
            --  Number declaration, initialization required
1535
 
1536
            Init_Expr := Init_Expr_Opt;
1537
 
1538
            if Present (Init_Expr) then
1539
               if Not_Null_Present then
1540
                  Error_Msg_SP
1541
                    ("`NOT NULL` not allowed in numeric expression");
1542
               end if;
1543
 
1544
               Decl_Node := New_Node (N_Number_Declaration, Ident_Sloc);
1545
               Set_Expression (Decl_Node, Init_Expr);
1546
 
1547
            --  Constant object declaration
1548
 
1549
            else
1550
               Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1551
               Set_Constant_Present (Decl_Node, True);
1552
 
1553
               if Token_Name = Name_Aliased then
1554
                  Check_95_Keyword (Tok_Aliased, Tok_Array);
1555
                  Check_95_Keyword (Tok_Aliased, Tok_Identifier);
1556
               end if;
1557
 
1558
               if Token = Tok_Aliased then
1559
                  Error_Msg_SC -- CODEFIX
1560
                    ("ALIASED should be before CONSTANT");
1561
                  Scan; -- past ALIASED
1562
                  Set_Aliased_Present (Decl_Node, True);
1563
               end if;
1564
 
1565
               if Token = Tok_Array then
1566
                  Set_Object_Definition
1567
                    (Decl_Node, P_Array_Type_Definition);
1568
 
1569
               else
1570
                  Not_Null_Present := P_Null_Exclusion; --  Ada 2005 (AI-231)
1571
                  Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1572
 
1573
                  if Token = Tok_Access then
1574
                     if Ada_Version < Ada_2005 then
1575
                        Error_Msg_SP
1576
                          ("generalized use of anonymous access types " &
1577
                           "is an Ada 2005 extension");
1578
                        Error_Msg_SP
1579
                          ("\unit must be compiled with -gnat05 switch");
1580
                     end if;
1581
 
1582
                     Set_Object_Definition
1583
                       (Decl_Node, P_Access_Definition (Not_Null_Present));
1584
                  else
1585
                     Set_Object_Definition
1586
                       (Decl_Node, P_Subtype_Indication (Not_Null_Present));
1587
                  end if;
1588
               end if;
1589
 
1590
               if Token = Tok_Renames then
1591
                  Error_Msg
1592
                    ("CONSTANT not permitted in renaming declaration",
1593
                     Con_Loc);
1594
                  Scan; -- Past renames
1595
                  Discard_Junk_Node (P_Name);
1596
               end if;
1597
            end if;
1598
 
1599
         --  Exception cases
1600
 
1601
         elsif Token = Tok_Exception then
1602
            Scan; -- past EXCEPTION
1603
 
1604
            if Token_Is_Renames then
1605
               No_List;
1606
               Decl_Node :=
1607
                 New_Node (N_Exception_Renaming_Declaration, Ident_Sloc);
1608
               Set_Name (Decl_Node, P_Qualified_Simple_Name_Resync);
1609
               No_Constraint;
1610
            else
1611
               Decl_Node := New_Node (N_Exception_Declaration, Prev_Token_Ptr);
1612
            end if;
1613
 
1614
         --  Aliased case (note that an object definition is required)
1615
 
1616
         elsif Token = Tok_Aliased then
1617
            Scan; -- past ALIASED
1618
            Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1619
            Set_Aliased_Present (Decl_Node, True);
1620
 
1621
            if Token = Tok_Constant then
1622
               Scan; -- past CONSTANT
1623
               Set_Constant_Present (Decl_Node, True);
1624
            end if;
1625
 
1626
            if Token = Tok_Array then
1627
               Set_Object_Definition
1628
                 (Decl_Node, P_Array_Type_Definition);
1629
 
1630
            else
1631
               Not_Null_Present := P_Null_Exclusion; --  Ada 2005 (AI-231)
1632
               Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1633
 
1634
               --  Access definition (AI-406) or subtype indication
1635
 
1636
               if Token = Tok_Access then
1637
                  if Ada_Version < Ada_2005 then
1638
                     Error_Msg_SP
1639
                       ("generalized use of anonymous access types " &
1640
                        "is an Ada 2005 extension");
1641
                     Error_Msg_SP
1642
                       ("\unit must be compiled with -gnat05 switch");
1643
                  end if;
1644
 
1645
                  Set_Object_Definition
1646
                    (Decl_Node, P_Access_Definition (Not_Null_Present));
1647
               else
1648
                  Set_Object_Definition
1649
                    (Decl_Node, P_Subtype_Indication (Not_Null_Present));
1650
               end if;
1651
            end if;
1652
 
1653
         --  Array case
1654
 
1655
         elsif Token = Tok_Array then
1656
            Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1657
            Set_Object_Definition (Decl_Node, P_Array_Type_Definition);
1658
 
1659
         --  Ada 2005 (AI-254, AI-406)
1660
 
1661
         elsif Token = Tok_Not then
1662
 
1663
            --  OBJECT_DECLARATION ::=
1664
            --    DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1665
            --      [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1666
            --  | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1667
            --      ACCESS_DEFINITION [:= EXPRESSION];
1668
 
1669
            --  OBJECT_RENAMING_DECLARATION ::=
1670
            --    DEFINING_IDENTIFIER :
1671
            --      [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
1672
            --  | DEFINING_IDENTIFIER :
1673
            --      ACCESS_DEFINITION renames object_NAME;
1674
 
1675
            Not_Null_Present := P_Null_Exclusion;  --  Ada 2005 (AI-231/423)
1676
 
1677
            if Token = Tok_Access then
1678
               if Ada_Version < Ada_2005 then
1679
                  Error_Msg_SP
1680
                    ("generalized use of anonymous access types " &
1681
                     "is an Ada 2005 extension");
1682
                  Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1683
               end if;
1684
 
1685
               Acc_Node := P_Access_Definition (Not_Null_Present);
1686
 
1687
               if Token /= Tok_Renames then
1688
                  Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1689
                  Set_Object_Definition (Decl_Node, Acc_Node);
1690
 
1691
               else
1692
                  Scan; --  past renames
1693
                  No_List;
1694
                  Decl_Node :=
1695
                    New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1696
                  Set_Access_Definition (Decl_Node, Acc_Node);
1697
                  Set_Name (Decl_Node, P_Name);
1698
               end if;
1699
 
1700
            else
1701
               Type_Node := P_Subtype_Mark;
1702
 
1703
               --  Object renaming declaration
1704
 
1705
               if Token_Is_Renames then
1706
                  if Ada_Version < Ada_2005 then
1707
                     Error_Msg_SP
1708
                       ("`NOT NULL` not allowed in object renaming");
1709
                     raise Error_Resync;
1710
 
1711
                  --  Ada 2005 (AI-423): Object renaming declaration with
1712
                  --  a null exclusion.
1713
 
1714
                  else
1715
                     No_List;
1716
                     Decl_Node :=
1717
                       New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1718
                     Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1719
                     Set_Subtype_Mark (Decl_Node, Type_Node);
1720
                     Set_Name (Decl_Node, P_Name);
1721
                  end if;
1722
 
1723
               --  Object declaration
1724
 
1725
               else
1726
                  Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1727
                  Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1728
                  Set_Object_Definition
1729
                    (Decl_Node,
1730
                     P_Subtype_Indication (Type_Node, Not_Null_Present));
1731
 
1732
                  --  RENAMES at this point means that we had the combination
1733
                  --  of a constraint on the Type_Node and renames, which is
1734
                  --  illegal
1735
 
1736
                  if Token_Is_Renames then
1737
                     Error_Msg_N
1738
                       ("constraint not allowed in object renaming "
1739
                        & "declaration",
1740
                        Constraint (Object_Definition (Decl_Node)));
1741
                     raise Error_Resync;
1742
                  end if;
1743
               end if;
1744
            end if;
1745
 
1746
         --  Ada 2005 (AI-230): Access Definition case
1747
 
1748
         elsif Token = Tok_Access then
1749
            if Ada_Version < Ada_2005 then
1750
               Error_Msg_SP
1751
                 ("generalized use of anonymous access types " &
1752
                  "is an Ada 2005 extension");
1753
               Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1754
            end if;
1755
 
1756
            Acc_Node := P_Access_Definition (Null_Exclusion_Present => False);
1757
 
1758
            --  Object declaration with access definition, or renaming
1759
 
1760
            if Token /= Tok_Renames then
1761
               Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1762
               Set_Object_Definition (Decl_Node, Acc_Node);
1763
 
1764
            else
1765
               Scan; --  past renames
1766
               No_List;
1767
               Decl_Node :=
1768
                 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1769
               Set_Access_Definition (Decl_Node, Acc_Node);
1770
               Set_Name (Decl_Node, P_Name);
1771
            end if;
1772
 
1773
         --  Subtype indication case
1774
 
1775
         else
1776
            Type_Node := P_Subtype_Mark;
1777
 
1778
            --  Object renaming declaration
1779
 
1780
            if Token_Is_Renames then
1781
               No_List;
1782
               Decl_Node :=
1783
                 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1784
               Set_Subtype_Mark (Decl_Node, Type_Node);
1785
               Set_Name (Decl_Node, P_Name);
1786
 
1787
            --  Object declaration
1788
 
1789
            else
1790
               Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1791
               Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1792
               Set_Object_Definition
1793
                 (Decl_Node,
1794
                  P_Subtype_Indication (Type_Node, Not_Null_Present));
1795
 
1796
               --  RENAMES at this point means that we had the combination of
1797
               --  a constraint on the Type_Node and renames, which is illegal
1798
 
1799
               if Token_Is_Renames then
1800
                  Error_Msg_N
1801
                    ("constraint not allowed in object renaming declaration",
1802
                     Constraint (Object_Definition (Decl_Node)));
1803
                  raise Error_Resync;
1804
               end if;
1805
            end if;
1806
         end if;
1807
 
1808
         --  Scan out initialization, allowed only for object declaration
1809
 
1810
         Init_Loc := Token_Ptr;
1811
         Init_Expr := Init_Expr_Opt;
1812
 
1813
         if Present (Init_Expr) then
1814
            if Nkind (Decl_Node) = N_Object_Declaration then
1815
               Set_Expression (Decl_Node, Init_Expr);
1816
               Set_Has_Init_Expression (Decl_Node);
1817
            else
1818
               Error_Msg ("initialization not allowed here", Init_Loc);
1819
            end if;
1820
         end if;
1821
 
1822
         Set_Defining_Identifier (Decl_Node, Idents (Ident));
1823
         P_Aspect_Specifications (Decl_Node);
1824
 
1825
         if List_OK then
1826
            if Ident < Num_Idents then
1827
               Set_More_Ids (Decl_Node, True);
1828
            end if;
1829
 
1830
            if Ident > 1 then
1831
               Set_Prev_Ids (Decl_Node, True);
1832
            end if;
1833
         end if;
1834
 
1835
         Append (Decl_Node, Decls);
1836
         exit Ident_Loop when Ident = Num_Idents;
1837
         Restore_Scan_State (Scan_State);
1838
         T_Colon;
1839
         Ident := Ident + 1;
1840
      end loop Ident_Loop;
1841
 
1842
      Done := False;
1843
   end P_Identifier_Declarations;
1844
 
1845
   -------------------------------
1846
   -- 3.3.1  Object Declaration --
1847
   -------------------------------
1848
 
1849
   --  OBJECT DECLARATION ::=
1850
   --    DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1851
   --      SUBTYPE_INDICATION [:= EXPRESSION];
1852
   --  | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1853
   --      ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1854
   --  | SINGLE_TASK_DECLARATION
1855
   --  | SINGLE_PROTECTED_DECLARATION
1856
 
1857
   --  Cases starting with TASK are parsed by P_Task (9.1)
1858
   --  Cases starting with PROTECTED are parsed by P_Protected (9.4)
1859
   --  All other cases are parsed by P_Identifier_Declarations (3.3)
1860
 
1861
   -------------------------------------
1862
   -- 3.3.1  Defining Identifier List --
1863
   -------------------------------------
1864
 
1865
   --  DEFINING_IDENTIFIER_LIST ::=
1866
   --    DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
1867
 
1868
   --  Always parsed by the construct in which it appears. See special
1869
   --  section on "Handling of Defining Identifier Lists" in this unit.
1870
 
1871
   -------------------------------
1872
   -- 3.3.2  Number Declaration --
1873
   -------------------------------
1874
 
1875
   --  Parsed by P_Identifier_Declarations (3.3)
1876
 
1877
   -------------------------------------------------------------------------
1878
   -- 3.4  Derived Type Definition or Private Extension Declaration (7.3) --
1879
   -------------------------------------------------------------------------
1880
 
1881
   --  DERIVED_TYPE_DEFINITION ::=
1882
   --    [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
1883
   --    [[and INTERFACE_LIST] RECORD_EXTENSION_PART]
1884
 
1885
   --  PRIVATE_EXTENSION_DECLARATION ::=
1886
   --     type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
1887
   --       [abstract] [limited | synchronized]
1888
   --          new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
1889
   --            with private;
1890
 
1891
   --  RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
1892
 
1893
   --  The caller has already scanned out the part up to the NEW, and Token
1894
   --  either contains Tok_New (or ought to, if it doesn't this procedure
1895
   --  will post an appropriate "NEW expected" message).
1896
 
1897
   --  Note: the caller is responsible for filling in the Sloc field of
1898
   --  the returned node in the private extension declaration case as
1899
   --  well as the stuff relating to the discriminant part.
1900
 
1901
   --  Error recovery: can raise Error_Resync;
1902
 
1903
   function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id is
1904
      Typedef_Node     : Node_Id;
1905
      Typedecl_Node    : Node_Id;
1906
      Not_Null_Present : Boolean := False;
1907
 
1908
   begin
1909
      Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
1910
 
1911
      if Ada_Version < Ada_2005
1912
        and then Token = Tok_Identifier
1913
        and then Token_Name = Name_Interface
1914
      then
1915
         Error_Msg_SP
1916
           ("abstract interface is an Ada 2005 extension");
1917
         Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1918
      else
1919
         T_New;
1920
      end if;
1921
 
1922
      if Token = Tok_Abstract then
1923
         Error_Msg_SC -- CODEFIX
1924
           ("ABSTRACT must come before NEW, not after");
1925
         Scan;
1926
      end if;
1927
 
1928
      Not_Null_Present := P_Null_Exclusion; --  Ada 2005 (AI-231)
1929
      Set_Null_Exclusion_Present (Typedef_Node, Not_Null_Present);
1930
      Set_Subtype_Indication (Typedef_Node,
1931
         P_Subtype_Indication (Not_Null_Present));
1932
 
1933
      --  Ada 2005 (AI-251): Deal with interfaces
1934
 
1935
      if Token = Tok_And then
1936
         Scan; -- past AND
1937
 
1938
         if Ada_Version < Ada_2005 then
1939
            Error_Msg_SP
1940
              ("abstract interface is an Ada 2005 extension");
1941
            Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1942
         end if;
1943
 
1944
         Set_Interface_List (Typedef_Node, New_List);
1945
 
1946
         loop
1947
            Append (P_Qualified_Simple_Name, Interface_List (Typedef_Node));
1948
            exit when Token /= Tok_And;
1949
            Scan; -- past AND
1950
         end loop;
1951
 
1952
         if Token /= Tok_With then
1953
            Error_Msg_SC ("WITH expected");
1954
            raise Error_Resync;
1955
         end if;
1956
      end if;
1957
 
1958
      --  Deal with record extension, note that we assume that a WITH is
1959
      --  missing in the case of "type X is new Y record ..." or in the
1960
      --  case of "type X is new Y null record".
1961
 
1962
      --  First make sure we don't have an aspect specification. If we do
1963
      --  return now, so that our caller can check it (the WITH here is not
1964
      --  part of a type extension).
1965
 
1966
      if Aspect_Specifications_Present then
1967
         return Typedef_Node;
1968
 
1969
      --  OK, not an aspect specification, so continue test for extension
1970
 
1971
      elsif Token = Tok_With
1972
        or else Token = Tok_Record
1973
        or else Token = Tok_Null
1974
      then
1975
         T_With; -- past WITH or give error message
1976
 
1977
         if Token = Tok_Limited then
1978
            Error_Msg_SC ("LIMITED keyword not allowed in private extension");
1979
            Scan; -- ignore LIMITED
1980
         end if;
1981
 
1982
         --  Private extension declaration
1983
 
1984
         if Token = Tok_Private then
1985
            Scan; -- past PRIVATE
1986
 
1987
            --  Throw away the type definition node and build the type
1988
            --  declaration node. Note the caller must set the Sloc,
1989
            --  Discriminant_Specifications, Unknown_Discriminants_Present,
1990
            --  and Defined_Identifier fields in the returned node.
1991
 
1992
            Typedecl_Node :=
1993
              Make_Private_Extension_Declaration (No_Location,
1994
                Defining_Identifier => Empty,
1995
                Subtype_Indication  => Subtype_Indication (Typedef_Node),
1996
                Abstract_Present    => Abstract_Present (Typedef_Node),
1997
                Interface_List      => Interface_List (Typedef_Node));
1998
 
1999
            return Typedecl_Node;
2000
 
2001
         --  Derived type definition with record extension part
2002
 
2003
         else
2004
            Set_Record_Extension_Part (Typedef_Node, P_Record_Definition);
2005
            return Typedef_Node;
2006
         end if;
2007
 
2008
      --  Derived type definition with no record extension part
2009
 
2010
      else
2011
         return Typedef_Node;
2012
      end if;
2013
   end P_Derived_Type_Def_Or_Private_Ext_Decl;
2014
 
2015
   ---------------------------
2016
   -- 3.5  Range Constraint --
2017
   ---------------------------
2018
 
2019
   --  RANGE_CONSTRAINT ::= range RANGE
2020
 
2021
   --  The caller has checked that the initial token is RANGE
2022
 
2023
   --  Error recovery: cannot raise Error_Resync
2024
 
2025
   function P_Range_Constraint return Node_Id is
2026
      Range_Node : Node_Id;
2027
 
2028
   begin
2029
      Range_Node := New_Node (N_Range_Constraint, Token_Ptr);
2030
      Scan; -- past RANGE
2031
      Set_Range_Expression (Range_Node, P_Range);
2032
      return Range_Node;
2033
   end P_Range_Constraint;
2034
 
2035
   ----------------
2036
   -- 3.5  Range --
2037
   ----------------
2038
 
2039
   --  RANGE ::=
2040
   --    RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
2041
 
2042
   --  Note: the range that appears in a membership test is parsed by
2043
   --  P_Range_Or_Subtype_Mark (3.5).
2044
 
2045
   --  Error recovery: cannot raise Error_Resync
2046
 
2047
   function P_Range return Node_Id is
2048
      Expr_Node  : Node_Id;
2049
      Range_Node : Node_Id;
2050
 
2051
   begin
2052
      Expr_Node := P_Simple_Expression_Or_Range_Attribute;
2053
 
2054
      if Expr_Form = EF_Range_Attr then
2055
         return Expr_Node;
2056
 
2057
      elsif Token = Tok_Dot_Dot then
2058
         Range_Node := New_Node (N_Range, Token_Ptr);
2059
         Set_Low_Bound (Range_Node, Expr_Node);
2060
         Scan; -- past ..
2061
         Expr_Node := P_Expression;
2062
         Check_Simple_Expression (Expr_Node);
2063
         Set_High_Bound (Range_Node, Expr_Node);
2064
         return Range_Node;
2065
 
2066
      --  Anything else is an error
2067
 
2068
      else
2069
         T_Dot_Dot; -- force missing .. message
2070
         return Error;
2071
      end if;
2072
   end P_Range;
2073
 
2074
   ----------------------------------
2075
   -- 3.5  P_Range_Or_Subtype_Mark --
2076
   ----------------------------------
2077
 
2078
   --  RANGE ::=
2079
   --    RANGE_ATTRIBUTE_REFERENCE
2080
   --  | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
2081
 
2082
   --  This routine scans out the range or subtype mark that forms the right
2083
   --  operand of a membership test (it is not used in any other contexts, and
2084
   --  error messages are specialized with this knowledge in mind).
2085
 
2086
   --  Note: as documented in the Sinfo interface, although the syntax only
2087
   --  allows a subtype mark, we in fact allow any simple expression to be
2088
   --  returned from this routine. The semantics is responsible for issuing
2089
   --  an appropriate message complaining if the argument is not a name.
2090
   --  This simplifies the coding and error recovery processing in the
2091
   --  parser, and in any case it is preferable not to consider this a
2092
   --  syntax error and to continue with the semantic analysis.
2093
 
2094
   --  Error recovery: cannot raise Error_Resync
2095
 
2096
   function P_Range_Or_Subtype_Mark
2097
     (Allow_Simple_Expression : Boolean := False) return Node_Id
2098
   is
2099
      Expr_Node  : Node_Id;
2100
      Range_Node : Node_Id;
2101
      Save_Loc   : Source_Ptr;
2102
 
2103
   --  Start of processing for P_Range_Or_Subtype_Mark
2104
 
2105
   begin
2106
      --  Save location of possible junk parentheses
2107
 
2108
      Save_Loc := Token_Ptr;
2109
 
2110
      --  Scan out either a simple expression or a range (this accepts more
2111
      --  than is legal here, but as explained above, we like to allow more
2112
      --  with a proper diagnostic, and in the case of a membership operation
2113
      --  where sets are allowed, a simple expression is permissible anyway.
2114
 
2115
      Expr_Node := P_Simple_Expression_Or_Range_Attribute;
2116
 
2117
      --  Range attribute
2118
 
2119
      if Expr_Form = EF_Range_Attr then
2120
         return Expr_Node;
2121
 
2122
      --  Simple_Expression .. Simple_Expression
2123
 
2124
      elsif Token = Tok_Dot_Dot then
2125
         Check_Simple_Expression (Expr_Node);
2126
         Range_Node := New_Node (N_Range, Token_Ptr);
2127
         Set_Low_Bound (Range_Node, Expr_Node);
2128
         Scan; -- past ..
2129
         Set_High_Bound (Range_Node, P_Simple_Expression);
2130
         return Range_Node;
2131
 
2132
      --  Case of subtype mark (optionally qualified simple name or an
2133
      --  attribute whose prefix is an optionally qualified simple name)
2134
 
2135
      elsif Expr_Form = EF_Simple_Name
2136
        or else Nkind (Expr_Node) = N_Attribute_Reference
2137
      then
2138
         --  Check for error of range constraint after a subtype mark
2139
 
2140
         if Token = Tok_Range then
2141
            Error_Msg_SC ("range constraint not allowed in membership test");
2142
            Scan; -- past RANGE
2143
            raise Error_Resync;
2144
 
2145
         --  Check for error of DIGITS or DELTA after a subtype mark
2146
 
2147
         elsif Token = Tok_Digits or else Token = Tok_Delta then
2148
            Error_Msg_SC
2149
              ("accuracy definition not allowed in membership test");
2150
            Scan; -- past DIGITS or DELTA
2151
            raise Error_Resync;
2152
 
2153
         --  Attribute reference, may or may not be OK, but in any case we
2154
         --  will scan it out
2155
 
2156
         elsif Token = Tok_Apostrophe then
2157
            return P_Subtype_Mark_Attribute (Expr_Node);
2158
 
2159
         --  OK case of simple name, just return it
2160
 
2161
         else
2162
            return Expr_Node;
2163
         end if;
2164
 
2165
      --  Simple expression case
2166
 
2167
      elsif Expr_Form = EF_Simple and then Allow_Simple_Expression then
2168
         return Expr_Node;
2169
 
2170
      --  Here we have some kind of error situation. Check for junk parens
2171
      --  then return what we have, caller will deal with other errors.
2172
 
2173
      else
2174
         if Nkind (Expr_Node) in N_Subexpr
2175
           and then Paren_Count (Expr_Node) /= 0
2176
         then
2177
            Error_Msg ("|parentheses not allowed for subtype mark", Save_Loc);
2178
            Set_Paren_Count (Expr_Node, 0);
2179
         end if;
2180
 
2181
         return Expr_Node;
2182
      end if;
2183
   end P_Range_Or_Subtype_Mark;
2184
 
2185
   ----------------------------------------
2186
   -- 3.5.1  Enumeration Type Definition --
2187
   ----------------------------------------
2188
 
2189
   --  ENUMERATION_TYPE_DEFINITION ::=
2190
   --    (ENUMERATION_LITERAL_SPECIFICATION
2191
   --      {, ENUMERATION_LITERAL_SPECIFICATION})
2192
 
2193
   --  The caller has already scanned out the TYPE keyword
2194
 
2195
   --  Error recovery: can raise Error_Resync;
2196
 
2197
   function P_Enumeration_Type_Definition return Node_Id is
2198
      Typedef_Node : Node_Id;
2199
 
2200
   begin
2201
      Typedef_Node := New_Node (N_Enumeration_Type_Definition, Token_Ptr);
2202
      Set_Literals (Typedef_Node, New_List);
2203
 
2204
      T_Left_Paren;
2205
 
2206
      loop
2207
         Append (P_Enumeration_Literal_Specification, Literals (Typedef_Node));
2208
         exit when not Comma_Present;
2209
      end loop;
2210
 
2211
      T_Right_Paren;
2212
      return Typedef_Node;
2213
   end P_Enumeration_Type_Definition;
2214
 
2215
   ----------------------------------------------
2216
   -- 3.5.1  Enumeration Literal Specification --
2217
   ----------------------------------------------
2218
 
2219
   --  ENUMERATION_LITERAL_SPECIFICATION ::=
2220
   --    DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
2221
 
2222
   --  Error recovery: can raise Error_Resync
2223
 
2224
   function P_Enumeration_Literal_Specification return Node_Id is
2225
   begin
2226
      if Token = Tok_Char_Literal then
2227
         return P_Defining_Character_Literal;
2228
      else
2229
         return P_Defining_Identifier (C_Comma_Right_Paren);
2230
      end if;
2231
   end P_Enumeration_Literal_Specification;
2232
 
2233
   ---------------------------------------
2234
   -- 3.5.1  Defining_Character_Literal --
2235
   ---------------------------------------
2236
 
2237
   --  DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
2238
 
2239
   --  Error recovery: cannot raise Error_Resync
2240
 
2241
   --  The caller has checked that the current token is a character literal
2242
 
2243
   function P_Defining_Character_Literal return Node_Id is
2244
      Literal_Node : Node_Id;
2245
   begin
2246
      Literal_Node := Token_Node;
2247
      Change_Character_Literal_To_Defining_Character_Literal (Literal_Node);
2248
      Scan; -- past character literal
2249
      return Literal_Node;
2250
   end P_Defining_Character_Literal;
2251
 
2252
   ------------------------------------
2253
   -- 3.5.4  Integer Type Definition --
2254
   ------------------------------------
2255
 
2256
   --  Parsed by P_Type_Declaration (3.2.1)
2257
 
2258
   -------------------------------------------
2259
   -- 3.5.4  Signed Integer Type Definition --
2260
   -------------------------------------------
2261
 
2262
   --  SIGNED_INTEGER_TYPE_DEFINITION ::=
2263
   --    range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2264
 
2265
   --  Normally the initial token on entry is RANGE, but in some
2266
   --  error conditions, the range token was missing and control is
2267
   --  passed with Token pointing to first token of the first expression.
2268
 
2269
   --  Error recovery: cannot raise Error_Resync
2270
 
2271
   function P_Signed_Integer_Type_Definition return Node_Id is
2272
      Typedef_Node : Node_Id;
2273
      Expr_Node    : Node_Id;
2274
 
2275
   begin
2276
      Typedef_Node := New_Node (N_Signed_Integer_Type_Definition, Token_Ptr);
2277
 
2278
      if Token = Tok_Range then
2279
         Scan; -- past RANGE
2280
      end if;
2281
 
2282
      Expr_Node := P_Expression_Or_Range_Attribute;
2283
 
2284
      --  Range case (not permitted by the grammar, this is surprising but
2285
      --  the grammar in the RM is as quoted above, and does not allow Range).
2286
 
2287
      if Expr_Form = EF_Range_Attr then
2288
         Error_Msg_N
2289
           ("Range attribute not allowed here, use First .. Last", Expr_Node);
2290
         Set_Low_Bound (Typedef_Node, Expr_Node);
2291
         Set_Attribute_Name (Expr_Node, Name_First);
2292
         Set_High_Bound (Typedef_Node, Copy_Separate_Tree (Expr_Node));
2293
         Set_Attribute_Name (High_Bound (Typedef_Node), Name_Last);
2294
 
2295
      --  Normal case of explicit range
2296
 
2297
      else
2298
         Check_Simple_Expression (Expr_Node);
2299
         Set_Low_Bound (Typedef_Node, Expr_Node);
2300
         T_Dot_Dot;
2301
         Expr_Node := P_Expression;
2302
         Check_Simple_Expression (Expr_Node);
2303
         Set_High_Bound (Typedef_Node, Expr_Node);
2304
      end if;
2305
 
2306
      return Typedef_Node;
2307
   end P_Signed_Integer_Type_Definition;
2308
 
2309
   ------------------------------------
2310
   -- 3.5.4  Modular Type Definition --
2311
   ------------------------------------
2312
 
2313
   --  MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
2314
 
2315
   --  The caller has checked that the initial token is MOD
2316
 
2317
   --  Error recovery: cannot raise Error_Resync
2318
 
2319
   function P_Modular_Type_Definition return Node_Id is
2320
      Typedef_Node : Node_Id;
2321
 
2322
   begin
2323
      if Ada_Version = Ada_83 then
2324
         Error_Msg_SC ("(Ada 83): modular types not allowed");
2325
      end if;
2326
 
2327
      Typedef_Node := New_Node (N_Modular_Type_Definition, Token_Ptr);
2328
      Scan; -- past MOD
2329
      Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
2330
 
2331
      --  Handle mod L..R cleanly
2332
 
2333
      if Token = Tok_Dot_Dot then
2334
         Error_Msg_SC ("range not allowed for modular type");
2335
         Scan; -- past ..
2336
         Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
2337
      end if;
2338
 
2339
      return Typedef_Node;
2340
   end P_Modular_Type_Definition;
2341
 
2342
   ---------------------------------
2343
   -- 3.5.6  Real Type Definition --
2344
   ---------------------------------
2345
 
2346
   --  Parsed by P_Type_Declaration (3.2.1)
2347
 
2348
   --------------------------------------
2349
   -- 3.5.7  Floating Point Definition --
2350
   --------------------------------------
2351
 
2352
   --  FLOATING_POINT_DEFINITION ::=
2353
   --    digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2354
 
2355
   --  Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
2356
 
2357
   --  The caller has checked that the initial token is DIGITS
2358
 
2359
   --  Error recovery: cannot raise Error_Resync
2360
 
2361
   function P_Floating_Point_Definition return Node_Id is
2362
      Digits_Loc : constant Source_Ptr := Token_Ptr;
2363
      Def_Node   : Node_Id;
2364
      Expr_Node  : Node_Id;
2365
 
2366
   begin
2367
      Scan; -- past DIGITS
2368
      Expr_Node := P_Expression_No_Right_Paren;
2369
      Check_Simple_Expression_In_Ada_83 (Expr_Node);
2370
 
2371
      --  Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
2372
 
2373
      if Token = Tok_Delta then
2374
         Error_Msg_SC -- CODEFIX
2375
           ("|DELTA must come before DIGITS");
2376
         Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Digits_Loc);
2377
         Scan; -- past DELTA
2378
         Set_Delta_Expression (Def_Node, P_Expression_No_Right_Paren);
2379
 
2380
      --  OK floating-point definition
2381
 
2382
      else
2383
         Def_Node := New_Node (N_Floating_Point_Definition, Digits_Loc);
2384
      end if;
2385
 
2386
      Set_Digits_Expression (Def_Node, Expr_Node);
2387
      Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt);
2388
      return Def_Node;
2389
   end P_Floating_Point_Definition;
2390
 
2391
   -------------------------------------
2392
   -- 3.5.7  Real Range Specification --
2393
   -------------------------------------
2394
 
2395
   --  REAL_RANGE_SPECIFICATION ::=
2396
   --    range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2397
 
2398
   --  Error recovery: cannot raise Error_Resync
2399
 
2400
   function P_Real_Range_Specification_Opt return Node_Id is
2401
      Specification_Node : Node_Id;
2402
      Expr_Node          : Node_Id;
2403
 
2404
   begin
2405
      if Token = Tok_Range then
2406
         Specification_Node :=
2407
           New_Node (N_Real_Range_Specification, Token_Ptr);
2408
         Scan; -- past RANGE
2409
         Expr_Node := P_Expression_No_Right_Paren;
2410
         Check_Simple_Expression (Expr_Node);
2411
         Set_Low_Bound (Specification_Node, Expr_Node);
2412
         T_Dot_Dot;
2413
         Expr_Node := P_Expression_No_Right_Paren;
2414
         Check_Simple_Expression (Expr_Node);
2415
         Set_High_Bound (Specification_Node, Expr_Node);
2416
         return Specification_Node;
2417
      else
2418
         return Empty;
2419
      end if;
2420
   end P_Real_Range_Specification_Opt;
2421
 
2422
   -----------------------------------
2423
   -- 3.5.9  Fixed Point Definition --
2424
   -----------------------------------
2425
 
2426
   --  FIXED_POINT_DEFINITION ::=
2427
   --    ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
2428
 
2429
   --  ORDINARY_FIXED_POINT_DEFINITION ::=
2430
   --    delta static_EXPRESSION REAL_RANGE_SPECIFICATION
2431
 
2432
   --  DECIMAL_FIXED_POINT_DEFINITION ::=
2433
   --    delta static_EXPRESSION
2434
   --      digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2435
 
2436
   --  The caller has checked that the initial token is DELTA
2437
 
2438
   --  Error recovery: cannot raise Error_Resync
2439
 
2440
   function P_Fixed_Point_Definition return Node_Id is
2441
      Delta_Node : Node_Id;
2442
      Delta_Loc  : Source_Ptr;
2443
      Def_Node   : Node_Id;
2444
      Expr_Node  : Node_Id;
2445
 
2446
   begin
2447
      Delta_Loc := Token_Ptr;
2448
      Scan; -- past DELTA
2449
      Delta_Node := P_Expression_No_Right_Paren;
2450
      Check_Simple_Expression_In_Ada_83 (Delta_Node);
2451
 
2452
      if Token = Tok_Digits then
2453
         if Ada_Version = Ada_83 then
2454
            Error_Msg_SC ("(Ada 83) decimal fixed type not allowed!");
2455
         end if;
2456
 
2457
         Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Delta_Loc);
2458
         Scan; -- past DIGITS
2459
         Expr_Node := P_Expression_No_Right_Paren;
2460
         Check_Simple_Expression_In_Ada_83 (Expr_Node);
2461
         Set_Digits_Expression (Def_Node, Expr_Node);
2462
 
2463
      else
2464
         Def_Node := New_Node (N_Ordinary_Fixed_Point_Definition, Delta_Loc);
2465
 
2466
         --  Range is required in ordinary fixed point case
2467
 
2468
         if Token /= Tok_Range then
2469
            Error_Msg_AP ("range must be given for fixed-point type");
2470
            T_Range;
2471
         end if;
2472
      end if;
2473
 
2474
      Set_Delta_Expression (Def_Node, Delta_Node);
2475
      Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt);
2476
      return Def_Node;
2477
   end P_Fixed_Point_Definition;
2478
 
2479
   --------------------------------------------
2480
   -- 3.5.9  Ordinary Fixed Point Definition --
2481
   --------------------------------------------
2482
 
2483
   --  Parsed by P_Fixed_Point_Definition (3.5.9)
2484
 
2485
   -------------------------------------------
2486
   -- 3.5.9  Decimal Fixed Point Definition --
2487
   -------------------------------------------
2488
 
2489
   --  Parsed by P_Decimal_Point_Definition (3.5.9)
2490
 
2491
   ------------------------------
2492
   -- 3.5.9  Digits Constraint --
2493
   ------------------------------
2494
 
2495
   --  DIGITS_CONSTRAINT ::=
2496
   --    digits static_EXPRESSION [RANGE_CONSTRAINT]
2497
 
2498
   --  Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2499
 
2500
   --  The caller has checked that the initial token is DIGITS
2501
 
2502
   function P_Digits_Constraint return Node_Id is
2503
      Constraint_Node : Node_Id;
2504
      Expr_Node : Node_Id;
2505
 
2506
   begin
2507
      Constraint_Node := New_Node (N_Digits_Constraint, Token_Ptr);
2508
      Scan; -- past DIGITS
2509
      Expr_Node := P_Expression;
2510
      Check_Simple_Expression_In_Ada_83 (Expr_Node);
2511
      Set_Digits_Expression (Constraint_Node, Expr_Node);
2512
 
2513
      if Token = Tok_Range then
2514
         Set_Range_Constraint (Constraint_Node, P_Range_Constraint);
2515
      end if;
2516
 
2517
      return Constraint_Node;
2518
   end P_Digits_Constraint;
2519
 
2520
   -----------------------------
2521
   -- 3.5.9  Delta Constraint --
2522
   -----------------------------
2523
 
2524
   --  DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
2525
 
2526
   --  Note: this is an obsolescent feature in Ada 95 (I.3)
2527
 
2528
   --  Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2529
   --  (also true in formal modes).
2530
 
2531
   --  The caller has checked that the initial token is DELTA
2532
 
2533
   --  Error recovery: cannot raise Error_Resync
2534
 
2535
   function P_Delta_Constraint return Node_Id is
2536
      Constraint_Node : Node_Id;
2537
      Expr_Node : Node_Id;
2538
 
2539
   begin
2540
      Constraint_Node := New_Node (N_Delta_Constraint, Token_Ptr);
2541
      Scan; -- past DELTA
2542
      Expr_Node := P_Expression;
2543
      Check_Simple_Expression_In_Ada_83 (Expr_Node);
2544
 
2545
      Set_Delta_Expression (Constraint_Node, Expr_Node);
2546
 
2547
      if Token = Tok_Range then
2548
         Set_Range_Constraint (Constraint_Node, P_Range_Constraint);
2549
      end if;
2550
 
2551
      return Constraint_Node;
2552
   end P_Delta_Constraint;
2553
 
2554
   --------------------------------
2555
   -- 3.6  Array Type Definition --
2556
   --------------------------------
2557
 
2558
   --  ARRAY_TYPE_DEFINITION ::=
2559
   --    UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
2560
 
2561
   --  UNCONSTRAINED_ARRAY_DEFINITION ::=
2562
   --    array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
2563
   --      COMPONENT_DEFINITION
2564
 
2565
   --  INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
2566
 
2567
   --  CONSTRAINED_ARRAY_DEFINITION ::=
2568
   --    array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
2569
   --      COMPONENT_DEFINITION
2570
 
2571
   --  DISCRETE_SUBTYPE_DEFINITION ::=
2572
   --    DISCRETE_SUBTYPE_INDICATION | RANGE
2573
 
2574
   --  COMPONENT_DEFINITION ::=
2575
   --    [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
2576
 
2577
   --  The caller has checked that the initial token is ARRAY
2578
 
2579
   --  Error recovery: can raise Error_Resync
2580
 
2581
   function P_Array_Type_Definition return Node_Id is
2582
      Array_Loc        : Source_Ptr;
2583
      CompDef_Node     : Node_Id;
2584
      Def_Node         : Node_Id;
2585
      Not_Null_Present : Boolean := False;
2586
      Subs_List        : List_Id;
2587
      Scan_State       : Saved_Scan_State;
2588
      Aliased_Present  : Boolean := False;
2589
 
2590
   begin
2591
      Array_Loc := Token_Ptr;
2592
      Scan; -- past ARRAY
2593
      Subs_List := New_List;
2594
      T_Left_Paren;
2595
 
2596
      --  It's quite tricky to disentangle these two possibilities, so we do
2597
      --  a prescan to determine which case we have and then reset the scan.
2598
      --  The prescan skips past possible subtype mark tokens.
2599
 
2600
      Save_Scan_State (Scan_State); -- just after paren
2601
 
2602
      while Token in Token_Class_Desig or else
2603
            Token = Tok_Dot or else
2604
            Token = Tok_Apostrophe -- because of 'BASE, 'CLASS
2605
      loop
2606
         Scan;
2607
      end loop;
2608
 
2609
      --  If we end up on RANGE <> then we have the unconstrained case. We
2610
      --  will also allow the RANGE to be omitted, just to improve error
2611
      --  handling for a case like array (integer <>) of integer;
2612
 
2613
      Scan; -- past possible RANGE or <>
2614
 
2615
      if (Prev_Token = Tok_Range and then Token = Tok_Box) or else
2616
         Prev_Token = Tok_Box
2617
      then
2618
         Def_Node := New_Node (N_Unconstrained_Array_Definition, Array_Loc);
2619
         Restore_Scan_State (Scan_State); -- to first subtype mark
2620
 
2621
         loop
2622
            Append (P_Subtype_Mark_Resync, Subs_List);
2623
            T_Range;
2624
            T_Box;
2625
            exit when Token = Tok_Right_Paren or else Token = Tok_Of;
2626
            T_Comma;
2627
         end loop;
2628
 
2629
         Set_Subtype_Marks (Def_Node, Subs_List);
2630
 
2631
      else
2632
         Def_Node := New_Node (N_Constrained_Array_Definition, Array_Loc);
2633
         Restore_Scan_State (Scan_State); -- to first discrete range
2634
 
2635
         loop
2636
            Append (P_Discrete_Subtype_Definition, Subs_List);
2637
            exit when not Comma_Present;
2638
         end loop;
2639
 
2640
         Set_Discrete_Subtype_Definitions (Def_Node, Subs_List);
2641
      end if;
2642
 
2643
      T_Right_Paren;
2644
      T_Of;
2645
 
2646
      CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
2647
 
2648
      if Token_Name = Name_Aliased then
2649
         Check_95_Keyword (Tok_Aliased, Tok_Identifier);
2650
      end if;
2651
 
2652
      if Token = Tok_Aliased then
2653
         Aliased_Present := True;
2654
         Scan; -- past ALIASED
2655
      end if;
2656
 
2657
      Not_Null_Present := P_Null_Exclusion; --  Ada 2005 (AI-231/AI-254)
2658
 
2659
      --  Ada 2005 (AI-230): Access Definition case
2660
 
2661
      if Token = Tok_Access then
2662
         if Ada_Version < Ada_2005 then
2663
            Error_Msg_SP
2664
              ("generalized use of anonymous access types " &
2665
               "is an Ada 2005 extension");
2666
            Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
2667
         end if;
2668
 
2669
         --  AI95-406 makes "aliased" legal (and useless) in this context so
2670
         --  followintg code which used to be needed is commented out.
2671
 
2672
         --  if Aliased_Present then
2673
         --     Error_Msg_SP ("ALIASED not allowed here");
2674
         --  end if;
2675
 
2676
         Set_Subtype_Indication     (CompDef_Node, Empty);
2677
         Set_Aliased_Present        (CompDef_Node, False);
2678
         Set_Access_Definition      (CompDef_Node,
2679
           P_Access_Definition (Not_Null_Present));
2680
      else
2681
 
2682
         Set_Access_Definition      (CompDef_Node, Empty);
2683
         Set_Aliased_Present        (CompDef_Node, Aliased_Present);
2684
         Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
2685
         Set_Subtype_Indication     (CompDef_Node,
2686
           P_Subtype_Indication (Not_Null_Present));
2687
      end if;
2688
 
2689
      Set_Component_Definition (Def_Node, CompDef_Node);
2690
 
2691
      return Def_Node;
2692
   end P_Array_Type_Definition;
2693
 
2694
   -----------------------------------------
2695
   -- 3.6  Unconstrained Array Definition --
2696
   -----------------------------------------
2697
 
2698
   --  Parsed by P_Array_Type_Definition (3.6)
2699
 
2700
   ---------------------------------------
2701
   -- 3.6  Constrained Array Definition --
2702
   ---------------------------------------
2703
 
2704
   --  Parsed by P_Array_Type_Definition (3.6)
2705
 
2706
   --------------------------------------
2707
   -- 3.6  Discrete Subtype Definition --
2708
   --------------------------------------
2709
 
2710
   --  DISCRETE_SUBTYPE_DEFINITION ::=
2711
   --    discrete_SUBTYPE_INDICATION | RANGE
2712
 
2713
   --  Note: the discrete subtype definition appearing in a constrained
2714
   --  array definition is parsed by P_Array_Type_Definition (3.6)
2715
 
2716
   --  Error recovery: cannot raise Error_Resync
2717
 
2718
   function P_Discrete_Subtype_Definition return Node_Id is
2719
   begin
2720
      --  The syntax of a discrete subtype definition is identical to that
2721
      --  of a discrete range, so we simply share the same parsing code.
2722
 
2723
      return P_Discrete_Range;
2724
   end P_Discrete_Subtype_Definition;
2725
 
2726
   -------------------------------
2727
   -- 3.6  Component Definition --
2728
   -------------------------------
2729
 
2730
   --  For the array case, parsed by P_Array_Type_Definition (3.6)
2731
   --  For the record case, parsed by P_Component_Declaration (3.8)
2732
 
2733
   -----------------------------
2734
   -- 3.6.1  Index Constraint --
2735
   -----------------------------
2736
 
2737
   --  Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2738
 
2739
   ---------------------------
2740
   -- 3.6.1  Discrete Range --
2741
   ---------------------------
2742
 
2743
   --  DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
2744
 
2745
   --  The possible forms for a discrete range are:
2746
 
2747
      --   Subtype_Mark                           (SUBTYPE_INDICATION, 3.2.2)
2748
      --   Subtype_Mark range Range               (SUBTYPE_INDICATION, 3.2.2)
2749
      --   Range_Attribute                        (RANGE, 3.5)
2750
      --   Simple_Expression .. Simple_Expression (RANGE, 3.5)
2751
 
2752
   --  Error recovery: cannot raise Error_Resync
2753
 
2754
   function P_Discrete_Range return Node_Id is
2755
      Expr_Node  : Node_Id;
2756
      Range_Node : Node_Id;
2757
 
2758
   begin
2759
      Expr_Node := P_Simple_Expression_Or_Range_Attribute;
2760
 
2761
      if Expr_Form = EF_Range_Attr then
2762
         return Expr_Node;
2763
 
2764
      elsif Token = Tok_Range then
2765
         if Expr_Form /= EF_Simple_Name then
2766
            Error_Msg_SC ("range must be preceded by subtype mark");
2767
         end if;
2768
 
2769
         return P_Subtype_Indication (Expr_Node);
2770
 
2771
      --  Check Expression .. Expression case
2772
 
2773
      elsif Token = Tok_Dot_Dot then
2774
         Range_Node := New_Node (N_Range, Token_Ptr);
2775
         Set_Low_Bound (Range_Node, Expr_Node);
2776
         Scan; -- past ..
2777
         Expr_Node := P_Expression;
2778
         Check_Simple_Expression (Expr_Node);
2779
         Set_High_Bound (Range_Node, Expr_Node);
2780
         return Range_Node;
2781
 
2782
      --  Otherwise we must have a subtype mark, or an Ada 2012 iterator
2783
 
2784
      elsif Expr_Form = EF_Simple_Name then
2785
         return Expr_Node;
2786
 
2787
      --  The domain of iteration must be a name. Semantics will determine that
2788
      --  the expression has the proper form.
2789
 
2790
      elsif Ada_Version >= Ada_2012 then
2791
         return Expr_Node;
2792
 
2793
      --  If incorrect, complain that we expect ..
2794
 
2795
      else
2796
         T_Dot_Dot;
2797
         return Expr_Node;
2798
      end if;
2799
   end P_Discrete_Range;
2800
 
2801
   ----------------------------
2802
   -- 3.7  Discriminant Part --
2803
   ----------------------------
2804
 
2805
   --  DISCRIMINANT_PART ::=
2806
   --    UNKNOWN_DISCRIMINANT_PART
2807
   --  | KNOWN_DISCRIMINANT_PART
2808
 
2809
   --  A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
2810
   --  or P_Unknown_Discriminant_Part (3.7), since we know which we want.
2811
 
2812
   ------------------------------------
2813
   -- 3.7  Unknown Discriminant Part --
2814
   ------------------------------------
2815
 
2816
   --  UNKNOWN_DISCRIMINANT_PART ::= (<>)
2817
 
2818
   --  If no unknown discriminant part is present, then False is returned,
2819
   --  otherwise the unknown discriminant is scanned out and True is returned.
2820
 
2821
   --  Error recovery: cannot raise Error_Resync
2822
 
2823
   function P_Unknown_Discriminant_Part_Opt return Boolean is
2824
      Scan_State : Saved_Scan_State;
2825
 
2826
   begin
2827
      --  If <> right now, then this is missing left paren
2828
 
2829
      if Token = Tok_Box then
2830
         U_Left_Paren;
2831
 
2832
      --  If not <> or left paren, then definitely no box
2833
 
2834
      elsif Token /= Tok_Left_Paren then
2835
         return False;
2836
 
2837
      --  Left paren, so might be a box after it
2838
 
2839
      else
2840
         Save_Scan_State (Scan_State);
2841
         Scan; -- past the left paren
2842
 
2843
         if Token /= Tok_Box then
2844
            Restore_Scan_State (Scan_State);
2845
            return False;
2846
         end if;
2847
      end if;
2848
 
2849
      --  We are now pointing to the box
2850
 
2851
      if Ada_Version = Ada_83 then
2852
         Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!");
2853
      end if;
2854
 
2855
      Scan; -- past the box
2856
      U_Right_Paren; -- must be followed by right paren
2857
      return True;
2858
   end P_Unknown_Discriminant_Part_Opt;
2859
 
2860
   ----------------------------------
2861
   -- 3.7  Known Discriminant Part --
2862
   ----------------------------------
2863
 
2864
   --  KNOWN_DISCRIMINANT_PART ::=
2865
   --    (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
2866
 
2867
   --  DISCRIMINANT_SPECIFICATION ::=
2868
   --    DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
2869
   --      [:= DEFAULT_EXPRESSION]
2870
   --  | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
2871
   --      [:= DEFAULT_EXPRESSION]
2872
 
2873
   --  If no known discriminant part is present, then No_List is returned
2874
 
2875
   --  Error recovery: cannot raise Error_Resync
2876
 
2877
   function P_Known_Discriminant_Part_Opt return List_Id is
2878
      Specification_Node : Node_Id;
2879
      Specification_List : List_Id;
2880
      Ident_Sloc         : Source_Ptr;
2881
      Scan_State         : Saved_Scan_State;
2882
      Num_Idents         : Nat;
2883
      Not_Null_Present   : Boolean;
2884
      Ident              : Nat;
2885
 
2886
      Idents : array (Int range 1 .. 4096) of Entity_Id;
2887
      --  This array holds the list of defining identifiers. The upper bound
2888
      --  of 4096 is intended to be essentially infinite, and we do not even
2889
      --  bother to check for it being exceeded.
2890
 
2891
   begin
2892
      if Token = Tok_Left_Paren then
2893
         Specification_List := New_List;
2894
         Scan; -- past (
2895
         P_Pragmas_Misplaced;
2896
 
2897
         Specification_Loop : loop
2898
 
2899
            Ident_Sloc := Token_Ptr;
2900
            Idents (1) := P_Defining_Identifier (C_Comma_Colon);
2901
            Num_Idents := 1;
2902
 
2903
            while Comma_Present loop
2904
               Num_Idents := Num_Idents + 1;
2905
               Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
2906
            end loop;
2907
 
2908
            --  If there are multiple identifiers, we repeatedly scan the
2909
            --  type and initialization expression information by resetting
2910
            --  the scan pointer (so that we get completely separate trees
2911
            --  for each occurrence).
2912
 
2913
            if Num_Idents > 1 then
2914
               Save_Scan_State (Scan_State);
2915
            end if;
2916
 
2917
            T_Colon;
2918
 
2919
            --  Loop through defining identifiers in list
2920
 
2921
            Ident := 1;
2922
            Ident_Loop : loop
2923
               Specification_Node :=
2924
                 New_Node (N_Discriminant_Specification, Ident_Sloc);
2925
               Set_Defining_Identifier (Specification_Node, Idents (Ident));
2926
               Not_Null_Present :=  --  Ada 2005 (AI-231, AI-447)
2927
                 P_Null_Exclusion (Allow_Anonymous_In_95 => True);
2928
 
2929
               if Token = Tok_Access then
2930
                  if Ada_Version = Ada_83 then
2931
                     Error_Msg_SC
2932
                       ("(Ada 83) access discriminant not allowed!");
2933
                  end if;
2934
 
2935
                  Set_Discriminant_Type
2936
                    (Specification_Node,
2937
                     P_Access_Definition (Not_Null_Present));
2938
               else
2939
 
2940
                  Set_Discriminant_Type
2941
                    (Specification_Node, P_Subtype_Mark);
2942
                  No_Constraint;
2943
                  Set_Null_Exclusion_Present  -- Ada 2005 (AI-231)
2944
                    (Specification_Node, Not_Null_Present);
2945
               end if;
2946
 
2947
               Set_Expression
2948
                 (Specification_Node, Init_Expr_Opt (True));
2949
 
2950
               if Ident > 1 then
2951
                  Set_Prev_Ids (Specification_Node, True);
2952
               end if;
2953
 
2954
               if Ident < Num_Idents then
2955
                  Set_More_Ids (Specification_Node, True);
2956
               end if;
2957
 
2958
               Append (Specification_Node, Specification_List);
2959
               exit Ident_Loop when Ident = Num_Idents;
2960
               Ident := Ident + 1;
2961
               Restore_Scan_State (Scan_State);
2962
               T_Colon;
2963
            end loop Ident_Loop;
2964
 
2965
            exit Specification_Loop when Token /= Tok_Semicolon;
2966
            Scan; -- past ;
2967
            P_Pragmas_Misplaced;
2968
         end loop Specification_Loop;
2969
 
2970
         T_Right_Paren;
2971
         return Specification_List;
2972
 
2973
      else
2974
         return No_List;
2975
      end if;
2976
   end P_Known_Discriminant_Part_Opt;
2977
 
2978
   -------------------------------------
2979
   -- 3.7  Discriminant Specification --
2980
   -------------------------------------
2981
 
2982
   --  Parsed by P_Known_Discriminant_Part_Opt (3.7)
2983
 
2984
   -----------------------------
2985
   -- 3.7  Default Expression --
2986
   -----------------------------
2987
 
2988
   --  Always parsed (simply as an Expression) by the parent construct
2989
 
2990
   ------------------------------------
2991
   -- 3.7.1  Discriminant Constraint --
2992
   ------------------------------------
2993
 
2994
   --  Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2995
 
2996
   --------------------------------------------------------
2997
   -- 3.7.1  Index or Discriminant Constraint (also 3.6) --
2998
   --------------------------------------------------------
2999
 
3000
   --  DISCRIMINANT_CONSTRAINT ::=
3001
   --    (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
3002
 
3003
   --  DISCRIMINANT_ASSOCIATION ::=
3004
   --    [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
3005
   --      EXPRESSION
3006
 
3007
   --  This routine parses either an index or a discriminant constraint. As
3008
   --  is clear from the above grammar, it is often possible to clearly
3009
   --  determine which of the two possibilities we have, but there are
3010
   --  cases (those in which we have a series of expressions of the same
3011
   --  syntactic form as subtype indications), where we cannot tell. Since
3012
   --  this means that in any case the semantic phase has to distinguish
3013
   --  between the two, there is not much point in the parser trying to
3014
   --  distinguish even those cases where the difference is clear. In any
3015
   --  case, if we have a situation like:
3016
 
3017
   --     (A => 123, 235 .. 500)
3018
 
3019
   --  it is not clear which of the two items is the wrong one, better to
3020
   --  let the semantic phase give a clear message. Consequently, this
3021
   --  routine in general returns a list of items which can be either
3022
   --  discrete ranges or discriminant associations.
3023
 
3024
   --  The caller has checked that the initial token is a left paren
3025
 
3026
   --  Error recovery: can raise Error_Resync
3027
 
3028
   function P_Index_Or_Discriminant_Constraint return Node_Id is
3029
      Scan_State  : Saved_Scan_State;
3030
      Constr_Node : Node_Id;
3031
      Constr_List : List_Id;
3032
      Expr_Node   : Node_Id;
3033
      Result_Node : Node_Id;
3034
 
3035
   begin
3036
      Result_Node := New_Node (N_Index_Or_Discriminant_Constraint, Token_Ptr);
3037
      Scan; -- past (
3038
      Constr_List := New_List;
3039
      Set_Constraints (Result_Node, Constr_List);
3040
 
3041
      --  The two syntactic forms are a little mixed up, so what we are doing
3042
      --  here is looking at the first entry to determine which case we have
3043
 
3044
      --  A discriminant constraint is a list of discriminant associations,
3045
      --  which have one of the following possible forms:
3046
 
3047
      --    Expression
3048
      --    Id => Expression
3049
      --    Id | Id | .. | Id => Expression
3050
 
3051
      --  An index constraint is a list of discrete ranges which have one
3052
      --  of the following possible forms:
3053
 
3054
      --    Subtype_Mark
3055
      --    Subtype_Mark range Range
3056
      --    Range_Attribute
3057
      --    Simple_Expression .. Simple_Expression
3058
 
3059
      --  Loop through discriminants in list
3060
 
3061
      loop
3062
         --  Check cases of Id => Expression or Id | Id => Expression
3063
 
3064
         if Token = Tok_Identifier then
3065
            Save_Scan_State (Scan_State); -- at Id
3066
            Scan; -- past Id
3067
 
3068
            if Token = Tok_Arrow or else Token = Tok_Vertical_Bar then
3069
               Restore_Scan_State (Scan_State); -- to Id
3070
               Append (P_Discriminant_Association, Constr_List);
3071
               goto Loop_Continue;
3072
            else
3073
               Restore_Scan_State (Scan_State); -- to Id
3074
            end if;
3075
         end if;
3076
 
3077
         --  Otherwise scan out an expression and see what we have got
3078
 
3079
         Expr_Node := P_Expression_Or_Range_Attribute;
3080
 
3081
         if Expr_Form = EF_Range_Attr then
3082
            Append (Expr_Node, Constr_List);
3083
 
3084
         elsif Token = Tok_Range then
3085
            if Expr_Form /= EF_Simple_Name then
3086
               Error_Msg_SC ("subtype mark required before RANGE");
3087
            end if;
3088
 
3089
            Append (P_Subtype_Indication (Expr_Node), Constr_List);
3090
            goto Loop_Continue;
3091
 
3092
         --  Check Simple_Expression .. Simple_Expression case
3093
 
3094
         elsif Token = Tok_Dot_Dot then
3095
            Check_Simple_Expression (Expr_Node);
3096
            Constr_Node := New_Node (N_Range, Token_Ptr);
3097
            Set_Low_Bound (Constr_Node, Expr_Node);
3098
            Scan; -- past ..
3099
            Expr_Node := P_Expression;
3100
            Check_Simple_Expression (Expr_Node);
3101
            Set_High_Bound (Constr_Node, Expr_Node);
3102
            Append (Constr_Node, Constr_List);
3103
            goto Loop_Continue;
3104
 
3105
         --  Case of an expression which could be either form
3106
 
3107
         else
3108
            Append (Expr_Node, Constr_List);
3109
            goto Loop_Continue;
3110
         end if;
3111
 
3112
         --  Here with a single entry scanned
3113
 
3114
         <<Loop_Continue>>
3115
            exit when not Comma_Present;
3116
 
3117
      end loop;
3118
 
3119
      T_Right_Paren;
3120
      return Result_Node;
3121
   end P_Index_Or_Discriminant_Constraint;
3122
 
3123
   -------------------------------------
3124
   -- 3.7.1  Discriminant Association --
3125
   -------------------------------------
3126
 
3127
   --  DISCRIMINANT_ASSOCIATION ::=
3128
   --    [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
3129
   --      EXPRESSION
3130
 
3131
   --  This routine is used only when the name list is present and the caller
3132
   --  has already checked this (by scanning ahead and repositioning the
3133
   --  scan).
3134
 
3135
   --  Error_Recovery: cannot raise Error_Resync;
3136
 
3137
   function P_Discriminant_Association return Node_Id is
3138
      Discr_Node : Node_Id;
3139
      Names_List : List_Id;
3140
      Ident_Sloc : Source_Ptr;
3141
 
3142
   begin
3143
      Ident_Sloc := Token_Ptr;
3144
      Names_List := New_List;
3145
 
3146
      loop
3147
         Append (P_Identifier (C_Vertical_Bar_Arrow), Names_List);
3148
         exit when Token /= Tok_Vertical_Bar;
3149
         Scan; -- past |
3150
      end loop;
3151
 
3152
      Discr_Node := New_Node (N_Discriminant_Association, Ident_Sloc);
3153
      Set_Selector_Names (Discr_Node, Names_List);
3154
      TF_Arrow;
3155
      Set_Expression (Discr_Node, P_Expression);
3156
      return Discr_Node;
3157
   end P_Discriminant_Association;
3158
 
3159
   ---------------------------------
3160
   -- 3.8  Record Type Definition --
3161
   ---------------------------------
3162
 
3163
   --  RECORD_TYPE_DEFINITION ::=
3164
   --    [[abstract] tagged] [limited] RECORD_DEFINITION
3165
 
3166
   --  There is no node in the tree for a record type definition. Instead
3167
   --  a record definition node appears, with possible Abstract_Present,
3168
   --  Tagged_Present, and Limited_Present flags set appropriately.
3169
 
3170
   ----------------------------
3171
   -- 3.8  Record Definition --
3172
   ----------------------------
3173
 
3174
   --  RECORD_DEFINITION ::=
3175
   --    record
3176
   --      COMPONENT_LIST
3177
   --    end record
3178
   --  | null record
3179
 
3180
   --  Note: in the case where a record definition node is used to represent
3181
   --  a record type definition, the caller sets the Tagged_Present and
3182
   --  Limited_Present flags in the resulting N_Record_Definition node as
3183
   --  required.
3184
 
3185
   --  Note that the RECORD token at the start may be missing in certain
3186
   --  error situations, so this function is expected to post the error
3187
 
3188
   --  Error recovery: can raise Error_Resync
3189
 
3190
   function P_Record_Definition return Node_Id is
3191
      Rec_Node : Node_Id;
3192
 
3193
   begin
3194
      Rec_Node := New_Node (N_Record_Definition, Token_Ptr);
3195
 
3196
      --  Null record case
3197
 
3198
      if Token = Tok_Null then
3199
         Scan; -- past NULL
3200
         T_Record;
3201
         Set_Null_Present (Rec_Node, True);
3202
 
3203
      --  Catch incomplete declaration to prevent cascaded errors, see
3204
      --  ACATS B393002 for an example.
3205
 
3206
      elsif Token = Tok_Semicolon then
3207
         Error_Msg_AP ("missing record definition");
3208
 
3209
      --  Case starting with RECORD keyword. Build scope stack entry. For the
3210
      --  column, we use the first non-blank character on the line, to deal
3211
      --  with situations such as:
3212
 
3213
      --    type X is record
3214
      --      ...
3215
      --    end record;
3216
 
3217
      --  which is not official RM indentation, but is not uncommon usage, and
3218
      --  in particular is standard GNAT coding style, so handle it nicely.
3219
 
3220
      else
3221
         Push_Scope_Stack;
3222
         Scope.Table (Scope.Last).Etyp := E_Record;
3223
         Scope.Table (Scope.Last).Ecol := Start_Column;
3224
         Scope.Table (Scope.Last).Sloc := Token_Ptr;
3225
         Scope.Table (Scope.Last).Labl := Error;
3226
         Scope.Table (Scope.Last).Junk := (Token /= Tok_Record);
3227
 
3228
         T_Record;
3229
 
3230
         Set_Component_List (Rec_Node, P_Component_List);
3231
 
3232
         loop
3233
            exit when Check_End;
3234
            Discard_Junk_Node (P_Component_List);
3235
         end loop;
3236
      end if;
3237
 
3238
      return Rec_Node;
3239
   end P_Record_Definition;
3240
 
3241
   -------------------------
3242
   -- 3.8  Component List --
3243
   -------------------------
3244
 
3245
   --  COMPONENT_LIST ::=
3246
   --    COMPONENT_ITEM {COMPONENT_ITEM}
3247
   --  | {COMPONENT_ITEM} VARIANT_PART
3248
   --  | null;
3249
 
3250
   --  Error recovery: cannot raise Error_Resync
3251
 
3252
   function P_Component_List return Node_Id is
3253
      Component_List_Node : Node_Id;
3254
      Decls_List          : List_Id;
3255
      Scan_State          : Saved_Scan_State;
3256
 
3257
   begin
3258
      Component_List_Node := New_Node (N_Component_List, Token_Ptr);
3259
      Decls_List := New_List;
3260
 
3261
      if Token = Tok_Null then
3262
         Scan; -- past NULL
3263
         TF_Semicolon;
3264
         P_Pragmas_Opt (Decls_List);
3265
         Set_Null_Present (Component_List_Node, True);
3266
         return Component_List_Node;
3267
 
3268
      else
3269
         P_Pragmas_Opt (Decls_List);
3270
 
3271
         if Token /= Tok_Case then
3272
            Component_Scan_Loop : loop
3273
               P_Component_Items (Decls_List);
3274
               P_Pragmas_Opt (Decls_List);
3275
 
3276
               exit Component_Scan_Loop when Token = Tok_End
3277
                 or else Token = Tok_Case
3278
                 or else Token = Tok_When;
3279
 
3280
               --  We are done if we do not have an identifier. However, if
3281
               --  we have a misspelled reserved identifier that is in a column
3282
               --  to the right of the record definition, we will treat it as
3283
               --  an identifier. It turns out to be too dangerous in practice
3284
               --  to accept such a mis-spelled identifier which does not have
3285
               --  this additional clue that confirms the incorrect spelling.
3286
 
3287
               if Token /= Tok_Identifier then
3288
                  if Start_Column > Scope.Table (Scope.Last).Ecol
3289
                    and then Is_Reserved_Identifier
3290
                  then
3291
                     Save_Scan_State (Scan_State); -- at reserved id
3292
                     Scan; -- possible reserved id
3293
 
3294
                     if Token = Tok_Comma or else Token = Tok_Colon then
3295
                        Restore_Scan_State (Scan_State);
3296
                        Scan_Reserved_Identifier (Force_Msg => True);
3297
 
3298
                     --  Note reserved identifier used as field name after
3299
                     --  all because not followed by colon or comma
3300
 
3301
                     else
3302
                        Restore_Scan_State (Scan_State);
3303
                        exit Component_Scan_Loop;
3304
                     end if;
3305
 
3306
                  --  Non-identifier that definitely was not reserved id
3307
 
3308
                  else
3309
                     exit Component_Scan_Loop;
3310
                  end if;
3311
               end if;
3312
            end loop Component_Scan_Loop;
3313
         end if;
3314
 
3315
         if Token = Tok_Case then
3316
            Set_Variant_Part (Component_List_Node, P_Variant_Part);
3317
 
3318
            --  Check for junk after variant part
3319
 
3320
            if Token = Tok_Identifier then
3321
               Save_Scan_State (Scan_State);
3322
               Scan; -- past identifier
3323
 
3324
               if Token = Tok_Colon then
3325
                  Restore_Scan_State (Scan_State);
3326
                  Error_Msg_SC ("component may not follow variant part");
3327
                  Discard_Junk_Node (P_Component_List);
3328
 
3329
               elsif Token = Tok_Case then
3330
                  Restore_Scan_State (Scan_State);
3331
                  Error_Msg_SC ("only one variant part allowed in a record");
3332
                  Discard_Junk_Node (P_Component_List);
3333
 
3334
               else
3335
                  Restore_Scan_State (Scan_State);
3336
               end if;
3337
            end if;
3338
         end if;
3339
      end if;
3340
 
3341
      Set_Component_Items (Component_List_Node, Decls_List);
3342
      return Component_List_Node;
3343
   end P_Component_List;
3344
 
3345
   -------------------------
3346
   -- 3.8  Component Item --
3347
   -------------------------
3348
 
3349
   --  COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
3350
 
3351
   --  COMPONENT_DECLARATION ::=
3352
   --    DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
3353
   --      [:= DEFAULT_EXPRESSION]
3354
   --        [ASPECT_SPECIFICATIONS];
3355
 
3356
   --  COMPONENT_DEFINITION ::=
3357
   --    [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
3358
 
3359
   --  Error recovery: cannot raise Error_Resync, if an error occurs,
3360
   --  the scan is positioned past the following semicolon.
3361
 
3362
   --  Note: we do not yet allow representation clauses to appear as component
3363
   --  items, do we need to add this capability sometime in the future ???
3364
 
3365
   procedure P_Component_Items (Decls : List_Id) is
3366
      Aliased_Present  : Boolean := False;
3367
      CompDef_Node     : Node_Id;
3368
      Decl_Node        : Node_Id;
3369
      Scan_State       : Saved_Scan_State;
3370
      Not_Null_Present : Boolean := False;
3371
      Num_Idents       : Nat;
3372
      Ident            : Nat;
3373
      Ident_Sloc       : Source_Ptr;
3374
 
3375
      Idents : array (Int range 1 .. 4096) of Entity_Id;
3376
      --  This array holds the list of defining identifiers. The upper bound
3377
      --  of 4096 is intended to be essentially infinite, and we do not even
3378
      --  bother to check for it being exceeded.
3379
 
3380
   begin
3381
      if Token /= Tok_Identifier then
3382
         Error_Msg_SC ("component declaration expected");
3383
         Resync_Past_Semicolon;
3384
         return;
3385
      end if;
3386
 
3387
      Ident_Sloc := Token_Ptr;
3388
      Idents (1) := P_Defining_Identifier (C_Comma_Colon);
3389
      Num_Idents := 1;
3390
 
3391
      while Comma_Present loop
3392
         Num_Idents := Num_Idents + 1;
3393
         Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
3394
      end loop;
3395
 
3396
      --  If there are multiple identifiers, we repeatedly scan the
3397
      --  type and initialization expression information by resetting
3398
      --  the scan pointer (so that we get completely separate trees
3399
      --  for each occurrence).
3400
 
3401
      if Num_Idents > 1 then
3402
         Save_Scan_State (Scan_State);
3403
      end if;
3404
 
3405
      T_Colon;
3406
 
3407
      --  Loop through defining identifiers in list
3408
 
3409
      Ident := 1;
3410
      Ident_Loop : loop
3411
 
3412
         --  The following block is present to catch Error_Resync
3413
         --  which causes the parse to be reset past the semicolon
3414
 
3415
         begin
3416
            Decl_Node := New_Node (N_Component_Declaration, Ident_Sloc);
3417
            Set_Defining_Identifier (Decl_Node, Idents (Ident));
3418
 
3419
            if Token = Tok_Constant then
3420
               Error_Msg_SC ("constant components are not permitted");
3421
               Scan;
3422
            end if;
3423
 
3424
            CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
3425
 
3426
            if Token_Name = Name_Aliased then
3427
               Check_95_Keyword (Tok_Aliased, Tok_Identifier);
3428
            end if;
3429
 
3430
            if Token = Tok_Aliased then
3431
               Aliased_Present := True;
3432
               Scan; -- past ALIASED
3433
            end if;
3434
 
3435
            Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254)
3436
 
3437
            --  Ada 2005 (AI-230): Access Definition case
3438
 
3439
            if Token = Tok_Access then
3440
               if Ada_Version < Ada_2005 then
3441
                  Error_Msg_SP
3442
                    ("generalized use of anonymous access types " &
3443
                     "is an Ada 2005 extension");
3444
                  Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
3445
               end if;
3446
 
3447
               --  AI95-406 makes "aliased" legal (and useless) here, so the
3448
               --  following code which used to be required is commented out.
3449
 
3450
               --  if Aliased_Present then
3451
               --     Error_Msg_SP ("ALIASED not allowed here");
3452
               --  end if;
3453
 
3454
               Set_Subtype_Indication (CompDef_Node, Empty);
3455
               Set_Aliased_Present    (CompDef_Node, False);
3456
               Set_Access_Definition  (CompDef_Node,
3457
                 P_Access_Definition (Not_Null_Present));
3458
            else
3459
 
3460
               Set_Access_Definition      (CompDef_Node, Empty);
3461
               Set_Aliased_Present        (CompDef_Node, Aliased_Present);
3462
               Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
3463
 
3464
               if Token = Tok_Array then
3465
                  Error_Msg_SC ("anonymous arrays not allowed as components");
3466
                  raise Error_Resync;
3467
               end if;
3468
 
3469
               Set_Subtype_Indication (CompDef_Node,
3470
                 P_Subtype_Indication (Not_Null_Present));
3471
            end if;
3472
 
3473
            Set_Component_Definition (Decl_Node, CompDef_Node);
3474
            Set_Expression           (Decl_Node, Init_Expr_Opt);
3475
 
3476
            if Ident > 1 then
3477
               Set_Prev_Ids (Decl_Node, True);
3478
            end if;
3479
 
3480
            if Ident < Num_Idents then
3481
               Set_More_Ids (Decl_Node, True);
3482
            end if;
3483
 
3484
            Append (Decl_Node, Decls);
3485
 
3486
         exception
3487
            when Error_Resync =>
3488
               if Token /= Tok_End then
3489
                  Resync_Past_Semicolon;
3490
               end if;
3491
         end;
3492
 
3493
         exit Ident_Loop when Ident = Num_Idents;
3494
         Ident := Ident + 1;
3495
         Restore_Scan_State (Scan_State);
3496
         T_Colon;
3497
      end loop Ident_Loop;
3498
 
3499
      P_Aspect_Specifications (Decl_Node);
3500
   end P_Component_Items;
3501
 
3502
   --------------------------------
3503
   -- 3.8  Component Declaration --
3504
   --------------------------------
3505
 
3506
   --  Parsed by P_Component_Items (3.8)
3507
 
3508
   -------------------------
3509
   -- 3.8.1  Variant Part --
3510
   -------------------------
3511
 
3512
   --  VARIANT_PART ::=
3513
   --    case discriminant_DIRECT_NAME is
3514
   --      VARIANT
3515
   --      {VARIANT}
3516
   --    end case;
3517
 
3518
   --  The caller has checked that the initial token is CASE
3519
 
3520
   --  Error recovery: cannot raise Error_Resync
3521
 
3522
   function P_Variant_Part return Node_Id is
3523
      Variant_Part_Node : Node_Id;
3524
      Variants_List     : List_Id;
3525
      Case_Node         : Node_Id;
3526
 
3527
   begin
3528
      Variant_Part_Node := New_Node (N_Variant_Part, Token_Ptr);
3529
      Push_Scope_Stack;
3530
      Scope.Table (Scope.Last).Etyp := E_Case;
3531
      Scope.Table (Scope.Last).Sloc := Token_Ptr;
3532
      Scope.Table (Scope.Last).Ecol := Start_Column;
3533
 
3534
      Scan; -- past CASE
3535
      Case_Node := P_Expression;
3536
      Set_Name (Variant_Part_Node, Case_Node);
3537
 
3538
      if Nkind (Case_Node) /= N_Identifier then
3539
         Set_Name (Variant_Part_Node, Error);
3540
         Error_Msg ("discriminant name expected", Sloc (Case_Node));
3541
 
3542
      elsif Paren_Count (Case_Node) /= 0 then
3543
         Error_Msg
3544
           ("|discriminant name may not be parenthesized",
3545
                    Sloc (Case_Node));
3546
         Set_Paren_Count (Case_Node, 0);
3547
      end if;
3548
 
3549
      TF_Is;
3550
      Variants_List := New_List;
3551
      P_Pragmas_Opt (Variants_List);
3552
 
3553
      --  Test missing variant
3554
 
3555
      if Token = Tok_End then
3556
         Error_Msg_BC ("WHEN expected (must have at least one variant)");
3557
      else
3558
         Append (P_Variant, Variants_List);
3559
      end if;
3560
 
3561
      --  Loop through variants, note that we allow if in place of when,
3562
      --  this error will be detected and handled in P_Variant.
3563
 
3564
      loop
3565
         P_Pragmas_Opt (Variants_List);
3566
 
3567
         if Token /= Tok_When
3568
           and then Token /= Tok_If
3569
           and then Token /= Tok_Others
3570
         then
3571
            exit when Check_End;
3572
         end if;
3573
 
3574
         Append (P_Variant, Variants_List);
3575
      end loop;
3576
 
3577
      Set_Variants (Variant_Part_Node, Variants_List);
3578
      return Variant_Part_Node;
3579
   end P_Variant_Part;
3580
 
3581
   --------------------
3582
   -- 3.8.1  Variant --
3583
   --------------------
3584
 
3585
   --  VARIANT ::=
3586
   --    when DISCRETE_CHOICE_LIST =>
3587
   --      COMPONENT_LIST
3588
 
3589
   --  Error recovery: cannot raise Error_Resync
3590
 
3591
   --  The initial token on entry is either WHEN, IF or OTHERS
3592
 
3593
   function P_Variant return Node_Id is
3594
      Variant_Node : Node_Id;
3595
 
3596
   begin
3597
      --  Special check to recover nicely from use of IF in place of WHEN
3598
 
3599
      if Token = Tok_If then
3600
         T_When;
3601
         Scan; -- past IF
3602
      else
3603
         T_When;
3604
      end if;
3605
 
3606
      Variant_Node := New_Node (N_Variant, Prev_Token_Ptr);
3607
      Set_Discrete_Choices (Variant_Node, P_Discrete_Choice_List);
3608
      TF_Arrow;
3609
      Set_Component_List (Variant_Node, P_Component_List);
3610
      return Variant_Node;
3611
   end P_Variant;
3612
 
3613
   ---------------------------------
3614
   -- 3.8.1  Discrete Choice List --
3615
   ---------------------------------
3616
 
3617
   --  DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
3618
 
3619
   --  DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
3620
 
3621
   --  Note: in Ada 83, the expression must be a simple expression
3622
 
3623
   --  Error recovery: cannot raise Error_Resync
3624
 
3625
   function P_Discrete_Choice_List return List_Id is
3626
      Choices     : List_Id;
3627
      Expr_Node   : Node_Id;
3628
      Choice_Node : Node_Id;
3629
 
3630
   begin
3631
      Choices := New_List;
3632
      loop
3633
         if Token = Tok_Others then
3634
            Append (New_Node (N_Others_Choice, Token_Ptr), Choices);
3635
            Scan; -- past OTHERS
3636
 
3637
         else
3638
            begin
3639
               --  Scan out expression or range attribute
3640
 
3641
               Expr_Node := P_Expression_Or_Range_Attribute;
3642
               Ignore (Tok_Right_Paren);
3643
 
3644
               if Token = Tok_Colon
3645
                 and then Nkind (Expr_Node) = N_Identifier
3646
               then
3647
                  Error_Msg_SP ("label not permitted in this context");
3648
                  Scan; -- past colon
3649
 
3650
               --  Range attribute
3651
 
3652
               elsif Expr_Form = EF_Range_Attr then
3653
                  Append (Expr_Node, Choices);
3654
 
3655
               --  Explicit range
3656
 
3657
               elsif Token = Tok_Dot_Dot then
3658
                  Check_Simple_Expression (Expr_Node);
3659
                  Choice_Node := New_Node (N_Range, Token_Ptr);
3660
                  Set_Low_Bound (Choice_Node, Expr_Node);
3661
                  Scan; -- past ..
3662
                  Expr_Node := P_Expression_No_Right_Paren;
3663
                  Check_Simple_Expression (Expr_Node);
3664
                  Set_High_Bound (Choice_Node, Expr_Node);
3665
                  Append (Choice_Node, Choices);
3666
 
3667
               --  Simple name, must be subtype, so range allowed
3668
 
3669
               elsif Expr_Form = EF_Simple_Name then
3670
                  if Token = Tok_Range then
3671
                     Append (P_Subtype_Indication (Expr_Node), Choices);
3672
 
3673
                  elsif Token in Token_Class_Consk then
3674
                     Error_Msg_SC
3675
                       ("the only constraint allowed here " &
3676
                        "is a range constraint");
3677
                     Discard_Junk_Node (P_Constraint_Opt);
3678
                     Append (Expr_Node, Choices);
3679
 
3680
                  else
3681
                     Append (Expr_Node, Choices);
3682
                  end if;
3683
 
3684
               --  Expression
3685
 
3686
               else
3687
                  --  In Ada 2012 mode, the expression must be a simple
3688
                  --  expression. The reason for this restriction (i.e. going
3689
                  --  back to the Ada 83 rule) is to avoid ambiguities when set
3690
                  --  membership operations are allowed, consider the
3691
                  --  following:
3692
 
3693
                  --     when A in 1 .. 10 | 12 =>
3694
 
3695
                  --  This is ambiguous without parentheses, so we require one
3696
                  --  of the following two parenthesized forms to disambiguate:
3697
 
3698
                  --  one of the following:
3699
 
3700
                  --     when (A in 1 .. 10 | 12) =>
3701
                  --     when (A in 1 .. 10) | 12 =>
3702
 
3703
                  --  To solve this, in Ada 2012 mode, we disallow the use of
3704
                  --  membership operations in expressions in choices.
3705
 
3706
                  --  Technically in the grammar, the expression must match the
3707
                  --  grammar for restricted expression.
3708
 
3709
                  if Ada_Version >= Ada_2012 then
3710
                     Check_Restricted_Expression (Expr_Node);
3711
 
3712
                  --  In Ada 83 mode, the syntax required a simple expression
3713
 
3714
                  else
3715
                     Check_Simple_Expression_In_Ada_83 (Expr_Node);
3716
                  end if;
3717
 
3718
                  Append (Expr_Node, Choices);
3719
               end if;
3720
 
3721
            exception
3722
               when Error_Resync =>
3723
                  Resync_Choice;
3724
                  return Error_List;
3725
            end;
3726
         end if;
3727
 
3728
         if Token = Tok_Comma then
3729
            Scan; -- past comma
3730
 
3731
            if Token = Tok_Vertical_Bar then
3732
               Error_Msg_SP -- CODEFIX
3733
                 ("|extra "","" ignored");
3734
               Scan; -- past |
3735
 
3736
            else
3737
               Error_Msg_SP -- CODEFIX
3738
                 (""","" should be ""'|""");
3739
            end if;
3740
 
3741
         else
3742
            exit when Token /= Tok_Vertical_Bar;
3743
            Scan; -- past |
3744
         end if;
3745
 
3746
      end loop;
3747
 
3748
      return Choices;
3749
   end P_Discrete_Choice_List;
3750
 
3751
   ----------------------------
3752
   -- 3.8.1  Discrete Choice --
3753
   ----------------------------
3754
 
3755
   --  Parsed by P_Discrete_Choice_List (3.8.1)
3756
 
3757
   ----------------------------------
3758
   -- 3.9.1  Record Extension Part --
3759
   ----------------------------------
3760
 
3761
   --  RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
3762
 
3763
   --  Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
3764
 
3765
   --------------------------------------
3766
   -- 3.9.4  Interface Type Definition --
3767
   --------------------------------------
3768
 
3769
   --  INTERFACE_TYPE_DEFINITION ::=
3770
   --    [limited | task | protected | synchronized] interface
3771
   --      [and INTERFACE_LIST]
3772
 
3773
   --  Error recovery: cannot raise Error_Resync
3774
 
3775
   function P_Interface_Type_Definition
3776
     (Abstract_Present : Boolean) return Node_Id
3777
   is
3778
      Typedef_Node : Node_Id;
3779
 
3780
   begin
3781
      if Ada_Version < Ada_2005 then
3782
         Error_Msg_SP ("abstract interface is an Ada 2005 extension");
3783
         Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
3784
      end if;
3785
 
3786
      if Abstract_Present then
3787
         Error_Msg_SP
3788
           ("ABSTRACT not allowed in interface type definition " &
3789
            "(RM 3.9.4(2/2))");
3790
      end if;
3791
 
3792
      Scan; -- past INTERFACE
3793
 
3794
      --  Ada 2005 (AI-345): In case of interfaces with a null list of
3795
      --  interfaces we build a record_definition node.
3796
 
3797
      if Token = Tok_Semicolon or else Aspect_Specifications_Present then
3798
         Typedef_Node := New_Node (N_Record_Definition, Token_Ptr);
3799
 
3800
         Set_Abstract_Present  (Typedef_Node);
3801
         Set_Tagged_Present    (Typedef_Node);
3802
         Set_Null_Present      (Typedef_Node);
3803
         Set_Interface_Present (Typedef_Node);
3804
 
3805
      --  Ada 2005 (AI-251): In case of not-synchronized interfaces that have
3806
      --  a list of interfaces we build a derived_type_definition node. This
3807
      --  simplifies the semantic analysis (and hence further maintenance)
3808
 
3809
      else
3810
         if Token /= Tok_And then
3811
            Error_Msg_AP ("AND expected");
3812
         else
3813
            Scan; -- past AND
3814
         end if;
3815
 
3816
         Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
3817
 
3818
         Set_Abstract_Present   (Typedef_Node);
3819
         Set_Interface_Present  (Typedef_Node);
3820
         Set_Subtype_Indication (Typedef_Node, P_Qualified_Simple_Name);
3821
 
3822
         Set_Record_Extension_Part (Typedef_Node,
3823
           New_Node (N_Record_Definition, Token_Ptr));
3824
         Set_Null_Present (Record_Extension_Part (Typedef_Node));
3825
 
3826
         if Token = Tok_And then
3827
            Set_Interface_List (Typedef_Node, New_List);
3828
            Scan; -- past AND
3829
 
3830
            loop
3831
               Append (P_Qualified_Simple_Name,
3832
                       Interface_List (Typedef_Node));
3833
               exit when Token /= Tok_And;
3834
               Scan; -- past AND
3835
            end loop;
3836
         end if;
3837
      end if;
3838
 
3839
      return Typedef_Node;
3840
   end P_Interface_Type_Definition;
3841
 
3842
   ----------------------------------
3843
   -- 3.10  Access Type Definition --
3844
   ----------------------------------
3845
 
3846
   --  ACCESS_TYPE_DEFINITION ::=
3847
   --    ACCESS_TO_OBJECT_DEFINITION
3848
   --  | ACCESS_TO_SUBPROGRAM_DEFINITION
3849
 
3850
   --  ACCESS_TO_OBJECT_DEFINITION ::=
3851
   --    [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
3852
 
3853
   --  GENERAL_ACCESS_MODIFIER ::= all | constant
3854
 
3855
   --  ACCESS_TO_SUBPROGRAM_DEFINITION
3856
   --    [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3857
   --  | [NULL_EXCLUSION] access [protected] function
3858
   --    PARAMETER_AND_RESULT_PROFILE
3859
 
3860
   --  PARAMETER_PROFILE ::= [FORMAL_PART]
3861
 
3862
   --  PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
3863
 
3864
   --  Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already
3865
   --  parsed the null_exclusion part and has also removed the ACCESS token;
3866
   --  otherwise the caller has just checked that the initial token is ACCESS
3867
 
3868
   --  Error recovery: can raise Error_Resync
3869
 
3870
   function P_Access_Type_Definition
3871
     (Header_Already_Parsed : Boolean := False) return Node_Id
3872
   is
3873
      Access_Loc       : constant Source_Ptr := Token_Ptr;
3874
      Prot_Flag        : Boolean;
3875
      Not_Null_Present : Boolean := False;
3876
      Type_Def_Node    : Node_Id;
3877
      Result_Not_Null  : Boolean;
3878
      Result_Node      : Node_Id;
3879
 
3880
      procedure Check_Junk_Subprogram_Name;
3881
      --  Used in access to subprogram definition cases to check for an
3882
      --  identifier or operator symbol that does not belong.
3883
 
3884
      --------------------------------
3885
      -- Check_Junk_Subprogram_Name --
3886
      --------------------------------
3887
 
3888
      procedure Check_Junk_Subprogram_Name is
3889
         Saved_State : Saved_Scan_State;
3890
 
3891
      begin
3892
         if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
3893
            Save_Scan_State (Saved_State);
3894
            Scan; -- past possible junk subprogram name
3895
 
3896
            if Token = Tok_Left_Paren or else Token = Tok_Semicolon then
3897
               Error_Msg_SP ("unexpected subprogram name ignored");
3898
               return;
3899
 
3900
            else
3901
               Restore_Scan_State (Saved_State);
3902
            end if;
3903
         end if;
3904
      end Check_Junk_Subprogram_Name;
3905
 
3906
   --  Start of processing for P_Access_Type_Definition
3907
 
3908
   begin
3909
      if not Header_Already_Parsed then
3910
         Not_Null_Present := P_Null_Exclusion;         --  Ada 2005 (AI-231)
3911
         Scan; -- past ACCESS
3912
      end if;
3913
 
3914
      if Token_Name = Name_Protected then
3915
         Check_95_Keyword (Tok_Protected, Tok_Procedure);
3916
         Check_95_Keyword (Tok_Protected, Tok_Function);
3917
      end if;
3918
 
3919
      Prot_Flag := (Token = Tok_Protected);
3920
 
3921
      if Prot_Flag then
3922
         Scan; -- past PROTECTED
3923
 
3924
         if Token /= Tok_Procedure and then Token /= Tok_Function then
3925
            Error_Msg_SC -- CODEFIX
3926
              ("FUNCTION or PROCEDURE expected");
3927
         end if;
3928
      end if;
3929
 
3930
      if Token = Tok_Procedure then
3931
         if Ada_Version = Ada_83 then
3932
            Error_Msg_SC ("(Ada 83) access to procedure not allowed!");
3933
         end if;
3934
 
3935
         Type_Def_Node := New_Node (N_Access_Procedure_Definition, Access_Loc);
3936
         Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3937
         Scan; -- past PROCEDURE
3938
         Check_Junk_Subprogram_Name;
3939
         Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
3940
         Set_Protected_Present (Type_Def_Node, Prot_Flag);
3941
 
3942
      elsif Token = Tok_Function then
3943
         if Ada_Version = Ada_83 then
3944
            Error_Msg_SC ("(Ada 83) access to function not allowed!");
3945
         end if;
3946
 
3947
         Type_Def_Node := New_Node (N_Access_Function_Definition, Access_Loc);
3948
         Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3949
         Scan; -- past FUNCTION
3950
         Check_Junk_Subprogram_Name;
3951
         Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
3952
         Set_Protected_Present (Type_Def_Node, Prot_Flag);
3953
         TF_Return;
3954
 
3955
         Result_Not_Null := P_Null_Exclusion;     --  Ada 2005 (AI-231)
3956
 
3957
         --  Ada 2005 (AI-318-02)
3958
 
3959
         if Token = Tok_Access then
3960
            if Ada_Version < Ada_2005 then
3961
               Error_Msg_SC
3962
                 ("anonymous access result type is an Ada 2005 extension");
3963
               Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
3964
            end if;
3965
 
3966
            Result_Node := P_Access_Definition (Result_Not_Null);
3967
 
3968
         else
3969
            Result_Node := P_Subtype_Mark;
3970
            No_Constraint;
3971
 
3972
            --  A null exclusion on the result type must be recorded in a flag
3973
            --  distinct from the one used for the access-to-subprogram type's
3974
            --  null exclusion.
3975
 
3976
            Set_Null_Exclusion_In_Return_Present
3977
              (Type_Def_Node, Result_Not_Null);
3978
         end if;
3979
 
3980
         Set_Result_Definition (Type_Def_Node, Result_Node);
3981
 
3982
      else
3983
         Type_Def_Node :=
3984
           New_Node (N_Access_To_Object_Definition, Access_Loc);
3985
         Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3986
 
3987
         if Token = Tok_All or else Token = Tok_Constant then
3988
            if Ada_Version = Ada_83 then
3989
               Error_Msg_SC ("(Ada 83) access modifier not allowed!");
3990
            end if;
3991
 
3992
            if Token = Tok_All then
3993
               Set_All_Present (Type_Def_Node, True);
3994
 
3995
            else
3996
               Set_Constant_Present (Type_Def_Node, True);
3997
            end if;
3998
 
3999
            Scan; -- past ALL or CONSTANT
4000
         end if;
4001
 
4002
         Set_Subtype_Indication (Type_Def_Node,
4003
            P_Subtype_Indication (Not_Null_Present));
4004
      end if;
4005
 
4006
      return Type_Def_Node;
4007
   end P_Access_Type_Definition;
4008
 
4009
   ---------------------------------------
4010
   -- 3.10  Access To Object Definition --
4011
   ---------------------------------------
4012
 
4013
   --  Parsed by P_Access_Type_Definition (3.10)
4014
 
4015
   -----------------------------------
4016
   -- 3.10  General Access Modifier --
4017
   -----------------------------------
4018
 
4019
   --  Parsed by P_Access_Type_Definition (3.10)
4020
 
4021
   -------------------------------------------
4022
   -- 3.10  Access To Subprogram Definition --
4023
   -------------------------------------------
4024
 
4025
   --  Parsed by P_Access_Type_Definition (3.10)
4026
 
4027
   -----------------------------
4028
   -- 3.10  Access Definition --
4029
   -----------------------------
4030
 
4031
   --  ACCESS_DEFINITION ::=
4032
   --    [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
4033
   --  | ACCESS_TO_SUBPROGRAM_DEFINITION
4034
   --
4035
   --  ACCESS_TO_SUBPROGRAM_DEFINITION
4036
   --    [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
4037
   --  | [NULL_EXCLUSION] access [protected] function
4038
   --    PARAMETER_AND_RESULT_PROFILE
4039
 
4040
   --  The caller has parsed the null-exclusion part and it has also checked
4041
   --  that the next token is ACCESS
4042
 
4043
   --  Error recovery: cannot raise Error_Resync
4044
 
4045
   function P_Access_Definition
4046
     (Null_Exclusion_Present : Boolean) return Node_Id
4047
   is
4048
      Def_Node  : Node_Id;
4049
      Subp_Node : Node_Id;
4050
 
4051
   begin
4052
      Def_Node := New_Node (N_Access_Definition, Token_Ptr);
4053
      Scan; -- past ACCESS
4054
 
4055
      --  Ada 2005 (AI-254): Access_To_Subprogram_Definition
4056
 
4057
      if Token = Tok_Protected
4058
        or else Token = Tok_Procedure
4059
        or else Token = Tok_Function
4060
      then
4061
         if Ada_Version < Ada_2005 then
4062
            Error_Msg_SP ("access-to-subprogram is an Ada 2005 extension");
4063
            Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
4064
         end if;
4065
 
4066
         Subp_Node := P_Access_Type_Definition (Header_Already_Parsed => True);
4067
         Set_Null_Exclusion_Present (Subp_Node, Null_Exclusion_Present);
4068
         Set_Access_To_Subprogram_Definition (Def_Node, Subp_Node);
4069
 
4070
      --  Ada 2005 (AI-231)
4071
      --  [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
4072
 
4073
      else
4074
         Set_Null_Exclusion_Present (Def_Node, Null_Exclusion_Present);
4075
 
4076
         if Token = Tok_All then
4077
            if Ada_Version < Ada_2005 then
4078
               Error_Msg_SP
4079
                 ("ALL is not permitted for anonymous access types");
4080
            end if;
4081
 
4082
            Scan; -- past ALL
4083
            Set_All_Present (Def_Node);
4084
 
4085
         elsif Token = Tok_Constant then
4086
            if Ada_Version < Ada_2005 then
4087
               Error_Msg_SP ("access-to-constant is an Ada 2005 extension");
4088
               Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
4089
            end if;
4090
 
4091
            Scan; -- past CONSTANT
4092
            Set_Constant_Present (Def_Node);
4093
         end if;
4094
 
4095
         Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
4096
         No_Constraint;
4097
      end if;
4098
 
4099
      return Def_Node;
4100
   end P_Access_Definition;
4101
 
4102
   -----------------------------------------
4103
   -- 3.10.1  Incomplete Type Declaration --
4104
   -----------------------------------------
4105
 
4106
   --  Parsed by P_Type_Declaration (3.2.1)
4107
 
4108
   ----------------------------
4109
   -- 3.11  Declarative Part --
4110
   ----------------------------
4111
 
4112
   --  DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
4113
 
4114
   --  Error recovery: cannot raise Error_Resync (because P_Declarative_Items
4115
   --  handles errors, and returns cleanly after an error has occurred)
4116
 
4117
   function P_Declarative_Part return List_Id is
4118
      Decls : List_Id;
4119
      Done  : Boolean;
4120
 
4121
   begin
4122
      --  Indicate no bad declarations detected yet. This will be reset by
4123
      --  P_Declarative_Items if a bad declaration is discovered.
4124
 
4125
      Missing_Begin_Msg := No_Error_Msg;
4126
 
4127
      --  Get rid of active SIS entry from outer scope. This means we will
4128
      --  miss some nested cases, but it doesn't seem worth the effort. See
4129
      --  discussion in Par for further details
4130
 
4131
      SIS_Entry_Active := False;
4132
      Decls := New_List;
4133
 
4134
      --  Loop to scan out the declarations
4135
 
4136
      loop
4137
         P_Declarative_Items (Decls, Done, In_Spec => False);
4138
         exit when Done;
4139
      end loop;
4140
 
4141
      --  Get rid of active SIS entry which is left set only if we scanned a
4142
      --  procedure declaration and have not found the body. We could give
4143
      --  an error message, but that really would be usurping the role of
4144
      --  semantic analysis (this really is a missing body case).
4145
 
4146
      SIS_Entry_Active := False;
4147
      return Decls;
4148
   end P_Declarative_Part;
4149
 
4150
   ----------------------------
4151
   -- 3.11  Declarative Item --
4152
   ----------------------------
4153
 
4154
   --  DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
4155
 
4156
   --  Can return Error if a junk declaration is found, or Empty if no
4157
   --  declaration is found (i.e. a token ending declarations, such as
4158
   --  BEGIN or END is encountered).
4159
 
4160
   --  Error recovery: cannot raise Error_Resync. If an error resync occurs,
4161
   --  then the scan is set past the next semicolon and Error is returned.
4162
 
4163
   procedure P_Declarative_Items
4164
     (Decls   : List_Id;
4165
      Done    : out Boolean;
4166
      In_Spec : Boolean)
4167
   is
4168
      Scan_State : Saved_Scan_State;
4169
 
4170
   begin
4171
      if Style_Check then
4172
         Style.Check_Indentation;
4173
      end if;
4174
 
4175
      case Token is
4176
 
4177
         when Tok_Function =>
4178
            Check_Bad_Layout;
4179
            Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
4180
            Done := False;
4181
 
4182
         when Tok_For =>
4183
            Check_Bad_Layout;
4184
 
4185
            --  Check for loop (premature statement)
4186
 
4187
            Save_Scan_State (Scan_State);
4188
            Scan; -- past FOR
4189
 
4190
            if Token = Tok_Identifier then
4191
               Scan; -- past identifier
4192
 
4193
               if Token = Tok_In then
4194
                  Restore_Scan_State (Scan_State);
4195
                  Statement_When_Declaration_Expected (Decls, Done, In_Spec);
4196
                  return;
4197
               end if;
4198
            end if;
4199
 
4200
            --  Not a loop, so must be rep clause
4201
 
4202
            Restore_Scan_State (Scan_State);
4203
            Append (P_Representation_Clause, Decls);
4204
            Done := False;
4205
 
4206
         when Tok_Generic =>
4207
            Check_Bad_Layout;
4208
            Append (P_Generic, Decls);
4209
            Done := False;
4210
 
4211
         when Tok_Identifier =>
4212
            Check_Bad_Layout;
4213
 
4214
            --  Special check for misuse of overriding not in Ada 2005 mode
4215
 
4216
            if Token_Name = Name_Overriding
4217
              and then not Next_Token_Is (Tok_Colon)
4218
            then
4219
               Error_Msg_SC ("overriding indicator is an Ada 2005 extension");
4220
               Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
4221
 
4222
               Token := Tok_Overriding;
4223
               Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
4224
               Done := False;
4225
 
4226
            --  Normal case, no overriding, or overriding followed by colon
4227
 
4228
            else
4229
               P_Identifier_Declarations (Decls, Done, In_Spec);
4230
            end if;
4231
 
4232
         --  Ada 2005: A subprogram declaration can start with "not" or
4233
         --  "overriding". In older versions, "overriding" is handled
4234
         --  like an identifier, with the appropriate messages.
4235
 
4236
         when Tok_Not =>
4237
            Check_Bad_Layout;
4238
            Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
4239
            Done := False;
4240
 
4241
         when Tok_Overriding =>
4242
            Check_Bad_Layout;
4243
            Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
4244
            Done := False;
4245
 
4246
         when Tok_Package =>
4247
            Check_Bad_Layout;
4248
            Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
4249
            Done := False;
4250
 
4251
         when Tok_Pragma =>
4252
            Append (P_Pragma, Decls);
4253
            Done := False;
4254
 
4255
         when Tok_Procedure =>
4256
            Check_Bad_Layout;
4257
            Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
4258
            Done := False;
4259
 
4260
         when Tok_Protected =>
4261
            Check_Bad_Layout;
4262
            Scan; -- past PROTECTED
4263
            Append (P_Protected, Decls);
4264
            Done := False;
4265
 
4266
         when Tok_Subtype =>
4267
            Check_Bad_Layout;
4268
            Append (P_Subtype_Declaration, Decls);
4269
            Done := False;
4270
 
4271
         when Tok_Task =>
4272
            Check_Bad_Layout;
4273
            Scan; -- past TASK
4274
            Append (P_Task, Decls);
4275
            Done := False;
4276
 
4277
         when Tok_Type =>
4278
            Check_Bad_Layout;
4279
            Append (P_Type_Declaration, Decls);
4280
            Done := False;
4281
 
4282
         when Tok_Use =>
4283
            Check_Bad_Layout;
4284
            Append (P_Use_Clause, Decls);
4285
            Done := False;
4286
 
4287
         when Tok_With =>
4288
            Check_Bad_Layout;
4289
 
4290
            if Aspect_Specifications_Present then
4291
 
4292
               --  If we are after a semicolon, complain that it was ignored.
4293
               --  But we don't really ignore it, since we dump the aspects,
4294
               --  so we make the error message a normal fatal message which
4295
               --  will inhibit semantic analysis anyway).
4296
 
4297
               if Prev_Token = Tok_Semicolon then
4298
                  Error_Msg_SP -- CODEFIX
4299
                    ("extra "";"" ignored");
4300
 
4301
               --  If not just past semicolon, just complain that aspects are
4302
               --  not allowed at this point.
4303
 
4304
               else
4305
                  Error_Msg_SC ("aspect specifications not allowed here");
4306
               end if;
4307
 
4308
               declare
4309
                  Dummy_Node : constant Node_Id :=
4310
                                 New_Node (N_Package_Specification, Token_Ptr);
4311
                  pragma Warnings (Off, Dummy_Node);
4312
                  --  Dummy node to attach aspect specifications to. We will
4313
                  --  then throw them away.
4314
 
4315
               begin
4316
                  P_Aspect_Specifications (Dummy_Node, Semicolon => True);
4317
               end;
4318
 
4319
            --  Here if not aspect specifications case
4320
 
4321
            else
4322
               Error_Msg_SC ("WITH can only appear in context clause");
4323
               raise Error_Resync;
4324
            end if;
4325
 
4326
         --  BEGIN terminates the scan of a sequence of declarations unless
4327
         --  there is a missing subprogram body, see section on handling
4328
         --  semicolon in place of IS. We only treat the begin as satisfying
4329
         --  the subprogram declaration if it falls in the expected column
4330
         --  or to its right.
4331
 
4332
         when Tok_Begin =>
4333
            if SIS_Entry_Active and then Start_Column >= SIS_Ecol then
4334
 
4335
               --  Here we have the case where a BEGIN is encountered during
4336
               --  declarations in a declarative part, or at the outer level,
4337
               --  and there is a subprogram declaration outstanding for which
4338
               --  no body has been supplied. This is the case where we assume
4339
               --  that the semicolon in the subprogram declaration should
4340
               --  really have been is. The active SIS entry describes the
4341
               --  subprogram declaration. On return the declaration has been
4342
               --  modified to become a body.
4343
 
4344
               declare
4345
                  Specification_Node : Node_Id;
4346
                  Decl_Node          : Node_Id;
4347
                  Body_Node          : Node_Id;
4348
 
4349
               begin
4350
                  --  First issue the error message. If we had a missing
4351
                  --  semicolon in the declaration, then change the message
4352
                  --  to <missing "is">
4353
 
4354
                  if SIS_Missing_Semicolon_Message /= No_Error_Msg then
4355
                     Change_Error_Text     -- Replace: "missing "";"" "
4356
                       (SIS_Missing_Semicolon_Message, "missing ""is""");
4357
 
4358
                  --  Otherwise we saved the semicolon position, so complain
4359
 
4360
                  else
4361
                     Error_Msg -- CODEFIX
4362
                       ("|"";"" should be IS", SIS_Semicolon_Sloc);
4363
                  end if;
4364
 
4365
                  --  The next job is to fix up any declarations that occurred
4366
                  --  between the procedure header and the BEGIN. These got
4367
                  --  chained to the outer declarative region (immediately
4368
                  --  after the procedure declaration) and they should be
4369
                  --  chained to the subprogram itself, which is a body
4370
                  --  rather than a spec.
4371
 
4372
                  Specification_Node := Specification (SIS_Declaration_Node);
4373
                  Change_Node (SIS_Declaration_Node, N_Subprogram_Body);
4374
                  Body_Node := SIS_Declaration_Node;
4375
                  Set_Specification (Body_Node, Specification_Node);
4376
                  Set_Declarations (Body_Node, New_List);
4377
 
4378
                  loop
4379
                     Decl_Node := Remove_Next (Body_Node);
4380
                     exit when Decl_Node = Empty;
4381
                     Append (Decl_Node, Declarations (Body_Node));
4382
                  end loop;
4383
 
4384
                  --  Now make the scope table entry for the Begin-End and
4385
                  --  scan it out
4386
 
4387
                  Push_Scope_Stack;
4388
                  Scope.Table (Scope.Last).Sloc := SIS_Sloc;
4389
                  Scope.Table (Scope.Last).Etyp := E_Name;
4390
                  Scope.Table (Scope.Last).Ecol := SIS_Ecol;
4391
                  Scope.Table (Scope.Last).Labl := SIS_Labl;
4392
                  Scope.Table (Scope.Last).Lreq := False;
4393
                  SIS_Entry_Active := False;
4394
                  Scan; -- past BEGIN
4395
                  Set_Handled_Statement_Sequence (Body_Node,
4396
                    P_Handled_Sequence_Of_Statements);
4397
                  End_Statements (Handled_Statement_Sequence (Body_Node));
4398
               end;
4399
 
4400
               Done := False;
4401
 
4402
            else
4403
               Done := True;
4404
            end if;
4405
 
4406
         --  Normally an END terminates the scan for basic declarative items.
4407
         --  The one exception is END RECORD, which is probably left over from
4408
         --  some other junk.
4409
 
4410
         when Tok_End =>
4411
            Save_Scan_State (Scan_State); -- at END
4412
            Scan; -- past END
4413
 
4414
            if Token = Tok_Record then
4415
               Error_Msg_SP ("no RECORD for this `end record`!");
4416
               Scan; -- past RECORD
4417
               TF_Semicolon;
4418
 
4419
            else
4420
               Restore_Scan_State (Scan_State); -- to END
4421
               Done := True;
4422
            end if;
4423
 
4424
         --  The following tokens which can only be the start of a statement
4425
         --  are considered to end a declarative part (i.e. we have a missing
4426
         --  BEGIN situation). We are fairly conservative in making this
4427
         --  judgment, because it is a real mess to go into statement mode
4428
         --  prematurely in response to a junk declaration.
4429
 
4430
         when Tok_Abort     |
4431
              Tok_Accept    |
4432
              Tok_Declare   |
4433
              Tok_Delay     |
4434
              Tok_Exit      |
4435
              Tok_Goto      |
4436
              Tok_If        |
4437
              Tok_Loop      |
4438
              Tok_Null      |
4439
              Tok_Requeue   |
4440
              Tok_Select    |
4441
              Tok_While     =>
4442
 
4443
            --  But before we decide that it's a statement, let's check for
4444
            --  a reserved word misused as an identifier.
4445
 
4446
            if Is_Reserved_Identifier then
4447
               Save_Scan_State (Scan_State);
4448
               Scan; -- past the token
4449
 
4450
               --  If reserved identifier not followed by colon or comma, then
4451
               --  this is most likely an assignment statement to the bad id.
4452
 
4453
               if Token /= Tok_Colon and then Token /= Tok_Comma then
4454
                  Restore_Scan_State (Scan_State);
4455
                  Statement_When_Declaration_Expected (Decls, Done, In_Spec);
4456
                  return;
4457
 
4458
               --  Otherwise we have a declaration of the bad id
4459
 
4460
               else
4461
                  Restore_Scan_State (Scan_State);
4462
                  Scan_Reserved_Identifier (Force_Msg => True);
4463
                  P_Identifier_Declarations (Decls, Done, In_Spec);
4464
               end if;
4465
 
4466
            --  If not reserved identifier, then it's definitely a statement
4467
 
4468
            else
4469
               Statement_When_Declaration_Expected (Decls, Done, In_Spec);
4470
               return;
4471
            end if;
4472
 
4473
         --  The token RETURN may well also signal a missing BEGIN situation,
4474
         --  however, we never let it end the declarative part, because it may
4475
         --  also be part of a half-baked function declaration.
4476
 
4477
         when Tok_Return =>
4478
            Error_Msg_SC ("misplaced RETURN statement");
4479
            raise Error_Resync;
4480
 
4481
         --  PRIVATE definitely terminates the declarations in a spec,
4482
         --  and is an error in a body.
4483
 
4484
         when Tok_Private =>
4485
            if In_Spec then
4486
               Done := True;
4487
            else
4488
               Error_Msg_SC ("PRIVATE not allowed in body");
4489
               Scan; -- past PRIVATE
4490
            end if;
4491
 
4492
         --  An end of file definitely terminates the declarations!
4493
 
4494
         when Tok_EOF =>
4495
            Done := True;
4496
 
4497
         --  The remaining tokens do not end the scan, but cannot start a
4498
         --  valid declaration, so we signal an error and resynchronize.
4499
         --  But first check for misuse of a reserved identifier.
4500
 
4501
         when others =>
4502
 
4503
            --  Here we check for a reserved identifier
4504
 
4505
            if Is_Reserved_Identifier then
4506
               Save_Scan_State (Scan_State);
4507
               Scan; -- past the token
4508
 
4509
               if Token /= Tok_Colon and then Token /= Tok_Comma then
4510
                  Restore_Scan_State (Scan_State);
4511
                  Set_Declaration_Expected;
4512
                  raise Error_Resync;
4513
               else
4514
                  Restore_Scan_State (Scan_State);
4515
                  Scan_Reserved_Identifier (Force_Msg => True);
4516
                  Check_Bad_Layout;
4517
                  P_Identifier_Declarations (Decls, Done, In_Spec);
4518
               end if;
4519
 
4520
            else
4521
               Set_Declaration_Expected;
4522
               raise Error_Resync;
4523
            end if;
4524
      end case;
4525
 
4526
   --  To resynchronize after an error, we scan to the next semicolon and
4527
   --  return with Done = False, indicating that there may still be more
4528
   --  valid declarations to come.
4529
 
4530
   exception
4531
      when Error_Resync =>
4532
         Resync_Past_Semicolon;
4533
         Done := False;
4534
   end P_Declarative_Items;
4535
 
4536
   ----------------------------------
4537
   -- 3.11  Basic Declarative Item --
4538
   ----------------------------------
4539
 
4540
   --  BASIC_DECLARATIVE_ITEM ::=
4541
   --    BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
4542
 
4543
   --  Scan zero or more basic declarative items
4544
 
4545
   --  Error recovery: cannot raise Error_Resync. If an error is detected, then
4546
   --  the scan pointer is repositioned past the next semicolon, and the scan
4547
   --  for declarative items continues.
4548
 
4549
   function P_Basic_Declarative_Items return List_Id is
4550
      Decl  : Node_Id;
4551
      Decls : List_Id;
4552
      Kind  : Node_Kind;
4553
      Done  : Boolean;
4554
 
4555
   begin
4556
      --  Indicate no bad declarations detected yet in the current context:
4557
      --  visible or private declarations of a package spec.
4558
 
4559
      Missing_Begin_Msg := No_Error_Msg;
4560
 
4561
      --  Get rid of active SIS entry from outer scope. This means we will
4562
      --  miss some nested cases, but it doesn't seem worth the effort. See
4563
      --  discussion in Par for further details
4564
 
4565
      SIS_Entry_Active := False;
4566
 
4567
      --  Loop to scan out declarations
4568
 
4569
      Decls := New_List;
4570
 
4571
      loop
4572
         P_Declarative_Items (Decls, Done, In_Spec => True);
4573
         exit when Done;
4574
      end loop;
4575
 
4576
      --  Get rid of active SIS entry. This is set only if we have scanned a
4577
      --  procedure declaration and have not found the body. We could give
4578
      --  an error message, but that really would be usurping the role of
4579
      --  semantic analysis (this really is a case of a missing body).
4580
 
4581
      SIS_Entry_Active := False;
4582
 
4583
      --  Test for assorted illegal declarations not diagnosed elsewhere
4584
 
4585
      Decl := First (Decls);
4586
 
4587
      while Present (Decl) loop
4588
         Kind := Nkind (Decl);
4589
 
4590
         --  Test for body scanned, not acceptable as basic decl item
4591
 
4592
         if Kind = N_Subprogram_Body or else
4593
            Kind = N_Package_Body or else
4594
            Kind = N_Task_Body or else
4595
            Kind = N_Protected_Body
4596
         then
4597
            Error_Msg ("proper body not allowed in package spec", Sloc (Decl));
4598
 
4599
         --  Test for body stub scanned, not acceptable as basic decl item
4600
 
4601
         elsif Kind in N_Body_Stub then
4602
            Error_Msg ("body stub not allowed in package spec", Sloc (Decl));
4603
 
4604
         elsif Kind = N_Assignment_Statement then
4605
            Error_Msg
4606
              ("assignment statement not allowed in package spec",
4607
                 Sloc (Decl));
4608
         end if;
4609
 
4610
         Next (Decl);
4611
      end loop;
4612
 
4613
      return Decls;
4614
   end P_Basic_Declarative_Items;
4615
 
4616
   ----------------
4617
   -- 3.11  Body --
4618
   ----------------
4619
 
4620
   --  For proper body, see below
4621
   --  For body stub, see 10.1.3
4622
 
4623
   -----------------------
4624
   -- 3.11  Proper Body --
4625
   -----------------------
4626
 
4627
   --  Subprogram body is parsed by P_Subprogram (6.1)
4628
   --  Package body is parsed by P_Package (7.1)
4629
   --  Task body is parsed by P_Task (9.1)
4630
   --  Protected body is parsed by P_Protected (9.4)
4631
 
4632
   ------------------------------
4633
   -- Set_Declaration_Expected --
4634
   ------------------------------
4635
 
4636
   procedure Set_Declaration_Expected is
4637
   begin
4638
      Error_Msg_SC ("declaration expected");
4639
 
4640
      if Missing_Begin_Msg = No_Error_Msg then
4641
         Missing_Begin_Msg := Get_Msg_Id;
4642
      end if;
4643
   end Set_Declaration_Expected;
4644
 
4645
   ----------------------
4646
   -- Skip_Declaration --
4647
   ----------------------
4648
 
4649
   procedure Skip_Declaration (S : List_Id) is
4650
      Dummy_Done : Boolean;
4651
      pragma Warnings (Off, Dummy_Done);
4652
   begin
4653
      P_Declarative_Items (S, Dummy_Done, False);
4654
   end Skip_Declaration;
4655
 
4656
   -----------------------------------------
4657
   -- Statement_When_Declaration_Expected --
4658
   -----------------------------------------
4659
 
4660
   procedure Statement_When_Declaration_Expected
4661
     (Decls   : List_Id;
4662
      Done    : out Boolean;
4663
      In_Spec : Boolean)
4664
   is
4665
   begin
4666
      --  Case of second occurrence of statement in one declaration sequence
4667
 
4668
      if Missing_Begin_Msg /= No_Error_Msg then
4669
 
4670
         --  In the procedure spec case, just ignore it, we only give one
4671
         --  message for the first occurrence, since otherwise we may get
4672
         --  horrible cascading if BODY was missing in the header line.
4673
 
4674
         if In_Spec then
4675
            null;
4676
 
4677
         --  In the declarative part case, take a second statement as a sure
4678
         --  sign that we really have a missing BEGIN, and end the declarative
4679
         --  part now. Note that the caller will fix up the first message to
4680
         --  say "missing BEGIN" so that's how the error will be signalled.
4681
 
4682
         else
4683
            Done := True;
4684
            return;
4685
         end if;
4686
 
4687
      --  Case of first occurrence of unexpected statement
4688
 
4689
      else
4690
         --  If we are in a package spec, then give message of statement
4691
         --  not allowed in package spec. This message never gets changed.
4692
 
4693
         if In_Spec then
4694
            Error_Msg_SC ("statement not allowed in package spec");
4695
 
4696
         --  If in declarative part, then we give the message complaining
4697
         --  about finding a statement when a declaration is expected. This
4698
         --  gets changed to a complaint about a missing BEGIN if we later
4699
         --  find that no BEGIN is present.
4700
 
4701
         else
4702
            Error_Msg_SC ("statement not allowed in declarative part");
4703
         end if;
4704
 
4705
         --  Capture message Id. This is used for two purposes, first to
4706
         --  stop multiple messages, see test above, and second, to allow
4707
         --  the replacement of the message in the declarative part case.
4708
 
4709
         Missing_Begin_Msg := Get_Msg_Id;
4710
      end if;
4711
 
4712
      --  In all cases except the case in which we decided to terminate the
4713
      --  declaration sequence on a second error, we scan out the statement
4714
      --  and append it to the list of declarations (note that the semantics
4715
      --  can handle statements in a declaration list so if we proceed to
4716
      --  call the semantic phase, all will be (reasonably) well!
4717
 
4718
      Append_List_To (Decls, P_Sequence_Of_Statements (SS_Unco));
4719
 
4720
      --  Done is set to False, since we want to continue the scan of
4721
      --  declarations, hoping that this statement was a temporary glitch.
4722
      --  If we indeed are now in the statement part (i.e. this was a missing
4723
      --  BEGIN, then it's not terrible, we will simply keep calling this
4724
      --  procedure to process the statements one by one, and then finally
4725
      --  hit the missing BEGIN, which will clean up the error message.
4726
 
4727
      Done := False;
4728
   end Statement_When_Declaration_Expected;
4729
 
4730
end Ch3;

powered by: WebSVN 2.1.0

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