1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005, 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 notify
179 -- that interface, overriding, and synchronized are
180 -- new reserved words
182 if Ada_Version = Ada_95 then
183 if Token_Name = Name_Overriding
184 or else Token_Name = Name_Synchronized
185 or else (Token_Name = Name_Interface
186 and then Prev_Token /= Tok_Pragma)
188 Error_Msg_N ("& is a reserved word in Ada 2005?", Token_Node);
192 -- If we have a reserved identifier, manufacture an identifier with
193 -- a corresponding name after posting an appropriate error message
195 elsif Is_Reserved_Identifier (C) then
196 Scan_Reserved_Identifier (Force_Msg => True);
198 -- Otherwise we have junk that cannot be interpreted as an identifier
201 T_Identifier; -- to give message
205 Ident_Node := Token_Node;
206 Scan; -- past the reserved identifier
208 if Ident_Node /= Error then
209 Change_Identifier_To_Defining_Identifier (Ident_Node);
213 end P_Defining_Identifier;
215 -----------------------------
216 -- 3.2.1 Type Declaration --
217 -----------------------------
219 -- TYPE_DECLARATION ::=
220 -- FULL_TYPE_DECLARATION
221 -- | INCOMPLETE_TYPE_DECLARATION
222 -- | PRIVATE_TYPE_DECLARATION
223 -- | PRIVATE_EXTENSION_DECLARATION
225 -- FULL_TYPE_DECLARATION ::=
226 -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION;
227 -- | CONCURRENT_TYPE_DECLARATION
229 -- INCOMPLETE_TYPE_DECLARATION ::=
230 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART];
232 -- PRIVATE_TYPE_DECLARATION ::=
233 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
234 -- is [abstract] [tagged] [limited] private;
236 -- PRIVATE_EXTENSION_DECLARATION ::=
237 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
238 -- [abstract] new ancestor_SUBTYPE_INDICATION with private;
240 -- TYPE_DEFINITION ::=
241 -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
242 -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION
243 -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION
244 -- | DERIVED_TYPE_DEFINITION | INTERFACE_TYPE_DEFINITION
246 -- INTEGER_TYPE_DEFINITION ::=
247 -- SIGNED_INTEGER_TYPE_DEFINITION
248 -- MODULAR_TYPE_DEFINITION
250 -- INTERFACE_TYPE_DEFINITION ::=
251 -- [limited | task | protected | synchronized ] interface
252 -- [AND interface_list]
254 -- Error recovery: can raise Error_Resync
256 -- Note: The processing for full type declaration, incomplete type
257 -- declaration, private type declaration and type definition is
258 -- included in this function. The processing for concurrent type
259 -- declarations is NOT here, but rather in chapter 9 (i.e. this
260 -- function handles only declarations starting with TYPE).
262 function P_Type_Declaration return Node_Id is
263 Abstract_Present : Boolean;
264 Abstract_Loc : Source_Ptr;
266 Discr_List : List_Id;
267 Discr_Sloc : Source_Ptr;
269 Type_Loc : Source_Ptr;
270 Type_Start_Col : Column_Number;
271 Ident_Node : Node_Id;
272 Is_Derived_Iface : Boolean := False;
273 Unknown_Dis : Boolean;
275 Typedef_Node : Node_Id;
276 -- Normally holds type definition, except in the case of a private
277 -- extension declaration, in which case it holds the declaration itself
280 Type_Loc := Token_Ptr;
281 Type_Start_Col := Start_Column;
283 -- If we have TYPE, then proceed ahead and scan identifier
285 if Token = Tok_Type then
287 Ident_Node := P_Defining_Identifier (C_Is);
289 -- Otherwise this is an error case, and we may already have converted
290 -- the current token to a defining identifier, so don't do it again!
295 if Token = Tok_Identifier
296 and then Nkind (Token_Node) = N_Defining_Identifier
298 Ident_Node := Token_Node;
299 Scan; -- past defining identifier
301 Ident_Node := P_Defining_Identifier (C_Is);
305 Discr_Sloc := Token_Ptr;
307 if P_Unknown_Discriminant_Part_Opt then
309 Discr_List := No_List;
311 Unknown_Dis := False;
312 Discr_List := P_Known_Discriminant_Part_Opt;
315 -- Incomplete type declaration. We complete the processing for this
316 -- case here and return the resulting incomplete type declaration node
318 if Token = Tok_Semicolon then
320 Decl_Node := New_Node (N_Incomplete_Type_Declaration, Type_Loc);
321 Set_Defining_Identifier (Decl_Node, Ident_Node);
322 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
323 Set_Discriminant_Specifications (Decl_Node, Discr_List);
330 -- Full type declaration or private type declaration, must have IS
332 if Token = Tok_Equal then
334 Scan; -- past = used in place of IS
336 elsif Token = Tok_Renames then
337 Error_Msg_SC ("RENAMES should be IS");
338 Scan; -- past RENAMES used in place of IS
344 -- First an error check, if we have two identifiers in a row, a likely
345 -- possibility is that the first of the identifiers is an incorrectly
348 if Token = Tok_Identifier then
350 SS : Saved_Scan_State;
354 Save_Scan_State (SS);
355 Scan; -- past initial identifier
356 I2 := (Token = Tok_Identifier);
357 Restore_Scan_State (SS);
361 (Bad_Spelling_Of (Tok_Abstract) or else
362 Bad_Spelling_Of (Tok_Access) or else
363 Bad_Spelling_Of (Tok_Aliased) or else
364 Bad_Spelling_Of (Tok_Constant))
371 -- Check for misuse of Ada 95 keyword abstract in Ada 83 mode
373 if Token_Name = Name_Abstract then
374 Check_95_Keyword (Tok_Abstract, Tok_Tagged);
375 Check_95_Keyword (Tok_Abstract, Tok_New);
378 -- Check cases of misuse of ABSTRACT
380 if Token = Tok_Abstract then
381 Abstract_Present := True;
382 Abstract_Loc := Token_Ptr;
383 Scan; -- past ABSTRACT
385 if Token = Tok_Limited
386 or else Token = Tok_Private
387 or else Token = Tok_Record
388 or else Token = Tok_Null
390 Error_Msg_AP ("TAGGED expected");
394 Abstract_Present := False;
395 Abstract_Loc := No_Location;
398 -- Check for misuse of Ada 95 keyword Tagged
400 if Token_Name = Name_Tagged then
401 Check_95_Keyword (Tok_Tagged, Tok_Private);
402 Check_95_Keyword (Tok_Tagged, Tok_Limited);
403 Check_95_Keyword (Tok_Tagged, Tok_Record);
406 -- Special check for misuse of Aliased
408 if Token = Tok_Aliased or else Token_Name = Name_Aliased then
409 Error_Msg_SC ("ALIASED not allowed in type definition");
410 Scan; -- past ALIASED
413 -- The following procesing deals with either a private type declaration
414 -- or a full type declaration. In the private type case, we build the
415 -- N_Private_Type_Declaration node, setting its Tagged_Present and
416 -- Limited_Present flags, on encountering the Private keyword, and
417 -- leave Typedef_Node set to Empty. For the full type declaration
418 -- case, Typedef_Node gets set to the type definition.
420 Typedef_Node := Empty;
422 -- Switch on token following the IS. The loop normally runs once. It
423 -- only runs more than once if an error is detected, to try again after
424 -- detecting and fixing up the error.
430 Tok_Not => -- Ada 2005 (AI-231)
431 Typedef_Node := P_Access_Type_Definition;
436 Typedef_Node := P_Array_Type_Definition;
441 Typedef_Node := P_Fixed_Point_Definition;
446 Typedef_Node := P_Floating_Point_Definition;
453 when Tok_Integer_Literal =>
455 Typedef_Node := P_Signed_Integer_Type_Definition;
460 Typedef_Node := P_Record_Definition;
464 when Tok_Left_Paren =>
465 Typedef_Node := P_Enumeration_Type_Definition;
468 Make_Identifier (Token_Ptr,
469 Chars => Chars (Ident_Node));
470 Set_Comes_From_Source (End_Labl, False);
472 Set_End_Label (Typedef_Node, End_Labl);
477 Typedef_Node := P_Modular_Type_Definition;
482 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
484 if Nkind (Typedef_Node) = N_Derived_Type_Definition
485 and then Present (Record_Extension_Part (Typedef_Node))
488 Make_Identifier (Token_Ptr,
489 Chars => Chars (Ident_Node));
490 Set_Comes_From_Source (End_Labl, False);
493 (Record_Extension_Part (Typedef_Node), End_Labl);
500 Typedef_Node := P_Signed_Integer_Type_Definition;
505 Typedef_Node := P_Record_Definition;
508 Make_Identifier (Token_Ptr,
509 Chars => Chars (Ident_Node));
510 Set_Comes_From_Source (End_Labl, False);
512 Set_End_Label (Typedef_Node, End_Labl);
519 if Token = Tok_Abstract then
520 Error_Msg_SC ("ABSTRACT must come before TAGGED");
521 Abstract_Present := True;
522 Abstract_Loc := Token_Ptr;
523 Scan; -- past ABSTRACT
526 if Token = Tok_Limited then
527 Scan; -- past LIMITED
529 -- TAGGED LIMITED PRIVATE case
531 if Token = Tok_Private then
533 New_Node (N_Private_Type_Declaration, Type_Loc);
534 Set_Tagged_Present (Decl_Node, True);
535 Set_Limited_Present (Decl_Node, True);
536 Scan; -- past PRIVATE
538 -- TAGGED LIMITED RECORD
541 Typedef_Node := P_Record_Definition;
542 Set_Tagged_Present (Typedef_Node, True);
543 Set_Limited_Present (Typedef_Node, True);
546 Make_Identifier (Token_Ptr,
547 Chars => Chars (Ident_Node));
548 Set_Comes_From_Source (End_Labl, False);
550 Set_End_Label (Typedef_Node, End_Labl);
556 if Token = Tok_Private then
558 New_Node (N_Private_Type_Declaration, Type_Loc);
559 Set_Tagged_Present (Decl_Node, True);
560 Scan; -- past PRIVATE
565 Typedef_Node := P_Record_Definition;
566 Set_Tagged_Present (Typedef_Node, True);
569 Make_Identifier (Token_Ptr,
570 Chars => Chars (Ident_Node));
571 Set_Comes_From_Source (End_Labl, False);
573 Set_End_Label (Typedef_Node, End_Labl);
581 Scan; -- past LIMITED
584 if Token = Tok_Tagged then
585 Error_Msg_SC ("TAGGED must come before LIMITED");
588 elsif Token = Tok_Abstract then
589 Error_Msg_SC ("ABSTRACT must come before LIMITED");
590 Scan; -- past ABSTRACT
597 -- LIMITED RECORD or LIMITED NULL RECORD
599 if Token = Tok_Record or else Token = Tok_Null then
600 if Ada_Version = Ada_83 then
602 ("(Ada 83) limited record declaration not allowed!");
605 Typedef_Node := P_Record_Definition;
606 Set_Limited_Present (Typedef_Node, True);
608 -- Ada 2005 (AI-251): LIMITED INTERFACE
610 -- If we are compiling in Ada 83 or Ada 95 mode, "interface"
611 -- is not a reserved word but we force its analysis to
612 -- generate the corresponding usage error.
614 elsif Token = Tok_Interface
615 or else (Token = Tok_Identifier
616 and then Chars (Token_Node) = Name_Interface)
618 Typedef_Node := P_Interface_Type_Definition
619 (Is_Synchronized => False);
620 Abstract_Present := True;
621 Set_Limited_Present (Typedef_Node);
623 if Nkind (Typedef_Node) = N_Derived_Type_Definition then
624 Is_Derived_Iface := True;
627 -- LIMITED PRIVATE is the only remaining possibility here
630 Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
631 Set_Limited_Present (Decl_Node, True);
632 T_Private; -- past PRIVATE (or complain if not there!)
638 -- Here we have an identifier after the IS, which is certainly
639 -- wrong and which might be one of several different mistakes.
641 when Tok_Identifier =>
643 -- First case, if identifier is on same line, then probably we
644 -- have something like "type X is Integer .." and the best
645 -- diagnosis is a missing NEW. Note: the missing new message
646 -- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl.
648 if not Token_Is_At_Start_Of_Line then
649 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
652 -- If the identifier is at the start of the line, and is in the
653 -- same column as the type declaration itself then we consider
654 -- that we had a missing type definition on the previous line
656 elsif Start_Column <= Type_Start_Col then
657 Error_Msg_AP ("type definition expected");
658 Typedef_Node := Error;
660 -- If the identifier is at the start of the line, and is in
661 -- a column to the right of the type declaration line, then we
662 -- may have something like:
667 -- and the best diagnosis is a missing record keyword
670 Typedef_Node := P_Record_Definition;
676 -- Ada 2005 (AI-251): INTERFACE
678 when Tok_Interface =>
679 Typedef_Node := P_Interface_Type_Definition
680 (Is_Synchronized => False);
681 Abstract_Present := True;
686 Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
687 Scan; -- past PRIVATE
698 Saved_Token : constant Token_Type := Token;
701 Scan; -- past TASK, PROTECTED or SYNCHRONIZED
703 Typedef_Node := P_Interface_Type_Definition
704 (Is_Synchronized => True);
708 Set_Task_Present (Typedef_Node);
710 when Tok_Protected =>
711 Set_Protected_Present (Typedef_Node);
713 when Tok_Synchronized =>
714 Set_Synchronized_Present (Typedef_Node);
717 pragma Assert (False);
725 -- Anything else is an error
728 if Bad_Spelling_Of (Tok_Access)
730 Bad_Spelling_Of (Tok_Array)
732 Bad_Spelling_Of (Tok_Delta)
734 Bad_Spelling_Of (Tok_Digits)
736 Bad_Spelling_Of (Tok_Limited)
738 Bad_Spelling_Of (Tok_Private)
740 Bad_Spelling_Of (Tok_Range)
742 Bad_Spelling_Of (Tok_Record)
744 Bad_Spelling_Of (Tok_Tagged)
749 Error_Msg_AP ("type definition expected");
756 -- For the private type declaration case, the private type declaration
757 -- node has been built, with the Tagged_Present and Limited_Present
758 -- flags set as needed, and Typedef_Node is left set to Empty.
760 if No (Typedef_Node) then
761 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
762 Set_Abstract_Present (Decl_Node, Abstract_Present);
764 -- For a private extension declaration, Typedef_Node contains the
765 -- N_Private_Extension_Declaration node, which we now complete. Note
766 -- that the private extension declaration, unlike a full type
767 -- declaration, does permit unknown discriminants.
769 elsif Nkind (Typedef_Node) = N_Private_Extension_Declaration then
770 Decl_Node := Typedef_Node;
771 Set_Sloc (Decl_Node, Type_Loc);
772 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
773 Set_Abstract_Present (Typedef_Node, Abstract_Present);
775 -- In the full type declaration case, Typedef_Node has the type
776 -- definition and here is where we build the full type declaration
777 -- node. This is also where we check for improper use of an unknown
778 -- discriminant part (not allowed for full type declaration).
781 if Nkind (Typedef_Node) = N_Record_Definition
782 or else (Nkind (Typedef_Node) = N_Derived_Type_Definition
783 and then Present (Record_Extension_Part (Typedef_Node)))
784 or else Is_Derived_Iface
786 Set_Abstract_Present (Typedef_Node, Abstract_Present);
788 elsif Abstract_Present then
789 Error_Msg ("ABSTRACT not allowed here, ignored", Abstract_Loc);
792 Decl_Node := New_Node (N_Full_Type_Declaration, Type_Loc);
793 Set_Type_Definition (Decl_Node, Typedef_Node);
797 ("Full type declaration cannot have unknown discriminants",
802 -- Remaining processing is common for all three cases
804 Set_Defining_Identifier (Decl_Node, Ident_Node);
805 Set_Discriminant_Specifications (Decl_Node, Discr_List);
807 end P_Type_Declaration;
809 ----------------------------------
810 -- 3.2.1 Full Type Declaration --
811 ----------------------------------
813 -- Parsed by P_Type_Declaration (3.2.1)
815 ----------------------------
816 -- 3.2.1 Type Definition --
817 ----------------------------
819 -- Parsed by P_Type_Declaration (3.2.1)
821 --------------------------------
822 -- 3.2.2 Subtype Declaration --
823 --------------------------------
825 -- SUBTYPE_DECLARATION ::=
826 -- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION;
828 -- The caller has checked that the initial token is SUBTYPE
830 -- Error recovery: can raise Error_Resync
832 function P_Subtype_Declaration return Node_Id is
834 Not_Null_Present : Boolean := False;
836 Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr);
837 Scan; -- past SUBTYPE
838 Set_Defining_Identifier (Decl_Node, P_Defining_Identifier (C_Is));
841 if Token = Tok_New then
842 Error_Msg_SC ("NEW ignored (only allowed in type declaration)");
846 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
847 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
849 Set_Subtype_Indication
850 (Decl_Node, P_Subtype_Indication (Not_Null_Present));
853 end P_Subtype_Declaration;
855 -------------------------------
856 -- 3.2.2 Subtype Indication --
857 -------------------------------
859 -- SUBTYPE_INDICATION ::=
860 -- [NOT NULL] SUBTYPE_MARK [CONSTRAINT]
862 -- Error recovery: can raise Error_Resync
864 function P_Null_Exclusion return Boolean is
866 if Token /= Tok_Not then
870 if Ada_Version < Ada_05 then
872 ("null-excluding access is an Ada 2005 extension");
873 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
878 if Token = Tok_Null then
881 Error_Msg_SP ("NULL expected");
886 end P_Null_Exclusion;
888 function P_Subtype_Indication
889 (Not_Null_Present : Boolean := False) return Node_Id is
893 if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
894 Type_Node := P_Subtype_Mark;
895 return P_Subtype_Indication (Type_Node, Not_Null_Present);
898 -- Check for error of using record definition and treat it nicely,
899 -- otherwise things are really messed up, so resynchronize.
901 if Token = Tok_Record then
902 Error_Msg_SC ("anonymous record definitions are not permitted");
903 Discard_Junk_Node (P_Record_Definition);
907 Error_Msg_AP ("subtype indication expected");
911 end P_Subtype_Indication;
913 -- The following function is identical except that it is called with
914 -- the subtype mark already scanned out, and it scans out the constraint
916 -- Error recovery: can raise Error_Resync
918 function P_Subtype_Indication
919 (Subtype_Mark : Node_Id;
920 Not_Null_Present : Boolean := False) return Node_Id is
921 Indic_Node : Node_Id;
922 Constr_Node : Node_Id;
925 Constr_Node := P_Constraint_Opt;
927 if No (Constr_Node) then
930 if Not_Null_Present then
931 Error_Msg_SP ("constrained null-exclusion not allowed");
934 Indic_Node := New_Node (N_Subtype_Indication, Sloc (Subtype_Mark));
935 Set_Subtype_Mark (Indic_Node, Check_Subtype_Mark (Subtype_Mark));
936 Set_Constraint (Indic_Node, Constr_Node);
939 end P_Subtype_Indication;
941 -------------------------
942 -- 3.2.2 Subtype Mark --
943 -------------------------
945 -- SUBTYPE_MARK ::= subtype_NAME;
947 -- Note: The subtype mark which appears after an IN or NOT IN
948 -- operator is parsed by P_Range_Or_Subtype_Mark (3.5)
950 -- Error recovery: cannot raise Error_Resync
952 function P_Subtype_Mark return Node_Id is
954 return P_Subtype_Mark_Resync;
961 -- This routine differs from P_Subtype_Mark in that it insists that an
962 -- identifier be present, and if it is not, it raises Error_Resync.
964 -- Error recovery: can raise Error_Resync
966 function P_Subtype_Mark_Resync return Node_Id is
970 if Token = Tok_Access then
971 Error_Msg_SC ("anonymous access type definition not allowed here");
975 if Token = Tok_Array then
976 Error_Msg_SC ("anonymous array definition not allowed here");
977 Discard_Junk_Node (P_Array_Type_Definition);
981 Type_Node := P_Qualified_Simple_Name_Resync;
983 -- Check for a subtype mark attribute. The only valid possibilities
984 -- are 'CLASS and 'BASE. Anything else is a definite error. We may
985 -- as well catch it here.
987 if Token = Tok_Apostrophe then
988 return P_Subtype_Mark_Attribute (Type_Node);
993 end P_Subtype_Mark_Resync;
995 -- The following function is called to scan out a subtype mark attribute.
996 -- The caller has already scanned out the subtype mark, which is passed in
997 -- as the argument, and has checked that the current token is apostrophe.
999 -- Only a special subclass of attributes, called type attributes
1000 -- (see Snames package) are allowed in this syntactic position.
1002 -- Note: if the apostrophe is followed by other than an identifier, then
1003 -- the input expression is returned unchanged, and the scan pointer is
1004 -- left pointing to the apostrophe.
1006 -- Error recovery: can raise Error_Resync
1008 function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id is
1009 Attr_Node : Node_Id := Empty;
1010 Scan_State : Saved_Scan_State;
1014 Prefix := Check_Subtype_Mark (Type_Node);
1016 if Prefix = Error then
1020 -- Loop through attributes appearing (more than one can appear as for
1021 -- for example in X'Base'Class). We are at an apostrophe on entry to
1022 -- this loop, and it runs once for each attribute parsed, with
1023 -- Prefix being the current possible prefix if it is an attribute.
1026 Save_Scan_State (Scan_State); -- at Apostrophe
1027 Scan; -- past apostrophe
1029 if Token /= Tok_Identifier then
1030 Restore_Scan_State (Scan_State); -- to apostrophe
1031 return Prefix; -- no attribute after all
1033 elsif not Is_Type_Attribute_Name (Token_Name) then
1035 ("attribute & may not be used in a subtype mark", Token_Node);
1040 Make_Attribute_Reference (Prev_Token_Ptr,
1042 Attribute_Name => Token_Name);
1043 Delete_Node (Token_Node);
1044 Scan; -- past type attribute identifier
1047 exit when Token /= Tok_Apostrophe;
1048 Prefix := Attr_Node;
1051 -- Fall through here after scanning type attribute
1054 end P_Subtype_Mark_Attribute;
1056 -----------------------
1057 -- 3.2.2 Constraint --
1058 -----------------------
1060 -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
1062 -- SCALAR_CONSTRAINT ::=
1063 -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
1065 -- COMPOSITE_CONSTRAINT ::=
1066 -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
1068 -- If no constraint is present, this function returns Empty
1070 -- Error recovery: can raise Error_Resync
1072 function P_Constraint_Opt return Node_Id is
1074 if Token = Tok_Range
1075 or else Bad_Spelling_Of (Tok_Range)
1077 return P_Range_Constraint;
1079 elsif Token = Tok_Digits
1080 or else Bad_Spelling_Of (Tok_Digits)
1082 return P_Digits_Constraint;
1084 elsif Token = Tok_Delta
1085 or else Bad_Spelling_Of (Tok_Delta)
1087 return P_Delta_Constraint;
1089 elsif Token = Tok_Left_Paren then
1090 return P_Index_Or_Discriminant_Constraint;
1092 elsif Token = Tok_In then
1094 return P_Constraint_Opt;
1099 end P_Constraint_Opt;
1101 ------------------------------
1102 -- 3.2.2 Scalar Constraint --
1103 ------------------------------
1105 -- Parsed by P_Constraint_Opt (3.2.2)
1107 ---------------------------------
1108 -- 3.2.2 Composite Constraint --
1109 ---------------------------------
1111 -- Parsed by P_Constraint_Opt (3.2.2)
1113 --------------------------------------------------------
1114 -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) --
1115 --------------------------------------------------------
1117 -- This routine scans out a declaration starting with an identifier:
1119 -- OBJECT_DECLARATION ::=
1120 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1121 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1122 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1123 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1125 -- NUMBER_DECLARATION ::=
1126 -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
1128 -- OBJECT_RENAMING_DECLARATION ::=
1129 -- DEFINING_IDENTIFIER : SUBTYPE_MARK renames object_NAME;
1130 -- | DEFINING_IDENTIFIER : ACCESS_DEFINITION renames object_NAME;
1132 -- EXCEPTION_RENAMING_DECLARATION ::=
1133 -- DEFINING_IDENTIFIER : exception renames exception_NAME;
1135 -- EXCEPTION_DECLARATION ::=
1136 -- DEFINING_IDENTIFIER_LIST : exception;
1138 -- Note that the ALIASED indication in an object declaration is
1139 -- marked by a flag in the parent node.
1141 -- The caller has checked that the initial token is an identifier
1143 -- The value returned is a list of declarations, one for each identifier
1144 -- in the list (as described in Sinfo, we always split up multiple
1145 -- declarations into the equivalent sequence of single declarations
1146 -- using the More_Ids and Prev_Ids flags to preserve the source).
1148 -- If the identifier turns out to be a probable statement rather than
1149 -- an identifier, then the scan is left pointing to the identifier and
1150 -- No_List is returned.
1152 -- Error recovery: can raise Error_Resync
1154 procedure P_Identifier_Declarations
1160 Decl_Node : Node_Id;
1161 Type_Node : Node_Id;
1162 Ident_Sloc : Source_Ptr;
1163 Scan_State : Saved_Scan_State;
1164 List_OK : Boolean := True;
1166 Init_Expr : Node_Id;
1167 Init_Loc : Source_Ptr;
1168 Con_Loc : Source_Ptr;
1169 Not_Null_Present : Boolean := False;
1171 Idents : array (Int range 1 .. 4096) of Entity_Id;
1172 -- Used to save identifiers in the identifier list. The upper bound
1173 -- of 4096 is expected to be infinite in practice, and we do not even
1174 -- bother to check if this upper bound is exceeded.
1176 Num_Idents : Nat := 1;
1177 -- Number of identifiers stored in Idents
1180 -- This procedure is called in renames cases to make sure that we do
1181 -- not have more than one identifier. If we do have more than one
1182 -- then an error message is issued (and the declaration is split into
1183 -- multiple declarations)
1185 function Token_Is_Renames return Boolean;
1186 -- Checks if current token is RENAMES, and if so, scans past it and
1187 -- returns True, otherwise returns False. Includes checking for some
1188 -- common error cases.
1190 procedure No_List is
1192 if Num_Idents > 1 then
1193 Error_Msg ("identifier list not allowed for RENAMES",
1200 function Token_Is_Renames return Boolean is
1201 At_Colon : Saved_Scan_State;
1204 if Token = Tok_Colon then
1205 Save_Scan_State (At_Colon);
1207 Check_Misspelling_Of (Tok_Renames);
1209 if Token = Tok_Renames then
1210 Error_Msg_SP ("extra "":"" ignored");
1211 Scan; -- past RENAMES
1214 Restore_Scan_State (At_Colon);
1219 Check_Misspelling_Of (Tok_Renames);
1221 if Token = Tok_Renames then
1222 Scan; -- past RENAMES
1228 end Token_Is_Renames;
1230 -- Start of processing for P_Identifier_Declarations
1233 Ident_Sloc := Token_Ptr;
1234 Save_Scan_State (Scan_State); -- at first identifier
1235 Idents (1) := P_Defining_Identifier (C_Comma_Colon);
1237 -- If we have a colon after the identifier, then we can assume that
1238 -- this is in fact a valid identifier declaration and can steam ahead.
1240 if Token = Tok_Colon then
1243 -- If we have a comma, then scan out the list of identifiers
1245 elsif Token = Tok_Comma then
1247 while Comma_Present loop
1248 Num_Idents := Num_Idents + 1;
1249 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
1252 Save_Scan_State (Scan_State); -- at colon
1255 -- If we have identifier followed by := then we assume that what is
1256 -- really meant is an assignment statement. The assignment statement
1257 -- is scanned out and added to the list of declarations. An exception
1258 -- occurs if the := is followed by the keyword constant, in which case
1259 -- we assume it was meant to be a colon.
1261 elsif Token = Tok_Colon_Equal then
1264 if Token = Tok_Constant then
1265 Error_Msg_SP ("colon expected");
1268 Restore_Scan_State (Scan_State);
1269 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
1273 -- If we have an IS keyword, then assume the TYPE keyword was missing
1275 elsif Token = Tok_Is then
1276 Restore_Scan_State (Scan_State);
1277 Append_To (Decls, P_Type_Declaration);
1281 -- Otherwise we have an error situation
1284 Restore_Scan_State (Scan_State);
1286 -- First case is possible misuse of PROTECTED in Ada 83 mode. If
1287 -- so, fix the keyword and return to scan the protected declaration.
1289 if Token_Name = Name_Protected then
1290 Check_95_Keyword (Tok_Protected, Tok_Identifier);
1291 Check_95_Keyword (Tok_Protected, Tok_Type);
1292 Check_95_Keyword (Tok_Protected, Tok_Body);
1294 if Token = Tok_Protected then
1299 -- Check misspelling possibilities. If so, correct the misspelling
1300 -- and return to scan out the resulting declaration.
1302 elsif Bad_Spelling_Of (Tok_Function)
1303 or else Bad_Spelling_Of (Tok_Procedure)
1304 or else Bad_Spelling_Of (Tok_Package)
1305 or else Bad_Spelling_Of (Tok_Pragma)
1306 or else Bad_Spelling_Of (Tok_Protected)
1307 or else Bad_Spelling_Of (Tok_Generic)
1308 or else Bad_Spelling_Of (Tok_Subtype)
1309 or else Bad_Spelling_Of (Tok_Type)
1310 or else Bad_Spelling_Of (Tok_Task)
1311 or else Bad_Spelling_Of (Tok_Use)
1312 or else Bad_Spelling_Of (Tok_For)
1317 -- Otherwise we definitely have an ordinary identifier with a junk
1318 -- token after it. Just complain that we expect a declaration, and
1319 -- skip to a semicolon
1322 Set_Declaration_Expected;
1323 Resync_Past_Semicolon;
1329 -- Come here with an identifier list and colon scanned out. We now
1330 -- build the nodes for the declarative items. One node is built for
1331 -- each identifier in the list, with the type information being
1332 -- repeated by rescanning the appropriate section of source.
1334 -- First an error check, if we have two identifiers in a row, a likely
1335 -- possibility is that the first of the identifiers is an incorrectly
1338 if Token = Tok_Identifier then
1340 SS : Saved_Scan_State;
1344 Save_Scan_State (SS);
1345 Scan; -- past initial identifier
1346 I2 := (Token = Tok_Identifier);
1347 Restore_Scan_State (SS);
1351 (Bad_Spelling_Of (Tok_Access) or else
1352 Bad_Spelling_Of (Tok_Aliased) or else
1353 Bad_Spelling_Of (Tok_Constant))
1360 -- Loop through identifiers
1365 -- Check for some cases of misused Ada 95 keywords
1367 if Token_Name = Name_Aliased then
1368 Check_95_Keyword (Tok_Aliased, Tok_Array);
1369 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
1370 Check_95_Keyword (Tok_Aliased, Tok_Constant);
1375 if Token = Tok_Constant then
1376 Con_Loc := Token_Ptr;
1377 Scan; -- past CONSTANT
1379 -- Number declaration, initialization required
1381 Init_Expr := Init_Expr_Opt;
1383 if Present (Init_Expr) then
1384 if Not_Null_Present then
1385 Error_Msg_SP ("null-exclusion not allowed in "
1386 & "numeric expression");
1389 Decl_Node := New_Node (N_Number_Declaration, Ident_Sloc);
1390 Set_Expression (Decl_Node, Init_Expr);
1392 -- Constant object declaration
1395 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1396 Set_Constant_Present (Decl_Node, True);
1398 if Token_Name = Name_Aliased then
1399 Check_95_Keyword (Tok_Aliased, Tok_Array);
1400 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
1403 if Token = Tok_Aliased then
1404 Error_Msg_SC ("ALIASED should be before CONSTANT");
1405 Scan; -- past ALIASED
1406 Set_Aliased_Present (Decl_Node, True);
1409 if Token = Tok_Array then
1410 Set_Object_Definition
1411 (Decl_Node, P_Array_Type_Definition);
1414 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1415 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1417 Set_Object_Definition (Decl_Node,
1418 P_Subtype_Indication (Not_Null_Present));
1421 if Token = Tok_Renames then
1423 ("CONSTANT not permitted in renaming declaration",
1425 Scan; -- Past renames
1426 Discard_Junk_Node (P_Name);
1432 elsif Token = Tok_Exception then
1433 Scan; -- past EXCEPTION
1435 if Token_Is_Renames then
1438 New_Node (N_Exception_Renaming_Declaration, Ident_Sloc);
1439 Set_Name (Decl_Node, P_Qualified_Simple_Name_Resync);
1442 Decl_Node := New_Node (N_Exception_Declaration, Prev_Token_Ptr);
1445 -- Aliased case (note that an object definition is required)
1447 elsif Token = Tok_Aliased then
1448 Scan; -- past ALIASED
1449 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1450 Set_Aliased_Present (Decl_Node, True);
1452 if Token = Tok_Constant then
1453 Scan; -- past CONSTANT
1454 Set_Constant_Present (Decl_Node, True);
1457 if Token = Tok_Array then
1458 Set_Object_Definition
1459 (Decl_Node, P_Array_Type_Definition);
1462 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1463 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1464 Set_Object_Definition (Decl_Node,
1465 P_Subtype_Indication (Not_Null_Present));
1470 elsif Token = Tok_Array then
1471 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1472 Set_Object_Definition (Decl_Node, P_Array_Type_Definition);
1474 -- Ada 2005 (AI-254)
1476 elsif Token = Tok_Not then
1478 -- OBJECT_DECLARATION ::=
1479 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1480 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1482 -- OBJECT_RENAMING_DECLARATION ::=
1484 -- | DEFINING_IDENTIFIER : ACCESS_DEFINITION renames object_NAME;
1486 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1488 if Token = Tok_Access then
1489 if Ada_Version < Ada_05 then
1491 ("generalized use of anonymous access types " &
1492 "is an Ada 2005 extension");
1493 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1496 Acc_Node := P_Access_Definition (Not_Null_Present);
1498 if Token /= Tok_Renames then
1499 Error_Msg_SC ("RENAMES expected");
1503 Scan; -- past renames
1506 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1507 Set_Access_Definition (Decl_Node, Acc_Node);
1508 Set_Name (Decl_Node, P_Name);
1511 Type_Node := P_Subtype_Mark;
1513 -- Object renaming declaration
1515 if Token_Is_Renames then
1517 ("null-exclusion not allowed in object renamings");
1520 -- Object declaration
1523 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1524 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1525 Set_Object_Definition
1527 P_Subtype_Indication (Type_Node, Not_Null_Present));
1529 -- RENAMES at this point means that we had the combination
1530 -- of a constraint on the Type_Node and renames, which is
1533 if Token_Is_Renames then
1534 Error_Msg_N ("constraint not allowed in object renaming "
1536 Constraint (Object_Definition (Decl_Node)));
1542 -- Ada 2005 (AI-230): Access Definition case
1544 elsif Token = Tok_Access then
1545 if Ada_Version < Ada_05 then
1547 ("generalized use of anonymous access types " &
1548 "is an Ada 2005 extension");
1549 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1552 Acc_Node := P_Access_Definition (Null_Exclusion_Present => False);
1554 if Token /= Tok_Renames then
1555 Error_Msg_SC ("RENAMES expected");
1559 Scan; -- past renames
1562 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1563 Set_Access_Definition (Decl_Node, Acc_Node);
1564 Set_Name (Decl_Node, P_Name);
1566 -- Subtype indication case
1569 Type_Node := P_Subtype_Mark;
1571 -- Object renaming declaration
1573 if Token_Is_Renames then
1576 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1577 Set_Subtype_Mark (Decl_Node, Type_Node);
1578 Set_Name (Decl_Node, P_Name);
1580 -- Object declaration
1583 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1584 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1585 Set_Object_Definition
1587 P_Subtype_Indication (Type_Node, Not_Null_Present));
1589 -- RENAMES at this point means that we had the combination of
1590 -- a constraint on the Type_Node and renames, which is illegal
1592 if Token_Is_Renames then
1594 ("constraint not allowed in object renaming declaration",
1595 Constraint (Object_Definition (Decl_Node)));
1601 -- Scan out initialization, allowed only for object declaration
1603 Init_Loc := Token_Ptr;
1604 Init_Expr := Init_Expr_Opt;
1606 if Present (Init_Expr) then
1607 if Nkind (Decl_Node) = N_Object_Declaration then
1608 Set_Expression (Decl_Node, Init_Expr);
1610 Error_Msg ("initialization not allowed here", Init_Loc);
1615 Set_Defining_Identifier (Decl_Node, Idents (Ident));
1618 if Ident < Num_Idents then
1619 Set_More_Ids (Decl_Node, True);
1623 Set_Prev_Ids (Decl_Node, True);
1627 Append (Decl_Node, Decls);
1628 exit Ident_Loop when Ident = Num_Idents;
1629 Restore_Scan_State (Scan_State);
1632 end loop Ident_Loop;
1635 end P_Identifier_Declarations;
1637 -------------------------------
1638 -- 3.3.1 Object Declaration --
1639 -------------------------------
1641 -- OBJECT DECLARATION ::=
1642 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1643 -- SUBTYPE_INDICATION [:= EXPRESSION];
1644 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1645 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1646 -- | SINGLE_TASK_DECLARATION
1647 -- | SINGLE_PROTECTED_DECLARATION
1649 -- Cases starting with TASK are parsed by P_Task (9.1)
1650 -- Cases starting with PROTECTED are parsed by P_Protected (9.4)
1651 -- All other cases are parsed by P_Identifier_Declarations (3.3)
1653 -------------------------------------
1654 -- 3.3.1 Defining Identifier List --
1655 -------------------------------------
1657 -- DEFINING_IDENTIFIER_LIST ::=
1658 -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
1660 -- Always parsed by the construct in which it appears. See special
1661 -- section on "Handling of Defining Identifier Lists" in this unit.
1663 -------------------------------
1664 -- 3.3.2 Number Declaration --
1665 -------------------------------
1667 -- Parsed by P_Identifier_Declarations (3.3)
1669 -------------------------------------------------------------------------
1670 -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) --
1671 -------------------------------------------------------------------------
1673 -- DERIVED_TYPE_DEFINITION ::=
1674 -- [abstract] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
1675 -- [[AND interface_list] RECORD_EXTENSION_PART]
1677 -- PRIVATE_EXTENSION_DECLARATION ::=
1678 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
1679 -- [abstract] new ancestor_SUBTYPE_INDICATION
1680 -- [AND interface_list] with PRIVATE;
1682 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
1684 -- The caller has already scanned out the part up to the NEW, and Token
1685 -- either contains Tok_New (or ought to, if it doesn't this procedure
1686 -- will post an appropriate "NEW expected" message).
1688 -- Note: the caller is responsible for filling in the Sloc field of
1689 -- the returned node in the private extension declaration case as
1690 -- well as the stuff relating to the discriminant part.
1692 -- Error recovery: can raise Error_Resync;
1694 function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id is
1695 Typedef_Node : Node_Id;
1696 Typedecl_Node : Node_Id;
1697 Not_Null_Present : Boolean := False;
1700 Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
1703 if Token = Tok_Abstract then
1704 Error_Msg_SC ("ABSTRACT must come before NEW, not after");
1708 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1709 Set_Null_Exclusion_Present (Typedef_Node, Not_Null_Present);
1710 Set_Subtype_Indication (Typedef_Node,
1711 P_Subtype_Indication (Not_Null_Present));
1713 -- Ada 2005 (AI-251): Deal with interfaces
1715 if Token = Tok_And then
1718 if Ada_Version < Ada_05 then
1720 ("abstract interface is an Ada 2005 extension");
1721 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1724 Set_Interface_List (Typedef_Node, New_List);
1727 Append (P_Qualified_Simple_Name, Interface_List (Typedef_Node));
1728 exit when Token /= Tok_And;
1732 if Token /= Tok_With then
1733 Error_Msg_SC ("WITH expected");
1738 -- Deal with record extension, note that we assume that a WITH is
1739 -- missing in the case of "type X is new Y record ..." or in the
1740 -- case of "type X is new Y null record".
1743 or else Token = Tok_Record
1744 or else Token = Tok_Null
1746 T_With; -- past WITH or give error message
1748 if Token = Tok_Limited then
1750 ("LIMITED keyword not allowed in private extension");
1751 Scan; -- ignore LIMITED
1754 -- Private extension declaration
1756 if Token = Tok_Private then
1757 Scan; -- past PRIVATE
1759 -- Throw away the type definition node and build the type
1760 -- declaration node. Note the caller must set the Sloc,
1761 -- Discriminant_Specifications, Unknown_Discriminants_Present,
1762 -- and Defined_Identifier fields in the returned node.
1765 Make_Private_Extension_Declaration (No_Location,
1766 Defining_Identifier => Empty,
1767 Subtype_Indication => Subtype_Indication (Typedef_Node),
1768 Abstract_Present => Abstract_Present (Typedef_Node));
1770 Delete_Node (Typedef_Node);
1771 return Typedecl_Node;
1773 -- Derived type definition with record extension part
1776 Set_Record_Extension_Part (Typedef_Node, P_Record_Definition);
1777 return Typedef_Node;
1780 -- Derived type definition with no record extension part
1783 return Typedef_Node;
1785 end P_Derived_Type_Def_Or_Private_Ext_Decl;
1787 ---------------------------
1788 -- 3.5 Range Constraint --
1789 ---------------------------
1791 -- RANGE_CONSTRAINT ::= range RANGE
1793 -- The caller has checked that the initial token is RANGE
1795 -- Error recovery: cannot raise Error_Resync
1797 function P_Range_Constraint return Node_Id is
1798 Range_Node : Node_Id;
1801 Range_Node := New_Node (N_Range_Constraint, Token_Ptr);
1803 Set_Range_Expression (Range_Node, P_Range);
1805 end P_Range_Constraint;
1812 -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
1814 -- Note: the range that appears in a membership test is parsed by
1815 -- P_Range_Or_Subtype_Mark (3.5).
1817 -- Error recovery: cannot raise Error_Resync
1819 function P_Range return Node_Id is
1820 Expr_Node : Node_Id;
1821 Range_Node : Node_Id;
1824 Expr_Node := P_Simple_Expression_Or_Range_Attribute;
1826 if Expr_Form = EF_Range_Attr then
1829 elsif Token = Tok_Dot_Dot then
1830 Range_Node := New_Node (N_Range, Token_Ptr);
1831 Set_Low_Bound (Range_Node, Expr_Node);
1833 Expr_Node := P_Expression;
1834 Check_Simple_Expression (Expr_Node);
1835 Set_High_Bound (Range_Node, Expr_Node);
1838 -- Anything else is an error
1841 T_Dot_Dot; -- force missing .. message
1846 ----------------------------------
1847 -- 3.5 P_Range_Or_Subtype_Mark --
1848 ----------------------------------
1851 -- RANGE_ATTRIBUTE_REFERENCE
1852 -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
1854 -- This routine scans out the range or subtype mark that forms the right
1855 -- operand of a membership test.
1857 -- Note: as documented in the Sinfo interface, although the syntax only
1858 -- allows a subtype mark, we in fact allow any simple expression to be
1859 -- returned from this routine. The semantics is responsible for issuing
1860 -- an appropriate message complaining if the argument is not a name.
1861 -- This simplifies the coding and error recovery processing in the
1862 -- parser, and in any case it is preferable not to consider this a
1863 -- syntax error and to continue with the semantic analysis.
1865 -- Error recovery: cannot raise Error_Resync
1867 function P_Range_Or_Subtype_Mark return Node_Id is
1868 Expr_Node : Node_Id;
1869 Range_Node : Node_Id;
1872 Expr_Node := P_Simple_Expression_Or_Range_Attribute;
1874 if Expr_Form = EF_Range_Attr then
1877 -- Simple_Expression .. Simple_Expression
1879 elsif Token = Tok_Dot_Dot then
1880 Check_Simple_Expression (Expr_Node);
1881 Range_Node := New_Node (N_Range, Token_Ptr);
1882 Set_Low_Bound (Range_Node, Expr_Node);
1884 Set_High_Bound (Range_Node, P_Simple_Expression);
1887 -- Case of subtype mark (optionally qualified simple name or an
1888 -- attribute whose prefix is an optionally qualifed simple name)
1890 elsif Expr_Form = EF_Simple_Name
1891 or else Nkind (Expr_Node) = N_Attribute_Reference
1893 -- Check for error of range constraint after a subtype mark
1895 if Token = Tok_Range then
1897 ("range constraint not allowed in membership test");
1901 -- Check for error of DIGITS or DELTA after a subtype mark
1903 elsif Token = Tok_Digits or else Token = Tok_Delta then
1905 ("accuracy definition not allowed in membership test");
1906 Scan; -- past DIGITS or DELTA
1909 elsif Token = Tok_Apostrophe then
1910 return P_Subtype_Mark_Attribute (Expr_Node);
1916 -- At this stage, we have some junk following the expression. We
1917 -- really can't tell what is wrong, might be a missing semicolon,
1918 -- or a missing THEN, or whatever. Our caller will figure it out!
1923 end P_Range_Or_Subtype_Mark;
1925 ----------------------------------------
1926 -- 3.5.1 Enumeration Type Definition --
1927 ----------------------------------------
1929 -- ENUMERATION_TYPE_DEFINITION ::=
1930 -- (ENUMERATION_LITERAL_SPECIFICATION
1931 -- {, ENUMERATION_LITERAL_SPECIFICATION})
1933 -- The caller has already scanned out the TYPE keyword
1935 -- Error recovery: can raise Error_Resync;
1937 function P_Enumeration_Type_Definition return Node_Id is
1938 Typedef_Node : Node_Id;
1941 Typedef_Node := New_Node (N_Enumeration_Type_Definition, Token_Ptr);
1942 Set_Literals (Typedef_Node, New_List);
1947 Append (P_Enumeration_Literal_Specification, Literals (Typedef_Node));
1948 exit when not Comma_Present;
1952 return Typedef_Node;
1953 end P_Enumeration_Type_Definition;
1955 ----------------------------------------------
1956 -- 3.5.1 Enumeration Literal Specification --
1957 ----------------------------------------------
1959 -- ENUMERATION_LITERAL_SPECIFICATION ::=
1960 -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
1962 -- Error recovery: can raise Error_Resync
1964 function P_Enumeration_Literal_Specification return Node_Id is
1966 if Token = Tok_Char_Literal then
1967 return P_Defining_Character_Literal;
1969 return P_Defining_Identifier (C_Comma_Right_Paren);
1971 end P_Enumeration_Literal_Specification;
1973 ---------------------------------------
1974 -- 3.5.1 Defining_Character_Literal --
1975 ---------------------------------------
1977 -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
1979 -- Error recovery: cannot raise Error_Resync
1981 -- The caller has checked that the current token is a character literal
1983 function P_Defining_Character_Literal return Node_Id is
1984 Literal_Node : Node_Id;
1987 Literal_Node := Token_Node;
1988 Change_Character_Literal_To_Defining_Character_Literal (Literal_Node);
1989 Scan; -- past character literal
1990 return Literal_Node;
1991 end P_Defining_Character_Literal;
1993 ------------------------------------
1994 -- 3.5.4 Integer Type Definition --
1995 ------------------------------------
1997 -- Parsed by P_Type_Declaration (3.2.1)
1999 -------------------------------------------
2000 -- 3.5.4 Signed Integer Type Definition --
2001 -------------------------------------------
2003 -- SIGNED_INTEGER_TYPE_DEFINITION ::=
2004 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2006 -- Normally the initial token on entry is RANGE, but in some
2007 -- error conditions, the range token was missing and control is
2008 -- passed with Token pointing to first token of the first expression.
2010 -- Error recovery: cannot raise Error_Resync
2012 function P_Signed_Integer_Type_Definition return Node_Id is
2013 Typedef_Node : Node_Id;
2014 Expr_Node : Node_Id;
2017 Typedef_Node := New_Node (N_Signed_Integer_Type_Definition, Token_Ptr);
2019 if Token = Tok_Range then
2023 Expr_Node := P_Expression;
2024 Check_Simple_Expression (Expr_Node);
2025 Set_Low_Bound (Typedef_Node, Expr_Node);
2027 Expr_Node := P_Expression;
2028 Check_Simple_Expression (Expr_Node);
2029 Set_High_Bound (Typedef_Node, Expr_Node);
2030 return Typedef_Node;
2031 end P_Signed_Integer_Type_Definition;
2033 ------------------------------------
2034 -- 3.5.4 Modular Type Definition --
2035 ------------------------------------
2037 -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
2039 -- The caller has checked that the initial token is MOD
2041 -- Error recovery: cannot raise Error_Resync
2043 function P_Modular_Type_Definition return Node_Id is
2044 Typedef_Node : Node_Id;
2047 if Ada_Version = Ada_83 then
2048 Error_Msg_SC ("(Ada 83): modular types not allowed");
2051 Typedef_Node := New_Node (N_Modular_Type_Definition, Token_Ptr);
2053 Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
2055 -- Handle mod L..R cleanly
2057 if Token = Tok_Dot_Dot then
2058 Error_Msg_SC ("range not allowed for modular type");
2060 Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
2063 return Typedef_Node;
2064 end P_Modular_Type_Definition;
2066 ---------------------------------
2067 -- 3.5.6 Real Type Definition --
2068 ---------------------------------
2070 -- Parsed by P_Type_Declaration (3.2.1)
2072 --------------------------------------
2073 -- 3.5.7 Floating Point Definition --
2074 --------------------------------------
2076 -- FLOATING_POINT_DEFINITION ::=
2077 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2079 -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
2081 -- The caller has checked that the initial token is DIGITS
2083 -- Error recovery: cannot raise Error_Resync
2085 function P_Floating_Point_Definition return Node_Id is
2086 Digits_Loc : constant Source_Ptr := Token_Ptr;
2088 Expr_Node : Node_Id;
2091 Scan; -- past DIGITS
2092 Expr_Node := P_Expression_No_Right_Paren;
2093 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2095 -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
2097 if Token = Tok_Delta then
2098 Error_Msg_SC ("DELTA must come before DIGITS");
2099 Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Digits_Loc);
2101 Set_Delta_Expression (Def_Node, P_Expression_No_Right_Paren);
2103 -- OK floating-point definition
2106 Def_Node := New_Node (N_Floating_Point_Definition, Digits_Loc);
2109 Set_Digits_Expression (Def_Node, Expr_Node);
2110 Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt);
2112 end P_Floating_Point_Definition;
2114 -------------------------------------
2115 -- 3.5.7 Real Range Specification --
2116 -------------------------------------
2118 -- REAL_RANGE_SPECIFICATION ::=
2119 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2121 -- Error recovery: cannot raise Error_Resync
2123 function P_Real_Range_Specification_Opt return Node_Id is
2124 Specification_Node : Node_Id;
2125 Expr_Node : Node_Id;
2128 if Token = Tok_Range then
2129 Specification_Node :=
2130 New_Node (N_Real_Range_Specification, Token_Ptr);
2132 Expr_Node := P_Expression_No_Right_Paren;
2133 Check_Simple_Expression (Expr_Node);
2134 Set_Low_Bound (Specification_Node, Expr_Node);
2136 Expr_Node := P_Expression_No_Right_Paren;
2137 Check_Simple_Expression (Expr_Node);
2138 Set_High_Bound (Specification_Node, Expr_Node);
2139 return Specification_Node;
2143 end P_Real_Range_Specification_Opt;
2145 -----------------------------------
2146 -- 3.5.9 Fixed Point Definition --
2147 -----------------------------------
2149 -- FIXED_POINT_DEFINITION ::=
2150 -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
2152 -- ORDINARY_FIXED_POINT_DEFINITION ::=
2153 -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION
2155 -- DECIMAL_FIXED_POINT_DEFINITION ::=
2156 -- delta static_EXPRESSION
2157 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2159 -- The caller has checked that the initial token is DELTA
2161 -- Error recovery: cannot raise Error_Resync
2163 function P_Fixed_Point_Definition return Node_Id is
2164 Delta_Node : Node_Id;
2165 Delta_Loc : Source_Ptr;
2167 Expr_Node : Node_Id;
2170 Delta_Loc := Token_Ptr;
2172 Delta_Node := P_Expression_No_Right_Paren;
2173 Check_Simple_Expression_In_Ada_83 (Delta_Node);
2175 if Token = Tok_Digits then
2176 if Ada_Version = Ada_83 then
2177 Error_Msg_SC ("(Ada 83) decimal fixed type not allowed!");
2180 Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Delta_Loc);
2181 Scan; -- past DIGITS
2182 Expr_Node := P_Expression_No_Right_Paren;
2183 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2184 Set_Digits_Expression (Def_Node, Expr_Node);
2187 Def_Node := New_Node (N_Ordinary_Fixed_Point_Definition, Delta_Loc);
2189 -- Range is required in ordinary fixed point case
2191 if Token /= Tok_Range then
2192 Error_Msg_AP ("range must be given for fixed-point type");
2197 Set_Delta_Expression (Def_Node, Delta_Node);
2198 Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt);
2200 end P_Fixed_Point_Definition;
2202 --------------------------------------------
2203 -- 3.5.9 Ordinary Fixed Point Definition --
2204 --------------------------------------------
2206 -- Parsed by P_Fixed_Point_Definition (3.5.9)
2208 -------------------------------------------
2209 -- 3.5.9 Decimal Fixed Point Definition --
2210 -------------------------------------------
2212 -- Parsed by P_Decimal_Point_Definition (3.5.9)
2214 ------------------------------
2215 -- 3.5.9 Digits Constraint --
2216 ------------------------------
2218 -- DIGITS_CONSTRAINT ::=
2219 -- digits static_EXPRESSION [RANGE_CONSTRAINT]
2221 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2223 -- The caller has checked that the initial token is DIGITS
2225 function P_Digits_Constraint return Node_Id is
2226 Constraint_Node : Node_Id;
2227 Expr_Node : Node_Id;
2230 Constraint_Node := New_Node (N_Digits_Constraint, Token_Ptr);
2231 Scan; -- past DIGITS
2232 Expr_Node := P_Expression_No_Right_Paren;
2233 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2234 Set_Digits_Expression (Constraint_Node, Expr_Node);
2236 if Token = Tok_Range then
2237 Set_Range_Constraint (Constraint_Node, P_Range_Constraint);
2240 return Constraint_Node;
2241 end P_Digits_Constraint;
2243 -----------------------------
2244 -- 3.5.9 Delta Constraint --
2245 -----------------------------
2247 -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
2249 -- Note: this is an obsolescent feature in Ada 95 (I.3)
2251 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2253 -- The caller has checked that the initial token is DELTA
2255 -- Error recovery: cannot raise Error_Resync
2257 function P_Delta_Constraint return Node_Id is
2258 Constraint_Node : Node_Id;
2259 Expr_Node : Node_Id;
2262 Constraint_Node := New_Node (N_Delta_Constraint, Token_Ptr);
2264 Expr_Node := P_Expression_No_Right_Paren;
2265 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2266 Set_Delta_Expression (Constraint_Node, Expr_Node);
2268 if Token = Tok_Range then
2269 Set_Range_Constraint (Constraint_Node, P_Range_Constraint);
2272 return Constraint_Node;
2273 end P_Delta_Constraint;
2275 --------------------------------
2276 -- 3.6 Array Type Definition --
2277 --------------------------------
2279 -- ARRAY_TYPE_DEFINITION ::=
2280 -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
2282 -- UNCONSTRAINED_ARRAY_DEFINITION ::=
2283 -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
2284 -- COMPONENT_DEFINITION
2286 -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
2288 -- CONSTRAINED_ARRAY_DEFINITION ::=
2289 -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
2290 -- COMPONENT_DEFINITION
2292 -- DISCRETE_SUBTYPE_DEFINITION ::=
2293 -- DISCRETE_SUBTYPE_INDICATION | RANGE
2295 -- COMPONENT_DEFINITION ::=
2296 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
2298 -- The caller has checked that the initial token is ARRAY
2300 -- Error recovery: can raise Error_Resync
2302 function P_Array_Type_Definition return Node_Id is
2303 Array_Loc : Source_Ptr;
2304 CompDef_Node : Node_Id;
2306 Not_Null_Present : Boolean := False;
2307 Subs_List : List_Id;
2308 Scan_State : Saved_Scan_State;
2309 Aliased_Present : Boolean := False;
2312 Array_Loc := Token_Ptr;
2314 Subs_List := New_List;
2317 -- It's quite tricky to disentangle these two possibilities, so we do
2318 -- a prescan to determine which case we have and then reset the scan.
2319 -- The prescan skips past possible subtype mark tokens.
2321 Save_Scan_State (Scan_State); -- just after paren
2323 while Token in Token_Class_Desig or else
2324 Token = Tok_Dot or else
2325 Token = Tok_Apostrophe -- because of 'BASE, 'CLASS
2330 -- If we end up on RANGE <> then we have the unconstrained case. We
2331 -- will also allow the RANGE to be omitted, just to improve error
2332 -- handling for a case like array (integer <>) of integer;
2334 Scan; -- past possible RANGE or <>
2336 if (Prev_Token = Tok_Range and then Token = Tok_Box) or else
2337 Prev_Token = Tok_Box
2339 Def_Node := New_Node (N_Unconstrained_Array_Definition, Array_Loc);
2340 Restore_Scan_State (Scan_State); -- to first subtype mark
2343 Append (P_Subtype_Mark_Resync, Subs_List);
2346 exit when Token = Tok_Right_Paren or else Token = Tok_Of;
2350 Set_Subtype_Marks (Def_Node, Subs_List);
2353 Def_Node := New_Node (N_Constrained_Array_Definition, Array_Loc);
2354 Restore_Scan_State (Scan_State); -- to first discrete range
2357 Append (P_Discrete_Subtype_Definition, Subs_List);
2358 exit when not Comma_Present;
2361 Set_Discrete_Subtype_Definitions (Def_Node, Subs_List);
2367 CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
2369 if Token_Name = Name_Aliased then
2370 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
2373 if Token = Tok_Aliased then
2374 Aliased_Present := True;
2375 Scan; -- past ALIASED
2378 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254)
2380 -- Ada 2005 (AI-230): Access Definition case
2382 if Token = Tok_Access then
2383 if Ada_Version < Ada_05 then
2385 ("generalized use of anonymous access types " &
2386 "is an Ada 2005 extension");
2387 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
2390 if Aliased_Present then
2391 Error_Msg_SP ("ALIASED not allowed here");
2394 Set_Subtype_Indication (CompDef_Node, Empty);
2395 Set_Aliased_Present (CompDef_Node, False);
2396 Set_Access_Definition (CompDef_Node,
2397 P_Access_Definition (Not_Null_Present));
2400 Set_Access_Definition (CompDef_Node, Empty);
2401 Set_Aliased_Present (CompDef_Node, Aliased_Present);
2402 Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
2403 Set_Subtype_Indication (CompDef_Node,
2404 P_Subtype_Indication (Not_Null_Present));
2407 Set_Component_Definition (Def_Node, CompDef_Node);
2410 end P_Array_Type_Definition;
2412 -----------------------------------------
2413 -- 3.6 Unconstrained Array Definition --
2414 -----------------------------------------
2416 -- Parsed by P_Array_Type_Definition (3.6)
2418 ---------------------------------------
2419 -- 3.6 Constrained Array Definition --
2420 ---------------------------------------
2422 -- Parsed by P_Array_Type_Definition (3.6)
2424 --------------------------------------
2425 -- 3.6 Discrete Subtype Definition --
2426 --------------------------------------
2428 -- DISCRETE_SUBTYPE_DEFINITION ::=
2429 -- discrete_SUBTYPE_INDICATION | RANGE
2431 -- Note: the discrete subtype definition appearing in a constrained
2432 -- array definition is parsed by P_Array_Type_Definition (3.6)
2434 -- Error recovery: cannot raise Error_Resync
2436 function P_Discrete_Subtype_Definition return Node_Id is
2438 -- The syntax of a discrete subtype definition is identical to that
2439 -- of a discrete range, so we simply share the same parsing code.
2441 return P_Discrete_Range;
2442 end P_Discrete_Subtype_Definition;
2444 -------------------------------
2445 -- 3.6 Component Definition --
2446 -------------------------------
2448 -- For the array case, parsed by P_Array_Type_Definition (3.6)
2449 -- For the record case, parsed by P_Component_Declaration (3.8)
2451 -----------------------------
2452 -- 3.6.1 Index Constraint --
2453 -----------------------------
2455 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2457 ---------------------------
2458 -- 3.6.1 Discrete Range --
2459 ---------------------------
2461 -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
2463 -- The possible forms for a discrete range are:
2465 -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2)
2466 -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2)
2467 -- Range_Attribute (RANGE, 3.5)
2468 -- Simple_Expression .. Simple_Expression (RANGE, 3.5)
2470 -- Error recovery: cannot raise Error_Resync
2472 function P_Discrete_Range return Node_Id is
2473 Expr_Node : Node_Id;
2474 Range_Node : Node_Id;
2477 Expr_Node := P_Simple_Expression_Or_Range_Attribute;
2479 if Expr_Form = EF_Range_Attr then
2482 elsif Token = Tok_Range then
2483 if Expr_Form /= EF_Simple_Name then
2484 Error_Msg_SC ("range must be preceded by subtype mark");
2487 return P_Subtype_Indication (Expr_Node);
2489 -- Check Expression .. Expression case
2491 elsif Token = Tok_Dot_Dot then
2492 Range_Node := New_Node (N_Range, Token_Ptr);
2493 Set_Low_Bound (Range_Node, Expr_Node);
2495 Expr_Node := P_Expression;
2496 Check_Simple_Expression (Expr_Node);
2497 Set_High_Bound (Range_Node, Expr_Node);
2500 -- Otherwise we must have a subtype mark
2502 elsif Expr_Form = EF_Simple_Name then
2505 -- If incorrect, complain that we expect ..
2511 end P_Discrete_Range;
2513 ----------------------------
2514 -- 3.7 Discriminant Part --
2515 ----------------------------
2517 -- DISCRIMINANT_PART ::=
2518 -- UNKNOWN_DISCRIMINANT_PART
2519 -- | KNOWN_DISCRIMINANT_PART
2521 -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
2522 -- or P_Unknown_Discriminant_Part (3.7), since we know which we want.
2524 ------------------------------------
2525 -- 3.7 Unknown Discriminant Part --
2526 ------------------------------------
2528 -- UNKNOWN_DISCRIMINANT_PART ::= (<>)
2530 -- If no unknown discriminant part is present, then False is returned,
2531 -- otherwise the unknown discriminant is scanned out and True is returned.
2533 -- Error recovery: cannot raise Error_Resync
2535 function P_Unknown_Discriminant_Part_Opt return Boolean is
2536 Scan_State : Saved_Scan_State;
2539 if Token /= Tok_Left_Paren then
2543 Save_Scan_State (Scan_State);
2544 Scan; -- past the left paren
2546 if Token = Tok_Box then
2547 if Ada_Version = Ada_83 then
2548 Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!");
2551 Scan; -- past the box
2552 T_Right_Paren; -- must be followed by right paren
2556 Restore_Scan_State (Scan_State);
2560 end P_Unknown_Discriminant_Part_Opt;
2562 ----------------------------------
2563 -- 3.7 Known Discriminant Part --
2564 ----------------------------------
2566 -- KNOWN_DISCRIMINANT_PART ::=
2567 -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
2569 -- DISCRIMINANT_SPECIFICATION ::=
2570 -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
2571 -- [:= DEFAULT_EXPRESSION]
2572 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
2573 -- [:= DEFAULT_EXPRESSION]
2575 -- If no known discriminant part is present, then No_List is returned
2577 -- Error recovery: cannot raise Error_Resync
2579 function P_Known_Discriminant_Part_Opt return List_Id is
2580 Specification_Node : Node_Id;
2581 Specification_List : List_Id;
2582 Ident_Sloc : Source_Ptr;
2583 Scan_State : Saved_Scan_State;
2585 Not_Null_Present : Boolean;
2588 Idents : array (Int range 1 .. 4096) of Entity_Id;
2589 -- This array holds the list of defining identifiers. The upper bound
2590 -- of 4096 is intended to be essentially infinite, and we do not even
2591 -- bother to check for it being exceeded.
2594 if Token = Tok_Left_Paren then
2595 Specification_List := New_List;
2597 P_Pragmas_Misplaced;
2599 Specification_Loop : loop
2601 Ident_Sloc := Token_Ptr;
2602 Idents (1) := P_Defining_Identifier (C_Comma_Colon);
2605 while Comma_Present loop
2606 Num_Idents := Num_Idents + 1;
2607 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
2612 -- If there are multiple identifiers, we repeatedly scan the
2613 -- type and initialization expression information by resetting
2614 -- the scan pointer (so that we get completely separate trees
2615 -- for each occurrence).
2617 if Num_Idents > 1 then
2618 Save_Scan_State (Scan_State);
2621 -- Loop through defining identifiers in list
2625 Specification_Node :=
2626 New_Node (N_Discriminant_Specification, Ident_Sloc);
2627 Set_Defining_Identifier (Specification_Node, Idents (Ident));
2628 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
2630 if Token = Tok_Access then
2631 if Ada_Version = Ada_83 then
2633 ("(Ada 83) access discriminant not allowed!");
2636 Set_Discriminant_Type
2637 (Specification_Node,
2638 P_Access_Definition (Not_Null_Present));
2641 Set_Discriminant_Type
2642 (Specification_Node, P_Subtype_Mark);
2644 Set_Null_Exclusion_Present -- Ada 2005 (AI-231)
2645 (Specification_Node, Not_Null_Present);
2649 (Specification_Node, Init_Expr_Opt (True));
2652 Set_Prev_Ids (Specification_Node, True);
2655 if Ident < Num_Idents then
2656 Set_More_Ids (Specification_Node, True);
2659 Append (Specification_Node, Specification_List);
2660 exit Ident_Loop when Ident = Num_Idents;
2662 Restore_Scan_State (Scan_State);
2663 end loop Ident_Loop;
2665 exit Specification_Loop when Token /= Tok_Semicolon;
2667 P_Pragmas_Misplaced;
2668 end loop Specification_Loop;
2671 return Specification_List;
2676 end P_Known_Discriminant_Part_Opt;
2678 -------------------------------------
2679 -- 3.7 DIscriminant Specification --
2680 -------------------------------------
2682 -- Parsed by P_Known_Discriminant_Part_Opt (3.7)
2684 -----------------------------
2685 -- 3.7 Default Expression --
2686 -----------------------------
2688 -- Always parsed (simply as an Expression) by the parent construct
2690 ------------------------------------
2691 -- 3.7.1 Discriminant Constraint --
2692 ------------------------------------
2694 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2696 --------------------------------------------------------
2697 -- 3.7.1 Index or Discriminant Constraint (also 3.6) --
2698 --------------------------------------------------------
2700 -- DISCRIMINANT_CONSTRAINT ::=
2701 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
2703 -- DISCRIMINANT_ASSOCIATION ::=
2704 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2707 -- This routine parses either an index or a discriminant constraint. As
2708 -- is clear from the above grammar, it is often possible to clearly
2709 -- determine which of the two possibilities we have, but there are
2710 -- cases (those in which we have a series of expressions of the same
2711 -- syntactic form as subtype indications), where we cannot tell. Since
2712 -- this means that in any case the semantic phase has to distinguish
2713 -- between the two, there is not much point in the parser trying to
2714 -- distinguish even those cases where the difference is clear. In any
2715 -- case, if we have a situation like:
2717 -- (A => 123, 235 .. 500)
2719 -- it is not clear which of the two items is the wrong one, better to
2720 -- let the semantic phase give a clear message. Consequently, this
2721 -- routine in general returns a list of items which can be either
2722 -- discrete ranges or discriminant associations.
2724 -- The caller has checked that the initial token is a left paren
2726 -- Error recovery: can raise Error_Resync
2728 function P_Index_Or_Discriminant_Constraint return Node_Id is
2729 Scan_State : Saved_Scan_State;
2730 Constr_Node : Node_Id;
2731 Constr_List : List_Id;
2732 Expr_Node : Node_Id;
2733 Result_Node : Node_Id;
2736 Result_Node := New_Node (N_Index_Or_Discriminant_Constraint, Token_Ptr);
2738 Constr_List := New_List;
2739 Set_Constraints (Result_Node, Constr_List);
2741 -- The two syntactic forms are a little mixed up, so what we are doing
2742 -- here is looking at the first entry to determine which case we have
2744 -- A discriminant constraint is a list of discriminant associations,
2745 -- which have one of the following possible forms:
2749 -- Id | Id | .. | Id => Expression
2751 -- An index constraint is a list of discrete ranges which have one
2752 -- of the following possible forms:
2755 -- Subtype_Mark range Range
2757 -- Simple_Expression .. Simple_Expression
2759 -- Loop through discriminants in list
2762 -- Check cases of Id => Expression or Id | Id => Expression
2764 if Token = Tok_Identifier then
2765 Save_Scan_State (Scan_State); -- at Id
2768 if Token = Tok_Arrow or else Token = Tok_Vertical_Bar then
2769 Restore_Scan_State (Scan_State); -- to Id
2770 Append (P_Discriminant_Association, Constr_List);
2773 Restore_Scan_State (Scan_State); -- to Id
2777 -- Otherwise scan out an expression and see what we have got
2779 Expr_Node := P_Expression_Or_Range_Attribute;
2781 if Expr_Form = EF_Range_Attr then
2782 Append (Expr_Node, Constr_List);
2784 elsif Token = Tok_Range then
2785 if Expr_Form /= EF_Simple_Name then
2786 Error_Msg_SC ("subtype mark required before RANGE");
2789 Append (P_Subtype_Indication (Expr_Node), Constr_List);
2792 -- Check Simple_Expression .. Simple_Expression case
2794 elsif Token = Tok_Dot_Dot then
2795 Check_Simple_Expression (Expr_Node);
2796 Constr_Node := New_Node (N_Range, Token_Ptr);
2797 Set_Low_Bound (Constr_Node, Expr_Node);
2799 Expr_Node := P_Expression;
2800 Check_Simple_Expression (Expr_Node);
2801 Set_High_Bound (Constr_Node, Expr_Node);
2802 Append (Constr_Node, Constr_List);
2805 -- Case of an expression which could be either form
2808 Append (Expr_Node, Constr_List);
2812 -- Here with a single entry scanned
2815 exit when not Comma_Present;
2821 end P_Index_Or_Discriminant_Constraint;
2823 -------------------------------------
2824 -- 3.7.1 Discriminant Association --
2825 -------------------------------------
2827 -- DISCRIMINANT_ASSOCIATION ::=
2828 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2831 -- This routine is used only when the name list is present and the caller
2832 -- has already checked this (by scanning ahead and repositioning the
2835 -- Error_Recovery: cannot raise Error_Resync;
2837 function P_Discriminant_Association return Node_Id is
2838 Discr_Node : Node_Id;
2839 Names_List : List_Id;
2840 Ident_Sloc : Source_Ptr;
2843 Ident_Sloc := Token_Ptr;
2844 Names_List := New_List;
2847 Append (P_Identifier (C_Vertical_Bar_Arrow), Names_List);
2848 exit when Token /= Tok_Vertical_Bar;
2852 Discr_Node := New_Node (N_Discriminant_Association, Ident_Sloc);
2853 Set_Selector_Names (Discr_Node, Names_List);
2855 Set_Expression (Discr_Node, P_Expression);
2857 end P_Discriminant_Association;
2859 ---------------------------------
2860 -- 3.8 Record Type Definition --
2861 ---------------------------------
2863 -- RECORD_TYPE_DEFINITION ::=
2864 -- [[abstract] tagged] [limited] RECORD_DEFINITION
2866 -- There is no node in the tree for a record type definition. Instead
2867 -- a record definition node appears, with possible Abstract_Present,
2868 -- Tagged_Present, and Limited_Present flags set appropriately.
2870 ----------------------------
2871 -- 3.8 Record Definition --
2872 ----------------------------
2874 -- RECORD_DEFINITION ::=
2880 -- Note: in the case where a record definition node is used to represent
2881 -- a record type definition, the caller sets the Tagged_Present and
2882 -- Limited_Present flags in the resulting N_Record_Definition node as
2885 -- Note that the RECORD token at the start may be missing in certain
2886 -- error situations, so this function is expected to post the error
2888 -- Error recovery: can raise Error_Resync
2890 function P_Record_Definition return Node_Id is
2894 Rec_Node := New_Node (N_Record_Definition, Token_Ptr);
2898 if Token = Tok_Null then
2901 Set_Null_Present (Rec_Node, True);
2903 -- Case starting with RECORD keyword. Build scope stack entry. For the
2904 -- column, we use the first non-blank character on the line, to deal
2905 -- with situations such as:
2911 -- which is not official RM indentation, but is not uncommon usage
2915 Scope.Table (Scope.Last).Etyp := E_Record;
2916 Scope.Table (Scope.Last).Ecol := Start_Column;
2917 Scope.Table (Scope.Last).Sloc := Token_Ptr;
2918 Scope.Table (Scope.Last).Labl := Error;
2919 Scope.Table (Scope.Last).Junk := (Token /= Tok_Record);
2923 Set_Component_List (Rec_Node, P_Component_List);
2926 exit when Check_End;
2927 Discard_Junk_Node (P_Component_List);
2932 end P_Record_Definition;
2934 -------------------------
2935 -- 3.8 Component List --
2936 -------------------------
2938 -- COMPONENT_LIST ::=
2939 -- COMPONENT_ITEM {COMPONENT_ITEM}
2940 -- | {COMPONENT_ITEM} VARIANT_PART
2943 -- Error recovery: cannot raise Error_Resync
2945 function P_Component_List return Node_Id is
2946 Component_List_Node : Node_Id;
2947 Decls_List : List_Id;
2948 Scan_State : Saved_Scan_State;
2951 Component_List_Node := New_Node (N_Component_List, Token_Ptr);
2952 Decls_List := New_List;
2954 if Token = Tok_Null then
2957 P_Pragmas_Opt (Decls_List);
2958 Set_Null_Present (Component_List_Node, True);
2959 return Component_List_Node;
2962 P_Pragmas_Opt (Decls_List);
2964 if Token /= Tok_Case then
2965 Component_Scan_Loop : loop
2966 P_Component_Items (Decls_List);
2967 P_Pragmas_Opt (Decls_List);
2969 exit Component_Scan_Loop when Token = Tok_End
2970 or else Token = Tok_Case
2971 or else Token = Tok_When;
2973 -- We are done if we do not have an identifier. However, if
2974 -- we have a misspelled reserved identifier that is in a column
2975 -- to the right of the record definition, we will treat it as
2976 -- an identifier. It turns out to be too dangerous in practice
2977 -- to accept such a mis-spelled identifier which does not have
2978 -- this additional clue that confirms the incorrect spelling.
2980 if Token /= Tok_Identifier then
2981 if Start_Column > Scope.Table (Scope.Last).Ecol
2982 and then Is_Reserved_Identifier
2984 Save_Scan_State (Scan_State); -- at reserved id
2985 Scan; -- possible reserved id
2987 if Token = Tok_Comma or else Token = Tok_Colon then
2988 Restore_Scan_State (Scan_State);
2989 Scan_Reserved_Identifier (Force_Msg => True);
2991 -- Note reserved identifier used as field name after
2992 -- all because not followed by colon or comma
2995 Restore_Scan_State (Scan_State);
2996 exit Component_Scan_Loop;
2999 -- Non-identifier that definitely was not reserved id
3002 exit Component_Scan_Loop;
3005 end loop Component_Scan_Loop;
3008 if Token = Tok_Case then
3009 Set_Variant_Part (Component_List_Node, P_Variant_Part);
3011 -- Check for junk after variant part
3013 if Token = Tok_Identifier then
3014 Save_Scan_State (Scan_State);
3015 Scan; -- past identifier
3017 if Token = Tok_Colon then
3018 Restore_Scan_State (Scan_State);
3019 Error_Msg_SC ("component may not follow variant part");
3020 Discard_Junk_Node (P_Component_List);
3022 elsif Token = Tok_Case then
3023 Restore_Scan_State (Scan_State);
3024 Error_Msg_SC ("only one variant part allowed in a record");
3025 Discard_Junk_Node (P_Component_List);
3028 Restore_Scan_State (Scan_State);
3034 Set_Component_Items (Component_List_Node, Decls_List);
3035 return Component_List_Node;
3036 end P_Component_List;
3038 -------------------------
3039 -- 3.8 Component Item --
3040 -------------------------
3042 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
3044 -- COMPONENT_DECLARATION ::=
3045 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
3046 -- [:= DEFAULT_EXPRESSION];
3048 -- COMPONENT_DEFINITION ::=
3049 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
3051 -- Error recovery: cannot raise Error_Resync, if an error occurs,
3052 -- the scan is positioned past the following semicolon.
3054 -- Note: we do not yet allow representation clauses to appear as component
3055 -- items, do we need to add this capability sometime in the future ???
3057 procedure P_Component_Items (Decls : List_Id) is
3058 Aliased_Present : Boolean := False;
3059 CompDef_Node : Node_Id;
3060 Decl_Node : Node_Id;
3061 Scan_State : Saved_Scan_State;
3062 Not_Null_Present : Boolean := False;
3065 Ident_Sloc : Source_Ptr;
3067 Idents : array (Int range 1 .. 4096) of Entity_Id;
3068 -- This array holds the list of defining identifiers. The upper bound
3069 -- of 4096 is intended to be essentially infinite, and we do not even
3070 -- bother to check for it being exceeded.
3073 if Token /= Tok_Identifier then
3074 Error_Msg_SC ("component declaration expected");
3075 Resync_Past_Semicolon;
3079 Ident_Sloc := Token_Ptr;
3080 Idents (1) := P_Defining_Identifier (C_Comma_Colon);
3083 while Comma_Present loop
3084 Num_Idents := Num_Idents + 1;
3085 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
3090 -- If there are multiple identifiers, we repeatedly scan the
3091 -- type and initialization expression information by resetting
3092 -- the scan pointer (so that we get completely separate trees
3093 -- for each occurrence).
3095 if Num_Idents > 1 then
3096 Save_Scan_State (Scan_State);
3099 -- Loop through defining identifiers in list
3104 -- The following block is present to catch Error_Resync
3105 -- which causes the parse to be reset past the semicolon
3108 Decl_Node := New_Node (N_Component_Declaration, Ident_Sloc);
3109 Set_Defining_Identifier (Decl_Node, Idents (Ident));
3111 if Token = Tok_Constant then
3112 Error_Msg_SC ("constant components are not permitted");
3116 CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
3118 if Token_Name = Name_Aliased then
3119 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
3122 if Token = Tok_Aliased then
3123 Aliased_Present := True;
3124 Scan; -- past ALIASED
3127 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254)
3129 -- Ada 2005 (AI-230): Access Definition case
3131 if Token = Tok_Access then
3132 if Ada_Version < Ada_05 then
3134 ("generalized use of anonymous access types " &
3135 "is an Ada 2005 extension");
3136 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
3139 if Aliased_Present then
3140 Error_Msg_SP ("ALIASED not allowed here");
3143 Set_Subtype_Indication (CompDef_Node, Empty);
3144 Set_Aliased_Present (CompDef_Node, False);
3145 Set_Access_Definition (CompDef_Node,
3146 P_Access_Definition (Not_Null_Present));
3149 Set_Access_Definition (CompDef_Node, Empty);
3150 Set_Aliased_Present (CompDef_Node, Aliased_Present);
3151 Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
3153 if Token = Tok_Array then
3155 ("anonymous arrays not allowed as components");
3159 Set_Subtype_Indication (CompDef_Node,
3160 P_Subtype_Indication (Not_Null_Present));
3163 Set_Component_Definition (Decl_Node, CompDef_Node);
3164 Set_Expression (Decl_Node, Init_Expr_Opt);
3167 Set_Prev_Ids (Decl_Node, True);
3170 if Ident < Num_Idents then
3171 Set_More_Ids (Decl_Node, True);
3174 Append (Decl_Node, Decls);
3177 when Error_Resync =>
3178 if Token /= Tok_End then
3179 Resync_Past_Semicolon;
3183 exit Ident_Loop when Ident = Num_Idents;
3185 Restore_Scan_State (Scan_State);
3187 end loop Ident_Loop;
3190 end P_Component_Items;
3192 --------------------------------
3193 -- 3.8 Component Declaration --
3194 --------------------------------
3196 -- Parsed by P_Component_Items (3.8)
3198 -------------------------
3199 -- 3.8.1 Variant Part --
3200 -------------------------
3203 -- case discriminant_DIRECT_NAME is
3208 -- The caller has checked that the initial token is CASE
3210 -- Error recovery: cannot raise Error_Resync
3212 function P_Variant_Part return Node_Id is
3213 Variant_Part_Node : Node_Id;
3214 Variants_List : List_Id;
3215 Case_Node : Node_Id;
3218 Variant_Part_Node := New_Node (N_Variant_Part, Token_Ptr);
3220 Scope.Table (Scope.Last).Etyp := E_Case;
3221 Scope.Table (Scope.Last).Sloc := Token_Ptr;
3222 Scope.Table (Scope.Last).Ecol := Start_Column;
3225 Case_Node := P_Expression;
3226 Set_Name (Variant_Part_Node, Case_Node);
3228 if Nkind (Case_Node) /= N_Identifier then
3229 Set_Name (Variant_Part_Node, Error);
3230 Error_Msg ("discriminant name expected", Sloc (Case_Node));
3234 Variants_List := New_List;
3235 P_Pragmas_Opt (Variants_List);
3237 -- Test missing variant
3239 if Token = Tok_End then
3240 Error_Msg_BC ("WHEN expected (must have at least one variant)");
3242 Append (P_Variant, Variants_List);
3245 -- Loop through variants, note that we allow if in place of when,
3246 -- this error will be detected and handled in P_Variant.
3249 P_Pragmas_Opt (Variants_List);
3251 if Token /= Tok_When
3252 and then Token /= Tok_If
3253 and then Token /= Tok_Others
3255 exit when Check_End;
3258 Append (P_Variant, Variants_List);
3261 Set_Variants (Variant_Part_Node, Variants_List);
3262 return Variant_Part_Node;
3265 --------------------
3267 --------------------
3270 -- when DISCRETE_CHOICE_LIST =>
3273 -- Error recovery: cannot raise Error_Resync
3275 -- The initial token on entry is either WHEN, IF or OTHERS
3277 function P_Variant return Node_Id is
3278 Variant_Node : Node_Id;
3281 -- Special check to recover nicely from use of IF in place of WHEN
3283 if Token = Tok_If then
3290 Variant_Node := New_Node (N_Variant, Prev_Token_Ptr);
3291 Set_Discrete_Choices (Variant_Node, P_Discrete_Choice_List);
3293 Set_Component_List (Variant_Node, P_Component_List);
3294 return Variant_Node;
3297 ---------------------------------
3298 -- 3.8.1 Discrete Choice List --
3299 ---------------------------------
3301 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
3303 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
3305 -- Note: in Ada 83, the expression must be a simple expression
3307 -- Error recovery: cannot raise Error_Resync
3309 function P_Discrete_Choice_List return List_Id is
3311 Expr_Node : Node_Id;
3312 Choice_Node : Node_Id;
3315 Choices := New_List;
3318 if Token = Tok_Others then
3319 Append (New_Node (N_Others_Choice, Token_Ptr), Choices);
3320 Scan; -- past OTHERS
3324 Expr_Node := No_Right_Paren (P_Expression_Or_Range_Attribute);
3326 if Token = Tok_Colon
3327 and then Nkind (Expr_Node) = N_Identifier
3329 Error_Msg_SP ("label not permitted in this context");
3332 elsif Expr_Form = EF_Range_Attr then
3333 Append (Expr_Node, Choices);
3335 elsif Token = Tok_Dot_Dot then
3336 Check_Simple_Expression (Expr_Node);
3337 Choice_Node := New_Node (N_Range, Token_Ptr);
3338 Set_Low_Bound (Choice_Node, Expr_Node);
3340 Expr_Node := P_Expression_No_Right_Paren;
3341 Check_Simple_Expression (Expr_Node);
3342 Set_High_Bound (Choice_Node, Expr_Node);
3343 Append (Choice_Node, Choices);
3345 elsif Expr_Form = EF_Simple_Name then
3346 if Token = Tok_Range then
3347 Append (P_Subtype_Indication (Expr_Node), Choices);
3349 elsif Token in Token_Class_Consk then
3351 ("the only constraint allowed here " &
3352 "is a range constraint");
3353 Discard_Junk_Node (P_Constraint_Opt);
3354 Append (Expr_Node, Choices);
3357 Append (Expr_Node, Choices);
3361 Check_Simple_Expression_In_Ada_83 (Expr_Node);
3362 Append (Expr_Node, Choices);
3366 when Error_Resync =>
3372 if Token = Tok_Comma then
3373 Error_Msg_SC (""","" should be ""'|""");
3375 exit when Token /= Tok_Vertical_Bar;
3378 Scan; -- past | or comma
3382 end P_Discrete_Choice_List;
3384 ----------------------------
3385 -- 3.8.1 Discrete Choice --
3386 ----------------------------
3388 -- Parsed by P_Discrete_Choice_List (3.8.1)
3390 ----------------------------------
3391 -- 3.9.1 Record Extension Part --
3392 ----------------------------------
3394 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
3396 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
3398 --------------------------------------
3399 -- 3.9.4 Interface Type Definition --
3400 --------------------------------------
3402 -- INTERFACE_TYPE_DEFINITION ::=
3403 -- [limited | task | protected | synchronized] interface
3404 -- [AND interface_list]
3406 -- Error recovery: cannot raise Error_Resync
3408 function P_Interface_Type_Definition
3409 (Is_Synchronized : Boolean) return Node_Id
3411 Typedef_Node : Node_Id;
3414 if Ada_Version < Ada_05 then
3415 Error_Msg_SP ("abstract interface is an Ada 2005 extension");
3416 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
3419 Scan; -- past INTERFACE
3421 -- Ada 2005 (AI-345): In case of synchronized interfaces and
3422 -- interfaces with a null list of interfaces we build a
3423 -- record_definition node.
3426 or else Token = Tok_Semicolon
3428 Typedef_Node := New_Node (N_Record_Definition, Token_Ptr);
3430 Set_Abstract_Present (Typedef_Node);
3431 Set_Tagged_Present (Typedef_Node);
3432 Set_Null_Present (Typedef_Node);
3433 Set_Interface_Present (Typedef_Node);
3436 and then Token = Tok_And
3439 Set_Interface_List (Typedef_Node, New_List);
3442 Append (P_Qualified_Simple_Name,
3443 Interface_List (Typedef_Node));
3444 exit when Token /= Tok_And;
3449 -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have
3450 -- a list of interfaces we build a derived_type_definition node. This
3451 -- simplifies the semantic analysis (and hence further mainteinance)
3454 if Token /= Tok_And then
3455 Error_Msg_AP ("AND expected");
3460 Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
3462 Set_Abstract_Present (Typedef_Node);
3463 Set_Interface_Present (Typedef_Node);
3464 Set_Subtype_Indication (Typedef_Node, P_Qualified_Simple_Name);
3466 Set_Record_Extension_Part (Typedef_Node,
3467 New_Node (N_Record_Definition, Token_Ptr));
3468 Set_Null_Present (Record_Extension_Part (Typedef_Node));
3470 if Token = Tok_And then
3471 Set_Interface_List (Typedef_Node, New_List);
3475 Append (P_Qualified_Simple_Name,
3476 Interface_List (Typedef_Node));
3477 exit when Token /= Tok_And;
3483 return Typedef_Node;
3484 end P_Interface_Type_Definition;
3486 ----------------------------------
3487 -- 3.10 Access Type Definition --
3488 ----------------------------------
3490 -- ACCESS_TYPE_DEFINITION ::=
3491 -- ACCESS_TO_OBJECT_DEFINITION
3492 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3494 -- ACCESS_TO_OBJECT_DEFINITION ::=
3495 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
3497 -- GENERAL_ACCESS_MODIFIER ::= all | constant
3499 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3500 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3501 -- | [NULL_EXCLUSION] access [protected] function
3502 -- PARAMETER_AND_RESULT_PROFILE
3504 -- PARAMETER_PROFILE ::= [FORMAL_PART]
3506 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
3508 -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already
3509 -- parsed the null_exclusion part and has also removed the ACCESS token;
3510 -- otherwise the caller has just checked that the initial token is ACCESS
3512 -- Error recovery: can raise Error_Resync
3514 function P_Access_Type_Definition
3515 (Header_Already_Parsed : Boolean := False) return Node_Id is
3516 Access_Loc : constant Source_Ptr := Token_Ptr;
3517 Prot_Flag : Boolean;
3518 Not_Null_Present : Boolean := False;
3519 Type_Def_Node : Node_Id;
3521 procedure Check_Junk_Subprogram_Name;
3522 -- Used in access to subprogram definition cases to check for an
3523 -- identifier or operator symbol that does not belong.
3525 procedure Check_Junk_Subprogram_Name is
3526 Saved_State : Saved_Scan_State;
3529 if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
3530 Save_Scan_State (Saved_State);
3531 Scan; -- past possible junk subprogram name
3533 if Token = Tok_Left_Paren or else Token = Tok_Semicolon then
3534 Error_Msg_SP ("unexpected subprogram name ignored");
3538 Restore_Scan_State (Saved_State);
3541 end Check_Junk_Subprogram_Name;
3543 -- Start of processing for P_Access_Type_Definition
3546 if not Header_Already_Parsed then
3547 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
3548 Scan; -- past ACCESS
3551 if Token_Name = Name_Protected then
3552 Check_95_Keyword (Tok_Protected, Tok_Procedure);
3553 Check_95_Keyword (Tok_Protected, Tok_Function);
3556 Prot_Flag := (Token = Tok_Protected);
3559 Scan; -- past PROTECTED
3561 if Token /= Tok_Procedure and then Token /= Tok_Function then
3562 Error_Msg_SC ("FUNCTION or PROCEDURE expected");
3566 if Token = Tok_Procedure then
3567 if Ada_Version = Ada_83 then
3568 Error_Msg_SC ("(Ada 83) access to procedure not allowed!");
3571 Type_Def_Node := New_Node (N_Access_Procedure_Definition, Access_Loc);
3572 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3573 Scan; -- past PROCEDURE
3574 Check_Junk_Subprogram_Name;
3575 Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
3576 Set_Protected_Present (Type_Def_Node, Prot_Flag);
3578 elsif Token = Tok_Function then
3579 if Ada_Version = Ada_83 then
3580 Error_Msg_SC ("(Ada 83) access to function not allowed!");
3583 Type_Def_Node := New_Node (N_Access_Function_Definition, Access_Loc);
3584 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3585 Scan; -- past FUNCTION
3586 Check_Junk_Subprogram_Name;
3587 Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
3588 Set_Protected_Present (Type_Def_Node, Prot_Flag);
3590 Set_Subtype_Mark (Type_Def_Node, P_Subtype_Mark);
3595 New_Node (N_Access_To_Object_Definition, Access_Loc);
3596 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3598 if Token = Tok_All or else Token = Tok_Constant then
3599 if Ada_Version = Ada_83 then
3600 Error_Msg_SC ("(Ada 83) access modifier not allowed!");
3603 if Token = Tok_All then
3604 Set_All_Present (Type_Def_Node, True);
3607 Set_Constant_Present (Type_Def_Node, True);
3610 Scan; -- past ALL or CONSTANT
3613 Set_Subtype_Indication (Type_Def_Node,
3614 P_Subtype_Indication (Not_Null_Present));
3617 return Type_Def_Node;
3618 end P_Access_Type_Definition;
3620 ---------------------------------------
3621 -- 3.10 Access To Object Definition --
3622 ---------------------------------------
3624 -- Parsed by P_Access_Type_Definition (3.10)
3626 -----------------------------------
3627 -- 3.10 General Access Modifier --
3628 -----------------------------------
3630 -- Parsed by P_Access_Type_Definition (3.10)
3632 -------------------------------------------
3633 -- 3.10 Access To Subprogram Definition --
3634 -------------------------------------------
3636 -- Parsed by P_Access_Type_Definition (3.10)
3638 -----------------------------
3639 -- 3.10 Access Definition --
3640 -----------------------------
3642 -- ACCESS_DEFINITION ::=
3643 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3644 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3646 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3647 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3648 -- | [NULL_EXCLUSION] access [protected] function
3649 -- PARAMETER_AND_RESULT_PROFILE
3651 -- The caller has parsed the null-exclusion part and it has also checked
3652 -- that the next token is ACCESS
3654 -- Error recovery: cannot raise Error_Resync
3656 function P_Access_Definition
3657 (Null_Exclusion_Present : Boolean) return Node_Id is
3659 Subp_Node : Node_Id;
3662 Def_Node := New_Node (N_Access_Definition, Token_Ptr);
3663 Scan; -- past ACCESS
3665 -- Ada 2005 (AI-254/AI-231)
3667 if Ada_Version >= Ada_05 then
3669 -- Ada 2005 (AI-254): Access_To_Subprogram_Definition
3671 if Token = Tok_Protected
3672 or else Token = Tok_Procedure
3673 or else Token = Tok_Function
3676 P_Access_Type_Definition (Header_Already_Parsed => True);
3677 Set_Null_Exclusion_Present (Subp_Node, Null_Exclusion_Present);
3678 Set_Access_To_Subprogram_Definition (Def_Node, Subp_Node);
3680 -- Ada 2005 (AI-231)
3681 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3684 Set_Null_Exclusion_Present (Def_Node, Null_Exclusion_Present);
3686 if Token = Tok_All then
3688 Set_All_Present (Def_Node);
3690 elsif Token = Tok_Constant then
3691 Scan; -- past CONSTANT
3692 Set_Constant_Present (Def_Node);
3695 Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
3702 -- Ada 2005 (AI-254): The null-exclusion present is never present
3703 -- in Ada 83 and Ada 95
3705 pragma Assert (Null_Exclusion_Present = False);
3707 Set_Null_Exclusion_Present (Def_Node, False);
3708 Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
3713 end P_Access_Definition;
3715 -----------------------------------------
3716 -- 3.10.1 Incomplete Type Declaration --
3717 -----------------------------------------
3719 -- Parsed by P_Type_Declaration (3.2.1)
3721 ----------------------------
3722 -- 3.11 Declarative Part --
3723 ----------------------------
3725 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
3727 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items
3728 -- handles errors, and returns cleanly after an error has occurred)
3730 function P_Declarative_Part return List_Id is
3735 -- Indicate no bad declarations detected yet. This will be reset by
3736 -- P_Declarative_Items if a bad declaration is discovered.
3738 Missing_Begin_Msg := No_Error_Msg;
3740 -- Get rid of active SIS entry from outer scope. This means we will
3741 -- miss some nested cases, but it doesn't seem worth the effort. See
3742 -- discussion in Par for further details
3744 SIS_Entry_Active := False;
3747 -- Loop to scan out the declarations
3750 P_Declarative_Items (Decls, Done, In_Spec => False);
3754 -- Get rid of active SIS entry which is left set only if we scanned a
3755 -- procedure declaration and have not found the body. We could give
3756 -- an error message, but that really would be usurping the role of
3757 -- semantic analysis (this really is a missing body case).
3759 SIS_Entry_Active := False;
3761 end P_Declarative_Part;
3763 ----------------------------
3764 -- 3.11 Declarative Item --
3765 ----------------------------
3767 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
3769 -- Can return Error if a junk declaration is found, or Empty if no
3770 -- declaration is found (i.e. a token ending declarations, such as
3771 -- BEGIN or END is encountered).
3773 -- Error recovery: cannot raise Error_Resync. If an error resync occurs,
3774 -- then the scan is set past the next semicolon and Error is returned.
3776 procedure P_Declarative_Items
3781 Scan_State : Saved_Scan_State;
3784 if Style_Check then Style.Check_Indentation; end if;
3788 when Tok_Function =>
3790 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
3796 -- Check for loop (premature statement)
3798 Save_Scan_State (Scan_State);
3801 if Token = Tok_Identifier then
3802 Scan; -- past identifier
3804 if Token = Tok_In then
3805 Restore_Scan_State (Scan_State);
3806 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
3811 -- Not a loop, so must be rep clause
3813 Restore_Scan_State (Scan_State);
3814 Append (P_Representation_Clause, Decls);
3819 Append (P_Generic, Decls);
3822 when Tok_Identifier =>
3824 P_Identifier_Declarations (Decls, Done, In_Spec);
3828 Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
3832 Append (P_Pragma, Decls);
3835 when Tok_Procedure =>
3837 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
3840 when Tok_Protected =>
3842 Scan; -- past PROTECTED
3843 Append (P_Protected, Decls);
3848 Append (P_Subtype_Declaration, Decls);
3854 Append (P_Task, Decls);
3859 Append (P_Type_Declaration, Decls);
3864 Append (P_Use_Clause, Decls);
3869 Error_Msg_SC ("WITH can only appear in context clause");
3872 -- BEGIN terminates the scan of a sequence of declarations unless
3873 -- there is a missing subprogram body, see section on handling
3874 -- semicolon in place of IS. We only treat the begin as satisfying
3875 -- the subprogram declaration if it falls in the expected column
3879 if SIS_Entry_Active and then Start_Column >= SIS_Ecol then
3881 -- Here we have the case where a BEGIN is encountered during
3882 -- declarations in a declarative part, or at the outer level,
3883 -- and there is a subprogram declaration outstanding for which
3884 -- no body has been supplied. This is the case where we assume
3885 -- that the semicolon in the subprogram declaration should
3886 -- really have been is. The active SIS entry describes the
3887 -- subprogram declaration. On return the declaration has been
3888 -- modified to become a body.
3891 Specification_Node : Node_Id;
3892 Decl_Node : Node_Id;
3893 Body_Node : Node_Id;
3896 -- First issue the error message. If we had a missing
3897 -- semicolon in the declaration, then change the message
3898 -- to <missing "is">
3900 if SIS_Missing_Semicolon_Message /= No_Error_Msg then
3901 Change_Error_Text -- Replace: "missing "";"" "
3902 (SIS_Missing_Semicolon_Message, "missing ""is""");
3904 -- Otherwise we saved the semicolon position, so complain
3907 Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc);
3910 -- The next job is to fix up any declarations that occurred
3911 -- between the procedure header and the BEGIN. These got
3912 -- chained to the outer declarative region (immediately
3913 -- after the procedure declaration) and they should be
3914 -- chained to the subprogram itself, which is a body
3915 -- rather than a spec.
3917 Specification_Node := Specification (SIS_Declaration_Node);
3918 Change_Node (SIS_Declaration_Node, N_Subprogram_Body);
3919 Body_Node := SIS_Declaration_Node;
3920 Set_Specification (Body_Node, Specification_Node);
3921 Set_Declarations (Body_Node, New_List);
3924 Decl_Node := Remove_Next (Body_Node);
3925 exit when Decl_Node = Empty;
3926 Append (Decl_Node, Declarations (Body_Node));
3929 -- Now make the scope table entry for the Begin-End and
3933 Scope.Table (Scope.Last).Sloc := SIS_Sloc;
3934 Scope.Table (Scope.Last).Etyp := E_Name;
3935 Scope.Table (Scope.Last).Ecol := SIS_Ecol;
3936 Scope.Table (Scope.Last).Labl := SIS_Labl;
3937 Scope.Table (Scope.Last).Lreq := False;
3938 SIS_Entry_Active := False;
3940 Set_Handled_Statement_Sequence (Body_Node,
3941 P_Handled_Sequence_Of_Statements);
3942 End_Statements (Handled_Statement_Sequence (Body_Node));
3951 -- Normally an END terminates the scan for basic declarative
3952 -- items. The one exception is END RECORD, which is probably
3953 -- left over from some other junk.
3956 Save_Scan_State (Scan_State); -- at END
3959 if Token = Tok_Record then
3960 Error_Msg_SP ("no RECORD for this `end record`!");
3961 Scan; -- past RECORD
3965 Restore_Scan_State (Scan_State); -- to END
3969 -- The following tokens which can only be the start of a statement
3970 -- are considered to end a declarative part (i.e. we have a missing
3971 -- BEGIN situation). We are fairly conservative in making this
3972 -- judgment, because it is a real mess to go into statement mode
3973 -- prematurely in response to a junk declaration.
3988 -- But before we decide that it's a statement, let's check for
3989 -- a reserved word misused as an identifier.
3991 if Is_Reserved_Identifier then
3992 Save_Scan_State (Scan_State);
3993 Scan; -- past the token
3995 -- If reserved identifier not followed by colon or comma, then
3996 -- this is most likely an assignment statement to the bad id.
3998 if Token /= Tok_Colon and then Token /= Tok_Comma then
3999 Restore_Scan_State (Scan_State);
4000 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
4003 -- Otherwise we have a declaration of the bad id
4006 Restore_Scan_State (Scan_State);
4007 Scan_Reserved_Identifier (Force_Msg => True);
4008 P_Identifier_Declarations (Decls, Done, In_Spec);
4011 -- If not reserved identifier, then it's definitely a statement
4014 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
4018 -- The token RETURN may well also signal a missing BEGIN situation,
4019 -- however, we never let it end the declarative part, because it may
4020 -- also be part of a half-baked function declaration.
4023 Error_Msg_SC ("misplaced RETURN statement");
4026 -- PRIVATE definitely terminates the declarations in a spec,
4027 -- and is an error in a body.
4033 Error_Msg_SC ("PRIVATE not allowed in body");
4034 Scan; -- past PRIVATE
4037 -- An end of file definitely terminates the declarations!
4042 -- The remaining tokens do not end the scan, but cannot start a
4043 -- valid declaration, so we signal an error and resynchronize.
4044 -- But first check for misuse of a reserved identifier.
4048 -- Here we check for a reserved identifier
4050 if Is_Reserved_Identifier then
4051 Save_Scan_State (Scan_State);
4052 Scan; -- past the token
4054 if Token /= Tok_Colon and then Token /= Tok_Comma then
4055 Restore_Scan_State (Scan_State);
4056 Set_Declaration_Expected;
4059 Restore_Scan_State (Scan_State);
4060 Scan_Reserved_Identifier (Force_Msg => True);
4062 P_Identifier_Declarations (Decls, Done, In_Spec);
4066 Set_Declaration_Expected;
4071 -- To resynchronize after an error, we scan to the next semicolon and
4072 -- return with Done = False, indicating that there may still be more
4073 -- valid declarations to come.
4076 when Error_Resync =>
4077 Resync_Past_Semicolon;
4079 end P_Declarative_Items;
4081 ----------------------------------
4082 -- 3.11 Basic Declarative Item --
4083 ----------------------------------
4085 -- BASIC_DECLARATIVE_ITEM ::=
4086 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
4088 -- Scan zero or more basic declarative items
4090 -- Error recovery: cannot raise Error_Resync. If an error is detected, then
4091 -- the scan pointer is repositioned past the next semicolon, and the scan
4092 -- for declarative items continues.
4094 function P_Basic_Declarative_Items return List_Id is
4101 -- Indicate no bad declarations detected yet in the current context:
4102 -- visible or private declarations of a package spec.
4104 Missing_Begin_Msg := No_Error_Msg;
4106 -- Get rid of active SIS entry from outer scope. This means we will
4107 -- miss some nested cases, but it doesn't seem worth the effort. See
4108 -- discussion in Par for further details
4110 SIS_Entry_Active := False;
4112 -- Loop to scan out declarations
4117 P_Declarative_Items (Decls, Done, In_Spec => True);
4121 -- Get rid of active SIS entry. This is set only if we have scanned a
4122 -- procedure declaration and have not found the body. We could give
4123 -- an error message, but that really would be usurping the role of
4124 -- semantic analysis (this really is a case of a missing body).
4126 SIS_Entry_Active := False;
4128 -- Test for assorted illegal declarations not diagnosed elsewhere.
4130 Decl := First (Decls);
4132 while Present (Decl) loop
4133 Kind := Nkind (Decl);
4135 -- Test for body scanned, not acceptable as basic decl item
4137 if Kind = N_Subprogram_Body or else
4138 Kind = N_Package_Body or else
4139 Kind = N_Task_Body or else
4140 Kind = N_Protected_Body
4143 ("proper body not allowed in package spec", Sloc (Decl));
4145 -- Test for body stub scanned, not acceptable as basic decl item
4147 elsif Kind in N_Body_Stub then
4149 ("body stub not allowed in package spec", Sloc (Decl));
4151 elsif Kind = N_Assignment_Statement then
4153 ("assignment statement not allowed in package spec",
4161 end P_Basic_Declarative_Items;
4167 -- For proper body, see below
4168 -- For body stub, see 10.1.3
4170 -----------------------
4171 -- 3.11 Proper Body --
4172 -----------------------
4174 -- Subprogram body is parsed by P_Subprogram (6.1)
4175 -- Package body is parsed by P_Package (7.1)
4176 -- Task body is parsed by P_Task (9.1)
4177 -- Protected body is parsed by P_Protected (9.4)
4179 ------------------------------
4180 -- Set_Declaration_Expected --
4181 ------------------------------
4183 procedure Set_Declaration_Expected is
4185 Error_Msg_SC ("declaration expected");
4187 if Missing_Begin_Msg = No_Error_Msg then
4188 Missing_Begin_Msg := Get_Msg_Id;
4190 end Set_Declaration_Expected;
4192 ----------------------
4193 -- Skip_Declaration --
4194 ----------------------
4196 procedure Skip_Declaration (S : List_Id) is
4197 Dummy_Done : Boolean;
4200 P_Declarative_Items (S, Dummy_Done, False);
4201 end Skip_Declaration;
4203 -----------------------------------------
4204 -- Statement_When_Declaration_Expected --
4205 -----------------------------------------
4207 procedure Statement_When_Declaration_Expected
4213 -- Case of second occurrence of statement in one declaration sequence
4215 if Missing_Begin_Msg /= No_Error_Msg then
4217 -- In the procedure spec case, just ignore it, we only give one
4218 -- message for the first occurrence, since otherwise we may get
4219 -- horrible cascading if BODY was missing in the header line.
4224 -- In the declarative part case, take a second statement as a sure
4225 -- sign that we really have a missing BEGIN, and end the declarative
4226 -- part now. Note that the caller will fix up the first message to
4227 -- say "missing BEGIN" so that's how the error will be signalled.
4234 -- Case of first occurrence of unexpected statement
4237 -- If we are in a package spec, then give message of statement
4238 -- not allowed in package spec. This message never gets changed.
4241 Error_Msg_SC ("statement not allowed in package spec");
4243 -- If in declarative part, then we give the message complaining
4244 -- about finding a statement when a declaration is expected. This
4245 -- gets changed to a complaint about a missing BEGIN if we later
4246 -- find that no BEGIN is present.
4249 Error_Msg_SC ("statement not allowed in declarative part");
4252 -- Capture message Id. This is used for two purposes, first to
4253 -- stop multiple messages, see test above, and second, to allow
4254 -- the replacement of the message in the declarative part case.
4256 Missing_Begin_Msg := Get_Msg_Id;
4259 -- In all cases except the case in which we decided to terminate the
4260 -- declaration sequence on a second error, we scan out the statement
4261 -- and append it to the list of declarations (note that the semantics
4262 -- can handle statements in a declaration list so if we proceed to
4263 -- call the semantic phase, all will be (reasonably) well!
4265 Append_List_To (Decls, P_Sequence_Of_Statements (SS_Unco));
4267 -- Done is set to False, since we want to continue the scan of
4268 -- declarations, hoping that this statement was a temporary glitch.
4269 -- If we indeed are now in the statement part (i.e. this was a missing
4270 -- BEGIN, then it's not terrible, we will simply keep calling this
4271 -- procedure to process the statements one by one, and then finally
4272 -- hit the missing BEGIN, which will clean up the error message.
4275 end Statement_When_Declaration_Expected;