1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 pragma Style_Checks (All_Checks);
27 -- Turn off subprogram body ordering check. Subprograms are in order
28 -- by RM section rather than alphabetical.
30 with Sinfo.CN; use Sinfo.CN;
40 -----------------------
41 -- Local Subprograms --
42 -----------------------
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;
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:
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}
73 -- RESTRICTED_RELATION ::=
74 -- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION]
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.
80 procedure P_Declarative_Items
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.
94 procedure P_Identifier_Declarations
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.
102 procedure Statement_When_Declaration_Expected
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.
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.
115 ---------------------------------
116 -- Check_Restricted_Expression --
117 ---------------------------------
119 procedure Check_Restricted_Expression (N : Node_Id) is
121 if Nkind_In (N, N_Op_And, N_Op_Or, N_Op_Xor, N_And_Then, N_Or_Else) then
122 Check_Restricted_Expression (Left_Opnd (N));
123 Check_Restricted_Expression (Right_Opnd (N));
125 elsif Nkind_In (N, N_In, N_Not_In)
126 and then Paren_Count (N) = 0
129 ("|this expression must be parenthesized!", N);
131 ("\|since extensions (and set notation) are allowed", N);
133 end Check_Restricted_Expression;
139 function Init_Expr_Opt (P : Boolean := False) return Node_Id is
141 -- For colon, assume it means := unless it is at the end of
142 -- a line, in which case guess that it means a semicolon.
144 if Token = Tok_Colon then
145 if Token_Is_At_End_Of_Line then
150 -- Here if := or something that we will take as equivalent
152 elsif Token = Tok_Colon_Equal
153 or else Token = Tok_Equal
154 or else Token = Tok_Is
158 -- Another possibility. If we have a literal followed by a semicolon,
159 -- we assume that we have a missing colon-equal.
161 elsif Token in Token_Class_Literal then
163 Scan_State : Saved_Scan_State;
166 Save_Scan_State (Scan_State);
167 Scan; -- past literal or identifier
169 if Token = Tok_Semicolon then
170 Restore_Scan_State (Scan_State);
172 Restore_Scan_State (Scan_State);
177 -- Otherwise we definitely have no initialization expression
183 -- Merge here if we have an initialization expression
190 return P_Expression_No_Right_Paren;
194 ----------------------------
195 -- 3.1 Basic Declaration --
196 ----------------------------
198 -- Parsed by P_Basic_Declarative_Items (3.9)
200 ------------------------------
201 -- 3.1 Defining Identifier --
202 ------------------------------
204 -- DEFINING_IDENTIFIER ::= IDENTIFIER
206 -- Error recovery: can raise Error_Resync
208 function P_Defining_Identifier (C : Id_Check := None) return Node_Id is
209 Ident_Node : Node_Id;
212 -- Scan out the identifier. Note that this code is essentially identical
213 -- to P_Identifier, except that in the call to Scan_Reserved_Identifier
214 -- we set Force_Msg to True, since we want at least one message for each
215 -- separate declaration (but not use) of a reserved identifier.
217 if Token = Tok_Identifier then
219 -- Ada 2005 (AI-284): Compiling in Ada95 mode we warn that INTERFACE,
220 -- OVERRIDING, and SYNCHRONIZED are new reserved words. Note that
221 -- in the case where these keywords are misused in Ada 95 mode,
222 -- this routine will generally not be called at all.
224 if Ada_Version = Ada_95
225 and then Warn_On_Ada_2005_Compatibility
227 if Token_Name = Name_Overriding
228 or else Token_Name = Name_Synchronized
229 or else (Token_Name = Name_Interface
230 and then Prev_Token /= Tok_Pragma)
232 Error_Msg_N ("& is a reserved word in Ada 2005?", Token_Node);
236 -- If we have a reserved identifier, manufacture an identifier with
237 -- a corresponding name after posting an appropriate error message
239 elsif Is_Reserved_Identifier (C) then
240 Scan_Reserved_Identifier (Force_Msg => True);
242 -- Otherwise we have junk that cannot be interpreted as an identifier
245 T_Identifier; -- to give message
249 Ident_Node := Token_Node;
250 Scan; -- past the reserved identifier
252 -- If we already have a defining identifier, clean it out and make
253 -- a new clean identifier. This situation arises in some error cases
254 -- and we need to fix it.
256 if Nkind (Ident_Node) = N_Defining_Identifier then
258 Make_Identifier (Sloc (Ident_Node),
259 Chars => Chars (Ident_Node));
262 -- Change identifier to defining identifier if not in error
264 if Ident_Node /= Error then
265 Change_Identifier_To_Defining_Identifier (Ident_Node);
269 end P_Defining_Identifier;
271 -----------------------------
272 -- 3.2.1 Type Declaration --
273 -----------------------------
275 -- TYPE_DECLARATION ::=
276 -- FULL_TYPE_DECLARATION
277 -- | INCOMPLETE_TYPE_DECLARATION
278 -- | PRIVATE_TYPE_DECLARATION
279 -- | PRIVATE_EXTENSION_DECLARATION
281 -- FULL_TYPE_DECLARATION ::=
282 -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION;
283 -- | CONCURRENT_TYPE_DECLARATION
285 -- INCOMPLETE_TYPE_DECLARATION ::=
286 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [is tagged];
288 -- PRIVATE_TYPE_DECLARATION ::=
289 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
290 -- is [abstract] [tagged] [limited] private;
292 -- PRIVATE_EXTENSION_DECLARATION ::=
293 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
294 -- [abstract] [limited | synchronized]
295 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
298 -- TYPE_DEFINITION ::=
299 -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
300 -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION
301 -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION
302 -- | DERIVED_TYPE_DEFINITION | INTERFACE_TYPE_DEFINITION
304 -- INTEGER_TYPE_DEFINITION ::=
305 -- SIGNED_INTEGER_TYPE_DEFINITION
306 -- MODULAR_TYPE_DEFINITION
308 -- INTERFACE_TYPE_DEFINITION ::=
309 -- [limited | task | protected | synchronized ] interface
310 -- [and INTERFACE_LIST]
312 -- Error recovery: can raise Error_Resync
314 -- Note: The processing for full type declaration, incomplete type
315 -- declaration, private type declaration and type definition is
316 -- included in this function. The processing for concurrent type
317 -- declarations is NOT here, but rather in chapter 9 (i.e. this
318 -- function handles only declarations starting with TYPE).
320 function P_Type_Declaration return Node_Id is
321 Abstract_Present : Boolean := False;
322 Abstract_Loc : Source_Ptr := No_Location;
324 Discr_List : List_Id;
325 Discr_Sloc : Source_Ptr;
327 Ident_Node : Node_Id;
328 Is_Derived_Iface : Boolean := False;
329 Type_Loc : Source_Ptr;
330 Type_Start_Col : Column_Number;
331 Unknown_Dis : Boolean;
333 Typedef_Node : Node_Id;
334 -- Normally holds type definition, except in the case of a private
335 -- extension declaration, in which case it holds the declaration itself
338 Type_Loc := Token_Ptr;
339 Type_Start_Col := Start_Column;
341 -- If we have TYPE, then proceed ahead and scan identifier
343 if Token = Tok_Type then
344 Type_Token_Location := Type_Loc;
346 Ident_Node := P_Defining_Identifier (C_Is);
348 -- Otherwise this is an error case
352 Type_Token_Location := Type_Loc;
353 Ident_Node := P_Defining_Identifier (C_Is);
356 Discr_Sloc := Token_Ptr;
358 if P_Unknown_Discriminant_Part_Opt then
360 Discr_List := No_List;
362 Unknown_Dis := False;
363 Discr_List := P_Known_Discriminant_Part_Opt;
366 -- Incomplete type declaration. We complete the processing for this
367 -- case here and return the resulting incomplete type declaration node
369 if Token = Tok_Semicolon then
371 Decl_Node := New_Node (N_Incomplete_Type_Declaration, Type_Loc);
372 Set_Defining_Identifier (Decl_Node, Ident_Node);
373 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
374 Set_Discriminant_Specifications (Decl_Node, Discr_List);
381 -- Full type declaration or private type declaration, must have IS
383 if Token = Tok_Equal then
385 Scan; -- past = used in place of IS
387 elsif Token = Tok_Renames then
388 Error_Msg_SC ("RENAMES should be IS");
389 Scan; -- past RENAMES used in place of IS
395 -- First an error check, if we have two identifiers in a row, a likely
396 -- possibility is that the first of the identifiers is an incorrectly
399 if Token = Tok_Identifier then
401 SS : Saved_Scan_State;
405 Save_Scan_State (SS);
406 Scan; -- past initial identifier
407 I2 := (Token = Tok_Identifier);
408 Restore_Scan_State (SS);
412 (Bad_Spelling_Of (Tok_Abstract) or else
413 Bad_Spelling_Of (Tok_Access) or else
414 Bad_Spelling_Of (Tok_Aliased) or else
415 Bad_Spelling_Of (Tok_Constant))
422 -- Check for misuse of Ada 95 keyword abstract in Ada 83 mode
424 if Token_Name = Name_Abstract then
425 Check_95_Keyword (Tok_Abstract, Tok_Tagged);
426 Check_95_Keyword (Tok_Abstract, Tok_New);
429 -- Check cases of misuse of ABSTRACT
431 if Token = Tok_Abstract then
432 Abstract_Present := True;
433 Abstract_Loc := Token_Ptr;
434 Scan; -- past ABSTRACT
436 -- Ada 2005 (AI-419): AARM 3.4 (2/2)
438 if (Ada_Version < Ada_05 and then Token = Tok_Limited)
439 or else Token = Tok_Private
440 or else Token = Tok_Record
441 or else Token = Tok_Null
443 Error_Msg_AP ("TAGGED expected");
447 -- Check for misuse of Ada 95 keyword Tagged
449 if Token_Name = Name_Tagged then
450 Check_95_Keyword (Tok_Tagged, Tok_Private);
451 Check_95_Keyword (Tok_Tagged, Tok_Limited);
452 Check_95_Keyword (Tok_Tagged, Tok_Record);
455 -- Special check for misuse of Aliased
457 if Token = Tok_Aliased or else Token_Name = Name_Aliased then
458 Error_Msg_SC ("ALIASED not allowed in type definition");
459 Scan; -- past ALIASED
462 -- The following processing deals with either a private type declaration
463 -- or a full type declaration. In the private type case, we build the
464 -- N_Private_Type_Declaration node, setting its Tagged_Present and
465 -- Limited_Present flags, on encountering the Private keyword, and
466 -- leave Typedef_Node set to Empty. For the full type declaration
467 -- case, Typedef_Node gets set to the type definition.
469 Typedef_Node := Empty;
471 -- Switch on token following the IS. The loop normally runs once. It
472 -- only runs more than once if an error is detected, to try again after
473 -- detecting and fixing up the error.
479 Tok_Not => -- Ada 2005 (AI-231)
480 Typedef_Node := P_Access_Type_Definition;
485 Typedef_Node := P_Array_Type_Definition;
490 Typedef_Node := P_Fixed_Point_Definition;
495 Typedef_Node := P_Floating_Point_Definition;
502 when Tok_Integer_Literal =>
504 Typedef_Node := P_Signed_Integer_Type_Definition;
509 Typedef_Node := P_Record_Definition;
513 when Tok_Left_Paren =>
514 Typedef_Node := P_Enumeration_Type_Definition;
517 Make_Identifier (Token_Ptr,
518 Chars => Chars (Ident_Node));
519 Set_Comes_From_Source (End_Labl, False);
521 Set_End_Label (Typedef_Node, End_Labl);
526 Typedef_Node := P_Modular_Type_Definition;
531 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
533 if Nkind (Typedef_Node) = N_Derived_Type_Definition
534 and then Present (Record_Extension_Part (Typedef_Node))
537 Make_Identifier (Token_Ptr,
538 Chars => Chars (Ident_Node));
539 Set_Comes_From_Source (End_Labl, False);
542 (Record_Extension_Part (Typedef_Node), End_Labl);
549 Typedef_Node := P_Signed_Integer_Type_Definition;
554 Typedef_Node := P_Record_Definition;
557 Make_Identifier (Token_Ptr,
558 Chars => Chars (Ident_Node));
559 Set_Comes_From_Source (End_Labl, False);
561 Set_End_Label (Typedef_Node, End_Labl);
568 -- Ada 2005 (AI-326): If the words IS TAGGED appear, the type
569 -- is a tagged incomplete type.
571 if Ada_Version >= Ada_05
572 and then Token = Tok_Semicolon
577 New_Node (N_Incomplete_Type_Declaration, Type_Loc);
578 Set_Defining_Identifier (Decl_Node, Ident_Node);
579 Set_Tagged_Present (Decl_Node);
580 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
581 Set_Discriminant_Specifications (Decl_Node, Discr_List);
586 if Token = Tok_Abstract then
587 Error_Msg_SC -- CODEFIX
588 ("ABSTRACT must come before TAGGED");
589 Abstract_Present := True;
590 Abstract_Loc := Token_Ptr;
591 Scan; -- past ABSTRACT
594 if Token = Tok_Limited then
595 Scan; -- past LIMITED
597 -- TAGGED LIMITED PRIVATE case
599 if Token = Tok_Private then
601 New_Node (N_Private_Type_Declaration, Type_Loc);
602 Set_Tagged_Present (Decl_Node, True);
603 Set_Limited_Present (Decl_Node, True);
604 Scan; -- past PRIVATE
606 -- TAGGED LIMITED RECORD
609 Typedef_Node := P_Record_Definition;
610 Set_Tagged_Present (Typedef_Node, True);
611 Set_Limited_Present (Typedef_Node, True);
614 Make_Identifier (Token_Ptr,
615 Chars => Chars (Ident_Node));
616 Set_Comes_From_Source (End_Labl, False);
618 Set_End_Label (Typedef_Node, End_Labl);
624 if Token = Tok_Private then
626 New_Node (N_Private_Type_Declaration, Type_Loc);
627 Set_Tagged_Present (Decl_Node, True);
628 Scan; -- past PRIVATE
633 Typedef_Node := P_Record_Definition;
634 Set_Tagged_Present (Typedef_Node, True);
637 Make_Identifier (Token_Ptr,
638 Chars => Chars (Ident_Node));
639 Set_Comes_From_Source (End_Labl, False);
641 Set_End_Label (Typedef_Node, End_Labl);
649 Scan; -- past LIMITED
652 if Token = Tok_Tagged then
653 Error_Msg_SC -- CODEFIX
654 ("TAGGED must come before LIMITED");
657 elsif Token = Tok_Abstract then
658 Error_Msg_SC -- CODEFIX
659 ("ABSTRACT must come before LIMITED");
660 Scan; -- past ABSTRACT
667 -- LIMITED RECORD or LIMITED NULL RECORD
669 if Token = Tok_Record or else Token = Tok_Null then
670 if Ada_Version = Ada_83 then
672 ("(Ada 83) limited record declaration not allowed!");
674 -- In Ada2005, "abstract limited" can appear before "new",
675 -- but it cannot be part of an untagged record declaration.
677 elsif Abstract_Present
678 and then Prev_Token /= Tok_Tagged
680 Error_Msg_SP ("TAGGED expected");
683 Typedef_Node := P_Record_Definition;
684 Set_Limited_Present (Typedef_Node, True);
686 -- Ada 2005 (AI-251): LIMITED INTERFACE
688 -- If we are compiling in Ada 83 or Ada 95 mode, "interface"
689 -- is not a reserved word but we force its analysis to
690 -- generate the corresponding usage error.
692 elsif Token = Tok_Interface
693 or else (Token = Tok_Identifier
694 and then Chars (Token_Node) = Name_Interface)
697 P_Interface_Type_Definition (Abstract_Present);
698 Abstract_Present := True;
699 Set_Limited_Present (Typedef_Node);
701 if Nkind (Typedef_Node) = N_Derived_Type_Definition then
702 Is_Derived_Iface := True;
705 -- Ada 2005 (AI-419): LIMITED NEW
707 elsif Token = Tok_New then
708 if Ada_Version < Ada_05 then
710 ("LIMITED in derived type is an Ada 2005 extension");
712 ("\unit must be compiled with -gnat05 switch");
715 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
716 Set_Limited_Present (Typedef_Node);
718 if Nkind (Typedef_Node) = N_Derived_Type_Definition
719 and then Present (Record_Extension_Part (Typedef_Node))
722 Make_Identifier (Token_Ptr,
723 Chars => Chars (Ident_Node));
724 Set_Comes_From_Source (End_Labl, False);
727 (Record_Extension_Part (Typedef_Node), End_Labl);
730 -- LIMITED PRIVATE is the only remaining possibility here
733 Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
734 Set_Limited_Present (Decl_Node, True);
735 T_Private; -- past PRIVATE (or complain if not there!)
741 -- Here we have an identifier after the IS, which is certainly
742 -- wrong and which might be one of several different mistakes.
744 when Tok_Identifier =>
746 -- First case, if identifier is on same line, then probably we
747 -- have something like "type X is Integer .." and the best
748 -- diagnosis is a missing NEW. Note: the missing new message
749 -- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl.
751 if not Token_Is_At_Start_Of_Line then
752 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
755 -- If the identifier is at the start of the line, and is in the
756 -- same column as the type declaration itself then we consider
757 -- that we had a missing type definition on the previous line
759 elsif Start_Column <= Type_Start_Col then
760 Error_Msg_AP ("type definition expected");
761 Typedef_Node := Error;
763 -- If the identifier is at the start of the line, and is in
764 -- a column to the right of the type declaration line, then we
765 -- may have something like:
770 -- and the best diagnosis is a missing record keyword
773 Typedef_Node := P_Record_Definition;
779 -- Ada 2005 (AI-251): INTERFACE
781 when Tok_Interface =>
782 Typedef_Node := P_Interface_Type_Definition (Abstract_Present);
783 Abstract_Present := True;
788 Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
789 Scan; -- past PRIVATE
793 -- Ada 2005 (AI-345): Protected, synchronized or task interface
794 -- or Ada 2005 (AI-443): Synchronized private extension.
801 Saved_Token : constant Token_Type := Token;
804 Scan; -- past TASK, PROTECTED or SYNCHRONIZED
806 -- Synchronized private extension
808 if Token = Tok_New then
809 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
811 if Saved_Token = Tok_Synchronized then
812 if Nkind (Typedef_Node) =
813 N_Derived_Type_Definition
816 ("SYNCHRONIZED not allowed for record extension",
819 Set_Synchronized_Present (Typedef_Node);
823 Error_Msg_SC ("invalid kind of private extension");
829 if Token /= Tok_Interface then
830 Error_Msg_SC ("NEW or INTERFACE expected");
834 P_Interface_Type_Definition (Abstract_Present);
835 Abstract_Present := True;
839 Set_Task_Present (Typedef_Node);
841 when Tok_Protected =>
842 Set_Protected_Present (Typedef_Node);
844 when Tok_Synchronized =>
845 Set_Synchronized_Present (Typedef_Node);
848 pragma Assert (False);
857 -- Anything else is an error
860 if Bad_Spelling_Of (Tok_Access)
862 Bad_Spelling_Of (Tok_Array)
864 Bad_Spelling_Of (Tok_Delta)
866 Bad_Spelling_Of (Tok_Digits)
868 Bad_Spelling_Of (Tok_Limited)
870 Bad_Spelling_Of (Tok_Private)
872 Bad_Spelling_Of (Tok_Range)
874 Bad_Spelling_Of (Tok_Record)
876 Bad_Spelling_Of (Tok_Tagged)
881 Error_Msg_AP ("type definition expected");
888 -- For the private type declaration case, the private type declaration
889 -- node has been built, with the Tagged_Present and Limited_Present
890 -- flags set as needed, and Typedef_Node is left set to Empty.
892 if No (Typedef_Node) then
893 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
894 Set_Abstract_Present (Decl_Node, Abstract_Present);
896 -- For a private extension declaration, Typedef_Node contains the
897 -- N_Private_Extension_Declaration node, which we now complete. Note
898 -- that the private extension declaration, unlike a full type
899 -- declaration, does permit unknown discriminants.
901 elsif Nkind (Typedef_Node) = N_Private_Extension_Declaration then
902 Decl_Node := Typedef_Node;
903 Set_Sloc (Decl_Node, Type_Loc);
904 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
905 Set_Abstract_Present (Typedef_Node, Abstract_Present);
907 -- In the full type declaration case, Typedef_Node has the type
908 -- definition and here is where we build the full type declaration
909 -- node. This is also where we check for improper use of an unknown
910 -- discriminant part (not allowed for full type declaration).
913 if Nkind (Typedef_Node) = N_Record_Definition
914 or else (Nkind (Typedef_Node) = N_Derived_Type_Definition
915 and then Present (Record_Extension_Part (Typedef_Node)))
916 or else Is_Derived_Iface
918 Set_Abstract_Present (Typedef_Node, Abstract_Present);
920 elsif Abstract_Present then
921 Error_Msg ("ABSTRACT not allowed here, ignored", Abstract_Loc);
924 Decl_Node := New_Node (N_Full_Type_Declaration, Type_Loc);
925 Set_Type_Definition (Decl_Node, Typedef_Node);
929 ("Full type declaration cannot have unknown discriminants",
934 -- Remaining processing is common for all three cases
936 Set_Defining_Identifier (Decl_Node, Ident_Node);
937 Set_Discriminant_Specifications (Decl_Node, Discr_List);
939 end P_Type_Declaration;
941 ----------------------------------
942 -- 3.2.1 Full Type Declaration --
943 ----------------------------------
945 -- Parsed by P_Type_Declaration (3.2.1)
947 ----------------------------
948 -- 3.2.1 Type Definition --
949 ----------------------------
951 -- Parsed by P_Type_Declaration (3.2.1)
953 --------------------------------
954 -- 3.2.2 Subtype Declaration --
955 --------------------------------
957 -- SUBTYPE_DECLARATION ::=
958 -- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION;
960 -- The caller has checked that the initial token is SUBTYPE
962 -- Error recovery: can raise Error_Resync
964 function P_Subtype_Declaration return Node_Id is
966 Not_Null_Present : Boolean := False;
969 Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr);
970 Scan; -- past SUBTYPE
971 Set_Defining_Identifier (Decl_Node, P_Defining_Identifier (C_Is));
974 if Token = Tok_New then
975 Error_Msg_SC ("NEW ignored (only allowed in type declaration)");
979 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
980 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
982 Set_Subtype_Indication
983 (Decl_Node, P_Subtype_Indication (Not_Null_Present));
986 end P_Subtype_Declaration;
988 -------------------------------
989 -- 3.2.2 Subtype Indication --
990 -------------------------------
992 -- SUBTYPE_INDICATION ::=
993 -- [not null] SUBTYPE_MARK [CONSTRAINT]
995 -- Error recovery: can raise Error_Resync
997 function P_Null_Exclusion
998 (Allow_Anonymous_In_95 : Boolean := False) return Boolean
1000 Not_Loc : constant Source_Ptr := Token_Ptr;
1001 -- Source position of "not", if present
1004 if Token /= Tok_Not then
1010 if Token = Tok_Null then
1013 -- Ada 2005 (AI-441, AI-447): null_exclusion is illegal in Ada 95,
1014 -- except in the case of anonymous access types.
1016 -- Allow_Anonymous_In_95 will be True if we're parsing a formal
1017 -- parameter or discriminant, which are the only places where
1018 -- anonymous access types occur in Ada 95. "Formal : not null
1019 -- access ..." is legal in Ada 95, whereas "Formal : not null
1020 -- Named_Access_Type" is not.
1022 if Ada_Version >= Ada_05
1023 or else (Ada_Version >= Ada_95
1024 and then Allow_Anonymous_In_95
1025 and then Token = Tok_Access)
1031 ("`NOT NULL` access type is an Ada 2005 extension", Not_Loc);
1033 ("\unit should be compiled with -gnat05 switch", Not_Loc);
1037 Error_Msg_SP ("NULL expected");
1040 if Token = Tok_New then
1041 Error_Msg ("`NOT NULL` comes after NEW, not before", Not_Loc);
1046 end P_Null_Exclusion;
1048 function P_Subtype_Indication
1049 (Not_Null_Present : Boolean := False) return Node_Id
1051 Type_Node : Node_Id;
1054 if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
1055 Type_Node := P_Subtype_Mark;
1056 return P_Subtype_Indication (Type_Node, Not_Null_Present);
1059 -- Check for error of using record definition and treat it nicely,
1060 -- otherwise things are really messed up, so resynchronize.
1062 if Token = Tok_Record then
1063 Error_Msg_SC ("anonymous record definitions are not permitted");
1064 Discard_Junk_Node (P_Record_Definition);
1068 Error_Msg_AP ("subtype indication expected");
1072 end P_Subtype_Indication;
1074 -- The following function is identical except that it is called with
1075 -- the subtype mark already scanned out, and it scans out the constraint
1077 -- Error recovery: can raise Error_Resync
1079 function P_Subtype_Indication
1080 (Subtype_Mark : Node_Id;
1081 Not_Null_Present : Boolean := False) return Node_Id
1083 Indic_Node : Node_Id;
1084 Constr_Node : Node_Id;
1087 Constr_Node := P_Constraint_Opt;
1089 if No (Constr_Node) then
1090 return Subtype_Mark;
1092 if Not_Null_Present then
1093 Error_Msg_SP ("`NOT NULL` not allowed if constraint given");
1096 Indic_Node := New_Node (N_Subtype_Indication, Sloc (Subtype_Mark));
1097 Set_Subtype_Mark (Indic_Node, Check_Subtype_Mark (Subtype_Mark));
1098 Set_Constraint (Indic_Node, Constr_Node);
1101 end P_Subtype_Indication;
1103 -------------------------
1104 -- 3.2.2 Subtype Mark --
1105 -------------------------
1107 -- SUBTYPE_MARK ::= subtype_NAME;
1109 -- Note: The subtype mark which appears after an IN or NOT IN
1110 -- operator is parsed by P_Range_Or_Subtype_Mark (3.5)
1112 -- Error recovery: cannot raise Error_Resync
1114 function P_Subtype_Mark return Node_Id is
1116 return P_Subtype_Mark_Resync;
1118 when Error_Resync =>
1122 -- This routine differs from P_Subtype_Mark in that it insists that an
1123 -- identifier be present, and if it is not, it raises Error_Resync.
1125 -- Error recovery: can raise Error_Resync
1127 function P_Subtype_Mark_Resync return Node_Id is
1128 Type_Node : Node_Id;
1131 if Token = Tok_Access then
1132 Error_Msg_SC ("anonymous access type definition not allowed here");
1133 Scan; -- past ACCESS
1136 if Token = Tok_Array then
1137 Error_Msg_SC ("anonymous array definition not allowed here");
1138 Discard_Junk_Node (P_Array_Type_Definition);
1142 Type_Node := P_Qualified_Simple_Name_Resync;
1144 -- Check for a subtype mark attribute. The only valid possibilities
1145 -- are 'CLASS and 'BASE. Anything else is a definite error. We may
1146 -- as well catch it here.
1148 if Token = Tok_Apostrophe then
1149 return P_Subtype_Mark_Attribute (Type_Node);
1154 end P_Subtype_Mark_Resync;
1156 -- The following function is called to scan out a subtype mark attribute.
1157 -- The caller has already scanned out the subtype mark, which is passed in
1158 -- as the argument, and has checked that the current token is apostrophe.
1160 -- Only a special subclass of attributes, called type attributes
1161 -- (see Snames package) are allowed in this syntactic position.
1163 -- Note: if the apostrophe is followed by other than an identifier, then
1164 -- the input expression is returned unchanged, and the scan pointer is
1165 -- left pointing to the apostrophe.
1167 -- Error recovery: can raise Error_Resync
1169 function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id is
1170 Attr_Node : Node_Id := Empty;
1171 Scan_State : Saved_Scan_State;
1175 Prefix := Check_Subtype_Mark (Type_Node);
1177 if Prefix = Error then
1181 -- Loop through attributes appearing (more than one can appear as for
1182 -- for example in X'Base'Class). We are at an apostrophe on entry to
1183 -- this loop, and it runs once for each attribute parsed, with
1184 -- Prefix being the current possible prefix if it is an attribute.
1187 Save_Scan_State (Scan_State); -- at Apostrophe
1188 Scan; -- past apostrophe
1190 if Token /= Tok_Identifier then
1191 Restore_Scan_State (Scan_State); -- to apostrophe
1192 return Prefix; -- no attribute after all
1194 elsif not Is_Type_Attribute_Name (Token_Name) then
1196 ("attribute & may not be used in a subtype mark", Token_Node);
1201 Make_Attribute_Reference (Prev_Token_Ptr,
1203 Attribute_Name => Token_Name);
1204 Scan; -- past type attribute identifier
1207 exit when Token /= Tok_Apostrophe;
1208 Prefix := Attr_Node;
1211 -- Fall through here after scanning type attribute
1214 end P_Subtype_Mark_Attribute;
1216 -----------------------
1217 -- 3.2.2 Constraint --
1218 -----------------------
1220 -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
1222 -- SCALAR_CONSTRAINT ::=
1223 -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
1225 -- COMPOSITE_CONSTRAINT ::=
1226 -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
1228 -- If no constraint is present, this function returns Empty
1230 -- Error recovery: can raise Error_Resync
1232 function P_Constraint_Opt return Node_Id is
1234 if Token = Tok_Range
1235 or else Bad_Spelling_Of (Tok_Range)
1237 return P_Range_Constraint;
1239 elsif Token = Tok_Digits
1240 or else Bad_Spelling_Of (Tok_Digits)
1242 return P_Digits_Constraint;
1244 elsif Token = Tok_Delta
1245 or else Bad_Spelling_Of (Tok_Delta)
1247 return P_Delta_Constraint;
1249 elsif Token = Tok_Left_Paren then
1250 return P_Index_Or_Discriminant_Constraint;
1252 elsif Token = Tok_In then
1254 return P_Constraint_Opt;
1259 end P_Constraint_Opt;
1261 ------------------------------
1262 -- 3.2.2 Scalar Constraint --
1263 ------------------------------
1265 -- Parsed by P_Constraint_Opt (3.2.2)
1267 ---------------------------------
1268 -- 3.2.2 Composite Constraint --
1269 ---------------------------------
1271 -- Parsed by P_Constraint_Opt (3.2.2)
1273 --------------------------------------------------------
1274 -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) --
1275 --------------------------------------------------------
1277 -- This routine scans out a declaration starting with an identifier:
1279 -- OBJECT_DECLARATION ::=
1280 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1281 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1282 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1283 -- ACCESS_DEFINITION [:= EXPRESSION];
1284 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1285 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1287 -- NUMBER_DECLARATION ::=
1288 -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
1290 -- OBJECT_RENAMING_DECLARATION ::=
1291 -- DEFINING_IDENTIFIER :
1292 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
1293 -- | DEFINING_IDENTIFIER :
1294 -- ACCESS_DEFINITION renames object_NAME;
1296 -- EXCEPTION_RENAMING_DECLARATION ::=
1297 -- DEFINING_IDENTIFIER : exception renames exception_NAME;
1299 -- EXCEPTION_DECLARATION ::=
1300 -- DEFINING_IDENTIFIER_LIST : exception;
1302 -- Note that the ALIASED indication in an object declaration is
1303 -- marked by a flag in the parent node.
1305 -- The caller has checked that the initial token is an identifier
1307 -- The value returned is a list of declarations, one for each identifier
1308 -- in the list (as described in Sinfo, we always split up multiple
1309 -- declarations into the equivalent sequence of single declarations
1310 -- using the More_Ids and Prev_Ids flags to preserve the source).
1312 -- If the identifier turns out to be a probable statement rather than
1313 -- an identifier, then the scan is left pointing to the identifier and
1314 -- No_List is returned.
1316 -- Error recovery: can raise Error_Resync
1318 procedure P_Identifier_Declarations
1324 Decl_Node : Node_Id;
1325 Type_Node : Node_Id;
1326 Ident_Sloc : Source_Ptr;
1327 Scan_State : Saved_Scan_State;
1328 List_OK : Boolean := True;
1330 Init_Expr : Node_Id;
1331 Init_Loc : Source_Ptr;
1332 Con_Loc : Source_Ptr;
1333 Not_Null_Present : Boolean := False;
1335 Idents : array (Int range 1 .. 4096) of Entity_Id;
1336 -- Used to save identifiers in the identifier list. The upper bound
1337 -- of 4096 is expected to be infinite in practice, and we do not even
1338 -- bother to check if this upper bound is exceeded.
1340 Num_Idents : Nat := 1;
1341 -- Number of identifiers stored in Idents
1344 -- This procedure is called in renames cases to make sure that we do
1345 -- not have more than one identifier. If we do have more than one
1346 -- then an error message is issued (and the declaration is split into
1347 -- multiple declarations)
1349 function Token_Is_Renames return Boolean;
1350 -- Checks if current token is RENAMES, and if so, scans past it and
1351 -- returns True, otherwise returns False. Includes checking for some
1352 -- common error cases.
1358 procedure No_List is
1360 if Num_Idents > 1 then
1361 Error_Msg ("identifier list not allowed for RENAMES",
1368 ----------------------
1369 -- Token_Is_Renames --
1370 ----------------------
1372 function Token_Is_Renames return Boolean is
1373 At_Colon : Saved_Scan_State;
1376 if Token = Tok_Colon then
1377 Save_Scan_State (At_Colon);
1379 Check_Misspelling_Of (Tok_Renames);
1381 if Token = Tok_Renames then
1382 Error_Msg_SP ("|extra "":"" ignored");
1383 Scan; -- past RENAMES
1386 Restore_Scan_State (At_Colon);
1391 Check_Misspelling_Of (Tok_Renames);
1393 if Token = Tok_Renames then
1394 Scan; -- past RENAMES
1400 end Token_Is_Renames;
1402 -- Start of processing for P_Identifier_Declarations
1405 Ident_Sloc := Token_Ptr;
1406 Save_Scan_State (Scan_State); -- at first identifier
1407 Idents (1) := P_Defining_Identifier (C_Comma_Colon);
1409 -- If we have a colon after the identifier, then we can assume that
1410 -- this is in fact a valid identifier declaration and can steam ahead.
1412 if Token = Tok_Colon then
1415 -- If we have a comma, then scan out the list of identifiers
1417 elsif Token = Tok_Comma then
1418 while Comma_Present loop
1419 Num_Idents := Num_Idents + 1;
1420 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
1423 Save_Scan_State (Scan_State); -- at colon
1426 -- If we have identifier followed by := then we assume that what is
1427 -- really meant is an assignment statement. The assignment statement
1428 -- is scanned out and added to the list of declarations. An exception
1429 -- occurs if the := is followed by the keyword constant, in which case
1430 -- we assume it was meant to be a colon.
1432 elsif Token = Tok_Colon_Equal then
1435 if Token = Tok_Constant then
1436 Error_Msg_SP ("colon expected");
1439 Restore_Scan_State (Scan_State);
1440 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
1444 -- If we have an IS keyword, then assume the TYPE keyword was missing
1446 elsif Token = Tok_Is then
1447 Restore_Scan_State (Scan_State);
1448 Append_To (Decls, P_Type_Declaration);
1452 -- Otherwise we have an error situation
1455 Restore_Scan_State (Scan_State);
1457 -- First case is possible misuse of PROTECTED in Ada 83 mode. If
1458 -- so, fix the keyword and return to scan the protected declaration.
1460 if Token_Name = Name_Protected then
1461 Check_95_Keyword (Tok_Protected, Tok_Identifier);
1462 Check_95_Keyword (Tok_Protected, Tok_Type);
1463 Check_95_Keyword (Tok_Protected, Tok_Body);
1465 if Token = Tok_Protected then
1470 -- Check misspelling possibilities. If so, correct the misspelling
1471 -- and return to scan out the resulting declaration.
1473 elsif Bad_Spelling_Of (Tok_Function)
1474 or else Bad_Spelling_Of (Tok_Procedure)
1475 or else Bad_Spelling_Of (Tok_Package)
1476 or else Bad_Spelling_Of (Tok_Pragma)
1477 or else Bad_Spelling_Of (Tok_Protected)
1478 or else Bad_Spelling_Of (Tok_Generic)
1479 or else Bad_Spelling_Of (Tok_Subtype)
1480 or else Bad_Spelling_Of (Tok_Type)
1481 or else Bad_Spelling_Of (Tok_Task)
1482 or else Bad_Spelling_Of (Tok_Use)
1483 or else Bad_Spelling_Of (Tok_For)
1488 -- Otherwise we definitely have an ordinary identifier with a junk
1489 -- token after it. Just complain that we expect a declaration, and
1490 -- skip to a semicolon
1493 Set_Declaration_Expected;
1494 Resync_Past_Semicolon;
1500 -- Come here with an identifier list and colon scanned out. We now
1501 -- build the nodes for the declarative items. One node is built for
1502 -- each identifier in the list, with the type information being
1503 -- repeated by rescanning the appropriate section of source.
1505 -- First an error check, if we have two identifiers in a row, a likely
1506 -- possibility is that the first of the identifiers is an incorrectly
1509 if Token = Tok_Identifier then
1511 SS : Saved_Scan_State;
1515 Save_Scan_State (SS);
1516 Scan; -- past initial identifier
1517 I2 := (Token = Tok_Identifier);
1518 Restore_Scan_State (SS);
1522 (Bad_Spelling_Of (Tok_Access) or else
1523 Bad_Spelling_Of (Tok_Aliased) or else
1524 Bad_Spelling_Of (Tok_Constant))
1531 -- Loop through identifiers
1536 -- Check for some cases of misused Ada 95 keywords
1538 if Token_Name = Name_Aliased then
1539 Check_95_Keyword (Tok_Aliased, Tok_Array);
1540 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
1541 Check_95_Keyword (Tok_Aliased, Tok_Constant);
1546 if Token = Tok_Constant then
1547 Con_Loc := Token_Ptr;
1548 Scan; -- past CONSTANT
1550 -- Number declaration, initialization required
1552 Init_Expr := Init_Expr_Opt;
1554 if Present (Init_Expr) then
1555 if Not_Null_Present then
1557 ("`NOT NULL` not allowed in numeric expression");
1560 Decl_Node := New_Node (N_Number_Declaration, Ident_Sloc);
1561 Set_Expression (Decl_Node, Init_Expr);
1563 -- Constant object declaration
1566 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1567 Set_Constant_Present (Decl_Node, True);
1569 if Token_Name = Name_Aliased then
1570 Check_95_Keyword (Tok_Aliased, Tok_Array);
1571 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
1574 if Token = Tok_Aliased then
1575 Error_Msg_SC -- CODEFIX
1576 ("ALIASED should be before CONSTANT");
1577 Scan; -- past ALIASED
1578 Set_Aliased_Present (Decl_Node, True);
1581 if Token = Tok_Array then
1582 Set_Object_Definition
1583 (Decl_Node, P_Array_Type_Definition);
1586 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1587 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1589 if Token = Tok_Access then
1590 if Ada_Version < Ada_05 then
1592 ("generalized use of anonymous access types " &
1593 "is an Ada 2005 extension");
1595 ("\unit must be compiled with -gnat05 switch");
1598 Set_Object_Definition
1599 (Decl_Node, P_Access_Definition (Not_Null_Present));
1601 Set_Object_Definition
1602 (Decl_Node, P_Subtype_Indication (Not_Null_Present));
1606 if Token = Tok_Renames then
1608 ("CONSTANT not permitted in renaming declaration",
1610 Scan; -- Past renames
1611 Discard_Junk_Node (P_Name);
1617 elsif Token = Tok_Exception then
1618 Scan; -- past EXCEPTION
1620 if Token_Is_Renames then
1623 New_Node (N_Exception_Renaming_Declaration, Ident_Sloc);
1624 Set_Name (Decl_Node, P_Qualified_Simple_Name_Resync);
1627 Decl_Node := New_Node (N_Exception_Declaration, Prev_Token_Ptr);
1630 -- Aliased case (note that an object definition is required)
1632 elsif Token = Tok_Aliased then
1633 Scan; -- past ALIASED
1634 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1635 Set_Aliased_Present (Decl_Node, True);
1637 if Token = Tok_Constant then
1638 Scan; -- past CONSTANT
1639 Set_Constant_Present (Decl_Node, True);
1642 if Token = Tok_Array then
1643 Set_Object_Definition
1644 (Decl_Node, P_Array_Type_Definition);
1647 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1648 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1650 -- Access definition (AI-406) or subtype indication
1652 if Token = Tok_Access then
1653 if Ada_Version < Ada_05 then
1655 ("generalized use of anonymous access types " &
1656 "is an Ada 2005 extension");
1658 ("\unit must be compiled with -gnat05 switch");
1661 Set_Object_Definition
1662 (Decl_Node, P_Access_Definition (Not_Null_Present));
1664 Set_Object_Definition
1665 (Decl_Node, P_Subtype_Indication (Not_Null_Present));
1671 elsif Token = Tok_Array then
1672 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1673 Set_Object_Definition (Decl_Node, P_Array_Type_Definition);
1675 -- Ada 2005 (AI-254, AI-406)
1677 elsif Token = Tok_Not then
1679 -- OBJECT_DECLARATION ::=
1680 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1681 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1682 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1683 -- ACCESS_DEFINITION [:= EXPRESSION];
1685 -- OBJECT_RENAMING_DECLARATION ::=
1686 -- DEFINING_IDENTIFIER :
1687 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
1688 -- | DEFINING_IDENTIFIER :
1689 -- ACCESS_DEFINITION renames object_NAME;
1691 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/423)
1693 if Token = Tok_Access then
1694 if Ada_Version < Ada_05 then
1696 ("generalized use of anonymous access types " &
1697 "is an Ada 2005 extension");
1698 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1701 Acc_Node := P_Access_Definition (Not_Null_Present);
1703 if Token /= Tok_Renames then
1704 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1705 Set_Object_Definition (Decl_Node, Acc_Node);
1708 Scan; -- past renames
1711 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1712 Set_Access_Definition (Decl_Node, Acc_Node);
1713 Set_Name (Decl_Node, P_Name);
1717 Type_Node := P_Subtype_Mark;
1719 -- Object renaming declaration
1721 if Token_Is_Renames then
1722 if Ada_Version < Ada_05 then
1724 ("`NOT NULL` not allowed in object renaming");
1727 -- Ada 2005 (AI-423): Object renaming declaration with
1728 -- a null exclusion.
1733 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1734 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1735 Set_Subtype_Mark (Decl_Node, Type_Node);
1736 Set_Name (Decl_Node, P_Name);
1739 -- Object declaration
1742 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1743 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1744 Set_Object_Definition
1746 P_Subtype_Indication (Type_Node, Not_Null_Present));
1748 -- RENAMES at this point means that we had the combination
1749 -- of a constraint on the Type_Node and renames, which is
1752 if Token_Is_Renames then
1753 Error_Msg_N ("constraint not allowed in object renaming "
1755 Constraint (Object_Definition (Decl_Node)));
1761 -- Ada 2005 (AI-230): Access Definition case
1763 elsif Token = Tok_Access then
1764 if Ada_Version < Ada_05 then
1766 ("generalized use of anonymous access types " &
1767 "is an Ada 2005 extension");
1768 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1771 Acc_Node := P_Access_Definition (Null_Exclusion_Present => False);
1773 -- Object declaration with access definition, or renaming
1775 if Token /= Tok_Renames then
1776 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1777 Set_Object_Definition (Decl_Node, Acc_Node);
1780 Scan; -- past renames
1783 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1784 Set_Access_Definition (Decl_Node, Acc_Node);
1785 Set_Name (Decl_Node, P_Name);
1788 -- Subtype indication case
1791 Type_Node := P_Subtype_Mark;
1793 -- Object renaming declaration
1795 if Token_Is_Renames then
1798 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1799 Set_Subtype_Mark (Decl_Node, Type_Node);
1800 Set_Name (Decl_Node, P_Name);
1802 -- Object declaration
1805 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1806 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1807 Set_Object_Definition
1809 P_Subtype_Indication (Type_Node, Not_Null_Present));
1811 -- RENAMES at this point means that we had the combination of
1812 -- a constraint on the Type_Node and renames, which is illegal
1814 if Token_Is_Renames then
1816 ("constraint not allowed in object renaming declaration",
1817 Constraint (Object_Definition (Decl_Node)));
1823 -- Scan out initialization, allowed only for object declaration
1825 Init_Loc := Token_Ptr;
1826 Init_Expr := Init_Expr_Opt;
1828 if Present (Init_Expr) then
1829 if Nkind (Decl_Node) = N_Object_Declaration then
1830 Set_Expression (Decl_Node, Init_Expr);
1831 Set_Has_Init_Expression (Decl_Node);
1833 Error_Msg ("initialization not allowed here", Init_Loc);
1838 Set_Defining_Identifier (Decl_Node, Idents (Ident));
1841 if Ident < Num_Idents then
1842 Set_More_Ids (Decl_Node, True);
1846 Set_Prev_Ids (Decl_Node, True);
1850 Append (Decl_Node, Decls);
1851 exit Ident_Loop when Ident = Num_Idents;
1852 Restore_Scan_State (Scan_State);
1855 end loop Ident_Loop;
1858 end P_Identifier_Declarations;
1860 -------------------------------
1861 -- 3.3.1 Object Declaration --
1862 -------------------------------
1864 -- OBJECT DECLARATION ::=
1865 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1866 -- SUBTYPE_INDICATION [:= EXPRESSION];
1867 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1868 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1869 -- | SINGLE_TASK_DECLARATION
1870 -- | SINGLE_PROTECTED_DECLARATION
1872 -- Cases starting with TASK are parsed by P_Task (9.1)
1873 -- Cases starting with PROTECTED are parsed by P_Protected (9.4)
1874 -- All other cases are parsed by P_Identifier_Declarations (3.3)
1876 -------------------------------------
1877 -- 3.3.1 Defining Identifier List --
1878 -------------------------------------
1880 -- DEFINING_IDENTIFIER_LIST ::=
1881 -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
1883 -- Always parsed by the construct in which it appears. See special
1884 -- section on "Handling of Defining Identifier Lists" in this unit.
1886 -------------------------------
1887 -- 3.3.2 Number Declaration --
1888 -------------------------------
1890 -- Parsed by P_Identifier_Declarations (3.3)
1892 -------------------------------------------------------------------------
1893 -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) --
1894 -------------------------------------------------------------------------
1896 -- DERIVED_TYPE_DEFINITION ::=
1897 -- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
1898 -- [[and INTERFACE_LIST] RECORD_EXTENSION_PART]
1900 -- PRIVATE_EXTENSION_DECLARATION ::=
1901 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
1902 -- [abstract] [limited | synchronized]
1903 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
1906 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
1908 -- The caller has already scanned out the part up to the NEW, and Token
1909 -- either contains Tok_New (or ought to, if it doesn't this procedure
1910 -- will post an appropriate "NEW expected" message).
1912 -- Note: the caller is responsible for filling in the Sloc field of
1913 -- the returned node in the private extension declaration case as
1914 -- well as the stuff relating to the discriminant part.
1916 -- Error recovery: can raise Error_Resync;
1918 function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id is
1919 Typedef_Node : Node_Id;
1920 Typedecl_Node : Node_Id;
1921 Not_Null_Present : Boolean := False;
1924 Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
1926 if Ada_Version < Ada_05
1927 and then Token = Tok_Identifier
1928 and then Token_Name = Name_Interface
1931 ("abstract interface is an Ada 2005 extension");
1932 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1937 if Token = Tok_Abstract then
1938 Error_Msg_SC -- CODEFIX
1939 ("ABSTRACT must come before NEW, not after");
1943 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1944 Set_Null_Exclusion_Present (Typedef_Node, Not_Null_Present);
1945 Set_Subtype_Indication (Typedef_Node,
1946 P_Subtype_Indication (Not_Null_Present));
1948 -- Ada 2005 (AI-251): Deal with interfaces
1950 if Token = Tok_And then
1953 if Ada_Version < Ada_05 then
1955 ("abstract interface is an Ada 2005 extension");
1956 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1959 Set_Interface_List (Typedef_Node, New_List);
1962 Append (P_Qualified_Simple_Name, Interface_List (Typedef_Node));
1963 exit when Token /= Tok_And;
1967 if Token /= Tok_With then
1968 Error_Msg_SC ("WITH expected");
1973 -- Deal with record extension, note that we assume that a WITH is
1974 -- missing in the case of "type X is new Y record ..." or in the
1975 -- case of "type X is new Y null record".
1978 or else Token = Tok_Record
1979 or else Token = Tok_Null
1981 T_With; -- past WITH or give error message
1983 if Token = Tok_Limited then
1985 ("LIMITED keyword not allowed in private extension");
1986 Scan; -- ignore LIMITED
1989 -- Private extension declaration
1991 if Token = Tok_Private then
1992 Scan; -- past PRIVATE
1994 -- Throw away the type definition node and build the type
1995 -- declaration node. Note the caller must set the Sloc,
1996 -- Discriminant_Specifications, Unknown_Discriminants_Present,
1997 -- and Defined_Identifier fields in the returned node.
2000 Make_Private_Extension_Declaration (No_Location,
2001 Defining_Identifier => Empty,
2002 Subtype_Indication => Subtype_Indication (Typedef_Node),
2003 Abstract_Present => Abstract_Present (Typedef_Node),
2004 Interface_List => Interface_List (Typedef_Node));
2006 return Typedecl_Node;
2008 -- Derived type definition with record extension part
2011 Set_Record_Extension_Part (Typedef_Node, P_Record_Definition);
2012 return Typedef_Node;
2015 -- Derived type definition with no record extension part
2018 return Typedef_Node;
2020 end P_Derived_Type_Def_Or_Private_Ext_Decl;
2022 ---------------------------
2023 -- 3.5 Range Constraint --
2024 ---------------------------
2026 -- RANGE_CONSTRAINT ::= range RANGE
2028 -- The caller has checked that the initial token is RANGE
2030 -- Error recovery: cannot raise Error_Resync
2032 function P_Range_Constraint return Node_Id is
2033 Range_Node : Node_Id;
2036 Range_Node := New_Node (N_Range_Constraint, Token_Ptr);
2038 Set_Range_Expression (Range_Node, P_Range);
2040 end P_Range_Constraint;
2047 -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
2049 -- Note: the range that appears in a membership test is parsed by
2050 -- P_Range_Or_Subtype_Mark (3.5).
2052 -- Error recovery: cannot raise Error_Resync
2054 function P_Range return Node_Id is
2055 Expr_Node : Node_Id;
2056 Range_Node : Node_Id;
2059 Expr_Node := P_Simple_Expression_Or_Range_Attribute;
2061 if Expr_Form = EF_Range_Attr then
2064 elsif Token = Tok_Dot_Dot then
2065 Range_Node := New_Node (N_Range, Token_Ptr);
2066 Set_Low_Bound (Range_Node, Expr_Node);
2068 Expr_Node := P_Expression;
2069 Check_Simple_Expression (Expr_Node);
2070 Set_High_Bound (Range_Node, Expr_Node);
2073 -- Anything else is an error
2076 T_Dot_Dot; -- force missing .. message
2081 ----------------------------------
2082 -- 3.5 P_Range_Or_Subtype_Mark --
2083 ----------------------------------
2086 -- RANGE_ATTRIBUTE_REFERENCE
2087 -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
2089 -- This routine scans out the range or subtype mark that forms the right
2090 -- operand of a membership test (it is not used in any other contexts, and
2091 -- error messages are specialized with this knowledge in mind).
2093 -- Note: as documented in the Sinfo interface, although the syntax only
2094 -- allows a subtype mark, we in fact allow any simple expression to be
2095 -- returned from this routine. The semantics is responsible for issuing
2096 -- an appropriate message complaining if the argument is not a name.
2097 -- This simplifies the coding and error recovery processing in the
2098 -- parser, and in any case it is preferable not to consider this a
2099 -- syntax error and to continue with the semantic analysis.
2101 -- Error recovery: cannot raise Error_Resync
2103 function P_Range_Or_Subtype_Mark
2104 (Allow_Simple_Expression : Boolean := False) return Node_Id
2106 Expr_Node : Node_Id;
2107 Range_Node : Node_Id;
2108 Save_Loc : Source_Ptr;
2111 -- Start of processing for P_Range_Or_Subtype_Mark
2114 -- Save location of possible junk parentheses
2116 Save_Loc := Token_Ptr;
2118 -- Scan out either a simple expression or a range (this accepts more
2119 -- than is legal here, but as explained above, we like to allow more
2120 -- with a proper diagnostic, and in the case of a membership operation
2121 -- where sets are allowed, a simple expression is permissible anyway.
2123 Expr_Node := P_Simple_Expression_Or_Range_Attribute;
2127 if Expr_Form = EF_Range_Attr then
2130 -- Simple_Expression .. Simple_Expression
2132 elsif Token = Tok_Dot_Dot then
2133 Check_Simple_Expression (Expr_Node);
2134 Range_Node := New_Node (N_Range, Token_Ptr);
2135 Set_Low_Bound (Range_Node, Expr_Node);
2137 Set_High_Bound (Range_Node, P_Simple_Expression);
2140 -- Case of subtype mark (optionally qualified simple name or an
2141 -- attribute whose prefix is an optionally qualified simple name)
2143 elsif Expr_Form = EF_Simple_Name
2144 or else Nkind (Expr_Node) = N_Attribute_Reference
2146 -- Check for error of range constraint after a subtype mark
2148 if Token = Tok_Range then
2149 Error_Msg_SC ("range constraint not allowed in membership test");
2153 -- Check for error of DIGITS or DELTA after a subtype mark
2155 elsif Token = Tok_Digits or else Token = Tok_Delta then
2157 ("accuracy definition not allowed in membership test");
2158 Scan; -- past DIGITS or DELTA
2161 -- Attribute reference, may or may not be OK, but in any case we
2164 elsif Token = Tok_Apostrophe then
2165 return P_Subtype_Mark_Attribute (Expr_Node);
2167 -- OK case of simple name, just return it
2173 -- Here we have some kind of error situation. Check for junk parens
2174 -- then return what we have, caller will deal with other errors.
2177 if Nkind (Expr_Node) in N_Subexpr
2178 and then Paren_Count (Expr_Node) /= 0
2180 Error_Msg ("|parentheses not allowed for subtype mark", Save_Loc);
2181 Set_Paren_Count (Expr_Node, 0);
2186 end P_Range_Or_Subtype_Mark;
2188 ----------------------------------------
2189 -- 3.5.1 Enumeration Type Definition --
2190 ----------------------------------------
2192 -- ENUMERATION_TYPE_DEFINITION ::=
2193 -- (ENUMERATION_LITERAL_SPECIFICATION
2194 -- {, ENUMERATION_LITERAL_SPECIFICATION})
2196 -- The caller has already scanned out the TYPE keyword
2198 -- Error recovery: can raise Error_Resync;
2200 function P_Enumeration_Type_Definition return Node_Id is
2201 Typedef_Node : Node_Id;
2204 Typedef_Node := New_Node (N_Enumeration_Type_Definition, Token_Ptr);
2205 Set_Literals (Typedef_Node, New_List);
2210 Append (P_Enumeration_Literal_Specification, Literals (Typedef_Node));
2211 exit when not Comma_Present;
2215 return Typedef_Node;
2216 end P_Enumeration_Type_Definition;
2218 ----------------------------------------------
2219 -- 3.5.1 Enumeration Literal Specification --
2220 ----------------------------------------------
2222 -- ENUMERATION_LITERAL_SPECIFICATION ::=
2223 -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
2225 -- Error recovery: can raise Error_Resync
2227 function P_Enumeration_Literal_Specification return Node_Id is
2229 if Token = Tok_Char_Literal then
2230 return P_Defining_Character_Literal;
2232 return P_Defining_Identifier (C_Comma_Right_Paren);
2234 end P_Enumeration_Literal_Specification;
2236 ---------------------------------------
2237 -- 3.5.1 Defining_Character_Literal --
2238 ---------------------------------------
2240 -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
2242 -- Error recovery: cannot raise Error_Resync
2244 -- The caller has checked that the current token is a character literal
2246 function P_Defining_Character_Literal return Node_Id is
2247 Literal_Node : Node_Id;
2250 Literal_Node := Token_Node;
2251 Change_Character_Literal_To_Defining_Character_Literal (Literal_Node);
2252 Scan; -- past character literal
2253 return Literal_Node;
2254 end P_Defining_Character_Literal;
2256 ------------------------------------
2257 -- 3.5.4 Integer Type Definition --
2258 ------------------------------------
2260 -- Parsed by P_Type_Declaration (3.2.1)
2262 -------------------------------------------
2263 -- 3.5.4 Signed Integer Type Definition --
2264 -------------------------------------------
2266 -- SIGNED_INTEGER_TYPE_DEFINITION ::=
2267 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2269 -- Normally the initial token on entry is RANGE, but in some
2270 -- error conditions, the range token was missing and control is
2271 -- passed with Token pointing to first token of the first expression.
2273 -- Error recovery: cannot raise Error_Resync
2275 function P_Signed_Integer_Type_Definition return Node_Id is
2276 Typedef_Node : Node_Id;
2277 Expr_Node : Node_Id;
2280 Typedef_Node := New_Node (N_Signed_Integer_Type_Definition, Token_Ptr);
2282 if Token = Tok_Range then
2286 Expr_Node := P_Expression;
2287 Check_Simple_Expression (Expr_Node);
2288 Set_Low_Bound (Typedef_Node, Expr_Node);
2290 Expr_Node := P_Expression;
2291 Check_Simple_Expression (Expr_Node);
2292 Set_High_Bound (Typedef_Node, Expr_Node);
2293 return Typedef_Node;
2294 end P_Signed_Integer_Type_Definition;
2296 ------------------------------------
2297 -- 3.5.4 Modular Type Definition --
2298 ------------------------------------
2300 -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
2302 -- The caller has checked that the initial token is MOD
2304 -- Error recovery: cannot raise Error_Resync
2306 function P_Modular_Type_Definition return Node_Id is
2307 Typedef_Node : Node_Id;
2310 if Ada_Version = Ada_83 then
2311 Error_Msg_SC ("(Ada 83): modular types not allowed");
2314 Typedef_Node := New_Node (N_Modular_Type_Definition, Token_Ptr);
2316 Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
2318 -- Handle mod L..R cleanly
2320 if Token = Tok_Dot_Dot then
2321 Error_Msg_SC ("range not allowed for modular type");
2323 Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
2326 return Typedef_Node;
2327 end P_Modular_Type_Definition;
2329 ---------------------------------
2330 -- 3.5.6 Real Type Definition --
2331 ---------------------------------
2333 -- Parsed by P_Type_Declaration (3.2.1)
2335 --------------------------------------
2336 -- 3.5.7 Floating Point Definition --
2337 --------------------------------------
2339 -- FLOATING_POINT_DEFINITION ::=
2340 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2342 -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
2344 -- The caller has checked that the initial token is DIGITS
2346 -- Error recovery: cannot raise Error_Resync
2348 function P_Floating_Point_Definition return Node_Id is
2349 Digits_Loc : constant Source_Ptr := Token_Ptr;
2351 Expr_Node : Node_Id;
2354 Scan; -- past DIGITS
2355 Expr_Node := P_Expression_No_Right_Paren;
2356 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2358 -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
2360 if Token = Tok_Delta then
2361 Error_Msg_SC -- CODEFIX
2362 ("|DELTA must come before DIGITS");
2363 Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Digits_Loc);
2365 Set_Delta_Expression (Def_Node, P_Expression_No_Right_Paren);
2367 -- OK floating-point definition
2370 Def_Node := New_Node (N_Floating_Point_Definition, Digits_Loc);
2373 Set_Digits_Expression (Def_Node, Expr_Node);
2374 Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt);
2376 end P_Floating_Point_Definition;
2378 -------------------------------------
2379 -- 3.5.7 Real Range Specification --
2380 -------------------------------------
2382 -- REAL_RANGE_SPECIFICATION ::=
2383 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2385 -- Error recovery: cannot raise Error_Resync
2387 function P_Real_Range_Specification_Opt return Node_Id is
2388 Specification_Node : Node_Id;
2389 Expr_Node : Node_Id;
2392 if Token = Tok_Range then
2393 Specification_Node :=
2394 New_Node (N_Real_Range_Specification, Token_Ptr);
2396 Expr_Node := P_Expression_No_Right_Paren;
2397 Check_Simple_Expression (Expr_Node);
2398 Set_Low_Bound (Specification_Node, Expr_Node);
2400 Expr_Node := P_Expression_No_Right_Paren;
2401 Check_Simple_Expression (Expr_Node);
2402 Set_High_Bound (Specification_Node, Expr_Node);
2403 return Specification_Node;
2407 end P_Real_Range_Specification_Opt;
2409 -----------------------------------
2410 -- 3.5.9 Fixed Point Definition --
2411 -----------------------------------
2413 -- FIXED_POINT_DEFINITION ::=
2414 -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
2416 -- ORDINARY_FIXED_POINT_DEFINITION ::=
2417 -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION
2419 -- DECIMAL_FIXED_POINT_DEFINITION ::=
2420 -- delta static_EXPRESSION
2421 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2423 -- The caller has checked that the initial token is DELTA
2425 -- Error recovery: cannot raise Error_Resync
2427 function P_Fixed_Point_Definition return Node_Id is
2428 Delta_Node : Node_Id;
2429 Delta_Loc : Source_Ptr;
2431 Expr_Node : Node_Id;
2434 Delta_Loc := Token_Ptr;
2436 Delta_Node := P_Expression_No_Right_Paren;
2437 Check_Simple_Expression_In_Ada_83 (Delta_Node);
2439 if Token = Tok_Digits then
2440 if Ada_Version = Ada_83 then
2441 Error_Msg_SC ("(Ada 83) decimal fixed type not allowed!");
2444 Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Delta_Loc);
2445 Scan; -- past DIGITS
2446 Expr_Node := P_Expression_No_Right_Paren;
2447 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2448 Set_Digits_Expression (Def_Node, Expr_Node);
2451 Def_Node := New_Node (N_Ordinary_Fixed_Point_Definition, Delta_Loc);
2453 -- Range is required in ordinary fixed point case
2455 if Token /= Tok_Range then
2456 Error_Msg_AP ("range must be given for fixed-point type");
2461 Set_Delta_Expression (Def_Node, Delta_Node);
2462 Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt);
2464 end P_Fixed_Point_Definition;
2466 --------------------------------------------
2467 -- 3.5.9 Ordinary Fixed Point Definition --
2468 --------------------------------------------
2470 -- Parsed by P_Fixed_Point_Definition (3.5.9)
2472 -------------------------------------------
2473 -- 3.5.9 Decimal Fixed Point Definition --
2474 -------------------------------------------
2476 -- Parsed by P_Decimal_Point_Definition (3.5.9)
2478 ------------------------------
2479 -- 3.5.9 Digits Constraint --
2480 ------------------------------
2482 -- DIGITS_CONSTRAINT ::=
2483 -- digits static_EXPRESSION [RANGE_CONSTRAINT]
2485 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2487 -- The caller has checked that the initial token is DIGITS
2489 function P_Digits_Constraint return Node_Id is
2490 Constraint_Node : Node_Id;
2491 Expr_Node : Node_Id;
2494 Constraint_Node := New_Node (N_Digits_Constraint, Token_Ptr);
2495 Scan; -- past DIGITS
2496 Expr_Node := P_Expression;
2497 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2498 Set_Digits_Expression (Constraint_Node, Expr_Node);
2500 if Token = Tok_Range then
2501 Set_Range_Constraint (Constraint_Node, P_Range_Constraint);
2504 return Constraint_Node;
2505 end P_Digits_Constraint;
2507 -----------------------------
2508 -- 3.5.9 Delta Constraint --
2509 -----------------------------
2511 -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
2513 -- Note: this is an obsolescent feature in Ada 95 (I.3)
2515 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2517 -- The caller has checked that the initial token is DELTA
2519 -- Error recovery: cannot raise Error_Resync
2521 function P_Delta_Constraint return Node_Id is
2522 Constraint_Node : Node_Id;
2523 Expr_Node : Node_Id;
2526 Constraint_Node := New_Node (N_Delta_Constraint, Token_Ptr);
2528 Expr_Node := P_Expression;
2529 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2530 Set_Delta_Expression (Constraint_Node, Expr_Node);
2532 if Token = Tok_Range then
2533 Set_Range_Constraint (Constraint_Node, P_Range_Constraint);
2536 return Constraint_Node;
2537 end P_Delta_Constraint;
2539 --------------------------------
2540 -- 3.6 Array Type Definition --
2541 --------------------------------
2543 -- ARRAY_TYPE_DEFINITION ::=
2544 -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
2546 -- UNCONSTRAINED_ARRAY_DEFINITION ::=
2547 -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
2548 -- COMPONENT_DEFINITION
2550 -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
2552 -- CONSTRAINED_ARRAY_DEFINITION ::=
2553 -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
2554 -- COMPONENT_DEFINITION
2556 -- DISCRETE_SUBTYPE_DEFINITION ::=
2557 -- DISCRETE_SUBTYPE_INDICATION | RANGE
2559 -- COMPONENT_DEFINITION ::=
2560 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
2562 -- The caller has checked that the initial token is ARRAY
2564 -- Error recovery: can raise Error_Resync
2566 function P_Array_Type_Definition return Node_Id is
2567 Array_Loc : Source_Ptr;
2568 CompDef_Node : Node_Id;
2570 Not_Null_Present : Boolean := False;
2571 Subs_List : List_Id;
2572 Scan_State : Saved_Scan_State;
2573 Aliased_Present : Boolean := False;
2576 Array_Loc := Token_Ptr;
2578 Subs_List := New_List;
2581 -- It's quite tricky to disentangle these two possibilities, so we do
2582 -- a prescan to determine which case we have and then reset the scan.
2583 -- The prescan skips past possible subtype mark tokens.
2585 Save_Scan_State (Scan_State); -- just after paren
2587 while Token in Token_Class_Desig or else
2588 Token = Tok_Dot or else
2589 Token = Tok_Apostrophe -- because of 'BASE, 'CLASS
2594 -- If we end up on RANGE <> then we have the unconstrained case. We
2595 -- will also allow the RANGE to be omitted, just to improve error
2596 -- handling for a case like array (integer <>) of integer;
2598 Scan; -- past possible RANGE or <>
2600 if (Prev_Token = Tok_Range and then Token = Tok_Box) or else
2601 Prev_Token = Tok_Box
2603 Def_Node := New_Node (N_Unconstrained_Array_Definition, Array_Loc);
2604 Restore_Scan_State (Scan_State); -- to first subtype mark
2607 Append (P_Subtype_Mark_Resync, Subs_List);
2610 exit when Token = Tok_Right_Paren or else Token = Tok_Of;
2614 Set_Subtype_Marks (Def_Node, Subs_List);
2617 Def_Node := New_Node (N_Constrained_Array_Definition, Array_Loc);
2618 Restore_Scan_State (Scan_State); -- to first discrete range
2621 Append (P_Discrete_Subtype_Definition, Subs_List);
2622 exit when not Comma_Present;
2625 Set_Discrete_Subtype_Definitions (Def_Node, Subs_List);
2631 CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
2633 if Token_Name = Name_Aliased then
2634 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
2637 if Token = Tok_Aliased then
2638 Aliased_Present := True;
2639 Scan; -- past ALIASED
2642 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254)
2644 -- Ada 2005 (AI-230): Access Definition case
2646 if Token = Tok_Access then
2647 if Ada_Version < Ada_05 then
2649 ("generalized use of anonymous access types " &
2650 "is an Ada 2005 extension");
2651 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
2654 if Aliased_Present then
2655 Error_Msg_SP ("ALIASED not allowed here");
2658 Set_Subtype_Indication (CompDef_Node, Empty);
2659 Set_Aliased_Present (CompDef_Node, False);
2660 Set_Access_Definition (CompDef_Node,
2661 P_Access_Definition (Not_Null_Present));
2664 Set_Access_Definition (CompDef_Node, Empty);
2665 Set_Aliased_Present (CompDef_Node, Aliased_Present);
2666 Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
2667 Set_Subtype_Indication (CompDef_Node,
2668 P_Subtype_Indication (Not_Null_Present));
2671 Set_Component_Definition (Def_Node, CompDef_Node);
2674 end P_Array_Type_Definition;
2676 -----------------------------------------
2677 -- 3.6 Unconstrained Array Definition --
2678 -----------------------------------------
2680 -- Parsed by P_Array_Type_Definition (3.6)
2682 ---------------------------------------
2683 -- 3.6 Constrained Array Definition --
2684 ---------------------------------------
2686 -- Parsed by P_Array_Type_Definition (3.6)
2688 --------------------------------------
2689 -- 3.6 Discrete Subtype Definition --
2690 --------------------------------------
2692 -- DISCRETE_SUBTYPE_DEFINITION ::=
2693 -- discrete_SUBTYPE_INDICATION | RANGE
2695 -- Note: the discrete subtype definition appearing in a constrained
2696 -- array definition is parsed by P_Array_Type_Definition (3.6)
2698 -- Error recovery: cannot raise Error_Resync
2700 function P_Discrete_Subtype_Definition return Node_Id is
2702 -- The syntax of a discrete subtype definition is identical to that
2703 -- of a discrete range, so we simply share the same parsing code.
2705 return P_Discrete_Range;
2706 end P_Discrete_Subtype_Definition;
2708 -------------------------------
2709 -- 3.6 Component Definition --
2710 -------------------------------
2712 -- For the array case, parsed by P_Array_Type_Definition (3.6)
2713 -- For the record case, parsed by P_Component_Declaration (3.8)
2715 -----------------------------
2716 -- 3.6.1 Index Constraint --
2717 -----------------------------
2719 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2721 ---------------------------
2722 -- 3.6.1 Discrete Range --
2723 ---------------------------
2725 -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
2727 -- The possible forms for a discrete range are:
2729 -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2)
2730 -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2)
2731 -- Range_Attribute (RANGE, 3.5)
2732 -- Simple_Expression .. Simple_Expression (RANGE, 3.5)
2734 -- Error recovery: cannot raise Error_Resync
2736 function P_Discrete_Range return Node_Id is
2737 Expr_Node : Node_Id;
2738 Range_Node : Node_Id;
2741 Expr_Node := P_Simple_Expression_Or_Range_Attribute;
2743 if Expr_Form = EF_Range_Attr then
2746 elsif Token = Tok_Range then
2747 if Expr_Form /= EF_Simple_Name then
2748 Error_Msg_SC ("range must be preceded by subtype mark");
2751 return P_Subtype_Indication (Expr_Node);
2753 -- Check Expression .. Expression case
2755 elsif Token = Tok_Dot_Dot then
2756 Range_Node := New_Node (N_Range, Token_Ptr);
2757 Set_Low_Bound (Range_Node, Expr_Node);
2759 Expr_Node := P_Expression;
2760 Check_Simple_Expression (Expr_Node);
2761 Set_High_Bound (Range_Node, Expr_Node);
2764 -- Otherwise we must have a subtype mark
2766 elsif Expr_Form = EF_Simple_Name then
2769 -- If incorrect, complain that we expect ..
2775 end P_Discrete_Range;
2777 ----------------------------
2778 -- 3.7 Discriminant Part --
2779 ----------------------------
2781 -- DISCRIMINANT_PART ::=
2782 -- UNKNOWN_DISCRIMINANT_PART
2783 -- | KNOWN_DISCRIMINANT_PART
2785 -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
2786 -- or P_Unknown_Discriminant_Part (3.7), since we know which we want.
2788 ------------------------------------
2789 -- 3.7 Unknown Discriminant Part --
2790 ------------------------------------
2792 -- UNKNOWN_DISCRIMINANT_PART ::= (<>)
2794 -- If no unknown discriminant part is present, then False is returned,
2795 -- otherwise the unknown discriminant is scanned out and True is returned.
2797 -- Error recovery: cannot raise Error_Resync
2799 function P_Unknown_Discriminant_Part_Opt return Boolean is
2800 Scan_State : Saved_Scan_State;
2803 -- If <> right now, then this is missing left paren
2805 if Token = Tok_Box then
2808 -- If not <> or left paren, then definitely no box
2810 elsif Token /= Tok_Left_Paren then
2813 -- Left paren, so might be a box after it
2816 Save_Scan_State (Scan_State);
2817 Scan; -- past the left paren
2819 if Token /= Tok_Box then
2820 Restore_Scan_State (Scan_State);
2825 -- We are now pointing to the box
2827 if Ada_Version = Ada_83 then
2828 Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!");
2831 Scan; -- past the box
2832 U_Right_Paren; -- must be followed by right paren
2834 end P_Unknown_Discriminant_Part_Opt;
2836 ----------------------------------
2837 -- 3.7 Known Discriminant Part --
2838 ----------------------------------
2840 -- KNOWN_DISCRIMINANT_PART ::=
2841 -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
2843 -- DISCRIMINANT_SPECIFICATION ::=
2844 -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
2845 -- [:= DEFAULT_EXPRESSION]
2846 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
2847 -- [:= DEFAULT_EXPRESSION]
2849 -- If no known discriminant part is present, then No_List is returned
2851 -- Error recovery: cannot raise Error_Resync
2853 function P_Known_Discriminant_Part_Opt return List_Id is
2854 Specification_Node : Node_Id;
2855 Specification_List : List_Id;
2856 Ident_Sloc : Source_Ptr;
2857 Scan_State : Saved_Scan_State;
2859 Not_Null_Present : Boolean;
2862 Idents : array (Int range 1 .. 4096) of Entity_Id;
2863 -- This array holds the list of defining identifiers. The upper bound
2864 -- of 4096 is intended to be essentially infinite, and we do not even
2865 -- bother to check for it being exceeded.
2868 if Token = Tok_Left_Paren then
2869 Specification_List := New_List;
2871 P_Pragmas_Misplaced;
2873 Specification_Loop : loop
2875 Ident_Sloc := Token_Ptr;
2876 Idents (1) := P_Defining_Identifier (C_Comma_Colon);
2879 while Comma_Present loop
2880 Num_Idents := Num_Idents + 1;
2881 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
2884 -- If there are multiple identifiers, we repeatedly scan the
2885 -- type and initialization expression information by resetting
2886 -- the scan pointer (so that we get completely separate trees
2887 -- for each occurrence).
2889 if Num_Idents > 1 then
2890 Save_Scan_State (Scan_State);
2895 -- Loop through defining identifiers in list
2899 Specification_Node :=
2900 New_Node (N_Discriminant_Specification, Ident_Sloc);
2901 Set_Defining_Identifier (Specification_Node, Idents (Ident));
2902 Not_Null_Present := -- Ada 2005 (AI-231, AI-447)
2903 P_Null_Exclusion (Allow_Anonymous_In_95 => True);
2905 if Token = Tok_Access then
2906 if Ada_Version = Ada_83 then
2908 ("(Ada 83) access discriminant not allowed!");
2911 Set_Discriminant_Type
2912 (Specification_Node,
2913 P_Access_Definition (Not_Null_Present));
2916 Set_Discriminant_Type
2917 (Specification_Node, P_Subtype_Mark);
2919 Set_Null_Exclusion_Present -- Ada 2005 (AI-231)
2920 (Specification_Node, Not_Null_Present);
2924 (Specification_Node, Init_Expr_Opt (True));
2927 Set_Prev_Ids (Specification_Node, True);
2930 if Ident < Num_Idents then
2931 Set_More_Ids (Specification_Node, True);
2934 Append (Specification_Node, Specification_List);
2935 exit Ident_Loop when Ident = Num_Idents;
2937 Restore_Scan_State (Scan_State);
2939 end loop Ident_Loop;
2941 exit Specification_Loop when Token /= Tok_Semicolon;
2943 P_Pragmas_Misplaced;
2944 end loop Specification_Loop;
2947 return Specification_List;
2952 end P_Known_Discriminant_Part_Opt;
2954 -------------------------------------
2955 -- 3.7 Discriminant Specification --
2956 -------------------------------------
2958 -- Parsed by P_Known_Discriminant_Part_Opt (3.7)
2960 -----------------------------
2961 -- 3.7 Default Expression --
2962 -----------------------------
2964 -- Always parsed (simply as an Expression) by the parent construct
2966 ------------------------------------
2967 -- 3.7.1 Discriminant Constraint --
2968 ------------------------------------
2970 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2972 --------------------------------------------------------
2973 -- 3.7.1 Index or Discriminant Constraint (also 3.6) --
2974 --------------------------------------------------------
2976 -- DISCRIMINANT_CONSTRAINT ::=
2977 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
2979 -- DISCRIMINANT_ASSOCIATION ::=
2980 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2983 -- This routine parses either an index or a discriminant constraint. As
2984 -- is clear from the above grammar, it is often possible to clearly
2985 -- determine which of the two possibilities we have, but there are
2986 -- cases (those in which we have a series of expressions of the same
2987 -- syntactic form as subtype indications), where we cannot tell. Since
2988 -- this means that in any case the semantic phase has to distinguish
2989 -- between the two, there is not much point in the parser trying to
2990 -- distinguish even those cases where the difference is clear. In any
2991 -- case, if we have a situation like:
2993 -- (A => 123, 235 .. 500)
2995 -- it is not clear which of the two items is the wrong one, better to
2996 -- let the semantic phase give a clear message. Consequently, this
2997 -- routine in general returns a list of items which can be either
2998 -- discrete ranges or discriminant associations.
3000 -- The caller has checked that the initial token is a left paren
3002 -- Error recovery: can raise Error_Resync
3004 function P_Index_Or_Discriminant_Constraint return Node_Id is
3005 Scan_State : Saved_Scan_State;
3006 Constr_Node : Node_Id;
3007 Constr_List : List_Id;
3008 Expr_Node : Node_Id;
3009 Result_Node : Node_Id;
3012 Result_Node := New_Node (N_Index_Or_Discriminant_Constraint, Token_Ptr);
3014 Constr_List := New_List;
3015 Set_Constraints (Result_Node, Constr_List);
3017 -- The two syntactic forms are a little mixed up, so what we are doing
3018 -- here is looking at the first entry to determine which case we have
3020 -- A discriminant constraint is a list of discriminant associations,
3021 -- which have one of the following possible forms:
3025 -- Id | Id | .. | Id => Expression
3027 -- An index constraint is a list of discrete ranges which have one
3028 -- of the following possible forms:
3031 -- Subtype_Mark range Range
3033 -- Simple_Expression .. Simple_Expression
3035 -- Loop through discriminants in list
3038 -- Check cases of Id => Expression or Id | Id => Expression
3040 if Token = Tok_Identifier then
3041 Save_Scan_State (Scan_State); -- at Id
3044 if Token = Tok_Arrow or else Token = Tok_Vertical_Bar then
3045 Restore_Scan_State (Scan_State); -- to Id
3046 Append (P_Discriminant_Association, Constr_List);
3049 Restore_Scan_State (Scan_State); -- to Id
3053 -- Otherwise scan out an expression and see what we have got
3055 Expr_Node := P_Expression_Or_Range_Attribute;
3057 if Expr_Form = EF_Range_Attr then
3058 Append (Expr_Node, Constr_List);
3060 elsif Token = Tok_Range then
3061 if Expr_Form /= EF_Simple_Name then
3062 Error_Msg_SC ("subtype mark required before RANGE");
3065 Append (P_Subtype_Indication (Expr_Node), Constr_List);
3068 -- Check Simple_Expression .. Simple_Expression case
3070 elsif Token = Tok_Dot_Dot then
3071 Check_Simple_Expression (Expr_Node);
3072 Constr_Node := New_Node (N_Range, Token_Ptr);
3073 Set_Low_Bound (Constr_Node, Expr_Node);
3075 Expr_Node := P_Expression;
3076 Check_Simple_Expression (Expr_Node);
3077 Set_High_Bound (Constr_Node, Expr_Node);
3078 Append (Constr_Node, Constr_List);
3081 -- Case of an expression which could be either form
3084 Append (Expr_Node, Constr_List);
3088 -- Here with a single entry scanned
3091 exit when not Comma_Present;
3097 end P_Index_Or_Discriminant_Constraint;
3099 -------------------------------------
3100 -- 3.7.1 Discriminant Association --
3101 -------------------------------------
3103 -- DISCRIMINANT_ASSOCIATION ::=
3104 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
3107 -- This routine is used only when the name list is present and the caller
3108 -- has already checked this (by scanning ahead and repositioning the
3111 -- Error_Recovery: cannot raise Error_Resync;
3113 function P_Discriminant_Association return Node_Id is
3114 Discr_Node : Node_Id;
3115 Names_List : List_Id;
3116 Ident_Sloc : Source_Ptr;
3119 Ident_Sloc := Token_Ptr;
3120 Names_List := New_List;
3123 Append (P_Identifier (C_Vertical_Bar_Arrow), Names_List);
3124 exit when Token /= Tok_Vertical_Bar;
3128 Discr_Node := New_Node (N_Discriminant_Association, Ident_Sloc);
3129 Set_Selector_Names (Discr_Node, Names_List);
3131 Set_Expression (Discr_Node, P_Expression);
3133 end P_Discriminant_Association;
3135 ---------------------------------
3136 -- 3.8 Record Type Definition --
3137 ---------------------------------
3139 -- RECORD_TYPE_DEFINITION ::=
3140 -- [[abstract] tagged] [limited] RECORD_DEFINITION
3142 -- There is no node in the tree for a record type definition. Instead
3143 -- a record definition node appears, with possible Abstract_Present,
3144 -- Tagged_Present, and Limited_Present flags set appropriately.
3146 ----------------------------
3147 -- 3.8 Record Definition --
3148 ----------------------------
3150 -- RECORD_DEFINITION ::=
3156 -- Note: in the case where a record definition node is used to represent
3157 -- a record type definition, the caller sets the Tagged_Present and
3158 -- Limited_Present flags in the resulting N_Record_Definition node as
3161 -- Note that the RECORD token at the start may be missing in certain
3162 -- error situations, so this function is expected to post the error
3164 -- Error recovery: can raise Error_Resync
3166 function P_Record_Definition return Node_Id is
3170 Rec_Node := New_Node (N_Record_Definition, Token_Ptr);
3174 if Token = Tok_Null then
3177 Set_Null_Present (Rec_Node, True);
3179 -- Catch incomplete declaration to prevent cascaded errors, see
3180 -- ACATS B393002 for an example.
3182 elsif Token = Tok_Semicolon then
3183 Error_Msg_AP ("missing record definition");
3185 -- Case starting with RECORD keyword. Build scope stack entry. For the
3186 -- column, we use the first non-blank character on the line, to deal
3187 -- with situations such as:
3193 -- which is not official RM indentation, but is not uncommon usage, and
3194 -- in particular is standard GNAT coding style, so handle it nicely.
3198 Scope.Table (Scope.Last).Etyp := E_Record;
3199 Scope.Table (Scope.Last).Ecol := Start_Column;
3200 Scope.Table (Scope.Last).Sloc := Token_Ptr;
3201 Scope.Table (Scope.Last).Labl := Error;
3202 Scope.Table (Scope.Last).Junk := (Token /= Tok_Record);
3206 Set_Component_List (Rec_Node, P_Component_List);
3209 exit when Check_End;
3210 Discard_Junk_Node (P_Component_List);
3215 end P_Record_Definition;
3217 -------------------------
3218 -- 3.8 Component List --
3219 -------------------------
3221 -- COMPONENT_LIST ::=
3222 -- COMPONENT_ITEM {COMPONENT_ITEM}
3223 -- | {COMPONENT_ITEM} VARIANT_PART
3226 -- Error recovery: cannot raise Error_Resync
3228 function P_Component_List return Node_Id is
3229 Component_List_Node : Node_Id;
3230 Decls_List : List_Id;
3231 Scan_State : Saved_Scan_State;
3234 Component_List_Node := New_Node (N_Component_List, Token_Ptr);
3235 Decls_List := New_List;
3237 if Token = Tok_Null then
3240 P_Pragmas_Opt (Decls_List);
3241 Set_Null_Present (Component_List_Node, True);
3242 return Component_List_Node;
3245 P_Pragmas_Opt (Decls_List);
3247 if Token /= Tok_Case then
3248 Component_Scan_Loop : loop
3249 P_Component_Items (Decls_List);
3250 P_Pragmas_Opt (Decls_List);
3252 exit Component_Scan_Loop when Token = Tok_End
3253 or else Token = Tok_Case
3254 or else Token = Tok_When;
3256 -- We are done if we do not have an identifier. However, if
3257 -- we have a misspelled reserved identifier that is in a column
3258 -- to the right of the record definition, we will treat it as
3259 -- an identifier. It turns out to be too dangerous in practice
3260 -- to accept such a mis-spelled identifier which does not have
3261 -- this additional clue that confirms the incorrect spelling.
3263 if Token /= Tok_Identifier then
3264 if Start_Column > Scope.Table (Scope.Last).Ecol
3265 and then Is_Reserved_Identifier
3267 Save_Scan_State (Scan_State); -- at reserved id
3268 Scan; -- possible reserved id
3270 if Token = Tok_Comma or else Token = Tok_Colon then
3271 Restore_Scan_State (Scan_State);
3272 Scan_Reserved_Identifier (Force_Msg => True);
3274 -- Note reserved identifier used as field name after
3275 -- all because not followed by colon or comma
3278 Restore_Scan_State (Scan_State);
3279 exit Component_Scan_Loop;
3282 -- Non-identifier that definitely was not reserved id
3285 exit Component_Scan_Loop;
3288 end loop Component_Scan_Loop;
3291 if Token = Tok_Case then
3292 Set_Variant_Part (Component_List_Node, P_Variant_Part);
3294 -- Check for junk after variant part
3296 if Token = Tok_Identifier then
3297 Save_Scan_State (Scan_State);
3298 Scan; -- past identifier
3300 if Token = Tok_Colon then
3301 Restore_Scan_State (Scan_State);
3302 Error_Msg_SC ("component may not follow variant part");
3303 Discard_Junk_Node (P_Component_List);
3305 elsif Token = Tok_Case then
3306 Restore_Scan_State (Scan_State);
3307 Error_Msg_SC ("only one variant part allowed in a record");
3308 Discard_Junk_Node (P_Component_List);
3311 Restore_Scan_State (Scan_State);
3317 Set_Component_Items (Component_List_Node, Decls_List);
3318 return Component_List_Node;
3319 end P_Component_List;
3321 -------------------------
3322 -- 3.8 Component Item --
3323 -------------------------
3325 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
3327 -- COMPONENT_DECLARATION ::=
3328 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
3329 -- [:= DEFAULT_EXPRESSION];
3331 -- COMPONENT_DEFINITION ::=
3332 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
3334 -- Error recovery: cannot raise Error_Resync, if an error occurs,
3335 -- the scan is positioned past the following semicolon.
3337 -- Note: we do not yet allow representation clauses to appear as component
3338 -- items, do we need to add this capability sometime in the future ???
3340 procedure P_Component_Items (Decls : List_Id) is
3341 Aliased_Present : Boolean := False;
3342 CompDef_Node : Node_Id;
3343 Decl_Node : Node_Id;
3344 Scan_State : Saved_Scan_State;
3345 Not_Null_Present : Boolean := False;
3348 Ident_Sloc : Source_Ptr;
3350 Idents : array (Int range 1 .. 4096) of Entity_Id;
3351 -- This array holds the list of defining identifiers. The upper bound
3352 -- of 4096 is intended to be essentially infinite, and we do not even
3353 -- bother to check for it being exceeded.
3356 if Token /= Tok_Identifier then
3357 Error_Msg_SC ("component declaration expected");
3358 Resync_Past_Semicolon;
3362 Ident_Sloc := Token_Ptr;
3363 Idents (1) := P_Defining_Identifier (C_Comma_Colon);
3366 while Comma_Present loop
3367 Num_Idents := Num_Idents + 1;
3368 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
3371 -- If there are multiple identifiers, we repeatedly scan the
3372 -- type and initialization expression information by resetting
3373 -- the scan pointer (so that we get completely separate trees
3374 -- for each occurrence).
3376 if Num_Idents > 1 then
3377 Save_Scan_State (Scan_State);
3382 -- Loop through defining identifiers in list
3387 -- The following block is present to catch Error_Resync
3388 -- which causes the parse to be reset past the semicolon
3391 Decl_Node := New_Node (N_Component_Declaration, Ident_Sloc);
3392 Set_Defining_Identifier (Decl_Node, Idents (Ident));
3394 if Token = Tok_Constant then
3395 Error_Msg_SC ("constant components are not permitted");
3399 CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
3401 if Token_Name = Name_Aliased then
3402 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
3405 if Token = Tok_Aliased then
3406 Aliased_Present := True;
3407 Scan; -- past ALIASED
3410 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254)
3412 -- Ada 2005 (AI-230): Access Definition case
3414 if Token = Tok_Access then
3415 if Ada_Version < Ada_05 then
3417 ("generalized use of anonymous access types " &
3418 "is an Ada 2005 extension");
3419 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
3422 if Aliased_Present then
3423 Error_Msg_SP ("ALIASED not allowed here");
3426 Set_Subtype_Indication (CompDef_Node, Empty);
3427 Set_Aliased_Present (CompDef_Node, False);
3428 Set_Access_Definition (CompDef_Node,
3429 P_Access_Definition (Not_Null_Present));
3432 Set_Access_Definition (CompDef_Node, Empty);
3433 Set_Aliased_Present (CompDef_Node, Aliased_Present);
3434 Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
3436 if Token = Tok_Array then
3438 ("anonymous arrays not allowed as components");
3442 Set_Subtype_Indication (CompDef_Node,
3443 P_Subtype_Indication (Not_Null_Present));
3446 Set_Component_Definition (Decl_Node, CompDef_Node);
3447 Set_Expression (Decl_Node, Init_Expr_Opt);
3450 Set_Prev_Ids (Decl_Node, True);
3453 if Ident < Num_Idents then
3454 Set_More_Ids (Decl_Node, True);
3457 Append (Decl_Node, Decls);
3460 when Error_Resync =>
3461 if Token /= Tok_End then
3462 Resync_Past_Semicolon;
3466 exit Ident_Loop when Ident = Num_Idents;
3468 Restore_Scan_State (Scan_State);
3471 end loop Ident_Loop;
3474 end P_Component_Items;
3476 --------------------------------
3477 -- 3.8 Component Declaration --
3478 --------------------------------
3480 -- Parsed by P_Component_Items (3.8)
3482 -------------------------
3483 -- 3.8.1 Variant Part --
3484 -------------------------
3487 -- case discriminant_DIRECT_NAME is
3492 -- The caller has checked that the initial token is CASE
3494 -- Error recovery: cannot raise Error_Resync
3496 function P_Variant_Part return Node_Id is
3497 Variant_Part_Node : Node_Id;
3498 Variants_List : List_Id;
3499 Case_Node : Node_Id;
3502 Variant_Part_Node := New_Node (N_Variant_Part, Token_Ptr);
3504 Scope.Table (Scope.Last).Etyp := E_Case;
3505 Scope.Table (Scope.Last).Sloc := Token_Ptr;
3506 Scope.Table (Scope.Last).Ecol := Start_Column;
3509 Case_Node := P_Expression;
3510 Set_Name (Variant_Part_Node, Case_Node);
3512 if Nkind (Case_Node) /= N_Identifier then
3513 Set_Name (Variant_Part_Node, Error);
3514 Error_Msg ("discriminant name expected", Sloc (Case_Node));
3516 elsif Paren_Count (Case_Node) /= 0 then
3517 Error_Msg ("|discriminant name may not be parenthesized",
3519 Set_Paren_Count (Case_Node, 0);
3523 Variants_List := New_List;
3524 P_Pragmas_Opt (Variants_List);
3526 -- Test missing variant
3528 if Token = Tok_End then
3529 Error_Msg_BC ("WHEN expected (must have at least one variant)");
3531 Append (P_Variant, Variants_List);
3534 -- Loop through variants, note that we allow if in place of when,
3535 -- this error will be detected and handled in P_Variant.
3538 P_Pragmas_Opt (Variants_List);
3540 if Token /= Tok_When
3541 and then Token /= Tok_If
3542 and then Token /= Tok_Others
3544 exit when Check_End;
3547 Append (P_Variant, Variants_List);
3550 Set_Variants (Variant_Part_Node, Variants_List);
3551 return Variant_Part_Node;
3554 --------------------
3556 --------------------
3559 -- when DISCRETE_CHOICE_LIST =>
3562 -- Error recovery: cannot raise Error_Resync
3564 -- The initial token on entry is either WHEN, IF or OTHERS
3566 function P_Variant return Node_Id is
3567 Variant_Node : Node_Id;
3570 -- Special check to recover nicely from use of IF in place of WHEN
3572 if Token = Tok_If then
3579 Variant_Node := New_Node (N_Variant, Prev_Token_Ptr);
3580 Set_Discrete_Choices (Variant_Node, P_Discrete_Choice_List);
3582 Set_Component_List (Variant_Node, P_Component_List);
3583 return Variant_Node;
3586 ---------------------------------
3587 -- 3.8.1 Discrete Choice List --
3588 ---------------------------------
3590 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
3592 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
3594 -- Note: in Ada 83, the expression must be a simple expression
3596 -- Error recovery: cannot raise Error_Resync
3598 function P_Discrete_Choice_List return List_Id is
3600 Expr_Node : Node_Id;
3601 Choice_Node : Node_Id;
3604 Choices := New_List;
3606 if Token = Tok_Others then
3607 Append (New_Node (N_Others_Choice, Token_Ptr), Choices);
3608 Scan; -- past OTHERS
3612 -- Scan out expression or range attribute
3614 Expr_Node := P_Expression_Or_Range_Attribute;
3615 Ignore (Tok_Right_Paren);
3617 if Token = Tok_Colon
3618 and then Nkind (Expr_Node) = N_Identifier
3620 Error_Msg_SP ("label not permitted in this context");
3625 elsif Expr_Form = EF_Range_Attr then
3626 Append (Expr_Node, Choices);
3630 elsif Token = Tok_Dot_Dot then
3631 Check_Simple_Expression (Expr_Node);
3632 Choice_Node := New_Node (N_Range, Token_Ptr);
3633 Set_Low_Bound (Choice_Node, Expr_Node);
3635 Expr_Node := P_Expression_No_Right_Paren;
3636 Check_Simple_Expression (Expr_Node);
3637 Set_High_Bound (Choice_Node, Expr_Node);
3638 Append (Choice_Node, Choices);
3640 -- Simple name, must be subtype, so range allowed
3642 elsif Expr_Form = EF_Simple_Name then
3643 if Token = Tok_Range then
3644 Append (P_Subtype_Indication (Expr_Node), Choices);
3646 elsif Token in Token_Class_Consk then
3648 ("the only constraint allowed here " &
3649 "is a range constraint");
3650 Discard_Junk_Node (P_Constraint_Opt);
3651 Append (Expr_Node, Choices);
3654 Append (Expr_Node, Choices);
3660 -- If extensions are permitted then the expression must be a
3661 -- simple expression. The resaon for this restriction (i.e.
3662 -- going back to the Ada 83 rule) is to avoid ambiguities
3663 -- when set membership operations are allowed, consider the
3666 -- when A in 1 .. 10 | 12 =>
3668 -- This is ambiguous without parentheses, so we require one
3669 -- of the following two parenthesized forms to disambuguate:
3671 -- one of the following:
3673 -- when (A in 1 .. 10 | 12) =>
3674 -- when (A in 1 .. 10) | 12 =>
3676 -- To solve this, if extensins are enabled, we disallow
3677 -- the use of membership operations in expressions in
3678 -- choices. Technically in the grammar, the expression
3679 -- must match the grammar for restricted expression.
3681 if Extensions_Allowed then
3682 Check_Restricted_Expression (Expr_Node);
3684 -- In Ada 83 mode, the syntax required a simple expression
3687 Check_Simple_Expression_In_Ada_83 (Expr_Node);
3690 Append (Expr_Node, Choices);
3694 when Error_Resync =>
3700 if Token = Tok_Comma then
3701 Error_Msg_SC (""","" should be ""'|""");
3703 exit when Token /= Tok_Vertical_Bar;
3706 Scan; -- past | or comma
3710 end P_Discrete_Choice_List;
3712 ----------------------------
3713 -- 3.8.1 Discrete Choice --
3714 ----------------------------
3716 -- Parsed by P_Discrete_Choice_List (3.8.1)
3718 ----------------------------------
3719 -- 3.9.1 Record Extension Part --
3720 ----------------------------------
3722 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
3724 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
3726 --------------------------------------
3727 -- 3.9.4 Interface Type Definition --
3728 --------------------------------------
3730 -- INTERFACE_TYPE_DEFINITION ::=
3731 -- [limited | task | protected | synchronized] interface
3732 -- [and INTERFACE_LIST]
3734 -- Error recovery: cannot raise Error_Resync
3736 function P_Interface_Type_Definition
3737 (Abstract_Present : Boolean) return Node_Id
3739 Typedef_Node : Node_Id;
3742 if Ada_Version < Ada_05 then
3743 Error_Msg_SP ("abstract interface is an Ada 2005 extension");
3744 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
3747 if Abstract_Present then
3748 Error_Msg_SP ("ABSTRACT not allowed in interface type definition " &
3752 Scan; -- past INTERFACE
3754 -- Ada 2005 (AI-345): In case of interfaces with a null list of
3755 -- interfaces we build a record_definition node.
3757 if Token = Tok_Semicolon then
3758 Typedef_Node := New_Node (N_Record_Definition, Token_Ptr);
3760 Set_Abstract_Present (Typedef_Node);
3761 Set_Tagged_Present (Typedef_Node);
3762 Set_Null_Present (Typedef_Node);
3763 Set_Interface_Present (Typedef_Node);
3765 -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have
3766 -- a list of interfaces we build a derived_type_definition node. This
3767 -- simplifies the semantic analysis (and hence further maintenance)
3770 if Token /= Tok_And then
3771 Error_Msg_AP ("AND expected");
3776 Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
3778 Set_Abstract_Present (Typedef_Node);
3779 Set_Interface_Present (Typedef_Node);
3780 Set_Subtype_Indication (Typedef_Node, P_Qualified_Simple_Name);
3782 Set_Record_Extension_Part (Typedef_Node,
3783 New_Node (N_Record_Definition, Token_Ptr));
3784 Set_Null_Present (Record_Extension_Part (Typedef_Node));
3786 if Token = Tok_And then
3787 Set_Interface_List (Typedef_Node, New_List);
3791 Append (P_Qualified_Simple_Name,
3792 Interface_List (Typedef_Node));
3793 exit when Token /= Tok_And;
3799 return Typedef_Node;
3800 end P_Interface_Type_Definition;
3802 ----------------------------------
3803 -- 3.10 Access Type Definition --
3804 ----------------------------------
3806 -- ACCESS_TYPE_DEFINITION ::=
3807 -- ACCESS_TO_OBJECT_DEFINITION
3808 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3810 -- ACCESS_TO_OBJECT_DEFINITION ::=
3811 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
3813 -- GENERAL_ACCESS_MODIFIER ::= all | constant
3815 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3816 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3817 -- | [NULL_EXCLUSION] access [protected] function
3818 -- PARAMETER_AND_RESULT_PROFILE
3820 -- PARAMETER_PROFILE ::= [FORMAL_PART]
3822 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
3824 -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already
3825 -- parsed the null_exclusion part and has also removed the ACCESS token;
3826 -- otherwise the caller has just checked that the initial token is ACCESS
3828 -- Error recovery: can raise Error_Resync
3830 function P_Access_Type_Definition
3831 (Header_Already_Parsed : Boolean := False) return Node_Id
3833 Access_Loc : constant Source_Ptr := Token_Ptr;
3834 Prot_Flag : Boolean;
3835 Not_Null_Present : Boolean := False;
3836 Type_Def_Node : Node_Id;
3837 Result_Not_Null : Boolean;
3838 Result_Node : Node_Id;
3840 procedure Check_Junk_Subprogram_Name;
3841 -- Used in access to subprogram definition cases to check for an
3842 -- identifier or operator symbol that does not belong.
3844 --------------------------------
3845 -- Check_Junk_Subprogram_Name --
3846 --------------------------------
3848 procedure Check_Junk_Subprogram_Name is
3849 Saved_State : Saved_Scan_State;
3852 if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
3853 Save_Scan_State (Saved_State);
3854 Scan; -- past possible junk subprogram name
3856 if Token = Tok_Left_Paren or else Token = Tok_Semicolon then
3857 Error_Msg_SP ("unexpected subprogram name ignored");
3861 Restore_Scan_State (Saved_State);
3864 end Check_Junk_Subprogram_Name;
3866 -- Start of processing for P_Access_Type_Definition
3869 if not Header_Already_Parsed then
3870 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
3871 Scan; -- past ACCESS
3874 if Token_Name = Name_Protected then
3875 Check_95_Keyword (Tok_Protected, Tok_Procedure);
3876 Check_95_Keyword (Tok_Protected, Tok_Function);
3879 Prot_Flag := (Token = Tok_Protected);
3882 Scan; -- past PROTECTED
3884 if Token /= Tok_Procedure and then Token /= Tok_Function then
3885 Error_Msg_SC -- CODEFIX
3886 ("FUNCTION or PROCEDURE expected");
3890 if Token = Tok_Procedure then
3891 if Ada_Version = Ada_83 then
3892 Error_Msg_SC ("(Ada 83) access to procedure not allowed!");
3895 Type_Def_Node := New_Node (N_Access_Procedure_Definition, Access_Loc);
3896 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3897 Scan; -- past PROCEDURE
3898 Check_Junk_Subprogram_Name;
3899 Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
3900 Set_Protected_Present (Type_Def_Node, Prot_Flag);
3902 elsif Token = Tok_Function then
3903 if Ada_Version = Ada_83 then
3904 Error_Msg_SC ("(Ada 83) access to function not allowed!");
3907 Type_Def_Node := New_Node (N_Access_Function_Definition, Access_Loc);
3908 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3909 Scan; -- past FUNCTION
3910 Check_Junk_Subprogram_Name;
3911 Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
3912 Set_Protected_Present (Type_Def_Node, Prot_Flag);
3915 Result_Not_Null := P_Null_Exclusion; -- Ada 2005 (AI-231)
3917 -- Ada 2005 (AI-318-02)
3919 if Token = Tok_Access then
3920 if Ada_Version < Ada_05 then
3922 ("anonymous access result type is an Ada 2005 extension");
3923 Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
3926 Result_Node := P_Access_Definition (Result_Not_Null);
3929 Result_Node := P_Subtype_Mark;
3932 -- A null exclusion on the result type must be recorded in a flag
3933 -- distinct from the one used for the access-to-subprogram type's
3936 Set_Null_Exclusion_In_Return_Present
3937 (Type_Def_Node, Result_Not_Null);
3940 Set_Result_Definition (Type_Def_Node, Result_Node);
3944 New_Node (N_Access_To_Object_Definition, Access_Loc);
3945 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3947 if Token = Tok_All or else Token = Tok_Constant then
3948 if Ada_Version = Ada_83 then
3949 Error_Msg_SC ("(Ada 83) access modifier not allowed!");
3952 if Token = Tok_All then
3953 Set_All_Present (Type_Def_Node, True);
3956 Set_Constant_Present (Type_Def_Node, True);
3959 Scan; -- past ALL or CONSTANT
3962 Set_Subtype_Indication (Type_Def_Node,
3963 P_Subtype_Indication (Not_Null_Present));
3966 return Type_Def_Node;
3967 end P_Access_Type_Definition;
3969 ---------------------------------------
3970 -- 3.10 Access To Object Definition --
3971 ---------------------------------------
3973 -- Parsed by P_Access_Type_Definition (3.10)
3975 -----------------------------------
3976 -- 3.10 General Access Modifier --
3977 -----------------------------------
3979 -- Parsed by P_Access_Type_Definition (3.10)
3981 -------------------------------------------
3982 -- 3.10 Access To Subprogram Definition --
3983 -------------------------------------------
3985 -- Parsed by P_Access_Type_Definition (3.10)
3987 -----------------------------
3988 -- 3.10 Access Definition --
3989 -----------------------------
3991 -- ACCESS_DEFINITION ::=
3992 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3993 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3995 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3996 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3997 -- | [NULL_EXCLUSION] access [protected] function
3998 -- PARAMETER_AND_RESULT_PROFILE
4000 -- The caller has parsed the null-exclusion part and it has also checked
4001 -- that the next token is ACCESS
4003 -- Error recovery: cannot raise Error_Resync
4005 function P_Access_Definition
4006 (Null_Exclusion_Present : Boolean) return Node_Id
4009 Subp_Node : Node_Id;
4012 Def_Node := New_Node (N_Access_Definition, Token_Ptr);
4013 Scan; -- past ACCESS
4015 -- Ada 2005 (AI-254): Access_To_Subprogram_Definition
4017 if Token = Tok_Protected
4018 or else Token = Tok_Procedure
4019 or else Token = Tok_Function
4021 if Ada_Version < Ada_05 then
4022 Error_Msg_SP ("access-to-subprogram is an Ada 2005 extension");
4023 Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
4026 Subp_Node := P_Access_Type_Definition (Header_Already_Parsed => True);
4027 Set_Null_Exclusion_Present (Subp_Node, Null_Exclusion_Present);
4028 Set_Access_To_Subprogram_Definition (Def_Node, Subp_Node);
4030 -- Ada 2005 (AI-231)
4031 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
4034 Set_Null_Exclusion_Present (Def_Node, Null_Exclusion_Present);
4036 if Token = Tok_All then
4037 if Ada_Version < Ada_05 then
4039 ("ALL is not permitted for anonymous access types");
4043 Set_All_Present (Def_Node);
4045 elsif Token = Tok_Constant then
4046 if Ada_Version < Ada_05 then
4047 Error_Msg_SP ("access-to-constant is an Ada 2005 extension");
4048 Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
4051 Scan; -- past CONSTANT
4052 Set_Constant_Present (Def_Node);
4055 Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
4060 end P_Access_Definition;
4062 -----------------------------------------
4063 -- 3.10.1 Incomplete Type Declaration --
4064 -----------------------------------------
4066 -- Parsed by P_Type_Declaration (3.2.1)
4068 ----------------------------
4069 -- 3.11 Declarative Part --
4070 ----------------------------
4072 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
4074 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items
4075 -- handles errors, and returns cleanly after an error has occurred)
4077 function P_Declarative_Part return List_Id is
4082 -- Indicate no bad declarations detected yet. This will be reset by
4083 -- P_Declarative_Items if a bad declaration is discovered.
4085 Missing_Begin_Msg := No_Error_Msg;
4087 -- Get rid of active SIS entry from outer scope. This means we will
4088 -- miss some nested cases, but it doesn't seem worth the effort. See
4089 -- discussion in Par for further details
4091 SIS_Entry_Active := False;
4094 -- Loop to scan out the declarations
4097 P_Declarative_Items (Decls, Done, In_Spec => False);
4101 -- Get rid of active SIS entry which is left set only if we scanned a
4102 -- procedure declaration and have not found the body. We could give
4103 -- an error message, but that really would be usurping the role of
4104 -- semantic analysis (this really is a missing body case).
4106 SIS_Entry_Active := False;
4108 end P_Declarative_Part;
4110 ----------------------------
4111 -- 3.11 Declarative Item --
4112 ----------------------------
4114 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
4116 -- Can return Error if a junk declaration is found, or Empty if no
4117 -- declaration is found (i.e. a token ending declarations, such as
4118 -- BEGIN or END is encountered).
4120 -- Error recovery: cannot raise Error_Resync. If an error resync occurs,
4121 -- then the scan is set past the next semicolon and Error is returned.
4123 procedure P_Declarative_Items
4128 Scan_State : Saved_Scan_State;
4132 Style.Check_Indentation;
4137 when Tok_Function =>
4139 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4145 -- Check for loop (premature statement)
4147 Save_Scan_State (Scan_State);
4150 if Token = Tok_Identifier then
4151 Scan; -- past identifier
4153 if Token = Tok_In then
4154 Restore_Scan_State (Scan_State);
4155 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
4160 -- Not a loop, so must be rep clause
4162 Restore_Scan_State (Scan_State);
4163 Append (P_Representation_Clause, Decls);
4168 Append (P_Generic, Decls);
4171 when Tok_Identifier =>
4174 -- Special check for misuse of overriding not in Ada 2005 mode
4176 if Token_Name = Name_Overriding
4177 and then not Next_Token_Is (Tok_Colon)
4179 Error_Msg_SC ("overriding indicator is an Ada 2005 extension");
4180 Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
4182 Token := Tok_Overriding;
4183 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4186 -- Normal case, no overriding, or overriding followed by colon
4189 P_Identifier_Declarations (Decls, Done, In_Spec);
4192 -- Ada2005: A subprogram declaration can start with "not" or
4193 -- "overriding". In older versions, "overriding" is handled
4194 -- like an identifier, with the appropriate messages.
4198 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4201 when Tok_Overriding =>
4203 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4208 Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4212 Append (P_Pragma, Decls);
4215 when Tok_Procedure =>
4217 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4220 when Tok_Protected =>
4222 Scan; -- past PROTECTED
4223 Append (P_Protected, Decls);
4228 Append (P_Subtype_Declaration, Decls);
4234 Append (P_Task, Decls);
4239 Append (P_Type_Declaration, Decls);
4244 Append (P_Use_Clause, Decls);
4249 Error_Msg_SC ("WITH can only appear in context clause");
4252 -- BEGIN terminates the scan of a sequence of declarations unless
4253 -- there is a missing subprogram body, see section on handling
4254 -- semicolon in place of IS. We only treat the begin as satisfying
4255 -- the subprogram declaration if it falls in the expected column
4259 if SIS_Entry_Active and then Start_Column >= SIS_Ecol then
4261 -- Here we have the case where a BEGIN is encountered during
4262 -- declarations in a declarative part, or at the outer level,
4263 -- and there is a subprogram declaration outstanding for which
4264 -- no body has been supplied. This is the case where we assume
4265 -- that the semicolon in the subprogram declaration should
4266 -- really have been is. The active SIS entry describes the
4267 -- subprogram declaration. On return the declaration has been
4268 -- modified to become a body.
4271 Specification_Node : Node_Id;
4272 Decl_Node : Node_Id;
4273 Body_Node : Node_Id;
4276 -- First issue the error message. If we had a missing
4277 -- semicolon in the declaration, then change the message
4278 -- to <missing "is">
4280 if SIS_Missing_Semicolon_Message /= No_Error_Msg then
4281 Change_Error_Text -- Replace: "missing "";"" "
4282 (SIS_Missing_Semicolon_Message, "missing ""is""");
4284 -- Otherwise we saved the semicolon position, so complain
4287 Error_Msg ("|"";"" should be IS", SIS_Semicolon_Sloc);
4290 -- The next job is to fix up any declarations that occurred
4291 -- between the procedure header and the BEGIN. These got
4292 -- chained to the outer declarative region (immediately
4293 -- after the procedure declaration) and they should be
4294 -- chained to the subprogram itself, which is a body
4295 -- rather than a spec.
4297 Specification_Node := Specification (SIS_Declaration_Node);
4298 Change_Node (SIS_Declaration_Node, N_Subprogram_Body);
4299 Body_Node := SIS_Declaration_Node;
4300 Set_Specification (Body_Node, Specification_Node);
4301 Set_Declarations (Body_Node, New_List);
4304 Decl_Node := Remove_Next (Body_Node);
4305 exit when Decl_Node = Empty;
4306 Append (Decl_Node, Declarations (Body_Node));
4309 -- Now make the scope table entry for the Begin-End and
4313 Scope.Table (Scope.Last).Sloc := SIS_Sloc;
4314 Scope.Table (Scope.Last).Etyp := E_Name;
4315 Scope.Table (Scope.Last).Ecol := SIS_Ecol;
4316 Scope.Table (Scope.Last).Labl := SIS_Labl;
4317 Scope.Table (Scope.Last).Lreq := False;
4318 SIS_Entry_Active := False;
4320 Set_Handled_Statement_Sequence (Body_Node,
4321 P_Handled_Sequence_Of_Statements);
4322 End_Statements (Handled_Statement_Sequence (Body_Node));
4331 -- Normally an END terminates the scan for basic declarative
4332 -- items. The one exception is END RECORD, which is probably
4333 -- left over from some other junk.
4336 Save_Scan_State (Scan_State); -- at END
4339 if Token = Tok_Record then
4340 Error_Msg_SP ("no RECORD for this `end record`!");
4341 Scan; -- past RECORD
4345 Restore_Scan_State (Scan_State); -- to END
4349 -- The following tokens which can only be the start of a statement
4350 -- are considered to end a declarative part (i.e. we have a missing
4351 -- BEGIN situation). We are fairly conservative in making this
4352 -- judgment, because it is a real mess to go into statement mode
4353 -- prematurely in response to a junk declaration.
4368 -- But before we decide that it's a statement, let's check for
4369 -- a reserved word misused as an identifier.
4371 if Is_Reserved_Identifier then
4372 Save_Scan_State (Scan_State);
4373 Scan; -- past the token
4375 -- If reserved identifier not followed by colon or comma, then
4376 -- this is most likely an assignment statement to the bad id.
4378 if Token /= Tok_Colon and then Token /= Tok_Comma then
4379 Restore_Scan_State (Scan_State);
4380 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
4383 -- Otherwise we have a declaration of the bad id
4386 Restore_Scan_State (Scan_State);
4387 Scan_Reserved_Identifier (Force_Msg => True);
4388 P_Identifier_Declarations (Decls, Done, In_Spec);
4391 -- If not reserved identifier, then it's definitely a statement
4394 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
4398 -- The token RETURN may well also signal a missing BEGIN situation,
4399 -- however, we never let it end the declarative part, because it may
4400 -- also be part of a half-baked function declaration.
4403 Error_Msg_SC ("misplaced RETURN statement");
4406 -- PRIVATE definitely terminates the declarations in a spec,
4407 -- and is an error in a body.
4413 Error_Msg_SC ("PRIVATE not allowed in body");
4414 Scan; -- past PRIVATE
4417 -- An end of file definitely terminates the declarations!
4422 -- The remaining tokens do not end the scan, but cannot start a
4423 -- valid declaration, so we signal an error and resynchronize.
4424 -- But first check for misuse of a reserved identifier.
4428 -- Here we check for a reserved identifier
4430 if Is_Reserved_Identifier then
4431 Save_Scan_State (Scan_State);
4432 Scan; -- past the token
4434 if Token /= Tok_Colon and then Token /= Tok_Comma then
4435 Restore_Scan_State (Scan_State);
4436 Set_Declaration_Expected;
4439 Restore_Scan_State (Scan_State);
4440 Scan_Reserved_Identifier (Force_Msg => True);
4442 P_Identifier_Declarations (Decls, Done, In_Spec);
4446 Set_Declaration_Expected;
4451 -- To resynchronize after an error, we scan to the next semicolon and
4452 -- return with Done = False, indicating that there may still be more
4453 -- valid declarations to come.
4456 when Error_Resync =>
4457 Resync_Past_Semicolon;
4459 end P_Declarative_Items;
4461 ----------------------------------
4462 -- 3.11 Basic Declarative Item --
4463 ----------------------------------
4465 -- BASIC_DECLARATIVE_ITEM ::=
4466 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
4468 -- Scan zero or more basic declarative items
4470 -- Error recovery: cannot raise Error_Resync. If an error is detected, then
4471 -- the scan pointer is repositioned past the next semicolon, and the scan
4472 -- for declarative items continues.
4474 function P_Basic_Declarative_Items return List_Id is
4481 -- Indicate no bad declarations detected yet in the current context:
4482 -- visible or private declarations of a package spec.
4484 Missing_Begin_Msg := No_Error_Msg;
4486 -- Get rid of active SIS entry from outer scope. This means we will
4487 -- miss some nested cases, but it doesn't seem worth the effort. See
4488 -- discussion in Par for further details
4490 SIS_Entry_Active := False;
4492 -- Loop to scan out declarations
4497 P_Declarative_Items (Decls, Done, In_Spec => True);
4501 -- Get rid of active SIS entry. This is set only if we have scanned a
4502 -- procedure declaration and have not found the body. We could give
4503 -- an error message, but that really would be usurping the role of
4504 -- semantic analysis (this really is a case of a missing body).
4506 SIS_Entry_Active := False;
4508 -- Test for assorted illegal declarations not diagnosed elsewhere
4510 Decl := First (Decls);
4512 while Present (Decl) loop
4513 Kind := Nkind (Decl);
4515 -- Test for body scanned, not acceptable as basic decl item
4517 if Kind = N_Subprogram_Body or else
4518 Kind = N_Package_Body or else
4519 Kind = N_Task_Body or else
4520 Kind = N_Protected_Body
4523 ("proper body not allowed in package spec", Sloc (Decl));
4525 -- Test for body stub scanned, not acceptable as basic decl item
4527 elsif Kind in N_Body_Stub then
4529 ("body stub not allowed in package spec", Sloc (Decl));
4531 elsif Kind = N_Assignment_Statement then
4533 ("assignment statement not allowed in package spec",
4541 end P_Basic_Declarative_Items;
4547 -- For proper body, see below
4548 -- For body stub, see 10.1.3
4550 -----------------------
4551 -- 3.11 Proper Body --
4552 -----------------------
4554 -- Subprogram body is parsed by P_Subprogram (6.1)
4555 -- Package body is parsed by P_Package (7.1)
4556 -- Task body is parsed by P_Task (9.1)
4557 -- Protected body is parsed by P_Protected (9.4)
4559 ------------------------------
4560 -- Set_Declaration_Expected --
4561 ------------------------------
4563 procedure Set_Declaration_Expected is
4565 Error_Msg_SC ("declaration expected");
4567 if Missing_Begin_Msg = No_Error_Msg then
4568 Missing_Begin_Msg := Get_Msg_Id;
4570 end Set_Declaration_Expected;
4572 ----------------------
4573 -- Skip_Declaration --
4574 ----------------------
4576 procedure Skip_Declaration (S : List_Id) is
4577 Dummy_Done : Boolean;
4578 pragma Warnings (Off, Dummy_Done);
4580 P_Declarative_Items (S, Dummy_Done, False);
4581 end Skip_Declaration;
4583 -----------------------------------------
4584 -- Statement_When_Declaration_Expected --
4585 -----------------------------------------
4587 procedure Statement_When_Declaration_Expected
4593 -- Case of second occurrence of statement in one declaration sequence
4595 if Missing_Begin_Msg /= No_Error_Msg then
4597 -- In the procedure spec case, just ignore it, we only give one
4598 -- message for the first occurrence, since otherwise we may get
4599 -- horrible cascading if BODY was missing in the header line.
4604 -- In the declarative part case, take a second statement as a sure
4605 -- sign that we really have a missing BEGIN, and end the declarative
4606 -- part now. Note that the caller will fix up the first message to
4607 -- say "missing BEGIN" so that's how the error will be signalled.
4614 -- Case of first occurrence of unexpected statement
4617 -- If we are in a package spec, then give message of statement
4618 -- not allowed in package spec. This message never gets changed.
4621 Error_Msg_SC ("statement not allowed in package spec");
4623 -- If in declarative part, then we give the message complaining
4624 -- about finding a statement when a declaration is expected. This
4625 -- gets changed to a complaint about a missing BEGIN if we later
4626 -- find that no BEGIN is present.
4629 Error_Msg_SC ("statement not allowed in declarative part");
4632 -- Capture message Id. This is used for two purposes, first to
4633 -- stop multiple messages, see test above, and second, to allow
4634 -- the replacement of the message in the declarative part case.
4636 Missing_Begin_Msg := Get_Msg_Id;
4639 -- In all cases except the case in which we decided to terminate the
4640 -- declaration sequence on a second error, we scan out the statement
4641 -- and append it to the list of declarations (note that the semantics
4642 -- can handle statements in a declaration list so if we proceed to
4643 -- call the semantic phase, all will be (reasonably) well!
4645 Append_List_To (Decls, P_Sequence_Of_Statements (SS_Unco));
4647 -- Done is set to False, since we want to continue the scan of
4648 -- declarations, hoping that this statement was a temporary glitch.
4649 -- If we indeed are now in the statement part (i.e. this was a missing
4650 -- BEGIN, then it's not terrible, we will simply keep calling this
4651 -- procedure to process the statements one by one, and then finally
4652 -- hit the missing BEGIN, which will clean up the error message.
4655 end Statement_When_Declaration_Expected;