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