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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 pragma Style_Checks (All_Checks);
28 -- Turn off subprogram body ordering check. Subprograms are in order
29 -- by RM section rather than alphabetical
31 with Sinfo.CN; use Sinfo.CN;
37 -----------------------
38 -- Local Subprograms --
39 -----------------------
41 function P_Component_List return Node_Id;
42 function P_Defining_Character_Literal return Node_Id;
43 function P_Delta_Constraint return Node_Id;
44 function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id;
45 function P_Digits_Constraint return Node_Id;
46 function P_Discriminant_Association return Node_Id;
47 function P_Enumeration_Literal_Specification return Node_Id;
48 function P_Enumeration_Type_Definition return Node_Id;
49 function P_Fixed_Point_Definition return Node_Id;
50 function P_Floating_Point_Definition return Node_Id;
51 function P_Index_Or_Discriminant_Constraint return Node_Id;
52 function P_Real_Range_Specification_Opt return Node_Id;
53 function P_Subtype_Declaration return Node_Id;
54 function P_Type_Declaration return Node_Id;
55 function P_Modular_Type_Definition return Node_Id;
56 function P_Variant return Node_Id;
57 function P_Variant_Part return Node_Id;
59 procedure P_Declarative_Items
63 -- Scans out a single declarative item, or, in the case of a declaration
64 -- with a list of identifiers, a list of declarations, one for each of
65 -- the identifiers in the list. The declaration or declarations scanned
66 -- are appended to the given list. Done indicates whether or not there
67 -- may be additional declarative items to scan. If Done is True, then
68 -- a decision has been made that there are no more items to scan. If
69 -- Done is False, then there may be additional declarations to scan.
70 -- In_Spec is true if we are scanning a package declaration, and is used
71 -- to generate an appropriate message if a statement is encountered in
74 procedure P_Identifier_Declarations
78 -- Scans out a set of declarations for an identifier or list of
79 -- identifiers, and appends them to the given list. The parameters have
80 -- the same significance as for P_Declarative_Items.
82 procedure Statement_When_Declaration_Expected
86 -- Called when a statement is found at a point where a declaration was
87 -- expected. The parameters are as described for P_Declarative_Items.
89 procedure Set_Declaration_Expected;
90 -- Posts a "declaration expected" error messages at the start of the
91 -- current token, and if this is the first such message issued, saves
92 -- the message id in Missing_Begin_Msg, for possible later replacement.
98 function Init_Expr_Opt (P : Boolean := False) return Node_Id is
100 -- For colon, assume it means := unless it is at the end of
101 -- a line, in which case guess that it means a semicolon.
103 if Token = Tok_Colon then
104 if Token_Is_At_End_Of_Line then
109 -- Here if := or something that we will take as equivalent
111 elsif Token = Tok_Colon_Equal
112 or else Token = Tok_Equal
113 or else Token = Tok_Is
117 -- Another possibility. If we have a literal followed by a semicolon,
118 -- we assume that we have a missing colon-equal.
120 elsif Token in Token_Class_Literal then
122 Scan_State : Saved_Scan_State;
125 Save_Scan_State (Scan_State);
126 Scan; -- past literal or identifier
128 if Token = Tok_Semicolon then
129 Restore_Scan_State (Scan_State);
131 Restore_Scan_State (Scan_State);
136 -- Otherwise we definitely have no initialization expression
142 -- Merge here if we have an initialization expression
149 return P_Expression_No_Right_Paren;
153 ----------------------------
154 -- 3.1 Basic Declaration --
155 ----------------------------
157 -- Parsed by P_Basic_Declarative_Items (3.9)
159 ------------------------------
160 -- 3.1 Defining Identifier --
161 ------------------------------
163 -- DEFINING_IDENTIFIER ::= IDENTIFIER
165 -- Error recovery: can raise Error_Resync
167 function P_Defining_Identifier (C : Id_Check := None) return Node_Id is
168 Ident_Node : Node_Id;
171 -- Scan out the identifier. Note that this code is essentially identical
172 -- to P_Identifier, except that in the call to Scan_Reserved_Identifier
173 -- we set Force_Msg to True, since we want at least one message for each
174 -- separate declaration (but not use) of a reserved identifier.
176 if Token = Tok_Identifier then
178 -- Ada 2005 (AI-284): Compiling in Ada95 mode we warn that INTERFACE,
179 -- OVERRIDING, and SYNCHRONIZED are new reserved words.
181 if Ada_Version = Ada_95
182 and then Warn_On_Ada_2005_Compatibility
184 if Token_Name = Name_Overriding
185 or else Token_Name = Name_Synchronized
186 or else (Token_Name = Name_Interface
187 and then Prev_Token /= Tok_Pragma)
189 Error_Msg_N ("& is a reserved word in Ada 2005?", Token_Node);
193 -- If we have a reserved identifier, manufacture an identifier with
194 -- a corresponding name after posting an appropriate error message
196 elsif Is_Reserved_Identifier (C) then
197 Scan_Reserved_Identifier (Force_Msg => True);
199 -- Otherwise we have junk that cannot be interpreted as an identifier
202 T_Identifier; -- to give message
206 Ident_Node := Token_Node;
207 Scan; -- past the reserved identifier
209 if Ident_Node /= Error then
210 Change_Identifier_To_Defining_Identifier (Ident_Node);
214 end P_Defining_Identifier;
216 -----------------------------
217 -- 3.2.1 Type Declaration --
218 -----------------------------
220 -- TYPE_DECLARATION ::=
221 -- FULL_TYPE_DECLARATION
222 -- | INCOMPLETE_TYPE_DECLARATION
223 -- | PRIVATE_TYPE_DECLARATION
224 -- | PRIVATE_EXTENSION_DECLARATION
226 -- FULL_TYPE_DECLARATION ::=
227 -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION;
228 -- | CONCURRENT_TYPE_DECLARATION
230 -- INCOMPLETE_TYPE_DECLARATION ::=
231 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART];
233 -- PRIVATE_TYPE_DECLARATION ::=
234 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
235 -- is [abstract] [tagged] [limited] private;
237 -- PRIVATE_EXTENSION_DECLARATION ::=
238 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
239 -- [abstract] new ancestor_SUBTYPE_INDICATION
240 -- [and INTERFACE_LIST] with private;
242 -- TYPE_DEFINITION ::=
243 -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
244 -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION
245 -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION
246 -- | DERIVED_TYPE_DEFINITION | INTERFACE_TYPE_DEFINITION
248 -- INTEGER_TYPE_DEFINITION ::=
249 -- SIGNED_INTEGER_TYPE_DEFINITION
250 -- MODULAR_TYPE_DEFINITION
252 -- INTERFACE_TYPE_DEFINITION ::=
253 -- [limited | task | protected | synchronized ] interface
254 -- [AND interface_list]
256 -- Error recovery: can raise Error_Resync
258 -- Note: The processing for full type declaration, incomplete type
259 -- declaration, private type declaration and type definition is
260 -- included in this function. The processing for concurrent type
261 -- declarations is NOT here, but rather in chapter 9 (i.e. this
262 -- function handles only declarations starting with TYPE).
264 function P_Type_Declaration return Node_Id is
265 Abstract_Present : Boolean;
266 Abstract_Loc : Source_Ptr;
268 Discr_List : List_Id;
269 Discr_Sloc : Source_Ptr;
271 Type_Loc : Source_Ptr;
272 Type_Start_Col : Column_Number;
273 Ident_Node : Node_Id;
274 Is_Derived_Iface : Boolean := False;
275 Unknown_Dis : Boolean;
277 Typedef_Node : Node_Id;
278 -- Normally holds type definition, except in the case of a private
279 -- extension declaration, in which case it holds the declaration itself
282 Type_Loc := Token_Ptr;
283 Type_Start_Col := Start_Column;
285 -- If we have TYPE, then proceed ahead and scan identifier
287 if Token = Tok_Type then
289 Ident_Node := P_Defining_Identifier (C_Is);
291 -- Otherwise this is an error case, and we may already have converted
292 -- the current token to a defining identifier, so don't do it again!
297 if Token = Tok_Identifier
298 and then Nkind (Token_Node) = N_Defining_Identifier
300 Ident_Node := Token_Node;
301 Scan; -- past defining identifier
303 Ident_Node := P_Defining_Identifier (C_Is);
307 Discr_Sloc := Token_Ptr;
309 if P_Unknown_Discriminant_Part_Opt then
311 Discr_List := No_List;
313 Unknown_Dis := False;
314 Discr_List := P_Known_Discriminant_Part_Opt;
317 -- Incomplete type declaration. We complete the processing for this
318 -- case here and return the resulting incomplete type declaration node
320 if Token = Tok_Semicolon then
322 Decl_Node := New_Node (N_Incomplete_Type_Declaration, Type_Loc);
323 Set_Defining_Identifier (Decl_Node, Ident_Node);
324 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
325 Set_Discriminant_Specifications (Decl_Node, Discr_List);
332 -- Full type declaration or private type declaration, must have IS
334 if Token = Tok_Equal then
336 Scan; -- past = used in place of IS
338 elsif Token = Tok_Renames then
339 Error_Msg_SC ("RENAMES should be IS");
340 Scan; -- past RENAMES used in place of IS
346 -- First an error check, if we have two identifiers in a row, a likely
347 -- possibility is that the first of the identifiers is an incorrectly
350 if Token = Tok_Identifier then
352 SS : Saved_Scan_State;
356 Save_Scan_State (SS);
357 Scan; -- past initial identifier
358 I2 := (Token = Tok_Identifier);
359 Restore_Scan_State (SS);
363 (Bad_Spelling_Of (Tok_Abstract) or else
364 Bad_Spelling_Of (Tok_Access) or else
365 Bad_Spelling_Of (Tok_Aliased) or else
366 Bad_Spelling_Of (Tok_Constant))
373 -- Check for misuse of Ada 95 keyword abstract in Ada 83 mode
375 if Token_Name = Name_Abstract then
376 Check_95_Keyword (Tok_Abstract, Tok_Tagged);
377 Check_95_Keyword (Tok_Abstract, Tok_New);
380 -- Check cases of misuse of ABSTRACT
382 if Token = Tok_Abstract then
383 Abstract_Present := True;
384 Abstract_Loc := Token_Ptr;
385 Scan; -- past ABSTRACT
387 if Token = Tok_Limited
388 or else Token = Tok_Private
389 or else Token = Tok_Record
390 or else Token = Tok_Null
392 Error_Msg_AP ("TAGGED expected");
396 Abstract_Present := False;
397 Abstract_Loc := No_Location;
400 -- Check for misuse of Ada 95 keyword Tagged
402 if Token_Name = Name_Tagged then
403 Check_95_Keyword (Tok_Tagged, Tok_Private);
404 Check_95_Keyword (Tok_Tagged, Tok_Limited);
405 Check_95_Keyword (Tok_Tagged, Tok_Record);
408 -- Special check for misuse of Aliased
410 if Token = Tok_Aliased or else Token_Name = Name_Aliased then
411 Error_Msg_SC ("ALIASED not allowed in type definition");
412 Scan; -- past ALIASED
415 -- The following procesing deals with either a private type declaration
416 -- or a full type declaration. In the private type case, we build the
417 -- N_Private_Type_Declaration node, setting its Tagged_Present and
418 -- Limited_Present flags, on encountering the Private keyword, and
419 -- leave Typedef_Node set to Empty. For the full type declaration
420 -- case, Typedef_Node gets set to the type definition.
422 Typedef_Node := Empty;
424 -- Switch on token following the IS. The loop normally runs once. It
425 -- only runs more than once if an error is detected, to try again after
426 -- detecting and fixing up the error.
432 Tok_Not => -- Ada 2005 (AI-231)
433 Typedef_Node := P_Access_Type_Definition;
438 Typedef_Node := P_Array_Type_Definition;
443 Typedef_Node := P_Fixed_Point_Definition;
448 Typedef_Node := P_Floating_Point_Definition;
455 when Tok_Integer_Literal =>
457 Typedef_Node := P_Signed_Integer_Type_Definition;
462 Typedef_Node := P_Record_Definition;
466 when Tok_Left_Paren =>
467 Typedef_Node := P_Enumeration_Type_Definition;
470 Make_Identifier (Token_Ptr,
471 Chars => Chars (Ident_Node));
472 Set_Comes_From_Source (End_Labl, False);
474 Set_End_Label (Typedef_Node, End_Labl);
479 Typedef_Node := P_Modular_Type_Definition;
484 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
486 if Nkind (Typedef_Node) = N_Derived_Type_Definition
487 and then Present (Record_Extension_Part (Typedef_Node))
490 Make_Identifier (Token_Ptr,
491 Chars => Chars (Ident_Node));
492 Set_Comes_From_Source (End_Labl, False);
495 (Record_Extension_Part (Typedef_Node), End_Labl);
502 Typedef_Node := P_Signed_Integer_Type_Definition;
507 Typedef_Node := P_Record_Definition;
510 Make_Identifier (Token_Ptr,
511 Chars => Chars (Ident_Node));
512 Set_Comes_From_Source (End_Labl, False);
514 Set_End_Label (Typedef_Node, End_Labl);
521 if Token = Tok_Abstract then
522 Error_Msg_SC ("ABSTRACT must come before TAGGED");
523 Abstract_Present := True;
524 Abstract_Loc := Token_Ptr;
525 Scan; -- past ABSTRACT
528 if Token = Tok_Limited then
529 Scan; -- past LIMITED
531 -- TAGGED LIMITED PRIVATE case
533 if Token = Tok_Private then
535 New_Node (N_Private_Type_Declaration, Type_Loc);
536 Set_Tagged_Present (Decl_Node, True);
537 Set_Limited_Present (Decl_Node, True);
538 Scan; -- past PRIVATE
540 -- TAGGED LIMITED RECORD
543 Typedef_Node := P_Record_Definition;
544 Set_Tagged_Present (Typedef_Node, True);
545 Set_Limited_Present (Typedef_Node, True);
548 Make_Identifier (Token_Ptr,
549 Chars => Chars (Ident_Node));
550 Set_Comes_From_Source (End_Labl, False);
552 Set_End_Label (Typedef_Node, End_Labl);
558 if Token = Tok_Private then
560 New_Node (N_Private_Type_Declaration, Type_Loc);
561 Set_Tagged_Present (Decl_Node, True);
562 Scan; -- past PRIVATE
567 Typedef_Node := P_Record_Definition;
568 Set_Tagged_Present (Typedef_Node, True);
571 Make_Identifier (Token_Ptr,
572 Chars => Chars (Ident_Node));
573 Set_Comes_From_Source (End_Labl, False);
575 Set_End_Label (Typedef_Node, End_Labl);
583 Scan; -- past LIMITED
586 if Token = Tok_Tagged then
587 Error_Msg_SC ("TAGGED must come before LIMITED");
590 elsif Token = Tok_Abstract then
591 Error_Msg_SC ("ABSTRACT must come before LIMITED");
592 Scan; -- past ABSTRACT
599 -- LIMITED RECORD or LIMITED NULL RECORD
601 if Token = Tok_Record or else Token = Tok_Null then
602 if Ada_Version = Ada_83 then
604 ("(Ada 83) limited record declaration not allowed!");
607 Typedef_Node := P_Record_Definition;
608 Set_Limited_Present (Typedef_Node, True);
610 -- Ada 2005 (AI-251): LIMITED INTERFACE
612 -- If we are compiling in Ada 83 or Ada 95 mode, "interface"
613 -- is not a reserved word but we force its analysis to
614 -- generate the corresponding usage error.
616 elsif Token = Tok_Interface
617 or else (Token = Tok_Identifier
618 and then Chars (Token_Node) = Name_Interface)
620 Typedef_Node := P_Interface_Type_Definition
621 (Is_Synchronized => False);
622 Abstract_Present := True;
623 Set_Limited_Present (Typedef_Node);
625 if Nkind (Typedef_Node) = N_Derived_Type_Definition then
626 Is_Derived_Iface := True;
629 -- LIMITED PRIVATE is the only remaining possibility here
632 Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
633 Set_Limited_Present (Decl_Node, True);
634 T_Private; -- past PRIVATE (or complain if not there!)
640 -- Here we have an identifier after the IS, which is certainly
641 -- wrong and which might be one of several different mistakes.
643 when Tok_Identifier =>
645 -- First case, if identifier is on same line, then probably we
646 -- have something like "type X is Integer .." and the best
647 -- diagnosis is a missing NEW. Note: the missing new message
648 -- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl.
650 if not Token_Is_At_Start_Of_Line then
651 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
654 -- If the identifier is at the start of the line, and is in the
655 -- same column as the type declaration itself then we consider
656 -- that we had a missing type definition on the previous line
658 elsif Start_Column <= Type_Start_Col then
659 Error_Msg_AP ("type definition expected");
660 Typedef_Node := Error;
662 -- If the identifier is at the start of the line, and is in
663 -- a column to the right of the type declaration line, then we
664 -- may have something like:
669 -- and the best diagnosis is a missing record keyword
672 Typedef_Node := P_Record_Definition;
678 -- Ada 2005 (AI-251): INTERFACE
680 when Tok_Interface =>
681 Typedef_Node := P_Interface_Type_Definition
682 (Is_Synchronized => False);
683 Abstract_Present := True;
688 Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
689 Scan; -- past PRIVATE
700 Saved_Token : constant Token_Type := Token;
703 Scan; -- past TASK, PROTECTED or SYNCHRONIZED
705 Typedef_Node := P_Interface_Type_Definition
706 (Is_Synchronized => True);
707 Abstract_Present := True;
711 Set_Task_Present (Typedef_Node);
713 when Tok_Protected =>
714 Set_Protected_Present (Typedef_Node);
716 when Tok_Synchronized =>
717 Set_Synchronized_Present (Typedef_Node);
720 pragma Assert (False);
728 -- Anything else is an error
731 if Bad_Spelling_Of (Tok_Access)
733 Bad_Spelling_Of (Tok_Array)
735 Bad_Spelling_Of (Tok_Delta)
737 Bad_Spelling_Of (Tok_Digits)
739 Bad_Spelling_Of (Tok_Limited)
741 Bad_Spelling_Of (Tok_Private)
743 Bad_Spelling_Of (Tok_Range)
745 Bad_Spelling_Of (Tok_Record)
747 Bad_Spelling_Of (Tok_Tagged)
752 Error_Msg_AP ("type definition expected");
759 -- For the private type declaration case, the private type declaration
760 -- node has been built, with the Tagged_Present and Limited_Present
761 -- flags set as needed, and Typedef_Node is left set to Empty.
763 if No (Typedef_Node) then
764 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
765 Set_Abstract_Present (Decl_Node, Abstract_Present);
767 -- For a private extension declaration, Typedef_Node contains the
768 -- N_Private_Extension_Declaration node, which we now complete. Note
769 -- that the private extension declaration, unlike a full type
770 -- declaration, does permit unknown discriminants.
772 elsif Nkind (Typedef_Node) = N_Private_Extension_Declaration then
773 Decl_Node := Typedef_Node;
774 Set_Sloc (Decl_Node, Type_Loc);
775 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
776 Set_Abstract_Present (Typedef_Node, Abstract_Present);
778 -- In the full type declaration case, Typedef_Node has the type
779 -- definition and here is where we build the full type declaration
780 -- node. This is also where we check for improper use of an unknown
781 -- discriminant part (not allowed for full type declaration).
784 if Nkind (Typedef_Node) = N_Record_Definition
785 or else (Nkind (Typedef_Node) = N_Derived_Type_Definition
786 and then Present (Record_Extension_Part (Typedef_Node)))
787 or else Is_Derived_Iface
789 Set_Abstract_Present (Typedef_Node, Abstract_Present);
791 elsif Abstract_Present then
792 Error_Msg ("ABSTRACT not allowed here, ignored", Abstract_Loc);
795 Decl_Node := New_Node (N_Full_Type_Declaration, Type_Loc);
796 Set_Type_Definition (Decl_Node, Typedef_Node);
800 ("Full type declaration cannot have unknown discriminants",
805 -- Remaining processing is common for all three cases
807 Set_Defining_Identifier (Decl_Node, Ident_Node);
808 Set_Discriminant_Specifications (Decl_Node, Discr_List);
810 end P_Type_Declaration;
812 ----------------------------------
813 -- 3.2.1 Full Type Declaration --
814 ----------------------------------
816 -- Parsed by P_Type_Declaration (3.2.1)
818 ----------------------------
819 -- 3.2.1 Type Definition --
820 ----------------------------
822 -- Parsed by P_Type_Declaration (3.2.1)
824 --------------------------------
825 -- 3.2.2 Subtype Declaration --
826 --------------------------------
828 -- SUBTYPE_DECLARATION ::=
829 -- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION;
831 -- The caller has checked that the initial token is SUBTYPE
833 -- Error recovery: can raise Error_Resync
835 function P_Subtype_Declaration return Node_Id is
837 Not_Null_Present : Boolean := False;
839 Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr);
840 Scan; -- past SUBTYPE
841 Set_Defining_Identifier (Decl_Node, P_Defining_Identifier (C_Is));
844 if Token = Tok_New then
845 Error_Msg_SC ("NEW ignored (only allowed in type declaration)");
849 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
850 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
852 Set_Subtype_Indication
853 (Decl_Node, P_Subtype_Indication (Not_Null_Present));
856 end P_Subtype_Declaration;
858 -------------------------------
859 -- 3.2.2 Subtype Indication --
860 -------------------------------
862 -- SUBTYPE_INDICATION ::=
863 -- [NOT NULL] SUBTYPE_MARK [CONSTRAINT]
865 -- Error recovery: can raise Error_Resync
867 function P_Null_Exclusion return Boolean is
869 if Token /= Tok_Not then
873 if Ada_Version < Ada_05 then
875 ("null-excluding access is an Ada 2005 extension");
876 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
881 if Token = Tok_Null then
884 Error_Msg_SP ("NULL expected");
889 end P_Null_Exclusion;
891 function P_Subtype_Indication
892 (Not_Null_Present : Boolean := False) return Node_Id is
896 if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
897 Type_Node := P_Subtype_Mark;
898 return P_Subtype_Indication (Type_Node, Not_Null_Present);
901 -- Check for error of using record definition and treat it nicely,
902 -- otherwise things are really messed up, so resynchronize.
904 if Token = Tok_Record then
905 Error_Msg_SC ("anonymous record definitions are not permitted");
906 Discard_Junk_Node (P_Record_Definition);
910 Error_Msg_AP ("subtype indication expected");
914 end P_Subtype_Indication;
916 -- The following function is identical except that it is called with
917 -- the subtype mark already scanned out, and it scans out the constraint
919 -- Error recovery: can raise Error_Resync
921 function P_Subtype_Indication
922 (Subtype_Mark : Node_Id;
923 Not_Null_Present : Boolean := False) return Node_Id is
924 Indic_Node : Node_Id;
925 Constr_Node : Node_Id;
928 Constr_Node := P_Constraint_Opt;
930 if No (Constr_Node) then
933 if Not_Null_Present then
934 Error_Msg_SP ("constrained null-exclusion not allowed");
937 Indic_Node := New_Node (N_Subtype_Indication, Sloc (Subtype_Mark));
938 Set_Subtype_Mark (Indic_Node, Check_Subtype_Mark (Subtype_Mark));
939 Set_Constraint (Indic_Node, Constr_Node);
942 end P_Subtype_Indication;
944 -------------------------
945 -- 3.2.2 Subtype Mark --
946 -------------------------
948 -- SUBTYPE_MARK ::= subtype_NAME;
950 -- Note: The subtype mark which appears after an IN or NOT IN
951 -- operator is parsed by P_Range_Or_Subtype_Mark (3.5)
953 -- Error recovery: cannot raise Error_Resync
955 function P_Subtype_Mark return Node_Id is
957 return P_Subtype_Mark_Resync;
964 -- This routine differs from P_Subtype_Mark in that it insists that an
965 -- identifier be present, and if it is not, it raises Error_Resync.
967 -- Error recovery: can raise Error_Resync
969 function P_Subtype_Mark_Resync return Node_Id is
973 if Token = Tok_Access then
974 Error_Msg_SC ("anonymous access type definition not allowed here");
978 if Token = Tok_Array then
979 Error_Msg_SC ("anonymous array definition not allowed here");
980 Discard_Junk_Node (P_Array_Type_Definition);
984 Type_Node := P_Qualified_Simple_Name_Resync;
986 -- Check for a subtype mark attribute. The only valid possibilities
987 -- are 'CLASS and 'BASE. Anything else is a definite error. We may
988 -- as well catch it here.
990 if Token = Tok_Apostrophe then
991 return P_Subtype_Mark_Attribute (Type_Node);
996 end P_Subtype_Mark_Resync;
998 -- The following function is called to scan out a subtype mark attribute.
999 -- The caller has already scanned out the subtype mark, which is passed in
1000 -- as the argument, and has checked that the current token is apostrophe.
1002 -- Only a special subclass of attributes, called type attributes
1003 -- (see Snames package) are allowed in this syntactic position.
1005 -- Note: if the apostrophe is followed by other than an identifier, then
1006 -- the input expression is returned unchanged, and the scan pointer is
1007 -- left pointing to the apostrophe.
1009 -- Error recovery: can raise Error_Resync
1011 function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id is
1012 Attr_Node : Node_Id := Empty;
1013 Scan_State : Saved_Scan_State;
1017 Prefix := Check_Subtype_Mark (Type_Node);
1019 if Prefix = Error then
1023 -- Loop through attributes appearing (more than one can appear as for
1024 -- for example in X'Base'Class). We are at an apostrophe on entry to
1025 -- this loop, and it runs once for each attribute parsed, with
1026 -- Prefix being the current possible prefix if it is an attribute.
1029 Save_Scan_State (Scan_State); -- at Apostrophe
1030 Scan; -- past apostrophe
1032 if Token /= Tok_Identifier then
1033 Restore_Scan_State (Scan_State); -- to apostrophe
1034 return Prefix; -- no attribute after all
1036 elsif not Is_Type_Attribute_Name (Token_Name) then
1038 ("attribute & may not be used in a subtype mark", Token_Node);
1043 Make_Attribute_Reference (Prev_Token_Ptr,
1045 Attribute_Name => Token_Name);
1046 Delete_Node (Token_Node);
1047 Scan; -- past type attribute identifier
1050 exit when Token /= Tok_Apostrophe;
1051 Prefix := Attr_Node;
1054 -- Fall through here after scanning type attribute
1057 end P_Subtype_Mark_Attribute;
1059 -----------------------
1060 -- 3.2.2 Constraint --
1061 -----------------------
1063 -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
1065 -- SCALAR_CONSTRAINT ::=
1066 -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
1068 -- COMPOSITE_CONSTRAINT ::=
1069 -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
1071 -- If no constraint is present, this function returns Empty
1073 -- Error recovery: can raise Error_Resync
1075 function P_Constraint_Opt return Node_Id is
1077 if Token = Tok_Range
1078 or else Bad_Spelling_Of (Tok_Range)
1080 return P_Range_Constraint;
1082 elsif Token = Tok_Digits
1083 or else Bad_Spelling_Of (Tok_Digits)
1085 return P_Digits_Constraint;
1087 elsif Token = Tok_Delta
1088 or else Bad_Spelling_Of (Tok_Delta)
1090 return P_Delta_Constraint;
1092 elsif Token = Tok_Left_Paren then
1093 return P_Index_Or_Discriminant_Constraint;
1095 elsif Token = Tok_In then
1097 return P_Constraint_Opt;
1102 end P_Constraint_Opt;
1104 ------------------------------
1105 -- 3.2.2 Scalar Constraint --
1106 ------------------------------
1108 -- Parsed by P_Constraint_Opt (3.2.2)
1110 ---------------------------------
1111 -- 3.2.2 Composite Constraint --
1112 ---------------------------------
1114 -- Parsed by P_Constraint_Opt (3.2.2)
1116 --------------------------------------------------------
1117 -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) --
1118 --------------------------------------------------------
1120 -- This routine scans out a declaration starting with an identifier:
1122 -- OBJECT_DECLARATION ::=
1123 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1124 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1125 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1126 -- ACCESS_DEFINITION [:= EXPRESSION];
1127 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1128 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1130 -- NUMBER_DECLARATION ::=
1131 -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
1133 -- OBJECT_RENAMING_DECLARATION ::=
1134 -- DEFINING_IDENTIFIER : SUBTYPE_MARK renames object_NAME;
1135 -- | DEFINING_IDENTIFIER : ACCESS_DEFINITION renames object_NAME;
1137 -- EXCEPTION_RENAMING_DECLARATION ::=
1138 -- DEFINING_IDENTIFIER : exception renames exception_NAME;
1140 -- EXCEPTION_DECLARATION ::=
1141 -- DEFINING_IDENTIFIER_LIST : exception;
1143 -- Note that the ALIASED indication in an object declaration is
1144 -- marked by a flag in the parent node.
1146 -- The caller has checked that the initial token is an identifier
1148 -- The value returned is a list of declarations, one for each identifier
1149 -- in the list (as described in Sinfo, we always split up multiple
1150 -- declarations into the equivalent sequence of single declarations
1151 -- using the More_Ids and Prev_Ids flags to preserve the source).
1153 -- If the identifier turns out to be a probable statement rather than
1154 -- an identifier, then the scan is left pointing to the identifier and
1155 -- No_List is returned.
1157 -- Error recovery: can raise Error_Resync
1159 procedure P_Identifier_Declarations
1165 Decl_Node : Node_Id;
1166 Type_Node : Node_Id;
1167 Ident_Sloc : Source_Ptr;
1168 Scan_State : Saved_Scan_State;
1169 List_OK : Boolean := True;
1171 Init_Expr : Node_Id;
1172 Init_Loc : Source_Ptr;
1173 Con_Loc : Source_Ptr;
1174 Not_Null_Present : Boolean := False;
1176 Idents : array (Int range 1 .. 4096) of Entity_Id;
1177 -- Used to save identifiers in the identifier list. The upper bound
1178 -- of 4096 is expected to be infinite in practice, and we do not even
1179 -- bother to check if this upper bound is exceeded.
1181 Num_Idents : Nat := 1;
1182 -- Number of identifiers stored in Idents
1185 -- This procedure is called in renames cases to make sure that we do
1186 -- not have more than one identifier. If we do have more than one
1187 -- then an error message is issued (and the declaration is split into
1188 -- multiple declarations)
1190 function Token_Is_Renames return Boolean;
1191 -- Checks if current token is RENAMES, and if so, scans past it and
1192 -- returns True, otherwise returns False. Includes checking for some
1193 -- common error cases.
1195 procedure No_List is
1197 if Num_Idents > 1 then
1198 Error_Msg ("identifier list not allowed for RENAMES",
1205 function Token_Is_Renames return Boolean is
1206 At_Colon : Saved_Scan_State;
1209 if Token = Tok_Colon then
1210 Save_Scan_State (At_Colon);
1212 Check_Misspelling_Of (Tok_Renames);
1214 if Token = Tok_Renames then
1215 Error_Msg_SP ("extra "":"" ignored");
1216 Scan; -- past RENAMES
1219 Restore_Scan_State (At_Colon);
1224 Check_Misspelling_Of (Tok_Renames);
1226 if Token = Tok_Renames then
1227 Scan; -- past RENAMES
1233 end Token_Is_Renames;
1235 -- Start of processing for P_Identifier_Declarations
1238 Ident_Sloc := Token_Ptr;
1239 Save_Scan_State (Scan_State); -- at first identifier
1240 Idents (1) := P_Defining_Identifier (C_Comma_Colon);
1242 -- If we have a colon after the identifier, then we can assume that
1243 -- this is in fact a valid identifier declaration and can steam ahead.
1245 if Token = Tok_Colon then
1248 -- If we have a comma, then scan out the list of identifiers
1250 elsif Token = Tok_Comma then
1252 while Comma_Present loop
1253 Num_Idents := Num_Idents + 1;
1254 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
1257 Save_Scan_State (Scan_State); -- at colon
1260 -- If we have identifier followed by := then we assume that what is
1261 -- really meant is an assignment statement. The assignment statement
1262 -- is scanned out and added to the list of declarations. An exception
1263 -- occurs if the := is followed by the keyword constant, in which case
1264 -- we assume it was meant to be a colon.
1266 elsif Token = Tok_Colon_Equal then
1269 if Token = Tok_Constant then
1270 Error_Msg_SP ("colon expected");
1273 Restore_Scan_State (Scan_State);
1274 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
1278 -- If we have an IS keyword, then assume the TYPE keyword was missing
1280 elsif Token = Tok_Is then
1281 Restore_Scan_State (Scan_State);
1282 Append_To (Decls, P_Type_Declaration);
1286 -- Otherwise we have an error situation
1289 Restore_Scan_State (Scan_State);
1291 -- First case is possible misuse of PROTECTED in Ada 83 mode. If
1292 -- so, fix the keyword and return to scan the protected declaration.
1294 if Token_Name = Name_Protected then
1295 Check_95_Keyword (Tok_Protected, Tok_Identifier);
1296 Check_95_Keyword (Tok_Protected, Tok_Type);
1297 Check_95_Keyword (Tok_Protected, Tok_Body);
1299 if Token = Tok_Protected then
1304 -- Check misspelling possibilities. If so, correct the misspelling
1305 -- and return to scan out the resulting declaration.
1307 elsif Bad_Spelling_Of (Tok_Function)
1308 or else Bad_Spelling_Of (Tok_Procedure)
1309 or else Bad_Spelling_Of (Tok_Package)
1310 or else Bad_Spelling_Of (Tok_Pragma)
1311 or else Bad_Spelling_Of (Tok_Protected)
1312 or else Bad_Spelling_Of (Tok_Generic)
1313 or else Bad_Spelling_Of (Tok_Subtype)
1314 or else Bad_Spelling_Of (Tok_Type)
1315 or else Bad_Spelling_Of (Tok_Task)
1316 or else Bad_Spelling_Of (Tok_Use)
1317 or else Bad_Spelling_Of (Tok_For)
1322 -- Otherwise we definitely have an ordinary identifier with a junk
1323 -- token after it. Just complain that we expect a declaration, and
1324 -- skip to a semicolon
1327 Set_Declaration_Expected;
1328 Resync_Past_Semicolon;
1334 -- Come here with an identifier list and colon scanned out. We now
1335 -- build the nodes for the declarative items. One node is built for
1336 -- each identifier in the list, with the type information being
1337 -- repeated by rescanning the appropriate section of source.
1339 -- First an error check, if we have two identifiers in a row, a likely
1340 -- possibility is that the first of the identifiers is an incorrectly
1343 if Token = Tok_Identifier then
1345 SS : Saved_Scan_State;
1349 Save_Scan_State (SS);
1350 Scan; -- past initial identifier
1351 I2 := (Token = Tok_Identifier);
1352 Restore_Scan_State (SS);
1356 (Bad_Spelling_Of (Tok_Access) or else
1357 Bad_Spelling_Of (Tok_Aliased) or else
1358 Bad_Spelling_Of (Tok_Constant))
1365 -- Loop through identifiers
1370 -- Check for some cases of misused Ada 95 keywords
1372 if Token_Name = Name_Aliased then
1373 Check_95_Keyword (Tok_Aliased, Tok_Array);
1374 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
1375 Check_95_Keyword (Tok_Aliased, Tok_Constant);
1380 if Token = Tok_Constant then
1381 Con_Loc := Token_Ptr;
1382 Scan; -- past CONSTANT
1384 -- Number declaration, initialization required
1386 Init_Expr := Init_Expr_Opt;
1388 if Present (Init_Expr) then
1389 if Not_Null_Present then
1390 Error_Msg_SP ("null-exclusion not allowed in "
1391 & "numeric expression");
1394 Decl_Node := New_Node (N_Number_Declaration, Ident_Sloc);
1395 Set_Expression (Decl_Node, Init_Expr);
1397 -- Constant object declaration
1400 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1401 Set_Constant_Present (Decl_Node, True);
1403 if Token_Name = Name_Aliased then
1404 Check_95_Keyword (Tok_Aliased, Tok_Array);
1405 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
1408 if Token = Tok_Aliased then
1409 Error_Msg_SC ("ALIASED should be before CONSTANT");
1410 Scan; -- past ALIASED
1411 Set_Aliased_Present (Decl_Node, True);
1414 if Token = Tok_Array then
1415 Set_Object_Definition
1416 (Decl_Node, P_Array_Type_Definition);
1419 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1420 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1422 if Token = Tok_Access then
1423 if Ada_Version < Ada_05 then
1425 ("generalized use of anonymous access types " &
1426 "is an Ada 2005 extension");
1428 ("\unit must be compiled with -gnat05 switch");
1431 Set_Object_Definition
1432 (Decl_Node, P_Access_Definition (Not_Null_Present));
1434 Set_Object_Definition
1435 (Decl_Node, P_Subtype_Indication (Not_Null_Present));
1439 if Token = Tok_Renames then
1441 ("CONSTANT not permitted in renaming declaration",
1443 Scan; -- Past renames
1444 Discard_Junk_Node (P_Name);
1450 elsif Token = Tok_Exception then
1451 Scan; -- past EXCEPTION
1453 if Token_Is_Renames then
1456 New_Node (N_Exception_Renaming_Declaration, Ident_Sloc);
1457 Set_Name (Decl_Node, P_Qualified_Simple_Name_Resync);
1460 Decl_Node := New_Node (N_Exception_Declaration, Prev_Token_Ptr);
1463 -- Aliased case (note that an object definition is required)
1465 elsif Token = Tok_Aliased then
1466 Scan; -- past ALIASED
1467 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1468 Set_Aliased_Present (Decl_Node, True);
1470 if Token = Tok_Constant then
1471 Scan; -- past CONSTANT
1472 Set_Constant_Present (Decl_Node, True);
1475 if Token = Tok_Array then
1476 Set_Object_Definition
1477 (Decl_Node, P_Array_Type_Definition);
1480 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1481 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1483 -- Access definition (AI-406) or subtype indication.
1485 if Token = Tok_Access then
1486 if Ada_Version < Ada_05 then
1488 ("generalized use of anonymous access types " &
1489 "is an Ada 2005 extension");
1491 ("\unit must be compiled with -gnat05 switch");
1494 Set_Object_Definition
1495 (Decl_Node, P_Access_Definition (Not_Null_Present));
1497 Set_Object_Definition
1498 (Decl_Node, P_Subtype_Indication (Not_Null_Present));
1504 elsif Token = Tok_Array then
1505 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1506 Set_Object_Definition (Decl_Node, P_Array_Type_Definition);
1508 -- Ada 2005 (AI-254, AI-406)
1510 elsif Token = Tok_Not then
1512 -- OBJECT_DECLARATION ::=
1513 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1514 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1515 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1516 -- ACCESS_DEFINITION [:= EXPRESSION];
1518 -- OBJECT_RENAMING_DECLARATION ::=
1520 -- | DEFINING_IDENTIFIER : ACCESS_DEFINITION renames object_NAME;
1522 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1524 if Token = Tok_Access then
1525 if Ada_Version < Ada_05 then
1527 ("generalized use of anonymous access types " &
1528 "is an Ada 2005 extension");
1529 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1532 Acc_Node := P_Access_Definition (Not_Null_Present);
1534 if Token /= Tok_Renames then
1535 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1536 Set_Object_Definition (Decl_Node, Acc_Node);
1540 Scan; -- past renames
1543 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1544 Set_Access_Definition (Decl_Node, Acc_Node);
1545 Set_Name (Decl_Node, P_Name);
1549 Type_Node := P_Subtype_Mark;
1551 -- Object renaming declaration
1553 if Token_Is_Renames then
1555 ("null-exclusion not allowed in object renamings");
1558 -- Object declaration
1561 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1562 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1563 Set_Object_Definition
1565 P_Subtype_Indication (Type_Node, Not_Null_Present));
1567 -- RENAMES at this point means that we had the combination
1568 -- of a constraint on the Type_Node and renames, which is
1571 if Token_Is_Renames then
1572 Error_Msg_N ("constraint not allowed in object renaming "
1574 Constraint (Object_Definition (Decl_Node)));
1580 -- Ada 2005 (AI-230): Access Definition case
1582 elsif Token = Tok_Access then
1583 if Ada_Version < Ada_05 then
1585 ("generalized use of anonymous access types " &
1586 "is an Ada 2005 extension");
1587 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1590 Acc_Node := P_Access_Definition (Null_Exclusion_Present => False);
1592 -- Object declaration with access definition, or renaming.
1594 if Token /= Tok_Renames then
1595 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1596 Set_Object_Definition (Decl_Node, Acc_Node);
1597 goto init; -- ??? is this really needed goes here anyway
1600 Scan; -- past renames
1603 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1604 Set_Access_Definition (Decl_Node, Acc_Node);
1605 Set_Name (Decl_Node, P_Name);
1608 -- Subtype indication case
1611 Type_Node := P_Subtype_Mark;
1613 -- Object renaming declaration
1615 if Token_Is_Renames then
1618 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1619 Set_Subtype_Mark (Decl_Node, Type_Node);
1620 Set_Name (Decl_Node, P_Name);
1622 -- Object declaration
1625 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1626 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1627 Set_Object_Definition
1629 P_Subtype_Indication (Type_Node, Not_Null_Present));
1631 -- RENAMES at this point means that we had the combination of
1632 -- a constraint on the Type_Node and renames, which is illegal
1634 if Token_Is_Renames then
1636 ("constraint not allowed in object renaming declaration",
1637 Constraint (Object_Definition (Decl_Node)));
1643 -- Scan out initialization, allowed only for object declaration
1645 <<init>> -- is this really needed ???
1646 Init_Loc := Token_Ptr;
1647 Init_Expr := Init_Expr_Opt;
1649 if Present (Init_Expr) then
1650 if Nkind (Decl_Node) = N_Object_Declaration then
1651 Set_Expression (Decl_Node, Init_Expr);
1653 Error_Msg ("initialization not allowed here", Init_Loc);
1658 Set_Defining_Identifier (Decl_Node, Idents (Ident));
1661 if Ident < Num_Idents then
1662 Set_More_Ids (Decl_Node, True);
1666 Set_Prev_Ids (Decl_Node, True);
1670 Append (Decl_Node, Decls);
1671 exit Ident_Loop when Ident = Num_Idents;
1672 Restore_Scan_State (Scan_State);
1675 end loop Ident_Loop;
1678 end P_Identifier_Declarations;
1680 -------------------------------
1681 -- 3.3.1 Object Declaration --
1682 -------------------------------
1684 -- OBJECT DECLARATION ::=
1685 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1686 -- SUBTYPE_INDICATION [:= EXPRESSION];
1687 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1688 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1689 -- | SINGLE_TASK_DECLARATION
1690 -- | SINGLE_PROTECTED_DECLARATION
1692 -- Cases starting with TASK are parsed by P_Task (9.1)
1693 -- Cases starting with PROTECTED are parsed by P_Protected (9.4)
1694 -- All other cases are parsed by P_Identifier_Declarations (3.3)
1696 -------------------------------------
1697 -- 3.3.1 Defining Identifier List --
1698 -------------------------------------
1700 -- DEFINING_IDENTIFIER_LIST ::=
1701 -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
1703 -- Always parsed by the construct in which it appears. See special
1704 -- section on "Handling of Defining Identifier Lists" in this unit.
1706 -------------------------------
1707 -- 3.3.2 Number Declaration --
1708 -------------------------------
1710 -- Parsed by P_Identifier_Declarations (3.3)
1712 -------------------------------------------------------------------------
1713 -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) --
1714 -------------------------------------------------------------------------
1716 -- DERIVED_TYPE_DEFINITION ::=
1717 -- [abstract] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
1718 -- [[AND interface_list] RECORD_EXTENSION_PART]
1720 -- PRIVATE_EXTENSION_DECLARATION ::=
1721 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
1722 -- [abstract] new ancestor_SUBTYPE_INDICATION
1723 -- [AND interface_list] with PRIVATE;
1725 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
1727 -- The caller has already scanned out the part up to the NEW, and Token
1728 -- either contains Tok_New (or ought to, if it doesn't this procedure
1729 -- will post an appropriate "NEW expected" message).
1731 -- Note: the caller is responsible for filling in the Sloc field of
1732 -- the returned node in the private extension declaration case as
1733 -- well as the stuff relating to the discriminant part.
1735 -- Error recovery: can raise Error_Resync;
1737 function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id is
1738 Typedef_Node : Node_Id;
1739 Typedecl_Node : Node_Id;
1740 Not_Null_Present : Boolean := False;
1743 Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
1746 if Token = Tok_Abstract then
1747 Error_Msg_SC ("ABSTRACT must come before NEW, not after");
1751 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1752 Set_Null_Exclusion_Present (Typedef_Node, Not_Null_Present);
1753 Set_Subtype_Indication (Typedef_Node,
1754 P_Subtype_Indication (Not_Null_Present));
1756 -- Ada 2005 (AI-251): Deal with interfaces
1758 if Token = Tok_And then
1761 if Ada_Version < Ada_05 then
1763 ("abstract interface is an Ada 2005 extension");
1764 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1767 Set_Interface_List (Typedef_Node, New_List);
1770 Append (P_Qualified_Simple_Name, Interface_List (Typedef_Node));
1771 exit when Token /= Tok_And;
1775 if Token /= Tok_With then
1776 Error_Msg_SC ("WITH expected");
1781 -- Deal with record extension, note that we assume that a WITH is
1782 -- missing in the case of "type X is new Y record ..." or in the
1783 -- case of "type X is new Y null record".
1786 or else Token = Tok_Record
1787 or else Token = Tok_Null
1789 T_With; -- past WITH or give error message
1791 if Token = Tok_Limited then
1793 ("LIMITED keyword not allowed in private extension");
1794 Scan; -- ignore LIMITED
1797 -- Private extension declaration
1799 if Token = Tok_Private then
1800 Scan; -- past PRIVATE
1802 -- Throw away the type definition node and build the type
1803 -- declaration node. Note the caller must set the Sloc,
1804 -- Discriminant_Specifications, Unknown_Discriminants_Present,
1805 -- and Defined_Identifier fields in the returned node.
1808 Make_Private_Extension_Declaration (No_Location,
1809 Defining_Identifier => Empty,
1810 Subtype_Indication => Subtype_Indication (Typedef_Node),
1811 Abstract_Present => Abstract_Present (Typedef_Node),
1812 Interface_List => Interface_List (Typedef_Node));
1814 Delete_Node (Typedef_Node);
1815 return Typedecl_Node;
1817 -- Derived type definition with record extension part
1820 Set_Record_Extension_Part (Typedef_Node, P_Record_Definition);
1821 return Typedef_Node;
1824 -- Derived type definition with no record extension part
1827 return Typedef_Node;
1829 end P_Derived_Type_Def_Or_Private_Ext_Decl;
1831 ---------------------------
1832 -- 3.5 Range Constraint --
1833 ---------------------------
1835 -- RANGE_CONSTRAINT ::= range RANGE
1837 -- The caller has checked that the initial token is RANGE
1839 -- Error recovery: cannot raise Error_Resync
1841 function P_Range_Constraint return Node_Id is
1842 Range_Node : Node_Id;
1845 Range_Node := New_Node (N_Range_Constraint, Token_Ptr);
1847 Set_Range_Expression (Range_Node, P_Range);
1849 end P_Range_Constraint;
1856 -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
1858 -- Note: the range that appears in a membership test is parsed by
1859 -- P_Range_Or_Subtype_Mark (3.5).
1861 -- Error recovery: cannot raise Error_Resync
1863 function P_Range return Node_Id is
1864 Expr_Node : Node_Id;
1865 Range_Node : Node_Id;
1868 Expr_Node := P_Simple_Expression_Or_Range_Attribute;
1870 if Expr_Form = EF_Range_Attr then
1873 elsif Token = Tok_Dot_Dot then
1874 Range_Node := New_Node (N_Range, Token_Ptr);
1875 Set_Low_Bound (Range_Node, Expr_Node);
1877 Expr_Node := P_Expression;
1878 Check_Simple_Expression (Expr_Node);
1879 Set_High_Bound (Range_Node, Expr_Node);
1882 -- Anything else is an error
1885 T_Dot_Dot; -- force missing .. message
1890 ----------------------------------
1891 -- 3.5 P_Range_Or_Subtype_Mark --
1892 ----------------------------------
1895 -- RANGE_ATTRIBUTE_REFERENCE
1896 -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
1898 -- This routine scans out the range or subtype mark that forms the right
1899 -- operand of a membership test.
1901 -- Note: as documented in the Sinfo interface, although the syntax only
1902 -- allows a subtype mark, we in fact allow any simple expression to be
1903 -- returned from this routine. The semantics is responsible for issuing
1904 -- an appropriate message complaining if the argument is not a name.
1905 -- This simplifies the coding and error recovery processing in the
1906 -- parser, and in any case it is preferable not to consider this a
1907 -- syntax error and to continue with the semantic analysis.
1909 -- Error recovery: cannot raise Error_Resync
1911 function P_Range_Or_Subtype_Mark return Node_Id is
1912 Expr_Node : Node_Id;
1913 Range_Node : Node_Id;
1916 Expr_Node := P_Simple_Expression_Or_Range_Attribute;
1918 if Expr_Form = EF_Range_Attr then
1921 -- Simple_Expression .. Simple_Expression
1923 elsif Token = Tok_Dot_Dot then
1924 Check_Simple_Expression (Expr_Node);
1925 Range_Node := New_Node (N_Range, Token_Ptr);
1926 Set_Low_Bound (Range_Node, Expr_Node);
1928 Set_High_Bound (Range_Node, P_Simple_Expression);
1931 -- Case of subtype mark (optionally qualified simple name or an
1932 -- attribute whose prefix is an optionally qualifed simple name)
1934 elsif Expr_Form = EF_Simple_Name
1935 or else Nkind (Expr_Node) = N_Attribute_Reference
1937 -- Check for error of range constraint after a subtype mark
1939 if Token = Tok_Range then
1941 ("range constraint not allowed in membership test");
1945 -- Check for error of DIGITS or DELTA after a subtype mark
1947 elsif Token = Tok_Digits or else Token = Tok_Delta then
1949 ("accuracy definition not allowed in membership test");
1950 Scan; -- past DIGITS or DELTA
1953 elsif Token = Tok_Apostrophe then
1954 return P_Subtype_Mark_Attribute (Expr_Node);
1960 -- At this stage, we have some junk following the expression. We
1961 -- really can't tell what is wrong, might be a missing semicolon,
1962 -- or a missing THEN, or whatever. Our caller will figure it out!
1967 end P_Range_Or_Subtype_Mark;
1969 ----------------------------------------
1970 -- 3.5.1 Enumeration Type Definition --
1971 ----------------------------------------
1973 -- ENUMERATION_TYPE_DEFINITION ::=
1974 -- (ENUMERATION_LITERAL_SPECIFICATION
1975 -- {, ENUMERATION_LITERAL_SPECIFICATION})
1977 -- The caller has already scanned out the TYPE keyword
1979 -- Error recovery: can raise Error_Resync;
1981 function P_Enumeration_Type_Definition return Node_Id is
1982 Typedef_Node : Node_Id;
1985 Typedef_Node := New_Node (N_Enumeration_Type_Definition, Token_Ptr);
1986 Set_Literals (Typedef_Node, New_List);
1991 Append (P_Enumeration_Literal_Specification, Literals (Typedef_Node));
1992 exit when not Comma_Present;
1996 return Typedef_Node;
1997 end P_Enumeration_Type_Definition;
1999 ----------------------------------------------
2000 -- 3.5.1 Enumeration Literal Specification --
2001 ----------------------------------------------
2003 -- ENUMERATION_LITERAL_SPECIFICATION ::=
2004 -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
2006 -- Error recovery: can raise Error_Resync
2008 function P_Enumeration_Literal_Specification return Node_Id is
2010 if Token = Tok_Char_Literal then
2011 return P_Defining_Character_Literal;
2013 return P_Defining_Identifier (C_Comma_Right_Paren);
2015 end P_Enumeration_Literal_Specification;
2017 ---------------------------------------
2018 -- 3.5.1 Defining_Character_Literal --
2019 ---------------------------------------
2021 -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
2023 -- Error recovery: cannot raise Error_Resync
2025 -- The caller has checked that the current token is a character literal
2027 function P_Defining_Character_Literal return Node_Id is
2028 Literal_Node : Node_Id;
2031 Literal_Node := Token_Node;
2032 Change_Character_Literal_To_Defining_Character_Literal (Literal_Node);
2033 Scan; -- past character literal
2034 return Literal_Node;
2035 end P_Defining_Character_Literal;
2037 ------------------------------------
2038 -- 3.5.4 Integer Type Definition --
2039 ------------------------------------
2041 -- Parsed by P_Type_Declaration (3.2.1)
2043 -------------------------------------------
2044 -- 3.5.4 Signed Integer Type Definition --
2045 -------------------------------------------
2047 -- SIGNED_INTEGER_TYPE_DEFINITION ::=
2048 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2050 -- Normally the initial token on entry is RANGE, but in some
2051 -- error conditions, the range token was missing and control is
2052 -- passed with Token pointing to first token of the first expression.
2054 -- Error recovery: cannot raise Error_Resync
2056 function P_Signed_Integer_Type_Definition return Node_Id is
2057 Typedef_Node : Node_Id;
2058 Expr_Node : Node_Id;
2061 Typedef_Node := New_Node (N_Signed_Integer_Type_Definition, Token_Ptr);
2063 if Token = Tok_Range then
2067 Expr_Node := P_Expression;
2068 Check_Simple_Expression (Expr_Node);
2069 Set_Low_Bound (Typedef_Node, Expr_Node);
2071 Expr_Node := P_Expression;
2072 Check_Simple_Expression (Expr_Node);
2073 Set_High_Bound (Typedef_Node, Expr_Node);
2074 return Typedef_Node;
2075 end P_Signed_Integer_Type_Definition;
2077 ------------------------------------
2078 -- 3.5.4 Modular Type Definition --
2079 ------------------------------------
2081 -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
2083 -- The caller has checked that the initial token is MOD
2085 -- Error recovery: cannot raise Error_Resync
2087 function P_Modular_Type_Definition return Node_Id is
2088 Typedef_Node : Node_Id;
2091 if Ada_Version = Ada_83 then
2092 Error_Msg_SC ("(Ada 83): modular types not allowed");
2095 Typedef_Node := New_Node (N_Modular_Type_Definition, Token_Ptr);
2097 Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
2099 -- Handle mod L..R cleanly
2101 if Token = Tok_Dot_Dot then
2102 Error_Msg_SC ("range not allowed for modular type");
2104 Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
2107 return Typedef_Node;
2108 end P_Modular_Type_Definition;
2110 ---------------------------------
2111 -- 3.5.6 Real Type Definition --
2112 ---------------------------------
2114 -- Parsed by P_Type_Declaration (3.2.1)
2116 --------------------------------------
2117 -- 3.5.7 Floating Point Definition --
2118 --------------------------------------
2120 -- FLOATING_POINT_DEFINITION ::=
2121 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2123 -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
2125 -- The caller has checked that the initial token is DIGITS
2127 -- Error recovery: cannot raise Error_Resync
2129 function P_Floating_Point_Definition return Node_Id is
2130 Digits_Loc : constant Source_Ptr := Token_Ptr;
2132 Expr_Node : Node_Id;
2135 Scan; -- past DIGITS
2136 Expr_Node := P_Expression_No_Right_Paren;
2137 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2139 -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
2141 if Token = Tok_Delta then
2142 Error_Msg_SC ("DELTA must come before DIGITS");
2143 Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Digits_Loc);
2145 Set_Delta_Expression (Def_Node, P_Expression_No_Right_Paren);
2147 -- OK floating-point definition
2150 Def_Node := New_Node (N_Floating_Point_Definition, Digits_Loc);
2153 Set_Digits_Expression (Def_Node, Expr_Node);
2154 Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt);
2156 end P_Floating_Point_Definition;
2158 -------------------------------------
2159 -- 3.5.7 Real Range Specification --
2160 -------------------------------------
2162 -- REAL_RANGE_SPECIFICATION ::=
2163 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2165 -- Error recovery: cannot raise Error_Resync
2167 function P_Real_Range_Specification_Opt return Node_Id is
2168 Specification_Node : Node_Id;
2169 Expr_Node : Node_Id;
2172 if Token = Tok_Range then
2173 Specification_Node :=
2174 New_Node (N_Real_Range_Specification, Token_Ptr);
2176 Expr_Node := P_Expression_No_Right_Paren;
2177 Check_Simple_Expression (Expr_Node);
2178 Set_Low_Bound (Specification_Node, Expr_Node);
2180 Expr_Node := P_Expression_No_Right_Paren;
2181 Check_Simple_Expression (Expr_Node);
2182 Set_High_Bound (Specification_Node, Expr_Node);
2183 return Specification_Node;
2187 end P_Real_Range_Specification_Opt;
2189 -----------------------------------
2190 -- 3.5.9 Fixed Point Definition --
2191 -----------------------------------
2193 -- FIXED_POINT_DEFINITION ::=
2194 -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
2196 -- ORDINARY_FIXED_POINT_DEFINITION ::=
2197 -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION
2199 -- DECIMAL_FIXED_POINT_DEFINITION ::=
2200 -- delta static_EXPRESSION
2201 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2203 -- The caller has checked that the initial token is DELTA
2205 -- Error recovery: cannot raise Error_Resync
2207 function P_Fixed_Point_Definition return Node_Id is
2208 Delta_Node : Node_Id;
2209 Delta_Loc : Source_Ptr;
2211 Expr_Node : Node_Id;
2214 Delta_Loc := Token_Ptr;
2216 Delta_Node := P_Expression_No_Right_Paren;
2217 Check_Simple_Expression_In_Ada_83 (Delta_Node);
2219 if Token = Tok_Digits then
2220 if Ada_Version = Ada_83 then
2221 Error_Msg_SC ("(Ada 83) decimal fixed type not allowed!");
2224 Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Delta_Loc);
2225 Scan; -- past DIGITS
2226 Expr_Node := P_Expression_No_Right_Paren;
2227 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2228 Set_Digits_Expression (Def_Node, Expr_Node);
2231 Def_Node := New_Node (N_Ordinary_Fixed_Point_Definition, Delta_Loc);
2233 -- Range is required in ordinary fixed point case
2235 if Token /= Tok_Range then
2236 Error_Msg_AP ("range must be given for fixed-point type");
2241 Set_Delta_Expression (Def_Node, Delta_Node);
2242 Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt);
2244 end P_Fixed_Point_Definition;
2246 --------------------------------------------
2247 -- 3.5.9 Ordinary Fixed Point Definition --
2248 --------------------------------------------
2250 -- Parsed by P_Fixed_Point_Definition (3.5.9)
2252 -------------------------------------------
2253 -- 3.5.9 Decimal Fixed Point Definition --
2254 -------------------------------------------
2256 -- Parsed by P_Decimal_Point_Definition (3.5.9)
2258 ------------------------------
2259 -- 3.5.9 Digits Constraint --
2260 ------------------------------
2262 -- DIGITS_CONSTRAINT ::=
2263 -- digits static_EXPRESSION [RANGE_CONSTRAINT]
2265 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2267 -- The caller has checked that the initial token is DIGITS
2269 function P_Digits_Constraint return Node_Id is
2270 Constraint_Node : Node_Id;
2271 Expr_Node : Node_Id;
2274 Constraint_Node := New_Node (N_Digits_Constraint, Token_Ptr);
2275 Scan; -- past DIGITS
2276 Expr_Node := P_Expression_No_Right_Paren;
2277 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2278 Set_Digits_Expression (Constraint_Node, Expr_Node);
2280 if Token = Tok_Range then
2281 Set_Range_Constraint (Constraint_Node, P_Range_Constraint);
2284 return Constraint_Node;
2285 end P_Digits_Constraint;
2287 -----------------------------
2288 -- 3.5.9 Delta Constraint --
2289 -----------------------------
2291 -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
2293 -- Note: this is an obsolescent feature in Ada 95 (I.3)
2295 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2297 -- The caller has checked that the initial token is DELTA
2299 -- Error recovery: cannot raise Error_Resync
2301 function P_Delta_Constraint return Node_Id is
2302 Constraint_Node : Node_Id;
2303 Expr_Node : Node_Id;
2306 Constraint_Node := New_Node (N_Delta_Constraint, Token_Ptr);
2308 Expr_Node := P_Expression_No_Right_Paren;
2309 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2310 Set_Delta_Expression (Constraint_Node, Expr_Node);
2312 if Token = Tok_Range then
2313 Set_Range_Constraint (Constraint_Node, P_Range_Constraint);
2316 return Constraint_Node;
2317 end P_Delta_Constraint;
2319 --------------------------------
2320 -- 3.6 Array Type Definition --
2321 --------------------------------
2323 -- ARRAY_TYPE_DEFINITION ::=
2324 -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
2326 -- UNCONSTRAINED_ARRAY_DEFINITION ::=
2327 -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
2328 -- COMPONENT_DEFINITION
2330 -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
2332 -- CONSTRAINED_ARRAY_DEFINITION ::=
2333 -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
2334 -- COMPONENT_DEFINITION
2336 -- DISCRETE_SUBTYPE_DEFINITION ::=
2337 -- DISCRETE_SUBTYPE_INDICATION | RANGE
2339 -- COMPONENT_DEFINITION ::=
2340 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
2342 -- The caller has checked that the initial token is ARRAY
2344 -- Error recovery: can raise Error_Resync
2346 function P_Array_Type_Definition return Node_Id is
2347 Array_Loc : Source_Ptr;
2348 CompDef_Node : Node_Id;
2350 Not_Null_Present : Boolean := False;
2351 Subs_List : List_Id;
2352 Scan_State : Saved_Scan_State;
2353 Aliased_Present : Boolean := False;
2356 Array_Loc := Token_Ptr;
2358 Subs_List := New_List;
2361 -- It's quite tricky to disentangle these two possibilities, so we do
2362 -- a prescan to determine which case we have and then reset the scan.
2363 -- The prescan skips past possible subtype mark tokens.
2365 Save_Scan_State (Scan_State); -- just after paren
2367 while Token in Token_Class_Desig or else
2368 Token = Tok_Dot or else
2369 Token = Tok_Apostrophe -- because of 'BASE, 'CLASS
2374 -- If we end up on RANGE <> then we have the unconstrained case. We
2375 -- will also allow the RANGE to be omitted, just to improve error
2376 -- handling for a case like array (integer <>) of integer;
2378 Scan; -- past possible RANGE or <>
2380 if (Prev_Token = Tok_Range and then Token = Tok_Box) or else
2381 Prev_Token = Tok_Box
2383 Def_Node := New_Node (N_Unconstrained_Array_Definition, Array_Loc);
2384 Restore_Scan_State (Scan_State); -- to first subtype mark
2387 Append (P_Subtype_Mark_Resync, Subs_List);
2390 exit when Token = Tok_Right_Paren or else Token = Tok_Of;
2394 Set_Subtype_Marks (Def_Node, Subs_List);
2397 Def_Node := New_Node (N_Constrained_Array_Definition, Array_Loc);
2398 Restore_Scan_State (Scan_State); -- to first discrete range
2401 Append (P_Discrete_Subtype_Definition, Subs_List);
2402 exit when not Comma_Present;
2405 Set_Discrete_Subtype_Definitions (Def_Node, Subs_List);
2411 CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
2413 if Token_Name = Name_Aliased then
2414 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
2417 if Token = Tok_Aliased then
2418 Aliased_Present := True;
2419 Scan; -- past ALIASED
2422 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254)
2424 -- Ada 2005 (AI-230): Access Definition case
2426 if Token = Tok_Access then
2427 if Ada_Version < Ada_05 then
2429 ("generalized use of anonymous access types " &
2430 "is an Ada 2005 extension");
2431 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
2434 if Aliased_Present then
2435 Error_Msg_SP ("ALIASED not allowed here");
2438 Set_Subtype_Indication (CompDef_Node, Empty);
2439 Set_Aliased_Present (CompDef_Node, False);
2440 Set_Access_Definition (CompDef_Node,
2441 P_Access_Definition (Not_Null_Present));
2444 Set_Access_Definition (CompDef_Node, Empty);
2445 Set_Aliased_Present (CompDef_Node, Aliased_Present);
2446 Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
2447 Set_Subtype_Indication (CompDef_Node,
2448 P_Subtype_Indication (Not_Null_Present));
2451 Set_Component_Definition (Def_Node, CompDef_Node);
2454 end P_Array_Type_Definition;
2456 -----------------------------------------
2457 -- 3.6 Unconstrained Array Definition --
2458 -----------------------------------------
2460 -- Parsed by P_Array_Type_Definition (3.6)
2462 ---------------------------------------
2463 -- 3.6 Constrained Array Definition --
2464 ---------------------------------------
2466 -- Parsed by P_Array_Type_Definition (3.6)
2468 --------------------------------------
2469 -- 3.6 Discrete Subtype Definition --
2470 --------------------------------------
2472 -- DISCRETE_SUBTYPE_DEFINITION ::=
2473 -- discrete_SUBTYPE_INDICATION | RANGE
2475 -- Note: the discrete subtype definition appearing in a constrained
2476 -- array definition is parsed by P_Array_Type_Definition (3.6)
2478 -- Error recovery: cannot raise Error_Resync
2480 function P_Discrete_Subtype_Definition return Node_Id is
2482 -- The syntax of a discrete subtype definition is identical to that
2483 -- of a discrete range, so we simply share the same parsing code.
2485 return P_Discrete_Range;
2486 end P_Discrete_Subtype_Definition;
2488 -------------------------------
2489 -- 3.6 Component Definition --
2490 -------------------------------
2492 -- For the array case, parsed by P_Array_Type_Definition (3.6)
2493 -- For the record case, parsed by P_Component_Declaration (3.8)
2495 -----------------------------
2496 -- 3.6.1 Index Constraint --
2497 -----------------------------
2499 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2501 ---------------------------
2502 -- 3.6.1 Discrete Range --
2503 ---------------------------
2505 -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
2507 -- The possible forms for a discrete range are:
2509 -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2)
2510 -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2)
2511 -- Range_Attribute (RANGE, 3.5)
2512 -- Simple_Expression .. Simple_Expression (RANGE, 3.5)
2514 -- Error recovery: cannot raise Error_Resync
2516 function P_Discrete_Range return Node_Id is
2517 Expr_Node : Node_Id;
2518 Range_Node : Node_Id;
2521 Expr_Node := P_Simple_Expression_Or_Range_Attribute;
2523 if Expr_Form = EF_Range_Attr then
2526 elsif Token = Tok_Range then
2527 if Expr_Form /= EF_Simple_Name then
2528 Error_Msg_SC ("range must be preceded by subtype mark");
2531 return P_Subtype_Indication (Expr_Node);
2533 -- Check Expression .. Expression case
2535 elsif Token = Tok_Dot_Dot then
2536 Range_Node := New_Node (N_Range, Token_Ptr);
2537 Set_Low_Bound (Range_Node, Expr_Node);
2539 Expr_Node := P_Expression;
2540 Check_Simple_Expression (Expr_Node);
2541 Set_High_Bound (Range_Node, Expr_Node);
2544 -- Otherwise we must have a subtype mark
2546 elsif Expr_Form = EF_Simple_Name then
2549 -- If incorrect, complain that we expect ..
2555 end P_Discrete_Range;
2557 ----------------------------
2558 -- 3.7 Discriminant Part --
2559 ----------------------------
2561 -- DISCRIMINANT_PART ::=
2562 -- UNKNOWN_DISCRIMINANT_PART
2563 -- | KNOWN_DISCRIMINANT_PART
2565 -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
2566 -- or P_Unknown_Discriminant_Part (3.7), since we know which we want.
2568 ------------------------------------
2569 -- 3.7 Unknown Discriminant Part --
2570 ------------------------------------
2572 -- UNKNOWN_DISCRIMINANT_PART ::= (<>)
2574 -- If no unknown discriminant part is present, then False is returned,
2575 -- otherwise the unknown discriminant is scanned out and True is returned.
2577 -- Error recovery: cannot raise Error_Resync
2579 function P_Unknown_Discriminant_Part_Opt return Boolean is
2580 Scan_State : Saved_Scan_State;
2583 if Token /= Tok_Left_Paren then
2587 Save_Scan_State (Scan_State);
2588 Scan; -- past the left paren
2590 if Token = Tok_Box then
2591 if Ada_Version = Ada_83 then
2592 Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!");
2595 Scan; -- past the box
2596 T_Right_Paren; -- must be followed by right paren
2600 Restore_Scan_State (Scan_State);
2604 end P_Unknown_Discriminant_Part_Opt;
2606 ----------------------------------
2607 -- 3.7 Known Discriminant Part --
2608 ----------------------------------
2610 -- KNOWN_DISCRIMINANT_PART ::=
2611 -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
2613 -- DISCRIMINANT_SPECIFICATION ::=
2614 -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
2615 -- [:= DEFAULT_EXPRESSION]
2616 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
2617 -- [:= DEFAULT_EXPRESSION]
2619 -- If no known discriminant part is present, then No_List is returned
2621 -- Error recovery: cannot raise Error_Resync
2623 function P_Known_Discriminant_Part_Opt return List_Id is
2624 Specification_Node : Node_Id;
2625 Specification_List : List_Id;
2626 Ident_Sloc : Source_Ptr;
2627 Scan_State : Saved_Scan_State;
2629 Not_Null_Present : Boolean;
2632 Idents : array (Int range 1 .. 4096) of Entity_Id;
2633 -- This array holds the list of defining identifiers. The upper bound
2634 -- of 4096 is intended to be essentially infinite, and we do not even
2635 -- bother to check for it being exceeded.
2638 if Token = Tok_Left_Paren then
2639 Specification_List := New_List;
2641 P_Pragmas_Misplaced;
2643 Specification_Loop : loop
2645 Ident_Sloc := Token_Ptr;
2646 Idents (1) := P_Defining_Identifier (C_Comma_Colon);
2649 while Comma_Present loop
2650 Num_Idents := Num_Idents + 1;
2651 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
2656 -- If there are multiple identifiers, we repeatedly scan the
2657 -- type and initialization expression information by resetting
2658 -- the scan pointer (so that we get completely separate trees
2659 -- for each occurrence).
2661 if Num_Idents > 1 then
2662 Save_Scan_State (Scan_State);
2665 -- Loop through defining identifiers in list
2669 Specification_Node :=
2670 New_Node (N_Discriminant_Specification, Ident_Sloc);
2671 Set_Defining_Identifier (Specification_Node, Idents (Ident));
2672 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
2674 if Token = Tok_Access then
2675 if Ada_Version = Ada_83 then
2677 ("(Ada 83) access discriminant not allowed!");
2680 Set_Discriminant_Type
2681 (Specification_Node,
2682 P_Access_Definition (Not_Null_Present));
2685 Set_Discriminant_Type
2686 (Specification_Node, P_Subtype_Mark);
2688 Set_Null_Exclusion_Present -- Ada 2005 (AI-231)
2689 (Specification_Node, Not_Null_Present);
2693 (Specification_Node, Init_Expr_Opt (True));
2696 Set_Prev_Ids (Specification_Node, True);
2699 if Ident < Num_Idents then
2700 Set_More_Ids (Specification_Node, True);
2703 Append (Specification_Node, Specification_List);
2704 exit Ident_Loop when Ident = Num_Idents;
2706 Restore_Scan_State (Scan_State);
2707 end loop Ident_Loop;
2709 exit Specification_Loop when Token /= Tok_Semicolon;
2711 P_Pragmas_Misplaced;
2712 end loop Specification_Loop;
2715 return Specification_List;
2720 end P_Known_Discriminant_Part_Opt;
2722 -------------------------------------
2723 -- 3.7 DIscriminant Specification --
2724 -------------------------------------
2726 -- Parsed by P_Known_Discriminant_Part_Opt (3.7)
2728 -----------------------------
2729 -- 3.7 Default Expression --
2730 -----------------------------
2732 -- Always parsed (simply as an Expression) by the parent construct
2734 ------------------------------------
2735 -- 3.7.1 Discriminant Constraint --
2736 ------------------------------------
2738 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2740 --------------------------------------------------------
2741 -- 3.7.1 Index or Discriminant Constraint (also 3.6) --
2742 --------------------------------------------------------
2744 -- DISCRIMINANT_CONSTRAINT ::=
2745 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
2747 -- DISCRIMINANT_ASSOCIATION ::=
2748 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2751 -- This routine parses either an index or a discriminant constraint. As
2752 -- is clear from the above grammar, it is often possible to clearly
2753 -- determine which of the two possibilities we have, but there are
2754 -- cases (those in which we have a series of expressions of the same
2755 -- syntactic form as subtype indications), where we cannot tell. Since
2756 -- this means that in any case the semantic phase has to distinguish
2757 -- between the two, there is not much point in the parser trying to
2758 -- distinguish even those cases where the difference is clear. In any
2759 -- case, if we have a situation like:
2761 -- (A => 123, 235 .. 500)
2763 -- it is not clear which of the two items is the wrong one, better to
2764 -- let the semantic phase give a clear message. Consequently, this
2765 -- routine in general returns a list of items which can be either
2766 -- discrete ranges or discriminant associations.
2768 -- The caller has checked that the initial token is a left paren
2770 -- Error recovery: can raise Error_Resync
2772 function P_Index_Or_Discriminant_Constraint return Node_Id is
2773 Scan_State : Saved_Scan_State;
2774 Constr_Node : Node_Id;
2775 Constr_List : List_Id;
2776 Expr_Node : Node_Id;
2777 Result_Node : Node_Id;
2780 Result_Node := New_Node (N_Index_Or_Discriminant_Constraint, Token_Ptr);
2782 Constr_List := New_List;
2783 Set_Constraints (Result_Node, Constr_List);
2785 -- The two syntactic forms are a little mixed up, so what we are doing
2786 -- here is looking at the first entry to determine which case we have
2788 -- A discriminant constraint is a list of discriminant associations,
2789 -- which have one of the following possible forms:
2793 -- Id | Id | .. | Id => Expression
2795 -- An index constraint is a list of discrete ranges which have one
2796 -- of the following possible forms:
2799 -- Subtype_Mark range Range
2801 -- Simple_Expression .. Simple_Expression
2803 -- Loop through discriminants in list
2806 -- Check cases of Id => Expression or Id | Id => Expression
2808 if Token = Tok_Identifier then
2809 Save_Scan_State (Scan_State); -- at Id
2812 if Token = Tok_Arrow or else Token = Tok_Vertical_Bar then
2813 Restore_Scan_State (Scan_State); -- to Id
2814 Append (P_Discriminant_Association, Constr_List);
2817 Restore_Scan_State (Scan_State); -- to Id
2821 -- Otherwise scan out an expression and see what we have got
2823 Expr_Node := P_Expression_Or_Range_Attribute;
2825 if Expr_Form = EF_Range_Attr then
2826 Append (Expr_Node, Constr_List);
2828 elsif Token = Tok_Range then
2829 if Expr_Form /= EF_Simple_Name then
2830 Error_Msg_SC ("subtype mark required before RANGE");
2833 Append (P_Subtype_Indication (Expr_Node), Constr_List);
2836 -- Check Simple_Expression .. Simple_Expression case
2838 elsif Token = Tok_Dot_Dot then
2839 Check_Simple_Expression (Expr_Node);
2840 Constr_Node := New_Node (N_Range, Token_Ptr);
2841 Set_Low_Bound (Constr_Node, Expr_Node);
2843 Expr_Node := P_Expression;
2844 Check_Simple_Expression (Expr_Node);
2845 Set_High_Bound (Constr_Node, Expr_Node);
2846 Append (Constr_Node, Constr_List);
2849 -- Case of an expression which could be either form
2852 Append (Expr_Node, Constr_List);
2856 -- Here with a single entry scanned
2859 exit when not Comma_Present;
2865 end P_Index_Or_Discriminant_Constraint;
2867 -------------------------------------
2868 -- 3.7.1 Discriminant Association --
2869 -------------------------------------
2871 -- DISCRIMINANT_ASSOCIATION ::=
2872 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2875 -- This routine is used only when the name list is present and the caller
2876 -- has already checked this (by scanning ahead and repositioning the
2879 -- Error_Recovery: cannot raise Error_Resync;
2881 function P_Discriminant_Association return Node_Id is
2882 Discr_Node : Node_Id;
2883 Names_List : List_Id;
2884 Ident_Sloc : Source_Ptr;
2887 Ident_Sloc := Token_Ptr;
2888 Names_List := New_List;
2891 Append (P_Identifier (C_Vertical_Bar_Arrow), Names_List);
2892 exit when Token /= Tok_Vertical_Bar;
2896 Discr_Node := New_Node (N_Discriminant_Association, Ident_Sloc);
2897 Set_Selector_Names (Discr_Node, Names_List);
2899 Set_Expression (Discr_Node, P_Expression);
2901 end P_Discriminant_Association;
2903 ---------------------------------
2904 -- 3.8 Record Type Definition --
2905 ---------------------------------
2907 -- RECORD_TYPE_DEFINITION ::=
2908 -- [[abstract] tagged] [limited] RECORD_DEFINITION
2910 -- There is no node in the tree for a record type definition. Instead
2911 -- a record definition node appears, with possible Abstract_Present,
2912 -- Tagged_Present, and Limited_Present flags set appropriately.
2914 ----------------------------
2915 -- 3.8 Record Definition --
2916 ----------------------------
2918 -- RECORD_DEFINITION ::=
2924 -- Note: in the case where a record definition node is used to represent
2925 -- a record type definition, the caller sets the Tagged_Present and
2926 -- Limited_Present flags in the resulting N_Record_Definition node as
2929 -- Note that the RECORD token at the start may be missing in certain
2930 -- error situations, so this function is expected to post the error
2932 -- Error recovery: can raise Error_Resync
2934 function P_Record_Definition return Node_Id is
2938 Rec_Node := New_Node (N_Record_Definition, Token_Ptr);
2942 if Token = Tok_Null then
2945 Set_Null_Present (Rec_Node, True);
2947 -- Case starting with RECORD keyword. Build scope stack entry. For the
2948 -- column, we use the first non-blank character on the line, to deal
2949 -- with situations such as:
2955 -- which is not official RM indentation, but is not uncommon usage
2959 Scope.Table (Scope.Last).Etyp := E_Record;
2960 Scope.Table (Scope.Last).Ecol := Start_Column;
2961 Scope.Table (Scope.Last).Sloc := Token_Ptr;
2962 Scope.Table (Scope.Last).Labl := Error;
2963 Scope.Table (Scope.Last).Junk := (Token /= Tok_Record);
2967 Set_Component_List (Rec_Node, P_Component_List);
2970 exit when Check_End;
2971 Discard_Junk_Node (P_Component_List);
2976 end P_Record_Definition;
2978 -------------------------
2979 -- 3.8 Component List --
2980 -------------------------
2982 -- COMPONENT_LIST ::=
2983 -- COMPONENT_ITEM {COMPONENT_ITEM}
2984 -- | {COMPONENT_ITEM} VARIANT_PART
2987 -- Error recovery: cannot raise Error_Resync
2989 function P_Component_List return Node_Id is
2990 Component_List_Node : Node_Id;
2991 Decls_List : List_Id;
2992 Scan_State : Saved_Scan_State;
2995 Component_List_Node := New_Node (N_Component_List, Token_Ptr);
2996 Decls_List := New_List;
2998 if Token = Tok_Null then
3001 P_Pragmas_Opt (Decls_List);
3002 Set_Null_Present (Component_List_Node, True);
3003 return Component_List_Node;
3006 P_Pragmas_Opt (Decls_List);
3008 if Token /= Tok_Case then
3009 Component_Scan_Loop : loop
3010 P_Component_Items (Decls_List);
3011 P_Pragmas_Opt (Decls_List);
3013 exit Component_Scan_Loop when Token = Tok_End
3014 or else Token = Tok_Case
3015 or else Token = Tok_When;
3017 -- We are done if we do not have an identifier. However, if
3018 -- we have a misspelled reserved identifier that is in a column
3019 -- to the right of the record definition, we will treat it as
3020 -- an identifier. It turns out to be too dangerous in practice
3021 -- to accept such a mis-spelled identifier which does not have
3022 -- this additional clue that confirms the incorrect spelling.
3024 if Token /= Tok_Identifier then
3025 if Start_Column > Scope.Table (Scope.Last).Ecol
3026 and then Is_Reserved_Identifier
3028 Save_Scan_State (Scan_State); -- at reserved id
3029 Scan; -- possible reserved id
3031 if Token = Tok_Comma or else Token = Tok_Colon then
3032 Restore_Scan_State (Scan_State);
3033 Scan_Reserved_Identifier (Force_Msg => True);
3035 -- Note reserved identifier used as field name after
3036 -- all because not followed by colon or comma
3039 Restore_Scan_State (Scan_State);
3040 exit Component_Scan_Loop;
3043 -- Non-identifier that definitely was not reserved id
3046 exit Component_Scan_Loop;
3049 end loop Component_Scan_Loop;
3052 if Token = Tok_Case then
3053 Set_Variant_Part (Component_List_Node, P_Variant_Part);
3055 -- Check for junk after variant part
3057 if Token = Tok_Identifier then
3058 Save_Scan_State (Scan_State);
3059 Scan; -- past identifier
3061 if Token = Tok_Colon then
3062 Restore_Scan_State (Scan_State);
3063 Error_Msg_SC ("component may not follow variant part");
3064 Discard_Junk_Node (P_Component_List);
3066 elsif Token = Tok_Case then
3067 Restore_Scan_State (Scan_State);
3068 Error_Msg_SC ("only one variant part allowed in a record");
3069 Discard_Junk_Node (P_Component_List);
3072 Restore_Scan_State (Scan_State);
3078 Set_Component_Items (Component_List_Node, Decls_List);
3079 return Component_List_Node;
3080 end P_Component_List;
3082 -------------------------
3083 -- 3.8 Component Item --
3084 -------------------------
3086 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
3088 -- COMPONENT_DECLARATION ::=
3089 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
3090 -- [:= DEFAULT_EXPRESSION];
3092 -- COMPONENT_DEFINITION ::=
3093 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
3095 -- Error recovery: cannot raise Error_Resync, if an error occurs,
3096 -- the scan is positioned past the following semicolon.
3098 -- Note: we do not yet allow representation clauses to appear as component
3099 -- items, do we need to add this capability sometime in the future ???
3101 procedure P_Component_Items (Decls : List_Id) is
3102 Aliased_Present : Boolean := False;
3103 CompDef_Node : Node_Id;
3104 Decl_Node : Node_Id;
3105 Scan_State : Saved_Scan_State;
3106 Not_Null_Present : Boolean := False;
3109 Ident_Sloc : Source_Ptr;
3111 Idents : array (Int range 1 .. 4096) of Entity_Id;
3112 -- This array holds the list of defining identifiers. The upper bound
3113 -- of 4096 is intended to be essentially infinite, and we do not even
3114 -- bother to check for it being exceeded.
3117 if Token /= Tok_Identifier then
3118 Error_Msg_SC ("component declaration expected");
3119 Resync_Past_Semicolon;
3123 Ident_Sloc := Token_Ptr;
3124 Idents (1) := P_Defining_Identifier (C_Comma_Colon);
3127 while Comma_Present loop
3128 Num_Idents := Num_Idents + 1;
3129 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
3134 -- If there are multiple identifiers, we repeatedly scan the
3135 -- type and initialization expression information by resetting
3136 -- the scan pointer (so that we get completely separate trees
3137 -- for each occurrence).
3139 if Num_Idents > 1 then
3140 Save_Scan_State (Scan_State);
3143 -- Loop through defining identifiers in list
3148 -- The following block is present to catch Error_Resync
3149 -- which causes the parse to be reset past the semicolon
3152 Decl_Node := New_Node (N_Component_Declaration, Ident_Sloc);
3153 Set_Defining_Identifier (Decl_Node, Idents (Ident));
3155 if Token = Tok_Constant then
3156 Error_Msg_SC ("constant components are not permitted");
3160 CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
3162 if Token_Name = Name_Aliased then
3163 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
3166 if Token = Tok_Aliased then
3167 Aliased_Present := True;
3168 Scan; -- past ALIASED
3171 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254)
3173 -- Ada 2005 (AI-230): Access Definition case
3175 if Token = Tok_Access then
3176 if Ada_Version < Ada_05 then
3178 ("generalized use of anonymous access types " &
3179 "is an Ada 2005 extension");
3180 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
3183 if Aliased_Present then
3184 Error_Msg_SP ("ALIASED not allowed here");
3187 Set_Subtype_Indication (CompDef_Node, Empty);
3188 Set_Aliased_Present (CompDef_Node, False);
3189 Set_Access_Definition (CompDef_Node,
3190 P_Access_Definition (Not_Null_Present));
3193 Set_Access_Definition (CompDef_Node, Empty);
3194 Set_Aliased_Present (CompDef_Node, Aliased_Present);
3195 Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
3197 if Token = Tok_Array then
3199 ("anonymous arrays not allowed as components");
3203 Set_Subtype_Indication (CompDef_Node,
3204 P_Subtype_Indication (Not_Null_Present));
3207 Set_Component_Definition (Decl_Node, CompDef_Node);
3208 Set_Expression (Decl_Node, Init_Expr_Opt);
3211 Set_Prev_Ids (Decl_Node, True);
3214 if Ident < Num_Idents then
3215 Set_More_Ids (Decl_Node, True);
3218 Append (Decl_Node, Decls);
3221 when Error_Resync =>
3222 if Token /= Tok_End then
3223 Resync_Past_Semicolon;
3227 exit Ident_Loop when Ident = Num_Idents;
3229 Restore_Scan_State (Scan_State);
3231 end loop Ident_Loop;
3234 end P_Component_Items;
3236 --------------------------------
3237 -- 3.8 Component Declaration --
3238 --------------------------------
3240 -- Parsed by P_Component_Items (3.8)
3242 -------------------------
3243 -- 3.8.1 Variant Part --
3244 -------------------------
3247 -- case discriminant_DIRECT_NAME is
3252 -- The caller has checked that the initial token is CASE
3254 -- Error recovery: cannot raise Error_Resync
3256 function P_Variant_Part return Node_Id is
3257 Variant_Part_Node : Node_Id;
3258 Variants_List : List_Id;
3259 Case_Node : Node_Id;
3262 Variant_Part_Node := New_Node (N_Variant_Part, Token_Ptr);
3264 Scope.Table (Scope.Last).Etyp := E_Case;
3265 Scope.Table (Scope.Last).Sloc := Token_Ptr;
3266 Scope.Table (Scope.Last).Ecol := Start_Column;
3269 Case_Node := P_Expression;
3270 Set_Name (Variant_Part_Node, Case_Node);
3272 if Nkind (Case_Node) /= N_Identifier then
3273 Set_Name (Variant_Part_Node, Error);
3274 Error_Msg ("discriminant name expected", Sloc (Case_Node));
3278 Variants_List := New_List;
3279 P_Pragmas_Opt (Variants_List);
3281 -- Test missing variant
3283 if Token = Tok_End then
3284 Error_Msg_BC ("WHEN expected (must have at least one variant)");
3286 Append (P_Variant, Variants_List);
3289 -- Loop through variants, note that we allow if in place of when,
3290 -- this error will be detected and handled in P_Variant.
3293 P_Pragmas_Opt (Variants_List);
3295 if Token /= Tok_When
3296 and then Token /= Tok_If
3297 and then Token /= Tok_Others
3299 exit when Check_End;
3302 Append (P_Variant, Variants_List);
3305 Set_Variants (Variant_Part_Node, Variants_List);
3306 return Variant_Part_Node;
3309 --------------------
3311 --------------------
3314 -- when DISCRETE_CHOICE_LIST =>
3317 -- Error recovery: cannot raise Error_Resync
3319 -- The initial token on entry is either WHEN, IF or OTHERS
3321 function P_Variant return Node_Id is
3322 Variant_Node : Node_Id;
3325 -- Special check to recover nicely from use of IF in place of WHEN
3327 if Token = Tok_If then
3334 Variant_Node := New_Node (N_Variant, Prev_Token_Ptr);
3335 Set_Discrete_Choices (Variant_Node, P_Discrete_Choice_List);
3337 Set_Component_List (Variant_Node, P_Component_List);
3338 return Variant_Node;
3341 ---------------------------------
3342 -- 3.8.1 Discrete Choice List --
3343 ---------------------------------
3345 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
3347 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
3349 -- Note: in Ada 83, the expression must be a simple expression
3351 -- Error recovery: cannot raise Error_Resync
3353 function P_Discrete_Choice_List return List_Id is
3355 Expr_Node : Node_Id;
3356 Choice_Node : Node_Id;
3359 Choices := New_List;
3362 if Token = Tok_Others then
3363 Append (New_Node (N_Others_Choice, Token_Ptr), Choices);
3364 Scan; -- past OTHERS
3368 Expr_Node := No_Right_Paren (P_Expression_Or_Range_Attribute);
3370 if Token = Tok_Colon
3371 and then Nkind (Expr_Node) = N_Identifier
3373 Error_Msg_SP ("label not permitted in this context");
3376 elsif Expr_Form = EF_Range_Attr then
3377 Append (Expr_Node, Choices);
3379 elsif Token = Tok_Dot_Dot then
3380 Check_Simple_Expression (Expr_Node);
3381 Choice_Node := New_Node (N_Range, Token_Ptr);
3382 Set_Low_Bound (Choice_Node, Expr_Node);
3384 Expr_Node := P_Expression_No_Right_Paren;
3385 Check_Simple_Expression (Expr_Node);
3386 Set_High_Bound (Choice_Node, Expr_Node);
3387 Append (Choice_Node, Choices);
3389 elsif Expr_Form = EF_Simple_Name then
3390 if Token = Tok_Range then
3391 Append (P_Subtype_Indication (Expr_Node), Choices);
3393 elsif Token in Token_Class_Consk then
3395 ("the only constraint allowed here " &
3396 "is a range constraint");
3397 Discard_Junk_Node (P_Constraint_Opt);
3398 Append (Expr_Node, Choices);
3401 Append (Expr_Node, Choices);
3405 Check_Simple_Expression_In_Ada_83 (Expr_Node);
3406 Append (Expr_Node, Choices);
3410 when Error_Resync =>
3416 if Token = Tok_Comma then
3417 Error_Msg_SC (""","" should be ""'|""");
3419 exit when Token /= Tok_Vertical_Bar;
3422 Scan; -- past | or comma
3426 end P_Discrete_Choice_List;
3428 ----------------------------
3429 -- 3.8.1 Discrete Choice --
3430 ----------------------------
3432 -- Parsed by P_Discrete_Choice_List (3.8.1)
3434 ----------------------------------
3435 -- 3.9.1 Record Extension Part --
3436 ----------------------------------
3438 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
3440 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
3442 --------------------------------------
3443 -- 3.9.4 Interface Type Definition --
3444 --------------------------------------
3446 -- INTERFACE_TYPE_DEFINITION ::=
3447 -- [limited | task | protected | synchronized] interface
3448 -- [AND interface_list]
3450 -- Error recovery: cannot raise Error_Resync
3452 function P_Interface_Type_Definition
3453 (Is_Synchronized : Boolean) return Node_Id
3455 Typedef_Node : Node_Id;
3458 if Ada_Version < Ada_05 then
3459 Error_Msg_SP ("abstract interface is an Ada 2005 extension");
3460 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
3463 Scan; -- past INTERFACE
3465 -- Ada 2005 (AI-345): In case of synchronized interfaces and
3466 -- interfaces with a null list of interfaces we build a
3467 -- record_definition node.
3470 or else Token = Tok_Semicolon
3472 Typedef_Node := New_Node (N_Record_Definition, Token_Ptr);
3474 Set_Abstract_Present (Typedef_Node);
3475 Set_Tagged_Present (Typedef_Node);
3476 Set_Null_Present (Typedef_Node);
3477 Set_Interface_Present (Typedef_Node);
3480 and then Token = Tok_And
3483 Set_Interface_List (Typedef_Node, New_List);
3486 Append (P_Qualified_Simple_Name,
3487 Interface_List (Typedef_Node));
3488 exit when Token /= Tok_And;
3493 -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have
3494 -- a list of interfaces we build a derived_type_definition node. This
3495 -- simplifies the semantic analysis (and hence further mainteinance)
3498 if Token /= Tok_And then
3499 Error_Msg_AP ("AND expected");
3504 Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
3506 Set_Abstract_Present (Typedef_Node);
3507 Set_Interface_Present (Typedef_Node);
3508 Set_Subtype_Indication (Typedef_Node, P_Qualified_Simple_Name);
3510 Set_Record_Extension_Part (Typedef_Node,
3511 New_Node (N_Record_Definition, Token_Ptr));
3512 Set_Null_Present (Record_Extension_Part (Typedef_Node));
3514 if Token = Tok_And then
3515 Set_Interface_List (Typedef_Node, New_List);
3519 Append (P_Qualified_Simple_Name,
3520 Interface_List (Typedef_Node));
3521 exit when Token /= Tok_And;
3527 return Typedef_Node;
3528 end P_Interface_Type_Definition;
3530 ----------------------------------
3531 -- 3.10 Access Type Definition --
3532 ----------------------------------
3534 -- ACCESS_TYPE_DEFINITION ::=
3535 -- ACCESS_TO_OBJECT_DEFINITION
3536 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3538 -- ACCESS_TO_OBJECT_DEFINITION ::=
3539 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
3541 -- GENERAL_ACCESS_MODIFIER ::= all | constant
3543 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3544 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3545 -- | [NULL_EXCLUSION] access [protected] function
3546 -- PARAMETER_AND_RESULT_PROFILE
3548 -- PARAMETER_PROFILE ::= [FORMAL_PART]
3550 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
3552 -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already
3553 -- parsed the null_exclusion part and has also removed the ACCESS token;
3554 -- otherwise the caller has just checked that the initial token is ACCESS
3556 -- Error recovery: can raise Error_Resync
3558 function P_Access_Type_Definition
3559 (Header_Already_Parsed : Boolean := False) return Node_Id is
3560 Access_Loc : constant Source_Ptr := Token_Ptr;
3561 Prot_Flag : Boolean;
3562 Not_Null_Present : Boolean := False;
3563 Type_Def_Node : Node_Id;
3565 procedure Check_Junk_Subprogram_Name;
3566 -- Used in access to subprogram definition cases to check for an
3567 -- identifier or operator symbol that does not belong.
3569 procedure Check_Junk_Subprogram_Name is
3570 Saved_State : Saved_Scan_State;
3573 if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
3574 Save_Scan_State (Saved_State);
3575 Scan; -- past possible junk subprogram name
3577 if Token = Tok_Left_Paren or else Token = Tok_Semicolon then
3578 Error_Msg_SP ("unexpected subprogram name ignored");
3582 Restore_Scan_State (Saved_State);
3585 end Check_Junk_Subprogram_Name;
3587 -- Start of processing for P_Access_Type_Definition
3590 if not Header_Already_Parsed then
3591 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
3592 Scan; -- past ACCESS
3595 if Token_Name = Name_Protected then
3596 Check_95_Keyword (Tok_Protected, Tok_Procedure);
3597 Check_95_Keyword (Tok_Protected, Tok_Function);
3600 Prot_Flag := (Token = Tok_Protected);
3603 Scan; -- past PROTECTED
3605 if Token /= Tok_Procedure and then Token /= Tok_Function then
3606 Error_Msg_SC ("FUNCTION or PROCEDURE expected");
3610 if Token = Tok_Procedure then
3611 if Ada_Version = Ada_83 then
3612 Error_Msg_SC ("(Ada 83) access to procedure not allowed!");
3615 Type_Def_Node := New_Node (N_Access_Procedure_Definition, Access_Loc);
3616 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3617 Scan; -- past PROCEDURE
3618 Check_Junk_Subprogram_Name;
3619 Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
3620 Set_Protected_Present (Type_Def_Node, Prot_Flag);
3622 elsif Token = Tok_Function then
3623 if Ada_Version = Ada_83 then
3624 Error_Msg_SC ("(Ada 83) access to function not allowed!");
3627 Type_Def_Node := New_Node (N_Access_Function_Definition, Access_Loc);
3628 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3629 Scan; -- past FUNCTION
3630 Check_Junk_Subprogram_Name;
3631 Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
3632 Set_Protected_Present (Type_Def_Node, Prot_Flag);
3634 Set_Subtype_Mark (Type_Def_Node, P_Subtype_Mark);
3639 New_Node (N_Access_To_Object_Definition, Access_Loc);
3640 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3642 if Token = Tok_All or else Token = Tok_Constant then
3643 if Ada_Version = Ada_83 then
3644 Error_Msg_SC ("(Ada 83) access modifier not allowed!");
3647 if Token = Tok_All then
3648 Set_All_Present (Type_Def_Node, True);
3651 Set_Constant_Present (Type_Def_Node, True);
3654 Scan; -- past ALL or CONSTANT
3657 Set_Subtype_Indication (Type_Def_Node,
3658 P_Subtype_Indication (Not_Null_Present));
3661 return Type_Def_Node;
3662 end P_Access_Type_Definition;
3664 ---------------------------------------
3665 -- 3.10 Access To Object Definition --
3666 ---------------------------------------
3668 -- Parsed by P_Access_Type_Definition (3.10)
3670 -----------------------------------
3671 -- 3.10 General Access Modifier --
3672 -----------------------------------
3674 -- Parsed by P_Access_Type_Definition (3.10)
3676 -------------------------------------------
3677 -- 3.10 Access To Subprogram Definition --
3678 -------------------------------------------
3680 -- Parsed by P_Access_Type_Definition (3.10)
3682 -----------------------------
3683 -- 3.10 Access Definition --
3684 -----------------------------
3686 -- ACCESS_DEFINITION ::=
3687 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3688 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3690 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3691 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3692 -- | [NULL_EXCLUSION] access [protected] function
3693 -- PARAMETER_AND_RESULT_PROFILE
3695 -- The caller has parsed the null-exclusion part and it has also checked
3696 -- that the next token is ACCESS
3698 -- Error recovery: cannot raise Error_Resync
3700 function P_Access_Definition
3701 (Null_Exclusion_Present : Boolean) return Node_Id is
3703 Subp_Node : Node_Id;
3706 Def_Node := New_Node (N_Access_Definition, Token_Ptr);
3707 Scan; -- past ACCESS
3709 -- Ada 2005 (AI-254/AI-231)
3711 if Ada_Version >= Ada_05 then
3713 -- Ada 2005 (AI-254): Access_To_Subprogram_Definition
3715 if Token = Tok_Protected
3716 or else Token = Tok_Procedure
3717 or else Token = Tok_Function
3720 P_Access_Type_Definition (Header_Already_Parsed => True);
3721 Set_Null_Exclusion_Present (Subp_Node, Null_Exclusion_Present);
3722 Set_Access_To_Subprogram_Definition (Def_Node, Subp_Node);
3724 -- Ada 2005 (AI-231)
3725 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3728 Set_Null_Exclusion_Present (Def_Node, Null_Exclusion_Present);
3730 if Token = Tok_All then
3732 Set_All_Present (Def_Node);
3734 elsif Token = Tok_Constant then
3735 Scan; -- past CONSTANT
3736 Set_Constant_Present (Def_Node);
3739 Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
3746 -- Ada 2005 (AI-254): The null-exclusion present is never present
3747 -- in Ada 83 and Ada 95
3749 pragma Assert (Null_Exclusion_Present = False);
3751 Set_Null_Exclusion_Present (Def_Node, False);
3752 Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
3757 end P_Access_Definition;
3759 -----------------------------------------
3760 -- 3.10.1 Incomplete Type Declaration --
3761 -----------------------------------------
3763 -- Parsed by P_Type_Declaration (3.2.1)
3765 ----------------------------
3766 -- 3.11 Declarative Part --
3767 ----------------------------
3769 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
3771 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items
3772 -- handles errors, and returns cleanly after an error has occurred)
3774 function P_Declarative_Part return List_Id is
3779 -- Indicate no bad declarations detected yet. This will be reset by
3780 -- P_Declarative_Items if a bad declaration is discovered.
3782 Missing_Begin_Msg := No_Error_Msg;
3784 -- Get rid of active SIS entry from outer scope. This means we will
3785 -- miss some nested cases, but it doesn't seem worth the effort. See
3786 -- discussion in Par for further details
3788 SIS_Entry_Active := False;
3791 -- Loop to scan out the declarations
3794 P_Declarative_Items (Decls, Done, In_Spec => False);
3798 -- Get rid of active SIS entry which is left set only if we scanned a
3799 -- procedure declaration and have not found the body. We could give
3800 -- an error message, but that really would be usurping the role of
3801 -- semantic analysis (this really is a missing body case).
3803 SIS_Entry_Active := False;
3805 end P_Declarative_Part;
3807 ----------------------------
3808 -- 3.11 Declarative Item --
3809 ----------------------------
3811 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
3813 -- Can return Error if a junk declaration is found, or Empty if no
3814 -- declaration is found (i.e. a token ending declarations, such as
3815 -- BEGIN or END is encountered).
3817 -- Error recovery: cannot raise Error_Resync. If an error resync occurs,
3818 -- then the scan is set past the next semicolon and Error is returned.
3820 procedure P_Declarative_Items
3825 Scan_State : Saved_Scan_State;
3828 if Style_Check then Style.Check_Indentation; end if;
3832 when Tok_Function =>
3834 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
3840 -- Check for loop (premature statement)
3842 Save_Scan_State (Scan_State);
3845 if Token = Tok_Identifier then
3846 Scan; -- past identifier
3848 if Token = Tok_In then
3849 Restore_Scan_State (Scan_State);
3850 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
3855 -- Not a loop, so must be rep clause
3857 Restore_Scan_State (Scan_State);
3858 Append (P_Representation_Clause, Decls);
3863 Append (P_Generic, Decls);
3866 when Tok_Identifier =>
3868 P_Identifier_Declarations (Decls, Done, In_Spec);
3870 -- Ada2005: A subprogram declaration can start with "not" or
3871 -- "overriding". In older versions, "overriding" is handled
3872 -- like an identifier, with the appropriate warning.
3876 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
3879 when Tok_Overriding =>
3881 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
3886 Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
3890 Append (P_Pragma, Decls);
3893 when Tok_Procedure =>
3895 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
3898 when Tok_Protected =>
3900 Scan; -- past PROTECTED
3901 Append (P_Protected, Decls);
3906 Append (P_Subtype_Declaration, Decls);
3912 Append (P_Task, Decls);
3917 Append (P_Type_Declaration, Decls);
3922 Append (P_Use_Clause, Decls);
3927 Error_Msg_SC ("WITH can only appear in context clause");
3930 -- BEGIN terminates the scan of a sequence of declarations unless
3931 -- there is a missing subprogram body, see section on handling
3932 -- semicolon in place of IS. We only treat the begin as satisfying
3933 -- the subprogram declaration if it falls in the expected column
3937 if SIS_Entry_Active and then Start_Column >= SIS_Ecol then
3939 -- Here we have the case where a BEGIN is encountered during
3940 -- declarations in a declarative part, or at the outer level,
3941 -- and there is a subprogram declaration outstanding for which
3942 -- no body has been supplied. This is the case where we assume
3943 -- that the semicolon in the subprogram declaration should
3944 -- really have been is. The active SIS entry describes the
3945 -- subprogram declaration. On return the declaration has been
3946 -- modified to become a body.
3949 Specification_Node : Node_Id;
3950 Decl_Node : Node_Id;
3951 Body_Node : Node_Id;
3954 -- First issue the error message. If we had a missing
3955 -- semicolon in the declaration, then change the message
3956 -- to <missing "is">
3958 if SIS_Missing_Semicolon_Message /= No_Error_Msg then
3959 Change_Error_Text -- Replace: "missing "";"" "
3960 (SIS_Missing_Semicolon_Message, "missing ""is""");
3962 -- Otherwise we saved the semicolon position, so complain
3965 Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc);
3968 -- The next job is to fix up any declarations that occurred
3969 -- between the procedure header and the BEGIN. These got
3970 -- chained to the outer declarative region (immediately
3971 -- after the procedure declaration) and they should be
3972 -- chained to the subprogram itself, which is a body
3973 -- rather than a spec.
3975 Specification_Node := Specification (SIS_Declaration_Node);
3976 Change_Node (SIS_Declaration_Node, N_Subprogram_Body);
3977 Body_Node := SIS_Declaration_Node;
3978 Set_Specification (Body_Node, Specification_Node);
3979 Set_Declarations (Body_Node, New_List);
3982 Decl_Node := Remove_Next (Body_Node);
3983 exit when Decl_Node = Empty;
3984 Append (Decl_Node, Declarations (Body_Node));
3987 -- Now make the scope table entry for the Begin-End and
3991 Scope.Table (Scope.Last).Sloc := SIS_Sloc;
3992 Scope.Table (Scope.Last).Etyp := E_Name;
3993 Scope.Table (Scope.Last).Ecol := SIS_Ecol;
3994 Scope.Table (Scope.Last).Labl := SIS_Labl;
3995 Scope.Table (Scope.Last).Lreq := False;
3996 SIS_Entry_Active := False;
3998 Set_Handled_Statement_Sequence (Body_Node,
3999 P_Handled_Sequence_Of_Statements);
4000 End_Statements (Handled_Statement_Sequence (Body_Node));
4009 -- Normally an END terminates the scan for basic declarative
4010 -- items. The one exception is END RECORD, which is probably
4011 -- left over from some other junk.
4014 Save_Scan_State (Scan_State); -- at END
4017 if Token = Tok_Record then
4018 Error_Msg_SP ("no RECORD for this `end record`!");
4019 Scan; -- past RECORD
4023 Restore_Scan_State (Scan_State); -- to END
4027 -- The following tokens which can only be the start of a statement
4028 -- are considered to end a declarative part (i.e. we have a missing
4029 -- BEGIN situation). We are fairly conservative in making this
4030 -- judgment, because it is a real mess to go into statement mode
4031 -- prematurely in response to a junk declaration.
4046 -- But before we decide that it's a statement, let's check for
4047 -- a reserved word misused as an identifier.
4049 if Is_Reserved_Identifier then
4050 Save_Scan_State (Scan_State);
4051 Scan; -- past the token
4053 -- If reserved identifier not followed by colon or comma, then
4054 -- this is most likely an assignment statement to the bad id.
4056 if Token /= Tok_Colon and then Token /= Tok_Comma then
4057 Restore_Scan_State (Scan_State);
4058 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
4061 -- Otherwise we have a declaration of the bad id
4064 Restore_Scan_State (Scan_State);
4065 Scan_Reserved_Identifier (Force_Msg => True);
4066 P_Identifier_Declarations (Decls, Done, In_Spec);
4069 -- If not reserved identifier, then it's definitely a statement
4072 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
4076 -- The token RETURN may well also signal a missing BEGIN situation,
4077 -- however, we never let it end the declarative part, because it may
4078 -- also be part of a half-baked function declaration.
4081 Error_Msg_SC ("misplaced RETURN statement");
4084 -- PRIVATE definitely terminates the declarations in a spec,
4085 -- and is an error in a body.
4091 Error_Msg_SC ("PRIVATE not allowed in body");
4092 Scan; -- past PRIVATE
4095 -- An end of file definitely terminates the declarations!
4100 -- The remaining tokens do not end the scan, but cannot start a
4101 -- valid declaration, so we signal an error and resynchronize.
4102 -- But first check for misuse of a reserved identifier.
4106 -- Here we check for a reserved identifier
4108 if Is_Reserved_Identifier then
4109 Save_Scan_State (Scan_State);
4110 Scan; -- past the token
4112 if Token /= Tok_Colon and then Token /= Tok_Comma then
4113 Restore_Scan_State (Scan_State);
4114 Set_Declaration_Expected;
4117 Restore_Scan_State (Scan_State);
4118 Scan_Reserved_Identifier (Force_Msg => True);
4120 P_Identifier_Declarations (Decls, Done, In_Spec);
4124 Set_Declaration_Expected;
4129 -- To resynchronize after an error, we scan to the next semicolon and
4130 -- return with Done = False, indicating that there may still be more
4131 -- valid declarations to come.
4134 when Error_Resync =>
4135 Resync_Past_Semicolon;
4137 end P_Declarative_Items;
4139 ----------------------------------
4140 -- 3.11 Basic Declarative Item --
4141 ----------------------------------
4143 -- BASIC_DECLARATIVE_ITEM ::=
4144 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
4146 -- Scan zero or more basic declarative items
4148 -- Error recovery: cannot raise Error_Resync. If an error is detected, then
4149 -- the scan pointer is repositioned past the next semicolon, and the scan
4150 -- for declarative items continues.
4152 function P_Basic_Declarative_Items return List_Id is
4159 -- Indicate no bad declarations detected yet in the current context:
4160 -- visible or private declarations of a package spec.
4162 Missing_Begin_Msg := No_Error_Msg;
4164 -- Get rid of active SIS entry from outer scope. This means we will
4165 -- miss some nested cases, but it doesn't seem worth the effort. See
4166 -- discussion in Par for further details
4168 SIS_Entry_Active := False;
4170 -- Loop to scan out declarations
4175 P_Declarative_Items (Decls, Done, In_Spec => True);
4179 -- Get rid of active SIS entry. This is set only if we have scanned a
4180 -- procedure declaration and have not found the body. We could give
4181 -- an error message, but that really would be usurping the role of
4182 -- semantic analysis (this really is a case of a missing body).
4184 SIS_Entry_Active := False;
4186 -- Test for assorted illegal declarations not diagnosed elsewhere.
4188 Decl := First (Decls);
4190 while Present (Decl) loop
4191 Kind := Nkind (Decl);
4193 -- Test for body scanned, not acceptable as basic decl item
4195 if Kind = N_Subprogram_Body or else
4196 Kind = N_Package_Body or else
4197 Kind = N_Task_Body or else
4198 Kind = N_Protected_Body
4201 ("proper body not allowed in package spec", Sloc (Decl));
4203 -- Test for body stub scanned, not acceptable as basic decl item
4205 elsif Kind in N_Body_Stub then
4207 ("body stub not allowed in package spec", Sloc (Decl));
4209 elsif Kind = N_Assignment_Statement then
4211 ("assignment statement not allowed in package spec",
4219 end P_Basic_Declarative_Items;
4225 -- For proper body, see below
4226 -- For body stub, see 10.1.3
4228 -----------------------
4229 -- 3.11 Proper Body --
4230 -----------------------
4232 -- Subprogram body is parsed by P_Subprogram (6.1)
4233 -- Package body is parsed by P_Package (7.1)
4234 -- Task body is parsed by P_Task (9.1)
4235 -- Protected body is parsed by P_Protected (9.4)
4237 ------------------------------
4238 -- Set_Declaration_Expected --
4239 ------------------------------
4241 procedure Set_Declaration_Expected is
4243 Error_Msg_SC ("declaration expected");
4245 if Missing_Begin_Msg = No_Error_Msg then
4246 Missing_Begin_Msg := Get_Msg_Id;
4248 end Set_Declaration_Expected;
4250 ----------------------
4251 -- Skip_Declaration --
4252 ----------------------
4254 procedure Skip_Declaration (S : List_Id) is
4255 Dummy_Done : Boolean;
4258 P_Declarative_Items (S, Dummy_Done, False);
4259 end Skip_Declaration;
4261 -----------------------------------------
4262 -- Statement_When_Declaration_Expected --
4263 -----------------------------------------
4265 procedure Statement_When_Declaration_Expected
4271 -- Case of second occurrence of statement in one declaration sequence
4273 if Missing_Begin_Msg /= No_Error_Msg then
4275 -- In the procedure spec case, just ignore it, we only give one
4276 -- message for the first occurrence, since otherwise we may get
4277 -- horrible cascading if BODY was missing in the header line.
4282 -- In the declarative part case, take a second statement as a sure
4283 -- sign that we really have a missing BEGIN, and end the declarative
4284 -- part now. Note that the caller will fix up the first message to
4285 -- say "missing BEGIN" so that's how the error will be signalled.
4292 -- Case of first occurrence of unexpected statement
4295 -- If we are in a package spec, then give message of statement
4296 -- not allowed in package spec. This message never gets changed.
4299 Error_Msg_SC ("statement not allowed in package spec");
4301 -- If in declarative part, then we give the message complaining
4302 -- about finding a statement when a declaration is expected. This
4303 -- gets changed to a complaint about a missing BEGIN if we later
4304 -- find that no BEGIN is present.
4307 Error_Msg_SC ("statement not allowed in declarative part");
4310 -- Capture message Id. This is used for two purposes, first to
4311 -- stop multiple messages, see test above, and second, to allow
4312 -- the replacement of the message in the declarative part case.
4314 Missing_Begin_Msg := Get_Msg_Id;
4317 -- In all cases except the case in which we decided to terminate the
4318 -- declaration sequence on a second error, we scan out the statement
4319 -- and append it to the list of declarations (note that the semantics
4320 -- can handle statements in a declaration list so if we proceed to
4321 -- call the semantic phase, all will be (reasonably) well!
4323 Append_List_To (Decls, P_Sequence_Of_Statements (SS_Unco));
4325 -- Done is set to False, since we want to continue the scan of
4326 -- declarations, hoping that this statement was a temporary glitch.
4327 -- If we indeed are now in the statement part (i.e. this was a missing
4328 -- BEGIN, then it's not terrible, we will simply keep calling this
4329 -- procedure to process the statements one by one, and then finally
4330 -- hit the missing BEGIN, which will clean up the error message.
4333 end Statement_When_Declaration_Expected;