1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, 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.
944 -- Allow_Anonymous_In_95 will be True if we're parsing a
945 -- formal parameter or discriminant, which are the only places
946 -- where anonymous access types occur in Ada 95. "Formal : not
947 -- null access ..." is legal in Ada 95, whereas "Formal : not
948 -- null Named_Access_Type" is not.
950 if Ada_Version >= Ada_05
951 or else (Ada_Version >= Ada_95
952 and then Allow_Anonymous_In_95
953 and then Token = Tok_Access)
959 ("null-excluding access is an Ada 2005 extension", Not_Loc);
961 ("\unit should be compiled with -gnat05 switch", Not_Loc);
965 Error_Msg_SP ("NULL expected");
970 end P_Null_Exclusion;
972 function P_Subtype_Indication
973 (Not_Null_Present : Boolean := False) return Node_Id
978 if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
979 Type_Node := P_Subtype_Mark;
980 return P_Subtype_Indication (Type_Node, Not_Null_Present);
983 -- Check for error of using record definition and treat it nicely,
984 -- otherwise things are really messed up, so resynchronize.
986 if Token = Tok_Record then
987 Error_Msg_SC ("anonymous record definitions are not permitted");
988 Discard_Junk_Node (P_Record_Definition);
992 Error_Msg_AP ("subtype indication expected");
996 end P_Subtype_Indication;
998 -- The following function is identical except that it is called with
999 -- the subtype mark already scanned out, and it scans out the constraint
1001 -- Error recovery: can raise Error_Resync
1003 function P_Subtype_Indication
1004 (Subtype_Mark : Node_Id;
1005 Not_Null_Present : Boolean := False) return Node_Id
1007 Indic_Node : Node_Id;
1008 Constr_Node : Node_Id;
1011 Constr_Node := P_Constraint_Opt;
1013 if No (Constr_Node) then
1014 return Subtype_Mark;
1016 if Not_Null_Present then
1017 Error_Msg_SP ("constrained null-exclusion not allowed");
1020 Indic_Node := New_Node (N_Subtype_Indication, Sloc (Subtype_Mark));
1021 Set_Subtype_Mark (Indic_Node, Check_Subtype_Mark (Subtype_Mark));
1022 Set_Constraint (Indic_Node, Constr_Node);
1025 end P_Subtype_Indication;
1027 -------------------------
1028 -- 3.2.2 Subtype Mark --
1029 -------------------------
1031 -- SUBTYPE_MARK ::= subtype_NAME;
1033 -- Note: The subtype mark which appears after an IN or NOT IN
1034 -- operator is parsed by P_Range_Or_Subtype_Mark (3.5)
1036 -- Error recovery: cannot raise Error_Resync
1038 function P_Subtype_Mark return Node_Id is
1040 return P_Subtype_Mark_Resync;
1042 when Error_Resync =>
1046 -- This routine differs from P_Subtype_Mark in that it insists that an
1047 -- identifier be present, and if it is not, it raises Error_Resync.
1049 -- Error recovery: can raise Error_Resync
1051 function P_Subtype_Mark_Resync return Node_Id is
1052 Type_Node : Node_Id;
1055 if Token = Tok_Access then
1056 Error_Msg_SC ("anonymous access type definition not allowed here");
1057 Scan; -- past ACCESS
1060 if Token = Tok_Array then
1061 Error_Msg_SC ("anonymous array definition not allowed here");
1062 Discard_Junk_Node (P_Array_Type_Definition);
1066 Type_Node := P_Qualified_Simple_Name_Resync;
1068 -- Check for a subtype mark attribute. The only valid possibilities
1069 -- are 'CLASS and 'BASE. Anything else is a definite error. We may
1070 -- as well catch it here.
1072 if Token = Tok_Apostrophe then
1073 return P_Subtype_Mark_Attribute (Type_Node);
1078 end P_Subtype_Mark_Resync;
1080 -- The following function is called to scan out a subtype mark attribute.
1081 -- The caller has already scanned out the subtype mark, which is passed in
1082 -- as the argument, and has checked that the current token is apostrophe.
1084 -- Only a special subclass of attributes, called type attributes
1085 -- (see Snames package) are allowed in this syntactic position.
1087 -- Note: if the apostrophe is followed by other than an identifier, then
1088 -- the input expression is returned unchanged, and the scan pointer is
1089 -- left pointing to the apostrophe.
1091 -- Error recovery: can raise Error_Resync
1093 function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id is
1094 Attr_Node : Node_Id := Empty;
1095 Scan_State : Saved_Scan_State;
1099 Prefix := Check_Subtype_Mark (Type_Node);
1101 if Prefix = Error then
1105 -- Loop through attributes appearing (more than one can appear as for
1106 -- for example in X'Base'Class). We are at an apostrophe on entry to
1107 -- this loop, and it runs once for each attribute parsed, with
1108 -- Prefix being the current possible prefix if it is an attribute.
1111 Save_Scan_State (Scan_State); -- at Apostrophe
1112 Scan; -- past apostrophe
1114 if Token /= Tok_Identifier then
1115 Restore_Scan_State (Scan_State); -- to apostrophe
1116 return Prefix; -- no attribute after all
1118 elsif not Is_Type_Attribute_Name (Token_Name) then
1120 ("attribute & may not be used in a subtype mark", Token_Node);
1125 Make_Attribute_Reference (Prev_Token_Ptr,
1127 Attribute_Name => Token_Name);
1128 Delete_Node (Token_Node);
1129 Scan; -- past type attribute identifier
1132 exit when Token /= Tok_Apostrophe;
1133 Prefix := Attr_Node;
1136 -- Fall through here after scanning type attribute
1139 end P_Subtype_Mark_Attribute;
1141 -----------------------
1142 -- 3.2.2 Constraint --
1143 -----------------------
1145 -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
1147 -- SCALAR_CONSTRAINT ::=
1148 -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
1150 -- COMPOSITE_CONSTRAINT ::=
1151 -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
1153 -- If no constraint is present, this function returns Empty
1155 -- Error recovery: can raise Error_Resync
1157 function P_Constraint_Opt return Node_Id is
1159 if Token = Tok_Range
1160 or else Bad_Spelling_Of (Tok_Range)
1162 return P_Range_Constraint;
1164 elsif Token = Tok_Digits
1165 or else Bad_Spelling_Of (Tok_Digits)
1167 return P_Digits_Constraint;
1169 elsif Token = Tok_Delta
1170 or else Bad_Spelling_Of (Tok_Delta)
1172 return P_Delta_Constraint;
1174 elsif Token = Tok_Left_Paren then
1175 return P_Index_Or_Discriminant_Constraint;
1177 elsif Token = Tok_In then
1179 return P_Constraint_Opt;
1184 end P_Constraint_Opt;
1186 ------------------------------
1187 -- 3.2.2 Scalar Constraint --
1188 ------------------------------
1190 -- Parsed by P_Constraint_Opt (3.2.2)
1192 ---------------------------------
1193 -- 3.2.2 Composite Constraint --
1194 ---------------------------------
1196 -- Parsed by P_Constraint_Opt (3.2.2)
1198 --------------------------------------------------------
1199 -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) --
1200 --------------------------------------------------------
1202 -- This routine scans out a declaration starting with an identifier:
1204 -- OBJECT_DECLARATION ::=
1205 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1206 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1207 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1208 -- ACCESS_DEFINITION [:= EXPRESSION];
1209 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1210 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1212 -- NUMBER_DECLARATION ::=
1213 -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
1215 -- OBJECT_RENAMING_DECLARATION ::=
1216 -- DEFINING_IDENTIFIER :
1217 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
1218 -- | DEFINING_IDENTIFIER :
1219 -- ACCESS_DEFINITION renames object_NAME;
1221 -- EXCEPTION_RENAMING_DECLARATION ::=
1222 -- DEFINING_IDENTIFIER : exception renames exception_NAME;
1224 -- EXCEPTION_DECLARATION ::=
1225 -- DEFINING_IDENTIFIER_LIST : exception;
1227 -- Note that the ALIASED indication in an object declaration is
1228 -- marked by a flag in the parent node.
1230 -- The caller has checked that the initial token is an identifier
1232 -- The value returned is a list of declarations, one for each identifier
1233 -- in the list (as described in Sinfo, we always split up multiple
1234 -- declarations into the equivalent sequence of single declarations
1235 -- using the More_Ids and Prev_Ids flags to preserve the source).
1237 -- If the identifier turns out to be a probable statement rather than
1238 -- an identifier, then the scan is left pointing to the identifier and
1239 -- No_List is returned.
1241 -- Error recovery: can raise Error_Resync
1243 procedure P_Identifier_Declarations
1249 Decl_Node : Node_Id;
1250 Type_Node : Node_Id;
1251 Ident_Sloc : Source_Ptr;
1252 Scan_State : Saved_Scan_State;
1253 List_OK : Boolean := True;
1255 Init_Expr : Node_Id;
1256 Init_Loc : Source_Ptr;
1257 Con_Loc : Source_Ptr;
1258 Not_Null_Present : Boolean := False;
1260 Idents : array (Int range 1 .. 4096) of Entity_Id;
1261 -- Used to save identifiers in the identifier list. The upper bound
1262 -- of 4096 is expected to be infinite in practice, and we do not even
1263 -- bother to check if this upper bound is exceeded.
1265 Num_Idents : Nat := 1;
1266 -- Number of identifiers stored in Idents
1269 -- This procedure is called in renames cases to make sure that we do
1270 -- not have more than one identifier. If we do have more than one
1271 -- then an error message is issued (and the declaration is split into
1272 -- multiple declarations)
1274 function Token_Is_Renames return Boolean;
1275 -- Checks if current token is RENAMES, and if so, scans past it and
1276 -- returns True, otherwise returns False. Includes checking for some
1277 -- common error cases.
1279 procedure No_List is
1281 if Num_Idents > 1 then
1282 Error_Msg ("identifier list not allowed for RENAMES",
1289 function Token_Is_Renames return Boolean is
1290 At_Colon : Saved_Scan_State;
1293 if Token = Tok_Colon then
1294 Save_Scan_State (At_Colon);
1296 Check_Misspelling_Of (Tok_Renames);
1298 if Token = Tok_Renames then
1299 Error_Msg_SP ("extra "":"" ignored");
1300 Scan; -- past RENAMES
1303 Restore_Scan_State (At_Colon);
1308 Check_Misspelling_Of (Tok_Renames);
1310 if Token = Tok_Renames then
1311 Scan; -- past RENAMES
1317 end Token_Is_Renames;
1319 -- Start of processing for P_Identifier_Declarations
1322 Ident_Sloc := Token_Ptr;
1323 Save_Scan_State (Scan_State); -- at first identifier
1324 Idents (1) := P_Defining_Identifier (C_Comma_Colon);
1326 -- If we have a colon after the identifier, then we can assume that
1327 -- this is in fact a valid identifier declaration and can steam ahead.
1329 if Token = Tok_Colon then
1332 -- If we have a comma, then scan out the list of identifiers
1334 elsif Token = Tok_Comma then
1336 while Comma_Present loop
1337 Num_Idents := Num_Idents + 1;
1338 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
1341 Save_Scan_State (Scan_State); -- at colon
1344 -- If we have identifier followed by := then we assume that what is
1345 -- really meant is an assignment statement. The assignment statement
1346 -- is scanned out and added to the list of declarations. An exception
1347 -- occurs if the := is followed by the keyword constant, in which case
1348 -- we assume it was meant to be a colon.
1350 elsif Token = Tok_Colon_Equal then
1353 if Token = Tok_Constant then
1354 Error_Msg_SP ("colon expected");
1357 Restore_Scan_State (Scan_State);
1358 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
1362 -- If we have an IS keyword, then assume the TYPE keyword was missing
1364 elsif Token = Tok_Is then
1365 Restore_Scan_State (Scan_State);
1366 Append_To (Decls, P_Type_Declaration);
1370 -- Otherwise we have an error situation
1373 Restore_Scan_State (Scan_State);
1375 -- First case is possible misuse of PROTECTED in Ada 83 mode. If
1376 -- so, fix the keyword and return to scan the protected declaration.
1378 if Token_Name = Name_Protected then
1379 Check_95_Keyword (Tok_Protected, Tok_Identifier);
1380 Check_95_Keyword (Tok_Protected, Tok_Type);
1381 Check_95_Keyword (Tok_Protected, Tok_Body);
1383 if Token = Tok_Protected then
1388 -- Check misspelling possibilities. If so, correct the misspelling
1389 -- and return to scan out the resulting declaration.
1391 elsif Bad_Spelling_Of (Tok_Function)
1392 or else Bad_Spelling_Of (Tok_Procedure)
1393 or else Bad_Spelling_Of (Tok_Package)
1394 or else Bad_Spelling_Of (Tok_Pragma)
1395 or else Bad_Spelling_Of (Tok_Protected)
1396 or else Bad_Spelling_Of (Tok_Generic)
1397 or else Bad_Spelling_Of (Tok_Subtype)
1398 or else Bad_Spelling_Of (Tok_Type)
1399 or else Bad_Spelling_Of (Tok_Task)
1400 or else Bad_Spelling_Of (Tok_Use)
1401 or else Bad_Spelling_Of (Tok_For)
1406 -- Otherwise we definitely have an ordinary identifier with a junk
1407 -- token after it. Just complain that we expect a declaration, and
1408 -- skip to a semicolon
1411 Set_Declaration_Expected;
1412 Resync_Past_Semicolon;
1418 -- Come here with an identifier list and colon scanned out. We now
1419 -- build the nodes for the declarative items. One node is built for
1420 -- each identifier in the list, with the type information being
1421 -- repeated by rescanning the appropriate section of source.
1423 -- First an error check, if we have two identifiers in a row, a likely
1424 -- possibility is that the first of the identifiers is an incorrectly
1427 if Token = Tok_Identifier then
1429 SS : Saved_Scan_State;
1433 Save_Scan_State (SS);
1434 Scan; -- past initial identifier
1435 I2 := (Token = Tok_Identifier);
1436 Restore_Scan_State (SS);
1440 (Bad_Spelling_Of (Tok_Access) or else
1441 Bad_Spelling_Of (Tok_Aliased) or else
1442 Bad_Spelling_Of (Tok_Constant))
1449 -- Loop through identifiers
1454 -- Check for some cases of misused Ada 95 keywords
1456 if Token_Name = Name_Aliased then
1457 Check_95_Keyword (Tok_Aliased, Tok_Array);
1458 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
1459 Check_95_Keyword (Tok_Aliased, Tok_Constant);
1464 if Token = Tok_Constant then
1465 Con_Loc := Token_Ptr;
1466 Scan; -- past CONSTANT
1468 -- Number declaration, initialization required
1470 Init_Expr := Init_Expr_Opt;
1472 if Present (Init_Expr) then
1473 if Not_Null_Present then
1474 Error_Msg_SP ("null-exclusion not allowed in "
1475 & "numeric expression");
1478 Decl_Node := New_Node (N_Number_Declaration, Ident_Sloc);
1479 Set_Expression (Decl_Node, Init_Expr);
1481 -- Constant object declaration
1484 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1485 Set_Constant_Present (Decl_Node, True);
1487 if Token_Name = Name_Aliased then
1488 Check_95_Keyword (Tok_Aliased, Tok_Array);
1489 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
1492 if Token = Tok_Aliased then
1493 Error_Msg_SC ("ALIASED should be before CONSTANT");
1494 Scan; -- past ALIASED
1495 Set_Aliased_Present (Decl_Node, True);
1498 if Token = Tok_Array then
1499 Set_Object_Definition
1500 (Decl_Node, P_Array_Type_Definition);
1503 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1504 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1506 if Token = Tok_Access then
1507 if Ada_Version < Ada_05 then
1509 ("generalized use of anonymous access types " &
1510 "is an Ada 2005 extension");
1512 ("\unit must be compiled with -gnat05 switch");
1515 Set_Object_Definition
1516 (Decl_Node, P_Access_Definition (Not_Null_Present));
1518 Set_Object_Definition
1519 (Decl_Node, P_Subtype_Indication (Not_Null_Present));
1523 if Token = Tok_Renames then
1525 ("CONSTANT not permitted in renaming declaration",
1527 Scan; -- Past renames
1528 Discard_Junk_Node (P_Name);
1534 elsif Token = Tok_Exception then
1535 Scan; -- past EXCEPTION
1537 if Token_Is_Renames then
1540 New_Node (N_Exception_Renaming_Declaration, Ident_Sloc);
1541 Set_Name (Decl_Node, P_Qualified_Simple_Name_Resync);
1544 Decl_Node := New_Node (N_Exception_Declaration, Prev_Token_Ptr);
1547 -- Aliased case (note that an object definition is required)
1549 elsif Token = Tok_Aliased then
1550 Scan; -- past ALIASED
1551 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1552 Set_Aliased_Present (Decl_Node, True);
1554 if Token = Tok_Constant then
1555 Scan; -- past CONSTANT
1556 Set_Constant_Present (Decl_Node, True);
1559 if Token = Tok_Array then
1560 Set_Object_Definition
1561 (Decl_Node, P_Array_Type_Definition);
1564 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1565 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1567 -- Access definition (AI-406) or subtype indication
1569 if Token = Tok_Access then
1570 if Ada_Version < Ada_05 then
1572 ("generalized use of anonymous access types " &
1573 "is an Ada 2005 extension");
1575 ("\unit must be compiled with -gnat05 switch");
1578 Set_Object_Definition
1579 (Decl_Node, P_Access_Definition (Not_Null_Present));
1581 Set_Object_Definition
1582 (Decl_Node, P_Subtype_Indication (Not_Null_Present));
1588 elsif Token = Tok_Array then
1589 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1590 Set_Object_Definition (Decl_Node, P_Array_Type_Definition);
1592 -- Ada 2005 (AI-254, AI-406)
1594 elsif Token = Tok_Not then
1596 -- OBJECT_DECLARATION ::=
1597 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1598 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1599 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1600 -- ACCESS_DEFINITION [:= EXPRESSION];
1602 -- OBJECT_RENAMING_DECLARATION ::=
1603 -- DEFINING_IDENTIFIER :
1604 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
1605 -- | DEFINING_IDENTIFIER :
1606 -- ACCESS_DEFINITION renames object_NAME;
1608 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/423)
1610 if Token = Tok_Access then
1611 if Ada_Version < Ada_05 then
1613 ("generalized use of anonymous access types " &
1614 "is an Ada 2005 extension");
1615 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1618 Acc_Node := P_Access_Definition (Not_Null_Present);
1620 if Token /= Tok_Renames then
1621 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1622 Set_Object_Definition (Decl_Node, Acc_Node);
1625 Scan; -- past renames
1628 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1629 Set_Access_Definition (Decl_Node, Acc_Node);
1630 Set_Name (Decl_Node, P_Name);
1634 Type_Node := P_Subtype_Mark;
1636 -- Object renaming declaration
1638 if Token_Is_Renames then
1639 if Ada_Version < Ada_05 then
1641 ("null-exclusion not allowed in object renaming");
1644 -- Ada 2005 (AI-423): Object renaming declaration with
1645 -- a null exclusion.
1650 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1651 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1652 Set_Subtype_Mark (Decl_Node, Type_Node);
1653 Set_Name (Decl_Node, P_Name);
1656 -- Object declaration
1659 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1660 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1661 Set_Object_Definition
1663 P_Subtype_Indication (Type_Node, Not_Null_Present));
1665 -- RENAMES at this point means that we had the combination
1666 -- of a constraint on the Type_Node and renames, which is
1669 if Token_Is_Renames then
1670 Error_Msg_N ("constraint not allowed in object renaming "
1672 Constraint (Object_Definition (Decl_Node)));
1678 -- Ada 2005 (AI-230): Access Definition case
1680 elsif Token = Tok_Access then
1681 if Ada_Version < Ada_05 then
1683 ("generalized use of anonymous access types " &
1684 "is an Ada 2005 extension");
1685 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1688 Acc_Node := P_Access_Definition (Null_Exclusion_Present => False);
1690 -- Object declaration with access definition, or renaming
1692 if Token /= Tok_Renames then
1693 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1694 Set_Object_Definition (Decl_Node, Acc_Node);
1697 Scan; -- past renames
1700 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1701 Set_Access_Definition (Decl_Node, Acc_Node);
1702 Set_Name (Decl_Node, P_Name);
1705 -- Subtype indication case
1708 Type_Node := P_Subtype_Mark;
1710 -- Object renaming declaration
1712 if Token_Is_Renames then
1715 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1716 Set_Subtype_Mark (Decl_Node, Type_Node);
1717 Set_Name (Decl_Node, P_Name);
1719 -- Object declaration
1722 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1723 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1724 Set_Object_Definition
1726 P_Subtype_Indication (Type_Node, Not_Null_Present));
1728 -- RENAMES at this point means that we had the combination of
1729 -- a constraint on the Type_Node and renames, which is illegal
1731 if Token_Is_Renames then
1733 ("constraint not allowed in object renaming declaration",
1734 Constraint (Object_Definition (Decl_Node)));
1740 -- Scan out initialization, allowed only for object declaration
1742 Init_Loc := Token_Ptr;
1743 Init_Expr := Init_Expr_Opt;
1745 if Present (Init_Expr) then
1746 if Nkind (Decl_Node) = N_Object_Declaration then
1747 Set_Expression (Decl_Node, Init_Expr);
1749 Error_Msg ("initialization not allowed here", Init_Loc);
1754 Set_Defining_Identifier (Decl_Node, Idents (Ident));
1757 if Ident < Num_Idents then
1758 Set_More_Ids (Decl_Node, True);
1762 Set_Prev_Ids (Decl_Node, True);
1766 Append (Decl_Node, Decls);
1767 exit Ident_Loop when Ident = Num_Idents;
1768 Restore_Scan_State (Scan_State);
1771 end loop Ident_Loop;
1774 end P_Identifier_Declarations;
1776 -------------------------------
1777 -- 3.3.1 Object Declaration --
1778 -------------------------------
1780 -- OBJECT DECLARATION ::=
1781 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1782 -- SUBTYPE_INDICATION [:= EXPRESSION];
1783 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1784 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1785 -- | SINGLE_TASK_DECLARATION
1786 -- | SINGLE_PROTECTED_DECLARATION
1788 -- Cases starting with TASK are parsed by P_Task (9.1)
1789 -- Cases starting with PROTECTED are parsed by P_Protected (9.4)
1790 -- All other cases are parsed by P_Identifier_Declarations (3.3)
1792 -------------------------------------
1793 -- 3.3.1 Defining Identifier List --
1794 -------------------------------------
1796 -- DEFINING_IDENTIFIER_LIST ::=
1797 -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
1799 -- Always parsed by the construct in which it appears. See special
1800 -- section on "Handling of Defining Identifier Lists" in this unit.
1802 -------------------------------
1803 -- 3.3.2 Number Declaration --
1804 -------------------------------
1806 -- Parsed by P_Identifier_Declarations (3.3)
1808 -------------------------------------------------------------------------
1809 -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) --
1810 -------------------------------------------------------------------------
1812 -- DERIVED_TYPE_DEFINITION ::=
1813 -- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
1814 -- [[and INTERFACE_LIST] RECORD_EXTENSION_PART]
1816 -- PRIVATE_EXTENSION_DECLARATION ::=
1817 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
1818 -- [abstract] [limited | synchronized]
1819 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
1822 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
1824 -- The caller has already scanned out the part up to the NEW, and Token
1825 -- either contains Tok_New (or ought to, if it doesn't this procedure
1826 -- will post an appropriate "NEW expected" message).
1828 -- Note: the caller is responsible for filling in the Sloc field of
1829 -- the returned node in the private extension declaration case as
1830 -- well as the stuff relating to the discriminant part.
1832 -- Error recovery: can raise Error_Resync;
1834 function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id is
1835 Typedef_Node : Node_Id;
1836 Typedecl_Node : Node_Id;
1837 Not_Null_Present : Boolean := False;
1840 Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
1842 if Ada_Version < Ada_05
1843 and then Token = Tok_Identifier
1844 and then Token_Name = Name_Interface
1847 ("abstract interface is an Ada 2005 extension");
1848 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1853 if Token = Tok_Abstract then
1854 Error_Msg_SC ("ABSTRACT must come before NEW, not after");
1858 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1859 Set_Null_Exclusion_Present (Typedef_Node, Not_Null_Present);
1860 Set_Subtype_Indication (Typedef_Node,
1861 P_Subtype_Indication (Not_Null_Present));
1863 -- Ada 2005 (AI-251): Deal with interfaces
1865 if Token = Tok_And then
1868 if Ada_Version < Ada_05 then
1870 ("abstract interface is an Ada 2005 extension");
1871 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1874 Set_Interface_List (Typedef_Node, New_List);
1877 Append (P_Qualified_Simple_Name, Interface_List (Typedef_Node));
1878 exit when Token /= Tok_And;
1882 if Token /= Tok_With then
1883 Error_Msg_SC ("WITH expected");
1888 -- Deal with record extension, note that we assume that a WITH is
1889 -- missing in the case of "type X is new Y record ..." or in the
1890 -- case of "type X is new Y null record".
1893 or else Token = Tok_Record
1894 or else Token = Tok_Null
1896 T_With; -- past WITH or give error message
1898 if Token = Tok_Limited then
1900 ("LIMITED keyword not allowed in private extension");
1901 Scan; -- ignore LIMITED
1904 -- Private extension declaration
1906 if Token = Tok_Private then
1907 Scan; -- past PRIVATE
1909 -- Throw away the type definition node and build the type
1910 -- declaration node. Note the caller must set the Sloc,
1911 -- Discriminant_Specifications, Unknown_Discriminants_Present,
1912 -- and Defined_Identifier fields in the returned node.
1915 Make_Private_Extension_Declaration (No_Location,
1916 Defining_Identifier => Empty,
1917 Subtype_Indication => Subtype_Indication (Typedef_Node),
1918 Abstract_Present => Abstract_Present (Typedef_Node),
1919 Interface_List => Interface_List (Typedef_Node));
1921 Delete_Node (Typedef_Node);
1922 return Typedecl_Node;
1924 -- Derived type definition with record extension part
1927 Set_Record_Extension_Part (Typedef_Node, P_Record_Definition);
1928 return Typedef_Node;
1931 -- Derived type definition with no record extension part
1934 return Typedef_Node;
1936 end P_Derived_Type_Def_Or_Private_Ext_Decl;
1938 ---------------------------
1939 -- 3.5 Range Constraint --
1940 ---------------------------
1942 -- RANGE_CONSTRAINT ::= range RANGE
1944 -- The caller has checked that the initial token is RANGE
1946 -- Error recovery: cannot raise Error_Resync
1948 function P_Range_Constraint return Node_Id is
1949 Range_Node : Node_Id;
1952 Range_Node := New_Node (N_Range_Constraint, Token_Ptr);
1954 Set_Range_Expression (Range_Node, P_Range);
1956 end P_Range_Constraint;
1963 -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
1965 -- Note: the range that appears in a membership test is parsed by
1966 -- P_Range_Or_Subtype_Mark (3.5).
1968 -- Error recovery: cannot raise Error_Resync
1970 function P_Range return Node_Id is
1971 Expr_Node : Node_Id;
1972 Range_Node : Node_Id;
1975 Expr_Node := P_Simple_Expression_Or_Range_Attribute;
1977 if Expr_Form = EF_Range_Attr then
1980 elsif Token = Tok_Dot_Dot then
1981 Range_Node := New_Node (N_Range, Token_Ptr);
1982 Set_Low_Bound (Range_Node, Expr_Node);
1984 Expr_Node := P_Expression;
1985 Check_Simple_Expression (Expr_Node);
1986 Set_High_Bound (Range_Node, Expr_Node);
1989 -- Anything else is an error
1992 T_Dot_Dot; -- force missing .. message
1997 ----------------------------------
1998 -- 3.5 P_Range_Or_Subtype_Mark --
1999 ----------------------------------
2002 -- RANGE_ATTRIBUTE_REFERENCE
2003 -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
2005 -- This routine scans out the range or subtype mark that forms the right
2006 -- operand of a membership test (it is not used in any other contexts, and
2007 -- error messages are specialized with this knowledge in mind).
2009 -- Note: as documented in the Sinfo interface, although the syntax only
2010 -- allows a subtype mark, we in fact allow any simple expression to be
2011 -- returned from this routine. The semantics is responsible for issuing
2012 -- an appropriate message complaining if the argument is not a name.
2013 -- This simplifies the coding and error recovery processing in the
2014 -- parser, and in any case it is preferable not to consider this a
2015 -- syntax error and to continue with the semantic analysis.
2017 -- Error recovery: cannot raise Error_Resync
2019 function P_Range_Or_Subtype_Mark return Node_Id is
2020 Expr_Node : Node_Id;
2021 Range_Node : Node_Id;
2022 Save_Loc : Source_Ptr;
2024 -- Start of processing for P_Range_Or_Subtype_Mark
2027 -- Save location of possible junk parentheses
2029 Save_Loc := Token_Ptr;
2031 -- Scan out either a simple expression or a range (this accepts more
2032 -- than is legal here, but as explained above, we like to allow more
2033 -- with a proper diagnostic.
2035 Expr_Node := P_Simple_Expression_Or_Range_Attribute;
2039 if Expr_Form = EF_Range_Attr then
2042 -- Simple_Expression .. Simple_Expression
2044 elsif Token = Tok_Dot_Dot then
2045 Check_Simple_Expression (Expr_Node);
2046 Range_Node := New_Node (N_Range, Token_Ptr);
2047 Set_Low_Bound (Range_Node, Expr_Node);
2049 Set_High_Bound (Range_Node, P_Simple_Expression);
2052 -- Case of subtype mark (optionally qualified simple name or an
2053 -- attribute whose prefix is an optionally qualifed simple name)
2055 elsif Expr_Form = EF_Simple_Name
2056 or else Nkind (Expr_Node) = N_Attribute_Reference
2058 -- Check for error of range constraint after a subtype mark
2060 if Token = Tok_Range then
2061 Error_Msg_SC ("range constraint not allowed in membership test");
2065 -- Check for error of DIGITS or DELTA after a subtype mark
2067 elsif Token = Tok_Digits or else Token = Tok_Delta then
2069 ("accuracy definition not allowed in membership test");
2070 Scan; -- past DIGITS or DELTA
2073 -- Attribute reference, may or may not be OK, but in any case we
2076 elsif Token = Tok_Apostrophe then
2077 return P_Subtype_Mark_Attribute (Expr_Node);
2079 -- OK case of simple name, just return it
2085 -- Here we have some kind of error situation. Check for junk parens
2086 -- then return what we have, caller will deal with other errors.
2089 if Nkind (Expr_Node) in N_Subexpr
2090 and then Paren_Count (Expr_Node) /= 0
2092 Error_Msg ("|parentheses not allowed for subtype mark", Save_Loc);
2093 Set_Paren_Count (Expr_Node, 0);
2098 end P_Range_Or_Subtype_Mark;
2100 ----------------------------------------
2101 -- 3.5.1 Enumeration Type Definition --
2102 ----------------------------------------
2104 -- ENUMERATION_TYPE_DEFINITION ::=
2105 -- (ENUMERATION_LITERAL_SPECIFICATION
2106 -- {, ENUMERATION_LITERAL_SPECIFICATION})
2108 -- The caller has already scanned out the TYPE keyword
2110 -- Error recovery: can raise Error_Resync;
2112 function P_Enumeration_Type_Definition return Node_Id is
2113 Typedef_Node : Node_Id;
2116 Typedef_Node := New_Node (N_Enumeration_Type_Definition, Token_Ptr);
2117 Set_Literals (Typedef_Node, New_List);
2122 Append (P_Enumeration_Literal_Specification, Literals (Typedef_Node));
2123 exit when not Comma_Present;
2127 return Typedef_Node;
2128 end P_Enumeration_Type_Definition;
2130 ----------------------------------------------
2131 -- 3.5.1 Enumeration Literal Specification --
2132 ----------------------------------------------
2134 -- ENUMERATION_LITERAL_SPECIFICATION ::=
2135 -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
2137 -- Error recovery: can raise Error_Resync
2139 function P_Enumeration_Literal_Specification return Node_Id is
2141 if Token = Tok_Char_Literal then
2142 return P_Defining_Character_Literal;
2144 return P_Defining_Identifier (C_Comma_Right_Paren);
2146 end P_Enumeration_Literal_Specification;
2148 ---------------------------------------
2149 -- 3.5.1 Defining_Character_Literal --
2150 ---------------------------------------
2152 -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
2154 -- Error recovery: cannot raise Error_Resync
2156 -- The caller has checked that the current token is a character literal
2158 function P_Defining_Character_Literal return Node_Id is
2159 Literal_Node : Node_Id;
2162 Literal_Node := Token_Node;
2163 Change_Character_Literal_To_Defining_Character_Literal (Literal_Node);
2164 Scan; -- past character literal
2165 return Literal_Node;
2166 end P_Defining_Character_Literal;
2168 ------------------------------------
2169 -- 3.5.4 Integer Type Definition --
2170 ------------------------------------
2172 -- Parsed by P_Type_Declaration (3.2.1)
2174 -------------------------------------------
2175 -- 3.5.4 Signed Integer Type Definition --
2176 -------------------------------------------
2178 -- SIGNED_INTEGER_TYPE_DEFINITION ::=
2179 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2181 -- Normally the initial token on entry is RANGE, but in some
2182 -- error conditions, the range token was missing and control is
2183 -- passed with Token pointing to first token of the first expression.
2185 -- Error recovery: cannot raise Error_Resync
2187 function P_Signed_Integer_Type_Definition return Node_Id is
2188 Typedef_Node : Node_Id;
2189 Expr_Node : Node_Id;
2192 Typedef_Node := New_Node (N_Signed_Integer_Type_Definition, Token_Ptr);
2194 if Token = Tok_Range then
2198 Expr_Node := P_Expression;
2199 Check_Simple_Expression (Expr_Node);
2200 Set_Low_Bound (Typedef_Node, Expr_Node);
2202 Expr_Node := P_Expression;
2203 Check_Simple_Expression (Expr_Node);
2204 Set_High_Bound (Typedef_Node, Expr_Node);
2205 return Typedef_Node;
2206 end P_Signed_Integer_Type_Definition;
2208 ------------------------------------
2209 -- 3.5.4 Modular Type Definition --
2210 ------------------------------------
2212 -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
2214 -- The caller has checked that the initial token is MOD
2216 -- Error recovery: cannot raise Error_Resync
2218 function P_Modular_Type_Definition return Node_Id is
2219 Typedef_Node : Node_Id;
2222 if Ada_Version = Ada_83 then
2223 Error_Msg_SC ("(Ada 83): modular types not allowed");
2226 Typedef_Node := New_Node (N_Modular_Type_Definition, Token_Ptr);
2228 Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
2230 -- Handle mod L..R cleanly
2232 if Token = Tok_Dot_Dot then
2233 Error_Msg_SC ("range not allowed for modular type");
2235 Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
2238 return Typedef_Node;
2239 end P_Modular_Type_Definition;
2241 ---------------------------------
2242 -- 3.5.6 Real Type Definition --
2243 ---------------------------------
2245 -- Parsed by P_Type_Declaration (3.2.1)
2247 --------------------------------------
2248 -- 3.5.7 Floating Point Definition --
2249 --------------------------------------
2251 -- FLOATING_POINT_DEFINITION ::=
2252 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2254 -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
2256 -- The caller has checked that the initial token is DIGITS
2258 -- Error recovery: cannot raise Error_Resync
2260 function P_Floating_Point_Definition return Node_Id is
2261 Digits_Loc : constant Source_Ptr := Token_Ptr;
2263 Expr_Node : Node_Id;
2266 Scan; -- past DIGITS
2267 Expr_Node := P_Expression_No_Right_Paren;
2268 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2270 -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
2272 if Token = Tok_Delta then
2273 Error_Msg_SC ("DELTA must come before DIGITS");
2274 Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Digits_Loc);
2276 Set_Delta_Expression (Def_Node, P_Expression_No_Right_Paren);
2278 -- OK floating-point definition
2281 Def_Node := New_Node (N_Floating_Point_Definition, Digits_Loc);
2284 Set_Digits_Expression (Def_Node, Expr_Node);
2285 Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt);
2287 end P_Floating_Point_Definition;
2289 -------------------------------------
2290 -- 3.5.7 Real Range Specification --
2291 -------------------------------------
2293 -- REAL_RANGE_SPECIFICATION ::=
2294 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2296 -- Error recovery: cannot raise Error_Resync
2298 function P_Real_Range_Specification_Opt return Node_Id is
2299 Specification_Node : Node_Id;
2300 Expr_Node : Node_Id;
2303 if Token = Tok_Range then
2304 Specification_Node :=
2305 New_Node (N_Real_Range_Specification, Token_Ptr);
2307 Expr_Node := P_Expression_No_Right_Paren;
2308 Check_Simple_Expression (Expr_Node);
2309 Set_Low_Bound (Specification_Node, Expr_Node);
2311 Expr_Node := P_Expression_No_Right_Paren;
2312 Check_Simple_Expression (Expr_Node);
2313 Set_High_Bound (Specification_Node, Expr_Node);
2314 return Specification_Node;
2318 end P_Real_Range_Specification_Opt;
2320 -----------------------------------
2321 -- 3.5.9 Fixed Point Definition --
2322 -----------------------------------
2324 -- FIXED_POINT_DEFINITION ::=
2325 -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
2327 -- ORDINARY_FIXED_POINT_DEFINITION ::=
2328 -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION
2330 -- DECIMAL_FIXED_POINT_DEFINITION ::=
2331 -- delta static_EXPRESSION
2332 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2334 -- The caller has checked that the initial token is DELTA
2336 -- Error recovery: cannot raise Error_Resync
2338 function P_Fixed_Point_Definition return Node_Id is
2339 Delta_Node : Node_Id;
2340 Delta_Loc : Source_Ptr;
2342 Expr_Node : Node_Id;
2345 Delta_Loc := Token_Ptr;
2347 Delta_Node := P_Expression_No_Right_Paren;
2348 Check_Simple_Expression_In_Ada_83 (Delta_Node);
2350 if Token = Tok_Digits then
2351 if Ada_Version = Ada_83 then
2352 Error_Msg_SC ("(Ada 83) decimal fixed type not allowed!");
2355 Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Delta_Loc);
2356 Scan; -- past DIGITS
2357 Expr_Node := P_Expression_No_Right_Paren;
2358 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2359 Set_Digits_Expression (Def_Node, Expr_Node);
2362 Def_Node := New_Node (N_Ordinary_Fixed_Point_Definition, Delta_Loc);
2364 -- Range is required in ordinary fixed point case
2366 if Token /= Tok_Range then
2367 Error_Msg_AP ("range must be given for fixed-point type");
2372 Set_Delta_Expression (Def_Node, Delta_Node);
2373 Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt);
2375 end P_Fixed_Point_Definition;
2377 --------------------------------------------
2378 -- 3.5.9 Ordinary Fixed Point Definition --
2379 --------------------------------------------
2381 -- Parsed by P_Fixed_Point_Definition (3.5.9)
2383 -------------------------------------------
2384 -- 3.5.9 Decimal Fixed Point Definition --
2385 -------------------------------------------
2387 -- Parsed by P_Decimal_Point_Definition (3.5.9)
2389 ------------------------------
2390 -- 3.5.9 Digits Constraint --
2391 ------------------------------
2393 -- DIGITS_CONSTRAINT ::=
2394 -- digits static_EXPRESSION [RANGE_CONSTRAINT]
2396 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2398 -- The caller has checked that the initial token is DIGITS
2400 function P_Digits_Constraint return Node_Id is
2401 Constraint_Node : Node_Id;
2402 Expr_Node : Node_Id;
2405 Constraint_Node := New_Node (N_Digits_Constraint, Token_Ptr);
2406 Scan; -- past DIGITS
2407 Expr_Node := P_Expression_No_Right_Paren;
2408 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2409 Set_Digits_Expression (Constraint_Node, Expr_Node);
2411 if Token = Tok_Range then
2412 Set_Range_Constraint (Constraint_Node, P_Range_Constraint);
2415 return Constraint_Node;
2416 end P_Digits_Constraint;
2418 -----------------------------
2419 -- 3.5.9 Delta Constraint --
2420 -----------------------------
2422 -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
2424 -- Note: this is an obsolescent feature in Ada 95 (I.3)
2426 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2428 -- The caller has checked that the initial token is DELTA
2430 -- Error recovery: cannot raise Error_Resync
2432 function P_Delta_Constraint return Node_Id is
2433 Constraint_Node : Node_Id;
2434 Expr_Node : Node_Id;
2437 Constraint_Node := New_Node (N_Delta_Constraint, Token_Ptr);
2439 Expr_Node := P_Expression_No_Right_Paren;
2440 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2441 Set_Delta_Expression (Constraint_Node, Expr_Node);
2443 if Token = Tok_Range then
2444 Set_Range_Constraint (Constraint_Node, P_Range_Constraint);
2447 return Constraint_Node;
2448 end P_Delta_Constraint;
2450 --------------------------------
2451 -- 3.6 Array Type Definition --
2452 --------------------------------
2454 -- ARRAY_TYPE_DEFINITION ::=
2455 -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
2457 -- UNCONSTRAINED_ARRAY_DEFINITION ::=
2458 -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
2459 -- COMPONENT_DEFINITION
2461 -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
2463 -- CONSTRAINED_ARRAY_DEFINITION ::=
2464 -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
2465 -- COMPONENT_DEFINITION
2467 -- DISCRETE_SUBTYPE_DEFINITION ::=
2468 -- DISCRETE_SUBTYPE_INDICATION | RANGE
2470 -- COMPONENT_DEFINITION ::=
2471 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
2473 -- The caller has checked that the initial token is ARRAY
2475 -- Error recovery: can raise Error_Resync
2477 function P_Array_Type_Definition return Node_Id is
2478 Array_Loc : Source_Ptr;
2479 CompDef_Node : Node_Id;
2481 Not_Null_Present : Boolean := False;
2482 Subs_List : List_Id;
2483 Scan_State : Saved_Scan_State;
2484 Aliased_Present : Boolean := False;
2487 Array_Loc := Token_Ptr;
2489 Subs_List := New_List;
2492 -- It's quite tricky to disentangle these two possibilities, so we do
2493 -- a prescan to determine which case we have and then reset the scan.
2494 -- The prescan skips past possible subtype mark tokens.
2496 Save_Scan_State (Scan_State); -- just after paren
2498 while Token in Token_Class_Desig or else
2499 Token = Tok_Dot or else
2500 Token = Tok_Apostrophe -- because of 'BASE, 'CLASS
2505 -- If we end up on RANGE <> then we have the unconstrained case. We
2506 -- will also allow the RANGE to be omitted, just to improve error
2507 -- handling for a case like array (integer <>) of integer;
2509 Scan; -- past possible RANGE or <>
2511 if (Prev_Token = Tok_Range and then Token = Tok_Box) or else
2512 Prev_Token = Tok_Box
2514 Def_Node := New_Node (N_Unconstrained_Array_Definition, Array_Loc);
2515 Restore_Scan_State (Scan_State); -- to first subtype mark
2518 Append (P_Subtype_Mark_Resync, Subs_List);
2521 exit when Token = Tok_Right_Paren or else Token = Tok_Of;
2525 Set_Subtype_Marks (Def_Node, Subs_List);
2528 Def_Node := New_Node (N_Constrained_Array_Definition, Array_Loc);
2529 Restore_Scan_State (Scan_State); -- to first discrete range
2532 Append (P_Discrete_Subtype_Definition, Subs_List);
2533 exit when not Comma_Present;
2536 Set_Discrete_Subtype_Definitions (Def_Node, Subs_List);
2542 CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
2544 if Token_Name = Name_Aliased then
2545 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
2548 if Token = Tok_Aliased then
2549 Aliased_Present := True;
2550 Scan; -- past ALIASED
2553 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254)
2555 -- Ada 2005 (AI-230): Access Definition case
2557 if Token = Tok_Access then
2558 if Ada_Version < Ada_05 then
2560 ("generalized use of anonymous access types " &
2561 "is an Ada 2005 extension");
2562 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
2565 if Aliased_Present then
2566 Error_Msg_SP ("ALIASED not allowed here");
2569 Set_Subtype_Indication (CompDef_Node, Empty);
2570 Set_Aliased_Present (CompDef_Node, False);
2571 Set_Access_Definition (CompDef_Node,
2572 P_Access_Definition (Not_Null_Present));
2575 Set_Access_Definition (CompDef_Node, Empty);
2576 Set_Aliased_Present (CompDef_Node, Aliased_Present);
2577 Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
2578 Set_Subtype_Indication (CompDef_Node,
2579 P_Subtype_Indication (Not_Null_Present));
2582 Set_Component_Definition (Def_Node, CompDef_Node);
2585 end P_Array_Type_Definition;
2587 -----------------------------------------
2588 -- 3.6 Unconstrained Array Definition --
2589 -----------------------------------------
2591 -- Parsed by P_Array_Type_Definition (3.6)
2593 ---------------------------------------
2594 -- 3.6 Constrained Array Definition --
2595 ---------------------------------------
2597 -- Parsed by P_Array_Type_Definition (3.6)
2599 --------------------------------------
2600 -- 3.6 Discrete Subtype Definition --
2601 --------------------------------------
2603 -- DISCRETE_SUBTYPE_DEFINITION ::=
2604 -- discrete_SUBTYPE_INDICATION | RANGE
2606 -- Note: the discrete subtype definition appearing in a constrained
2607 -- array definition is parsed by P_Array_Type_Definition (3.6)
2609 -- Error recovery: cannot raise Error_Resync
2611 function P_Discrete_Subtype_Definition return Node_Id is
2613 -- The syntax of a discrete subtype definition is identical to that
2614 -- of a discrete range, so we simply share the same parsing code.
2616 return P_Discrete_Range;
2617 end P_Discrete_Subtype_Definition;
2619 -------------------------------
2620 -- 3.6 Component Definition --
2621 -------------------------------
2623 -- For the array case, parsed by P_Array_Type_Definition (3.6)
2624 -- For the record case, parsed by P_Component_Declaration (3.8)
2626 -----------------------------
2627 -- 3.6.1 Index Constraint --
2628 -----------------------------
2630 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2632 ---------------------------
2633 -- 3.6.1 Discrete Range --
2634 ---------------------------
2636 -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
2638 -- The possible forms for a discrete range are:
2640 -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2)
2641 -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2)
2642 -- Range_Attribute (RANGE, 3.5)
2643 -- Simple_Expression .. Simple_Expression (RANGE, 3.5)
2645 -- Error recovery: cannot raise Error_Resync
2647 function P_Discrete_Range return Node_Id is
2648 Expr_Node : Node_Id;
2649 Range_Node : Node_Id;
2652 Expr_Node := P_Simple_Expression_Or_Range_Attribute;
2654 if Expr_Form = EF_Range_Attr then
2657 elsif Token = Tok_Range then
2658 if Expr_Form /= EF_Simple_Name then
2659 Error_Msg_SC ("range must be preceded by subtype mark");
2662 return P_Subtype_Indication (Expr_Node);
2664 -- Check Expression .. Expression case
2666 elsif Token = Tok_Dot_Dot then
2667 Range_Node := New_Node (N_Range, Token_Ptr);
2668 Set_Low_Bound (Range_Node, Expr_Node);
2670 Expr_Node := P_Expression;
2671 Check_Simple_Expression (Expr_Node);
2672 Set_High_Bound (Range_Node, Expr_Node);
2675 -- Otherwise we must have a subtype mark
2677 elsif Expr_Form = EF_Simple_Name then
2680 -- If incorrect, complain that we expect ..
2686 end P_Discrete_Range;
2688 ----------------------------
2689 -- 3.7 Discriminant Part --
2690 ----------------------------
2692 -- DISCRIMINANT_PART ::=
2693 -- UNKNOWN_DISCRIMINANT_PART
2694 -- | KNOWN_DISCRIMINANT_PART
2696 -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
2697 -- or P_Unknown_Discriminant_Part (3.7), since we know which we want.
2699 ------------------------------------
2700 -- 3.7 Unknown Discriminant Part --
2701 ------------------------------------
2703 -- UNKNOWN_DISCRIMINANT_PART ::= (<>)
2705 -- If no unknown discriminant part is present, then False is returned,
2706 -- otherwise the unknown discriminant is scanned out and True is returned.
2708 -- Error recovery: cannot raise Error_Resync
2710 function P_Unknown_Discriminant_Part_Opt return Boolean is
2711 Scan_State : Saved_Scan_State;
2714 if Token /= Tok_Left_Paren then
2718 Save_Scan_State (Scan_State);
2719 Scan; -- past the left paren
2721 if Token = Tok_Box then
2722 if Ada_Version = Ada_83 then
2723 Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!");
2726 Scan; -- past the box
2727 T_Right_Paren; -- must be followed by right paren
2731 Restore_Scan_State (Scan_State);
2735 end P_Unknown_Discriminant_Part_Opt;
2737 ----------------------------------
2738 -- 3.7 Known Discriminant Part --
2739 ----------------------------------
2741 -- KNOWN_DISCRIMINANT_PART ::=
2742 -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
2744 -- DISCRIMINANT_SPECIFICATION ::=
2745 -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
2746 -- [:= DEFAULT_EXPRESSION]
2747 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
2748 -- [:= DEFAULT_EXPRESSION]
2750 -- If no known discriminant part is present, then No_List is returned
2752 -- Error recovery: cannot raise Error_Resync
2754 function P_Known_Discriminant_Part_Opt return List_Id is
2755 Specification_Node : Node_Id;
2756 Specification_List : List_Id;
2757 Ident_Sloc : Source_Ptr;
2758 Scan_State : Saved_Scan_State;
2760 Not_Null_Present : Boolean;
2763 Idents : array (Int range 1 .. 4096) of Entity_Id;
2764 -- This array holds the list of defining identifiers. The upper bound
2765 -- of 4096 is intended to be essentially infinite, and we do not even
2766 -- bother to check for it being exceeded.
2769 if Token = Tok_Left_Paren then
2770 Specification_List := New_List;
2772 P_Pragmas_Misplaced;
2774 Specification_Loop : loop
2776 Ident_Sloc := Token_Ptr;
2777 Idents (1) := P_Defining_Identifier (C_Comma_Colon);
2780 while Comma_Present loop
2781 Num_Idents := Num_Idents + 1;
2782 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
2787 -- If there are multiple identifiers, we repeatedly scan the
2788 -- type and initialization expression information by resetting
2789 -- the scan pointer (so that we get completely separate trees
2790 -- for each occurrence).
2792 if Num_Idents > 1 then
2793 Save_Scan_State (Scan_State);
2796 -- Loop through defining identifiers in list
2800 Specification_Node :=
2801 New_Node (N_Discriminant_Specification, Ident_Sloc);
2802 Set_Defining_Identifier (Specification_Node, Idents (Ident));
2803 Not_Null_Present := -- Ada 2005 (AI-231, AI-447)
2804 P_Null_Exclusion (Allow_Anonymous_In_95 => True);
2806 if Token = Tok_Access then
2807 if Ada_Version = Ada_83 then
2809 ("(Ada 83) access discriminant not allowed!");
2812 Set_Discriminant_Type
2813 (Specification_Node,
2814 P_Access_Definition (Not_Null_Present));
2817 Set_Discriminant_Type
2818 (Specification_Node, P_Subtype_Mark);
2820 Set_Null_Exclusion_Present -- Ada 2005 (AI-231)
2821 (Specification_Node, Not_Null_Present);
2825 (Specification_Node, Init_Expr_Opt (True));
2828 Set_Prev_Ids (Specification_Node, True);
2831 if Ident < Num_Idents then
2832 Set_More_Ids (Specification_Node, True);
2835 Append (Specification_Node, Specification_List);
2836 exit Ident_Loop when Ident = Num_Idents;
2838 Restore_Scan_State (Scan_State);
2839 end loop Ident_Loop;
2841 exit Specification_Loop when Token /= Tok_Semicolon;
2843 P_Pragmas_Misplaced;
2844 end loop Specification_Loop;
2847 return Specification_List;
2852 end P_Known_Discriminant_Part_Opt;
2854 -------------------------------------
2855 -- 3.7 DIscriminant Specification --
2856 -------------------------------------
2858 -- Parsed by P_Known_Discriminant_Part_Opt (3.7)
2860 -----------------------------
2861 -- 3.7 Default Expression --
2862 -----------------------------
2864 -- Always parsed (simply as an Expression) by the parent construct
2866 ------------------------------------
2867 -- 3.7.1 Discriminant Constraint --
2868 ------------------------------------
2870 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2872 --------------------------------------------------------
2873 -- 3.7.1 Index or Discriminant Constraint (also 3.6) --
2874 --------------------------------------------------------
2876 -- DISCRIMINANT_CONSTRAINT ::=
2877 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
2879 -- DISCRIMINANT_ASSOCIATION ::=
2880 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2883 -- This routine parses either an index or a discriminant constraint. As
2884 -- is clear from the above grammar, it is often possible to clearly
2885 -- determine which of the two possibilities we have, but there are
2886 -- cases (those in which we have a series of expressions of the same
2887 -- syntactic form as subtype indications), where we cannot tell. Since
2888 -- this means that in any case the semantic phase has to distinguish
2889 -- between the two, there is not much point in the parser trying to
2890 -- distinguish even those cases where the difference is clear. In any
2891 -- case, if we have a situation like:
2893 -- (A => 123, 235 .. 500)
2895 -- it is not clear which of the two items is the wrong one, better to
2896 -- let the semantic phase give a clear message. Consequently, this
2897 -- routine in general returns a list of items which can be either
2898 -- discrete ranges or discriminant associations.
2900 -- The caller has checked that the initial token is a left paren
2902 -- Error recovery: can raise Error_Resync
2904 function P_Index_Or_Discriminant_Constraint return Node_Id is
2905 Scan_State : Saved_Scan_State;
2906 Constr_Node : Node_Id;
2907 Constr_List : List_Id;
2908 Expr_Node : Node_Id;
2909 Result_Node : Node_Id;
2912 Result_Node := New_Node (N_Index_Or_Discriminant_Constraint, Token_Ptr);
2914 Constr_List := New_List;
2915 Set_Constraints (Result_Node, Constr_List);
2917 -- The two syntactic forms are a little mixed up, so what we are doing
2918 -- here is looking at the first entry to determine which case we have
2920 -- A discriminant constraint is a list of discriminant associations,
2921 -- which have one of the following possible forms:
2925 -- Id | Id | .. | Id => Expression
2927 -- An index constraint is a list of discrete ranges which have one
2928 -- of the following possible forms:
2931 -- Subtype_Mark range Range
2933 -- Simple_Expression .. Simple_Expression
2935 -- Loop through discriminants in list
2938 -- Check cases of Id => Expression or Id | Id => Expression
2940 if Token = Tok_Identifier then
2941 Save_Scan_State (Scan_State); -- at Id
2944 if Token = Tok_Arrow or else Token = Tok_Vertical_Bar then
2945 Restore_Scan_State (Scan_State); -- to Id
2946 Append (P_Discriminant_Association, Constr_List);
2949 Restore_Scan_State (Scan_State); -- to Id
2953 -- Otherwise scan out an expression and see what we have got
2955 Expr_Node := P_Expression_Or_Range_Attribute;
2957 if Expr_Form = EF_Range_Attr then
2958 Append (Expr_Node, Constr_List);
2960 elsif Token = Tok_Range then
2961 if Expr_Form /= EF_Simple_Name then
2962 Error_Msg_SC ("subtype mark required before RANGE");
2965 Append (P_Subtype_Indication (Expr_Node), Constr_List);
2968 -- Check Simple_Expression .. Simple_Expression case
2970 elsif Token = Tok_Dot_Dot then
2971 Check_Simple_Expression (Expr_Node);
2972 Constr_Node := New_Node (N_Range, Token_Ptr);
2973 Set_Low_Bound (Constr_Node, Expr_Node);
2975 Expr_Node := P_Expression;
2976 Check_Simple_Expression (Expr_Node);
2977 Set_High_Bound (Constr_Node, Expr_Node);
2978 Append (Constr_Node, Constr_List);
2981 -- Case of an expression which could be either form
2984 Append (Expr_Node, Constr_List);
2988 -- Here with a single entry scanned
2991 exit when not Comma_Present;
2997 end P_Index_Or_Discriminant_Constraint;
2999 -------------------------------------
3000 -- 3.7.1 Discriminant Association --
3001 -------------------------------------
3003 -- DISCRIMINANT_ASSOCIATION ::=
3004 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
3007 -- This routine is used only when the name list is present and the caller
3008 -- has already checked this (by scanning ahead and repositioning the
3011 -- Error_Recovery: cannot raise Error_Resync;
3013 function P_Discriminant_Association return Node_Id is
3014 Discr_Node : Node_Id;
3015 Names_List : List_Id;
3016 Ident_Sloc : Source_Ptr;
3019 Ident_Sloc := Token_Ptr;
3020 Names_List := New_List;
3023 Append (P_Identifier (C_Vertical_Bar_Arrow), Names_List);
3024 exit when Token /= Tok_Vertical_Bar;
3028 Discr_Node := New_Node (N_Discriminant_Association, Ident_Sloc);
3029 Set_Selector_Names (Discr_Node, Names_List);
3031 Set_Expression (Discr_Node, P_Expression);
3033 end P_Discriminant_Association;
3035 ---------------------------------
3036 -- 3.8 Record Type Definition --
3037 ---------------------------------
3039 -- RECORD_TYPE_DEFINITION ::=
3040 -- [[abstract] tagged] [limited] RECORD_DEFINITION
3042 -- There is no node in the tree for a record type definition. Instead
3043 -- a record definition node appears, with possible Abstract_Present,
3044 -- Tagged_Present, and Limited_Present flags set appropriately.
3046 ----------------------------
3047 -- 3.8 Record Definition --
3048 ----------------------------
3050 -- RECORD_DEFINITION ::=
3056 -- Note: in the case where a record definition node is used to represent
3057 -- a record type definition, the caller sets the Tagged_Present and
3058 -- Limited_Present flags in the resulting N_Record_Definition node as
3061 -- Note that the RECORD token at the start may be missing in certain
3062 -- error situations, so this function is expected to post the error
3064 -- Error recovery: can raise Error_Resync
3066 function P_Record_Definition return Node_Id is
3070 Rec_Node := New_Node (N_Record_Definition, Token_Ptr);
3074 if Token = Tok_Null then
3077 Set_Null_Present (Rec_Node, True);
3079 -- Case starting with RECORD keyword. Build scope stack entry. For the
3080 -- column, we use the first non-blank character on the line, to deal
3081 -- with situations such as:
3087 -- which is not official RM indentation, but is not uncommon usage
3091 Scope.Table (Scope.Last).Etyp := E_Record;
3092 Scope.Table (Scope.Last).Ecol := Start_Column;
3093 Scope.Table (Scope.Last).Sloc := Token_Ptr;
3094 Scope.Table (Scope.Last).Labl := Error;
3095 Scope.Table (Scope.Last).Junk := (Token /= Tok_Record);
3099 Set_Component_List (Rec_Node, P_Component_List);
3102 exit when Check_End;
3103 Discard_Junk_Node (P_Component_List);
3108 end P_Record_Definition;
3110 -------------------------
3111 -- 3.8 Component List --
3112 -------------------------
3114 -- COMPONENT_LIST ::=
3115 -- COMPONENT_ITEM {COMPONENT_ITEM}
3116 -- | {COMPONENT_ITEM} VARIANT_PART
3119 -- Error recovery: cannot raise Error_Resync
3121 function P_Component_List return Node_Id is
3122 Component_List_Node : Node_Id;
3123 Decls_List : List_Id;
3124 Scan_State : Saved_Scan_State;
3127 Component_List_Node := New_Node (N_Component_List, Token_Ptr);
3128 Decls_List := New_List;
3130 if Token = Tok_Null then
3133 P_Pragmas_Opt (Decls_List);
3134 Set_Null_Present (Component_List_Node, True);
3135 return Component_List_Node;
3138 P_Pragmas_Opt (Decls_List);
3140 if Token /= Tok_Case then
3141 Component_Scan_Loop : loop
3142 P_Component_Items (Decls_List);
3143 P_Pragmas_Opt (Decls_List);
3145 exit Component_Scan_Loop when Token = Tok_End
3146 or else Token = Tok_Case
3147 or else Token = Tok_When;
3149 -- We are done if we do not have an identifier. However, if
3150 -- we have a misspelled reserved identifier that is in a column
3151 -- to the right of the record definition, we will treat it as
3152 -- an identifier. It turns out to be too dangerous in practice
3153 -- to accept such a mis-spelled identifier which does not have
3154 -- this additional clue that confirms the incorrect spelling.
3156 if Token /= Tok_Identifier then
3157 if Start_Column > Scope.Table (Scope.Last).Ecol
3158 and then Is_Reserved_Identifier
3160 Save_Scan_State (Scan_State); -- at reserved id
3161 Scan; -- possible reserved id
3163 if Token = Tok_Comma or else Token = Tok_Colon then
3164 Restore_Scan_State (Scan_State);
3165 Scan_Reserved_Identifier (Force_Msg => True);
3167 -- Note reserved identifier used as field name after
3168 -- all because not followed by colon or comma
3171 Restore_Scan_State (Scan_State);
3172 exit Component_Scan_Loop;
3175 -- Non-identifier that definitely was not reserved id
3178 exit Component_Scan_Loop;
3181 end loop Component_Scan_Loop;
3184 if Token = Tok_Case then
3185 Set_Variant_Part (Component_List_Node, P_Variant_Part);
3187 -- Check for junk after variant part
3189 if Token = Tok_Identifier then
3190 Save_Scan_State (Scan_State);
3191 Scan; -- past identifier
3193 if Token = Tok_Colon then
3194 Restore_Scan_State (Scan_State);
3195 Error_Msg_SC ("component may not follow variant part");
3196 Discard_Junk_Node (P_Component_List);
3198 elsif Token = Tok_Case then
3199 Restore_Scan_State (Scan_State);
3200 Error_Msg_SC ("only one variant part allowed in a record");
3201 Discard_Junk_Node (P_Component_List);
3204 Restore_Scan_State (Scan_State);
3210 Set_Component_Items (Component_List_Node, Decls_List);
3211 return Component_List_Node;
3212 end P_Component_List;
3214 -------------------------
3215 -- 3.8 Component Item --
3216 -------------------------
3218 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
3220 -- COMPONENT_DECLARATION ::=
3221 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
3222 -- [:= DEFAULT_EXPRESSION];
3224 -- COMPONENT_DEFINITION ::=
3225 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
3227 -- Error recovery: cannot raise Error_Resync, if an error occurs,
3228 -- the scan is positioned past the following semicolon.
3230 -- Note: we do not yet allow representation clauses to appear as component
3231 -- items, do we need to add this capability sometime in the future ???
3233 procedure P_Component_Items (Decls : List_Id) is
3234 Aliased_Present : Boolean := False;
3235 CompDef_Node : Node_Id;
3236 Decl_Node : Node_Id;
3237 Scan_State : Saved_Scan_State;
3238 Not_Null_Present : Boolean := False;
3241 Ident_Sloc : Source_Ptr;
3243 Idents : array (Int range 1 .. 4096) of Entity_Id;
3244 -- This array holds the list of defining identifiers. The upper bound
3245 -- of 4096 is intended to be essentially infinite, and we do not even
3246 -- bother to check for it being exceeded.
3249 if Token /= Tok_Identifier then
3250 Error_Msg_SC ("component declaration expected");
3251 Resync_Past_Semicolon;
3255 Ident_Sloc := Token_Ptr;
3256 Idents (1) := P_Defining_Identifier (C_Comma_Colon);
3259 while Comma_Present loop
3260 Num_Idents := Num_Idents + 1;
3261 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
3266 -- If there are multiple identifiers, we repeatedly scan the
3267 -- type and initialization expression information by resetting
3268 -- the scan pointer (so that we get completely separate trees
3269 -- for each occurrence).
3271 if Num_Idents > 1 then
3272 Save_Scan_State (Scan_State);
3275 -- Loop through defining identifiers in list
3280 -- The following block is present to catch Error_Resync
3281 -- which causes the parse to be reset past the semicolon
3284 Decl_Node := New_Node (N_Component_Declaration, Ident_Sloc);
3285 Set_Defining_Identifier (Decl_Node, Idents (Ident));
3287 if Token = Tok_Constant then
3288 Error_Msg_SC ("constant components are not permitted");
3292 CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
3294 if Token_Name = Name_Aliased then
3295 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
3298 if Token = Tok_Aliased then
3299 Aliased_Present := True;
3300 Scan; -- past ALIASED
3303 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254)
3305 -- Ada 2005 (AI-230): Access Definition case
3307 if Token = Tok_Access then
3308 if Ada_Version < Ada_05 then
3310 ("generalized use of anonymous access types " &
3311 "is an Ada 2005 extension");
3312 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
3315 if Aliased_Present then
3316 Error_Msg_SP ("ALIASED not allowed here");
3319 Set_Subtype_Indication (CompDef_Node, Empty);
3320 Set_Aliased_Present (CompDef_Node, False);
3321 Set_Access_Definition (CompDef_Node,
3322 P_Access_Definition (Not_Null_Present));
3325 Set_Access_Definition (CompDef_Node, Empty);
3326 Set_Aliased_Present (CompDef_Node, Aliased_Present);
3327 Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
3329 if Token = Tok_Array then
3331 ("anonymous arrays not allowed as components");
3335 Set_Subtype_Indication (CompDef_Node,
3336 P_Subtype_Indication (Not_Null_Present));
3339 Set_Component_Definition (Decl_Node, CompDef_Node);
3340 Set_Expression (Decl_Node, Init_Expr_Opt);
3343 Set_Prev_Ids (Decl_Node, True);
3346 if Ident < Num_Idents then
3347 Set_More_Ids (Decl_Node, True);
3350 Append (Decl_Node, Decls);
3353 when Error_Resync =>
3354 if Token /= Tok_End then
3355 Resync_Past_Semicolon;
3359 exit Ident_Loop when Ident = Num_Idents;
3361 Restore_Scan_State (Scan_State);
3363 end loop Ident_Loop;
3366 end P_Component_Items;
3368 --------------------------------
3369 -- 3.8 Component Declaration --
3370 --------------------------------
3372 -- Parsed by P_Component_Items (3.8)
3374 -------------------------
3375 -- 3.8.1 Variant Part --
3376 -------------------------
3379 -- case discriminant_DIRECT_NAME is
3384 -- The caller has checked that the initial token is CASE
3386 -- Error recovery: cannot raise Error_Resync
3388 function P_Variant_Part return Node_Id is
3389 Variant_Part_Node : Node_Id;
3390 Variants_List : List_Id;
3391 Case_Node : Node_Id;
3394 Variant_Part_Node := New_Node (N_Variant_Part, Token_Ptr);
3396 Scope.Table (Scope.Last).Etyp := E_Case;
3397 Scope.Table (Scope.Last).Sloc := Token_Ptr;
3398 Scope.Table (Scope.Last).Ecol := Start_Column;
3401 Case_Node := P_Expression;
3402 Set_Name (Variant_Part_Node, Case_Node);
3404 if Nkind (Case_Node) /= N_Identifier then
3405 Set_Name (Variant_Part_Node, Error);
3406 Error_Msg ("discriminant name expected", Sloc (Case_Node));
3410 Variants_List := New_List;
3411 P_Pragmas_Opt (Variants_List);
3413 -- Test missing variant
3415 if Token = Tok_End then
3416 Error_Msg_BC ("WHEN expected (must have at least one variant)");
3418 Append (P_Variant, Variants_List);
3421 -- Loop through variants, note that we allow if in place of when,
3422 -- this error will be detected and handled in P_Variant.
3425 P_Pragmas_Opt (Variants_List);
3427 if Token /= Tok_When
3428 and then Token /= Tok_If
3429 and then Token /= Tok_Others
3431 exit when Check_End;
3434 Append (P_Variant, Variants_List);
3437 Set_Variants (Variant_Part_Node, Variants_List);
3438 return Variant_Part_Node;
3441 --------------------
3443 --------------------
3446 -- when DISCRETE_CHOICE_LIST =>
3449 -- Error recovery: cannot raise Error_Resync
3451 -- The initial token on entry is either WHEN, IF or OTHERS
3453 function P_Variant return Node_Id is
3454 Variant_Node : Node_Id;
3457 -- Special check to recover nicely from use of IF in place of WHEN
3459 if Token = Tok_If then
3466 Variant_Node := New_Node (N_Variant, Prev_Token_Ptr);
3467 Set_Discrete_Choices (Variant_Node, P_Discrete_Choice_List);
3469 Set_Component_List (Variant_Node, P_Component_List);
3470 return Variant_Node;
3473 ---------------------------------
3474 -- 3.8.1 Discrete Choice List --
3475 ---------------------------------
3477 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
3479 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
3481 -- Note: in Ada 83, the expression must be a simple expression
3483 -- Error recovery: cannot raise Error_Resync
3485 function P_Discrete_Choice_List return List_Id is
3487 Expr_Node : Node_Id;
3488 Choice_Node : Node_Id;
3491 Choices := New_List;
3494 if Token = Tok_Others then
3495 Append (New_Node (N_Others_Choice, Token_Ptr), Choices);
3496 Scan; -- past OTHERS
3500 Expr_Node := No_Right_Paren (P_Expression_Or_Range_Attribute);
3502 if Token = Tok_Colon
3503 and then Nkind (Expr_Node) = N_Identifier
3505 Error_Msg_SP ("label not permitted in this context");
3508 elsif Expr_Form = EF_Range_Attr then
3509 Append (Expr_Node, Choices);
3511 elsif Token = Tok_Dot_Dot then
3512 Check_Simple_Expression (Expr_Node);
3513 Choice_Node := New_Node (N_Range, Token_Ptr);
3514 Set_Low_Bound (Choice_Node, Expr_Node);
3516 Expr_Node := P_Expression_No_Right_Paren;
3517 Check_Simple_Expression (Expr_Node);
3518 Set_High_Bound (Choice_Node, Expr_Node);
3519 Append (Choice_Node, Choices);
3521 elsif Expr_Form = EF_Simple_Name then
3522 if Token = Tok_Range then
3523 Append (P_Subtype_Indication (Expr_Node), Choices);
3525 elsif Token in Token_Class_Consk then
3527 ("the only constraint allowed here " &
3528 "is a range constraint");
3529 Discard_Junk_Node (P_Constraint_Opt);
3530 Append (Expr_Node, Choices);
3533 Append (Expr_Node, Choices);
3537 Check_Simple_Expression_In_Ada_83 (Expr_Node);
3538 Append (Expr_Node, Choices);
3542 when Error_Resync =>
3548 if Token = Tok_Comma then
3549 Error_Msg_SC (""","" should be ""'|""");
3551 exit when Token /= Tok_Vertical_Bar;
3554 Scan; -- past | or comma
3558 end P_Discrete_Choice_List;
3560 ----------------------------
3561 -- 3.8.1 Discrete Choice --
3562 ----------------------------
3564 -- Parsed by P_Discrete_Choice_List (3.8.1)
3566 ----------------------------------
3567 -- 3.9.1 Record Extension Part --
3568 ----------------------------------
3570 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
3572 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
3574 --------------------------------------
3575 -- 3.9.4 Interface Type Definition --
3576 --------------------------------------
3578 -- INTERFACE_TYPE_DEFINITION ::=
3579 -- [limited | task | protected | synchronized] interface
3580 -- [and INTERFACE_LIST]
3582 -- Error recovery: cannot raise Error_Resync
3584 function P_Interface_Type_Definition
3585 (Abstract_Present : Boolean) return Node_Id
3587 Typedef_Node : Node_Id;
3590 if Ada_Version < Ada_05 then
3591 Error_Msg_SP ("abstract interface is an Ada 2005 extension");
3592 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
3595 if Abstract_Present then
3596 Error_Msg_SP ("ABSTRACT not allowed in interface type definition " &
3597 "('R'M' 3.9.4(2/2))");
3600 Scan; -- past INTERFACE
3602 -- Ada 2005 (AI-345): In case of interfaces with a null list of
3603 -- interfaces we build a record_definition node.
3605 if Token = Tok_Semicolon then
3606 Typedef_Node := New_Node (N_Record_Definition, Token_Ptr);
3608 Set_Abstract_Present (Typedef_Node);
3609 Set_Tagged_Present (Typedef_Node);
3610 Set_Null_Present (Typedef_Node);
3611 Set_Interface_Present (Typedef_Node);
3613 -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have
3614 -- a list of interfaces we build a derived_type_definition node. This
3615 -- simplifies the semantic analysis (and hence further mainteinance)
3618 if Token /= Tok_And then
3619 Error_Msg_AP ("AND expected");
3624 Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
3626 Set_Abstract_Present (Typedef_Node);
3627 Set_Interface_Present (Typedef_Node);
3628 Set_Subtype_Indication (Typedef_Node, P_Qualified_Simple_Name);
3630 Set_Record_Extension_Part (Typedef_Node,
3631 New_Node (N_Record_Definition, Token_Ptr));
3632 Set_Null_Present (Record_Extension_Part (Typedef_Node));
3634 if Token = Tok_And then
3635 Set_Interface_List (Typedef_Node, New_List);
3639 Append (P_Qualified_Simple_Name,
3640 Interface_List (Typedef_Node));
3641 exit when Token /= Tok_And;
3647 return Typedef_Node;
3648 end P_Interface_Type_Definition;
3650 ----------------------------------
3651 -- 3.10 Access Type Definition --
3652 ----------------------------------
3654 -- ACCESS_TYPE_DEFINITION ::=
3655 -- ACCESS_TO_OBJECT_DEFINITION
3656 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3658 -- ACCESS_TO_OBJECT_DEFINITION ::=
3659 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
3661 -- GENERAL_ACCESS_MODIFIER ::= all | constant
3663 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3664 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3665 -- | [NULL_EXCLUSION] access [protected] function
3666 -- PARAMETER_AND_RESULT_PROFILE
3668 -- PARAMETER_PROFILE ::= [FORMAL_PART]
3670 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
3672 -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already
3673 -- parsed the null_exclusion part and has also removed the ACCESS token;
3674 -- otherwise the caller has just checked that the initial token is ACCESS
3676 -- Error recovery: can raise Error_Resync
3678 function P_Access_Type_Definition
3679 (Header_Already_Parsed : Boolean := False) return Node_Id
3681 Access_Loc : constant Source_Ptr := Token_Ptr;
3682 Prot_Flag : Boolean;
3683 Not_Null_Present : Boolean := False;
3684 Type_Def_Node : Node_Id;
3685 Result_Not_Null : Boolean;
3686 Result_Node : Node_Id;
3688 procedure Check_Junk_Subprogram_Name;
3689 -- Used in access to subprogram definition cases to check for an
3690 -- identifier or operator symbol that does not belong.
3692 --------------------------------
3693 -- Check_Junk_Subprogram_Name --
3694 --------------------------------
3696 procedure Check_Junk_Subprogram_Name is
3697 Saved_State : Saved_Scan_State;
3700 if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
3701 Save_Scan_State (Saved_State);
3702 Scan; -- past possible junk subprogram name
3704 if Token = Tok_Left_Paren or else Token = Tok_Semicolon then
3705 Error_Msg_SP ("unexpected subprogram name ignored");
3709 Restore_Scan_State (Saved_State);
3712 end Check_Junk_Subprogram_Name;
3714 -- Start of processing for P_Access_Type_Definition
3717 if not Header_Already_Parsed then
3718 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
3719 Scan; -- past ACCESS
3722 if Token_Name = Name_Protected then
3723 Check_95_Keyword (Tok_Protected, Tok_Procedure);
3724 Check_95_Keyword (Tok_Protected, Tok_Function);
3727 Prot_Flag := (Token = Tok_Protected);
3730 Scan; -- past PROTECTED
3732 if Token /= Tok_Procedure and then Token /= Tok_Function then
3733 Error_Msg_SC ("FUNCTION or PROCEDURE expected");
3737 if Token = Tok_Procedure then
3738 if Ada_Version = Ada_83 then
3739 Error_Msg_SC ("(Ada 83) access to procedure not allowed!");
3742 Type_Def_Node := New_Node (N_Access_Procedure_Definition, Access_Loc);
3743 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3744 Scan; -- past PROCEDURE
3745 Check_Junk_Subprogram_Name;
3746 Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
3747 Set_Protected_Present (Type_Def_Node, Prot_Flag);
3749 elsif Token = Tok_Function then
3750 if Ada_Version = Ada_83 then
3751 Error_Msg_SC ("(Ada 83) access to function not allowed!");
3754 Type_Def_Node := New_Node (N_Access_Function_Definition, Access_Loc);
3755 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3756 Scan; -- past FUNCTION
3757 Check_Junk_Subprogram_Name;
3758 Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
3759 Set_Protected_Present (Type_Def_Node, Prot_Flag);
3762 Result_Not_Null := P_Null_Exclusion; -- Ada 2005 (AI-231)
3764 -- Ada 2005 (AI-318-02)
3766 if Token = Tok_Access then
3767 if Ada_Version < Ada_05 then
3769 ("anonymous access result type is an Ada 2005 extension");
3770 Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
3773 Result_Node := P_Access_Definition (Result_Not_Null);
3776 Result_Node := P_Subtype_Mark;
3780 -- Note: A null exclusion given on the result type needs to
3781 -- be coded by a distinct flag, since Null_Exclusion_Present
3782 -- on an access-to-function type pertains to a null exclusion
3783 -- on the access type itself (as set above). ???
3784 -- Set_Null_Exclusion_Present??? (Type_Def_Node, Result_Not_Null);
3786 Set_Result_Definition (Type_Def_Node, Result_Node);
3790 New_Node (N_Access_To_Object_Definition, Access_Loc);
3791 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3793 if Token = Tok_All or else Token = Tok_Constant then
3794 if Ada_Version = Ada_83 then
3795 Error_Msg_SC ("(Ada 83) access modifier not allowed!");
3798 if Token = Tok_All then
3799 Set_All_Present (Type_Def_Node, True);
3802 Set_Constant_Present (Type_Def_Node, True);
3805 Scan; -- past ALL or CONSTANT
3808 Set_Subtype_Indication (Type_Def_Node,
3809 P_Subtype_Indication (Not_Null_Present));
3812 return Type_Def_Node;
3813 end P_Access_Type_Definition;
3815 ---------------------------------------
3816 -- 3.10 Access To Object Definition --
3817 ---------------------------------------
3819 -- Parsed by P_Access_Type_Definition (3.10)
3821 -----------------------------------
3822 -- 3.10 General Access Modifier --
3823 -----------------------------------
3825 -- Parsed by P_Access_Type_Definition (3.10)
3827 -------------------------------------------
3828 -- 3.10 Access To Subprogram Definition --
3829 -------------------------------------------
3831 -- Parsed by P_Access_Type_Definition (3.10)
3833 -----------------------------
3834 -- 3.10 Access Definition --
3835 -----------------------------
3837 -- ACCESS_DEFINITION ::=
3838 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3839 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3841 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3842 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3843 -- | [NULL_EXCLUSION] access [protected] function
3844 -- PARAMETER_AND_RESULT_PROFILE
3846 -- The caller has parsed the null-exclusion part and it has also checked
3847 -- that the next token is ACCESS
3849 -- Error recovery: cannot raise Error_Resync
3851 function P_Access_Definition
3852 (Null_Exclusion_Present : Boolean) return Node_Id
3855 Subp_Node : Node_Id;
3858 Def_Node := New_Node (N_Access_Definition, Token_Ptr);
3859 Scan; -- past ACCESS
3861 -- Ada 2005 (AI-254): Access_To_Subprogram_Definition
3863 if Token = Tok_Protected
3864 or else Token = Tok_Procedure
3865 or else Token = Tok_Function
3867 if Ada_Version < Ada_05 then
3868 Error_Msg_SP ("access-to-subprogram is an Ada 2005 extension");
3869 Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
3872 Subp_Node := P_Access_Type_Definition (Header_Already_Parsed => True);
3873 Set_Null_Exclusion_Present (Subp_Node, Null_Exclusion_Present);
3874 Set_Access_To_Subprogram_Definition (Def_Node, Subp_Node);
3876 -- Ada 2005 (AI-231)
3877 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3880 Set_Null_Exclusion_Present (Def_Node, Null_Exclusion_Present);
3882 if Token = Tok_All then
3883 if Ada_Version < Ada_05 then
3885 ("access-all in this context is an Ada 2005 extension");
3886 Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
3890 Set_All_Present (Def_Node);
3892 elsif Token = Tok_Constant then
3893 if Ada_Version < Ada_05 then
3894 Error_Msg_SP ("access-to-constant is an Ada 2005 extension");
3895 Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
3898 Scan; -- past CONSTANT
3899 Set_Constant_Present (Def_Node);
3902 Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
3907 end P_Access_Definition;
3909 -----------------------------------------
3910 -- 3.10.1 Incomplete Type Declaration --
3911 -----------------------------------------
3913 -- Parsed by P_Type_Declaration (3.2.1)
3915 ----------------------------
3916 -- 3.11 Declarative Part --
3917 ----------------------------
3919 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
3921 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items
3922 -- handles errors, and returns cleanly after an error has occurred)
3924 function P_Declarative_Part return List_Id is
3929 -- Indicate no bad declarations detected yet. This will be reset by
3930 -- P_Declarative_Items if a bad declaration is discovered.
3932 Missing_Begin_Msg := No_Error_Msg;
3934 -- Get rid of active SIS entry from outer scope. This means we will
3935 -- miss some nested cases, but it doesn't seem worth the effort. See
3936 -- discussion in Par for further details
3938 SIS_Entry_Active := False;
3941 -- Loop to scan out the declarations
3944 P_Declarative_Items (Decls, Done, In_Spec => False);
3948 -- Get rid of active SIS entry which is left set only if we scanned a
3949 -- procedure declaration and have not found the body. We could give
3950 -- an error message, but that really would be usurping the role of
3951 -- semantic analysis (this really is a missing body case).
3953 SIS_Entry_Active := False;
3955 end P_Declarative_Part;
3957 ----------------------------
3958 -- 3.11 Declarative Item --
3959 ----------------------------
3961 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
3963 -- Can return Error if a junk declaration is found, or Empty if no
3964 -- declaration is found (i.e. a token ending declarations, such as
3965 -- BEGIN or END is encountered).
3967 -- Error recovery: cannot raise Error_Resync. If an error resync occurs,
3968 -- then the scan is set past the next semicolon and Error is returned.
3970 procedure P_Declarative_Items
3975 Scan_State : Saved_Scan_State;
3978 if Style_Check then Style.Check_Indentation; end if;
3982 when Tok_Function =>
3984 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
3990 -- Check for loop (premature statement)
3992 Save_Scan_State (Scan_State);
3995 if Token = Tok_Identifier then
3996 Scan; -- past identifier
3998 if Token = Tok_In then
3999 Restore_Scan_State (Scan_State);
4000 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
4005 -- Not a loop, so must be rep clause
4007 Restore_Scan_State (Scan_State);
4008 Append (P_Representation_Clause, Decls);
4013 Append (P_Generic, Decls);
4016 when Tok_Identifier =>
4018 P_Identifier_Declarations (Decls, Done, In_Spec);
4020 -- Ada2005: A subprogram declaration can start with "not" or
4021 -- "overriding". In older versions, "overriding" is handled
4022 -- like an identifier, with the appropriate warning.
4026 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4029 when Tok_Overriding =>
4031 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4036 Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4040 Append (P_Pragma, Decls);
4043 when Tok_Procedure =>
4045 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4048 when Tok_Protected =>
4050 Scan; -- past PROTECTED
4051 Append (P_Protected, Decls);
4056 Append (P_Subtype_Declaration, Decls);
4062 Append (P_Task, Decls);
4067 Append (P_Type_Declaration, Decls);
4072 Append (P_Use_Clause, Decls);
4077 Error_Msg_SC ("WITH can only appear in context clause");
4080 -- BEGIN terminates the scan of a sequence of declarations unless
4081 -- there is a missing subprogram body, see section on handling
4082 -- semicolon in place of IS. We only treat the begin as satisfying
4083 -- the subprogram declaration if it falls in the expected column
4087 if SIS_Entry_Active and then Start_Column >= SIS_Ecol then
4089 -- Here we have the case where a BEGIN is encountered during
4090 -- declarations in a declarative part, or at the outer level,
4091 -- and there is a subprogram declaration outstanding for which
4092 -- no body has been supplied. This is the case where we assume
4093 -- that the semicolon in the subprogram declaration should
4094 -- really have been is. The active SIS entry describes the
4095 -- subprogram declaration. On return the declaration has been
4096 -- modified to become a body.
4099 Specification_Node : Node_Id;
4100 Decl_Node : Node_Id;
4101 Body_Node : Node_Id;
4104 -- First issue the error message. If we had a missing
4105 -- semicolon in the declaration, then change the message
4106 -- to <missing "is">
4108 if SIS_Missing_Semicolon_Message /= No_Error_Msg then
4109 Change_Error_Text -- Replace: "missing "";"" "
4110 (SIS_Missing_Semicolon_Message, "missing ""is""");
4112 -- Otherwise we saved the semicolon position, so complain
4115 Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc);
4118 -- The next job is to fix up any declarations that occurred
4119 -- between the procedure header and the BEGIN. These got
4120 -- chained to the outer declarative region (immediately
4121 -- after the procedure declaration) and they should be
4122 -- chained to the subprogram itself, which is a body
4123 -- rather than a spec.
4125 Specification_Node := Specification (SIS_Declaration_Node);
4126 Change_Node (SIS_Declaration_Node, N_Subprogram_Body);
4127 Body_Node := SIS_Declaration_Node;
4128 Set_Specification (Body_Node, Specification_Node);
4129 Set_Declarations (Body_Node, New_List);
4132 Decl_Node := Remove_Next (Body_Node);
4133 exit when Decl_Node = Empty;
4134 Append (Decl_Node, Declarations (Body_Node));
4137 -- Now make the scope table entry for the Begin-End and
4141 Scope.Table (Scope.Last).Sloc := SIS_Sloc;
4142 Scope.Table (Scope.Last).Etyp := E_Name;
4143 Scope.Table (Scope.Last).Ecol := SIS_Ecol;
4144 Scope.Table (Scope.Last).Labl := SIS_Labl;
4145 Scope.Table (Scope.Last).Lreq := False;
4146 SIS_Entry_Active := False;
4148 Set_Handled_Statement_Sequence (Body_Node,
4149 P_Handled_Sequence_Of_Statements);
4150 End_Statements (Handled_Statement_Sequence (Body_Node));
4159 -- Normally an END terminates the scan for basic declarative
4160 -- items. The one exception is END RECORD, which is probably
4161 -- left over from some other junk.
4164 Save_Scan_State (Scan_State); -- at END
4167 if Token = Tok_Record then
4168 Error_Msg_SP ("no RECORD for this `end record`!");
4169 Scan; -- past RECORD
4173 Restore_Scan_State (Scan_State); -- to END
4177 -- The following tokens which can only be the start of a statement
4178 -- are considered to end a declarative part (i.e. we have a missing
4179 -- BEGIN situation). We are fairly conservative in making this
4180 -- judgment, because it is a real mess to go into statement mode
4181 -- prematurely in response to a junk declaration.
4196 -- But before we decide that it's a statement, let's check for
4197 -- a reserved word misused as an identifier.
4199 if Is_Reserved_Identifier then
4200 Save_Scan_State (Scan_State);
4201 Scan; -- past the token
4203 -- If reserved identifier not followed by colon or comma, then
4204 -- this is most likely an assignment statement to the bad id.
4206 if Token /= Tok_Colon and then Token /= Tok_Comma then
4207 Restore_Scan_State (Scan_State);
4208 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
4211 -- Otherwise we have a declaration of the bad id
4214 Restore_Scan_State (Scan_State);
4215 Scan_Reserved_Identifier (Force_Msg => True);
4216 P_Identifier_Declarations (Decls, Done, In_Spec);
4219 -- If not reserved identifier, then it's definitely a statement
4222 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
4226 -- The token RETURN may well also signal a missing BEGIN situation,
4227 -- however, we never let it end the declarative part, because it may
4228 -- also be part of a half-baked function declaration.
4231 Error_Msg_SC ("misplaced RETURN statement");
4234 -- PRIVATE definitely terminates the declarations in a spec,
4235 -- and is an error in a body.
4241 Error_Msg_SC ("PRIVATE not allowed in body");
4242 Scan; -- past PRIVATE
4245 -- An end of file definitely terminates the declarations!
4250 -- The remaining tokens do not end the scan, but cannot start a
4251 -- valid declaration, so we signal an error and resynchronize.
4252 -- But first check for misuse of a reserved identifier.
4256 -- Here we check for a reserved identifier
4258 if Is_Reserved_Identifier then
4259 Save_Scan_State (Scan_State);
4260 Scan; -- past the token
4262 if Token /= Tok_Colon and then Token /= Tok_Comma then
4263 Restore_Scan_State (Scan_State);
4264 Set_Declaration_Expected;
4267 Restore_Scan_State (Scan_State);
4268 Scan_Reserved_Identifier (Force_Msg => True);
4270 P_Identifier_Declarations (Decls, Done, In_Spec);
4274 Set_Declaration_Expected;
4279 -- To resynchronize after an error, we scan to the next semicolon and
4280 -- return with Done = False, indicating that there may still be more
4281 -- valid declarations to come.
4284 when Error_Resync =>
4285 Resync_Past_Semicolon;
4287 end P_Declarative_Items;
4289 ----------------------------------
4290 -- 3.11 Basic Declarative Item --
4291 ----------------------------------
4293 -- BASIC_DECLARATIVE_ITEM ::=
4294 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
4296 -- Scan zero or more basic declarative items
4298 -- Error recovery: cannot raise Error_Resync. If an error is detected, then
4299 -- the scan pointer is repositioned past the next semicolon, and the scan
4300 -- for declarative items continues.
4302 function P_Basic_Declarative_Items return List_Id is
4309 -- Indicate no bad declarations detected yet in the current context:
4310 -- visible or private declarations of a package spec.
4312 Missing_Begin_Msg := No_Error_Msg;
4314 -- Get rid of active SIS entry from outer scope. This means we will
4315 -- miss some nested cases, but it doesn't seem worth the effort. See
4316 -- discussion in Par for further details
4318 SIS_Entry_Active := False;
4320 -- Loop to scan out declarations
4325 P_Declarative_Items (Decls, Done, In_Spec => True);
4329 -- Get rid of active SIS entry. This is set only if we have scanned a
4330 -- procedure declaration and have not found the body. We could give
4331 -- an error message, but that really would be usurping the role of
4332 -- semantic analysis (this really is a case of a missing body).
4334 SIS_Entry_Active := False;
4336 -- Test for assorted illegal declarations not diagnosed elsewhere
4338 Decl := First (Decls);
4340 while Present (Decl) loop
4341 Kind := Nkind (Decl);
4343 -- Test for body scanned, not acceptable as basic decl item
4345 if Kind = N_Subprogram_Body or else
4346 Kind = N_Package_Body or else
4347 Kind = N_Task_Body or else
4348 Kind = N_Protected_Body
4351 ("proper body not allowed in package spec", Sloc (Decl));
4353 -- Test for body stub scanned, not acceptable as basic decl item
4355 elsif Kind in N_Body_Stub then
4357 ("body stub not allowed in package spec", Sloc (Decl));
4359 elsif Kind = N_Assignment_Statement then
4361 ("assignment statement not allowed in package spec",
4369 end P_Basic_Declarative_Items;
4375 -- For proper body, see below
4376 -- For body stub, see 10.1.3
4378 -----------------------
4379 -- 3.11 Proper Body --
4380 -----------------------
4382 -- Subprogram body is parsed by P_Subprogram (6.1)
4383 -- Package body is parsed by P_Package (7.1)
4384 -- Task body is parsed by P_Task (9.1)
4385 -- Protected body is parsed by P_Protected (9.4)
4387 ------------------------------
4388 -- Set_Declaration_Expected --
4389 ------------------------------
4391 procedure Set_Declaration_Expected is
4393 Error_Msg_SC ("declaration expected");
4395 if Missing_Begin_Msg = No_Error_Msg then
4396 Missing_Begin_Msg := Get_Msg_Id;
4398 end Set_Declaration_Expected;
4400 ----------------------
4401 -- Skip_Declaration --
4402 ----------------------
4404 procedure Skip_Declaration (S : List_Id) is
4405 Dummy_Done : Boolean;
4408 P_Declarative_Items (S, Dummy_Done, False);
4409 end Skip_Declaration;
4411 -----------------------------------------
4412 -- Statement_When_Declaration_Expected --
4413 -----------------------------------------
4415 procedure Statement_When_Declaration_Expected
4421 -- Case of second occurrence of statement in one declaration sequence
4423 if Missing_Begin_Msg /= No_Error_Msg then
4425 -- In the procedure spec case, just ignore it, we only give one
4426 -- message for the first occurrence, since otherwise we may get
4427 -- horrible cascading if BODY was missing in the header line.
4432 -- In the declarative part case, take a second statement as a sure
4433 -- sign that we really have a missing BEGIN, and end the declarative
4434 -- part now. Note that the caller will fix up the first message to
4435 -- say "missing BEGIN" so that's how the error will be signalled.
4442 -- Case of first occurrence of unexpected statement
4445 -- If we are in a package spec, then give message of statement
4446 -- not allowed in package spec. This message never gets changed.
4449 Error_Msg_SC ("statement not allowed in package spec");
4451 -- If in declarative part, then we give the message complaining
4452 -- about finding a statement when a declaration is expected. This
4453 -- gets changed to a complaint about a missing BEGIN if we later
4454 -- find that no BEGIN is present.
4457 Error_Msg_SC ("statement not allowed in declarative part");
4460 -- Capture message Id. This is used for two purposes, first to
4461 -- stop multiple messages, see test above, and second, to allow
4462 -- the replacement of the message in the declarative part case.
4464 Missing_Begin_Msg := Get_Msg_Id;
4467 -- In all cases except the case in which we decided to terminate the
4468 -- declaration sequence on a second error, we scan out the statement
4469 -- and append it to the list of declarations (note that the semantics
4470 -- can handle statements in a declaration list so if we proceed to
4471 -- call the semantic phase, all will be (reasonably) well!
4473 Append_List_To (Decls, P_Sequence_Of_Statements (SS_Unco));
4475 -- Done is set to False, since we want to continue the scan of
4476 -- declarations, hoping that this statement was a temporary glitch.
4477 -- If we indeed are now in the statement part (i.e. this was a missing
4478 -- BEGIN, then it's not terrible, we will simply keep calling this
4479 -- procedure to process the statements one by one, and then finally
4480 -- hit the missing BEGIN, which will clean up the error message.
4483 end Statement_When_Declaration_Expected;