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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 pragma Style_Checks (All_Checks);
28 -- Turn off subprogram body ordering check. Subprograms are in order
29 -- by RM section rather than alphabetical.
31 with Sinfo.CN; use Sinfo.CN;
37 -----------------------
38 -- Local Subprograms --
39 -----------------------
41 function P_Component_List return Node_Id;
42 function P_Defining_Character_Literal return Node_Id;
43 function P_Delta_Constraint return Node_Id;
44 function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id;
45 function P_Digits_Constraint return Node_Id;
46 function P_Discriminant_Association return Node_Id;
47 function P_Enumeration_Literal_Specification return Node_Id;
48 function P_Enumeration_Type_Definition return Node_Id;
49 function P_Fixed_Point_Definition return Node_Id;
50 function P_Floating_Point_Definition return Node_Id;
51 function P_Index_Or_Discriminant_Constraint return Node_Id;
52 function P_Real_Range_Specification_Opt return Node_Id;
53 function P_Subtype_Declaration return Node_Id;
54 function P_Type_Declaration return Node_Id;
55 function P_Modular_Type_Definition return Node_Id;
56 function P_Variant return Node_Id;
57 function P_Variant_Part return Node_Id;
59 procedure P_Declarative_Items
63 -- Scans out a single declarative item, or, in the case of a declaration
64 -- with a list of identifiers, a list of declarations, one for each of
65 -- the identifiers in the list. The declaration or declarations scanned
66 -- are appended to the given list. Done indicates whether or not there
67 -- may be additional declarative items to scan. If Done is True, then
68 -- a decision has been made that there are no more items to scan. If
69 -- Done is False, then there may be additional declarations to scan.
70 -- In_Spec is true if we are scanning a package declaration, and is used
71 -- to generate an appropriate message if a statement is encountered in
74 procedure P_Identifier_Declarations
78 -- Scans out a set of declarations for an identifier or list of
79 -- identifiers, and appends them to the given list. The parameters have
80 -- the same significance as for P_Declarative_Items.
82 procedure Statement_When_Declaration_Expected
86 -- Called when a statement is found at a point where a declaration was
87 -- expected. The parameters are as described for P_Declarative_Items.
89 procedure Set_Declaration_Expected;
90 -- Posts a "declaration expected" error messages at the start of the
91 -- current token, and if this is the first such message issued, saves
92 -- the message id in Missing_Begin_Msg, for possible later replacement.
98 function Init_Expr_Opt (P : Boolean := False) return Node_Id is
100 -- For colon, assume it means := unless it is at the end of
101 -- a line, in which case guess that it means a semicolon.
103 if Token = Tok_Colon then
104 if Token_Is_At_End_Of_Line then
109 -- Here if := or something that we will take as equivalent
111 elsif Token = Tok_Colon_Equal
112 or else Token = Tok_Equal
113 or else Token = Tok_Is
117 -- Another possibility. If we have a literal followed by a semicolon,
118 -- we assume that we have a missing colon-equal.
120 elsif Token in Token_Class_Literal then
122 Scan_State : Saved_Scan_State;
125 Save_Scan_State (Scan_State);
126 Scan; -- past literal or identifier
128 if Token = Tok_Semicolon then
129 Restore_Scan_State (Scan_State);
131 Restore_Scan_State (Scan_State);
136 -- Otherwise we definitely have no initialization expression
142 -- Merge here if we have an initialization expression
149 return P_Expression_No_Right_Paren;
153 ----------------------------
154 -- 3.1 Basic Declaration --
155 ----------------------------
157 -- Parsed by P_Basic_Declarative_Items (3.9)
159 ------------------------------
160 -- 3.1 Defining Identifier --
161 ------------------------------
163 -- DEFINING_IDENTIFIER ::= IDENTIFIER
165 -- Error recovery: can raise Error_Resync
167 function P_Defining_Identifier (C : Id_Check := None) return Node_Id is
168 Ident_Node : Node_Id;
171 -- Scan out the identifier. Note that this code is essentially identical
172 -- to P_Identifier, except that in the call to Scan_Reserved_Identifier
173 -- we set Force_Msg to True, since we want at least one message for each
174 -- separate declaration (but not use) of a reserved identifier.
176 if Token = Tok_Identifier then
178 -- Ada 2005 (AI-284): Compiling in Ada95 mode we warn that INTERFACE,
179 -- OVERRIDING, and SYNCHRONIZED are new reserved words.
181 if Ada_Version = Ada_95
182 and then Warn_On_Ada_2005_Compatibility
184 if Token_Name = Name_Overriding
185 or else Token_Name = Name_Synchronized
186 or else (Token_Name = Name_Interface
187 and then Prev_Token /= Tok_Pragma)
189 Error_Msg_N ("& is a reserved word in Ada 2005?", Token_Node);
193 -- If we have a reserved identifier, manufacture an identifier with
194 -- a corresponding name after posting an appropriate error message
196 elsif Is_Reserved_Identifier (C) then
197 Scan_Reserved_Identifier (Force_Msg => True);
199 -- Otherwise we have junk that cannot be interpreted as an identifier
202 T_Identifier; -- to give message
206 Ident_Node := Token_Node;
207 Scan; -- past the reserved identifier
209 if Ident_Node /= Error then
210 Change_Identifier_To_Defining_Identifier (Ident_Node);
214 end P_Defining_Identifier;
216 -----------------------------
217 -- 3.2.1 Type Declaration --
218 -----------------------------
220 -- TYPE_DECLARATION ::=
221 -- FULL_TYPE_DECLARATION
222 -- | INCOMPLETE_TYPE_DECLARATION
223 -- | PRIVATE_TYPE_DECLARATION
224 -- | PRIVATE_EXTENSION_DECLARATION
226 -- FULL_TYPE_DECLARATION ::=
227 -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION;
228 -- | CONCURRENT_TYPE_DECLARATION
230 -- INCOMPLETE_TYPE_DECLARATION ::=
231 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [is tagged];
233 -- PRIVATE_TYPE_DECLARATION ::=
234 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
235 -- is [abstract] [tagged] [limited] private;
237 -- PRIVATE_EXTENSION_DECLARATION ::=
238 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
239 -- [abstract] [limited | synchronized]
240 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
243 -- TYPE_DEFINITION ::=
244 -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
245 -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION
246 -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION
247 -- | DERIVED_TYPE_DEFINITION | INTERFACE_TYPE_DEFINITION
249 -- INTEGER_TYPE_DEFINITION ::=
250 -- SIGNED_INTEGER_TYPE_DEFINITION
251 -- MODULAR_TYPE_DEFINITION
253 -- INTERFACE_TYPE_DEFINITION ::=
254 -- [limited | task | protected | synchronized ] interface
255 -- [and INTERFACE_LIST]
257 -- Error recovery: can raise Error_Resync
259 -- Note: The processing for full type declaration, incomplete type
260 -- declaration, private type declaration and type definition is
261 -- included in this function. The processing for concurrent type
262 -- declarations is NOT here, but rather in chapter 9 (i.e. this
263 -- function handles only declarations starting with TYPE).
265 function P_Type_Declaration return Node_Id is
266 Abstract_Present : Boolean := False;
267 Abstract_Loc : Source_Ptr := No_Location;
269 Discr_List : List_Id;
270 Discr_Sloc : Source_Ptr;
272 Ident_Node : Node_Id;
273 Is_Derived_Iface : Boolean := False;
274 Type_Loc : Source_Ptr;
275 Type_Start_Col : Column_Number;
276 Unknown_Dis : Boolean;
278 Typedef_Node : Node_Id;
279 -- Normally holds type definition, except in the case of a private
280 -- extension declaration, in which case it holds the declaration itself
283 Type_Loc := Token_Ptr;
284 Type_Start_Col := Start_Column;
286 -- If we have TYPE, then proceed ahead and scan identifier
288 if Token = Tok_Type then
289 Type_Token_Location := Type_Loc;
291 Ident_Node := P_Defining_Identifier (C_Is);
293 -- Otherwise this is an error case, and we may already have converted
294 -- the current token to a defining identifier, so don't do it again!
299 if Token = Tok_Identifier
300 and then Nkind (Token_Node) = N_Defining_Identifier
302 Ident_Node := Token_Node;
303 Scan; -- past defining identifier
305 Ident_Node := P_Defining_Identifier (C_Is);
309 Discr_Sloc := Token_Ptr;
311 if P_Unknown_Discriminant_Part_Opt then
313 Discr_List := No_List;
315 Unknown_Dis := False;
316 Discr_List := P_Known_Discriminant_Part_Opt;
319 -- Incomplete type declaration. We complete the processing for this
320 -- case here and return the resulting incomplete type declaration node
322 if Token = Tok_Semicolon then
324 Decl_Node := New_Node (N_Incomplete_Type_Declaration, Type_Loc);
325 Set_Defining_Identifier (Decl_Node, Ident_Node);
326 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
327 Set_Discriminant_Specifications (Decl_Node, Discr_List);
334 -- Full type declaration or private type declaration, must have IS
336 if Token = Tok_Equal then
338 Scan; -- past = used in place of IS
340 elsif Token = Tok_Renames then
341 Error_Msg_SC ("RENAMES should be IS");
342 Scan; -- past RENAMES used in place of IS
348 -- First an error check, if we have two identifiers in a row, a likely
349 -- possibility is that the first of the identifiers is an incorrectly
352 if Token = Tok_Identifier then
354 SS : Saved_Scan_State;
358 Save_Scan_State (SS);
359 Scan; -- past initial identifier
360 I2 := (Token = Tok_Identifier);
361 Restore_Scan_State (SS);
365 (Bad_Spelling_Of (Tok_Abstract) or else
366 Bad_Spelling_Of (Tok_Access) or else
367 Bad_Spelling_Of (Tok_Aliased) or else
368 Bad_Spelling_Of (Tok_Constant))
375 -- Check for misuse of Ada 95 keyword abstract in Ada 83 mode
377 if Token_Name = Name_Abstract then
378 Check_95_Keyword (Tok_Abstract, Tok_Tagged);
379 Check_95_Keyword (Tok_Abstract, Tok_New);
382 -- Check cases of misuse of ABSTRACT
384 if Token = Tok_Abstract then
385 Abstract_Present := True;
386 Abstract_Loc := Token_Ptr;
387 Scan; -- past ABSTRACT
389 -- Ada 2005 (AI-419): AARM 3.4 (2/2)
391 if (Ada_Version < Ada_05 and then Token = Tok_Limited)
392 or else Token = Tok_Private
393 or else Token = Tok_Record
394 or else Token = Tok_Null
396 Error_Msg_AP ("TAGGED expected");
400 -- Check for misuse of Ada 95 keyword Tagged
402 if Token_Name = Name_Tagged then
403 Check_95_Keyword (Tok_Tagged, Tok_Private);
404 Check_95_Keyword (Tok_Tagged, Tok_Limited);
405 Check_95_Keyword (Tok_Tagged, Tok_Record);
408 -- Special check for misuse of Aliased
410 if Token = Tok_Aliased or else Token_Name = Name_Aliased then
411 Error_Msg_SC ("ALIASED not allowed in type definition");
412 Scan; -- past ALIASED
415 -- The following procesing deals with either a private type declaration
416 -- or a full type declaration. In the private type case, we build the
417 -- N_Private_Type_Declaration node, setting its Tagged_Present and
418 -- Limited_Present flags, on encountering the Private keyword, and
419 -- leave Typedef_Node set to Empty. For the full type declaration
420 -- case, Typedef_Node gets set to the type definition.
422 Typedef_Node := Empty;
424 -- Switch on token following the IS. The loop normally runs once. It
425 -- only runs more than once if an error is detected, to try again after
426 -- detecting and fixing up the error.
432 Tok_Not => -- Ada 2005 (AI-231)
433 Typedef_Node := P_Access_Type_Definition;
438 Typedef_Node := P_Array_Type_Definition;
443 Typedef_Node := P_Fixed_Point_Definition;
448 Typedef_Node := P_Floating_Point_Definition;
455 when Tok_Integer_Literal =>
457 Typedef_Node := P_Signed_Integer_Type_Definition;
462 Typedef_Node := P_Record_Definition;
466 when Tok_Left_Paren =>
467 Typedef_Node := P_Enumeration_Type_Definition;
470 Make_Identifier (Token_Ptr,
471 Chars => Chars (Ident_Node));
472 Set_Comes_From_Source (End_Labl, False);
474 Set_End_Label (Typedef_Node, End_Labl);
479 Typedef_Node := P_Modular_Type_Definition;
484 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
486 if Nkind (Typedef_Node) = N_Derived_Type_Definition
487 and then Present (Record_Extension_Part (Typedef_Node))
490 Make_Identifier (Token_Ptr,
491 Chars => Chars (Ident_Node));
492 Set_Comes_From_Source (End_Labl, False);
495 (Record_Extension_Part (Typedef_Node), End_Labl);
502 Typedef_Node := P_Signed_Integer_Type_Definition;
507 Typedef_Node := P_Record_Definition;
510 Make_Identifier (Token_Ptr,
511 Chars => Chars (Ident_Node));
512 Set_Comes_From_Source (End_Labl, False);
514 Set_End_Label (Typedef_Node, End_Labl);
521 -- Ada 2005 (AI-326): If the words IS TAGGED appear, the type
522 -- is a tagged incomplete type.
524 if Ada_Version >= Ada_05
525 and then Token = Tok_Semicolon
530 New_Node (N_Incomplete_Type_Declaration, Type_Loc);
531 Set_Defining_Identifier (Decl_Node, Ident_Node);
532 Set_Tagged_Present (Decl_Node);
533 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
534 Set_Discriminant_Specifications (Decl_Node, Discr_List);
539 if Token = Tok_Abstract then
540 Error_Msg_SC ("ABSTRACT must come before TAGGED");
541 Abstract_Present := True;
542 Abstract_Loc := Token_Ptr;
543 Scan; -- past ABSTRACT
546 if Token = Tok_Limited then
547 Scan; -- past LIMITED
549 -- TAGGED LIMITED PRIVATE case
551 if Token = Tok_Private then
553 New_Node (N_Private_Type_Declaration, Type_Loc);
554 Set_Tagged_Present (Decl_Node, True);
555 Set_Limited_Present (Decl_Node, True);
556 Scan; -- past PRIVATE
558 -- TAGGED LIMITED RECORD
561 Typedef_Node := P_Record_Definition;
562 Set_Tagged_Present (Typedef_Node, True);
563 Set_Limited_Present (Typedef_Node, True);
566 Make_Identifier (Token_Ptr,
567 Chars => Chars (Ident_Node));
568 Set_Comes_From_Source (End_Labl, False);
570 Set_End_Label (Typedef_Node, End_Labl);
576 if Token = Tok_Private then
578 New_Node (N_Private_Type_Declaration, Type_Loc);
579 Set_Tagged_Present (Decl_Node, True);
580 Scan; -- past PRIVATE
585 Typedef_Node := P_Record_Definition;
586 Set_Tagged_Present (Typedef_Node, True);
589 Make_Identifier (Token_Ptr,
590 Chars => Chars (Ident_Node));
591 Set_Comes_From_Source (End_Labl, False);
593 Set_End_Label (Typedef_Node, End_Labl);
601 Scan; -- past LIMITED
604 if Token = Tok_Tagged then
605 Error_Msg_SC ("TAGGED must come before LIMITED");
608 elsif Token = Tok_Abstract then
609 Error_Msg_SC ("ABSTRACT must come before LIMITED");
610 Scan; -- past ABSTRACT
617 -- LIMITED RECORD or LIMITED NULL RECORD
619 if Token = Tok_Record or else Token = Tok_Null then
620 if Ada_Version = Ada_83 then
622 ("(Ada 83) limited record declaration not allowed!");
625 Typedef_Node := P_Record_Definition;
626 Set_Limited_Present (Typedef_Node, True);
628 -- Ada 2005 (AI-251): LIMITED INTERFACE
630 -- If we are compiling in Ada 83 or Ada 95 mode, "interface"
631 -- is not a reserved word but we force its analysis to
632 -- generate the corresponding usage error.
634 elsif Token = Tok_Interface
635 or else (Token = Tok_Identifier
636 and then Chars (Token_Node) = Name_Interface)
639 P_Interface_Type_Definition (Abstract_Present);
640 Abstract_Present := True;
641 Set_Limited_Present (Typedef_Node);
643 if Nkind (Typedef_Node) = N_Derived_Type_Definition then
644 Is_Derived_Iface := True;
647 -- Ada 2005 (AI-419): LIMITED NEW
649 elsif Token = Tok_New then
650 if Ada_Version < Ada_05 then
652 ("LIMITED in derived type is an Ada 2005 extension");
654 ("\unit must be compiled with -gnat05 switch");
657 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
658 Set_Limited_Present (Typedef_Node);
660 if Nkind (Typedef_Node) = N_Derived_Type_Definition
661 and then Present (Record_Extension_Part (Typedef_Node))
664 Make_Identifier (Token_Ptr,
665 Chars => Chars (Ident_Node));
666 Set_Comes_From_Source (End_Labl, False);
669 (Record_Extension_Part (Typedef_Node), End_Labl);
672 -- LIMITED PRIVATE is the only remaining possibility here
675 Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
676 Set_Limited_Present (Decl_Node, True);
677 T_Private; -- past PRIVATE (or complain if not there!)
683 -- Here we have an identifier after the IS, which is certainly
684 -- wrong and which might be one of several different mistakes.
686 when Tok_Identifier =>
688 -- First case, if identifier is on same line, then probably we
689 -- have something like "type X is Integer .." and the best
690 -- diagnosis is a missing NEW. Note: the missing new message
691 -- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl.
693 if not Token_Is_At_Start_Of_Line then
694 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
697 -- If the identifier is at the start of the line, and is in the
698 -- same column as the type declaration itself then we consider
699 -- that we had a missing type definition on the previous line
701 elsif Start_Column <= Type_Start_Col then
702 Error_Msg_AP ("type definition expected");
703 Typedef_Node := Error;
705 -- If the identifier is at the start of the line, and is in
706 -- a column to the right of the type declaration line, then we
707 -- may have something like:
712 -- and the best diagnosis is a missing record keyword
715 Typedef_Node := P_Record_Definition;
721 -- Ada 2005 (AI-251): INTERFACE
723 when Tok_Interface =>
724 Typedef_Node := P_Interface_Type_Definition (Abstract_Present);
725 Abstract_Present := True;
730 Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
731 Scan; -- past PRIVATE
735 -- Ada 2005 (AI-345): Protected, synchronized or task interface
736 -- or Ada 2005 (AI-443): Synchronized private extension.
743 Saved_Token : constant Token_Type := Token;
746 Scan; -- past TASK, PROTECTED or SYNCHRONIZED
748 -- Synchronized private extension
750 if Token = Tok_New then
751 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
753 if Saved_Token = Tok_Synchronized then
754 Set_Synchronized_Present (Typedef_Node);
756 Error_Msg_SC ("invalid kind of private extension");
763 P_Interface_Type_Definition (Abstract_Present);
764 Abstract_Present := True;
768 Set_Task_Present (Typedef_Node);
770 when Tok_Protected =>
771 Set_Protected_Present (Typedef_Node);
773 when Tok_Synchronized =>
774 Set_Synchronized_Present (Typedef_Node);
777 pragma Assert (False);
786 -- Anything else is an error
789 if Bad_Spelling_Of (Tok_Access)
791 Bad_Spelling_Of (Tok_Array)
793 Bad_Spelling_Of (Tok_Delta)
795 Bad_Spelling_Of (Tok_Digits)
797 Bad_Spelling_Of (Tok_Limited)
799 Bad_Spelling_Of (Tok_Private)
801 Bad_Spelling_Of (Tok_Range)
803 Bad_Spelling_Of (Tok_Record)
805 Bad_Spelling_Of (Tok_Tagged)
810 Error_Msg_AP ("type definition expected");
817 -- For the private type declaration case, the private type declaration
818 -- node has been built, with the Tagged_Present and Limited_Present
819 -- flags set as needed, and Typedef_Node is left set to Empty.
821 if No (Typedef_Node) then
822 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
823 Set_Abstract_Present (Decl_Node, Abstract_Present);
825 -- For a private extension declaration, Typedef_Node contains the
826 -- N_Private_Extension_Declaration node, which we now complete. Note
827 -- that the private extension declaration, unlike a full type
828 -- declaration, does permit unknown discriminants.
830 elsif Nkind (Typedef_Node) = N_Private_Extension_Declaration then
831 Decl_Node := Typedef_Node;
832 Set_Sloc (Decl_Node, Type_Loc);
833 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
834 Set_Abstract_Present (Typedef_Node, Abstract_Present);
836 -- In the full type declaration case, Typedef_Node has the type
837 -- definition and here is where we build the full type declaration
838 -- node. This is also where we check for improper use of an unknown
839 -- discriminant part (not allowed for full type declaration).
842 if Nkind (Typedef_Node) = N_Record_Definition
843 or else (Nkind (Typedef_Node) = N_Derived_Type_Definition
844 and then Present (Record_Extension_Part (Typedef_Node)))
845 or else Is_Derived_Iface
847 Set_Abstract_Present (Typedef_Node, Abstract_Present);
849 elsif Abstract_Present then
850 Error_Msg ("ABSTRACT not allowed here, ignored", Abstract_Loc);
853 Decl_Node := New_Node (N_Full_Type_Declaration, Type_Loc);
854 Set_Type_Definition (Decl_Node, Typedef_Node);
858 ("Full type declaration cannot have unknown discriminants",
863 -- Remaining processing is common for all three cases
865 Set_Defining_Identifier (Decl_Node, Ident_Node);
866 Set_Discriminant_Specifications (Decl_Node, Discr_List);
868 end P_Type_Declaration;
870 ----------------------------------
871 -- 3.2.1 Full Type Declaration --
872 ----------------------------------
874 -- Parsed by P_Type_Declaration (3.2.1)
876 ----------------------------
877 -- 3.2.1 Type Definition --
878 ----------------------------
880 -- Parsed by P_Type_Declaration (3.2.1)
882 --------------------------------
883 -- 3.2.2 Subtype Declaration --
884 --------------------------------
886 -- SUBTYPE_DECLARATION ::=
887 -- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION;
889 -- The caller has checked that the initial token is SUBTYPE
891 -- Error recovery: can raise Error_Resync
893 function P_Subtype_Declaration return Node_Id is
895 Not_Null_Present : Boolean := False;
898 Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr);
899 Scan; -- past SUBTYPE
900 Set_Defining_Identifier (Decl_Node, P_Defining_Identifier (C_Is));
903 if Token = Tok_New then
904 Error_Msg_SC ("NEW ignored (only allowed in type declaration)");
908 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
909 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
911 Set_Subtype_Indication
912 (Decl_Node, P_Subtype_Indication (Not_Null_Present));
915 end P_Subtype_Declaration;
917 -------------------------------
918 -- 3.2.2 Subtype Indication --
919 -------------------------------
921 -- SUBTYPE_INDICATION ::=
922 -- [not null] SUBTYPE_MARK [CONSTRAINT]
924 -- Error recovery: can raise Error_Resync
926 function P_Null_Exclusion
927 (Allow_Anonymous_In_95 : Boolean := False) return Boolean
929 Not_Loc : constant Source_Ptr := Token_Ptr;
930 -- Source position of "not", if present
933 if Token /= Tok_Not then
939 if Token = Tok_Null then
942 -- Ada 2005 (AI-441, AI-447): null_exclusion is illegal in Ada 95,
943 -- except in the case of anonymous access types.
945 -- Allow_Anonymous_In_95 will be True if we're parsing a formal
946 -- parameter or discriminant, which are the only places where
947 -- anonymous access types occur in Ada 95. "Formal : not null
948 -- access ..." is legal in Ada 95, whereas "Formal : not null
949 -- Named_Access_Type" is not.
951 if Ada_Version >= Ada_05
952 or else (Ada_Version >= Ada_95
953 and then Allow_Anonymous_In_95
954 and then Token = Tok_Access)
960 ("`NOT NULL` access type is an Ada 2005 extension", Not_Loc);
962 ("\unit should be compiled with -gnat05 switch", Not_Loc);
966 Error_Msg_SP ("NULL expected");
969 if Token = Tok_New then
970 Error_Msg ("`NOT NULL` comes after NEW, not before", Not_Loc);
975 end P_Null_Exclusion;
977 function P_Subtype_Indication
978 (Not_Null_Present : Boolean := False) return Node_Id
983 if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
984 Type_Node := P_Subtype_Mark;
985 return P_Subtype_Indication (Type_Node, Not_Null_Present);
988 -- Check for error of using record definition and treat it nicely,
989 -- otherwise things are really messed up, so resynchronize.
991 if Token = Tok_Record then
992 Error_Msg_SC ("anonymous record definitions are not permitted");
993 Discard_Junk_Node (P_Record_Definition);
997 Error_Msg_AP ("subtype indication expected");
1001 end P_Subtype_Indication;
1003 -- The following function is identical except that it is called with
1004 -- the subtype mark already scanned out, and it scans out the constraint
1006 -- Error recovery: can raise Error_Resync
1008 function P_Subtype_Indication
1009 (Subtype_Mark : Node_Id;
1010 Not_Null_Present : Boolean := False) return Node_Id
1012 Indic_Node : Node_Id;
1013 Constr_Node : Node_Id;
1016 Constr_Node := P_Constraint_Opt;
1018 if No (Constr_Node) then
1019 return Subtype_Mark;
1021 if Not_Null_Present then
1022 Error_Msg_SP ("`NOT NULL` not allowed if constraint given");
1025 Indic_Node := New_Node (N_Subtype_Indication, Sloc (Subtype_Mark));
1026 Set_Subtype_Mark (Indic_Node, Check_Subtype_Mark (Subtype_Mark));
1027 Set_Constraint (Indic_Node, Constr_Node);
1030 end P_Subtype_Indication;
1032 -------------------------
1033 -- 3.2.2 Subtype Mark --
1034 -------------------------
1036 -- SUBTYPE_MARK ::= subtype_NAME;
1038 -- Note: The subtype mark which appears after an IN or NOT IN
1039 -- operator is parsed by P_Range_Or_Subtype_Mark (3.5)
1041 -- Error recovery: cannot raise Error_Resync
1043 function P_Subtype_Mark return Node_Id is
1045 return P_Subtype_Mark_Resync;
1047 when Error_Resync =>
1051 -- This routine differs from P_Subtype_Mark in that it insists that an
1052 -- identifier be present, and if it is not, it raises Error_Resync.
1054 -- Error recovery: can raise Error_Resync
1056 function P_Subtype_Mark_Resync return Node_Id is
1057 Type_Node : Node_Id;
1060 if Token = Tok_Access then
1061 Error_Msg_SC ("anonymous access type definition not allowed here");
1062 Scan; -- past ACCESS
1065 if Token = Tok_Array then
1066 Error_Msg_SC ("anonymous array definition not allowed here");
1067 Discard_Junk_Node (P_Array_Type_Definition);
1071 Type_Node := P_Qualified_Simple_Name_Resync;
1073 -- Check for a subtype mark attribute. The only valid possibilities
1074 -- are 'CLASS and 'BASE. Anything else is a definite error. We may
1075 -- as well catch it here.
1077 if Token = Tok_Apostrophe then
1078 return P_Subtype_Mark_Attribute (Type_Node);
1083 end P_Subtype_Mark_Resync;
1085 -- The following function is called to scan out a subtype mark attribute.
1086 -- The caller has already scanned out the subtype mark, which is passed in
1087 -- as the argument, and has checked that the current token is apostrophe.
1089 -- Only a special subclass of attributes, called type attributes
1090 -- (see Snames package) are allowed in this syntactic position.
1092 -- Note: if the apostrophe is followed by other than an identifier, then
1093 -- the input expression is returned unchanged, and the scan pointer is
1094 -- left pointing to the apostrophe.
1096 -- Error recovery: can raise Error_Resync
1098 function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id is
1099 Attr_Node : Node_Id := Empty;
1100 Scan_State : Saved_Scan_State;
1104 Prefix := Check_Subtype_Mark (Type_Node);
1106 if Prefix = Error then
1110 -- Loop through attributes appearing (more than one can appear as for
1111 -- for example in X'Base'Class). We are at an apostrophe on entry to
1112 -- this loop, and it runs once for each attribute parsed, with
1113 -- Prefix being the current possible prefix if it is an attribute.
1116 Save_Scan_State (Scan_State); -- at Apostrophe
1117 Scan; -- past apostrophe
1119 if Token /= Tok_Identifier then
1120 Restore_Scan_State (Scan_State); -- to apostrophe
1121 return Prefix; -- no attribute after all
1123 elsif not Is_Type_Attribute_Name (Token_Name) then
1125 ("attribute & may not be used in a subtype mark", Token_Node);
1130 Make_Attribute_Reference (Prev_Token_Ptr,
1132 Attribute_Name => Token_Name);
1133 Delete_Node (Token_Node);
1134 Scan; -- past type attribute identifier
1137 exit when Token /= Tok_Apostrophe;
1138 Prefix := Attr_Node;
1141 -- Fall through here after scanning type attribute
1144 end P_Subtype_Mark_Attribute;
1146 -----------------------
1147 -- 3.2.2 Constraint --
1148 -----------------------
1150 -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
1152 -- SCALAR_CONSTRAINT ::=
1153 -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
1155 -- COMPOSITE_CONSTRAINT ::=
1156 -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
1158 -- If no constraint is present, this function returns Empty
1160 -- Error recovery: can raise Error_Resync
1162 function P_Constraint_Opt return Node_Id is
1164 if Token = Tok_Range
1165 or else Bad_Spelling_Of (Tok_Range)
1167 return P_Range_Constraint;
1169 elsif Token = Tok_Digits
1170 or else Bad_Spelling_Of (Tok_Digits)
1172 return P_Digits_Constraint;
1174 elsif Token = Tok_Delta
1175 or else Bad_Spelling_Of (Tok_Delta)
1177 return P_Delta_Constraint;
1179 elsif Token = Tok_Left_Paren then
1180 return P_Index_Or_Discriminant_Constraint;
1182 elsif Token = Tok_In then
1184 return P_Constraint_Opt;
1189 end P_Constraint_Opt;
1191 ------------------------------
1192 -- 3.2.2 Scalar Constraint --
1193 ------------------------------
1195 -- Parsed by P_Constraint_Opt (3.2.2)
1197 ---------------------------------
1198 -- 3.2.2 Composite Constraint --
1199 ---------------------------------
1201 -- Parsed by P_Constraint_Opt (3.2.2)
1203 --------------------------------------------------------
1204 -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) --
1205 --------------------------------------------------------
1207 -- This routine scans out a declaration starting with an identifier:
1209 -- OBJECT_DECLARATION ::=
1210 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1211 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1212 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1213 -- ACCESS_DEFINITION [:= EXPRESSION];
1214 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1215 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1217 -- NUMBER_DECLARATION ::=
1218 -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
1220 -- OBJECT_RENAMING_DECLARATION ::=
1221 -- DEFINING_IDENTIFIER :
1222 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
1223 -- | DEFINING_IDENTIFIER :
1224 -- ACCESS_DEFINITION renames object_NAME;
1226 -- EXCEPTION_RENAMING_DECLARATION ::=
1227 -- DEFINING_IDENTIFIER : exception renames exception_NAME;
1229 -- EXCEPTION_DECLARATION ::=
1230 -- DEFINING_IDENTIFIER_LIST : exception;
1232 -- Note that the ALIASED indication in an object declaration is
1233 -- marked by a flag in the parent node.
1235 -- The caller has checked that the initial token is an identifier
1237 -- The value returned is a list of declarations, one for each identifier
1238 -- in the list (as described in Sinfo, we always split up multiple
1239 -- declarations into the equivalent sequence of single declarations
1240 -- using the More_Ids and Prev_Ids flags to preserve the source).
1242 -- If the identifier turns out to be a probable statement rather than
1243 -- an identifier, then the scan is left pointing to the identifier and
1244 -- No_List is returned.
1246 -- Error recovery: can raise Error_Resync
1248 procedure P_Identifier_Declarations
1254 Decl_Node : Node_Id;
1255 Type_Node : Node_Id;
1256 Ident_Sloc : Source_Ptr;
1257 Scan_State : Saved_Scan_State;
1258 List_OK : Boolean := True;
1260 Init_Expr : Node_Id;
1261 Init_Loc : Source_Ptr;
1262 Con_Loc : Source_Ptr;
1263 Not_Null_Present : Boolean := False;
1265 Idents : array (Int range 1 .. 4096) of Entity_Id;
1266 -- Used to save identifiers in the identifier list. The upper bound
1267 -- of 4096 is expected to be infinite in practice, and we do not even
1268 -- bother to check if this upper bound is exceeded.
1270 Num_Idents : Nat := 1;
1271 -- Number of identifiers stored in Idents
1274 -- This procedure is called in renames cases to make sure that we do
1275 -- not have more than one identifier. If we do have more than one
1276 -- then an error message is issued (and the declaration is split into
1277 -- multiple declarations)
1279 function Token_Is_Renames return Boolean;
1280 -- Checks if current token is RENAMES, and if so, scans past it and
1281 -- returns True, otherwise returns False. Includes checking for some
1282 -- common error cases.
1284 procedure No_List is
1286 if Num_Idents > 1 then
1287 Error_Msg ("identifier list not allowed for RENAMES",
1294 function Token_Is_Renames return Boolean is
1295 At_Colon : Saved_Scan_State;
1298 if Token = Tok_Colon then
1299 Save_Scan_State (At_Colon);
1301 Check_Misspelling_Of (Tok_Renames);
1303 if Token = Tok_Renames then
1304 Error_Msg_SP ("extra "":"" ignored");
1305 Scan; -- past RENAMES
1308 Restore_Scan_State (At_Colon);
1313 Check_Misspelling_Of (Tok_Renames);
1315 if Token = Tok_Renames then
1316 Scan; -- past RENAMES
1322 end Token_Is_Renames;
1324 -- Start of processing for P_Identifier_Declarations
1327 Ident_Sloc := Token_Ptr;
1328 Save_Scan_State (Scan_State); -- at first identifier
1329 Idents (1) := P_Defining_Identifier (C_Comma_Colon);
1331 -- If we have a colon after the identifier, then we can assume that
1332 -- this is in fact a valid identifier declaration and can steam ahead.
1334 if Token = Tok_Colon then
1337 -- If we have a comma, then scan out the list of identifiers
1339 elsif Token = Tok_Comma then
1341 while Comma_Present loop
1342 Num_Idents := Num_Idents + 1;
1343 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
1346 Save_Scan_State (Scan_State); -- at colon
1349 -- If we have identifier followed by := then we assume that what is
1350 -- really meant is an assignment statement. The assignment statement
1351 -- is scanned out and added to the list of declarations. An exception
1352 -- occurs if the := is followed by the keyword constant, in which case
1353 -- we assume it was meant to be a colon.
1355 elsif Token = Tok_Colon_Equal then
1358 if Token = Tok_Constant then
1359 Error_Msg_SP ("colon expected");
1362 Restore_Scan_State (Scan_State);
1363 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
1367 -- If we have an IS keyword, then assume the TYPE keyword was missing
1369 elsif Token = Tok_Is then
1370 Restore_Scan_State (Scan_State);
1371 Append_To (Decls, P_Type_Declaration);
1375 -- Otherwise we have an error situation
1378 Restore_Scan_State (Scan_State);
1380 -- First case is possible misuse of PROTECTED in Ada 83 mode. If
1381 -- so, fix the keyword and return to scan the protected declaration.
1383 if Token_Name = Name_Protected then
1384 Check_95_Keyword (Tok_Protected, Tok_Identifier);
1385 Check_95_Keyword (Tok_Protected, Tok_Type);
1386 Check_95_Keyword (Tok_Protected, Tok_Body);
1388 if Token = Tok_Protected then
1393 -- Check misspelling possibilities. If so, correct the misspelling
1394 -- and return to scan out the resulting declaration.
1396 elsif Bad_Spelling_Of (Tok_Function)
1397 or else Bad_Spelling_Of (Tok_Procedure)
1398 or else Bad_Spelling_Of (Tok_Package)
1399 or else Bad_Spelling_Of (Tok_Pragma)
1400 or else Bad_Spelling_Of (Tok_Protected)
1401 or else Bad_Spelling_Of (Tok_Generic)
1402 or else Bad_Spelling_Of (Tok_Subtype)
1403 or else Bad_Spelling_Of (Tok_Type)
1404 or else Bad_Spelling_Of (Tok_Task)
1405 or else Bad_Spelling_Of (Tok_Use)
1406 or else Bad_Spelling_Of (Tok_For)
1411 -- Otherwise we definitely have an ordinary identifier with a junk
1412 -- token after it. Just complain that we expect a declaration, and
1413 -- skip to a semicolon
1416 Set_Declaration_Expected;
1417 Resync_Past_Semicolon;
1423 -- Come here with an identifier list and colon scanned out. We now
1424 -- build the nodes for the declarative items. One node is built for
1425 -- each identifier in the list, with the type information being
1426 -- repeated by rescanning the appropriate section of source.
1428 -- First an error check, if we have two identifiers in a row, a likely
1429 -- possibility is that the first of the identifiers is an incorrectly
1432 if Token = Tok_Identifier then
1434 SS : Saved_Scan_State;
1438 Save_Scan_State (SS);
1439 Scan; -- past initial identifier
1440 I2 := (Token = Tok_Identifier);
1441 Restore_Scan_State (SS);
1445 (Bad_Spelling_Of (Tok_Access) or else
1446 Bad_Spelling_Of (Tok_Aliased) or else
1447 Bad_Spelling_Of (Tok_Constant))
1454 -- Loop through identifiers
1459 -- Check for some cases of misused Ada 95 keywords
1461 if Token_Name = Name_Aliased then
1462 Check_95_Keyword (Tok_Aliased, Tok_Array);
1463 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
1464 Check_95_Keyword (Tok_Aliased, Tok_Constant);
1469 if Token = Tok_Constant then
1470 Con_Loc := Token_Ptr;
1471 Scan; -- past CONSTANT
1473 -- Number declaration, initialization required
1475 Init_Expr := Init_Expr_Opt;
1477 if Present (Init_Expr) then
1478 if Not_Null_Present then
1480 ("`NOT NULL` not allowed in numeric expression");
1483 Decl_Node := New_Node (N_Number_Declaration, Ident_Sloc);
1484 Set_Expression (Decl_Node, Init_Expr);
1486 -- Constant object declaration
1489 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1490 Set_Constant_Present (Decl_Node, True);
1492 if Token_Name = Name_Aliased then
1493 Check_95_Keyword (Tok_Aliased, Tok_Array);
1494 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
1497 if Token = Tok_Aliased then
1498 Error_Msg_SC ("ALIASED should be before CONSTANT");
1499 Scan; -- past ALIASED
1500 Set_Aliased_Present (Decl_Node, True);
1503 if Token = Tok_Array then
1504 Set_Object_Definition
1505 (Decl_Node, P_Array_Type_Definition);
1508 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1509 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1511 if Token = Tok_Access then
1512 if Ada_Version < Ada_05 then
1514 ("generalized use of anonymous access types " &
1515 "is an Ada 2005 extension");
1517 ("\unit must be compiled with -gnat05 switch");
1520 Set_Object_Definition
1521 (Decl_Node, P_Access_Definition (Not_Null_Present));
1523 Set_Object_Definition
1524 (Decl_Node, P_Subtype_Indication (Not_Null_Present));
1528 if Token = Tok_Renames then
1530 ("CONSTANT not permitted in renaming declaration",
1532 Scan; -- Past renames
1533 Discard_Junk_Node (P_Name);
1539 elsif Token = Tok_Exception then
1540 Scan; -- past EXCEPTION
1542 if Token_Is_Renames then
1545 New_Node (N_Exception_Renaming_Declaration, Ident_Sloc);
1546 Set_Name (Decl_Node, P_Qualified_Simple_Name_Resync);
1549 Decl_Node := New_Node (N_Exception_Declaration, Prev_Token_Ptr);
1552 -- Aliased case (note that an object definition is required)
1554 elsif Token = Tok_Aliased then
1555 Scan; -- past ALIASED
1556 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1557 Set_Aliased_Present (Decl_Node, True);
1559 if Token = Tok_Constant then
1560 Scan; -- past CONSTANT
1561 Set_Constant_Present (Decl_Node, True);
1564 if Token = Tok_Array then
1565 Set_Object_Definition
1566 (Decl_Node, P_Array_Type_Definition);
1569 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1570 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1572 -- Access definition (AI-406) or subtype indication
1574 if Token = Tok_Access then
1575 if Ada_Version < Ada_05 then
1577 ("generalized use of anonymous access types " &
1578 "is an Ada 2005 extension");
1580 ("\unit must be compiled with -gnat05 switch");
1583 Set_Object_Definition
1584 (Decl_Node, P_Access_Definition (Not_Null_Present));
1586 Set_Object_Definition
1587 (Decl_Node, P_Subtype_Indication (Not_Null_Present));
1593 elsif Token = Tok_Array then
1594 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1595 Set_Object_Definition (Decl_Node, P_Array_Type_Definition);
1597 -- Ada 2005 (AI-254, AI-406)
1599 elsif Token = Tok_Not then
1601 -- OBJECT_DECLARATION ::=
1602 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1603 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1604 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1605 -- ACCESS_DEFINITION [:= EXPRESSION];
1607 -- OBJECT_RENAMING_DECLARATION ::=
1608 -- DEFINING_IDENTIFIER :
1609 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
1610 -- | DEFINING_IDENTIFIER :
1611 -- ACCESS_DEFINITION renames object_NAME;
1613 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/423)
1615 if Token = Tok_Access then
1616 if Ada_Version < Ada_05 then
1618 ("generalized use of anonymous access types " &
1619 "is an Ada 2005 extension");
1620 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1623 Acc_Node := P_Access_Definition (Not_Null_Present);
1625 if Token /= Tok_Renames then
1626 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1627 Set_Object_Definition (Decl_Node, Acc_Node);
1630 Scan; -- past renames
1633 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1634 Set_Access_Definition (Decl_Node, Acc_Node);
1635 Set_Name (Decl_Node, P_Name);
1639 Type_Node := P_Subtype_Mark;
1641 -- Object renaming declaration
1643 if Token_Is_Renames then
1644 if Ada_Version < Ada_05 then
1646 ("`NOT NULL` not allowed in object renaming");
1649 -- Ada 2005 (AI-423): Object renaming declaration with
1650 -- a null exclusion.
1655 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1656 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1657 Set_Subtype_Mark (Decl_Node, Type_Node);
1658 Set_Name (Decl_Node, P_Name);
1661 -- Object declaration
1664 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1665 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1666 Set_Object_Definition
1668 P_Subtype_Indication (Type_Node, Not_Null_Present));
1670 -- RENAMES at this point means that we had the combination
1671 -- of a constraint on the Type_Node and renames, which is
1674 if Token_Is_Renames then
1675 Error_Msg_N ("constraint not allowed in object renaming "
1677 Constraint (Object_Definition (Decl_Node)));
1683 -- Ada 2005 (AI-230): Access Definition case
1685 elsif Token = Tok_Access then
1686 if Ada_Version < Ada_05 then
1688 ("generalized use of anonymous access types " &
1689 "is an Ada 2005 extension");
1690 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1693 Acc_Node := P_Access_Definition (Null_Exclusion_Present => False);
1695 -- Object declaration with access definition, or renaming
1697 if Token /= Tok_Renames then
1698 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1699 Set_Object_Definition (Decl_Node, Acc_Node);
1702 Scan; -- past renames
1705 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1706 Set_Access_Definition (Decl_Node, Acc_Node);
1707 Set_Name (Decl_Node, P_Name);
1710 -- Subtype indication case
1713 Type_Node := P_Subtype_Mark;
1715 -- Object renaming declaration
1717 if Token_Is_Renames then
1720 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1721 Set_Subtype_Mark (Decl_Node, Type_Node);
1722 Set_Name (Decl_Node, P_Name);
1724 -- Object declaration
1727 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1728 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1729 Set_Object_Definition
1731 P_Subtype_Indication (Type_Node, Not_Null_Present));
1733 -- RENAMES at this point means that we had the combination of
1734 -- a constraint on the Type_Node and renames, which is illegal
1736 if Token_Is_Renames then
1738 ("constraint not allowed in object renaming declaration",
1739 Constraint (Object_Definition (Decl_Node)));
1745 -- Scan out initialization, allowed only for object declaration
1747 Init_Loc := Token_Ptr;
1748 Init_Expr := Init_Expr_Opt;
1750 if Present (Init_Expr) then
1751 if Nkind (Decl_Node) = N_Object_Declaration then
1752 Set_Expression (Decl_Node, Init_Expr);
1753 Set_Has_Init_Expression (Decl_Node);
1755 Error_Msg ("initialization not allowed here", Init_Loc);
1760 Set_Defining_Identifier (Decl_Node, Idents (Ident));
1763 if Ident < Num_Idents then
1764 Set_More_Ids (Decl_Node, True);
1768 Set_Prev_Ids (Decl_Node, True);
1772 Append (Decl_Node, Decls);
1773 exit Ident_Loop when Ident = Num_Idents;
1774 Restore_Scan_State (Scan_State);
1777 end loop Ident_Loop;
1780 end P_Identifier_Declarations;
1782 -------------------------------
1783 -- 3.3.1 Object Declaration --
1784 -------------------------------
1786 -- OBJECT DECLARATION ::=
1787 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1788 -- SUBTYPE_INDICATION [:= EXPRESSION];
1789 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1790 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1791 -- | SINGLE_TASK_DECLARATION
1792 -- | SINGLE_PROTECTED_DECLARATION
1794 -- Cases starting with TASK are parsed by P_Task (9.1)
1795 -- Cases starting with PROTECTED are parsed by P_Protected (9.4)
1796 -- All other cases are parsed by P_Identifier_Declarations (3.3)
1798 -------------------------------------
1799 -- 3.3.1 Defining Identifier List --
1800 -------------------------------------
1802 -- DEFINING_IDENTIFIER_LIST ::=
1803 -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
1805 -- Always parsed by the construct in which it appears. See special
1806 -- section on "Handling of Defining Identifier Lists" in this unit.
1808 -------------------------------
1809 -- 3.3.2 Number Declaration --
1810 -------------------------------
1812 -- Parsed by P_Identifier_Declarations (3.3)
1814 -------------------------------------------------------------------------
1815 -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) --
1816 -------------------------------------------------------------------------
1818 -- DERIVED_TYPE_DEFINITION ::=
1819 -- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
1820 -- [[and INTERFACE_LIST] RECORD_EXTENSION_PART]
1822 -- PRIVATE_EXTENSION_DECLARATION ::=
1823 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
1824 -- [abstract] [limited | synchronized]
1825 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
1828 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
1830 -- The caller has already scanned out the part up to the NEW, and Token
1831 -- either contains Tok_New (or ought to, if it doesn't this procedure
1832 -- will post an appropriate "NEW expected" message).
1834 -- Note: the caller is responsible for filling in the Sloc field of
1835 -- the returned node in the private extension declaration case as
1836 -- well as the stuff relating to the discriminant part.
1838 -- Error recovery: can raise Error_Resync;
1840 function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id is
1841 Typedef_Node : Node_Id;
1842 Typedecl_Node : Node_Id;
1843 Not_Null_Present : Boolean := False;
1846 Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
1848 if Ada_Version < Ada_05
1849 and then Token = Tok_Identifier
1850 and then Token_Name = Name_Interface
1853 ("abstract interface is an Ada 2005 extension");
1854 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1859 if Token = Tok_Abstract then
1860 Error_Msg_SC ("ABSTRACT must come before NEW, not after");
1864 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1865 Set_Null_Exclusion_Present (Typedef_Node, Not_Null_Present);
1866 Set_Subtype_Indication (Typedef_Node,
1867 P_Subtype_Indication (Not_Null_Present));
1869 -- Ada 2005 (AI-251): Deal with interfaces
1871 if Token = Tok_And then
1874 if Ada_Version < Ada_05 then
1876 ("abstract interface is an Ada 2005 extension");
1877 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1880 Set_Interface_List (Typedef_Node, New_List);
1883 Append (P_Qualified_Simple_Name, Interface_List (Typedef_Node));
1884 exit when Token /= Tok_And;
1888 if Token /= Tok_With then
1889 Error_Msg_SC ("WITH expected");
1894 -- Deal with record extension, note that we assume that a WITH is
1895 -- missing in the case of "type X is new Y record ..." or in the
1896 -- case of "type X is new Y null record".
1899 or else Token = Tok_Record
1900 or else Token = Tok_Null
1902 T_With; -- past WITH or give error message
1904 if Token = Tok_Limited then
1906 ("LIMITED keyword not allowed in private extension");
1907 Scan; -- ignore LIMITED
1910 -- Private extension declaration
1912 if Token = Tok_Private then
1913 Scan; -- past PRIVATE
1915 -- Throw away the type definition node and build the type
1916 -- declaration node. Note the caller must set the Sloc,
1917 -- Discriminant_Specifications, Unknown_Discriminants_Present,
1918 -- and Defined_Identifier fields in the returned node.
1921 Make_Private_Extension_Declaration (No_Location,
1922 Defining_Identifier => Empty,
1923 Subtype_Indication => Subtype_Indication (Typedef_Node),
1924 Abstract_Present => Abstract_Present (Typedef_Node),
1925 Interface_List => Interface_List (Typedef_Node));
1927 Delete_Node (Typedef_Node);
1928 return Typedecl_Node;
1930 -- Derived type definition with record extension part
1933 Set_Record_Extension_Part (Typedef_Node, P_Record_Definition);
1934 return Typedef_Node;
1937 -- Derived type definition with no record extension part
1940 return Typedef_Node;
1942 end P_Derived_Type_Def_Or_Private_Ext_Decl;
1944 ---------------------------
1945 -- 3.5 Range Constraint --
1946 ---------------------------
1948 -- RANGE_CONSTRAINT ::= range RANGE
1950 -- The caller has checked that the initial token is RANGE
1952 -- Error recovery: cannot raise Error_Resync
1954 function P_Range_Constraint return Node_Id is
1955 Range_Node : Node_Id;
1958 Range_Node := New_Node (N_Range_Constraint, Token_Ptr);
1960 Set_Range_Expression (Range_Node, P_Range);
1962 end P_Range_Constraint;
1969 -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
1971 -- Note: the range that appears in a membership test is parsed by
1972 -- P_Range_Or_Subtype_Mark (3.5).
1974 -- Error recovery: cannot raise Error_Resync
1976 function P_Range return Node_Id is
1977 Expr_Node : Node_Id;
1978 Range_Node : Node_Id;
1981 Expr_Node := P_Simple_Expression_Or_Range_Attribute;
1983 if Expr_Form = EF_Range_Attr then
1986 elsif Token = Tok_Dot_Dot then
1987 Range_Node := New_Node (N_Range, Token_Ptr);
1988 Set_Low_Bound (Range_Node, Expr_Node);
1990 Expr_Node := P_Expression;
1991 Check_Simple_Expression (Expr_Node);
1992 Set_High_Bound (Range_Node, Expr_Node);
1995 -- Anything else is an error
1998 T_Dot_Dot; -- force missing .. message
2003 ----------------------------------
2004 -- 3.5 P_Range_Or_Subtype_Mark --
2005 ----------------------------------
2008 -- RANGE_ATTRIBUTE_REFERENCE
2009 -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
2011 -- This routine scans out the range or subtype mark that forms the right
2012 -- operand of a membership test (it is not used in any other contexts, and
2013 -- error messages are specialized with this knowledge in mind).
2015 -- Note: as documented in the Sinfo interface, although the syntax only
2016 -- allows a subtype mark, we in fact allow any simple expression to be
2017 -- returned from this routine. The semantics is responsible for issuing
2018 -- an appropriate message complaining if the argument is not a name.
2019 -- This simplifies the coding and error recovery processing in the
2020 -- parser, and in any case it is preferable not to consider this a
2021 -- syntax error and to continue with the semantic analysis.
2023 -- Error recovery: cannot raise Error_Resync
2025 function P_Range_Or_Subtype_Mark return Node_Id is
2026 Expr_Node : Node_Id;
2027 Range_Node : Node_Id;
2028 Save_Loc : Source_Ptr;
2030 -- Start of processing for P_Range_Or_Subtype_Mark
2033 -- Save location of possible junk parentheses
2035 Save_Loc := Token_Ptr;
2037 -- Scan out either a simple expression or a range (this accepts more
2038 -- than is legal here, but as explained above, we like to allow more
2039 -- with a proper diagnostic.
2041 Expr_Node := P_Simple_Expression_Or_Range_Attribute;
2045 if Expr_Form = EF_Range_Attr then
2048 -- Simple_Expression .. Simple_Expression
2050 elsif Token = Tok_Dot_Dot then
2051 Check_Simple_Expression (Expr_Node);
2052 Range_Node := New_Node (N_Range, Token_Ptr);
2053 Set_Low_Bound (Range_Node, Expr_Node);
2055 Set_High_Bound (Range_Node, P_Simple_Expression);
2058 -- Case of subtype mark (optionally qualified simple name or an
2059 -- attribute whose prefix is an optionally qualifed simple name)
2061 elsif Expr_Form = EF_Simple_Name
2062 or else Nkind (Expr_Node) = N_Attribute_Reference
2064 -- Check for error of range constraint after a subtype mark
2066 if Token = Tok_Range then
2067 Error_Msg_SC ("range constraint not allowed in membership test");
2071 -- Check for error of DIGITS or DELTA after a subtype mark
2073 elsif Token = Tok_Digits or else Token = Tok_Delta then
2075 ("accuracy definition not allowed in membership test");
2076 Scan; -- past DIGITS or DELTA
2079 -- Attribute reference, may or may not be OK, but in any case we
2082 elsif Token = Tok_Apostrophe then
2083 return P_Subtype_Mark_Attribute (Expr_Node);
2085 -- OK case of simple name, just return it
2091 -- Here we have some kind of error situation. Check for junk parens
2092 -- then return what we have, caller will deal with other errors.
2095 if Nkind (Expr_Node) in N_Subexpr
2096 and then Paren_Count (Expr_Node) /= 0
2098 Error_Msg ("|parentheses not allowed for subtype mark", Save_Loc);
2099 Set_Paren_Count (Expr_Node, 0);
2104 end P_Range_Or_Subtype_Mark;
2106 ----------------------------------------
2107 -- 3.5.1 Enumeration Type Definition --
2108 ----------------------------------------
2110 -- ENUMERATION_TYPE_DEFINITION ::=
2111 -- (ENUMERATION_LITERAL_SPECIFICATION
2112 -- {, ENUMERATION_LITERAL_SPECIFICATION})
2114 -- The caller has already scanned out the TYPE keyword
2116 -- Error recovery: can raise Error_Resync;
2118 function P_Enumeration_Type_Definition return Node_Id is
2119 Typedef_Node : Node_Id;
2122 Typedef_Node := New_Node (N_Enumeration_Type_Definition, Token_Ptr);
2123 Set_Literals (Typedef_Node, New_List);
2128 Append (P_Enumeration_Literal_Specification, Literals (Typedef_Node));
2129 exit when not Comma_Present;
2133 return Typedef_Node;
2134 end P_Enumeration_Type_Definition;
2136 ----------------------------------------------
2137 -- 3.5.1 Enumeration Literal Specification --
2138 ----------------------------------------------
2140 -- ENUMERATION_LITERAL_SPECIFICATION ::=
2141 -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
2143 -- Error recovery: can raise Error_Resync
2145 function P_Enumeration_Literal_Specification return Node_Id is
2147 if Token = Tok_Char_Literal then
2148 return P_Defining_Character_Literal;
2150 return P_Defining_Identifier (C_Comma_Right_Paren);
2152 end P_Enumeration_Literal_Specification;
2154 ---------------------------------------
2155 -- 3.5.1 Defining_Character_Literal --
2156 ---------------------------------------
2158 -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
2160 -- Error recovery: cannot raise Error_Resync
2162 -- The caller has checked that the current token is a character literal
2164 function P_Defining_Character_Literal return Node_Id is
2165 Literal_Node : Node_Id;
2168 Literal_Node := Token_Node;
2169 Change_Character_Literal_To_Defining_Character_Literal (Literal_Node);
2170 Scan; -- past character literal
2171 return Literal_Node;
2172 end P_Defining_Character_Literal;
2174 ------------------------------------
2175 -- 3.5.4 Integer Type Definition --
2176 ------------------------------------
2178 -- Parsed by P_Type_Declaration (3.2.1)
2180 -------------------------------------------
2181 -- 3.5.4 Signed Integer Type Definition --
2182 -------------------------------------------
2184 -- SIGNED_INTEGER_TYPE_DEFINITION ::=
2185 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2187 -- Normally the initial token on entry is RANGE, but in some
2188 -- error conditions, the range token was missing and control is
2189 -- passed with Token pointing to first token of the first expression.
2191 -- Error recovery: cannot raise Error_Resync
2193 function P_Signed_Integer_Type_Definition return Node_Id is
2194 Typedef_Node : Node_Id;
2195 Expr_Node : Node_Id;
2198 Typedef_Node := New_Node (N_Signed_Integer_Type_Definition, Token_Ptr);
2200 if Token = Tok_Range then
2204 Expr_Node := P_Expression;
2205 Check_Simple_Expression (Expr_Node);
2206 Set_Low_Bound (Typedef_Node, Expr_Node);
2208 Expr_Node := P_Expression;
2209 Check_Simple_Expression (Expr_Node);
2210 Set_High_Bound (Typedef_Node, Expr_Node);
2211 return Typedef_Node;
2212 end P_Signed_Integer_Type_Definition;
2214 ------------------------------------
2215 -- 3.5.4 Modular Type Definition --
2216 ------------------------------------
2218 -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
2220 -- The caller has checked that the initial token is MOD
2222 -- Error recovery: cannot raise Error_Resync
2224 function P_Modular_Type_Definition return Node_Id is
2225 Typedef_Node : Node_Id;
2228 if Ada_Version = Ada_83 then
2229 Error_Msg_SC ("(Ada 83): modular types not allowed");
2232 Typedef_Node := New_Node (N_Modular_Type_Definition, Token_Ptr);
2234 Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
2236 -- Handle mod L..R cleanly
2238 if Token = Tok_Dot_Dot then
2239 Error_Msg_SC ("range not allowed for modular type");
2241 Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
2244 return Typedef_Node;
2245 end P_Modular_Type_Definition;
2247 ---------------------------------
2248 -- 3.5.6 Real Type Definition --
2249 ---------------------------------
2251 -- Parsed by P_Type_Declaration (3.2.1)
2253 --------------------------------------
2254 -- 3.5.7 Floating Point Definition --
2255 --------------------------------------
2257 -- FLOATING_POINT_DEFINITION ::=
2258 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2260 -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
2262 -- The caller has checked that the initial token is DIGITS
2264 -- Error recovery: cannot raise Error_Resync
2266 function P_Floating_Point_Definition return Node_Id is
2267 Digits_Loc : constant Source_Ptr := Token_Ptr;
2269 Expr_Node : Node_Id;
2272 Scan; -- past DIGITS
2273 Expr_Node := P_Expression_No_Right_Paren;
2274 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2276 -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
2278 if Token = Tok_Delta then
2279 Error_Msg_SC ("DELTA must come before DIGITS");
2280 Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Digits_Loc);
2282 Set_Delta_Expression (Def_Node, P_Expression_No_Right_Paren);
2284 -- OK floating-point definition
2287 Def_Node := New_Node (N_Floating_Point_Definition, Digits_Loc);
2290 Set_Digits_Expression (Def_Node, Expr_Node);
2291 Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt);
2293 end P_Floating_Point_Definition;
2295 -------------------------------------
2296 -- 3.5.7 Real Range Specification --
2297 -------------------------------------
2299 -- REAL_RANGE_SPECIFICATION ::=
2300 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2302 -- Error recovery: cannot raise Error_Resync
2304 function P_Real_Range_Specification_Opt return Node_Id is
2305 Specification_Node : Node_Id;
2306 Expr_Node : Node_Id;
2309 if Token = Tok_Range then
2310 Specification_Node :=
2311 New_Node (N_Real_Range_Specification, Token_Ptr);
2313 Expr_Node := P_Expression_No_Right_Paren;
2314 Check_Simple_Expression (Expr_Node);
2315 Set_Low_Bound (Specification_Node, Expr_Node);
2317 Expr_Node := P_Expression_No_Right_Paren;
2318 Check_Simple_Expression (Expr_Node);
2319 Set_High_Bound (Specification_Node, Expr_Node);
2320 return Specification_Node;
2324 end P_Real_Range_Specification_Opt;
2326 -----------------------------------
2327 -- 3.5.9 Fixed Point Definition --
2328 -----------------------------------
2330 -- FIXED_POINT_DEFINITION ::=
2331 -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
2333 -- ORDINARY_FIXED_POINT_DEFINITION ::=
2334 -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION
2336 -- DECIMAL_FIXED_POINT_DEFINITION ::=
2337 -- delta static_EXPRESSION
2338 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2340 -- The caller has checked that the initial token is DELTA
2342 -- Error recovery: cannot raise Error_Resync
2344 function P_Fixed_Point_Definition return Node_Id is
2345 Delta_Node : Node_Id;
2346 Delta_Loc : Source_Ptr;
2348 Expr_Node : Node_Id;
2351 Delta_Loc := Token_Ptr;
2353 Delta_Node := P_Expression_No_Right_Paren;
2354 Check_Simple_Expression_In_Ada_83 (Delta_Node);
2356 if Token = Tok_Digits then
2357 if Ada_Version = Ada_83 then
2358 Error_Msg_SC ("(Ada 83) decimal fixed type not allowed!");
2361 Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Delta_Loc);
2362 Scan; -- past DIGITS
2363 Expr_Node := P_Expression_No_Right_Paren;
2364 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2365 Set_Digits_Expression (Def_Node, Expr_Node);
2368 Def_Node := New_Node (N_Ordinary_Fixed_Point_Definition, Delta_Loc);
2370 -- Range is required in ordinary fixed point case
2372 if Token /= Tok_Range then
2373 Error_Msg_AP ("range must be given for fixed-point type");
2378 Set_Delta_Expression (Def_Node, Delta_Node);
2379 Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt);
2381 end P_Fixed_Point_Definition;
2383 --------------------------------------------
2384 -- 3.5.9 Ordinary Fixed Point Definition --
2385 --------------------------------------------
2387 -- Parsed by P_Fixed_Point_Definition (3.5.9)
2389 -------------------------------------------
2390 -- 3.5.9 Decimal Fixed Point Definition --
2391 -------------------------------------------
2393 -- Parsed by P_Decimal_Point_Definition (3.5.9)
2395 ------------------------------
2396 -- 3.5.9 Digits Constraint --
2397 ------------------------------
2399 -- DIGITS_CONSTRAINT ::=
2400 -- digits static_EXPRESSION [RANGE_CONSTRAINT]
2402 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2404 -- The caller has checked that the initial token is DIGITS
2406 function P_Digits_Constraint return Node_Id is
2407 Constraint_Node : Node_Id;
2408 Expr_Node : Node_Id;
2411 Constraint_Node := New_Node (N_Digits_Constraint, Token_Ptr);
2412 Scan; -- past DIGITS
2413 Expr_Node := P_Expression_No_Right_Paren;
2414 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2415 Set_Digits_Expression (Constraint_Node, Expr_Node);
2417 if Token = Tok_Range then
2418 Set_Range_Constraint (Constraint_Node, P_Range_Constraint);
2421 return Constraint_Node;
2422 end P_Digits_Constraint;
2424 -----------------------------
2425 -- 3.5.9 Delta Constraint --
2426 -----------------------------
2428 -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
2430 -- Note: this is an obsolescent feature in Ada 95 (I.3)
2432 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2434 -- The caller has checked that the initial token is DELTA
2436 -- Error recovery: cannot raise Error_Resync
2438 function P_Delta_Constraint return Node_Id is
2439 Constraint_Node : Node_Id;
2440 Expr_Node : Node_Id;
2443 Constraint_Node := New_Node (N_Delta_Constraint, Token_Ptr);
2445 Expr_Node := P_Expression_No_Right_Paren;
2446 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2447 Set_Delta_Expression (Constraint_Node, Expr_Node);
2449 if Token = Tok_Range then
2450 Set_Range_Constraint (Constraint_Node, P_Range_Constraint);
2453 return Constraint_Node;
2454 end P_Delta_Constraint;
2456 --------------------------------
2457 -- 3.6 Array Type Definition --
2458 --------------------------------
2460 -- ARRAY_TYPE_DEFINITION ::=
2461 -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
2463 -- UNCONSTRAINED_ARRAY_DEFINITION ::=
2464 -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
2465 -- COMPONENT_DEFINITION
2467 -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
2469 -- CONSTRAINED_ARRAY_DEFINITION ::=
2470 -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
2471 -- COMPONENT_DEFINITION
2473 -- DISCRETE_SUBTYPE_DEFINITION ::=
2474 -- DISCRETE_SUBTYPE_INDICATION | RANGE
2476 -- COMPONENT_DEFINITION ::=
2477 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
2479 -- The caller has checked that the initial token is ARRAY
2481 -- Error recovery: can raise Error_Resync
2483 function P_Array_Type_Definition return Node_Id is
2484 Array_Loc : Source_Ptr;
2485 CompDef_Node : Node_Id;
2487 Not_Null_Present : Boolean := False;
2488 Subs_List : List_Id;
2489 Scan_State : Saved_Scan_State;
2490 Aliased_Present : Boolean := False;
2493 Array_Loc := Token_Ptr;
2495 Subs_List := New_List;
2498 -- It's quite tricky to disentangle these two possibilities, so we do
2499 -- a prescan to determine which case we have and then reset the scan.
2500 -- The prescan skips past possible subtype mark tokens.
2502 Save_Scan_State (Scan_State); -- just after paren
2504 while Token in Token_Class_Desig or else
2505 Token = Tok_Dot or else
2506 Token = Tok_Apostrophe -- because of 'BASE, 'CLASS
2511 -- If we end up on RANGE <> then we have the unconstrained case. We
2512 -- will also allow the RANGE to be omitted, just to improve error
2513 -- handling for a case like array (integer <>) of integer;
2515 Scan; -- past possible RANGE or <>
2517 if (Prev_Token = Tok_Range and then Token = Tok_Box) or else
2518 Prev_Token = Tok_Box
2520 Def_Node := New_Node (N_Unconstrained_Array_Definition, Array_Loc);
2521 Restore_Scan_State (Scan_State); -- to first subtype mark
2524 Append (P_Subtype_Mark_Resync, Subs_List);
2527 exit when Token = Tok_Right_Paren or else Token = Tok_Of;
2531 Set_Subtype_Marks (Def_Node, Subs_List);
2534 Def_Node := New_Node (N_Constrained_Array_Definition, Array_Loc);
2535 Restore_Scan_State (Scan_State); -- to first discrete range
2538 Append (P_Discrete_Subtype_Definition, Subs_List);
2539 exit when not Comma_Present;
2542 Set_Discrete_Subtype_Definitions (Def_Node, Subs_List);
2548 CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
2550 if Token_Name = Name_Aliased then
2551 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
2554 if Token = Tok_Aliased then
2555 Aliased_Present := True;
2556 Scan; -- past ALIASED
2559 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254)
2561 -- Ada 2005 (AI-230): Access Definition case
2563 if Token = Tok_Access then
2564 if Ada_Version < Ada_05 then
2566 ("generalized use of anonymous access types " &
2567 "is an Ada 2005 extension");
2568 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
2571 if Aliased_Present then
2572 Error_Msg_SP ("ALIASED not allowed here");
2575 Set_Subtype_Indication (CompDef_Node, Empty);
2576 Set_Aliased_Present (CompDef_Node, False);
2577 Set_Access_Definition (CompDef_Node,
2578 P_Access_Definition (Not_Null_Present));
2581 Set_Access_Definition (CompDef_Node, Empty);
2582 Set_Aliased_Present (CompDef_Node, Aliased_Present);
2583 Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
2584 Set_Subtype_Indication (CompDef_Node,
2585 P_Subtype_Indication (Not_Null_Present));
2588 Set_Component_Definition (Def_Node, CompDef_Node);
2591 end P_Array_Type_Definition;
2593 -----------------------------------------
2594 -- 3.6 Unconstrained Array Definition --
2595 -----------------------------------------
2597 -- Parsed by P_Array_Type_Definition (3.6)
2599 ---------------------------------------
2600 -- 3.6 Constrained Array Definition --
2601 ---------------------------------------
2603 -- Parsed by P_Array_Type_Definition (3.6)
2605 --------------------------------------
2606 -- 3.6 Discrete Subtype Definition --
2607 --------------------------------------
2609 -- DISCRETE_SUBTYPE_DEFINITION ::=
2610 -- discrete_SUBTYPE_INDICATION | RANGE
2612 -- Note: the discrete subtype definition appearing in a constrained
2613 -- array definition is parsed by P_Array_Type_Definition (3.6)
2615 -- Error recovery: cannot raise Error_Resync
2617 function P_Discrete_Subtype_Definition return Node_Id is
2619 -- The syntax of a discrete subtype definition is identical to that
2620 -- of a discrete range, so we simply share the same parsing code.
2622 return P_Discrete_Range;
2623 end P_Discrete_Subtype_Definition;
2625 -------------------------------
2626 -- 3.6 Component Definition --
2627 -------------------------------
2629 -- For the array case, parsed by P_Array_Type_Definition (3.6)
2630 -- For the record case, parsed by P_Component_Declaration (3.8)
2632 -----------------------------
2633 -- 3.6.1 Index Constraint --
2634 -----------------------------
2636 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2638 ---------------------------
2639 -- 3.6.1 Discrete Range --
2640 ---------------------------
2642 -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
2644 -- The possible forms for a discrete range are:
2646 -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2)
2647 -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2)
2648 -- Range_Attribute (RANGE, 3.5)
2649 -- Simple_Expression .. Simple_Expression (RANGE, 3.5)
2651 -- Error recovery: cannot raise Error_Resync
2653 function P_Discrete_Range return Node_Id is
2654 Expr_Node : Node_Id;
2655 Range_Node : Node_Id;
2658 Expr_Node := P_Simple_Expression_Or_Range_Attribute;
2660 if Expr_Form = EF_Range_Attr then
2663 elsif Token = Tok_Range then
2664 if Expr_Form /= EF_Simple_Name then
2665 Error_Msg_SC ("range must be preceded by subtype mark");
2668 return P_Subtype_Indication (Expr_Node);
2670 -- Check Expression .. Expression case
2672 elsif Token = Tok_Dot_Dot then
2673 Range_Node := New_Node (N_Range, Token_Ptr);
2674 Set_Low_Bound (Range_Node, Expr_Node);
2676 Expr_Node := P_Expression;
2677 Check_Simple_Expression (Expr_Node);
2678 Set_High_Bound (Range_Node, Expr_Node);
2681 -- Otherwise we must have a subtype mark
2683 elsif Expr_Form = EF_Simple_Name then
2686 -- If incorrect, complain that we expect ..
2692 end P_Discrete_Range;
2694 ----------------------------
2695 -- 3.7 Discriminant Part --
2696 ----------------------------
2698 -- DISCRIMINANT_PART ::=
2699 -- UNKNOWN_DISCRIMINANT_PART
2700 -- | KNOWN_DISCRIMINANT_PART
2702 -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
2703 -- or P_Unknown_Discriminant_Part (3.7), since we know which we want.
2705 ------------------------------------
2706 -- 3.7 Unknown Discriminant Part --
2707 ------------------------------------
2709 -- UNKNOWN_DISCRIMINANT_PART ::= (<>)
2711 -- If no unknown discriminant part is present, then False is returned,
2712 -- otherwise the unknown discriminant is scanned out and True is returned.
2714 -- Error recovery: cannot raise Error_Resync
2716 function P_Unknown_Discriminant_Part_Opt return Boolean is
2717 Scan_State : Saved_Scan_State;
2720 if Token /= Tok_Left_Paren then
2724 Save_Scan_State (Scan_State);
2725 Scan; -- past the left paren
2727 if Token = Tok_Box then
2728 if Ada_Version = Ada_83 then
2729 Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!");
2732 Scan; -- past the box
2733 T_Right_Paren; -- must be followed by right paren
2737 Restore_Scan_State (Scan_State);
2741 end P_Unknown_Discriminant_Part_Opt;
2743 ----------------------------------
2744 -- 3.7 Known Discriminant Part --
2745 ----------------------------------
2747 -- KNOWN_DISCRIMINANT_PART ::=
2748 -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
2750 -- DISCRIMINANT_SPECIFICATION ::=
2751 -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
2752 -- [:= DEFAULT_EXPRESSION]
2753 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
2754 -- [:= DEFAULT_EXPRESSION]
2756 -- If no known discriminant part is present, then No_List is returned
2758 -- Error recovery: cannot raise Error_Resync
2760 function P_Known_Discriminant_Part_Opt return List_Id is
2761 Specification_Node : Node_Id;
2762 Specification_List : List_Id;
2763 Ident_Sloc : Source_Ptr;
2764 Scan_State : Saved_Scan_State;
2766 Not_Null_Present : Boolean;
2769 Idents : array (Int range 1 .. 4096) of Entity_Id;
2770 -- This array holds the list of defining identifiers. The upper bound
2771 -- of 4096 is intended to be essentially infinite, and we do not even
2772 -- bother to check for it being exceeded.
2775 if Token = Tok_Left_Paren then
2776 Specification_List := New_List;
2778 P_Pragmas_Misplaced;
2780 Specification_Loop : loop
2782 Ident_Sloc := Token_Ptr;
2783 Idents (1) := P_Defining_Identifier (C_Comma_Colon);
2786 while Comma_Present loop
2787 Num_Idents := Num_Idents + 1;
2788 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
2791 -- If there are multiple identifiers, we repeatedly scan the
2792 -- type and initialization expression information by resetting
2793 -- the scan pointer (so that we get completely separate trees
2794 -- for each occurrence).
2796 if Num_Idents > 1 then
2797 Save_Scan_State (Scan_State);
2802 -- Loop through defining identifiers in list
2806 Specification_Node :=
2807 New_Node (N_Discriminant_Specification, Ident_Sloc);
2808 Set_Defining_Identifier (Specification_Node, Idents (Ident));
2809 Not_Null_Present := -- Ada 2005 (AI-231, AI-447)
2810 P_Null_Exclusion (Allow_Anonymous_In_95 => True);
2812 if Token = Tok_Access then
2813 if Ada_Version = Ada_83 then
2815 ("(Ada 83) access discriminant not allowed!");
2818 Set_Discriminant_Type
2819 (Specification_Node,
2820 P_Access_Definition (Not_Null_Present));
2823 Set_Discriminant_Type
2824 (Specification_Node, P_Subtype_Mark);
2826 Set_Null_Exclusion_Present -- Ada 2005 (AI-231)
2827 (Specification_Node, Not_Null_Present);
2831 (Specification_Node, Init_Expr_Opt (True));
2834 Set_Prev_Ids (Specification_Node, True);
2837 if Ident < Num_Idents then
2838 Set_More_Ids (Specification_Node, True);
2841 Append (Specification_Node, Specification_List);
2842 exit Ident_Loop when Ident = Num_Idents;
2844 Restore_Scan_State (Scan_State);
2846 end loop Ident_Loop;
2848 exit Specification_Loop when Token /= Tok_Semicolon;
2850 P_Pragmas_Misplaced;
2851 end loop Specification_Loop;
2854 return Specification_List;
2859 end P_Known_Discriminant_Part_Opt;
2861 -------------------------------------
2862 -- 3.7 DIscriminant Specification --
2863 -------------------------------------
2865 -- Parsed by P_Known_Discriminant_Part_Opt (3.7)
2867 -----------------------------
2868 -- 3.7 Default Expression --
2869 -----------------------------
2871 -- Always parsed (simply as an Expression) by the parent construct
2873 ------------------------------------
2874 -- 3.7.1 Discriminant Constraint --
2875 ------------------------------------
2877 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2879 --------------------------------------------------------
2880 -- 3.7.1 Index or Discriminant Constraint (also 3.6) --
2881 --------------------------------------------------------
2883 -- DISCRIMINANT_CONSTRAINT ::=
2884 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
2886 -- DISCRIMINANT_ASSOCIATION ::=
2887 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2890 -- This routine parses either an index or a discriminant constraint. As
2891 -- is clear from the above grammar, it is often possible to clearly
2892 -- determine which of the two possibilities we have, but there are
2893 -- cases (those in which we have a series of expressions of the same
2894 -- syntactic form as subtype indications), where we cannot tell. Since
2895 -- this means that in any case the semantic phase has to distinguish
2896 -- between the two, there is not much point in the parser trying to
2897 -- distinguish even those cases where the difference is clear. In any
2898 -- case, if we have a situation like:
2900 -- (A => 123, 235 .. 500)
2902 -- it is not clear which of the two items is the wrong one, better to
2903 -- let the semantic phase give a clear message. Consequently, this
2904 -- routine in general returns a list of items which can be either
2905 -- discrete ranges or discriminant associations.
2907 -- The caller has checked that the initial token is a left paren
2909 -- Error recovery: can raise Error_Resync
2911 function P_Index_Or_Discriminant_Constraint return Node_Id is
2912 Scan_State : Saved_Scan_State;
2913 Constr_Node : Node_Id;
2914 Constr_List : List_Id;
2915 Expr_Node : Node_Id;
2916 Result_Node : Node_Id;
2919 Result_Node := New_Node (N_Index_Or_Discriminant_Constraint, Token_Ptr);
2921 Constr_List := New_List;
2922 Set_Constraints (Result_Node, Constr_List);
2924 -- The two syntactic forms are a little mixed up, so what we are doing
2925 -- here is looking at the first entry to determine which case we have
2927 -- A discriminant constraint is a list of discriminant associations,
2928 -- which have one of the following possible forms:
2932 -- Id | Id | .. | Id => Expression
2934 -- An index constraint is a list of discrete ranges which have one
2935 -- of the following possible forms:
2938 -- Subtype_Mark range Range
2940 -- Simple_Expression .. Simple_Expression
2942 -- Loop through discriminants in list
2945 -- Check cases of Id => Expression or Id | Id => Expression
2947 if Token = Tok_Identifier then
2948 Save_Scan_State (Scan_State); -- at Id
2951 if Token = Tok_Arrow or else Token = Tok_Vertical_Bar then
2952 Restore_Scan_State (Scan_State); -- to Id
2953 Append (P_Discriminant_Association, Constr_List);
2956 Restore_Scan_State (Scan_State); -- to Id
2960 -- Otherwise scan out an expression and see what we have got
2962 Expr_Node := P_Expression_Or_Range_Attribute;
2964 if Expr_Form = EF_Range_Attr then
2965 Append (Expr_Node, Constr_List);
2967 elsif Token = Tok_Range then
2968 if Expr_Form /= EF_Simple_Name then
2969 Error_Msg_SC ("subtype mark required before RANGE");
2972 Append (P_Subtype_Indication (Expr_Node), Constr_List);
2975 -- Check Simple_Expression .. Simple_Expression case
2977 elsif Token = Tok_Dot_Dot then
2978 Check_Simple_Expression (Expr_Node);
2979 Constr_Node := New_Node (N_Range, Token_Ptr);
2980 Set_Low_Bound (Constr_Node, Expr_Node);
2982 Expr_Node := P_Expression;
2983 Check_Simple_Expression (Expr_Node);
2984 Set_High_Bound (Constr_Node, Expr_Node);
2985 Append (Constr_Node, Constr_List);
2988 -- Case of an expression which could be either form
2991 Append (Expr_Node, Constr_List);
2995 -- Here with a single entry scanned
2998 exit when not Comma_Present;
3004 end P_Index_Or_Discriminant_Constraint;
3006 -------------------------------------
3007 -- 3.7.1 Discriminant Association --
3008 -------------------------------------
3010 -- DISCRIMINANT_ASSOCIATION ::=
3011 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
3014 -- This routine is used only when the name list is present and the caller
3015 -- has already checked this (by scanning ahead and repositioning the
3018 -- Error_Recovery: cannot raise Error_Resync;
3020 function P_Discriminant_Association return Node_Id is
3021 Discr_Node : Node_Id;
3022 Names_List : List_Id;
3023 Ident_Sloc : Source_Ptr;
3026 Ident_Sloc := Token_Ptr;
3027 Names_List := New_List;
3030 Append (P_Identifier (C_Vertical_Bar_Arrow), Names_List);
3031 exit when Token /= Tok_Vertical_Bar;
3035 Discr_Node := New_Node (N_Discriminant_Association, Ident_Sloc);
3036 Set_Selector_Names (Discr_Node, Names_List);
3038 Set_Expression (Discr_Node, P_Expression);
3040 end P_Discriminant_Association;
3042 ---------------------------------
3043 -- 3.8 Record Type Definition --
3044 ---------------------------------
3046 -- RECORD_TYPE_DEFINITION ::=
3047 -- [[abstract] tagged] [limited] RECORD_DEFINITION
3049 -- There is no node in the tree for a record type definition. Instead
3050 -- a record definition node appears, with possible Abstract_Present,
3051 -- Tagged_Present, and Limited_Present flags set appropriately.
3053 ----------------------------
3054 -- 3.8 Record Definition --
3055 ----------------------------
3057 -- RECORD_DEFINITION ::=
3063 -- Note: in the case where a record definition node is used to represent
3064 -- a record type definition, the caller sets the Tagged_Present and
3065 -- Limited_Present flags in the resulting N_Record_Definition node as
3068 -- Note that the RECORD token at the start may be missing in certain
3069 -- error situations, so this function is expected to post the error
3071 -- Error recovery: can raise Error_Resync
3073 function P_Record_Definition return Node_Id is
3077 Rec_Node := New_Node (N_Record_Definition, Token_Ptr);
3081 if Token = Tok_Null then
3084 Set_Null_Present (Rec_Node, True);
3086 -- Case starting with RECORD keyword. Build scope stack entry. For the
3087 -- column, we use the first non-blank character on the line, to deal
3088 -- with situations such as:
3094 -- which is not official RM indentation, but is not uncommon usage
3098 Scope.Table (Scope.Last).Etyp := E_Record;
3099 Scope.Table (Scope.Last).Ecol := Start_Column;
3100 Scope.Table (Scope.Last).Sloc := Token_Ptr;
3101 Scope.Table (Scope.Last).Labl := Error;
3102 Scope.Table (Scope.Last).Junk := (Token /= Tok_Record);
3106 Set_Component_List (Rec_Node, P_Component_List);
3109 exit when Check_End;
3110 Discard_Junk_Node (P_Component_List);
3115 end P_Record_Definition;
3117 -------------------------
3118 -- 3.8 Component List --
3119 -------------------------
3121 -- COMPONENT_LIST ::=
3122 -- COMPONENT_ITEM {COMPONENT_ITEM}
3123 -- | {COMPONENT_ITEM} VARIANT_PART
3126 -- Error recovery: cannot raise Error_Resync
3128 function P_Component_List return Node_Id is
3129 Component_List_Node : Node_Id;
3130 Decls_List : List_Id;
3131 Scan_State : Saved_Scan_State;
3134 Component_List_Node := New_Node (N_Component_List, Token_Ptr);
3135 Decls_List := New_List;
3137 if Token = Tok_Null then
3140 P_Pragmas_Opt (Decls_List);
3141 Set_Null_Present (Component_List_Node, True);
3142 return Component_List_Node;
3145 P_Pragmas_Opt (Decls_List);
3147 if Token /= Tok_Case then
3148 Component_Scan_Loop : loop
3149 P_Component_Items (Decls_List);
3150 P_Pragmas_Opt (Decls_List);
3152 exit Component_Scan_Loop when Token = Tok_End
3153 or else Token = Tok_Case
3154 or else Token = Tok_When;
3156 -- We are done if we do not have an identifier. However, if
3157 -- we have a misspelled reserved identifier that is in a column
3158 -- to the right of the record definition, we will treat it as
3159 -- an identifier. It turns out to be too dangerous in practice
3160 -- to accept such a mis-spelled identifier which does not have
3161 -- this additional clue that confirms the incorrect spelling.
3163 if Token /= Tok_Identifier then
3164 if Start_Column > Scope.Table (Scope.Last).Ecol
3165 and then Is_Reserved_Identifier
3167 Save_Scan_State (Scan_State); -- at reserved id
3168 Scan; -- possible reserved id
3170 if Token = Tok_Comma or else Token = Tok_Colon then
3171 Restore_Scan_State (Scan_State);
3172 Scan_Reserved_Identifier (Force_Msg => True);
3174 -- Note reserved identifier used as field name after
3175 -- all because not followed by colon or comma
3178 Restore_Scan_State (Scan_State);
3179 exit Component_Scan_Loop;
3182 -- Non-identifier that definitely was not reserved id
3185 exit Component_Scan_Loop;
3188 end loop Component_Scan_Loop;
3191 if Token = Tok_Case then
3192 Set_Variant_Part (Component_List_Node, P_Variant_Part);
3194 -- Check for junk after variant part
3196 if Token = Tok_Identifier then
3197 Save_Scan_State (Scan_State);
3198 Scan; -- past identifier
3200 if Token = Tok_Colon then
3201 Restore_Scan_State (Scan_State);
3202 Error_Msg_SC ("component may not follow variant part");
3203 Discard_Junk_Node (P_Component_List);
3205 elsif Token = Tok_Case then
3206 Restore_Scan_State (Scan_State);
3207 Error_Msg_SC ("only one variant part allowed in a record");
3208 Discard_Junk_Node (P_Component_List);
3211 Restore_Scan_State (Scan_State);
3217 Set_Component_Items (Component_List_Node, Decls_List);
3218 return Component_List_Node;
3219 end P_Component_List;
3221 -------------------------
3222 -- 3.8 Component Item --
3223 -------------------------
3225 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
3227 -- COMPONENT_DECLARATION ::=
3228 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
3229 -- [:= DEFAULT_EXPRESSION];
3231 -- COMPONENT_DEFINITION ::=
3232 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
3234 -- Error recovery: cannot raise Error_Resync, if an error occurs,
3235 -- the scan is positioned past the following semicolon.
3237 -- Note: we do not yet allow representation clauses to appear as component
3238 -- items, do we need to add this capability sometime in the future ???
3240 procedure P_Component_Items (Decls : List_Id) is
3241 Aliased_Present : Boolean := False;
3242 CompDef_Node : Node_Id;
3243 Decl_Node : Node_Id;
3244 Scan_State : Saved_Scan_State;
3245 Not_Null_Present : Boolean := False;
3248 Ident_Sloc : Source_Ptr;
3250 Idents : array (Int range 1 .. 4096) of Entity_Id;
3251 -- This array holds the list of defining identifiers. The upper bound
3252 -- of 4096 is intended to be essentially infinite, and we do not even
3253 -- bother to check for it being exceeded.
3256 if Token /= Tok_Identifier then
3257 Error_Msg_SC ("component declaration expected");
3258 Resync_Past_Semicolon;
3262 Ident_Sloc := Token_Ptr;
3263 Idents (1) := P_Defining_Identifier (C_Comma_Colon);
3266 while Comma_Present loop
3267 Num_Idents := Num_Idents + 1;
3268 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
3271 -- If there are multiple identifiers, we repeatedly scan the
3272 -- type and initialization expression information by resetting
3273 -- the scan pointer (so that we get completely separate trees
3274 -- for each occurrence).
3276 if Num_Idents > 1 then
3277 Save_Scan_State (Scan_State);
3282 -- Loop through defining identifiers in list
3287 -- The following block is present to catch Error_Resync
3288 -- which causes the parse to be reset past the semicolon
3291 Decl_Node := New_Node (N_Component_Declaration, Ident_Sloc);
3292 Set_Defining_Identifier (Decl_Node, Idents (Ident));
3294 if Token = Tok_Constant then
3295 Error_Msg_SC ("constant components are not permitted");
3299 CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
3301 if Token_Name = Name_Aliased then
3302 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
3305 if Token = Tok_Aliased then
3306 Aliased_Present := True;
3307 Scan; -- past ALIASED
3310 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254)
3312 -- Ada 2005 (AI-230): Access Definition case
3314 if Token = Tok_Access then
3315 if Ada_Version < Ada_05 then
3317 ("generalized use of anonymous access types " &
3318 "is an Ada 2005 extension");
3319 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
3322 if Aliased_Present then
3323 Error_Msg_SP ("ALIASED not allowed here");
3326 Set_Subtype_Indication (CompDef_Node, Empty);
3327 Set_Aliased_Present (CompDef_Node, False);
3328 Set_Access_Definition (CompDef_Node,
3329 P_Access_Definition (Not_Null_Present));
3332 Set_Access_Definition (CompDef_Node, Empty);
3333 Set_Aliased_Present (CompDef_Node, Aliased_Present);
3334 Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
3336 if Token = Tok_Array then
3338 ("anonymous arrays not allowed as components");
3342 Set_Subtype_Indication (CompDef_Node,
3343 P_Subtype_Indication (Not_Null_Present));
3346 Set_Component_Definition (Decl_Node, CompDef_Node);
3347 Set_Expression (Decl_Node, Init_Expr_Opt);
3350 Set_Prev_Ids (Decl_Node, True);
3353 if Ident < Num_Idents then
3354 Set_More_Ids (Decl_Node, True);
3357 Append (Decl_Node, Decls);
3360 when Error_Resync =>
3361 if Token /= Tok_End then
3362 Resync_Past_Semicolon;
3366 exit Ident_Loop when Ident = Num_Idents;
3368 Restore_Scan_State (Scan_State);
3371 end loop Ident_Loop;
3374 end P_Component_Items;
3376 --------------------------------
3377 -- 3.8 Component Declaration --
3378 --------------------------------
3380 -- Parsed by P_Component_Items (3.8)
3382 -------------------------
3383 -- 3.8.1 Variant Part --
3384 -------------------------
3387 -- case discriminant_DIRECT_NAME is
3392 -- The caller has checked that the initial token is CASE
3394 -- Error recovery: cannot raise Error_Resync
3396 function P_Variant_Part return Node_Id is
3397 Variant_Part_Node : Node_Id;
3398 Variants_List : List_Id;
3399 Case_Node : Node_Id;
3402 Variant_Part_Node := New_Node (N_Variant_Part, Token_Ptr);
3404 Scope.Table (Scope.Last).Etyp := E_Case;
3405 Scope.Table (Scope.Last).Sloc := Token_Ptr;
3406 Scope.Table (Scope.Last).Ecol := Start_Column;
3409 Case_Node := P_Expression;
3410 Set_Name (Variant_Part_Node, Case_Node);
3412 if Nkind (Case_Node) /= N_Identifier then
3413 Set_Name (Variant_Part_Node, Error);
3414 Error_Msg ("discriminant name expected", Sloc (Case_Node));
3418 Variants_List := New_List;
3419 P_Pragmas_Opt (Variants_List);
3421 -- Test missing variant
3423 if Token = Tok_End then
3424 Error_Msg_BC ("WHEN expected (must have at least one variant)");
3426 Append (P_Variant, Variants_List);
3429 -- Loop through variants, note that we allow if in place of when,
3430 -- this error will be detected and handled in P_Variant.
3433 P_Pragmas_Opt (Variants_List);
3435 if Token /= Tok_When
3436 and then Token /= Tok_If
3437 and then Token /= Tok_Others
3439 exit when Check_End;
3442 Append (P_Variant, Variants_List);
3445 Set_Variants (Variant_Part_Node, Variants_List);
3446 return Variant_Part_Node;
3449 --------------------
3451 --------------------
3454 -- when DISCRETE_CHOICE_LIST =>
3457 -- Error recovery: cannot raise Error_Resync
3459 -- The initial token on entry is either WHEN, IF or OTHERS
3461 function P_Variant return Node_Id is
3462 Variant_Node : Node_Id;
3465 -- Special check to recover nicely from use of IF in place of WHEN
3467 if Token = Tok_If then
3474 Variant_Node := New_Node (N_Variant, Prev_Token_Ptr);
3475 Set_Discrete_Choices (Variant_Node, P_Discrete_Choice_List);
3477 Set_Component_List (Variant_Node, P_Component_List);
3478 return Variant_Node;
3481 ---------------------------------
3482 -- 3.8.1 Discrete Choice List --
3483 ---------------------------------
3485 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
3487 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
3489 -- Note: in Ada 83, the expression must be a simple expression
3491 -- Error recovery: cannot raise Error_Resync
3493 function P_Discrete_Choice_List return List_Id is
3495 Expr_Node : Node_Id;
3496 Choice_Node : Node_Id;
3499 Choices := New_List;
3502 if Token = Tok_Others then
3503 Append (New_Node (N_Others_Choice, Token_Ptr), Choices);
3504 Scan; -- past OTHERS
3508 Expr_Node := No_Right_Paren (P_Expression_Or_Range_Attribute);
3510 if Token = Tok_Colon
3511 and then Nkind (Expr_Node) = N_Identifier
3513 Error_Msg_SP ("label not permitted in this context");
3516 elsif Expr_Form = EF_Range_Attr then
3517 Append (Expr_Node, Choices);
3519 elsif Token = Tok_Dot_Dot then
3520 Check_Simple_Expression (Expr_Node);
3521 Choice_Node := New_Node (N_Range, Token_Ptr);
3522 Set_Low_Bound (Choice_Node, Expr_Node);
3524 Expr_Node := P_Expression_No_Right_Paren;
3525 Check_Simple_Expression (Expr_Node);
3526 Set_High_Bound (Choice_Node, Expr_Node);
3527 Append (Choice_Node, Choices);
3529 elsif Expr_Form = EF_Simple_Name then
3530 if Token = Tok_Range then
3531 Append (P_Subtype_Indication (Expr_Node), Choices);
3533 elsif Token in Token_Class_Consk then
3535 ("the only constraint allowed here " &
3536 "is a range constraint");
3537 Discard_Junk_Node (P_Constraint_Opt);
3538 Append (Expr_Node, Choices);
3541 Append (Expr_Node, Choices);
3545 Check_Simple_Expression_In_Ada_83 (Expr_Node);
3546 Append (Expr_Node, Choices);
3550 when Error_Resync =>
3556 if Token = Tok_Comma then
3557 Error_Msg_SC (""","" should be ""'|""");
3559 exit when Token /= Tok_Vertical_Bar;
3562 Scan; -- past | or comma
3566 end P_Discrete_Choice_List;
3568 ----------------------------
3569 -- 3.8.1 Discrete Choice --
3570 ----------------------------
3572 -- Parsed by P_Discrete_Choice_List (3.8.1)
3574 ----------------------------------
3575 -- 3.9.1 Record Extension Part --
3576 ----------------------------------
3578 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
3580 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
3582 --------------------------------------
3583 -- 3.9.4 Interface Type Definition --
3584 --------------------------------------
3586 -- INTERFACE_TYPE_DEFINITION ::=
3587 -- [limited | task | protected | synchronized] interface
3588 -- [and INTERFACE_LIST]
3590 -- Error recovery: cannot raise Error_Resync
3592 function P_Interface_Type_Definition
3593 (Abstract_Present : Boolean) return Node_Id
3595 Typedef_Node : Node_Id;
3598 if Ada_Version < Ada_05 then
3599 Error_Msg_SP ("abstract interface is an Ada 2005 extension");
3600 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
3603 if Abstract_Present then
3604 Error_Msg_SP ("ABSTRACT not allowed in interface type definition " &
3605 "('R'M' 3.9.4(2/2))");
3608 Scan; -- past INTERFACE
3610 -- Ada 2005 (AI-345): In case of interfaces with a null list of
3611 -- interfaces we build a record_definition node.
3613 if Token = Tok_Semicolon then
3614 Typedef_Node := New_Node (N_Record_Definition, Token_Ptr);
3616 Set_Abstract_Present (Typedef_Node);
3617 Set_Tagged_Present (Typedef_Node);
3618 Set_Null_Present (Typedef_Node);
3619 Set_Interface_Present (Typedef_Node);
3621 -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have
3622 -- a list of interfaces we build a derived_type_definition node. This
3623 -- simplifies the semantic analysis (and hence further mainteinance)
3626 if Token /= Tok_And then
3627 Error_Msg_AP ("AND expected");
3632 Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
3634 Set_Abstract_Present (Typedef_Node);
3635 Set_Interface_Present (Typedef_Node);
3636 Set_Subtype_Indication (Typedef_Node, P_Qualified_Simple_Name);
3638 Set_Record_Extension_Part (Typedef_Node,
3639 New_Node (N_Record_Definition, Token_Ptr));
3640 Set_Null_Present (Record_Extension_Part (Typedef_Node));
3642 if Token = Tok_And then
3643 Set_Interface_List (Typedef_Node, New_List);
3647 Append (P_Qualified_Simple_Name,
3648 Interface_List (Typedef_Node));
3649 exit when Token /= Tok_And;
3655 return Typedef_Node;
3656 end P_Interface_Type_Definition;
3658 ----------------------------------
3659 -- 3.10 Access Type Definition --
3660 ----------------------------------
3662 -- ACCESS_TYPE_DEFINITION ::=
3663 -- ACCESS_TO_OBJECT_DEFINITION
3664 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3666 -- ACCESS_TO_OBJECT_DEFINITION ::=
3667 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
3669 -- GENERAL_ACCESS_MODIFIER ::= all | constant
3671 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3672 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3673 -- | [NULL_EXCLUSION] access [protected] function
3674 -- PARAMETER_AND_RESULT_PROFILE
3676 -- PARAMETER_PROFILE ::= [FORMAL_PART]
3678 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
3680 -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already
3681 -- parsed the null_exclusion part and has also removed the ACCESS token;
3682 -- otherwise the caller has just checked that the initial token is ACCESS
3684 -- Error recovery: can raise Error_Resync
3686 function P_Access_Type_Definition
3687 (Header_Already_Parsed : Boolean := False) return Node_Id
3689 Access_Loc : constant Source_Ptr := Token_Ptr;
3690 Prot_Flag : Boolean;
3691 Not_Null_Present : Boolean := False;
3692 Type_Def_Node : Node_Id;
3693 Result_Not_Null : Boolean;
3694 Result_Node : Node_Id;
3696 procedure Check_Junk_Subprogram_Name;
3697 -- Used in access to subprogram definition cases to check for an
3698 -- identifier or operator symbol that does not belong.
3700 --------------------------------
3701 -- Check_Junk_Subprogram_Name --
3702 --------------------------------
3704 procedure Check_Junk_Subprogram_Name is
3705 Saved_State : Saved_Scan_State;
3708 if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
3709 Save_Scan_State (Saved_State);
3710 Scan; -- past possible junk subprogram name
3712 if Token = Tok_Left_Paren or else Token = Tok_Semicolon then
3713 Error_Msg_SP ("unexpected subprogram name ignored");
3717 Restore_Scan_State (Saved_State);
3720 end Check_Junk_Subprogram_Name;
3722 -- Start of processing for P_Access_Type_Definition
3725 if not Header_Already_Parsed then
3726 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
3727 Scan; -- past ACCESS
3730 if Token_Name = Name_Protected then
3731 Check_95_Keyword (Tok_Protected, Tok_Procedure);
3732 Check_95_Keyword (Tok_Protected, Tok_Function);
3735 Prot_Flag := (Token = Tok_Protected);
3738 Scan; -- past PROTECTED
3740 if Token /= Tok_Procedure and then Token /= Tok_Function then
3741 Error_Msg_SC ("FUNCTION or PROCEDURE expected");
3745 if Token = Tok_Procedure then
3746 if Ada_Version = Ada_83 then
3747 Error_Msg_SC ("(Ada 83) access to procedure not allowed!");
3750 Type_Def_Node := New_Node (N_Access_Procedure_Definition, Access_Loc);
3751 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3752 Scan; -- past PROCEDURE
3753 Check_Junk_Subprogram_Name;
3754 Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
3755 Set_Protected_Present (Type_Def_Node, Prot_Flag);
3757 elsif Token = Tok_Function then
3758 if Ada_Version = Ada_83 then
3759 Error_Msg_SC ("(Ada 83) access to function not allowed!");
3762 Type_Def_Node := New_Node (N_Access_Function_Definition, Access_Loc);
3763 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3764 Scan; -- past FUNCTION
3765 Check_Junk_Subprogram_Name;
3766 Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
3767 Set_Protected_Present (Type_Def_Node, Prot_Flag);
3770 Result_Not_Null := P_Null_Exclusion; -- Ada 2005 (AI-231)
3772 -- Ada 2005 (AI-318-02)
3774 if Token = Tok_Access then
3775 if Ada_Version < Ada_05 then
3777 ("anonymous access result type is an Ada 2005 extension");
3778 Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
3781 Result_Node := P_Access_Definition (Result_Not_Null);
3784 Result_Node := P_Subtype_Mark;
3788 -- Note: A null exclusion given on the result type needs to
3789 -- be coded by a distinct flag, since Null_Exclusion_Present
3790 -- on an access-to-function type pertains to a null exclusion
3791 -- on the access type itself (as set above). ???
3792 -- Set_Null_Exclusion_Present??? (Type_Def_Node, Result_Not_Null);
3794 Set_Result_Definition (Type_Def_Node, Result_Node);
3798 New_Node (N_Access_To_Object_Definition, Access_Loc);
3799 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3801 if Token = Tok_All or else Token = Tok_Constant then
3802 if Ada_Version = Ada_83 then
3803 Error_Msg_SC ("(Ada 83) access modifier not allowed!");
3806 if Token = Tok_All then
3807 Set_All_Present (Type_Def_Node, True);
3810 Set_Constant_Present (Type_Def_Node, True);
3813 Scan; -- past ALL or CONSTANT
3816 Set_Subtype_Indication (Type_Def_Node,
3817 P_Subtype_Indication (Not_Null_Present));
3820 return Type_Def_Node;
3821 end P_Access_Type_Definition;
3823 ---------------------------------------
3824 -- 3.10 Access To Object Definition --
3825 ---------------------------------------
3827 -- Parsed by P_Access_Type_Definition (3.10)
3829 -----------------------------------
3830 -- 3.10 General Access Modifier --
3831 -----------------------------------
3833 -- Parsed by P_Access_Type_Definition (3.10)
3835 -------------------------------------------
3836 -- 3.10 Access To Subprogram Definition --
3837 -------------------------------------------
3839 -- Parsed by P_Access_Type_Definition (3.10)
3841 -----------------------------
3842 -- 3.10 Access Definition --
3843 -----------------------------
3845 -- ACCESS_DEFINITION ::=
3846 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3847 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3849 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3850 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3851 -- | [NULL_EXCLUSION] access [protected] function
3852 -- PARAMETER_AND_RESULT_PROFILE
3854 -- The caller has parsed the null-exclusion part and it has also checked
3855 -- that the next token is ACCESS
3857 -- Error recovery: cannot raise Error_Resync
3859 function P_Access_Definition
3860 (Null_Exclusion_Present : Boolean) return Node_Id
3863 Subp_Node : Node_Id;
3866 Def_Node := New_Node (N_Access_Definition, Token_Ptr);
3867 Scan; -- past ACCESS
3869 -- Ada 2005 (AI-254): Access_To_Subprogram_Definition
3871 if Token = Tok_Protected
3872 or else Token = Tok_Procedure
3873 or else Token = Tok_Function
3875 if Ada_Version < Ada_05 then
3876 Error_Msg_SP ("access-to-subprogram is an Ada 2005 extension");
3877 Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
3880 Subp_Node := P_Access_Type_Definition (Header_Already_Parsed => True);
3881 Set_Null_Exclusion_Present (Subp_Node, Null_Exclusion_Present);
3882 Set_Access_To_Subprogram_Definition (Def_Node, Subp_Node);
3884 -- Ada 2005 (AI-231)
3885 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3888 Set_Null_Exclusion_Present (Def_Node, Null_Exclusion_Present);
3890 if Token = Tok_All then
3891 if Ada_Version < Ada_05 then
3893 ("access-all in this context is an Ada 2005 extension");
3894 Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
3898 Set_All_Present (Def_Node);
3900 elsif Token = Tok_Constant then
3901 if Ada_Version < Ada_05 then
3902 Error_Msg_SP ("access-to-constant is an Ada 2005 extension");
3903 Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
3906 Scan; -- past CONSTANT
3907 Set_Constant_Present (Def_Node);
3910 Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
3915 end P_Access_Definition;
3917 -----------------------------------------
3918 -- 3.10.1 Incomplete Type Declaration --
3919 -----------------------------------------
3921 -- Parsed by P_Type_Declaration (3.2.1)
3923 ----------------------------
3924 -- 3.11 Declarative Part --
3925 ----------------------------
3927 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
3929 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items
3930 -- handles errors, and returns cleanly after an error has occurred)
3932 function P_Declarative_Part return List_Id is
3937 -- Indicate no bad declarations detected yet. This will be reset by
3938 -- P_Declarative_Items if a bad declaration is discovered.
3940 Missing_Begin_Msg := No_Error_Msg;
3942 -- Get rid of active SIS entry from outer scope. This means we will
3943 -- miss some nested cases, but it doesn't seem worth the effort. See
3944 -- discussion in Par for further details
3946 SIS_Entry_Active := False;
3949 -- Loop to scan out the declarations
3952 P_Declarative_Items (Decls, Done, In_Spec => False);
3956 -- Get rid of active SIS entry which is left set only if we scanned a
3957 -- procedure declaration and have not found the body. We could give
3958 -- an error message, but that really would be usurping the role of
3959 -- semantic analysis (this really is a missing body case).
3961 SIS_Entry_Active := False;
3963 end P_Declarative_Part;
3965 ----------------------------
3966 -- 3.11 Declarative Item --
3967 ----------------------------
3969 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
3971 -- Can return Error if a junk declaration is found, or Empty if no
3972 -- declaration is found (i.e. a token ending declarations, such as
3973 -- BEGIN or END is encountered).
3975 -- Error recovery: cannot raise Error_Resync. If an error resync occurs,
3976 -- then the scan is set past the next semicolon and Error is returned.
3978 procedure P_Declarative_Items
3983 Scan_State : Saved_Scan_State;
3986 if Style_Check then Style.Check_Indentation; end if;
3990 when Tok_Function =>
3992 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
3998 -- Check for loop (premature statement)
4000 Save_Scan_State (Scan_State);
4003 if Token = Tok_Identifier then
4004 Scan; -- past identifier
4006 if Token = Tok_In then
4007 Restore_Scan_State (Scan_State);
4008 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
4013 -- Not a loop, so must be rep clause
4015 Restore_Scan_State (Scan_State);
4016 Append (P_Representation_Clause, Decls);
4021 Append (P_Generic, Decls);
4024 when Tok_Identifier =>
4026 P_Identifier_Declarations (Decls, Done, In_Spec);
4028 -- Ada2005: A subprogram declaration can start with "not" or
4029 -- "overriding". In older versions, "overriding" is handled
4030 -- like an identifier, with the appropriate warning.
4034 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4037 when Tok_Overriding =>
4039 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4044 Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4048 Append (P_Pragma, Decls);
4051 when Tok_Procedure =>
4053 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4056 when Tok_Protected =>
4058 Scan; -- past PROTECTED
4059 Append (P_Protected, Decls);
4064 Append (P_Subtype_Declaration, Decls);
4070 Append (P_Task, Decls);
4075 Append (P_Type_Declaration, Decls);
4080 Append (P_Use_Clause, Decls);
4085 Error_Msg_SC ("WITH can only appear in context clause");
4088 -- BEGIN terminates the scan of a sequence of declarations unless
4089 -- there is a missing subprogram body, see section on handling
4090 -- semicolon in place of IS. We only treat the begin as satisfying
4091 -- the subprogram declaration if it falls in the expected column
4095 if SIS_Entry_Active and then Start_Column >= SIS_Ecol then
4097 -- Here we have the case where a BEGIN is encountered during
4098 -- declarations in a declarative part, or at the outer level,
4099 -- and there is a subprogram declaration outstanding for which
4100 -- no body has been supplied. This is the case where we assume
4101 -- that the semicolon in the subprogram declaration should
4102 -- really have been is. The active SIS entry describes the
4103 -- subprogram declaration. On return the declaration has been
4104 -- modified to become a body.
4107 Specification_Node : Node_Id;
4108 Decl_Node : Node_Id;
4109 Body_Node : Node_Id;
4112 -- First issue the error message. If we had a missing
4113 -- semicolon in the declaration, then change the message
4114 -- to <missing "is">
4116 if SIS_Missing_Semicolon_Message /= No_Error_Msg then
4117 Change_Error_Text -- Replace: "missing "";"" "
4118 (SIS_Missing_Semicolon_Message, "missing ""is""");
4120 -- Otherwise we saved the semicolon position, so complain
4123 Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc);
4126 -- The next job is to fix up any declarations that occurred
4127 -- between the procedure header and the BEGIN. These got
4128 -- chained to the outer declarative region (immediately
4129 -- after the procedure declaration) and they should be
4130 -- chained to the subprogram itself, which is a body
4131 -- rather than a spec.
4133 Specification_Node := Specification (SIS_Declaration_Node);
4134 Change_Node (SIS_Declaration_Node, N_Subprogram_Body);
4135 Body_Node := SIS_Declaration_Node;
4136 Set_Specification (Body_Node, Specification_Node);
4137 Set_Declarations (Body_Node, New_List);
4140 Decl_Node := Remove_Next (Body_Node);
4141 exit when Decl_Node = Empty;
4142 Append (Decl_Node, Declarations (Body_Node));
4145 -- Now make the scope table entry for the Begin-End and
4149 Scope.Table (Scope.Last).Sloc := SIS_Sloc;
4150 Scope.Table (Scope.Last).Etyp := E_Name;
4151 Scope.Table (Scope.Last).Ecol := SIS_Ecol;
4152 Scope.Table (Scope.Last).Labl := SIS_Labl;
4153 Scope.Table (Scope.Last).Lreq := False;
4154 SIS_Entry_Active := False;
4156 Set_Handled_Statement_Sequence (Body_Node,
4157 P_Handled_Sequence_Of_Statements);
4158 End_Statements (Handled_Statement_Sequence (Body_Node));
4167 -- Normally an END terminates the scan for basic declarative
4168 -- items. The one exception is END RECORD, which is probably
4169 -- left over from some other junk.
4172 Save_Scan_State (Scan_State); -- at END
4175 if Token = Tok_Record then
4176 Error_Msg_SP ("no RECORD for this `end record`!");
4177 Scan; -- past RECORD
4181 Restore_Scan_State (Scan_State); -- to END
4185 -- The following tokens which can only be the start of a statement
4186 -- are considered to end a declarative part (i.e. we have a missing
4187 -- BEGIN situation). We are fairly conservative in making this
4188 -- judgment, because it is a real mess to go into statement mode
4189 -- prematurely in response to a junk declaration.
4204 -- But before we decide that it's a statement, let's check for
4205 -- a reserved word misused as an identifier.
4207 if Is_Reserved_Identifier then
4208 Save_Scan_State (Scan_State);
4209 Scan; -- past the token
4211 -- If reserved identifier not followed by colon or comma, then
4212 -- this is most likely an assignment statement to the bad id.
4214 if Token /= Tok_Colon and then Token /= Tok_Comma then
4215 Restore_Scan_State (Scan_State);
4216 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
4219 -- Otherwise we have a declaration of the bad id
4222 Restore_Scan_State (Scan_State);
4223 Scan_Reserved_Identifier (Force_Msg => True);
4224 P_Identifier_Declarations (Decls, Done, In_Spec);
4227 -- If not reserved identifier, then it's definitely a statement
4230 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
4234 -- The token RETURN may well also signal a missing BEGIN situation,
4235 -- however, we never let it end the declarative part, because it may
4236 -- also be part of a half-baked function declaration.
4239 Error_Msg_SC ("misplaced RETURN statement");
4242 -- PRIVATE definitely terminates the declarations in a spec,
4243 -- and is an error in a body.
4249 Error_Msg_SC ("PRIVATE not allowed in body");
4250 Scan; -- past PRIVATE
4253 -- An end of file definitely terminates the declarations!
4258 -- The remaining tokens do not end the scan, but cannot start a
4259 -- valid declaration, so we signal an error and resynchronize.
4260 -- But first check for misuse of a reserved identifier.
4264 -- Here we check for a reserved identifier
4266 if Is_Reserved_Identifier then
4267 Save_Scan_State (Scan_State);
4268 Scan; -- past the token
4270 if Token /= Tok_Colon and then Token /= Tok_Comma then
4271 Restore_Scan_State (Scan_State);
4272 Set_Declaration_Expected;
4275 Restore_Scan_State (Scan_State);
4276 Scan_Reserved_Identifier (Force_Msg => True);
4278 P_Identifier_Declarations (Decls, Done, In_Spec);
4282 Set_Declaration_Expected;
4287 -- To resynchronize after an error, we scan to the next semicolon and
4288 -- return with Done = False, indicating that there may still be more
4289 -- valid declarations to come.
4292 when Error_Resync =>
4293 Resync_Past_Semicolon;
4295 end P_Declarative_Items;
4297 ----------------------------------
4298 -- 3.11 Basic Declarative Item --
4299 ----------------------------------
4301 -- BASIC_DECLARATIVE_ITEM ::=
4302 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
4304 -- Scan zero or more basic declarative items
4306 -- Error recovery: cannot raise Error_Resync. If an error is detected, then
4307 -- the scan pointer is repositioned past the next semicolon, and the scan
4308 -- for declarative items continues.
4310 function P_Basic_Declarative_Items return List_Id is
4317 -- Indicate no bad declarations detected yet in the current context:
4318 -- visible or private declarations of a package spec.
4320 Missing_Begin_Msg := No_Error_Msg;
4322 -- Get rid of active SIS entry from outer scope. This means we will
4323 -- miss some nested cases, but it doesn't seem worth the effort. See
4324 -- discussion in Par for further details
4326 SIS_Entry_Active := False;
4328 -- Loop to scan out declarations
4333 P_Declarative_Items (Decls, Done, In_Spec => True);
4337 -- Get rid of active SIS entry. This is set only if we have scanned a
4338 -- procedure declaration and have not found the body. We could give
4339 -- an error message, but that really would be usurping the role of
4340 -- semantic analysis (this really is a case of a missing body).
4342 SIS_Entry_Active := False;
4344 -- Test for assorted illegal declarations not diagnosed elsewhere
4346 Decl := First (Decls);
4348 while Present (Decl) loop
4349 Kind := Nkind (Decl);
4351 -- Test for body scanned, not acceptable as basic decl item
4353 if Kind = N_Subprogram_Body or else
4354 Kind = N_Package_Body or else
4355 Kind = N_Task_Body or else
4356 Kind = N_Protected_Body
4359 ("proper body not allowed in package spec", Sloc (Decl));
4361 -- Test for body stub scanned, not acceptable as basic decl item
4363 elsif Kind in N_Body_Stub then
4365 ("body stub not allowed in package spec", Sloc (Decl));
4367 elsif Kind = N_Assignment_Statement then
4369 ("assignment statement not allowed in package spec",
4377 end P_Basic_Declarative_Items;
4383 -- For proper body, see below
4384 -- For body stub, see 10.1.3
4386 -----------------------
4387 -- 3.11 Proper Body --
4388 -----------------------
4390 -- Subprogram body is parsed by P_Subprogram (6.1)
4391 -- Package body is parsed by P_Package (7.1)
4392 -- Task body is parsed by P_Task (9.1)
4393 -- Protected body is parsed by P_Protected (9.4)
4395 ------------------------------
4396 -- Set_Declaration_Expected --
4397 ------------------------------
4399 procedure Set_Declaration_Expected is
4401 Error_Msg_SC ("declaration expected");
4403 if Missing_Begin_Msg = No_Error_Msg then
4404 Missing_Begin_Msg := Get_Msg_Id;
4406 end Set_Declaration_Expected;
4408 ----------------------
4409 -- Skip_Declaration --
4410 ----------------------
4412 procedure Skip_Declaration (S : List_Id) is
4413 Dummy_Done : Boolean;
4416 P_Declarative_Items (S, Dummy_Done, False);
4417 end Skip_Declaration;
4419 -----------------------------------------
4420 -- Statement_When_Declaration_Expected --
4421 -----------------------------------------
4423 procedure Statement_When_Declaration_Expected
4429 -- Case of second occurrence of statement in one declaration sequence
4431 if Missing_Begin_Msg /= No_Error_Msg then
4433 -- In the procedure spec case, just ignore it, we only give one
4434 -- message for the first occurrence, since otherwise we may get
4435 -- horrible cascading if BODY was missing in the header line.
4440 -- In the declarative part case, take a second statement as a sure
4441 -- sign that we really have a missing BEGIN, and end the declarative
4442 -- part now. Note that the caller will fix up the first message to
4443 -- say "missing BEGIN" so that's how the error will be signalled.
4450 -- Case of first occurrence of unexpected statement
4453 -- If we are in a package spec, then give message of statement
4454 -- not allowed in package spec. This message never gets changed.
4457 Error_Msg_SC ("statement not allowed in package spec");
4459 -- If in declarative part, then we give the message complaining
4460 -- about finding a statement when a declaration is expected. This
4461 -- gets changed to a complaint about a missing BEGIN if we later
4462 -- find that no BEGIN is present.
4465 Error_Msg_SC ("statement not allowed in declarative part");
4468 -- Capture message Id. This is used for two purposes, first to
4469 -- stop multiple messages, see test above, and second, to allow
4470 -- the replacement of the message in the declarative part case.
4472 Missing_Begin_Msg := Get_Msg_Id;
4475 -- In all cases except the case in which we decided to terminate the
4476 -- declaration sequence on a second error, we scan out the statement
4477 -- and append it to the list of declarations (note that the semantics
4478 -- can handle statements in a declaration list so if we proceed to
4479 -- call the semantic phase, all will be (reasonably) well!
4481 Append_List_To (Decls, P_Sequence_Of_Statements (SS_Unco));
4483 -- Done is set to False, since we want to continue the scan of
4484 -- declarations, hoping that this statement was a temporary glitch.
4485 -- If we indeed are now in the statement part (i.e. this was a missing
4486 -- BEGIN, then it's not terrible, we will simply keep calling this
4487 -- procedure to process the statements one by one, and then finally
4488 -- hit the missing BEGIN, which will clean up the error message.
4491 end Statement_When_Declaration_Expected;