1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, 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;
36 -----------------------
37 -- Local Subprograms --
38 -----------------------
40 function P_Component_List return Node_Id;
41 function P_Defining_Character_Literal return Node_Id;
42 function P_Delta_Constraint return Node_Id;
43 function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id;
44 function P_Digits_Constraint return Node_Id;
45 function P_Discriminant_Association return Node_Id;
46 function P_Enumeration_Literal_Specification return Node_Id;
47 function P_Enumeration_Type_Definition return Node_Id;
48 function P_Fixed_Point_Definition return Node_Id;
49 function P_Floating_Point_Definition return Node_Id;
50 function P_Index_Or_Discriminant_Constraint return Node_Id;
51 function P_Real_Range_Specification_Opt return Node_Id;
52 function P_Subtype_Declaration return Node_Id;
53 function P_Type_Declaration return Node_Id;
54 function P_Modular_Type_Definition return Node_Id;
55 function P_Variant return Node_Id;
56 function P_Variant_Part return Node_Id;
58 procedure P_Declarative_Items
62 -- Scans out a single declarative item, or, in the case of a declaration
63 -- with a list of identifiers, a list of declarations, one for each of the
64 -- identifiers in the list. The declaration or declarations scanned are
65 -- appended to the given list. Done indicates whether or not there may be
66 -- additional declarative items to scan. If Done is True, then a decision
67 -- has been made that there are no more items to scan. If Done is False,
68 -- then there may be additional declarations to scan. In_Spec is true if
69 -- we are scanning a package declaration, and is used to generate an
70 -- appropriate message if a statement is encountered in such a context.
72 procedure P_Identifier_Declarations
76 -- Scans out a set of declarations for an identifier or list of
77 -- identifiers, and appends them to the given list. The parameters have
78 -- the same significance as for P_Declarative_Items.
80 procedure Statement_When_Declaration_Expected
84 -- Called when a statement is found at a point where a declaration was
85 -- expected. The parameters are as described for P_Declarative_Items.
87 procedure Set_Declaration_Expected;
88 -- Posts a "declaration expected" error messages at the start of the
89 -- current token, and if this is the first such message issued, saves
90 -- the message id in Missing_Begin_Msg, for possible later replacement.
96 function Init_Expr_Opt (P : Boolean := False) return Node_Id is
98 -- For colon, assume it means := unless it is at the end of
99 -- a line, in which case guess that it means a semicolon.
101 if Token = Tok_Colon then
102 if Token_Is_At_End_Of_Line then
107 -- Here if := or something that we will take as equivalent
109 elsif Token = Tok_Colon_Equal
110 or else Token = Tok_Equal
111 or else Token = Tok_Is
115 -- Another possibility. If we have a literal followed by a semicolon,
116 -- we assume that we have a missing colon-equal.
118 elsif Token in Token_Class_Literal then
120 Scan_State : Saved_Scan_State;
123 Save_Scan_State (Scan_State);
124 Scan; -- past literal or identifier
126 if Token = Tok_Semicolon then
127 Restore_Scan_State (Scan_State);
129 Restore_Scan_State (Scan_State);
134 -- Otherwise we definitely have no initialization expression
140 -- Merge here if we have an initialization expression
147 return P_Expression_No_Right_Paren;
151 ----------------------------
152 -- 3.1 Basic Declaration --
153 ----------------------------
155 -- Parsed by P_Basic_Declarative_Items (3.9)
157 ------------------------------
158 -- 3.1 Defining Identifier --
159 ------------------------------
161 -- DEFINING_IDENTIFIER ::= IDENTIFIER
163 -- Error recovery: can raise Error_Resync
165 function P_Defining_Identifier (C : Id_Check := None) return Node_Id is
166 Ident_Node : Node_Id;
169 -- Scan out the identifier. Note that this code is essentially identical
170 -- to P_Identifier, except that in the call to Scan_Reserved_Identifier
171 -- we set Force_Msg to True, since we want at least one message for each
172 -- separate declaration (but not use) of a reserved identifier.
174 if Token = Tok_Identifier then
176 -- Ada 2005 (AI-284): Compiling in Ada95 mode we warn that INTERFACE,
177 -- OVERRIDING, and SYNCHRONIZED are new reserved words.
179 if Ada_Version = Ada_95
180 and then Warn_On_Ada_2005_Compatibility
182 if Token_Name = Name_Overriding
183 or else Token_Name = Name_Synchronized
184 or else (Token_Name = Name_Interface
185 and then Prev_Token /= Tok_Pragma)
187 Error_Msg_N ("& is a reserved word in Ada 2005?", Token_Node);
191 -- If we have a reserved identifier, manufacture an identifier with
192 -- a corresponding name after posting an appropriate error message
194 elsif Is_Reserved_Identifier (C) then
195 Scan_Reserved_Identifier (Force_Msg => True);
197 -- Otherwise we have junk that cannot be interpreted as an identifier
200 T_Identifier; -- to give message
204 Ident_Node := Token_Node;
205 Scan; -- past the reserved identifier
207 if Ident_Node /= Error then
208 Change_Identifier_To_Defining_Identifier (Ident_Node);
212 end P_Defining_Identifier;
214 -----------------------------
215 -- 3.2.1 Type Declaration --
216 -----------------------------
218 -- TYPE_DECLARATION ::=
219 -- FULL_TYPE_DECLARATION
220 -- | INCOMPLETE_TYPE_DECLARATION
221 -- | PRIVATE_TYPE_DECLARATION
222 -- | PRIVATE_EXTENSION_DECLARATION
224 -- FULL_TYPE_DECLARATION ::=
225 -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION;
226 -- | CONCURRENT_TYPE_DECLARATION
228 -- INCOMPLETE_TYPE_DECLARATION ::=
229 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [is tagged];
231 -- PRIVATE_TYPE_DECLARATION ::=
232 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
233 -- is [abstract] [tagged] [limited] private;
235 -- PRIVATE_EXTENSION_DECLARATION ::=
236 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
237 -- [abstract] [limited | synchronized]
238 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
241 -- TYPE_DEFINITION ::=
242 -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
243 -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION
244 -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION
245 -- | DERIVED_TYPE_DEFINITION | INTERFACE_TYPE_DEFINITION
247 -- INTEGER_TYPE_DEFINITION ::=
248 -- SIGNED_INTEGER_TYPE_DEFINITION
249 -- MODULAR_TYPE_DEFINITION
251 -- INTERFACE_TYPE_DEFINITION ::=
252 -- [limited | task | protected | synchronized ] interface
253 -- [and INTERFACE_LIST]
255 -- Error recovery: can raise Error_Resync
257 -- Note: The processing for full type declaration, incomplete type
258 -- declaration, private type declaration and type definition is
259 -- included in this function. The processing for concurrent type
260 -- declarations is NOT here, but rather in chapter 9 (i.e. this
261 -- function handles only declarations starting with TYPE).
263 function P_Type_Declaration return Node_Id is
264 Abstract_Present : Boolean := False;
265 Abstract_Loc : Source_Ptr := No_Location;
267 Discr_List : List_Id;
268 Discr_Sloc : Source_Ptr;
270 Ident_Node : Node_Id;
271 Is_Derived_Iface : Boolean := False;
272 Type_Loc : Source_Ptr;
273 Type_Start_Col : Column_Number;
274 Unknown_Dis : Boolean;
276 Typedef_Node : Node_Id;
277 -- Normally holds type definition, except in the case of a private
278 -- extension declaration, in which case it holds the declaration itself
281 Type_Loc := Token_Ptr;
282 Type_Start_Col := Start_Column;
284 -- If we have TYPE, then proceed ahead and scan identifier
286 if Token = Tok_Type then
287 Type_Token_Location := Type_Loc;
289 Ident_Node := P_Defining_Identifier (C_Is);
291 -- Otherwise this is an error case, and we may already have converted
292 -- the current token to a defining identifier, so don't do it again!
297 if Token = Tok_Identifier
298 and then Nkind (Token_Node) = N_Defining_Identifier
300 Ident_Node := Token_Node;
301 Scan; -- past defining identifier
303 Ident_Node := P_Defining_Identifier (C_Is);
307 Discr_Sloc := Token_Ptr;
309 if P_Unknown_Discriminant_Part_Opt then
311 Discr_List := No_List;
313 Unknown_Dis := False;
314 Discr_List := P_Known_Discriminant_Part_Opt;
317 -- Incomplete type declaration. We complete the processing for this
318 -- case here and return the resulting incomplete type declaration node
320 if Token = Tok_Semicolon then
322 Decl_Node := New_Node (N_Incomplete_Type_Declaration, Type_Loc);
323 Set_Defining_Identifier (Decl_Node, Ident_Node);
324 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
325 Set_Discriminant_Specifications (Decl_Node, Discr_List);
332 -- Full type declaration or private type declaration, must have IS
334 if Token = Tok_Equal then
336 Scan; -- past = used in place of IS
338 elsif Token = Tok_Renames then
339 Error_Msg_SC ("RENAMES should be IS");
340 Scan; -- past RENAMES used in place of IS
346 -- First an error check, if we have two identifiers in a row, a likely
347 -- possibility is that the first of the identifiers is an incorrectly
350 if Token = Tok_Identifier then
352 SS : Saved_Scan_State;
356 Save_Scan_State (SS);
357 Scan; -- past initial identifier
358 I2 := (Token = Tok_Identifier);
359 Restore_Scan_State (SS);
363 (Bad_Spelling_Of (Tok_Abstract) or else
364 Bad_Spelling_Of (Tok_Access) or else
365 Bad_Spelling_Of (Tok_Aliased) or else
366 Bad_Spelling_Of (Tok_Constant))
373 -- Check for misuse of Ada 95 keyword abstract in Ada 83 mode
375 if Token_Name = Name_Abstract then
376 Check_95_Keyword (Tok_Abstract, Tok_Tagged);
377 Check_95_Keyword (Tok_Abstract, Tok_New);
380 -- Check cases of misuse of ABSTRACT
382 if Token = Tok_Abstract then
383 Abstract_Present := True;
384 Abstract_Loc := Token_Ptr;
385 Scan; -- past ABSTRACT
387 -- Ada 2005 (AI-419): AARM 3.4 (2/2)
389 if (Ada_Version < Ada_05 and then Token = Tok_Limited)
390 or else Token = Tok_Private
391 or else Token = Tok_Record
392 or else Token = Tok_Null
394 Error_Msg_AP ("TAGGED expected");
398 -- Check for misuse of Ada 95 keyword Tagged
400 if Token_Name = Name_Tagged then
401 Check_95_Keyword (Tok_Tagged, Tok_Private);
402 Check_95_Keyword (Tok_Tagged, Tok_Limited);
403 Check_95_Keyword (Tok_Tagged, Tok_Record);
406 -- Special check for misuse of Aliased
408 if Token = Tok_Aliased or else Token_Name = Name_Aliased then
409 Error_Msg_SC ("ALIASED not allowed in type definition");
410 Scan; -- past ALIASED
413 -- The following procesing deals with either a private type declaration
414 -- or a full type declaration. In the private type case, we build the
415 -- N_Private_Type_Declaration node, setting its Tagged_Present and
416 -- Limited_Present flags, on encountering the Private keyword, and
417 -- leave Typedef_Node set to Empty. For the full type declaration
418 -- case, Typedef_Node gets set to the type definition.
420 Typedef_Node := Empty;
422 -- Switch on token following the IS. The loop normally runs once. It
423 -- only runs more than once if an error is detected, to try again after
424 -- detecting and fixing up the error.
430 Tok_Not => -- Ada 2005 (AI-231)
431 Typedef_Node := P_Access_Type_Definition;
436 Typedef_Node := P_Array_Type_Definition;
441 Typedef_Node := P_Fixed_Point_Definition;
446 Typedef_Node := P_Floating_Point_Definition;
453 when Tok_Integer_Literal =>
455 Typedef_Node := P_Signed_Integer_Type_Definition;
460 Typedef_Node := P_Record_Definition;
464 when Tok_Left_Paren =>
465 Typedef_Node := P_Enumeration_Type_Definition;
468 Make_Identifier (Token_Ptr,
469 Chars => Chars (Ident_Node));
470 Set_Comes_From_Source (End_Labl, False);
472 Set_End_Label (Typedef_Node, End_Labl);
477 Typedef_Node := P_Modular_Type_Definition;
482 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
484 if Nkind (Typedef_Node) = N_Derived_Type_Definition
485 and then Present (Record_Extension_Part (Typedef_Node))
488 Make_Identifier (Token_Ptr,
489 Chars => Chars (Ident_Node));
490 Set_Comes_From_Source (End_Labl, False);
493 (Record_Extension_Part (Typedef_Node), End_Labl);
500 Typedef_Node := P_Signed_Integer_Type_Definition;
505 Typedef_Node := P_Record_Definition;
508 Make_Identifier (Token_Ptr,
509 Chars => Chars (Ident_Node));
510 Set_Comes_From_Source (End_Labl, False);
512 Set_End_Label (Typedef_Node, End_Labl);
519 -- Ada 2005 (AI-326): If the words IS TAGGED appear, the type
520 -- is a tagged incomplete type.
522 if Ada_Version >= Ada_05
523 and then Token = Tok_Semicolon
528 New_Node (N_Incomplete_Type_Declaration, Type_Loc);
529 Set_Defining_Identifier (Decl_Node, Ident_Node);
530 Set_Tagged_Present (Decl_Node);
531 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
532 Set_Discriminant_Specifications (Decl_Node, Discr_List);
537 if Token = Tok_Abstract then
538 Error_Msg_SC ("ABSTRACT must come before TAGGED");
539 Abstract_Present := True;
540 Abstract_Loc := Token_Ptr;
541 Scan; -- past ABSTRACT
544 if Token = Tok_Limited then
545 Scan; -- past LIMITED
547 -- TAGGED LIMITED PRIVATE case
549 if Token = Tok_Private then
551 New_Node (N_Private_Type_Declaration, Type_Loc);
552 Set_Tagged_Present (Decl_Node, True);
553 Set_Limited_Present (Decl_Node, True);
554 Scan; -- past PRIVATE
556 -- TAGGED LIMITED RECORD
559 Typedef_Node := P_Record_Definition;
560 Set_Tagged_Present (Typedef_Node, True);
561 Set_Limited_Present (Typedef_Node, True);
564 Make_Identifier (Token_Ptr,
565 Chars => Chars (Ident_Node));
566 Set_Comes_From_Source (End_Labl, False);
568 Set_End_Label (Typedef_Node, End_Labl);
574 if Token = Tok_Private then
576 New_Node (N_Private_Type_Declaration, Type_Loc);
577 Set_Tagged_Present (Decl_Node, True);
578 Scan; -- past PRIVATE
583 Typedef_Node := P_Record_Definition;
584 Set_Tagged_Present (Typedef_Node, True);
587 Make_Identifier (Token_Ptr,
588 Chars => Chars (Ident_Node));
589 Set_Comes_From_Source (End_Labl, False);
591 Set_End_Label (Typedef_Node, End_Labl);
599 Scan; -- past LIMITED
602 if Token = Tok_Tagged then
603 Error_Msg_SC ("TAGGED must come before LIMITED");
606 elsif Token = Tok_Abstract then
607 Error_Msg_SC ("ABSTRACT must come before LIMITED");
608 Scan; -- past ABSTRACT
615 -- LIMITED RECORD or LIMITED NULL RECORD
617 if Token = Tok_Record or else Token = Tok_Null then
618 if Ada_Version = Ada_83 then
620 ("(Ada 83) limited record declaration not allowed!");
623 Typedef_Node := P_Record_Definition;
624 Set_Limited_Present (Typedef_Node, True);
626 -- Ada 2005 (AI-251): LIMITED INTERFACE
628 -- If we are compiling in Ada 83 or Ada 95 mode, "interface"
629 -- is not a reserved word but we force its analysis to
630 -- generate the corresponding usage error.
632 elsif Token = Tok_Interface
633 or else (Token = Tok_Identifier
634 and then Chars (Token_Node) = Name_Interface)
637 P_Interface_Type_Definition (Abstract_Present);
638 Abstract_Present := True;
639 Set_Limited_Present (Typedef_Node);
641 if Nkind (Typedef_Node) = N_Derived_Type_Definition then
642 Is_Derived_Iface := True;
645 -- Ada 2005 (AI-419): LIMITED NEW
647 elsif Token = Tok_New then
648 if Ada_Version < Ada_05 then
650 ("LIMITED in derived type is an Ada 2005 extension");
652 ("\unit must be compiled with -gnat05 switch");
655 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
656 Set_Limited_Present (Typedef_Node);
658 if Nkind (Typedef_Node) = N_Derived_Type_Definition
659 and then Present (Record_Extension_Part (Typedef_Node))
662 Make_Identifier (Token_Ptr,
663 Chars => Chars (Ident_Node));
664 Set_Comes_From_Source (End_Labl, False);
667 (Record_Extension_Part (Typedef_Node), End_Labl);
670 -- LIMITED PRIVATE is the only remaining possibility here
673 Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
674 Set_Limited_Present (Decl_Node, True);
675 T_Private; -- past PRIVATE (or complain if not there!)
681 -- Here we have an identifier after the IS, which is certainly
682 -- wrong and which might be one of several different mistakes.
684 when Tok_Identifier =>
686 -- First case, if identifier is on same line, then probably we
687 -- have something like "type X is Integer .." and the best
688 -- diagnosis is a missing NEW. Note: the missing new message
689 -- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl.
691 if not Token_Is_At_Start_Of_Line then
692 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
695 -- If the identifier is at the start of the line, and is in the
696 -- same column as the type declaration itself then we consider
697 -- that we had a missing type definition on the previous line
699 elsif Start_Column <= Type_Start_Col then
700 Error_Msg_AP ("type definition expected");
701 Typedef_Node := Error;
703 -- If the identifier is at the start of the line, and is in
704 -- a column to the right of the type declaration line, then we
705 -- may have something like:
710 -- and the best diagnosis is a missing record keyword
713 Typedef_Node := P_Record_Definition;
719 -- Ada 2005 (AI-251): INTERFACE
721 when Tok_Interface =>
722 Typedef_Node := P_Interface_Type_Definition (Abstract_Present);
723 Abstract_Present := True;
728 Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
729 Scan; -- past PRIVATE
733 -- Ada 2005 (AI-345): Protected, synchronized or task interface
734 -- or Ada 2005 (AI-443): Synchronized private extension.
741 Saved_Token : constant Token_Type := Token;
744 Scan; -- past TASK, PROTECTED or SYNCHRONIZED
746 -- Synchronized private extension
748 if Token = Tok_New then
749 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
751 if Saved_Token = Tok_Synchronized then
752 Set_Synchronized_Present (Typedef_Node);
754 Error_Msg_SC ("invalid kind of private extension");
761 P_Interface_Type_Definition (Abstract_Present);
762 Abstract_Present := True;
766 Set_Task_Present (Typedef_Node);
768 when Tok_Protected =>
769 Set_Protected_Present (Typedef_Node);
771 when Tok_Synchronized =>
772 Set_Synchronized_Present (Typedef_Node);
775 pragma Assert (False);
784 -- Anything else is an error
787 if Bad_Spelling_Of (Tok_Access)
789 Bad_Spelling_Of (Tok_Array)
791 Bad_Spelling_Of (Tok_Delta)
793 Bad_Spelling_Of (Tok_Digits)
795 Bad_Spelling_Of (Tok_Limited)
797 Bad_Spelling_Of (Tok_Private)
799 Bad_Spelling_Of (Tok_Range)
801 Bad_Spelling_Of (Tok_Record)
803 Bad_Spelling_Of (Tok_Tagged)
808 Error_Msg_AP ("type definition expected");
815 -- For the private type declaration case, the private type declaration
816 -- node has been built, with the Tagged_Present and Limited_Present
817 -- flags set as needed, and Typedef_Node is left set to Empty.
819 if No (Typedef_Node) then
820 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
821 Set_Abstract_Present (Decl_Node, Abstract_Present);
823 -- For a private extension declaration, Typedef_Node contains the
824 -- N_Private_Extension_Declaration node, which we now complete. Note
825 -- that the private extension declaration, unlike a full type
826 -- declaration, does permit unknown discriminants.
828 elsif Nkind (Typedef_Node) = N_Private_Extension_Declaration then
829 Decl_Node := Typedef_Node;
830 Set_Sloc (Decl_Node, Type_Loc);
831 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
832 Set_Abstract_Present (Typedef_Node, Abstract_Present);
834 -- In the full type declaration case, Typedef_Node has the type
835 -- definition and here is where we build the full type declaration
836 -- node. This is also where we check for improper use of an unknown
837 -- discriminant part (not allowed for full type declaration).
840 if Nkind (Typedef_Node) = N_Record_Definition
841 or else (Nkind (Typedef_Node) = N_Derived_Type_Definition
842 and then Present (Record_Extension_Part (Typedef_Node)))
843 or else Is_Derived_Iface
845 Set_Abstract_Present (Typedef_Node, Abstract_Present);
847 elsif Abstract_Present then
848 Error_Msg ("ABSTRACT not allowed here, ignored", Abstract_Loc);
851 Decl_Node := New_Node (N_Full_Type_Declaration, Type_Loc);
852 Set_Type_Definition (Decl_Node, Typedef_Node);
856 ("Full type declaration cannot have unknown discriminants",
861 -- Remaining processing is common for all three cases
863 Set_Defining_Identifier (Decl_Node, Ident_Node);
864 Set_Discriminant_Specifications (Decl_Node, Discr_List);
866 end P_Type_Declaration;
868 ----------------------------------
869 -- 3.2.1 Full Type Declaration --
870 ----------------------------------
872 -- Parsed by P_Type_Declaration (3.2.1)
874 ----------------------------
875 -- 3.2.1 Type Definition --
876 ----------------------------
878 -- Parsed by P_Type_Declaration (3.2.1)
880 --------------------------------
881 -- 3.2.2 Subtype Declaration --
882 --------------------------------
884 -- SUBTYPE_DECLARATION ::=
885 -- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION;
887 -- The caller has checked that the initial token is SUBTYPE
889 -- Error recovery: can raise Error_Resync
891 function P_Subtype_Declaration return Node_Id is
893 Not_Null_Present : Boolean := False;
896 Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr);
897 Scan; -- past SUBTYPE
898 Set_Defining_Identifier (Decl_Node, P_Defining_Identifier (C_Is));
901 if Token = Tok_New then
902 Error_Msg_SC ("NEW ignored (only allowed in type declaration)");
906 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
907 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
909 Set_Subtype_Indication
910 (Decl_Node, P_Subtype_Indication (Not_Null_Present));
913 end P_Subtype_Declaration;
915 -------------------------------
916 -- 3.2.2 Subtype Indication --
917 -------------------------------
919 -- SUBTYPE_INDICATION ::=
920 -- [not null] SUBTYPE_MARK [CONSTRAINT]
922 -- Error recovery: can raise Error_Resync
924 function P_Null_Exclusion
925 (Allow_Anonymous_In_95 : Boolean := False) return Boolean
927 Not_Loc : constant Source_Ptr := Token_Ptr;
928 -- Source position of "not", if present
931 if Token /= Tok_Not then
937 if Token = Tok_Null then
940 -- Ada 2005 (AI-441, AI-447): null_exclusion is illegal in Ada 95,
941 -- except in the case of anonymous access types.
943 -- Allow_Anonymous_In_95 will be True if we're parsing a formal
944 -- parameter or discriminant, which are the only places where
945 -- anonymous access types occur in Ada 95. "Formal : not null
946 -- access ..." is legal in Ada 95, whereas "Formal : not null
947 -- Named_Access_Type" is not.
949 if Ada_Version >= Ada_05
950 or else (Ada_Version >= Ada_95
951 and then Allow_Anonymous_In_95
952 and then Token = Tok_Access)
958 ("`NOT NULL` access type is an Ada 2005 extension", Not_Loc);
960 ("\unit should be compiled with -gnat05 switch", Not_Loc);
964 Error_Msg_SP ("NULL expected");
967 if Token = Tok_New then
968 Error_Msg ("`NOT NULL` comes after NEW, not before", Not_Loc);
973 end P_Null_Exclusion;
975 function P_Subtype_Indication
976 (Not_Null_Present : Boolean := False) return Node_Id
981 if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
982 Type_Node := P_Subtype_Mark;
983 return P_Subtype_Indication (Type_Node, Not_Null_Present);
986 -- Check for error of using record definition and treat it nicely,
987 -- otherwise things are really messed up, so resynchronize.
989 if Token = Tok_Record then
990 Error_Msg_SC ("anonymous record definitions are not permitted");
991 Discard_Junk_Node (P_Record_Definition);
995 Error_Msg_AP ("subtype indication expected");
999 end P_Subtype_Indication;
1001 -- The following function is identical except that it is called with
1002 -- the subtype mark already scanned out, and it scans out the constraint
1004 -- Error recovery: can raise Error_Resync
1006 function P_Subtype_Indication
1007 (Subtype_Mark : Node_Id;
1008 Not_Null_Present : Boolean := False) return Node_Id
1010 Indic_Node : Node_Id;
1011 Constr_Node : Node_Id;
1014 Constr_Node := P_Constraint_Opt;
1016 if No (Constr_Node) then
1017 return Subtype_Mark;
1019 if Not_Null_Present then
1020 Error_Msg_SP ("`NOT NULL` not allowed if constraint given");
1023 Indic_Node := New_Node (N_Subtype_Indication, Sloc (Subtype_Mark));
1024 Set_Subtype_Mark (Indic_Node, Check_Subtype_Mark (Subtype_Mark));
1025 Set_Constraint (Indic_Node, Constr_Node);
1028 end P_Subtype_Indication;
1030 -------------------------
1031 -- 3.2.2 Subtype Mark --
1032 -------------------------
1034 -- SUBTYPE_MARK ::= subtype_NAME;
1036 -- Note: The subtype mark which appears after an IN or NOT IN
1037 -- operator is parsed by P_Range_Or_Subtype_Mark (3.5)
1039 -- Error recovery: cannot raise Error_Resync
1041 function P_Subtype_Mark return Node_Id is
1043 return P_Subtype_Mark_Resync;
1045 when Error_Resync =>
1049 -- This routine differs from P_Subtype_Mark in that it insists that an
1050 -- identifier be present, and if it is not, it raises Error_Resync.
1052 -- Error recovery: can raise Error_Resync
1054 function P_Subtype_Mark_Resync return Node_Id is
1055 Type_Node : Node_Id;
1058 if Token = Tok_Access then
1059 Error_Msg_SC ("anonymous access type definition not allowed here");
1060 Scan; -- past ACCESS
1063 if Token = Tok_Array then
1064 Error_Msg_SC ("anonymous array definition not allowed here");
1065 Discard_Junk_Node (P_Array_Type_Definition);
1069 Type_Node := P_Qualified_Simple_Name_Resync;
1071 -- Check for a subtype mark attribute. The only valid possibilities
1072 -- are 'CLASS and 'BASE. Anything else is a definite error. We may
1073 -- as well catch it here.
1075 if Token = Tok_Apostrophe then
1076 return P_Subtype_Mark_Attribute (Type_Node);
1081 end P_Subtype_Mark_Resync;
1083 -- The following function is called to scan out a subtype mark attribute.
1084 -- The caller has already scanned out the subtype mark, which is passed in
1085 -- as the argument, and has checked that the current token is apostrophe.
1087 -- Only a special subclass of attributes, called type attributes
1088 -- (see Snames package) are allowed in this syntactic position.
1090 -- Note: if the apostrophe is followed by other than an identifier, then
1091 -- the input expression is returned unchanged, and the scan pointer is
1092 -- left pointing to the apostrophe.
1094 -- Error recovery: can raise Error_Resync
1096 function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id is
1097 Attr_Node : Node_Id := Empty;
1098 Scan_State : Saved_Scan_State;
1102 Prefix := Check_Subtype_Mark (Type_Node);
1104 if Prefix = Error then
1108 -- Loop through attributes appearing (more than one can appear as for
1109 -- for example in X'Base'Class). We are at an apostrophe on entry to
1110 -- this loop, and it runs once for each attribute parsed, with
1111 -- Prefix being the current possible prefix if it is an attribute.
1114 Save_Scan_State (Scan_State); -- at Apostrophe
1115 Scan; -- past apostrophe
1117 if Token /= Tok_Identifier then
1118 Restore_Scan_State (Scan_State); -- to apostrophe
1119 return Prefix; -- no attribute after all
1121 elsif not Is_Type_Attribute_Name (Token_Name) then
1123 ("attribute & may not be used in a subtype mark", Token_Node);
1128 Make_Attribute_Reference (Prev_Token_Ptr,
1130 Attribute_Name => Token_Name);
1131 Delete_Node (Token_Node);
1132 Scan; -- past type attribute identifier
1135 exit when Token /= Tok_Apostrophe;
1136 Prefix := Attr_Node;
1139 -- Fall through here after scanning type attribute
1142 end P_Subtype_Mark_Attribute;
1144 -----------------------
1145 -- 3.2.2 Constraint --
1146 -----------------------
1148 -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
1150 -- SCALAR_CONSTRAINT ::=
1151 -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
1153 -- COMPOSITE_CONSTRAINT ::=
1154 -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
1156 -- If no constraint is present, this function returns Empty
1158 -- Error recovery: can raise Error_Resync
1160 function P_Constraint_Opt return Node_Id is
1162 if Token = Tok_Range
1163 or else Bad_Spelling_Of (Tok_Range)
1165 return P_Range_Constraint;
1167 elsif Token = Tok_Digits
1168 or else Bad_Spelling_Of (Tok_Digits)
1170 return P_Digits_Constraint;
1172 elsif Token = Tok_Delta
1173 or else Bad_Spelling_Of (Tok_Delta)
1175 return P_Delta_Constraint;
1177 elsif Token = Tok_Left_Paren then
1178 return P_Index_Or_Discriminant_Constraint;
1180 elsif Token = Tok_In then
1182 return P_Constraint_Opt;
1187 end P_Constraint_Opt;
1189 ------------------------------
1190 -- 3.2.2 Scalar Constraint --
1191 ------------------------------
1193 -- Parsed by P_Constraint_Opt (3.2.2)
1195 ---------------------------------
1196 -- 3.2.2 Composite Constraint --
1197 ---------------------------------
1199 -- Parsed by P_Constraint_Opt (3.2.2)
1201 --------------------------------------------------------
1202 -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) --
1203 --------------------------------------------------------
1205 -- This routine scans out a declaration starting with an identifier:
1207 -- OBJECT_DECLARATION ::=
1208 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1209 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1210 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1211 -- ACCESS_DEFINITION [:= EXPRESSION];
1212 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1213 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1215 -- NUMBER_DECLARATION ::=
1216 -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
1218 -- OBJECT_RENAMING_DECLARATION ::=
1219 -- DEFINING_IDENTIFIER :
1220 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
1221 -- | DEFINING_IDENTIFIER :
1222 -- ACCESS_DEFINITION renames object_NAME;
1224 -- EXCEPTION_RENAMING_DECLARATION ::=
1225 -- DEFINING_IDENTIFIER : exception renames exception_NAME;
1227 -- EXCEPTION_DECLARATION ::=
1228 -- DEFINING_IDENTIFIER_LIST : exception;
1230 -- Note that the ALIASED indication in an object declaration is
1231 -- marked by a flag in the parent node.
1233 -- The caller has checked that the initial token is an identifier
1235 -- The value returned is a list of declarations, one for each identifier
1236 -- in the list (as described in Sinfo, we always split up multiple
1237 -- declarations into the equivalent sequence of single declarations
1238 -- using the More_Ids and Prev_Ids flags to preserve the source).
1240 -- If the identifier turns out to be a probable statement rather than
1241 -- an identifier, then the scan is left pointing to the identifier and
1242 -- No_List is returned.
1244 -- Error recovery: can raise Error_Resync
1246 procedure P_Identifier_Declarations
1252 Decl_Node : Node_Id;
1253 Type_Node : Node_Id;
1254 Ident_Sloc : Source_Ptr;
1255 Scan_State : Saved_Scan_State;
1256 List_OK : Boolean := True;
1258 Init_Expr : Node_Id;
1259 Init_Loc : Source_Ptr;
1260 Con_Loc : Source_Ptr;
1261 Not_Null_Present : Boolean := False;
1263 Idents : array (Int range 1 .. 4096) of Entity_Id;
1264 -- Used to save identifiers in the identifier list. The upper bound
1265 -- of 4096 is expected to be infinite in practice, and we do not even
1266 -- bother to check if this upper bound is exceeded.
1268 Num_Idents : Nat := 1;
1269 -- Number of identifiers stored in Idents
1272 -- This procedure is called in renames cases to make sure that we do
1273 -- not have more than one identifier. If we do have more than one
1274 -- then an error message is issued (and the declaration is split into
1275 -- multiple declarations)
1277 function Token_Is_Renames return Boolean;
1278 -- Checks if current token is RENAMES, and if so, scans past it and
1279 -- returns True, otherwise returns False. Includes checking for some
1280 -- common error cases.
1282 procedure No_List is
1284 if Num_Idents > 1 then
1285 Error_Msg ("identifier list not allowed for RENAMES",
1292 function Token_Is_Renames return Boolean is
1293 At_Colon : Saved_Scan_State;
1296 if Token = Tok_Colon then
1297 Save_Scan_State (At_Colon);
1299 Check_Misspelling_Of (Tok_Renames);
1301 if Token = Tok_Renames then
1302 Error_Msg_SP ("extra "":"" ignored");
1303 Scan; -- past RENAMES
1306 Restore_Scan_State (At_Colon);
1311 Check_Misspelling_Of (Tok_Renames);
1313 if Token = Tok_Renames then
1314 Scan; -- past RENAMES
1320 end Token_Is_Renames;
1322 -- Start of processing for P_Identifier_Declarations
1325 Ident_Sloc := Token_Ptr;
1326 Save_Scan_State (Scan_State); -- at first identifier
1327 Idents (1) := P_Defining_Identifier (C_Comma_Colon);
1329 -- If we have a colon after the identifier, then we can assume that
1330 -- this is in fact a valid identifier declaration and can steam ahead.
1332 if Token = Tok_Colon then
1335 -- If we have a comma, then scan out the list of identifiers
1337 elsif Token = Tok_Comma then
1339 while Comma_Present loop
1340 Num_Idents := Num_Idents + 1;
1341 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
1344 Save_Scan_State (Scan_State); -- at colon
1347 -- If we have identifier followed by := then we assume that what is
1348 -- really meant is an assignment statement. The assignment statement
1349 -- is scanned out and added to the list of declarations. An exception
1350 -- occurs if the := is followed by the keyword constant, in which case
1351 -- we assume it was meant to be a colon.
1353 elsif Token = Tok_Colon_Equal then
1356 if Token = Tok_Constant then
1357 Error_Msg_SP ("colon expected");
1360 Restore_Scan_State (Scan_State);
1361 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
1365 -- If we have an IS keyword, then assume the TYPE keyword was missing
1367 elsif Token = Tok_Is then
1368 Restore_Scan_State (Scan_State);
1369 Append_To (Decls, P_Type_Declaration);
1373 -- Otherwise we have an error situation
1376 Restore_Scan_State (Scan_State);
1378 -- First case is possible misuse of PROTECTED in Ada 83 mode. If
1379 -- so, fix the keyword and return to scan the protected declaration.
1381 if Token_Name = Name_Protected then
1382 Check_95_Keyword (Tok_Protected, Tok_Identifier);
1383 Check_95_Keyword (Tok_Protected, Tok_Type);
1384 Check_95_Keyword (Tok_Protected, Tok_Body);
1386 if Token = Tok_Protected then
1391 -- Check misspelling possibilities. If so, correct the misspelling
1392 -- and return to scan out the resulting declaration.
1394 elsif Bad_Spelling_Of (Tok_Function)
1395 or else Bad_Spelling_Of (Tok_Procedure)
1396 or else Bad_Spelling_Of (Tok_Package)
1397 or else Bad_Spelling_Of (Tok_Pragma)
1398 or else Bad_Spelling_Of (Tok_Protected)
1399 or else Bad_Spelling_Of (Tok_Generic)
1400 or else Bad_Spelling_Of (Tok_Subtype)
1401 or else Bad_Spelling_Of (Tok_Type)
1402 or else Bad_Spelling_Of (Tok_Task)
1403 or else Bad_Spelling_Of (Tok_Use)
1404 or else Bad_Spelling_Of (Tok_For)
1409 -- Otherwise we definitely have an ordinary identifier with a junk
1410 -- token after it. Just complain that we expect a declaration, and
1411 -- skip to a semicolon
1414 Set_Declaration_Expected;
1415 Resync_Past_Semicolon;
1421 -- Come here with an identifier list and colon scanned out. We now
1422 -- build the nodes for the declarative items. One node is built for
1423 -- each identifier in the list, with the type information being
1424 -- repeated by rescanning the appropriate section of source.
1426 -- First an error check, if we have two identifiers in a row, a likely
1427 -- possibility is that the first of the identifiers is an incorrectly
1430 if Token = Tok_Identifier then
1432 SS : Saved_Scan_State;
1436 Save_Scan_State (SS);
1437 Scan; -- past initial identifier
1438 I2 := (Token = Tok_Identifier);
1439 Restore_Scan_State (SS);
1443 (Bad_Spelling_Of (Tok_Access) or else
1444 Bad_Spelling_Of (Tok_Aliased) or else
1445 Bad_Spelling_Of (Tok_Constant))
1452 -- Loop through identifiers
1457 -- Check for some cases of misused Ada 95 keywords
1459 if Token_Name = Name_Aliased then
1460 Check_95_Keyword (Tok_Aliased, Tok_Array);
1461 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
1462 Check_95_Keyword (Tok_Aliased, Tok_Constant);
1467 if Token = Tok_Constant then
1468 Con_Loc := Token_Ptr;
1469 Scan; -- past CONSTANT
1471 -- Number declaration, initialization required
1473 Init_Expr := Init_Expr_Opt;
1475 if Present (Init_Expr) then
1476 if Not_Null_Present then
1478 ("`NOT NULL` not allowed in numeric expression");
1481 Decl_Node := New_Node (N_Number_Declaration, Ident_Sloc);
1482 Set_Expression (Decl_Node, Init_Expr);
1484 -- Constant object declaration
1487 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1488 Set_Constant_Present (Decl_Node, True);
1490 if Token_Name = Name_Aliased then
1491 Check_95_Keyword (Tok_Aliased, Tok_Array);
1492 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
1495 if Token = Tok_Aliased then
1496 Error_Msg_SC ("ALIASED should be before CONSTANT");
1497 Scan; -- past ALIASED
1498 Set_Aliased_Present (Decl_Node, True);
1501 if Token = Tok_Array then
1502 Set_Object_Definition
1503 (Decl_Node, P_Array_Type_Definition);
1506 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1507 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1509 if Token = Tok_Access then
1510 if Ada_Version < Ada_05 then
1512 ("generalized use of anonymous access types " &
1513 "is an Ada 2005 extension");
1515 ("\unit must be compiled with -gnat05 switch");
1518 Set_Object_Definition
1519 (Decl_Node, P_Access_Definition (Not_Null_Present));
1521 Set_Object_Definition
1522 (Decl_Node, P_Subtype_Indication (Not_Null_Present));
1526 if Token = Tok_Renames then
1528 ("CONSTANT not permitted in renaming declaration",
1530 Scan; -- Past renames
1531 Discard_Junk_Node (P_Name);
1537 elsif Token = Tok_Exception then
1538 Scan; -- past EXCEPTION
1540 if Token_Is_Renames then
1543 New_Node (N_Exception_Renaming_Declaration, Ident_Sloc);
1544 Set_Name (Decl_Node, P_Qualified_Simple_Name_Resync);
1547 Decl_Node := New_Node (N_Exception_Declaration, Prev_Token_Ptr);
1550 -- Aliased case (note that an object definition is required)
1552 elsif Token = Tok_Aliased then
1553 Scan; -- past ALIASED
1554 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1555 Set_Aliased_Present (Decl_Node, True);
1557 if Token = Tok_Constant then
1558 Scan; -- past CONSTANT
1559 Set_Constant_Present (Decl_Node, True);
1562 if Token = Tok_Array then
1563 Set_Object_Definition
1564 (Decl_Node, P_Array_Type_Definition);
1567 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1568 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1570 -- Access definition (AI-406) or subtype indication
1572 if Token = Tok_Access then
1573 if Ada_Version < Ada_05 then
1575 ("generalized use of anonymous access types " &
1576 "is an Ada 2005 extension");
1578 ("\unit must be compiled with -gnat05 switch");
1581 Set_Object_Definition
1582 (Decl_Node, P_Access_Definition (Not_Null_Present));
1584 Set_Object_Definition
1585 (Decl_Node, P_Subtype_Indication (Not_Null_Present));
1591 elsif Token = Tok_Array then
1592 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1593 Set_Object_Definition (Decl_Node, P_Array_Type_Definition);
1595 -- Ada 2005 (AI-254, AI-406)
1597 elsif Token = Tok_Not then
1599 -- OBJECT_DECLARATION ::=
1600 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1601 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1602 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1603 -- ACCESS_DEFINITION [:= EXPRESSION];
1605 -- OBJECT_RENAMING_DECLARATION ::=
1606 -- DEFINING_IDENTIFIER :
1607 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
1608 -- | DEFINING_IDENTIFIER :
1609 -- ACCESS_DEFINITION renames object_NAME;
1611 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/423)
1613 if Token = Tok_Access then
1614 if Ada_Version < Ada_05 then
1616 ("generalized use of anonymous access types " &
1617 "is an Ada 2005 extension");
1618 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1621 Acc_Node := P_Access_Definition (Not_Null_Present);
1623 if Token /= Tok_Renames then
1624 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1625 Set_Object_Definition (Decl_Node, Acc_Node);
1628 Scan; -- past renames
1631 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1632 Set_Access_Definition (Decl_Node, Acc_Node);
1633 Set_Name (Decl_Node, P_Name);
1637 Type_Node := P_Subtype_Mark;
1639 -- Object renaming declaration
1641 if Token_Is_Renames then
1642 if Ada_Version < Ada_05 then
1644 ("`NOT NULL` not allowed in object renaming");
1647 -- Ada 2005 (AI-423): Object renaming declaration with
1648 -- a null exclusion.
1653 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1654 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1655 Set_Subtype_Mark (Decl_Node, Type_Node);
1656 Set_Name (Decl_Node, P_Name);
1659 -- Object declaration
1662 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1663 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1664 Set_Object_Definition
1666 P_Subtype_Indication (Type_Node, Not_Null_Present));
1668 -- RENAMES at this point means that we had the combination
1669 -- of a constraint on the Type_Node and renames, which is
1672 if Token_Is_Renames then
1673 Error_Msg_N ("constraint not allowed in object renaming "
1675 Constraint (Object_Definition (Decl_Node)));
1681 -- Ada 2005 (AI-230): Access Definition case
1683 elsif Token = Tok_Access then
1684 if Ada_Version < Ada_05 then
1686 ("generalized use of anonymous access types " &
1687 "is an Ada 2005 extension");
1688 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1691 Acc_Node := P_Access_Definition (Null_Exclusion_Present => False);
1693 -- Object declaration with access definition, or renaming
1695 if Token /= Tok_Renames then
1696 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1697 Set_Object_Definition (Decl_Node, Acc_Node);
1700 Scan; -- past renames
1703 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1704 Set_Access_Definition (Decl_Node, Acc_Node);
1705 Set_Name (Decl_Node, P_Name);
1708 -- Subtype indication case
1711 Type_Node := P_Subtype_Mark;
1713 -- Object renaming declaration
1715 if Token_Is_Renames then
1718 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1719 Set_Subtype_Mark (Decl_Node, Type_Node);
1720 Set_Name (Decl_Node, P_Name);
1722 -- Object declaration
1725 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1726 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1727 Set_Object_Definition
1729 P_Subtype_Indication (Type_Node, Not_Null_Present));
1731 -- RENAMES at this point means that we had the combination of
1732 -- a constraint on the Type_Node and renames, which is illegal
1734 if Token_Is_Renames then
1736 ("constraint not allowed in object renaming declaration",
1737 Constraint (Object_Definition (Decl_Node)));
1743 -- Scan out initialization, allowed only for object declaration
1745 Init_Loc := Token_Ptr;
1746 Init_Expr := Init_Expr_Opt;
1748 if Present (Init_Expr) then
1749 if Nkind (Decl_Node) = N_Object_Declaration then
1750 Set_Expression (Decl_Node, Init_Expr);
1751 Set_Has_Init_Expression (Decl_Node);
1753 Error_Msg ("initialization not allowed here", Init_Loc);
1758 Set_Defining_Identifier (Decl_Node, Idents (Ident));
1761 if Ident < Num_Idents then
1762 Set_More_Ids (Decl_Node, True);
1766 Set_Prev_Ids (Decl_Node, True);
1770 Append (Decl_Node, Decls);
1771 exit Ident_Loop when Ident = Num_Idents;
1772 Restore_Scan_State (Scan_State);
1775 end loop Ident_Loop;
1778 end P_Identifier_Declarations;
1780 -------------------------------
1781 -- 3.3.1 Object Declaration --
1782 -------------------------------
1784 -- OBJECT DECLARATION ::=
1785 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1786 -- SUBTYPE_INDICATION [:= EXPRESSION];
1787 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1788 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1789 -- | SINGLE_TASK_DECLARATION
1790 -- | SINGLE_PROTECTED_DECLARATION
1792 -- Cases starting with TASK are parsed by P_Task (9.1)
1793 -- Cases starting with PROTECTED are parsed by P_Protected (9.4)
1794 -- All other cases are parsed by P_Identifier_Declarations (3.3)
1796 -------------------------------------
1797 -- 3.3.1 Defining Identifier List --
1798 -------------------------------------
1800 -- DEFINING_IDENTIFIER_LIST ::=
1801 -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
1803 -- Always parsed by the construct in which it appears. See special
1804 -- section on "Handling of Defining Identifier Lists" in this unit.
1806 -------------------------------
1807 -- 3.3.2 Number Declaration --
1808 -------------------------------
1810 -- Parsed by P_Identifier_Declarations (3.3)
1812 -------------------------------------------------------------------------
1813 -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) --
1814 -------------------------------------------------------------------------
1816 -- DERIVED_TYPE_DEFINITION ::=
1817 -- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
1818 -- [[and INTERFACE_LIST] RECORD_EXTENSION_PART]
1820 -- PRIVATE_EXTENSION_DECLARATION ::=
1821 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
1822 -- [abstract] [limited | synchronized]
1823 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
1826 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
1828 -- The caller has already scanned out the part up to the NEW, and Token
1829 -- either contains Tok_New (or ought to, if it doesn't this procedure
1830 -- will post an appropriate "NEW expected" message).
1832 -- Note: the caller is responsible for filling in the Sloc field of
1833 -- the returned node in the private extension declaration case as
1834 -- well as the stuff relating to the discriminant part.
1836 -- Error recovery: can raise Error_Resync;
1838 function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id is
1839 Typedef_Node : Node_Id;
1840 Typedecl_Node : Node_Id;
1841 Not_Null_Present : Boolean := False;
1844 Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
1846 if Ada_Version < Ada_05
1847 and then Token = Tok_Identifier
1848 and then Token_Name = Name_Interface
1851 ("abstract interface is an Ada 2005 extension");
1852 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1857 if Token = Tok_Abstract then
1858 Error_Msg_SC ("ABSTRACT must come before NEW, not after");
1862 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1863 Set_Null_Exclusion_Present (Typedef_Node, Not_Null_Present);
1864 Set_Subtype_Indication (Typedef_Node,
1865 P_Subtype_Indication (Not_Null_Present));
1867 -- Ada 2005 (AI-251): Deal with interfaces
1869 if Token = Tok_And then
1872 if Ada_Version < Ada_05 then
1874 ("abstract interface is an Ada 2005 extension");
1875 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1878 Set_Interface_List (Typedef_Node, New_List);
1881 Append (P_Qualified_Simple_Name, Interface_List (Typedef_Node));
1882 exit when Token /= Tok_And;
1886 if Token /= Tok_With then
1887 Error_Msg_SC ("WITH expected");
1892 -- Deal with record extension, note that we assume that a WITH is
1893 -- missing in the case of "type X is new Y record ..." or in the
1894 -- case of "type X is new Y null record".
1897 or else Token = Tok_Record
1898 or else Token = Tok_Null
1900 T_With; -- past WITH or give error message
1902 if Token = Tok_Limited then
1904 ("LIMITED keyword not allowed in private extension");
1905 Scan; -- ignore LIMITED
1908 -- Private extension declaration
1910 if Token = Tok_Private then
1911 Scan; -- past PRIVATE
1913 -- Throw away the type definition node and build the type
1914 -- declaration node. Note the caller must set the Sloc,
1915 -- Discriminant_Specifications, Unknown_Discriminants_Present,
1916 -- and Defined_Identifier fields in the returned node.
1919 Make_Private_Extension_Declaration (No_Location,
1920 Defining_Identifier => Empty,
1921 Subtype_Indication => Subtype_Indication (Typedef_Node),
1922 Abstract_Present => Abstract_Present (Typedef_Node),
1923 Interface_List => Interface_List (Typedef_Node));
1925 Delete_Node (Typedef_Node);
1926 return Typedecl_Node;
1928 -- Derived type definition with record extension part
1931 Set_Record_Extension_Part (Typedef_Node, P_Record_Definition);
1932 return Typedef_Node;
1935 -- Derived type definition with no record extension part
1938 return Typedef_Node;
1940 end P_Derived_Type_Def_Or_Private_Ext_Decl;
1942 ---------------------------
1943 -- 3.5 Range Constraint --
1944 ---------------------------
1946 -- RANGE_CONSTRAINT ::= range RANGE
1948 -- The caller has checked that the initial token is RANGE
1950 -- Error recovery: cannot raise Error_Resync
1952 function P_Range_Constraint return Node_Id is
1953 Range_Node : Node_Id;
1956 Range_Node := New_Node (N_Range_Constraint, Token_Ptr);
1958 Set_Range_Expression (Range_Node, P_Range);
1960 end P_Range_Constraint;
1967 -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
1969 -- Note: the range that appears in a membership test is parsed by
1970 -- P_Range_Or_Subtype_Mark (3.5).
1972 -- Error recovery: cannot raise Error_Resync
1974 function P_Range return Node_Id is
1975 Expr_Node : Node_Id;
1976 Range_Node : Node_Id;
1979 Expr_Node := P_Simple_Expression_Or_Range_Attribute;
1981 if Expr_Form = EF_Range_Attr then
1984 elsif Token = Tok_Dot_Dot then
1985 Range_Node := New_Node (N_Range, Token_Ptr);
1986 Set_Low_Bound (Range_Node, Expr_Node);
1988 Expr_Node := P_Expression;
1989 Check_Simple_Expression (Expr_Node);
1990 Set_High_Bound (Range_Node, Expr_Node);
1993 -- Anything else is an error
1996 T_Dot_Dot; -- force missing .. message
2001 ----------------------------------
2002 -- 3.5 P_Range_Or_Subtype_Mark --
2003 ----------------------------------
2006 -- RANGE_ATTRIBUTE_REFERENCE
2007 -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
2009 -- This routine scans out the range or subtype mark that forms the right
2010 -- operand of a membership test (it is not used in any other contexts, and
2011 -- error messages are specialized with this knowledge in mind).
2013 -- Note: as documented in the Sinfo interface, although the syntax only
2014 -- allows a subtype mark, we in fact allow any simple expression to be
2015 -- returned from this routine. The semantics is responsible for issuing
2016 -- an appropriate message complaining if the argument is not a name.
2017 -- This simplifies the coding and error recovery processing in the
2018 -- parser, and in any case it is preferable not to consider this a
2019 -- syntax error and to continue with the semantic analysis.
2021 -- Error recovery: cannot raise Error_Resync
2023 function P_Range_Or_Subtype_Mark return Node_Id is
2024 Expr_Node : Node_Id;
2025 Range_Node : Node_Id;
2026 Save_Loc : Source_Ptr;
2028 -- Start of processing for P_Range_Or_Subtype_Mark
2031 -- Save location of possible junk parentheses
2033 Save_Loc := Token_Ptr;
2035 -- Scan out either a simple expression or a range (this accepts more
2036 -- than is legal here, but as explained above, we like to allow more
2037 -- with a proper diagnostic.
2039 Expr_Node := P_Simple_Expression_Or_Range_Attribute;
2043 if Expr_Form = EF_Range_Attr then
2046 -- Simple_Expression .. Simple_Expression
2048 elsif Token = Tok_Dot_Dot then
2049 Check_Simple_Expression (Expr_Node);
2050 Range_Node := New_Node (N_Range, Token_Ptr);
2051 Set_Low_Bound (Range_Node, Expr_Node);
2053 Set_High_Bound (Range_Node, P_Simple_Expression);
2056 -- Case of subtype mark (optionally qualified simple name or an
2057 -- attribute whose prefix is an optionally qualifed simple name)
2059 elsif Expr_Form = EF_Simple_Name
2060 or else Nkind (Expr_Node) = N_Attribute_Reference
2062 -- Check for error of range constraint after a subtype mark
2064 if Token = Tok_Range then
2065 Error_Msg_SC ("range constraint not allowed in membership test");
2069 -- Check for error of DIGITS or DELTA after a subtype mark
2071 elsif Token = Tok_Digits or else Token = Tok_Delta then
2073 ("accuracy definition not allowed in membership test");
2074 Scan; -- past DIGITS or DELTA
2077 -- Attribute reference, may or may not be OK, but in any case we
2080 elsif Token = Tok_Apostrophe then
2081 return P_Subtype_Mark_Attribute (Expr_Node);
2083 -- OK case of simple name, just return it
2089 -- Here we have some kind of error situation. Check for junk parens
2090 -- then return what we have, caller will deal with other errors.
2093 if Nkind (Expr_Node) in N_Subexpr
2094 and then Paren_Count (Expr_Node) /= 0
2096 Error_Msg ("|parentheses not allowed for subtype mark", Save_Loc);
2097 Set_Paren_Count (Expr_Node, 0);
2102 end P_Range_Or_Subtype_Mark;
2104 ----------------------------------------
2105 -- 3.5.1 Enumeration Type Definition --
2106 ----------------------------------------
2108 -- ENUMERATION_TYPE_DEFINITION ::=
2109 -- (ENUMERATION_LITERAL_SPECIFICATION
2110 -- {, ENUMERATION_LITERAL_SPECIFICATION})
2112 -- The caller has already scanned out the TYPE keyword
2114 -- Error recovery: can raise Error_Resync;
2116 function P_Enumeration_Type_Definition return Node_Id is
2117 Typedef_Node : Node_Id;
2120 Typedef_Node := New_Node (N_Enumeration_Type_Definition, Token_Ptr);
2121 Set_Literals (Typedef_Node, New_List);
2126 Append (P_Enumeration_Literal_Specification, Literals (Typedef_Node));
2127 exit when not Comma_Present;
2131 return Typedef_Node;
2132 end P_Enumeration_Type_Definition;
2134 ----------------------------------------------
2135 -- 3.5.1 Enumeration Literal Specification --
2136 ----------------------------------------------
2138 -- ENUMERATION_LITERAL_SPECIFICATION ::=
2139 -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
2141 -- Error recovery: can raise Error_Resync
2143 function P_Enumeration_Literal_Specification return Node_Id is
2145 if Token = Tok_Char_Literal then
2146 return P_Defining_Character_Literal;
2148 return P_Defining_Identifier (C_Comma_Right_Paren);
2150 end P_Enumeration_Literal_Specification;
2152 ---------------------------------------
2153 -- 3.5.1 Defining_Character_Literal --
2154 ---------------------------------------
2156 -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
2158 -- Error recovery: cannot raise Error_Resync
2160 -- The caller has checked that the current token is a character literal
2162 function P_Defining_Character_Literal return Node_Id is
2163 Literal_Node : Node_Id;
2166 Literal_Node := Token_Node;
2167 Change_Character_Literal_To_Defining_Character_Literal (Literal_Node);
2168 Scan; -- past character literal
2169 return Literal_Node;
2170 end P_Defining_Character_Literal;
2172 ------------------------------------
2173 -- 3.5.4 Integer Type Definition --
2174 ------------------------------------
2176 -- Parsed by P_Type_Declaration (3.2.1)
2178 -------------------------------------------
2179 -- 3.5.4 Signed Integer Type Definition --
2180 -------------------------------------------
2182 -- SIGNED_INTEGER_TYPE_DEFINITION ::=
2183 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2185 -- Normally the initial token on entry is RANGE, but in some
2186 -- error conditions, the range token was missing and control is
2187 -- passed with Token pointing to first token of the first expression.
2189 -- Error recovery: cannot raise Error_Resync
2191 function P_Signed_Integer_Type_Definition return Node_Id is
2192 Typedef_Node : Node_Id;
2193 Expr_Node : Node_Id;
2196 Typedef_Node := New_Node (N_Signed_Integer_Type_Definition, Token_Ptr);
2198 if Token = Tok_Range then
2202 Expr_Node := P_Expression;
2203 Check_Simple_Expression (Expr_Node);
2204 Set_Low_Bound (Typedef_Node, Expr_Node);
2206 Expr_Node := P_Expression;
2207 Check_Simple_Expression (Expr_Node);
2208 Set_High_Bound (Typedef_Node, Expr_Node);
2209 return Typedef_Node;
2210 end P_Signed_Integer_Type_Definition;
2212 ------------------------------------
2213 -- 3.5.4 Modular Type Definition --
2214 ------------------------------------
2216 -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
2218 -- The caller has checked that the initial token is MOD
2220 -- Error recovery: cannot raise Error_Resync
2222 function P_Modular_Type_Definition return Node_Id is
2223 Typedef_Node : Node_Id;
2226 if Ada_Version = Ada_83 then
2227 Error_Msg_SC ("(Ada 83): modular types not allowed");
2230 Typedef_Node := New_Node (N_Modular_Type_Definition, Token_Ptr);
2232 Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
2234 -- Handle mod L..R cleanly
2236 if Token = Tok_Dot_Dot then
2237 Error_Msg_SC ("range not allowed for modular type");
2239 Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
2242 return Typedef_Node;
2243 end P_Modular_Type_Definition;
2245 ---------------------------------
2246 -- 3.5.6 Real Type Definition --
2247 ---------------------------------
2249 -- Parsed by P_Type_Declaration (3.2.1)
2251 --------------------------------------
2252 -- 3.5.7 Floating Point Definition --
2253 --------------------------------------
2255 -- FLOATING_POINT_DEFINITION ::=
2256 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2258 -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
2260 -- The caller has checked that the initial token is DIGITS
2262 -- Error recovery: cannot raise Error_Resync
2264 function P_Floating_Point_Definition return Node_Id is
2265 Digits_Loc : constant Source_Ptr := Token_Ptr;
2267 Expr_Node : Node_Id;
2270 Scan; -- past DIGITS
2271 Expr_Node := P_Expression_No_Right_Paren;
2272 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2274 -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
2276 if Token = Tok_Delta then
2277 Error_Msg_SC ("DELTA must come before DIGITS");
2278 Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Digits_Loc);
2280 Set_Delta_Expression (Def_Node, P_Expression_No_Right_Paren);
2282 -- OK floating-point definition
2285 Def_Node := New_Node (N_Floating_Point_Definition, Digits_Loc);
2288 Set_Digits_Expression (Def_Node, Expr_Node);
2289 Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt);
2291 end P_Floating_Point_Definition;
2293 -------------------------------------
2294 -- 3.5.7 Real Range Specification --
2295 -------------------------------------
2297 -- REAL_RANGE_SPECIFICATION ::=
2298 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2300 -- Error recovery: cannot raise Error_Resync
2302 function P_Real_Range_Specification_Opt return Node_Id is
2303 Specification_Node : Node_Id;
2304 Expr_Node : Node_Id;
2307 if Token = Tok_Range then
2308 Specification_Node :=
2309 New_Node (N_Real_Range_Specification, Token_Ptr);
2311 Expr_Node := P_Expression_No_Right_Paren;
2312 Check_Simple_Expression (Expr_Node);
2313 Set_Low_Bound (Specification_Node, Expr_Node);
2315 Expr_Node := P_Expression_No_Right_Paren;
2316 Check_Simple_Expression (Expr_Node);
2317 Set_High_Bound (Specification_Node, Expr_Node);
2318 return Specification_Node;
2322 end P_Real_Range_Specification_Opt;
2324 -----------------------------------
2325 -- 3.5.9 Fixed Point Definition --
2326 -----------------------------------
2328 -- FIXED_POINT_DEFINITION ::=
2329 -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
2331 -- ORDINARY_FIXED_POINT_DEFINITION ::=
2332 -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION
2334 -- DECIMAL_FIXED_POINT_DEFINITION ::=
2335 -- delta static_EXPRESSION
2336 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2338 -- The caller has checked that the initial token is DELTA
2340 -- Error recovery: cannot raise Error_Resync
2342 function P_Fixed_Point_Definition return Node_Id is
2343 Delta_Node : Node_Id;
2344 Delta_Loc : Source_Ptr;
2346 Expr_Node : Node_Id;
2349 Delta_Loc := Token_Ptr;
2351 Delta_Node := P_Expression_No_Right_Paren;
2352 Check_Simple_Expression_In_Ada_83 (Delta_Node);
2354 if Token = Tok_Digits then
2355 if Ada_Version = Ada_83 then
2356 Error_Msg_SC ("(Ada 83) decimal fixed type not allowed!");
2359 Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Delta_Loc);
2360 Scan; -- past DIGITS
2361 Expr_Node := P_Expression_No_Right_Paren;
2362 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2363 Set_Digits_Expression (Def_Node, Expr_Node);
2366 Def_Node := New_Node (N_Ordinary_Fixed_Point_Definition, Delta_Loc);
2368 -- Range is required in ordinary fixed point case
2370 if Token /= Tok_Range then
2371 Error_Msg_AP ("range must be given for fixed-point type");
2376 Set_Delta_Expression (Def_Node, Delta_Node);
2377 Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt);
2379 end P_Fixed_Point_Definition;
2381 --------------------------------------------
2382 -- 3.5.9 Ordinary Fixed Point Definition --
2383 --------------------------------------------
2385 -- Parsed by P_Fixed_Point_Definition (3.5.9)
2387 -------------------------------------------
2388 -- 3.5.9 Decimal Fixed Point Definition --
2389 -------------------------------------------
2391 -- Parsed by P_Decimal_Point_Definition (3.5.9)
2393 ------------------------------
2394 -- 3.5.9 Digits Constraint --
2395 ------------------------------
2397 -- DIGITS_CONSTRAINT ::=
2398 -- digits static_EXPRESSION [RANGE_CONSTRAINT]
2400 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2402 -- The caller has checked that the initial token is DIGITS
2404 function P_Digits_Constraint return Node_Id is
2405 Constraint_Node : Node_Id;
2406 Expr_Node : Node_Id;
2409 Constraint_Node := New_Node (N_Digits_Constraint, Token_Ptr);
2410 Scan; -- past DIGITS
2411 Expr_Node := P_Expression;
2412 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2413 Set_Digits_Expression (Constraint_Node, Expr_Node);
2415 if Token = Tok_Range then
2416 Set_Range_Constraint (Constraint_Node, P_Range_Constraint);
2419 return Constraint_Node;
2420 end P_Digits_Constraint;
2422 -----------------------------
2423 -- 3.5.9 Delta Constraint --
2424 -----------------------------
2426 -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
2428 -- Note: this is an obsolescent feature in Ada 95 (I.3)
2430 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2432 -- The caller has checked that the initial token is DELTA
2434 -- Error recovery: cannot raise Error_Resync
2436 function P_Delta_Constraint return Node_Id is
2437 Constraint_Node : Node_Id;
2438 Expr_Node : Node_Id;
2441 Constraint_Node := New_Node (N_Delta_Constraint, Token_Ptr);
2443 Expr_Node := P_Expression;
2444 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2445 Set_Delta_Expression (Constraint_Node, Expr_Node);
2447 if Token = Tok_Range then
2448 Set_Range_Constraint (Constraint_Node, P_Range_Constraint);
2451 return Constraint_Node;
2452 end P_Delta_Constraint;
2454 --------------------------------
2455 -- 3.6 Array Type Definition --
2456 --------------------------------
2458 -- ARRAY_TYPE_DEFINITION ::=
2459 -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
2461 -- UNCONSTRAINED_ARRAY_DEFINITION ::=
2462 -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
2463 -- COMPONENT_DEFINITION
2465 -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
2467 -- CONSTRAINED_ARRAY_DEFINITION ::=
2468 -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
2469 -- COMPONENT_DEFINITION
2471 -- DISCRETE_SUBTYPE_DEFINITION ::=
2472 -- DISCRETE_SUBTYPE_INDICATION | RANGE
2474 -- COMPONENT_DEFINITION ::=
2475 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
2477 -- The caller has checked that the initial token is ARRAY
2479 -- Error recovery: can raise Error_Resync
2481 function P_Array_Type_Definition return Node_Id is
2482 Array_Loc : Source_Ptr;
2483 CompDef_Node : Node_Id;
2485 Not_Null_Present : Boolean := False;
2486 Subs_List : List_Id;
2487 Scan_State : Saved_Scan_State;
2488 Aliased_Present : Boolean := False;
2491 Array_Loc := Token_Ptr;
2493 Subs_List := New_List;
2496 -- It's quite tricky to disentangle these two possibilities, so we do
2497 -- a prescan to determine which case we have and then reset the scan.
2498 -- The prescan skips past possible subtype mark tokens.
2500 Save_Scan_State (Scan_State); -- just after paren
2502 while Token in Token_Class_Desig or else
2503 Token = Tok_Dot or else
2504 Token = Tok_Apostrophe -- because of 'BASE, 'CLASS
2509 -- If we end up on RANGE <> then we have the unconstrained case. We
2510 -- will also allow the RANGE to be omitted, just to improve error
2511 -- handling for a case like array (integer <>) of integer;
2513 Scan; -- past possible RANGE or <>
2515 if (Prev_Token = Tok_Range and then Token = Tok_Box) or else
2516 Prev_Token = Tok_Box
2518 Def_Node := New_Node (N_Unconstrained_Array_Definition, Array_Loc);
2519 Restore_Scan_State (Scan_State); -- to first subtype mark
2522 Append (P_Subtype_Mark_Resync, Subs_List);
2525 exit when Token = Tok_Right_Paren or else Token = Tok_Of;
2529 Set_Subtype_Marks (Def_Node, Subs_List);
2532 Def_Node := New_Node (N_Constrained_Array_Definition, Array_Loc);
2533 Restore_Scan_State (Scan_State); -- to first discrete range
2536 Append (P_Discrete_Subtype_Definition, Subs_List);
2537 exit when not Comma_Present;
2540 Set_Discrete_Subtype_Definitions (Def_Node, Subs_List);
2546 CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
2548 if Token_Name = Name_Aliased then
2549 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
2552 if Token = Tok_Aliased then
2553 Aliased_Present := True;
2554 Scan; -- past ALIASED
2557 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254)
2559 -- Ada 2005 (AI-230): Access Definition case
2561 if Token = Tok_Access then
2562 if Ada_Version < Ada_05 then
2564 ("generalized use of anonymous access types " &
2565 "is an Ada 2005 extension");
2566 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
2569 if Aliased_Present then
2570 Error_Msg_SP ("ALIASED not allowed here");
2573 Set_Subtype_Indication (CompDef_Node, Empty);
2574 Set_Aliased_Present (CompDef_Node, False);
2575 Set_Access_Definition (CompDef_Node,
2576 P_Access_Definition (Not_Null_Present));
2579 Set_Access_Definition (CompDef_Node, Empty);
2580 Set_Aliased_Present (CompDef_Node, Aliased_Present);
2581 Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
2582 Set_Subtype_Indication (CompDef_Node,
2583 P_Subtype_Indication (Not_Null_Present));
2586 Set_Component_Definition (Def_Node, CompDef_Node);
2589 end P_Array_Type_Definition;
2591 -----------------------------------------
2592 -- 3.6 Unconstrained Array Definition --
2593 -----------------------------------------
2595 -- Parsed by P_Array_Type_Definition (3.6)
2597 ---------------------------------------
2598 -- 3.6 Constrained Array Definition --
2599 ---------------------------------------
2601 -- Parsed by P_Array_Type_Definition (3.6)
2603 --------------------------------------
2604 -- 3.6 Discrete Subtype Definition --
2605 --------------------------------------
2607 -- DISCRETE_SUBTYPE_DEFINITION ::=
2608 -- discrete_SUBTYPE_INDICATION | RANGE
2610 -- Note: the discrete subtype definition appearing in a constrained
2611 -- array definition is parsed by P_Array_Type_Definition (3.6)
2613 -- Error recovery: cannot raise Error_Resync
2615 function P_Discrete_Subtype_Definition return Node_Id is
2617 -- The syntax of a discrete subtype definition is identical to that
2618 -- of a discrete range, so we simply share the same parsing code.
2620 return P_Discrete_Range;
2621 end P_Discrete_Subtype_Definition;
2623 -------------------------------
2624 -- 3.6 Component Definition --
2625 -------------------------------
2627 -- For the array case, parsed by P_Array_Type_Definition (3.6)
2628 -- For the record case, parsed by P_Component_Declaration (3.8)
2630 -----------------------------
2631 -- 3.6.1 Index Constraint --
2632 -----------------------------
2634 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2636 ---------------------------
2637 -- 3.6.1 Discrete Range --
2638 ---------------------------
2640 -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
2642 -- The possible forms for a discrete range are:
2644 -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2)
2645 -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2)
2646 -- Range_Attribute (RANGE, 3.5)
2647 -- Simple_Expression .. Simple_Expression (RANGE, 3.5)
2649 -- Error recovery: cannot raise Error_Resync
2651 function P_Discrete_Range return Node_Id is
2652 Expr_Node : Node_Id;
2653 Range_Node : Node_Id;
2656 Expr_Node := P_Simple_Expression_Or_Range_Attribute;
2658 if Expr_Form = EF_Range_Attr then
2661 elsif Token = Tok_Range then
2662 if Expr_Form /= EF_Simple_Name then
2663 Error_Msg_SC ("range must be preceded by subtype mark");
2666 return P_Subtype_Indication (Expr_Node);
2668 -- Check Expression .. Expression case
2670 elsif Token = Tok_Dot_Dot then
2671 Range_Node := New_Node (N_Range, Token_Ptr);
2672 Set_Low_Bound (Range_Node, Expr_Node);
2674 Expr_Node := P_Expression;
2675 Check_Simple_Expression (Expr_Node);
2676 Set_High_Bound (Range_Node, Expr_Node);
2679 -- Otherwise we must have a subtype mark
2681 elsif Expr_Form = EF_Simple_Name then
2684 -- If incorrect, complain that we expect ..
2690 end P_Discrete_Range;
2692 ----------------------------
2693 -- 3.7 Discriminant Part --
2694 ----------------------------
2696 -- DISCRIMINANT_PART ::=
2697 -- UNKNOWN_DISCRIMINANT_PART
2698 -- | KNOWN_DISCRIMINANT_PART
2700 -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
2701 -- or P_Unknown_Discriminant_Part (3.7), since we know which we want.
2703 ------------------------------------
2704 -- 3.7 Unknown Discriminant Part --
2705 ------------------------------------
2707 -- UNKNOWN_DISCRIMINANT_PART ::= (<>)
2709 -- If no unknown discriminant part is present, then False is returned,
2710 -- otherwise the unknown discriminant is scanned out and True is returned.
2712 -- Error recovery: cannot raise Error_Resync
2714 function P_Unknown_Discriminant_Part_Opt return Boolean is
2715 Scan_State : Saved_Scan_State;
2718 if Token /= Tok_Left_Paren then
2722 Save_Scan_State (Scan_State);
2723 Scan; -- past the left paren
2725 if Token = Tok_Box then
2726 if Ada_Version = Ada_83 then
2727 Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!");
2730 Scan; -- past the box
2731 T_Right_Paren; -- must be followed by right paren
2735 Restore_Scan_State (Scan_State);
2739 end P_Unknown_Discriminant_Part_Opt;
2741 ----------------------------------
2742 -- 3.7 Known Discriminant Part --
2743 ----------------------------------
2745 -- KNOWN_DISCRIMINANT_PART ::=
2746 -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
2748 -- DISCRIMINANT_SPECIFICATION ::=
2749 -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
2750 -- [:= DEFAULT_EXPRESSION]
2751 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
2752 -- [:= DEFAULT_EXPRESSION]
2754 -- If no known discriminant part is present, then No_List is returned
2756 -- Error recovery: cannot raise Error_Resync
2758 function P_Known_Discriminant_Part_Opt return List_Id is
2759 Specification_Node : Node_Id;
2760 Specification_List : List_Id;
2761 Ident_Sloc : Source_Ptr;
2762 Scan_State : Saved_Scan_State;
2764 Not_Null_Present : Boolean;
2767 Idents : array (Int range 1 .. 4096) of Entity_Id;
2768 -- This array holds the list of defining identifiers. The upper bound
2769 -- of 4096 is intended to be essentially infinite, and we do not even
2770 -- bother to check for it being exceeded.
2773 if Token = Tok_Left_Paren then
2774 Specification_List := New_List;
2776 P_Pragmas_Misplaced;
2778 Specification_Loop : loop
2780 Ident_Sloc := Token_Ptr;
2781 Idents (1) := P_Defining_Identifier (C_Comma_Colon);
2784 while Comma_Present loop
2785 Num_Idents := Num_Idents + 1;
2786 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
2789 -- If there are multiple identifiers, we repeatedly scan the
2790 -- type and initialization expression information by resetting
2791 -- the scan pointer (so that we get completely separate trees
2792 -- for each occurrence).
2794 if Num_Idents > 1 then
2795 Save_Scan_State (Scan_State);
2800 -- Loop through defining identifiers in list
2804 Specification_Node :=
2805 New_Node (N_Discriminant_Specification, Ident_Sloc);
2806 Set_Defining_Identifier (Specification_Node, Idents (Ident));
2807 Not_Null_Present := -- Ada 2005 (AI-231, AI-447)
2808 P_Null_Exclusion (Allow_Anonymous_In_95 => True);
2810 if Token = Tok_Access then
2811 if Ada_Version = Ada_83 then
2813 ("(Ada 83) access discriminant not allowed!");
2816 Set_Discriminant_Type
2817 (Specification_Node,
2818 P_Access_Definition (Not_Null_Present));
2821 Set_Discriminant_Type
2822 (Specification_Node, P_Subtype_Mark);
2824 Set_Null_Exclusion_Present -- Ada 2005 (AI-231)
2825 (Specification_Node, Not_Null_Present);
2829 (Specification_Node, Init_Expr_Opt (True));
2832 Set_Prev_Ids (Specification_Node, True);
2835 if Ident < Num_Idents then
2836 Set_More_Ids (Specification_Node, True);
2839 Append (Specification_Node, Specification_List);
2840 exit Ident_Loop when Ident = Num_Idents;
2842 Restore_Scan_State (Scan_State);
2844 end loop Ident_Loop;
2846 exit Specification_Loop when Token /= Tok_Semicolon;
2848 P_Pragmas_Misplaced;
2849 end loop Specification_Loop;
2852 return Specification_List;
2857 end P_Known_Discriminant_Part_Opt;
2859 -------------------------------------
2860 -- 3.7 DIscriminant Specification --
2861 -------------------------------------
2863 -- Parsed by P_Known_Discriminant_Part_Opt (3.7)
2865 -----------------------------
2866 -- 3.7 Default Expression --
2867 -----------------------------
2869 -- Always parsed (simply as an Expression) by the parent construct
2871 ------------------------------------
2872 -- 3.7.1 Discriminant Constraint --
2873 ------------------------------------
2875 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2877 --------------------------------------------------------
2878 -- 3.7.1 Index or Discriminant Constraint (also 3.6) --
2879 --------------------------------------------------------
2881 -- DISCRIMINANT_CONSTRAINT ::=
2882 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
2884 -- DISCRIMINANT_ASSOCIATION ::=
2885 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2888 -- This routine parses either an index or a discriminant constraint. As
2889 -- is clear from the above grammar, it is often possible to clearly
2890 -- determine which of the two possibilities we have, but there are
2891 -- cases (those in which we have a series of expressions of the same
2892 -- syntactic form as subtype indications), where we cannot tell. Since
2893 -- this means that in any case the semantic phase has to distinguish
2894 -- between the two, there is not much point in the parser trying to
2895 -- distinguish even those cases where the difference is clear. In any
2896 -- case, if we have a situation like:
2898 -- (A => 123, 235 .. 500)
2900 -- it is not clear which of the two items is the wrong one, better to
2901 -- let the semantic phase give a clear message. Consequently, this
2902 -- routine in general returns a list of items which can be either
2903 -- discrete ranges or discriminant associations.
2905 -- The caller has checked that the initial token is a left paren
2907 -- Error recovery: can raise Error_Resync
2909 function P_Index_Or_Discriminant_Constraint return Node_Id is
2910 Scan_State : Saved_Scan_State;
2911 Constr_Node : Node_Id;
2912 Constr_List : List_Id;
2913 Expr_Node : Node_Id;
2914 Result_Node : Node_Id;
2917 Result_Node := New_Node (N_Index_Or_Discriminant_Constraint, Token_Ptr);
2919 Constr_List := New_List;
2920 Set_Constraints (Result_Node, Constr_List);
2922 -- The two syntactic forms are a little mixed up, so what we are doing
2923 -- here is looking at the first entry to determine which case we have
2925 -- A discriminant constraint is a list of discriminant associations,
2926 -- which have one of the following possible forms:
2930 -- Id | Id | .. | Id => Expression
2932 -- An index constraint is a list of discrete ranges which have one
2933 -- of the following possible forms:
2936 -- Subtype_Mark range Range
2938 -- Simple_Expression .. Simple_Expression
2940 -- Loop through discriminants in list
2943 -- Check cases of Id => Expression or Id | Id => Expression
2945 if Token = Tok_Identifier then
2946 Save_Scan_State (Scan_State); -- at Id
2949 if Token = Tok_Arrow or else Token = Tok_Vertical_Bar then
2950 Restore_Scan_State (Scan_State); -- to Id
2951 Append (P_Discriminant_Association, Constr_List);
2954 Restore_Scan_State (Scan_State); -- to Id
2958 -- Otherwise scan out an expression and see what we have got
2960 Expr_Node := P_Expression_Or_Range_Attribute;
2962 if Expr_Form = EF_Range_Attr then
2963 Append (Expr_Node, Constr_List);
2965 elsif Token = Tok_Range then
2966 if Expr_Form /= EF_Simple_Name then
2967 Error_Msg_SC ("subtype mark required before RANGE");
2970 Append (P_Subtype_Indication (Expr_Node), Constr_List);
2973 -- Check Simple_Expression .. Simple_Expression case
2975 elsif Token = Tok_Dot_Dot then
2976 Check_Simple_Expression (Expr_Node);
2977 Constr_Node := New_Node (N_Range, Token_Ptr);
2978 Set_Low_Bound (Constr_Node, Expr_Node);
2980 Expr_Node := P_Expression;
2981 Check_Simple_Expression (Expr_Node);
2982 Set_High_Bound (Constr_Node, Expr_Node);
2983 Append (Constr_Node, Constr_List);
2986 -- Case of an expression which could be either form
2989 Append (Expr_Node, Constr_List);
2993 -- Here with a single entry scanned
2996 exit when not Comma_Present;
3002 end P_Index_Or_Discriminant_Constraint;
3004 -------------------------------------
3005 -- 3.7.1 Discriminant Association --
3006 -------------------------------------
3008 -- DISCRIMINANT_ASSOCIATION ::=
3009 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
3012 -- This routine is used only when the name list is present and the caller
3013 -- has already checked this (by scanning ahead and repositioning the
3016 -- Error_Recovery: cannot raise Error_Resync;
3018 function P_Discriminant_Association return Node_Id is
3019 Discr_Node : Node_Id;
3020 Names_List : List_Id;
3021 Ident_Sloc : Source_Ptr;
3024 Ident_Sloc := Token_Ptr;
3025 Names_List := New_List;
3028 Append (P_Identifier (C_Vertical_Bar_Arrow), Names_List);
3029 exit when Token /= Tok_Vertical_Bar;
3033 Discr_Node := New_Node (N_Discriminant_Association, Ident_Sloc);
3034 Set_Selector_Names (Discr_Node, Names_List);
3036 Set_Expression (Discr_Node, P_Expression);
3038 end P_Discriminant_Association;
3040 ---------------------------------
3041 -- 3.8 Record Type Definition --
3042 ---------------------------------
3044 -- RECORD_TYPE_DEFINITION ::=
3045 -- [[abstract] tagged] [limited] RECORD_DEFINITION
3047 -- There is no node in the tree for a record type definition. Instead
3048 -- a record definition node appears, with possible Abstract_Present,
3049 -- Tagged_Present, and Limited_Present flags set appropriately.
3051 ----------------------------
3052 -- 3.8 Record Definition --
3053 ----------------------------
3055 -- RECORD_DEFINITION ::=
3061 -- Note: in the case where a record definition node is used to represent
3062 -- a record type definition, the caller sets the Tagged_Present and
3063 -- Limited_Present flags in the resulting N_Record_Definition node as
3066 -- Note that the RECORD token at the start may be missing in certain
3067 -- error situations, so this function is expected to post the error
3069 -- Error recovery: can raise Error_Resync
3071 function P_Record_Definition return Node_Id is
3075 Rec_Node := New_Node (N_Record_Definition, Token_Ptr);
3079 if Token = Tok_Null then
3082 Set_Null_Present (Rec_Node, True);
3084 -- Case starting with RECORD keyword. Build scope stack entry. For the
3085 -- column, we use the first non-blank character on the line, to deal
3086 -- with situations such as:
3092 -- which is not official RM indentation, but is not uncommon usage
3096 Scope.Table (Scope.Last).Etyp := E_Record;
3097 Scope.Table (Scope.Last).Ecol := Start_Column;
3098 Scope.Table (Scope.Last).Sloc := Token_Ptr;
3099 Scope.Table (Scope.Last).Labl := Error;
3100 Scope.Table (Scope.Last).Junk := (Token /= Tok_Record);
3104 Set_Component_List (Rec_Node, P_Component_List);
3107 exit when Check_End;
3108 Discard_Junk_Node (P_Component_List);
3113 end P_Record_Definition;
3115 -------------------------
3116 -- 3.8 Component List --
3117 -------------------------
3119 -- COMPONENT_LIST ::=
3120 -- COMPONENT_ITEM {COMPONENT_ITEM}
3121 -- | {COMPONENT_ITEM} VARIANT_PART
3124 -- Error recovery: cannot raise Error_Resync
3126 function P_Component_List return Node_Id is
3127 Component_List_Node : Node_Id;
3128 Decls_List : List_Id;
3129 Scan_State : Saved_Scan_State;
3132 Component_List_Node := New_Node (N_Component_List, Token_Ptr);
3133 Decls_List := New_List;
3135 if Token = Tok_Null then
3138 P_Pragmas_Opt (Decls_List);
3139 Set_Null_Present (Component_List_Node, True);
3140 return Component_List_Node;
3143 P_Pragmas_Opt (Decls_List);
3145 if Token /= Tok_Case then
3146 Component_Scan_Loop : loop
3147 P_Component_Items (Decls_List);
3148 P_Pragmas_Opt (Decls_List);
3150 exit Component_Scan_Loop when Token = Tok_End
3151 or else Token = Tok_Case
3152 or else Token = Tok_When;
3154 -- We are done if we do not have an identifier. However, if
3155 -- we have a misspelled reserved identifier that is in a column
3156 -- to the right of the record definition, we will treat it as
3157 -- an identifier. It turns out to be too dangerous in practice
3158 -- to accept such a mis-spelled identifier which does not have
3159 -- this additional clue that confirms the incorrect spelling.
3161 if Token /= Tok_Identifier then
3162 if Start_Column > Scope.Table (Scope.Last).Ecol
3163 and then Is_Reserved_Identifier
3165 Save_Scan_State (Scan_State); -- at reserved id
3166 Scan; -- possible reserved id
3168 if Token = Tok_Comma or else Token = Tok_Colon then
3169 Restore_Scan_State (Scan_State);
3170 Scan_Reserved_Identifier (Force_Msg => True);
3172 -- Note reserved identifier used as field name after
3173 -- all because not followed by colon or comma
3176 Restore_Scan_State (Scan_State);
3177 exit Component_Scan_Loop;
3180 -- Non-identifier that definitely was not reserved id
3183 exit Component_Scan_Loop;
3186 end loop Component_Scan_Loop;
3189 if Token = Tok_Case then
3190 Set_Variant_Part (Component_List_Node, P_Variant_Part);
3192 -- Check for junk after variant part
3194 if Token = Tok_Identifier then
3195 Save_Scan_State (Scan_State);
3196 Scan; -- past identifier
3198 if Token = Tok_Colon then
3199 Restore_Scan_State (Scan_State);
3200 Error_Msg_SC ("component may not follow variant part");
3201 Discard_Junk_Node (P_Component_List);
3203 elsif Token = Tok_Case then
3204 Restore_Scan_State (Scan_State);
3205 Error_Msg_SC ("only one variant part allowed in a record");
3206 Discard_Junk_Node (P_Component_List);
3209 Restore_Scan_State (Scan_State);
3215 Set_Component_Items (Component_List_Node, Decls_List);
3216 return Component_List_Node;
3217 end P_Component_List;
3219 -------------------------
3220 -- 3.8 Component Item --
3221 -------------------------
3223 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
3225 -- COMPONENT_DECLARATION ::=
3226 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
3227 -- [:= DEFAULT_EXPRESSION];
3229 -- COMPONENT_DEFINITION ::=
3230 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
3232 -- Error recovery: cannot raise Error_Resync, if an error occurs,
3233 -- the scan is positioned past the following semicolon.
3235 -- Note: we do not yet allow representation clauses to appear as component
3236 -- items, do we need to add this capability sometime in the future ???
3238 procedure P_Component_Items (Decls : List_Id) is
3239 Aliased_Present : Boolean := False;
3240 CompDef_Node : Node_Id;
3241 Decl_Node : Node_Id;
3242 Scan_State : Saved_Scan_State;
3243 Not_Null_Present : Boolean := False;
3246 Ident_Sloc : Source_Ptr;
3248 Idents : array (Int range 1 .. 4096) of Entity_Id;
3249 -- This array holds the list of defining identifiers. The upper bound
3250 -- of 4096 is intended to be essentially infinite, and we do not even
3251 -- bother to check for it being exceeded.
3254 if Token /= Tok_Identifier then
3255 Error_Msg_SC ("component declaration expected");
3256 Resync_Past_Semicolon;
3260 Ident_Sloc := Token_Ptr;
3261 Idents (1) := P_Defining_Identifier (C_Comma_Colon);
3264 while Comma_Present loop
3265 Num_Idents := Num_Idents + 1;
3266 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
3269 -- If there are multiple identifiers, we repeatedly scan the
3270 -- type and initialization expression information by resetting
3271 -- the scan pointer (so that we get completely separate trees
3272 -- for each occurrence).
3274 if Num_Idents > 1 then
3275 Save_Scan_State (Scan_State);
3280 -- Loop through defining identifiers in list
3285 -- The following block is present to catch Error_Resync
3286 -- which causes the parse to be reset past the semicolon
3289 Decl_Node := New_Node (N_Component_Declaration, Ident_Sloc);
3290 Set_Defining_Identifier (Decl_Node, Idents (Ident));
3292 if Token = Tok_Constant then
3293 Error_Msg_SC ("constant components are not permitted");
3297 CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
3299 if Token_Name = Name_Aliased then
3300 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
3303 if Token = Tok_Aliased then
3304 Aliased_Present := True;
3305 Scan; -- past ALIASED
3308 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254)
3310 -- Ada 2005 (AI-230): Access Definition case
3312 if Token = Tok_Access then
3313 if Ada_Version < Ada_05 then
3315 ("generalized use of anonymous access types " &
3316 "is an Ada 2005 extension");
3317 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
3320 if Aliased_Present then
3321 Error_Msg_SP ("ALIASED not allowed here");
3324 Set_Subtype_Indication (CompDef_Node, Empty);
3325 Set_Aliased_Present (CompDef_Node, False);
3326 Set_Access_Definition (CompDef_Node,
3327 P_Access_Definition (Not_Null_Present));
3330 Set_Access_Definition (CompDef_Node, Empty);
3331 Set_Aliased_Present (CompDef_Node, Aliased_Present);
3332 Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
3334 if Token = Tok_Array then
3336 ("anonymous arrays not allowed as components");
3340 Set_Subtype_Indication (CompDef_Node,
3341 P_Subtype_Indication (Not_Null_Present));
3344 Set_Component_Definition (Decl_Node, CompDef_Node);
3345 Set_Expression (Decl_Node, Init_Expr_Opt);
3348 Set_Prev_Ids (Decl_Node, True);
3351 if Ident < Num_Idents then
3352 Set_More_Ids (Decl_Node, True);
3355 Append (Decl_Node, Decls);
3358 when Error_Resync =>
3359 if Token /= Tok_End then
3360 Resync_Past_Semicolon;
3364 exit Ident_Loop when Ident = Num_Idents;
3366 Restore_Scan_State (Scan_State);
3369 end loop Ident_Loop;
3372 end P_Component_Items;
3374 --------------------------------
3375 -- 3.8 Component Declaration --
3376 --------------------------------
3378 -- Parsed by P_Component_Items (3.8)
3380 -------------------------
3381 -- 3.8.1 Variant Part --
3382 -------------------------
3385 -- case discriminant_DIRECT_NAME is
3390 -- The caller has checked that the initial token is CASE
3392 -- Error recovery: cannot raise Error_Resync
3394 function P_Variant_Part return Node_Id is
3395 Variant_Part_Node : Node_Id;
3396 Variants_List : List_Id;
3397 Case_Node : Node_Id;
3398 Ident_Token : Token_Type;
3401 Variant_Part_Node := New_Node (N_Variant_Part, Token_Ptr);
3403 Scope.Table (Scope.Last).Etyp := E_Case;
3404 Scope.Table (Scope.Last).Sloc := Token_Ptr;
3405 Scope.Table (Scope.Last).Ecol := Start_Column;
3409 -- A discriminant name between parentheses will be returned as
3410 -- a N_Identifier although it is not allowed by RM 3.8.1. We
3411 -- save the token type to check it later. However, in case of
3412 -- a discriminant name with parentheses, we can continue the
3413 -- analysis as if only the discriminant name had been given.
3415 Ident_Token := Token;
3416 Case_Node := P_Expression;
3418 if Nkind (Case_Node) = N_Identifier then
3419 Set_Name (Variant_Part_Node, Case_Node);
3421 Set_Name (Variant_Part_Node, Error);
3424 if Nkind (Case_Node) /= N_Identifier
3425 or else Ident_Token /= Tok_Identifier
3427 Error_Msg ("discriminant name expected", Sloc (Case_Node));
3431 Variants_List := New_List;
3432 P_Pragmas_Opt (Variants_List);
3434 -- Test missing variant
3436 if Token = Tok_End then
3437 Error_Msg_BC ("WHEN expected (must have at least one variant)");
3439 Append (P_Variant, Variants_List);
3442 -- Loop through variants, note that we allow if in place of when,
3443 -- this error will be detected and handled in P_Variant.
3446 P_Pragmas_Opt (Variants_List);
3448 if Token /= Tok_When
3449 and then Token /= Tok_If
3450 and then Token /= Tok_Others
3452 exit when Check_End;
3455 Append (P_Variant, Variants_List);
3458 Set_Variants (Variant_Part_Node, Variants_List);
3459 return Variant_Part_Node;
3462 --------------------
3464 --------------------
3467 -- when DISCRETE_CHOICE_LIST =>
3470 -- Error recovery: cannot raise Error_Resync
3472 -- The initial token on entry is either WHEN, IF or OTHERS
3474 function P_Variant return Node_Id is
3475 Variant_Node : Node_Id;
3478 -- Special check to recover nicely from use of IF in place of WHEN
3480 if Token = Tok_If then
3487 Variant_Node := New_Node (N_Variant, Prev_Token_Ptr);
3488 Set_Discrete_Choices (Variant_Node, P_Discrete_Choice_List);
3490 Set_Component_List (Variant_Node, P_Component_List);
3491 return Variant_Node;
3494 ---------------------------------
3495 -- 3.8.1 Discrete Choice List --
3496 ---------------------------------
3498 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
3500 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
3502 -- Note: in Ada 83, the expression must be a simple expression
3504 -- Error recovery: cannot raise Error_Resync
3506 function P_Discrete_Choice_List return List_Id is
3508 Expr_Node : Node_Id;
3509 Choice_Node : Node_Id;
3512 Choices := New_List;
3515 if Token = Tok_Others then
3516 Append (New_Node (N_Others_Choice, Token_Ptr), Choices);
3517 Scan; -- past OTHERS
3521 Expr_Node := P_Expression_Or_Range_Attribute;
3522 Check_No_Right_Paren;
3524 if Token = Tok_Colon
3525 and then Nkind (Expr_Node) = N_Identifier
3527 Error_Msg_SP ("label not permitted in this context");
3530 elsif Expr_Form = EF_Range_Attr then
3531 Append (Expr_Node, Choices);
3533 elsif Token = Tok_Dot_Dot then
3534 Check_Simple_Expression (Expr_Node);
3535 Choice_Node := New_Node (N_Range, Token_Ptr);
3536 Set_Low_Bound (Choice_Node, Expr_Node);
3538 Expr_Node := P_Expression_No_Right_Paren;
3539 Check_Simple_Expression (Expr_Node);
3540 Set_High_Bound (Choice_Node, Expr_Node);
3541 Append (Choice_Node, Choices);
3543 elsif Expr_Form = EF_Simple_Name then
3544 if Token = Tok_Range then
3545 Append (P_Subtype_Indication (Expr_Node), Choices);
3547 elsif Token in Token_Class_Consk then
3549 ("the only constraint allowed here " &
3550 "is a range constraint");
3551 Discard_Junk_Node (P_Constraint_Opt);
3552 Append (Expr_Node, Choices);
3555 Append (Expr_Node, Choices);
3559 Check_Simple_Expression_In_Ada_83 (Expr_Node);
3560 Append (Expr_Node, Choices);
3564 when Error_Resync =>
3570 if Token = Tok_Comma then
3571 Error_Msg_SC (""","" should be ""'|""");
3573 exit when Token /= Tok_Vertical_Bar;
3576 Scan; -- past | or comma
3580 end P_Discrete_Choice_List;
3582 ----------------------------
3583 -- 3.8.1 Discrete Choice --
3584 ----------------------------
3586 -- Parsed by P_Discrete_Choice_List (3.8.1)
3588 ----------------------------------
3589 -- 3.9.1 Record Extension Part --
3590 ----------------------------------
3592 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
3594 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
3596 --------------------------------------
3597 -- 3.9.4 Interface Type Definition --
3598 --------------------------------------
3600 -- INTERFACE_TYPE_DEFINITION ::=
3601 -- [limited | task | protected | synchronized] interface
3602 -- [and INTERFACE_LIST]
3604 -- Error recovery: cannot raise Error_Resync
3606 function P_Interface_Type_Definition
3607 (Abstract_Present : Boolean) return Node_Id
3609 Typedef_Node : Node_Id;
3612 if Ada_Version < Ada_05 then
3613 Error_Msg_SP ("abstract interface is an Ada 2005 extension");
3614 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
3617 if Abstract_Present then
3618 Error_Msg_SP ("ABSTRACT not allowed in interface type definition " &
3622 Scan; -- past INTERFACE
3624 -- Ada 2005 (AI-345): In case of interfaces with a null list of
3625 -- interfaces we build a record_definition node.
3627 if Token = Tok_Semicolon then
3628 Typedef_Node := New_Node (N_Record_Definition, Token_Ptr);
3630 Set_Abstract_Present (Typedef_Node);
3631 Set_Tagged_Present (Typedef_Node);
3632 Set_Null_Present (Typedef_Node);
3633 Set_Interface_Present (Typedef_Node);
3635 -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have
3636 -- a list of interfaces we build a derived_type_definition node. This
3637 -- simplifies the semantic analysis (and hence further mainteinance)
3640 if Token /= Tok_And then
3641 Error_Msg_AP ("AND expected");
3646 Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
3648 Set_Abstract_Present (Typedef_Node);
3649 Set_Interface_Present (Typedef_Node);
3650 Set_Subtype_Indication (Typedef_Node, P_Qualified_Simple_Name);
3652 Set_Record_Extension_Part (Typedef_Node,
3653 New_Node (N_Record_Definition, Token_Ptr));
3654 Set_Null_Present (Record_Extension_Part (Typedef_Node));
3656 if Token = Tok_And then
3657 Set_Interface_List (Typedef_Node, New_List);
3661 Append (P_Qualified_Simple_Name,
3662 Interface_List (Typedef_Node));
3663 exit when Token /= Tok_And;
3669 return Typedef_Node;
3670 end P_Interface_Type_Definition;
3672 ----------------------------------
3673 -- 3.10 Access Type Definition --
3674 ----------------------------------
3676 -- ACCESS_TYPE_DEFINITION ::=
3677 -- ACCESS_TO_OBJECT_DEFINITION
3678 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3680 -- ACCESS_TO_OBJECT_DEFINITION ::=
3681 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
3683 -- GENERAL_ACCESS_MODIFIER ::= all | constant
3685 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3686 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3687 -- | [NULL_EXCLUSION] access [protected] function
3688 -- PARAMETER_AND_RESULT_PROFILE
3690 -- PARAMETER_PROFILE ::= [FORMAL_PART]
3692 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
3694 -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already
3695 -- parsed the null_exclusion part and has also removed the ACCESS token;
3696 -- otherwise the caller has just checked that the initial token is ACCESS
3698 -- Error recovery: can raise Error_Resync
3700 function P_Access_Type_Definition
3701 (Header_Already_Parsed : Boolean := False) return Node_Id
3703 Access_Loc : constant Source_Ptr := Token_Ptr;
3704 Prot_Flag : Boolean;
3705 Not_Null_Present : Boolean := False;
3706 Type_Def_Node : Node_Id;
3707 Result_Not_Null : Boolean;
3708 Result_Node : Node_Id;
3710 procedure Check_Junk_Subprogram_Name;
3711 -- Used in access to subprogram definition cases to check for an
3712 -- identifier or operator symbol that does not belong.
3714 --------------------------------
3715 -- Check_Junk_Subprogram_Name --
3716 --------------------------------
3718 procedure Check_Junk_Subprogram_Name is
3719 Saved_State : Saved_Scan_State;
3722 if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
3723 Save_Scan_State (Saved_State);
3724 Scan; -- past possible junk subprogram name
3726 if Token = Tok_Left_Paren or else Token = Tok_Semicolon then
3727 Error_Msg_SP ("unexpected subprogram name ignored");
3731 Restore_Scan_State (Saved_State);
3734 end Check_Junk_Subprogram_Name;
3736 -- Start of processing for P_Access_Type_Definition
3739 if not Header_Already_Parsed then
3740 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
3741 Scan; -- past ACCESS
3744 if Token_Name = Name_Protected then
3745 Check_95_Keyword (Tok_Protected, Tok_Procedure);
3746 Check_95_Keyword (Tok_Protected, Tok_Function);
3749 Prot_Flag := (Token = Tok_Protected);
3752 Scan; -- past PROTECTED
3754 if Token /= Tok_Procedure and then Token /= Tok_Function then
3755 Error_Msg_SC ("FUNCTION or PROCEDURE expected");
3759 if Token = Tok_Procedure then
3760 if Ada_Version = Ada_83 then
3761 Error_Msg_SC ("(Ada 83) access to procedure not allowed!");
3764 Type_Def_Node := New_Node (N_Access_Procedure_Definition, Access_Loc);
3765 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3766 Scan; -- past PROCEDURE
3767 Check_Junk_Subprogram_Name;
3768 Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
3769 Set_Protected_Present (Type_Def_Node, Prot_Flag);
3771 elsif Token = Tok_Function then
3772 if Ada_Version = Ada_83 then
3773 Error_Msg_SC ("(Ada 83) access to function not allowed!");
3776 Type_Def_Node := New_Node (N_Access_Function_Definition, Access_Loc);
3777 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3778 Scan; -- past FUNCTION
3779 Check_Junk_Subprogram_Name;
3780 Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
3781 Set_Protected_Present (Type_Def_Node, Prot_Flag);
3784 Result_Not_Null := P_Null_Exclusion; -- Ada 2005 (AI-231)
3786 -- Ada 2005 (AI-318-02)
3788 if Token = Tok_Access then
3789 if Ada_Version < Ada_05 then
3791 ("anonymous access result type is an Ada 2005 extension");
3792 Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
3795 Result_Node := P_Access_Definition (Result_Not_Null);
3798 Result_Node := P_Subtype_Mark;
3802 -- Note: A null exclusion given on the result type needs to
3803 -- be coded by a distinct flag, since Null_Exclusion_Present
3804 -- on an access-to-function type pertains to a null exclusion
3805 -- on the access type itself (as set above). ???
3806 -- Set_Null_Exclusion_Present??? (Type_Def_Node, Result_Not_Null);
3808 Set_Result_Definition (Type_Def_Node, Result_Node);
3812 New_Node (N_Access_To_Object_Definition, Access_Loc);
3813 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3815 if Token = Tok_All or else Token = Tok_Constant then
3816 if Ada_Version = Ada_83 then
3817 Error_Msg_SC ("(Ada 83) access modifier not allowed!");
3820 if Token = Tok_All then
3821 Set_All_Present (Type_Def_Node, True);
3824 Set_Constant_Present (Type_Def_Node, True);
3827 Scan; -- past ALL or CONSTANT
3830 Set_Subtype_Indication (Type_Def_Node,
3831 P_Subtype_Indication (Not_Null_Present));
3834 return Type_Def_Node;
3835 end P_Access_Type_Definition;
3837 ---------------------------------------
3838 -- 3.10 Access To Object Definition --
3839 ---------------------------------------
3841 -- Parsed by P_Access_Type_Definition (3.10)
3843 -----------------------------------
3844 -- 3.10 General Access Modifier --
3845 -----------------------------------
3847 -- Parsed by P_Access_Type_Definition (3.10)
3849 -------------------------------------------
3850 -- 3.10 Access To Subprogram Definition --
3851 -------------------------------------------
3853 -- Parsed by P_Access_Type_Definition (3.10)
3855 -----------------------------
3856 -- 3.10 Access Definition --
3857 -----------------------------
3859 -- ACCESS_DEFINITION ::=
3860 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3861 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3863 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3864 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3865 -- | [NULL_EXCLUSION] access [protected] function
3866 -- PARAMETER_AND_RESULT_PROFILE
3868 -- The caller has parsed the null-exclusion part and it has also checked
3869 -- that the next token is ACCESS
3871 -- Error recovery: cannot raise Error_Resync
3873 function P_Access_Definition
3874 (Null_Exclusion_Present : Boolean) return Node_Id
3877 Subp_Node : Node_Id;
3880 Def_Node := New_Node (N_Access_Definition, Token_Ptr);
3881 Scan; -- past ACCESS
3883 -- Ada 2005 (AI-254): Access_To_Subprogram_Definition
3885 if Token = Tok_Protected
3886 or else Token = Tok_Procedure
3887 or else Token = Tok_Function
3889 if Ada_Version < Ada_05 then
3890 Error_Msg_SP ("access-to-subprogram is an Ada 2005 extension");
3891 Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
3894 Subp_Node := P_Access_Type_Definition (Header_Already_Parsed => True);
3895 Set_Null_Exclusion_Present (Subp_Node, Null_Exclusion_Present);
3896 Set_Access_To_Subprogram_Definition (Def_Node, Subp_Node);
3898 -- Ada 2005 (AI-231)
3899 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3902 Set_Null_Exclusion_Present (Def_Node, Null_Exclusion_Present);
3904 if Token = Tok_All then
3905 if Ada_Version < Ada_05 then
3907 ("access-all in this context is an Ada 2005 extension");
3908 Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
3912 Set_All_Present (Def_Node);
3914 elsif Token = Tok_Constant then
3915 if Ada_Version < Ada_05 then
3916 Error_Msg_SP ("access-to-constant is an Ada 2005 extension");
3917 Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
3920 Scan; -- past CONSTANT
3921 Set_Constant_Present (Def_Node);
3924 Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
3929 end P_Access_Definition;
3931 -----------------------------------------
3932 -- 3.10.1 Incomplete Type Declaration --
3933 -----------------------------------------
3935 -- Parsed by P_Type_Declaration (3.2.1)
3937 ----------------------------
3938 -- 3.11 Declarative Part --
3939 ----------------------------
3941 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
3943 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items
3944 -- handles errors, and returns cleanly after an error has occurred)
3946 function P_Declarative_Part return List_Id is
3951 -- Indicate no bad declarations detected yet. This will be reset by
3952 -- P_Declarative_Items if a bad declaration is discovered.
3954 Missing_Begin_Msg := No_Error_Msg;
3956 -- Get rid of active SIS entry from outer scope. This means we will
3957 -- miss some nested cases, but it doesn't seem worth the effort. See
3958 -- discussion in Par for further details
3960 SIS_Entry_Active := False;
3963 -- Loop to scan out the declarations
3966 P_Declarative_Items (Decls, Done, In_Spec => False);
3970 -- Get rid of active SIS entry which is left set only if we scanned a
3971 -- procedure declaration and have not found the body. We could give
3972 -- an error message, but that really would be usurping the role of
3973 -- semantic analysis (this really is a missing body case).
3975 SIS_Entry_Active := False;
3977 end P_Declarative_Part;
3979 ----------------------------
3980 -- 3.11 Declarative Item --
3981 ----------------------------
3983 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
3985 -- Can return Error if a junk declaration is found, or Empty if no
3986 -- declaration is found (i.e. a token ending declarations, such as
3987 -- BEGIN or END is encountered).
3989 -- Error recovery: cannot raise Error_Resync. If an error resync occurs,
3990 -- then the scan is set past the next semicolon and Error is returned.
3992 procedure P_Declarative_Items
3997 Scan_State : Saved_Scan_State;
4001 Style.Check_Indentation;
4006 when Tok_Function =>
4008 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4014 -- Check for loop (premature statement)
4016 Save_Scan_State (Scan_State);
4019 if Token = Tok_Identifier then
4020 Scan; -- past identifier
4022 if Token = Tok_In then
4023 Restore_Scan_State (Scan_State);
4024 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
4029 -- Not a loop, so must be rep clause
4031 Restore_Scan_State (Scan_State);
4032 Append (P_Representation_Clause, Decls);
4037 Append (P_Generic, Decls);
4040 when Tok_Identifier =>
4042 P_Identifier_Declarations (Decls, Done, In_Spec);
4044 -- Ada2005: A subprogram declaration can start with "not" or
4045 -- "overriding". In older versions, "overriding" is handled
4046 -- like an identifier, with the appropriate warning.
4050 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4053 when Tok_Overriding =>
4055 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4060 Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4064 Append (P_Pragma, Decls);
4067 when Tok_Procedure =>
4069 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4072 when Tok_Protected =>
4074 Scan; -- past PROTECTED
4075 Append (P_Protected, Decls);
4080 Append (P_Subtype_Declaration, Decls);
4086 Append (P_Task, Decls);
4091 Append (P_Type_Declaration, Decls);
4096 Append (P_Use_Clause, Decls);
4101 Error_Msg_SC ("WITH can only appear in context clause");
4104 -- BEGIN terminates the scan of a sequence of declarations unless
4105 -- there is a missing subprogram body, see section on handling
4106 -- semicolon in place of IS. We only treat the begin as satisfying
4107 -- the subprogram declaration if it falls in the expected column
4111 if SIS_Entry_Active and then Start_Column >= SIS_Ecol then
4113 -- Here we have the case where a BEGIN is encountered during
4114 -- declarations in a declarative part, or at the outer level,
4115 -- and there is a subprogram declaration outstanding for which
4116 -- no body has been supplied. This is the case where we assume
4117 -- that the semicolon in the subprogram declaration should
4118 -- really have been is. The active SIS entry describes the
4119 -- subprogram declaration. On return the declaration has been
4120 -- modified to become a body.
4123 Specification_Node : Node_Id;
4124 Decl_Node : Node_Id;
4125 Body_Node : Node_Id;
4128 -- First issue the error message. If we had a missing
4129 -- semicolon in the declaration, then change the message
4130 -- to <missing "is">
4132 if SIS_Missing_Semicolon_Message /= No_Error_Msg then
4133 Change_Error_Text -- Replace: "missing "";"" "
4134 (SIS_Missing_Semicolon_Message, "missing ""is""");
4136 -- Otherwise we saved the semicolon position, so complain
4139 Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc);
4142 -- The next job is to fix up any declarations that occurred
4143 -- between the procedure header and the BEGIN. These got
4144 -- chained to the outer declarative region (immediately
4145 -- after the procedure declaration) and they should be
4146 -- chained to the subprogram itself, which is a body
4147 -- rather than a spec.
4149 Specification_Node := Specification (SIS_Declaration_Node);
4150 Change_Node (SIS_Declaration_Node, N_Subprogram_Body);
4151 Body_Node := SIS_Declaration_Node;
4152 Set_Specification (Body_Node, Specification_Node);
4153 Set_Declarations (Body_Node, New_List);
4156 Decl_Node := Remove_Next (Body_Node);
4157 exit when Decl_Node = Empty;
4158 Append (Decl_Node, Declarations (Body_Node));
4161 -- Now make the scope table entry for the Begin-End and
4165 Scope.Table (Scope.Last).Sloc := SIS_Sloc;
4166 Scope.Table (Scope.Last).Etyp := E_Name;
4167 Scope.Table (Scope.Last).Ecol := SIS_Ecol;
4168 Scope.Table (Scope.Last).Labl := SIS_Labl;
4169 Scope.Table (Scope.Last).Lreq := False;
4170 SIS_Entry_Active := False;
4172 Set_Handled_Statement_Sequence (Body_Node,
4173 P_Handled_Sequence_Of_Statements);
4174 End_Statements (Handled_Statement_Sequence (Body_Node));
4183 -- Normally an END terminates the scan for basic declarative
4184 -- items. The one exception is END RECORD, which is probably
4185 -- left over from some other junk.
4188 Save_Scan_State (Scan_State); -- at END
4191 if Token = Tok_Record then
4192 Error_Msg_SP ("no RECORD for this `end record`!");
4193 Scan; -- past RECORD
4197 Restore_Scan_State (Scan_State); -- to END
4201 -- The following tokens which can only be the start of a statement
4202 -- are considered to end a declarative part (i.e. we have a missing
4203 -- BEGIN situation). We are fairly conservative in making this
4204 -- judgment, because it is a real mess to go into statement mode
4205 -- prematurely in response to a junk declaration.
4220 -- But before we decide that it's a statement, let's check for
4221 -- a reserved word misused as an identifier.
4223 if Is_Reserved_Identifier then
4224 Save_Scan_State (Scan_State);
4225 Scan; -- past the token
4227 -- If reserved identifier not followed by colon or comma, then
4228 -- this is most likely an assignment statement to the bad id.
4230 if Token /= Tok_Colon and then Token /= Tok_Comma then
4231 Restore_Scan_State (Scan_State);
4232 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
4235 -- Otherwise we have a declaration of the bad id
4238 Restore_Scan_State (Scan_State);
4239 Scan_Reserved_Identifier (Force_Msg => True);
4240 P_Identifier_Declarations (Decls, Done, In_Spec);
4243 -- If not reserved identifier, then it's definitely a statement
4246 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
4250 -- The token RETURN may well also signal a missing BEGIN situation,
4251 -- however, we never let it end the declarative part, because it may
4252 -- also be part of a half-baked function declaration.
4255 Error_Msg_SC ("misplaced RETURN statement");
4258 -- PRIVATE definitely terminates the declarations in a spec,
4259 -- and is an error in a body.
4265 Error_Msg_SC ("PRIVATE not allowed in body");
4266 Scan; -- past PRIVATE
4269 -- An end of file definitely terminates the declarations!
4274 -- The remaining tokens do not end the scan, but cannot start a
4275 -- valid declaration, so we signal an error and resynchronize.
4276 -- But first check for misuse of a reserved identifier.
4280 -- Here we check for a reserved identifier
4282 if Is_Reserved_Identifier then
4283 Save_Scan_State (Scan_State);
4284 Scan; -- past the token
4286 if Token /= Tok_Colon and then Token /= Tok_Comma then
4287 Restore_Scan_State (Scan_State);
4288 Set_Declaration_Expected;
4291 Restore_Scan_State (Scan_State);
4292 Scan_Reserved_Identifier (Force_Msg => True);
4294 P_Identifier_Declarations (Decls, Done, In_Spec);
4298 Set_Declaration_Expected;
4303 -- To resynchronize after an error, we scan to the next semicolon and
4304 -- return with Done = False, indicating that there may still be more
4305 -- valid declarations to come.
4308 when Error_Resync =>
4309 Resync_Past_Semicolon;
4311 end P_Declarative_Items;
4313 ----------------------------------
4314 -- 3.11 Basic Declarative Item --
4315 ----------------------------------
4317 -- BASIC_DECLARATIVE_ITEM ::=
4318 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
4320 -- Scan zero or more basic declarative items
4322 -- Error recovery: cannot raise Error_Resync. If an error is detected, then
4323 -- the scan pointer is repositioned past the next semicolon, and the scan
4324 -- for declarative items continues.
4326 function P_Basic_Declarative_Items return List_Id is
4333 -- Indicate no bad declarations detected yet in the current context:
4334 -- visible or private declarations of a package spec.
4336 Missing_Begin_Msg := No_Error_Msg;
4338 -- Get rid of active SIS entry from outer scope. This means we will
4339 -- miss some nested cases, but it doesn't seem worth the effort. See
4340 -- discussion in Par for further details
4342 SIS_Entry_Active := False;
4344 -- Loop to scan out declarations
4349 P_Declarative_Items (Decls, Done, In_Spec => True);
4353 -- Get rid of active SIS entry. This is set only if we have scanned a
4354 -- procedure declaration and have not found the body. We could give
4355 -- an error message, but that really would be usurping the role of
4356 -- semantic analysis (this really is a case of a missing body).
4358 SIS_Entry_Active := False;
4360 -- Test for assorted illegal declarations not diagnosed elsewhere
4362 Decl := First (Decls);
4364 while Present (Decl) loop
4365 Kind := Nkind (Decl);
4367 -- Test for body scanned, not acceptable as basic decl item
4369 if Kind = N_Subprogram_Body or else
4370 Kind = N_Package_Body or else
4371 Kind = N_Task_Body or else
4372 Kind = N_Protected_Body
4375 ("proper body not allowed in package spec", Sloc (Decl));
4377 -- Test for body stub scanned, not acceptable as basic decl item
4379 elsif Kind in N_Body_Stub then
4381 ("body stub not allowed in package spec", Sloc (Decl));
4383 elsif Kind = N_Assignment_Statement then
4385 ("assignment statement not allowed in package spec",
4393 end P_Basic_Declarative_Items;
4399 -- For proper body, see below
4400 -- For body stub, see 10.1.3
4402 -----------------------
4403 -- 3.11 Proper Body --
4404 -----------------------
4406 -- Subprogram body is parsed by P_Subprogram (6.1)
4407 -- Package body is parsed by P_Package (7.1)
4408 -- Task body is parsed by P_Task (9.1)
4409 -- Protected body is parsed by P_Protected (9.4)
4411 ------------------------------
4412 -- Set_Declaration_Expected --
4413 ------------------------------
4415 procedure Set_Declaration_Expected is
4417 Error_Msg_SC ("declaration expected");
4419 if Missing_Begin_Msg = No_Error_Msg then
4420 Missing_Begin_Msg := Get_Msg_Id;
4422 end Set_Declaration_Expected;
4424 ----------------------
4425 -- Skip_Declaration --
4426 ----------------------
4428 procedure Skip_Declaration (S : List_Id) is
4429 Dummy_Done : Boolean;
4430 pragma Warnings (Off, Dummy_Done);
4432 P_Declarative_Items (S, Dummy_Done, False);
4433 end Skip_Declaration;
4435 -----------------------------------------
4436 -- Statement_When_Declaration_Expected --
4437 -----------------------------------------
4439 procedure Statement_When_Declaration_Expected
4445 -- Case of second occurrence of statement in one declaration sequence
4447 if Missing_Begin_Msg /= No_Error_Msg then
4449 -- In the procedure spec case, just ignore it, we only give one
4450 -- message for the first occurrence, since otherwise we may get
4451 -- horrible cascading if BODY was missing in the header line.
4456 -- In the declarative part case, take a second statement as a sure
4457 -- sign that we really have a missing BEGIN, and end the declarative
4458 -- part now. Note that the caller will fix up the first message to
4459 -- say "missing BEGIN" so that's how the error will be signalled.
4466 -- Case of first occurrence of unexpected statement
4469 -- If we are in a package spec, then give message of statement
4470 -- not allowed in package spec. This message never gets changed.
4473 Error_Msg_SC ("statement not allowed in package spec");
4475 -- If in declarative part, then we give the message complaining
4476 -- about finding a statement when a declaration is expected. This
4477 -- gets changed to a complaint about a missing BEGIN if we later
4478 -- find that no BEGIN is present.
4481 Error_Msg_SC ("statement not allowed in declarative part");
4484 -- Capture message Id. This is used for two purposes, first to
4485 -- stop multiple messages, see test above, and second, to allow
4486 -- the replacement of the message in the declarative part case.
4488 Missing_Begin_Msg := Get_Msg_Id;
4491 -- In all cases except the case in which we decided to terminate the
4492 -- declaration sequence on a second error, we scan out the statement
4493 -- and append it to the list of declarations (note that the semantics
4494 -- can handle statements in a declaration list so if we proceed to
4495 -- call the semantic phase, all will be (reasonably) well!
4497 Append_List_To (Decls, P_Sequence_Of_Statements (SS_Unco));
4499 -- Done is set to False, since we want to continue the scan of
4500 -- declarations, hoping that this statement was a temporary glitch.
4501 -- If we indeed are now in the statement part (i.e. this was a missing
4502 -- BEGIN, then it's not terrible, we will simply keep calling this
4503 -- procedure to process the statements one by one, and then finally
4504 -- hit the missing BEGIN, which will clean up the error message.
4507 end Statement_When_Declaration_Expected;