1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 pragma Style_Checks (All_Checks);
28 -- Turn off subprogram body ordering check. Subprograms are in order
29 -- by RM section rather than alphabetical.
31 with Sinfo.CN; use Sinfo.CN;
37 -----------------------
38 -- Local Subprograms --
39 -----------------------
41 function P_Component_List return Node_Id;
42 function P_Defining_Character_Literal return Node_Id;
43 function P_Delta_Constraint return Node_Id;
44 function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id;
45 function P_Digits_Constraint return Node_Id;
46 function P_Discriminant_Association return Node_Id;
47 function P_Enumeration_Literal_Specification return Node_Id;
48 function P_Enumeration_Type_Definition return Node_Id;
49 function P_Fixed_Point_Definition return Node_Id;
50 function P_Floating_Point_Definition return Node_Id;
51 function P_Index_Or_Discriminant_Constraint return Node_Id;
52 function P_Real_Range_Specification_Opt return Node_Id;
53 function P_Subtype_Declaration return Node_Id;
54 function P_Type_Declaration return Node_Id;
55 function P_Modular_Type_Definition return Node_Id;
56 function P_Variant return Node_Id;
57 function P_Variant_Part return Node_Id;
59 procedure P_Declarative_Items
63 -- Scans out a single declarative item, or, in the case of a declaration
64 -- with a list of identifiers, a list of declarations, one for each of the
65 -- identifiers in the list. The declaration or declarations scanned are
66 -- appended to the given list. Done indicates whether or not there may be
67 -- additional declarative items to scan. If Done is True, then a decision
68 -- has been made that there are no more items to scan. If Done is False,
69 -- then there may be additional declarations to scan. In_Spec is true if
70 -- we are scanning a package declaration, and is used to generate an
71 -- appropriate message if a statement is encountered in such a context.
73 procedure P_Identifier_Declarations
77 -- Scans out a set of declarations for an identifier or list of
78 -- identifiers, and appends them to the given list. The parameters have
79 -- the same significance as for P_Declarative_Items.
81 procedure Statement_When_Declaration_Expected
85 -- Called when a statement is found at a point where a declaration was
86 -- expected. The parameters are as described for P_Declarative_Items.
88 procedure Set_Declaration_Expected;
89 -- Posts a "declaration expected" error messages at the start of the
90 -- current token, and if this is the first such message issued, saves
91 -- the message id in Missing_Begin_Msg, for possible later replacement.
97 function Init_Expr_Opt (P : Boolean := False) return Node_Id is
99 -- For colon, assume it means := unless it is at the end of
100 -- a line, in which case guess that it means a semicolon.
102 if Token = Tok_Colon then
103 if Token_Is_At_End_Of_Line then
108 -- Here if := or something that we will take as equivalent
110 elsif Token = Tok_Colon_Equal
111 or else Token = Tok_Equal
112 or else Token = Tok_Is
116 -- Another possibility. If we have a literal followed by a semicolon,
117 -- we assume that we have a missing colon-equal.
119 elsif Token in Token_Class_Literal then
121 Scan_State : Saved_Scan_State;
124 Save_Scan_State (Scan_State);
125 Scan; -- past literal or identifier
127 if Token = Tok_Semicolon then
128 Restore_Scan_State (Scan_State);
130 Restore_Scan_State (Scan_State);
135 -- Otherwise we definitely have no initialization expression
141 -- Merge here if we have an initialization expression
148 return P_Expression_No_Right_Paren;
152 ----------------------------
153 -- 3.1 Basic Declaration --
154 ----------------------------
156 -- Parsed by P_Basic_Declarative_Items (3.9)
158 ------------------------------
159 -- 3.1 Defining Identifier --
160 ------------------------------
162 -- DEFINING_IDENTIFIER ::= IDENTIFIER
164 -- Error recovery: can raise Error_Resync
166 function P_Defining_Identifier (C : Id_Check := None) return Node_Id is
167 Ident_Node : Node_Id;
170 -- Scan out the identifier. Note that this code is essentially identical
171 -- to P_Identifier, except that in the call to Scan_Reserved_Identifier
172 -- we set Force_Msg to True, since we want at least one message for each
173 -- separate declaration (but not use) of a reserved identifier.
175 if Token = Tok_Identifier then
177 -- Ada 2005 (AI-284): Compiling in Ada95 mode we warn that INTERFACE,
178 -- OVERRIDING, and SYNCHRONIZED are new reserved words.
180 if Ada_Version = Ada_95
181 and then Warn_On_Ada_2005_Compatibility
183 if Token_Name = Name_Overriding
184 or else Token_Name = Name_Synchronized
185 or else (Token_Name = Name_Interface
186 and then Prev_Token /= Tok_Pragma)
188 Error_Msg_N ("& is a reserved word in Ada 2005?", Token_Node);
192 -- If we have a reserved identifier, manufacture an identifier with
193 -- a corresponding name after posting an appropriate error message
195 elsif Is_Reserved_Identifier (C) then
196 Scan_Reserved_Identifier (Force_Msg => True);
198 -- Otherwise we have junk that cannot be interpreted as an identifier
201 T_Identifier; -- to give message
205 Ident_Node := Token_Node;
206 Scan; -- past the reserved identifier
208 if Ident_Node /= Error then
209 Change_Identifier_To_Defining_Identifier (Ident_Node);
213 end P_Defining_Identifier;
215 -----------------------------
216 -- 3.2.1 Type Declaration --
217 -----------------------------
219 -- TYPE_DECLARATION ::=
220 -- FULL_TYPE_DECLARATION
221 -- | INCOMPLETE_TYPE_DECLARATION
222 -- | PRIVATE_TYPE_DECLARATION
223 -- | PRIVATE_EXTENSION_DECLARATION
225 -- FULL_TYPE_DECLARATION ::=
226 -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION;
227 -- | CONCURRENT_TYPE_DECLARATION
229 -- INCOMPLETE_TYPE_DECLARATION ::=
230 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [is tagged];
232 -- PRIVATE_TYPE_DECLARATION ::=
233 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
234 -- is [abstract] [tagged] [limited] private;
236 -- PRIVATE_EXTENSION_DECLARATION ::=
237 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
238 -- [abstract] [limited | synchronized]
239 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
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 := False;
266 Abstract_Loc : Source_Ptr := No_Location;
268 Discr_List : List_Id;
269 Discr_Sloc : Source_Ptr;
271 Ident_Node : Node_Id;
272 Is_Derived_Iface : Boolean := False;
273 Type_Loc : Source_Ptr;
274 Type_Start_Col : Column_Number;
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
288 Type_Token_Location := Type_Loc;
290 Ident_Node := P_Defining_Identifier (C_Is);
292 -- Otherwise this is an error case, and we may already have converted
293 -- the current token to a defining identifier, so don't do it again!
298 if Token = Tok_Identifier
299 and then Nkind (Token_Node) = N_Defining_Identifier
301 Ident_Node := Token_Node;
302 Scan; -- past defining identifier
304 Ident_Node := P_Defining_Identifier (C_Is);
308 Discr_Sloc := Token_Ptr;
310 if P_Unknown_Discriminant_Part_Opt then
312 Discr_List := No_List;
314 Unknown_Dis := False;
315 Discr_List := P_Known_Discriminant_Part_Opt;
318 -- Incomplete type declaration. We complete the processing for this
319 -- case here and return the resulting incomplete type declaration node
321 if Token = Tok_Semicolon then
323 Decl_Node := New_Node (N_Incomplete_Type_Declaration, Type_Loc);
324 Set_Defining_Identifier (Decl_Node, Ident_Node);
325 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
326 Set_Discriminant_Specifications (Decl_Node, Discr_List);
333 -- Full type declaration or private type declaration, must have IS
335 if Token = Tok_Equal then
337 Scan; -- past = used in place of IS
339 elsif Token = Tok_Renames then
340 Error_Msg_SC ("RENAMES should be IS");
341 Scan; -- past RENAMES used in place of IS
347 -- First an error check, if we have two identifiers in a row, a likely
348 -- possibility is that the first of the identifiers is an incorrectly
351 if Token = Tok_Identifier then
353 SS : Saved_Scan_State;
357 Save_Scan_State (SS);
358 Scan; -- past initial identifier
359 I2 := (Token = Tok_Identifier);
360 Restore_Scan_State (SS);
364 (Bad_Spelling_Of (Tok_Abstract) or else
365 Bad_Spelling_Of (Tok_Access) or else
366 Bad_Spelling_Of (Tok_Aliased) or else
367 Bad_Spelling_Of (Tok_Constant))
374 -- Check for misuse of Ada 95 keyword abstract in Ada 83 mode
376 if Token_Name = Name_Abstract then
377 Check_95_Keyword (Tok_Abstract, Tok_Tagged);
378 Check_95_Keyword (Tok_Abstract, Tok_New);
381 -- Check cases of misuse of ABSTRACT
383 if Token = Tok_Abstract then
384 Abstract_Present := True;
385 Abstract_Loc := Token_Ptr;
386 Scan; -- past ABSTRACT
388 -- Ada 2005 (AI-419): AARM 3.4 (2/2)
390 if (Ada_Version < Ada_05 and then Token = Tok_Limited)
391 or else Token = Tok_Private
392 or else Token = Tok_Record
393 or else Token = Tok_Null
395 Error_Msg_AP ("TAGGED expected");
399 -- Check for misuse of Ada 95 keyword Tagged
401 if Token_Name = Name_Tagged then
402 Check_95_Keyword (Tok_Tagged, Tok_Private);
403 Check_95_Keyword (Tok_Tagged, Tok_Limited);
404 Check_95_Keyword (Tok_Tagged, Tok_Record);
407 -- Special check for misuse of Aliased
409 if Token = Tok_Aliased or else Token_Name = Name_Aliased then
410 Error_Msg_SC ("ALIASED not allowed in type definition");
411 Scan; -- past ALIASED
414 -- The following procesing deals with either a private type declaration
415 -- or a full type declaration. In the private type case, we build the
416 -- N_Private_Type_Declaration node, setting its Tagged_Present and
417 -- Limited_Present flags, on encountering the Private keyword, and
418 -- leave Typedef_Node set to Empty. For the full type declaration
419 -- case, Typedef_Node gets set to the type definition.
421 Typedef_Node := Empty;
423 -- Switch on token following the IS. The loop normally runs once. It
424 -- only runs more than once if an error is detected, to try again after
425 -- detecting and fixing up the error.
431 Tok_Not => -- Ada 2005 (AI-231)
432 Typedef_Node := P_Access_Type_Definition;
437 Typedef_Node := P_Array_Type_Definition;
442 Typedef_Node := P_Fixed_Point_Definition;
447 Typedef_Node := P_Floating_Point_Definition;
454 when Tok_Integer_Literal =>
456 Typedef_Node := P_Signed_Integer_Type_Definition;
461 Typedef_Node := P_Record_Definition;
465 when Tok_Left_Paren =>
466 Typedef_Node := P_Enumeration_Type_Definition;
469 Make_Identifier (Token_Ptr,
470 Chars => Chars (Ident_Node));
471 Set_Comes_From_Source (End_Labl, False);
473 Set_End_Label (Typedef_Node, End_Labl);
478 Typedef_Node := P_Modular_Type_Definition;
483 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
485 if Nkind (Typedef_Node) = N_Derived_Type_Definition
486 and then Present (Record_Extension_Part (Typedef_Node))
489 Make_Identifier (Token_Ptr,
490 Chars => Chars (Ident_Node));
491 Set_Comes_From_Source (End_Labl, False);
494 (Record_Extension_Part (Typedef_Node), End_Labl);
501 Typedef_Node := P_Signed_Integer_Type_Definition;
506 Typedef_Node := P_Record_Definition;
509 Make_Identifier (Token_Ptr,
510 Chars => Chars (Ident_Node));
511 Set_Comes_From_Source (End_Labl, False);
513 Set_End_Label (Typedef_Node, End_Labl);
520 -- Ada 2005 (AI-326): If the words IS TAGGED appear, the type
521 -- is a tagged incomplete type.
523 if Ada_Version >= Ada_05
524 and then Token = Tok_Semicolon
529 New_Node (N_Incomplete_Type_Declaration, Type_Loc);
530 Set_Defining_Identifier (Decl_Node, Ident_Node);
531 Set_Tagged_Present (Decl_Node);
532 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
533 Set_Discriminant_Specifications (Decl_Node, Discr_List);
538 if Token = Tok_Abstract then
539 Error_Msg_SC ("ABSTRACT must come before TAGGED");
540 Abstract_Present := True;
541 Abstract_Loc := Token_Ptr;
542 Scan; -- past ABSTRACT
545 if Token = Tok_Limited then
546 Scan; -- past LIMITED
548 -- TAGGED LIMITED PRIVATE case
550 if Token = Tok_Private then
552 New_Node (N_Private_Type_Declaration, Type_Loc);
553 Set_Tagged_Present (Decl_Node, True);
554 Set_Limited_Present (Decl_Node, True);
555 Scan; -- past PRIVATE
557 -- TAGGED LIMITED RECORD
560 Typedef_Node := P_Record_Definition;
561 Set_Tagged_Present (Typedef_Node, True);
562 Set_Limited_Present (Typedef_Node, True);
565 Make_Identifier (Token_Ptr,
566 Chars => Chars (Ident_Node));
567 Set_Comes_From_Source (End_Labl, False);
569 Set_End_Label (Typedef_Node, End_Labl);
575 if Token = Tok_Private then
577 New_Node (N_Private_Type_Declaration, Type_Loc);
578 Set_Tagged_Present (Decl_Node, True);
579 Scan; -- past PRIVATE
584 Typedef_Node := P_Record_Definition;
585 Set_Tagged_Present (Typedef_Node, True);
588 Make_Identifier (Token_Ptr,
589 Chars => Chars (Ident_Node));
590 Set_Comes_From_Source (End_Labl, False);
592 Set_End_Label (Typedef_Node, End_Labl);
600 Scan; -- past LIMITED
603 if Token = Tok_Tagged then
604 Error_Msg_SC ("TAGGED must come before LIMITED");
607 elsif Token = Tok_Abstract then
608 Error_Msg_SC ("ABSTRACT must come before LIMITED");
609 Scan; -- past ABSTRACT
616 -- LIMITED RECORD or LIMITED NULL RECORD
618 if Token = Tok_Record or else Token = Tok_Null then
619 if Ada_Version = Ada_83 then
621 ("(Ada 83) limited record declaration not allowed!");
624 Typedef_Node := P_Record_Definition;
625 Set_Limited_Present (Typedef_Node, True);
627 -- Ada 2005 (AI-251): LIMITED INTERFACE
629 -- If we are compiling in Ada 83 or Ada 95 mode, "interface"
630 -- is not a reserved word but we force its analysis to
631 -- generate the corresponding usage error.
633 elsif Token = Tok_Interface
634 or else (Token = Tok_Identifier
635 and then Chars (Token_Node) = Name_Interface)
638 P_Interface_Type_Definition (Abstract_Present);
639 Abstract_Present := True;
640 Set_Limited_Present (Typedef_Node);
642 if Nkind (Typedef_Node) = N_Derived_Type_Definition then
643 Is_Derived_Iface := True;
646 -- Ada 2005 (AI-419): LIMITED NEW
648 elsif Token = Tok_New then
649 if Ada_Version < Ada_05 then
651 ("LIMITED in derived type is an Ada 2005 extension");
653 ("\unit must be compiled with -gnat05 switch");
656 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
657 Set_Limited_Present (Typedef_Node);
659 if Nkind (Typedef_Node) = N_Derived_Type_Definition
660 and then Present (Record_Extension_Part (Typedef_Node))
663 Make_Identifier (Token_Ptr,
664 Chars => Chars (Ident_Node));
665 Set_Comes_From_Source (End_Labl, False);
668 (Record_Extension_Part (Typedef_Node), End_Labl);
671 -- LIMITED PRIVATE is the only remaining possibility here
674 Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
675 Set_Limited_Present (Decl_Node, True);
676 T_Private; -- past PRIVATE (or complain if not there!)
682 -- Here we have an identifier after the IS, which is certainly
683 -- wrong and which might be one of several different mistakes.
685 when Tok_Identifier =>
687 -- First case, if identifier is on same line, then probably we
688 -- have something like "type X is Integer .." and the best
689 -- diagnosis is a missing NEW. Note: the missing new message
690 -- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl.
692 if not Token_Is_At_Start_Of_Line then
693 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
696 -- If the identifier is at the start of the line, and is in the
697 -- same column as the type declaration itself then we consider
698 -- that we had a missing type definition on the previous line
700 elsif Start_Column <= Type_Start_Col then
701 Error_Msg_AP ("type definition expected");
702 Typedef_Node := Error;
704 -- If the identifier is at the start of the line, and is in
705 -- a column to the right of the type declaration line, then we
706 -- may have something like:
711 -- and the best diagnosis is a missing record keyword
714 Typedef_Node := P_Record_Definition;
720 -- Ada 2005 (AI-251): INTERFACE
722 when Tok_Interface =>
723 Typedef_Node := P_Interface_Type_Definition (Abstract_Present);
724 Abstract_Present := True;
729 Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc);
730 Scan; -- past PRIVATE
734 -- Ada 2005 (AI-345): Protected, synchronized or task interface
735 -- or Ada 2005 (AI-443): Synchronized private extension.
742 Saved_Token : constant Token_Type := Token;
745 Scan; -- past TASK, PROTECTED or SYNCHRONIZED
747 -- Synchronized private extension
749 if Token = Tok_New then
750 Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
752 if Saved_Token = Tok_Synchronized then
753 Set_Synchronized_Present (Typedef_Node);
755 Error_Msg_SC ("invalid kind of private extension");
762 P_Interface_Type_Definition (Abstract_Present);
763 Abstract_Present := True;
767 Set_Task_Present (Typedef_Node);
769 when Tok_Protected =>
770 Set_Protected_Present (Typedef_Node);
772 when Tok_Synchronized =>
773 Set_Synchronized_Present (Typedef_Node);
776 pragma Assert (False);
785 -- Anything else is an error
788 if Bad_Spelling_Of (Tok_Access)
790 Bad_Spelling_Of (Tok_Array)
792 Bad_Spelling_Of (Tok_Delta)
794 Bad_Spelling_Of (Tok_Digits)
796 Bad_Spelling_Of (Tok_Limited)
798 Bad_Spelling_Of (Tok_Private)
800 Bad_Spelling_Of (Tok_Range)
802 Bad_Spelling_Of (Tok_Record)
804 Bad_Spelling_Of (Tok_Tagged)
809 Error_Msg_AP ("type definition expected");
816 -- For the private type declaration case, the private type declaration
817 -- node has been built, with the Tagged_Present and Limited_Present
818 -- flags set as needed, and Typedef_Node is left set to Empty.
820 if No (Typedef_Node) then
821 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
822 Set_Abstract_Present (Decl_Node, Abstract_Present);
824 -- For a private extension declaration, Typedef_Node contains the
825 -- N_Private_Extension_Declaration node, which we now complete. Note
826 -- that the private extension declaration, unlike a full type
827 -- declaration, does permit unknown discriminants.
829 elsif Nkind (Typedef_Node) = N_Private_Extension_Declaration then
830 Decl_Node := Typedef_Node;
831 Set_Sloc (Decl_Node, Type_Loc);
832 Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis);
833 Set_Abstract_Present (Typedef_Node, Abstract_Present);
835 -- In the full type declaration case, Typedef_Node has the type
836 -- definition and here is where we build the full type declaration
837 -- node. This is also where we check for improper use of an unknown
838 -- discriminant part (not allowed for full type declaration).
841 if Nkind (Typedef_Node) = N_Record_Definition
842 or else (Nkind (Typedef_Node) = N_Derived_Type_Definition
843 and then Present (Record_Extension_Part (Typedef_Node)))
844 or else Is_Derived_Iface
846 Set_Abstract_Present (Typedef_Node, Abstract_Present);
848 elsif Abstract_Present then
849 Error_Msg ("ABSTRACT not allowed here, ignored", Abstract_Loc);
852 Decl_Node := New_Node (N_Full_Type_Declaration, Type_Loc);
853 Set_Type_Definition (Decl_Node, Typedef_Node);
857 ("Full type declaration cannot have unknown discriminants",
862 -- Remaining processing is common for all three cases
864 Set_Defining_Identifier (Decl_Node, Ident_Node);
865 Set_Discriminant_Specifications (Decl_Node, Discr_List);
867 end P_Type_Declaration;
869 ----------------------------------
870 -- 3.2.1 Full Type Declaration --
871 ----------------------------------
873 -- Parsed by P_Type_Declaration (3.2.1)
875 ----------------------------
876 -- 3.2.1 Type Definition --
877 ----------------------------
879 -- Parsed by P_Type_Declaration (3.2.1)
881 --------------------------------
882 -- 3.2.2 Subtype Declaration --
883 --------------------------------
885 -- SUBTYPE_DECLARATION ::=
886 -- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION;
888 -- The caller has checked that the initial token is SUBTYPE
890 -- Error recovery: can raise Error_Resync
892 function P_Subtype_Declaration return Node_Id is
894 Not_Null_Present : Boolean := False;
897 Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr);
898 Scan; -- past SUBTYPE
899 Set_Defining_Identifier (Decl_Node, P_Defining_Identifier (C_Is));
902 if Token = Tok_New then
903 Error_Msg_SC ("NEW ignored (only allowed in type declaration)");
907 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
908 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
910 Set_Subtype_Indication
911 (Decl_Node, P_Subtype_Indication (Not_Null_Present));
914 end P_Subtype_Declaration;
916 -------------------------------
917 -- 3.2.2 Subtype Indication --
918 -------------------------------
920 -- SUBTYPE_INDICATION ::=
921 -- [not null] SUBTYPE_MARK [CONSTRAINT]
923 -- Error recovery: can raise Error_Resync
925 function P_Null_Exclusion
926 (Allow_Anonymous_In_95 : Boolean := False) return Boolean
928 Not_Loc : constant Source_Ptr := Token_Ptr;
929 -- Source position of "not", if present
932 if Token /= Tok_Not then
938 if Token = Tok_Null then
941 -- Ada 2005 (AI-441, AI-447): null_exclusion is illegal in Ada 95,
942 -- except in the case of anonymous access types.
944 -- Allow_Anonymous_In_95 will be True if we're parsing a formal
945 -- parameter or discriminant, which are the only places where
946 -- anonymous access types occur in Ada 95. "Formal : not null
947 -- access ..." is legal in Ada 95, whereas "Formal : not null
948 -- Named_Access_Type" is not.
950 if Ada_Version >= Ada_05
951 or else (Ada_Version >= Ada_95
952 and then Allow_Anonymous_In_95
953 and then Token = Tok_Access)
959 ("`NOT NULL` access type is an Ada 2005 extension", Not_Loc);
961 ("\unit should be compiled with -gnat05 switch", Not_Loc);
965 Error_Msg_SP ("NULL expected");
968 if Token = Tok_New then
969 Error_Msg ("`NOT NULL` comes after NEW, not before", Not_Loc);
974 end P_Null_Exclusion;
976 function P_Subtype_Indication
977 (Not_Null_Present : Boolean := False) return Node_Id
982 if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
983 Type_Node := P_Subtype_Mark;
984 return P_Subtype_Indication (Type_Node, Not_Null_Present);
987 -- Check for error of using record definition and treat it nicely,
988 -- otherwise things are really messed up, so resynchronize.
990 if Token = Tok_Record then
991 Error_Msg_SC ("anonymous record definitions are not permitted");
992 Discard_Junk_Node (P_Record_Definition);
996 Error_Msg_AP ("subtype indication expected");
1000 end P_Subtype_Indication;
1002 -- The following function is identical except that it is called with
1003 -- the subtype mark already scanned out, and it scans out the constraint
1005 -- Error recovery: can raise Error_Resync
1007 function P_Subtype_Indication
1008 (Subtype_Mark : Node_Id;
1009 Not_Null_Present : Boolean := False) return Node_Id
1011 Indic_Node : Node_Id;
1012 Constr_Node : Node_Id;
1015 Constr_Node := P_Constraint_Opt;
1017 if No (Constr_Node) then
1018 return Subtype_Mark;
1020 if Not_Null_Present then
1021 Error_Msg_SP ("`NOT NULL` not allowed if constraint given");
1024 Indic_Node := New_Node (N_Subtype_Indication, Sloc (Subtype_Mark));
1025 Set_Subtype_Mark (Indic_Node, Check_Subtype_Mark (Subtype_Mark));
1026 Set_Constraint (Indic_Node, Constr_Node);
1029 end P_Subtype_Indication;
1031 -------------------------
1032 -- 3.2.2 Subtype Mark --
1033 -------------------------
1035 -- SUBTYPE_MARK ::= subtype_NAME;
1037 -- Note: The subtype mark which appears after an IN or NOT IN
1038 -- operator is parsed by P_Range_Or_Subtype_Mark (3.5)
1040 -- Error recovery: cannot raise Error_Resync
1042 function P_Subtype_Mark return Node_Id is
1044 return P_Subtype_Mark_Resync;
1046 when Error_Resync =>
1050 -- This routine differs from P_Subtype_Mark in that it insists that an
1051 -- identifier be present, and if it is not, it raises Error_Resync.
1053 -- Error recovery: can raise Error_Resync
1055 function P_Subtype_Mark_Resync return Node_Id is
1056 Type_Node : Node_Id;
1059 if Token = Tok_Access then
1060 Error_Msg_SC ("anonymous access type definition not allowed here");
1061 Scan; -- past ACCESS
1064 if Token = Tok_Array then
1065 Error_Msg_SC ("anonymous array definition not allowed here");
1066 Discard_Junk_Node (P_Array_Type_Definition);
1070 Type_Node := P_Qualified_Simple_Name_Resync;
1072 -- Check for a subtype mark attribute. The only valid possibilities
1073 -- are 'CLASS and 'BASE. Anything else is a definite error. We may
1074 -- as well catch it here.
1076 if Token = Tok_Apostrophe then
1077 return P_Subtype_Mark_Attribute (Type_Node);
1082 end P_Subtype_Mark_Resync;
1084 -- The following function is called to scan out a subtype mark attribute.
1085 -- The caller has already scanned out the subtype mark, which is passed in
1086 -- as the argument, and has checked that the current token is apostrophe.
1088 -- Only a special subclass of attributes, called type attributes
1089 -- (see Snames package) are allowed in this syntactic position.
1091 -- Note: if the apostrophe is followed by other than an identifier, then
1092 -- the input expression is returned unchanged, and the scan pointer is
1093 -- left pointing to the apostrophe.
1095 -- Error recovery: can raise Error_Resync
1097 function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id is
1098 Attr_Node : Node_Id := Empty;
1099 Scan_State : Saved_Scan_State;
1103 Prefix := Check_Subtype_Mark (Type_Node);
1105 if Prefix = Error then
1109 -- Loop through attributes appearing (more than one can appear as for
1110 -- for example in X'Base'Class). We are at an apostrophe on entry to
1111 -- this loop, and it runs once for each attribute parsed, with
1112 -- Prefix being the current possible prefix if it is an attribute.
1115 Save_Scan_State (Scan_State); -- at Apostrophe
1116 Scan; -- past apostrophe
1118 if Token /= Tok_Identifier then
1119 Restore_Scan_State (Scan_State); -- to apostrophe
1120 return Prefix; -- no attribute after all
1122 elsif not Is_Type_Attribute_Name (Token_Name) then
1124 ("attribute & may not be used in a subtype mark", Token_Node);
1129 Make_Attribute_Reference (Prev_Token_Ptr,
1131 Attribute_Name => Token_Name);
1132 Delete_Node (Token_Node);
1133 Scan; -- past type attribute identifier
1136 exit when Token /= Tok_Apostrophe;
1137 Prefix := Attr_Node;
1140 -- Fall through here after scanning type attribute
1143 end P_Subtype_Mark_Attribute;
1145 -----------------------
1146 -- 3.2.2 Constraint --
1147 -----------------------
1149 -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
1151 -- SCALAR_CONSTRAINT ::=
1152 -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
1154 -- COMPOSITE_CONSTRAINT ::=
1155 -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
1157 -- If no constraint is present, this function returns Empty
1159 -- Error recovery: can raise Error_Resync
1161 function P_Constraint_Opt return Node_Id is
1163 if Token = Tok_Range
1164 or else Bad_Spelling_Of (Tok_Range)
1166 return P_Range_Constraint;
1168 elsif Token = Tok_Digits
1169 or else Bad_Spelling_Of (Tok_Digits)
1171 return P_Digits_Constraint;
1173 elsif Token = Tok_Delta
1174 or else Bad_Spelling_Of (Tok_Delta)
1176 return P_Delta_Constraint;
1178 elsif Token = Tok_Left_Paren then
1179 return P_Index_Or_Discriminant_Constraint;
1181 elsif Token = Tok_In then
1183 return P_Constraint_Opt;
1188 end P_Constraint_Opt;
1190 ------------------------------
1191 -- 3.2.2 Scalar Constraint --
1192 ------------------------------
1194 -- Parsed by P_Constraint_Opt (3.2.2)
1196 ---------------------------------
1197 -- 3.2.2 Composite Constraint --
1198 ---------------------------------
1200 -- Parsed by P_Constraint_Opt (3.2.2)
1202 --------------------------------------------------------
1203 -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) --
1204 --------------------------------------------------------
1206 -- This routine scans out a declaration starting with an identifier:
1208 -- OBJECT_DECLARATION ::=
1209 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1210 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1211 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1212 -- ACCESS_DEFINITION [:= EXPRESSION];
1213 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1214 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1216 -- NUMBER_DECLARATION ::=
1217 -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
1219 -- OBJECT_RENAMING_DECLARATION ::=
1220 -- DEFINING_IDENTIFIER :
1221 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
1222 -- | DEFINING_IDENTIFIER :
1223 -- ACCESS_DEFINITION renames object_NAME;
1225 -- EXCEPTION_RENAMING_DECLARATION ::=
1226 -- DEFINING_IDENTIFIER : exception renames exception_NAME;
1228 -- EXCEPTION_DECLARATION ::=
1229 -- DEFINING_IDENTIFIER_LIST : exception;
1231 -- Note that the ALIASED indication in an object declaration is
1232 -- marked by a flag in the parent node.
1234 -- The caller has checked that the initial token is an identifier
1236 -- The value returned is a list of declarations, one for each identifier
1237 -- in the list (as described in Sinfo, we always split up multiple
1238 -- declarations into the equivalent sequence of single declarations
1239 -- using the More_Ids and Prev_Ids flags to preserve the source).
1241 -- If the identifier turns out to be a probable statement rather than
1242 -- an identifier, then the scan is left pointing to the identifier and
1243 -- No_List is returned.
1245 -- Error recovery: can raise Error_Resync
1247 procedure P_Identifier_Declarations
1253 Decl_Node : Node_Id;
1254 Type_Node : Node_Id;
1255 Ident_Sloc : Source_Ptr;
1256 Scan_State : Saved_Scan_State;
1257 List_OK : Boolean := True;
1259 Init_Expr : Node_Id;
1260 Init_Loc : Source_Ptr;
1261 Con_Loc : Source_Ptr;
1262 Not_Null_Present : Boolean := False;
1264 Idents : array (Int range 1 .. 4096) of Entity_Id;
1265 -- Used to save identifiers in the identifier list. The upper bound
1266 -- of 4096 is expected to be infinite in practice, and we do not even
1267 -- bother to check if this upper bound is exceeded.
1269 Num_Idents : Nat := 1;
1270 -- Number of identifiers stored in Idents
1273 -- This procedure is called in renames cases to make sure that we do
1274 -- not have more than one identifier. If we do have more than one
1275 -- then an error message is issued (and the declaration is split into
1276 -- multiple declarations)
1278 function Token_Is_Renames return Boolean;
1279 -- Checks if current token is RENAMES, and if so, scans past it and
1280 -- returns True, otherwise returns False. Includes checking for some
1281 -- common error cases.
1283 procedure No_List is
1285 if Num_Idents > 1 then
1286 Error_Msg ("identifier list not allowed for RENAMES",
1293 function Token_Is_Renames return Boolean is
1294 At_Colon : Saved_Scan_State;
1297 if Token = Tok_Colon then
1298 Save_Scan_State (At_Colon);
1300 Check_Misspelling_Of (Tok_Renames);
1302 if Token = Tok_Renames then
1303 Error_Msg_SP ("extra "":"" ignored");
1304 Scan; -- past RENAMES
1307 Restore_Scan_State (At_Colon);
1312 Check_Misspelling_Of (Tok_Renames);
1314 if Token = Tok_Renames then
1315 Scan; -- past RENAMES
1321 end Token_Is_Renames;
1323 -- Start of processing for P_Identifier_Declarations
1326 Ident_Sloc := Token_Ptr;
1327 Save_Scan_State (Scan_State); -- at first identifier
1328 Idents (1) := P_Defining_Identifier (C_Comma_Colon);
1330 -- If we have a colon after the identifier, then we can assume that
1331 -- this is in fact a valid identifier declaration and can steam ahead.
1333 if Token = Tok_Colon then
1336 -- If we have a comma, then scan out the list of identifiers
1338 elsif Token = Tok_Comma then
1340 while Comma_Present loop
1341 Num_Idents := Num_Idents + 1;
1342 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
1345 Save_Scan_State (Scan_State); -- at colon
1348 -- If we have identifier followed by := then we assume that what is
1349 -- really meant is an assignment statement. The assignment statement
1350 -- is scanned out and added to the list of declarations. An exception
1351 -- occurs if the := is followed by the keyword constant, in which case
1352 -- we assume it was meant to be a colon.
1354 elsif Token = Tok_Colon_Equal then
1357 if Token = Tok_Constant then
1358 Error_Msg_SP ("colon expected");
1361 Restore_Scan_State (Scan_State);
1362 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
1366 -- If we have an IS keyword, then assume the TYPE keyword was missing
1368 elsif Token = Tok_Is then
1369 Restore_Scan_State (Scan_State);
1370 Append_To (Decls, P_Type_Declaration);
1374 -- Otherwise we have an error situation
1377 Restore_Scan_State (Scan_State);
1379 -- First case is possible misuse of PROTECTED in Ada 83 mode. If
1380 -- so, fix the keyword and return to scan the protected declaration.
1382 if Token_Name = Name_Protected then
1383 Check_95_Keyword (Tok_Protected, Tok_Identifier);
1384 Check_95_Keyword (Tok_Protected, Tok_Type);
1385 Check_95_Keyword (Tok_Protected, Tok_Body);
1387 if Token = Tok_Protected then
1392 -- Check misspelling possibilities. If so, correct the misspelling
1393 -- and return to scan out the resulting declaration.
1395 elsif Bad_Spelling_Of (Tok_Function)
1396 or else Bad_Spelling_Of (Tok_Procedure)
1397 or else Bad_Spelling_Of (Tok_Package)
1398 or else Bad_Spelling_Of (Tok_Pragma)
1399 or else Bad_Spelling_Of (Tok_Protected)
1400 or else Bad_Spelling_Of (Tok_Generic)
1401 or else Bad_Spelling_Of (Tok_Subtype)
1402 or else Bad_Spelling_Of (Tok_Type)
1403 or else Bad_Spelling_Of (Tok_Task)
1404 or else Bad_Spelling_Of (Tok_Use)
1405 or else Bad_Spelling_Of (Tok_For)
1410 -- Otherwise we definitely have an ordinary identifier with a junk
1411 -- token after it. Just complain that we expect a declaration, and
1412 -- skip to a semicolon
1415 Set_Declaration_Expected;
1416 Resync_Past_Semicolon;
1422 -- Come here with an identifier list and colon scanned out. We now
1423 -- build the nodes for the declarative items. One node is built for
1424 -- each identifier in the list, with the type information being
1425 -- repeated by rescanning the appropriate section of source.
1427 -- First an error check, if we have two identifiers in a row, a likely
1428 -- possibility is that the first of the identifiers is an incorrectly
1431 if Token = Tok_Identifier then
1433 SS : Saved_Scan_State;
1437 Save_Scan_State (SS);
1438 Scan; -- past initial identifier
1439 I2 := (Token = Tok_Identifier);
1440 Restore_Scan_State (SS);
1444 (Bad_Spelling_Of (Tok_Access) or else
1445 Bad_Spelling_Of (Tok_Aliased) or else
1446 Bad_Spelling_Of (Tok_Constant))
1453 -- Loop through identifiers
1458 -- Check for some cases of misused Ada 95 keywords
1460 if Token_Name = Name_Aliased then
1461 Check_95_Keyword (Tok_Aliased, Tok_Array);
1462 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
1463 Check_95_Keyword (Tok_Aliased, Tok_Constant);
1468 if Token = Tok_Constant then
1469 Con_Loc := Token_Ptr;
1470 Scan; -- past CONSTANT
1472 -- Number declaration, initialization required
1474 Init_Expr := Init_Expr_Opt;
1476 if Present (Init_Expr) then
1477 if Not_Null_Present then
1479 ("`NOT NULL` not allowed in numeric expression");
1482 Decl_Node := New_Node (N_Number_Declaration, Ident_Sloc);
1483 Set_Expression (Decl_Node, Init_Expr);
1485 -- Constant object declaration
1488 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1489 Set_Constant_Present (Decl_Node, True);
1491 if Token_Name = Name_Aliased then
1492 Check_95_Keyword (Tok_Aliased, Tok_Array);
1493 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
1496 if Token = Tok_Aliased then
1497 Error_Msg_SC ("ALIASED should be before CONSTANT");
1498 Scan; -- past ALIASED
1499 Set_Aliased_Present (Decl_Node, True);
1502 if Token = Tok_Array then
1503 Set_Object_Definition
1504 (Decl_Node, P_Array_Type_Definition);
1507 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1508 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1510 if Token = Tok_Access then
1511 if Ada_Version < Ada_05 then
1513 ("generalized use of anonymous access types " &
1514 "is an Ada 2005 extension");
1516 ("\unit must be compiled with -gnat05 switch");
1519 Set_Object_Definition
1520 (Decl_Node, P_Access_Definition (Not_Null_Present));
1522 Set_Object_Definition
1523 (Decl_Node, P_Subtype_Indication (Not_Null_Present));
1527 if Token = Tok_Renames then
1529 ("CONSTANT not permitted in renaming declaration",
1531 Scan; -- Past renames
1532 Discard_Junk_Node (P_Name);
1538 elsif Token = Tok_Exception then
1539 Scan; -- past EXCEPTION
1541 if Token_Is_Renames then
1544 New_Node (N_Exception_Renaming_Declaration, Ident_Sloc);
1545 Set_Name (Decl_Node, P_Qualified_Simple_Name_Resync);
1548 Decl_Node := New_Node (N_Exception_Declaration, Prev_Token_Ptr);
1551 -- Aliased case (note that an object definition is required)
1553 elsif Token = Tok_Aliased then
1554 Scan; -- past ALIASED
1555 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1556 Set_Aliased_Present (Decl_Node, True);
1558 if Token = Tok_Constant then
1559 Scan; -- past CONSTANT
1560 Set_Constant_Present (Decl_Node, True);
1563 if Token = Tok_Array then
1564 Set_Object_Definition
1565 (Decl_Node, P_Array_Type_Definition);
1568 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1569 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1571 -- Access definition (AI-406) or subtype indication
1573 if Token = Tok_Access then
1574 if Ada_Version < Ada_05 then
1576 ("generalized use of anonymous access types " &
1577 "is an Ada 2005 extension");
1579 ("\unit must be compiled with -gnat05 switch");
1582 Set_Object_Definition
1583 (Decl_Node, P_Access_Definition (Not_Null_Present));
1585 Set_Object_Definition
1586 (Decl_Node, P_Subtype_Indication (Not_Null_Present));
1592 elsif Token = Tok_Array then
1593 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1594 Set_Object_Definition (Decl_Node, P_Array_Type_Definition);
1596 -- Ada 2005 (AI-254, AI-406)
1598 elsif Token = Tok_Not then
1600 -- OBJECT_DECLARATION ::=
1601 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1602 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1603 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1604 -- ACCESS_DEFINITION [:= EXPRESSION];
1606 -- OBJECT_RENAMING_DECLARATION ::=
1607 -- DEFINING_IDENTIFIER :
1608 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
1609 -- | DEFINING_IDENTIFIER :
1610 -- ACCESS_DEFINITION renames object_NAME;
1612 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/423)
1614 if Token = Tok_Access then
1615 if Ada_Version < Ada_05 then
1617 ("generalized use of anonymous access types " &
1618 "is an Ada 2005 extension");
1619 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1622 Acc_Node := P_Access_Definition (Not_Null_Present);
1624 if Token /= Tok_Renames then
1625 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1626 Set_Object_Definition (Decl_Node, Acc_Node);
1629 Scan; -- past renames
1632 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1633 Set_Access_Definition (Decl_Node, Acc_Node);
1634 Set_Name (Decl_Node, P_Name);
1638 Type_Node := P_Subtype_Mark;
1640 -- Object renaming declaration
1642 if Token_Is_Renames then
1643 if Ada_Version < Ada_05 then
1645 ("`NOT NULL` not allowed in object renaming");
1648 -- Ada 2005 (AI-423): Object renaming declaration with
1649 -- a null exclusion.
1654 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1655 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1656 Set_Subtype_Mark (Decl_Node, Type_Node);
1657 Set_Name (Decl_Node, P_Name);
1660 -- Object declaration
1663 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1664 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1665 Set_Object_Definition
1667 P_Subtype_Indication (Type_Node, Not_Null_Present));
1669 -- RENAMES at this point means that we had the combination
1670 -- of a constraint on the Type_Node and renames, which is
1673 if Token_Is_Renames then
1674 Error_Msg_N ("constraint not allowed in object renaming "
1676 Constraint (Object_Definition (Decl_Node)));
1682 -- Ada 2005 (AI-230): Access Definition case
1684 elsif Token = Tok_Access then
1685 if Ada_Version < Ada_05 then
1687 ("generalized use of anonymous access types " &
1688 "is an Ada 2005 extension");
1689 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1692 Acc_Node := P_Access_Definition (Null_Exclusion_Present => False);
1694 -- Object declaration with access definition, or renaming
1696 if Token /= Tok_Renames then
1697 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1698 Set_Object_Definition (Decl_Node, Acc_Node);
1701 Scan; -- past renames
1704 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1705 Set_Access_Definition (Decl_Node, Acc_Node);
1706 Set_Name (Decl_Node, P_Name);
1709 -- Subtype indication case
1712 Type_Node := P_Subtype_Mark;
1714 -- Object renaming declaration
1716 if Token_Is_Renames then
1719 New_Node (N_Object_Renaming_Declaration, Ident_Sloc);
1720 Set_Subtype_Mark (Decl_Node, Type_Node);
1721 Set_Name (Decl_Node, P_Name);
1723 -- Object declaration
1726 Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc);
1727 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present);
1728 Set_Object_Definition
1730 P_Subtype_Indication (Type_Node, Not_Null_Present));
1732 -- RENAMES at this point means that we had the combination of
1733 -- a constraint on the Type_Node and renames, which is illegal
1735 if Token_Is_Renames then
1737 ("constraint not allowed in object renaming declaration",
1738 Constraint (Object_Definition (Decl_Node)));
1744 -- Scan out initialization, allowed only for object declaration
1746 Init_Loc := Token_Ptr;
1747 Init_Expr := Init_Expr_Opt;
1749 if Present (Init_Expr) then
1750 if Nkind (Decl_Node) = N_Object_Declaration then
1751 Set_Expression (Decl_Node, Init_Expr);
1752 Set_Has_Init_Expression (Decl_Node);
1754 Error_Msg ("initialization not allowed here", Init_Loc);
1759 Set_Defining_Identifier (Decl_Node, Idents (Ident));
1762 if Ident < Num_Idents then
1763 Set_More_Ids (Decl_Node, True);
1767 Set_Prev_Ids (Decl_Node, True);
1771 Append (Decl_Node, Decls);
1772 exit Ident_Loop when Ident = Num_Idents;
1773 Restore_Scan_State (Scan_State);
1776 end loop Ident_Loop;
1779 end P_Identifier_Declarations;
1781 -------------------------------
1782 -- 3.3.1 Object Declaration --
1783 -------------------------------
1785 -- OBJECT DECLARATION ::=
1786 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1787 -- SUBTYPE_INDICATION [:= EXPRESSION];
1788 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1789 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1790 -- | SINGLE_TASK_DECLARATION
1791 -- | SINGLE_PROTECTED_DECLARATION
1793 -- Cases starting with TASK are parsed by P_Task (9.1)
1794 -- Cases starting with PROTECTED are parsed by P_Protected (9.4)
1795 -- All other cases are parsed by P_Identifier_Declarations (3.3)
1797 -------------------------------------
1798 -- 3.3.1 Defining Identifier List --
1799 -------------------------------------
1801 -- DEFINING_IDENTIFIER_LIST ::=
1802 -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
1804 -- Always parsed by the construct in which it appears. See special
1805 -- section on "Handling of Defining Identifier Lists" in this unit.
1807 -------------------------------
1808 -- 3.3.2 Number Declaration --
1809 -------------------------------
1811 -- Parsed by P_Identifier_Declarations (3.3)
1813 -------------------------------------------------------------------------
1814 -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) --
1815 -------------------------------------------------------------------------
1817 -- DERIVED_TYPE_DEFINITION ::=
1818 -- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
1819 -- [[and INTERFACE_LIST] RECORD_EXTENSION_PART]
1821 -- PRIVATE_EXTENSION_DECLARATION ::=
1822 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
1823 -- [abstract] [limited | synchronized]
1824 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
1827 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
1829 -- The caller has already scanned out the part up to the NEW, and Token
1830 -- either contains Tok_New (or ought to, if it doesn't this procedure
1831 -- will post an appropriate "NEW expected" message).
1833 -- Note: the caller is responsible for filling in the Sloc field of
1834 -- the returned node in the private extension declaration case as
1835 -- well as the stuff relating to the discriminant part.
1837 -- Error recovery: can raise Error_Resync;
1839 function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id is
1840 Typedef_Node : Node_Id;
1841 Typedecl_Node : Node_Id;
1842 Not_Null_Present : Boolean := False;
1845 Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
1847 if Ada_Version < Ada_05
1848 and then Token = Tok_Identifier
1849 and then Token_Name = Name_Interface
1852 ("abstract interface is an Ada 2005 extension");
1853 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1858 if Token = Tok_Abstract then
1859 Error_Msg_SC ("ABSTRACT must come before NEW, not after");
1863 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
1864 Set_Null_Exclusion_Present (Typedef_Node, Not_Null_Present);
1865 Set_Subtype_Indication (Typedef_Node,
1866 P_Subtype_Indication (Not_Null_Present));
1868 -- Ada 2005 (AI-251): Deal with interfaces
1870 if Token = Tok_And then
1873 if Ada_Version < Ada_05 then
1875 ("abstract interface is an Ada 2005 extension");
1876 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
1879 Set_Interface_List (Typedef_Node, New_List);
1882 Append (P_Qualified_Simple_Name, Interface_List (Typedef_Node));
1883 exit when Token /= Tok_And;
1887 if Token /= Tok_With then
1888 Error_Msg_SC ("WITH expected");
1893 -- Deal with record extension, note that we assume that a WITH is
1894 -- missing in the case of "type X is new Y record ..." or in the
1895 -- case of "type X is new Y null record".
1898 or else Token = Tok_Record
1899 or else Token = Tok_Null
1901 T_With; -- past WITH or give error message
1903 if Token = Tok_Limited then
1905 ("LIMITED keyword not allowed in private extension");
1906 Scan; -- ignore LIMITED
1909 -- Private extension declaration
1911 if Token = Tok_Private then
1912 Scan; -- past PRIVATE
1914 -- Throw away the type definition node and build the type
1915 -- declaration node. Note the caller must set the Sloc,
1916 -- Discriminant_Specifications, Unknown_Discriminants_Present,
1917 -- and Defined_Identifier fields in the returned node.
1920 Make_Private_Extension_Declaration (No_Location,
1921 Defining_Identifier => Empty,
1922 Subtype_Indication => Subtype_Indication (Typedef_Node),
1923 Abstract_Present => Abstract_Present (Typedef_Node),
1924 Interface_List => Interface_List (Typedef_Node));
1926 Delete_Node (Typedef_Node);
1927 return Typedecl_Node;
1929 -- Derived type definition with record extension part
1932 Set_Record_Extension_Part (Typedef_Node, P_Record_Definition);
1933 return Typedef_Node;
1936 -- Derived type definition with no record extension part
1939 return Typedef_Node;
1941 end P_Derived_Type_Def_Or_Private_Ext_Decl;
1943 ---------------------------
1944 -- 3.5 Range Constraint --
1945 ---------------------------
1947 -- RANGE_CONSTRAINT ::= range RANGE
1949 -- The caller has checked that the initial token is RANGE
1951 -- Error recovery: cannot raise Error_Resync
1953 function P_Range_Constraint return Node_Id is
1954 Range_Node : Node_Id;
1957 Range_Node := New_Node (N_Range_Constraint, Token_Ptr);
1959 Set_Range_Expression (Range_Node, P_Range);
1961 end P_Range_Constraint;
1968 -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
1970 -- Note: the range that appears in a membership test is parsed by
1971 -- P_Range_Or_Subtype_Mark (3.5).
1973 -- Error recovery: cannot raise Error_Resync
1975 function P_Range return Node_Id is
1976 Expr_Node : Node_Id;
1977 Range_Node : Node_Id;
1980 Expr_Node := P_Simple_Expression_Or_Range_Attribute;
1982 if Expr_Form = EF_Range_Attr then
1985 elsif Token = Tok_Dot_Dot then
1986 Range_Node := New_Node (N_Range, Token_Ptr);
1987 Set_Low_Bound (Range_Node, Expr_Node);
1989 Expr_Node := P_Expression;
1990 Check_Simple_Expression (Expr_Node);
1991 Set_High_Bound (Range_Node, Expr_Node);
1994 -- Anything else is an error
1997 T_Dot_Dot; -- force missing .. message
2002 ----------------------------------
2003 -- 3.5 P_Range_Or_Subtype_Mark --
2004 ----------------------------------
2007 -- RANGE_ATTRIBUTE_REFERENCE
2008 -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
2010 -- This routine scans out the range or subtype mark that forms the right
2011 -- operand of a membership test (it is not used in any other contexts, and
2012 -- error messages are specialized with this knowledge in mind).
2014 -- Note: as documented in the Sinfo interface, although the syntax only
2015 -- allows a subtype mark, we in fact allow any simple expression to be
2016 -- returned from this routine. The semantics is responsible for issuing
2017 -- an appropriate message complaining if the argument is not a name.
2018 -- This simplifies the coding and error recovery processing in the
2019 -- parser, and in any case it is preferable not to consider this a
2020 -- syntax error and to continue with the semantic analysis.
2022 -- Error recovery: cannot raise Error_Resync
2024 function P_Range_Or_Subtype_Mark return Node_Id is
2025 Expr_Node : Node_Id;
2026 Range_Node : Node_Id;
2027 Save_Loc : Source_Ptr;
2029 -- Start of processing for P_Range_Or_Subtype_Mark
2032 -- Save location of possible junk parentheses
2034 Save_Loc := Token_Ptr;
2036 -- Scan out either a simple expression or a range (this accepts more
2037 -- than is legal here, but as explained above, we like to allow more
2038 -- with a proper diagnostic.
2040 Expr_Node := P_Simple_Expression_Or_Range_Attribute;
2044 if Expr_Form = EF_Range_Attr then
2047 -- Simple_Expression .. Simple_Expression
2049 elsif Token = Tok_Dot_Dot then
2050 Check_Simple_Expression (Expr_Node);
2051 Range_Node := New_Node (N_Range, Token_Ptr);
2052 Set_Low_Bound (Range_Node, Expr_Node);
2054 Set_High_Bound (Range_Node, P_Simple_Expression);
2057 -- Case of subtype mark (optionally qualified simple name or an
2058 -- attribute whose prefix is an optionally qualifed simple name)
2060 elsif Expr_Form = EF_Simple_Name
2061 or else Nkind (Expr_Node) = N_Attribute_Reference
2063 -- Check for error of range constraint after a subtype mark
2065 if Token = Tok_Range then
2066 Error_Msg_SC ("range constraint not allowed in membership test");
2070 -- Check for error of DIGITS or DELTA after a subtype mark
2072 elsif Token = Tok_Digits or else Token = Tok_Delta then
2074 ("accuracy definition not allowed in membership test");
2075 Scan; -- past DIGITS or DELTA
2078 -- Attribute reference, may or may not be OK, but in any case we
2081 elsif Token = Tok_Apostrophe then
2082 return P_Subtype_Mark_Attribute (Expr_Node);
2084 -- OK case of simple name, just return it
2090 -- Here we have some kind of error situation. Check for junk parens
2091 -- then return what we have, caller will deal with other errors.
2094 if Nkind (Expr_Node) in N_Subexpr
2095 and then Paren_Count (Expr_Node) /= 0
2097 Error_Msg ("|parentheses not allowed for subtype mark", Save_Loc);
2098 Set_Paren_Count (Expr_Node, 0);
2103 end P_Range_Or_Subtype_Mark;
2105 ----------------------------------------
2106 -- 3.5.1 Enumeration Type Definition --
2107 ----------------------------------------
2109 -- ENUMERATION_TYPE_DEFINITION ::=
2110 -- (ENUMERATION_LITERAL_SPECIFICATION
2111 -- {, ENUMERATION_LITERAL_SPECIFICATION})
2113 -- The caller has already scanned out the TYPE keyword
2115 -- Error recovery: can raise Error_Resync;
2117 function P_Enumeration_Type_Definition return Node_Id is
2118 Typedef_Node : Node_Id;
2121 Typedef_Node := New_Node (N_Enumeration_Type_Definition, Token_Ptr);
2122 Set_Literals (Typedef_Node, New_List);
2127 Append (P_Enumeration_Literal_Specification, Literals (Typedef_Node));
2128 exit when not Comma_Present;
2132 return Typedef_Node;
2133 end P_Enumeration_Type_Definition;
2135 ----------------------------------------------
2136 -- 3.5.1 Enumeration Literal Specification --
2137 ----------------------------------------------
2139 -- ENUMERATION_LITERAL_SPECIFICATION ::=
2140 -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
2142 -- Error recovery: can raise Error_Resync
2144 function P_Enumeration_Literal_Specification return Node_Id is
2146 if Token = Tok_Char_Literal then
2147 return P_Defining_Character_Literal;
2149 return P_Defining_Identifier (C_Comma_Right_Paren);
2151 end P_Enumeration_Literal_Specification;
2153 ---------------------------------------
2154 -- 3.5.1 Defining_Character_Literal --
2155 ---------------------------------------
2157 -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
2159 -- Error recovery: cannot raise Error_Resync
2161 -- The caller has checked that the current token is a character literal
2163 function P_Defining_Character_Literal return Node_Id is
2164 Literal_Node : Node_Id;
2167 Literal_Node := Token_Node;
2168 Change_Character_Literal_To_Defining_Character_Literal (Literal_Node);
2169 Scan; -- past character literal
2170 return Literal_Node;
2171 end P_Defining_Character_Literal;
2173 ------------------------------------
2174 -- 3.5.4 Integer Type Definition --
2175 ------------------------------------
2177 -- Parsed by P_Type_Declaration (3.2.1)
2179 -------------------------------------------
2180 -- 3.5.4 Signed Integer Type Definition --
2181 -------------------------------------------
2183 -- SIGNED_INTEGER_TYPE_DEFINITION ::=
2184 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2186 -- Normally the initial token on entry is RANGE, but in some
2187 -- error conditions, the range token was missing and control is
2188 -- passed with Token pointing to first token of the first expression.
2190 -- Error recovery: cannot raise Error_Resync
2192 function P_Signed_Integer_Type_Definition return Node_Id is
2193 Typedef_Node : Node_Id;
2194 Expr_Node : Node_Id;
2197 Typedef_Node := New_Node (N_Signed_Integer_Type_Definition, Token_Ptr);
2199 if Token = Tok_Range then
2203 Expr_Node := P_Expression;
2204 Check_Simple_Expression (Expr_Node);
2205 Set_Low_Bound (Typedef_Node, Expr_Node);
2207 Expr_Node := P_Expression;
2208 Check_Simple_Expression (Expr_Node);
2209 Set_High_Bound (Typedef_Node, Expr_Node);
2210 return Typedef_Node;
2211 end P_Signed_Integer_Type_Definition;
2213 ------------------------------------
2214 -- 3.5.4 Modular Type Definition --
2215 ------------------------------------
2217 -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
2219 -- The caller has checked that the initial token is MOD
2221 -- Error recovery: cannot raise Error_Resync
2223 function P_Modular_Type_Definition return Node_Id is
2224 Typedef_Node : Node_Id;
2227 if Ada_Version = Ada_83 then
2228 Error_Msg_SC ("(Ada 83): modular types not allowed");
2231 Typedef_Node := New_Node (N_Modular_Type_Definition, Token_Ptr);
2233 Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
2235 -- Handle mod L..R cleanly
2237 if Token = Tok_Dot_Dot then
2238 Error_Msg_SC ("range not allowed for modular type");
2240 Set_Expression (Typedef_Node, P_Expression_No_Right_Paren);
2243 return Typedef_Node;
2244 end P_Modular_Type_Definition;
2246 ---------------------------------
2247 -- 3.5.6 Real Type Definition --
2248 ---------------------------------
2250 -- Parsed by P_Type_Declaration (3.2.1)
2252 --------------------------------------
2253 -- 3.5.7 Floating Point Definition --
2254 --------------------------------------
2256 -- FLOATING_POINT_DEFINITION ::=
2257 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2259 -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
2261 -- The caller has checked that the initial token is DIGITS
2263 -- Error recovery: cannot raise Error_Resync
2265 function P_Floating_Point_Definition return Node_Id is
2266 Digits_Loc : constant Source_Ptr := Token_Ptr;
2268 Expr_Node : Node_Id;
2271 Scan; -- past DIGITS
2272 Expr_Node := P_Expression_No_Right_Paren;
2273 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2275 -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
2277 if Token = Tok_Delta then
2278 Error_Msg_SC ("DELTA must come before DIGITS");
2279 Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Digits_Loc);
2281 Set_Delta_Expression (Def_Node, P_Expression_No_Right_Paren);
2283 -- OK floating-point definition
2286 Def_Node := New_Node (N_Floating_Point_Definition, Digits_Loc);
2289 Set_Digits_Expression (Def_Node, Expr_Node);
2290 Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt);
2292 end P_Floating_Point_Definition;
2294 -------------------------------------
2295 -- 3.5.7 Real Range Specification --
2296 -------------------------------------
2298 -- REAL_RANGE_SPECIFICATION ::=
2299 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2301 -- Error recovery: cannot raise Error_Resync
2303 function P_Real_Range_Specification_Opt return Node_Id is
2304 Specification_Node : Node_Id;
2305 Expr_Node : Node_Id;
2308 if Token = Tok_Range then
2309 Specification_Node :=
2310 New_Node (N_Real_Range_Specification, Token_Ptr);
2312 Expr_Node := P_Expression_No_Right_Paren;
2313 Check_Simple_Expression (Expr_Node);
2314 Set_Low_Bound (Specification_Node, Expr_Node);
2316 Expr_Node := P_Expression_No_Right_Paren;
2317 Check_Simple_Expression (Expr_Node);
2318 Set_High_Bound (Specification_Node, Expr_Node);
2319 return Specification_Node;
2323 end P_Real_Range_Specification_Opt;
2325 -----------------------------------
2326 -- 3.5.9 Fixed Point Definition --
2327 -----------------------------------
2329 -- FIXED_POINT_DEFINITION ::=
2330 -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
2332 -- ORDINARY_FIXED_POINT_DEFINITION ::=
2333 -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION
2335 -- DECIMAL_FIXED_POINT_DEFINITION ::=
2336 -- delta static_EXPRESSION
2337 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2339 -- The caller has checked that the initial token is DELTA
2341 -- Error recovery: cannot raise Error_Resync
2343 function P_Fixed_Point_Definition return Node_Id is
2344 Delta_Node : Node_Id;
2345 Delta_Loc : Source_Ptr;
2347 Expr_Node : Node_Id;
2350 Delta_Loc := Token_Ptr;
2352 Delta_Node := P_Expression_No_Right_Paren;
2353 Check_Simple_Expression_In_Ada_83 (Delta_Node);
2355 if Token = Tok_Digits then
2356 if Ada_Version = Ada_83 then
2357 Error_Msg_SC ("(Ada 83) decimal fixed type not allowed!");
2360 Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Delta_Loc);
2361 Scan; -- past DIGITS
2362 Expr_Node := P_Expression_No_Right_Paren;
2363 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2364 Set_Digits_Expression (Def_Node, Expr_Node);
2367 Def_Node := New_Node (N_Ordinary_Fixed_Point_Definition, Delta_Loc);
2369 -- Range is required in ordinary fixed point case
2371 if Token /= Tok_Range then
2372 Error_Msg_AP ("range must be given for fixed-point type");
2377 Set_Delta_Expression (Def_Node, Delta_Node);
2378 Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt);
2380 end P_Fixed_Point_Definition;
2382 --------------------------------------------
2383 -- 3.5.9 Ordinary Fixed Point Definition --
2384 --------------------------------------------
2386 -- Parsed by P_Fixed_Point_Definition (3.5.9)
2388 -------------------------------------------
2389 -- 3.5.9 Decimal Fixed Point Definition --
2390 -------------------------------------------
2392 -- Parsed by P_Decimal_Point_Definition (3.5.9)
2394 ------------------------------
2395 -- 3.5.9 Digits Constraint --
2396 ------------------------------
2398 -- DIGITS_CONSTRAINT ::=
2399 -- digits static_EXPRESSION [RANGE_CONSTRAINT]
2401 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2403 -- The caller has checked that the initial token is DIGITS
2405 function P_Digits_Constraint return Node_Id is
2406 Constraint_Node : Node_Id;
2407 Expr_Node : Node_Id;
2410 Constraint_Node := New_Node (N_Digits_Constraint, Token_Ptr);
2411 Scan; -- past DIGITS
2412 Expr_Node := P_Expression;
2413 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2414 Set_Digits_Expression (Constraint_Node, Expr_Node);
2416 if Token = Tok_Range then
2417 Set_Range_Constraint (Constraint_Node, P_Range_Constraint);
2420 return Constraint_Node;
2421 end P_Digits_Constraint;
2423 -----------------------------
2424 -- 3.5.9 Delta Constraint --
2425 -----------------------------
2427 -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
2429 -- Note: this is an obsolescent feature in Ada 95 (I.3)
2431 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2433 -- The caller has checked that the initial token is DELTA
2435 -- Error recovery: cannot raise Error_Resync
2437 function P_Delta_Constraint return Node_Id is
2438 Constraint_Node : Node_Id;
2439 Expr_Node : Node_Id;
2442 Constraint_Node := New_Node (N_Delta_Constraint, Token_Ptr);
2444 Expr_Node := P_Expression;
2445 Check_Simple_Expression_In_Ada_83 (Expr_Node);
2446 Set_Delta_Expression (Constraint_Node, Expr_Node);
2448 if Token = Tok_Range then
2449 Set_Range_Constraint (Constraint_Node, P_Range_Constraint);
2452 return Constraint_Node;
2453 end P_Delta_Constraint;
2455 --------------------------------
2456 -- 3.6 Array Type Definition --
2457 --------------------------------
2459 -- ARRAY_TYPE_DEFINITION ::=
2460 -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
2462 -- UNCONSTRAINED_ARRAY_DEFINITION ::=
2463 -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
2464 -- COMPONENT_DEFINITION
2466 -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
2468 -- CONSTRAINED_ARRAY_DEFINITION ::=
2469 -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
2470 -- COMPONENT_DEFINITION
2472 -- DISCRETE_SUBTYPE_DEFINITION ::=
2473 -- DISCRETE_SUBTYPE_INDICATION | RANGE
2475 -- COMPONENT_DEFINITION ::=
2476 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
2478 -- The caller has checked that the initial token is ARRAY
2480 -- Error recovery: can raise Error_Resync
2482 function P_Array_Type_Definition return Node_Id is
2483 Array_Loc : Source_Ptr;
2484 CompDef_Node : Node_Id;
2486 Not_Null_Present : Boolean := False;
2487 Subs_List : List_Id;
2488 Scan_State : Saved_Scan_State;
2489 Aliased_Present : Boolean := False;
2492 Array_Loc := Token_Ptr;
2494 Subs_List := New_List;
2497 -- It's quite tricky to disentangle these two possibilities, so we do
2498 -- a prescan to determine which case we have and then reset the scan.
2499 -- The prescan skips past possible subtype mark tokens.
2501 Save_Scan_State (Scan_State); -- just after paren
2503 while Token in Token_Class_Desig or else
2504 Token = Tok_Dot or else
2505 Token = Tok_Apostrophe -- because of 'BASE, 'CLASS
2510 -- If we end up on RANGE <> then we have the unconstrained case. We
2511 -- will also allow the RANGE to be omitted, just to improve error
2512 -- handling for a case like array (integer <>) of integer;
2514 Scan; -- past possible RANGE or <>
2516 if (Prev_Token = Tok_Range and then Token = Tok_Box) or else
2517 Prev_Token = Tok_Box
2519 Def_Node := New_Node (N_Unconstrained_Array_Definition, Array_Loc);
2520 Restore_Scan_State (Scan_State); -- to first subtype mark
2523 Append (P_Subtype_Mark_Resync, Subs_List);
2526 exit when Token = Tok_Right_Paren or else Token = Tok_Of;
2530 Set_Subtype_Marks (Def_Node, Subs_List);
2533 Def_Node := New_Node (N_Constrained_Array_Definition, Array_Loc);
2534 Restore_Scan_State (Scan_State); -- to first discrete range
2537 Append (P_Discrete_Subtype_Definition, Subs_List);
2538 exit when not Comma_Present;
2541 Set_Discrete_Subtype_Definitions (Def_Node, Subs_List);
2547 CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
2549 if Token_Name = Name_Aliased then
2550 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
2553 if Token = Tok_Aliased then
2554 Aliased_Present := True;
2555 Scan; -- past ALIASED
2558 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254)
2560 -- Ada 2005 (AI-230): Access Definition case
2562 if Token = Tok_Access then
2563 if Ada_Version < Ada_05 then
2565 ("generalized use of anonymous access types " &
2566 "is an Ada 2005 extension");
2567 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
2570 if Aliased_Present then
2571 Error_Msg_SP ("ALIASED not allowed here");
2574 Set_Subtype_Indication (CompDef_Node, Empty);
2575 Set_Aliased_Present (CompDef_Node, False);
2576 Set_Access_Definition (CompDef_Node,
2577 P_Access_Definition (Not_Null_Present));
2580 Set_Access_Definition (CompDef_Node, Empty);
2581 Set_Aliased_Present (CompDef_Node, Aliased_Present);
2582 Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
2583 Set_Subtype_Indication (CompDef_Node,
2584 P_Subtype_Indication (Not_Null_Present));
2587 Set_Component_Definition (Def_Node, CompDef_Node);
2590 end P_Array_Type_Definition;
2592 -----------------------------------------
2593 -- 3.6 Unconstrained Array Definition --
2594 -----------------------------------------
2596 -- Parsed by P_Array_Type_Definition (3.6)
2598 ---------------------------------------
2599 -- 3.6 Constrained Array Definition --
2600 ---------------------------------------
2602 -- Parsed by P_Array_Type_Definition (3.6)
2604 --------------------------------------
2605 -- 3.6 Discrete Subtype Definition --
2606 --------------------------------------
2608 -- DISCRETE_SUBTYPE_DEFINITION ::=
2609 -- discrete_SUBTYPE_INDICATION | RANGE
2611 -- Note: the discrete subtype definition appearing in a constrained
2612 -- array definition is parsed by P_Array_Type_Definition (3.6)
2614 -- Error recovery: cannot raise Error_Resync
2616 function P_Discrete_Subtype_Definition return Node_Id is
2618 -- The syntax of a discrete subtype definition is identical to that
2619 -- of a discrete range, so we simply share the same parsing code.
2621 return P_Discrete_Range;
2622 end P_Discrete_Subtype_Definition;
2624 -------------------------------
2625 -- 3.6 Component Definition --
2626 -------------------------------
2628 -- For the array case, parsed by P_Array_Type_Definition (3.6)
2629 -- For the record case, parsed by P_Component_Declaration (3.8)
2631 -----------------------------
2632 -- 3.6.1 Index Constraint --
2633 -----------------------------
2635 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2637 ---------------------------
2638 -- 3.6.1 Discrete Range --
2639 ---------------------------
2641 -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
2643 -- The possible forms for a discrete range are:
2645 -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2)
2646 -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2)
2647 -- Range_Attribute (RANGE, 3.5)
2648 -- Simple_Expression .. Simple_Expression (RANGE, 3.5)
2650 -- Error recovery: cannot raise Error_Resync
2652 function P_Discrete_Range return Node_Id is
2653 Expr_Node : Node_Id;
2654 Range_Node : Node_Id;
2657 Expr_Node := P_Simple_Expression_Or_Range_Attribute;
2659 if Expr_Form = EF_Range_Attr then
2662 elsif Token = Tok_Range then
2663 if Expr_Form /= EF_Simple_Name then
2664 Error_Msg_SC ("range must be preceded by subtype mark");
2667 return P_Subtype_Indication (Expr_Node);
2669 -- Check Expression .. Expression case
2671 elsif Token = Tok_Dot_Dot then
2672 Range_Node := New_Node (N_Range, Token_Ptr);
2673 Set_Low_Bound (Range_Node, Expr_Node);
2675 Expr_Node := P_Expression;
2676 Check_Simple_Expression (Expr_Node);
2677 Set_High_Bound (Range_Node, Expr_Node);
2680 -- Otherwise we must have a subtype mark
2682 elsif Expr_Form = EF_Simple_Name then
2685 -- If incorrect, complain that we expect ..
2691 end P_Discrete_Range;
2693 ----------------------------
2694 -- 3.7 Discriminant Part --
2695 ----------------------------
2697 -- DISCRIMINANT_PART ::=
2698 -- UNKNOWN_DISCRIMINANT_PART
2699 -- | KNOWN_DISCRIMINANT_PART
2701 -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
2702 -- or P_Unknown_Discriminant_Part (3.7), since we know which we want.
2704 ------------------------------------
2705 -- 3.7 Unknown Discriminant Part --
2706 ------------------------------------
2708 -- UNKNOWN_DISCRIMINANT_PART ::= (<>)
2710 -- If no unknown discriminant part is present, then False is returned,
2711 -- otherwise the unknown discriminant is scanned out and True is returned.
2713 -- Error recovery: cannot raise Error_Resync
2715 function P_Unknown_Discriminant_Part_Opt return Boolean is
2716 Scan_State : Saved_Scan_State;
2719 if Token /= Tok_Left_Paren then
2723 Save_Scan_State (Scan_State);
2724 Scan; -- past the left paren
2726 if Token = Tok_Box then
2727 if Ada_Version = Ada_83 then
2728 Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!");
2731 Scan; -- past the box
2732 T_Right_Paren; -- must be followed by right paren
2736 Restore_Scan_State (Scan_State);
2740 end P_Unknown_Discriminant_Part_Opt;
2742 ----------------------------------
2743 -- 3.7 Known Discriminant Part --
2744 ----------------------------------
2746 -- KNOWN_DISCRIMINANT_PART ::=
2747 -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
2749 -- DISCRIMINANT_SPECIFICATION ::=
2750 -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
2751 -- [:= DEFAULT_EXPRESSION]
2752 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
2753 -- [:= DEFAULT_EXPRESSION]
2755 -- If no known discriminant part is present, then No_List is returned
2757 -- Error recovery: cannot raise Error_Resync
2759 function P_Known_Discriminant_Part_Opt return List_Id is
2760 Specification_Node : Node_Id;
2761 Specification_List : List_Id;
2762 Ident_Sloc : Source_Ptr;
2763 Scan_State : Saved_Scan_State;
2765 Not_Null_Present : Boolean;
2768 Idents : array (Int range 1 .. 4096) of Entity_Id;
2769 -- This array holds the list of defining identifiers. The upper bound
2770 -- of 4096 is intended to be essentially infinite, and we do not even
2771 -- bother to check for it being exceeded.
2774 if Token = Tok_Left_Paren then
2775 Specification_List := New_List;
2777 P_Pragmas_Misplaced;
2779 Specification_Loop : loop
2781 Ident_Sloc := Token_Ptr;
2782 Idents (1) := P_Defining_Identifier (C_Comma_Colon);
2785 while Comma_Present loop
2786 Num_Idents := Num_Idents + 1;
2787 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
2790 -- If there are multiple identifiers, we repeatedly scan the
2791 -- type and initialization expression information by resetting
2792 -- the scan pointer (so that we get completely separate trees
2793 -- for each occurrence).
2795 if Num_Idents > 1 then
2796 Save_Scan_State (Scan_State);
2801 -- Loop through defining identifiers in list
2805 Specification_Node :=
2806 New_Node (N_Discriminant_Specification, Ident_Sloc);
2807 Set_Defining_Identifier (Specification_Node, Idents (Ident));
2808 Not_Null_Present := -- Ada 2005 (AI-231, AI-447)
2809 P_Null_Exclusion (Allow_Anonymous_In_95 => True);
2811 if Token = Tok_Access then
2812 if Ada_Version = Ada_83 then
2814 ("(Ada 83) access discriminant not allowed!");
2817 Set_Discriminant_Type
2818 (Specification_Node,
2819 P_Access_Definition (Not_Null_Present));
2822 Set_Discriminant_Type
2823 (Specification_Node, P_Subtype_Mark);
2825 Set_Null_Exclusion_Present -- Ada 2005 (AI-231)
2826 (Specification_Node, Not_Null_Present);
2830 (Specification_Node, Init_Expr_Opt (True));
2833 Set_Prev_Ids (Specification_Node, True);
2836 if Ident < Num_Idents then
2837 Set_More_Ids (Specification_Node, True);
2840 Append (Specification_Node, Specification_List);
2841 exit Ident_Loop when Ident = Num_Idents;
2843 Restore_Scan_State (Scan_State);
2845 end loop Ident_Loop;
2847 exit Specification_Loop when Token /= Tok_Semicolon;
2849 P_Pragmas_Misplaced;
2850 end loop Specification_Loop;
2853 return Specification_List;
2858 end P_Known_Discriminant_Part_Opt;
2860 -------------------------------------
2861 -- 3.7 DIscriminant Specification --
2862 -------------------------------------
2864 -- Parsed by P_Known_Discriminant_Part_Opt (3.7)
2866 -----------------------------
2867 -- 3.7 Default Expression --
2868 -----------------------------
2870 -- Always parsed (simply as an Expression) by the parent construct
2872 ------------------------------------
2873 -- 3.7.1 Discriminant Constraint --
2874 ------------------------------------
2876 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2878 --------------------------------------------------------
2879 -- 3.7.1 Index or Discriminant Constraint (also 3.6) --
2880 --------------------------------------------------------
2882 -- DISCRIMINANT_CONSTRAINT ::=
2883 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
2885 -- DISCRIMINANT_ASSOCIATION ::=
2886 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2889 -- This routine parses either an index or a discriminant constraint. As
2890 -- is clear from the above grammar, it is often possible to clearly
2891 -- determine which of the two possibilities we have, but there are
2892 -- cases (those in which we have a series of expressions of the same
2893 -- syntactic form as subtype indications), where we cannot tell. Since
2894 -- this means that in any case the semantic phase has to distinguish
2895 -- between the two, there is not much point in the parser trying to
2896 -- distinguish even those cases where the difference is clear. In any
2897 -- case, if we have a situation like:
2899 -- (A => 123, 235 .. 500)
2901 -- it is not clear which of the two items is the wrong one, better to
2902 -- let the semantic phase give a clear message. Consequently, this
2903 -- routine in general returns a list of items which can be either
2904 -- discrete ranges or discriminant associations.
2906 -- The caller has checked that the initial token is a left paren
2908 -- Error recovery: can raise Error_Resync
2910 function P_Index_Or_Discriminant_Constraint return Node_Id is
2911 Scan_State : Saved_Scan_State;
2912 Constr_Node : Node_Id;
2913 Constr_List : List_Id;
2914 Expr_Node : Node_Id;
2915 Result_Node : Node_Id;
2918 Result_Node := New_Node (N_Index_Or_Discriminant_Constraint, Token_Ptr);
2920 Constr_List := New_List;
2921 Set_Constraints (Result_Node, Constr_List);
2923 -- The two syntactic forms are a little mixed up, so what we are doing
2924 -- here is looking at the first entry to determine which case we have
2926 -- A discriminant constraint is a list of discriminant associations,
2927 -- which have one of the following possible forms:
2931 -- Id | Id | .. | Id => Expression
2933 -- An index constraint is a list of discrete ranges which have one
2934 -- of the following possible forms:
2937 -- Subtype_Mark range Range
2939 -- Simple_Expression .. Simple_Expression
2941 -- Loop through discriminants in list
2944 -- Check cases of Id => Expression or Id | Id => Expression
2946 if Token = Tok_Identifier then
2947 Save_Scan_State (Scan_State); -- at Id
2950 if Token = Tok_Arrow or else Token = Tok_Vertical_Bar then
2951 Restore_Scan_State (Scan_State); -- to Id
2952 Append (P_Discriminant_Association, Constr_List);
2955 Restore_Scan_State (Scan_State); -- to Id
2959 -- Otherwise scan out an expression and see what we have got
2961 Expr_Node := P_Expression_Or_Range_Attribute;
2963 if Expr_Form = EF_Range_Attr then
2964 Append (Expr_Node, Constr_List);
2966 elsif Token = Tok_Range then
2967 if Expr_Form /= EF_Simple_Name then
2968 Error_Msg_SC ("subtype mark required before RANGE");
2971 Append (P_Subtype_Indication (Expr_Node), Constr_List);
2974 -- Check Simple_Expression .. Simple_Expression case
2976 elsif Token = Tok_Dot_Dot then
2977 Check_Simple_Expression (Expr_Node);
2978 Constr_Node := New_Node (N_Range, Token_Ptr);
2979 Set_Low_Bound (Constr_Node, Expr_Node);
2981 Expr_Node := P_Expression;
2982 Check_Simple_Expression (Expr_Node);
2983 Set_High_Bound (Constr_Node, Expr_Node);
2984 Append (Constr_Node, Constr_List);
2987 -- Case of an expression which could be either form
2990 Append (Expr_Node, Constr_List);
2994 -- Here with a single entry scanned
2997 exit when not Comma_Present;
3003 end P_Index_Or_Discriminant_Constraint;
3005 -------------------------------------
3006 -- 3.7.1 Discriminant Association --
3007 -------------------------------------
3009 -- DISCRIMINANT_ASSOCIATION ::=
3010 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
3013 -- This routine is used only when the name list is present and the caller
3014 -- has already checked this (by scanning ahead and repositioning the
3017 -- Error_Recovery: cannot raise Error_Resync;
3019 function P_Discriminant_Association return Node_Id is
3020 Discr_Node : Node_Id;
3021 Names_List : List_Id;
3022 Ident_Sloc : Source_Ptr;
3025 Ident_Sloc := Token_Ptr;
3026 Names_List := New_List;
3029 Append (P_Identifier (C_Vertical_Bar_Arrow), Names_List);
3030 exit when Token /= Tok_Vertical_Bar;
3034 Discr_Node := New_Node (N_Discriminant_Association, Ident_Sloc);
3035 Set_Selector_Names (Discr_Node, Names_List);
3037 Set_Expression (Discr_Node, P_Expression);
3039 end P_Discriminant_Association;
3041 ---------------------------------
3042 -- 3.8 Record Type Definition --
3043 ---------------------------------
3045 -- RECORD_TYPE_DEFINITION ::=
3046 -- [[abstract] tagged] [limited] RECORD_DEFINITION
3048 -- There is no node in the tree for a record type definition. Instead
3049 -- a record definition node appears, with possible Abstract_Present,
3050 -- Tagged_Present, and Limited_Present flags set appropriately.
3052 ----------------------------
3053 -- 3.8 Record Definition --
3054 ----------------------------
3056 -- RECORD_DEFINITION ::=
3062 -- Note: in the case where a record definition node is used to represent
3063 -- a record type definition, the caller sets the Tagged_Present and
3064 -- Limited_Present flags in the resulting N_Record_Definition node as
3067 -- Note that the RECORD token at the start may be missing in certain
3068 -- error situations, so this function is expected to post the error
3070 -- Error recovery: can raise Error_Resync
3072 function P_Record_Definition return Node_Id is
3076 Rec_Node := New_Node (N_Record_Definition, Token_Ptr);
3080 if Token = Tok_Null then
3083 Set_Null_Present (Rec_Node, True);
3085 -- Case starting with RECORD keyword. Build scope stack entry. For the
3086 -- column, we use the first non-blank character on the line, to deal
3087 -- with situations such as:
3093 -- which is not official RM indentation, but is not uncommon usage
3097 Scope.Table (Scope.Last).Etyp := E_Record;
3098 Scope.Table (Scope.Last).Ecol := Start_Column;
3099 Scope.Table (Scope.Last).Sloc := Token_Ptr;
3100 Scope.Table (Scope.Last).Labl := Error;
3101 Scope.Table (Scope.Last).Junk := (Token /= Tok_Record);
3105 Set_Component_List (Rec_Node, P_Component_List);
3108 exit when Check_End;
3109 Discard_Junk_Node (P_Component_List);
3114 end P_Record_Definition;
3116 -------------------------
3117 -- 3.8 Component List --
3118 -------------------------
3120 -- COMPONENT_LIST ::=
3121 -- COMPONENT_ITEM {COMPONENT_ITEM}
3122 -- | {COMPONENT_ITEM} VARIANT_PART
3125 -- Error recovery: cannot raise Error_Resync
3127 function P_Component_List return Node_Id is
3128 Component_List_Node : Node_Id;
3129 Decls_List : List_Id;
3130 Scan_State : Saved_Scan_State;
3133 Component_List_Node := New_Node (N_Component_List, Token_Ptr);
3134 Decls_List := New_List;
3136 if Token = Tok_Null then
3139 P_Pragmas_Opt (Decls_List);
3140 Set_Null_Present (Component_List_Node, True);
3141 return Component_List_Node;
3144 P_Pragmas_Opt (Decls_List);
3146 if Token /= Tok_Case then
3147 Component_Scan_Loop : loop
3148 P_Component_Items (Decls_List);
3149 P_Pragmas_Opt (Decls_List);
3151 exit Component_Scan_Loop when Token = Tok_End
3152 or else Token = Tok_Case
3153 or else Token = Tok_When;
3155 -- We are done if we do not have an identifier. However, if
3156 -- we have a misspelled reserved identifier that is in a column
3157 -- to the right of the record definition, we will treat it as
3158 -- an identifier. It turns out to be too dangerous in practice
3159 -- to accept such a mis-spelled identifier which does not have
3160 -- this additional clue that confirms the incorrect spelling.
3162 if Token /= Tok_Identifier then
3163 if Start_Column > Scope.Table (Scope.Last).Ecol
3164 and then Is_Reserved_Identifier
3166 Save_Scan_State (Scan_State); -- at reserved id
3167 Scan; -- possible reserved id
3169 if Token = Tok_Comma or else Token = Tok_Colon then
3170 Restore_Scan_State (Scan_State);
3171 Scan_Reserved_Identifier (Force_Msg => True);
3173 -- Note reserved identifier used as field name after
3174 -- all because not followed by colon or comma
3177 Restore_Scan_State (Scan_State);
3178 exit Component_Scan_Loop;
3181 -- Non-identifier that definitely was not reserved id
3184 exit Component_Scan_Loop;
3187 end loop Component_Scan_Loop;
3190 if Token = Tok_Case then
3191 Set_Variant_Part (Component_List_Node, P_Variant_Part);
3193 -- Check for junk after variant part
3195 if Token = Tok_Identifier then
3196 Save_Scan_State (Scan_State);
3197 Scan; -- past identifier
3199 if Token = Tok_Colon then
3200 Restore_Scan_State (Scan_State);
3201 Error_Msg_SC ("component may not follow variant part");
3202 Discard_Junk_Node (P_Component_List);
3204 elsif Token = Tok_Case then
3205 Restore_Scan_State (Scan_State);
3206 Error_Msg_SC ("only one variant part allowed in a record");
3207 Discard_Junk_Node (P_Component_List);
3210 Restore_Scan_State (Scan_State);
3216 Set_Component_Items (Component_List_Node, Decls_List);
3217 return Component_List_Node;
3218 end P_Component_List;
3220 -------------------------
3221 -- 3.8 Component Item --
3222 -------------------------
3224 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
3226 -- COMPONENT_DECLARATION ::=
3227 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
3228 -- [:= DEFAULT_EXPRESSION];
3230 -- COMPONENT_DEFINITION ::=
3231 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
3233 -- Error recovery: cannot raise Error_Resync, if an error occurs,
3234 -- the scan is positioned past the following semicolon.
3236 -- Note: we do not yet allow representation clauses to appear as component
3237 -- items, do we need to add this capability sometime in the future ???
3239 procedure P_Component_Items (Decls : List_Id) is
3240 Aliased_Present : Boolean := False;
3241 CompDef_Node : Node_Id;
3242 Decl_Node : Node_Id;
3243 Scan_State : Saved_Scan_State;
3244 Not_Null_Present : Boolean := False;
3247 Ident_Sloc : Source_Ptr;
3249 Idents : array (Int range 1 .. 4096) of Entity_Id;
3250 -- This array holds the list of defining identifiers. The upper bound
3251 -- of 4096 is intended to be essentially infinite, and we do not even
3252 -- bother to check for it being exceeded.
3255 if Token /= Tok_Identifier then
3256 Error_Msg_SC ("component declaration expected");
3257 Resync_Past_Semicolon;
3261 Ident_Sloc := Token_Ptr;
3262 Idents (1) := P_Defining_Identifier (C_Comma_Colon);
3265 while Comma_Present loop
3266 Num_Idents := Num_Idents + 1;
3267 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
3270 -- If there are multiple identifiers, we repeatedly scan the
3271 -- type and initialization expression information by resetting
3272 -- the scan pointer (so that we get completely separate trees
3273 -- for each occurrence).
3275 if Num_Idents > 1 then
3276 Save_Scan_State (Scan_State);
3281 -- Loop through defining identifiers in list
3286 -- The following block is present to catch Error_Resync
3287 -- which causes the parse to be reset past the semicolon
3290 Decl_Node := New_Node (N_Component_Declaration, Ident_Sloc);
3291 Set_Defining_Identifier (Decl_Node, Idents (Ident));
3293 if Token = Tok_Constant then
3294 Error_Msg_SC ("constant components are not permitted");
3298 CompDef_Node := New_Node (N_Component_Definition, Token_Ptr);
3300 if Token_Name = Name_Aliased then
3301 Check_95_Keyword (Tok_Aliased, Tok_Identifier);
3304 if Token = Tok_Aliased then
3305 Aliased_Present := True;
3306 Scan; -- past ALIASED
3309 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254)
3311 -- Ada 2005 (AI-230): Access Definition case
3313 if Token = Tok_Access then
3314 if Ada_Version < Ada_05 then
3316 ("generalized use of anonymous access types " &
3317 "is an Ada 2005 extension");
3318 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
3321 if Aliased_Present then
3322 Error_Msg_SP ("ALIASED not allowed here");
3325 Set_Subtype_Indication (CompDef_Node, Empty);
3326 Set_Aliased_Present (CompDef_Node, False);
3327 Set_Access_Definition (CompDef_Node,
3328 P_Access_Definition (Not_Null_Present));
3331 Set_Access_Definition (CompDef_Node, Empty);
3332 Set_Aliased_Present (CompDef_Node, Aliased_Present);
3333 Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present);
3335 if Token = Tok_Array then
3337 ("anonymous arrays not allowed as components");
3341 Set_Subtype_Indication (CompDef_Node,
3342 P_Subtype_Indication (Not_Null_Present));
3345 Set_Component_Definition (Decl_Node, CompDef_Node);
3346 Set_Expression (Decl_Node, Init_Expr_Opt);
3349 Set_Prev_Ids (Decl_Node, True);
3352 if Ident < Num_Idents then
3353 Set_More_Ids (Decl_Node, True);
3356 Append (Decl_Node, Decls);
3359 when Error_Resync =>
3360 if Token /= Tok_End then
3361 Resync_Past_Semicolon;
3365 exit Ident_Loop when Ident = Num_Idents;
3367 Restore_Scan_State (Scan_State);
3370 end loop Ident_Loop;
3373 end P_Component_Items;
3375 --------------------------------
3376 -- 3.8 Component Declaration --
3377 --------------------------------
3379 -- Parsed by P_Component_Items (3.8)
3381 -------------------------
3382 -- 3.8.1 Variant Part --
3383 -------------------------
3386 -- case discriminant_DIRECT_NAME is
3391 -- The caller has checked that the initial token is CASE
3393 -- Error recovery: cannot raise Error_Resync
3395 function P_Variant_Part return Node_Id is
3396 Variant_Part_Node : Node_Id;
3397 Variants_List : List_Id;
3398 Case_Node : Node_Id;
3401 Variant_Part_Node := New_Node (N_Variant_Part, Token_Ptr);
3403 Scope.Table (Scope.Last).Etyp := E_Case;
3404 Scope.Table (Scope.Last).Sloc := Token_Ptr;
3405 Scope.Table (Scope.Last).Ecol := Start_Column;
3408 Case_Node := P_Expression;
3409 Set_Name (Variant_Part_Node, Case_Node);
3411 if Nkind (Case_Node) /= N_Identifier then
3412 Set_Name (Variant_Part_Node, Error);
3413 Error_Msg ("discriminant name expected", Sloc (Case_Node));
3417 Variants_List := New_List;
3418 P_Pragmas_Opt (Variants_List);
3420 -- Test missing variant
3422 if Token = Tok_End then
3423 Error_Msg_BC ("WHEN expected (must have at least one variant)");
3425 Append (P_Variant, Variants_List);
3428 -- Loop through variants, note that we allow if in place of when,
3429 -- this error will be detected and handled in P_Variant.
3432 P_Pragmas_Opt (Variants_List);
3434 if Token /= Tok_When
3435 and then Token /= Tok_If
3436 and then Token /= Tok_Others
3438 exit when Check_End;
3441 Append (P_Variant, Variants_List);
3444 Set_Variants (Variant_Part_Node, Variants_List);
3445 return Variant_Part_Node;
3448 --------------------
3450 --------------------
3453 -- when DISCRETE_CHOICE_LIST =>
3456 -- Error recovery: cannot raise Error_Resync
3458 -- The initial token on entry is either WHEN, IF or OTHERS
3460 function P_Variant return Node_Id is
3461 Variant_Node : Node_Id;
3464 -- Special check to recover nicely from use of IF in place of WHEN
3466 if Token = Tok_If then
3473 Variant_Node := New_Node (N_Variant, Prev_Token_Ptr);
3474 Set_Discrete_Choices (Variant_Node, P_Discrete_Choice_List);
3476 Set_Component_List (Variant_Node, P_Component_List);
3477 return Variant_Node;
3480 ---------------------------------
3481 -- 3.8.1 Discrete Choice List --
3482 ---------------------------------
3484 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
3486 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
3488 -- Note: in Ada 83, the expression must be a simple expression
3490 -- Error recovery: cannot raise Error_Resync
3492 function P_Discrete_Choice_List return List_Id is
3494 Expr_Node : Node_Id;
3495 Choice_Node : Node_Id;
3498 Choices := New_List;
3501 if Token = Tok_Others then
3502 Append (New_Node (N_Others_Choice, Token_Ptr), Choices);
3503 Scan; -- past OTHERS
3507 Expr_Node := P_Expression_Or_Range_Attribute;
3508 Check_No_Right_Paren;
3510 if Token = Tok_Colon
3511 and then Nkind (Expr_Node) = N_Identifier
3513 Error_Msg_SP ("label not permitted in this context");
3516 elsif Expr_Form = EF_Range_Attr then
3517 Append (Expr_Node, Choices);
3519 elsif Token = Tok_Dot_Dot then
3520 Check_Simple_Expression (Expr_Node);
3521 Choice_Node := New_Node (N_Range, Token_Ptr);
3522 Set_Low_Bound (Choice_Node, Expr_Node);
3524 Expr_Node := P_Expression_No_Right_Paren;
3525 Check_Simple_Expression (Expr_Node);
3526 Set_High_Bound (Choice_Node, Expr_Node);
3527 Append (Choice_Node, Choices);
3529 elsif Expr_Form = EF_Simple_Name then
3530 if Token = Tok_Range then
3531 Append (P_Subtype_Indication (Expr_Node), Choices);
3533 elsif Token in Token_Class_Consk then
3535 ("the only constraint allowed here " &
3536 "is a range constraint");
3537 Discard_Junk_Node (P_Constraint_Opt);
3538 Append (Expr_Node, Choices);
3541 Append (Expr_Node, Choices);
3545 Check_Simple_Expression_In_Ada_83 (Expr_Node);
3546 Append (Expr_Node, Choices);
3550 when Error_Resync =>
3556 if Token = Tok_Comma then
3557 Error_Msg_SC (""","" should be ""'|""");
3559 exit when Token /= Tok_Vertical_Bar;
3562 Scan; -- past | or comma
3566 end P_Discrete_Choice_List;
3568 ----------------------------
3569 -- 3.8.1 Discrete Choice --
3570 ----------------------------
3572 -- Parsed by P_Discrete_Choice_List (3.8.1)
3574 ----------------------------------
3575 -- 3.9.1 Record Extension Part --
3576 ----------------------------------
3578 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
3580 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
3582 --------------------------------------
3583 -- 3.9.4 Interface Type Definition --
3584 --------------------------------------
3586 -- INTERFACE_TYPE_DEFINITION ::=
3587 -- [limited | task | protected | synchronized] interface
3588 -- [and INTERFACE_LIST]
3590 -- Error recovery: cannot raise Error_Resync
3592 function P_Interface_Type_Definition
3593 (Abstract_Present : Boolean) return Node_Id
3595 Typedef_Node : Node_Id;
3598 if Ada_Version < Ada_05 then
3599 Error_Msg_SP ("abstract interface is an Ada 2005 extension");
3600 Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
3603 if Abstract_Present then
3604 Error_Msg_SP ("ABSTRACT not allowed in interface type definition " &
3608 Scan; -- past INTERFACE
3610 -- Ada 2005 (AI-345): In case of interfaces with a null list of
3611 -- interfaces we build a record_definition node.
3613 if Token = Tok_Semicolon then
3614 Typedef_Node := New_Node (N_Record_Definition, Token_Ptr);
3616 Set_Abstract_Present (Typedef_Node);
3617 Set_Tagged_Present (Typedef_Node);
3618 Set_Null_Present (Typedef_Node);
3619 Set_Interface_Present (Typedef_Node);
3621 -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have
3622 -- a list of interfaces we build a derived_type_definition node. This
3623 -- simplifies the semantic analysis (and hence further mainteinance)
3626 if Token /= Tok_And then
3627 Error_Msg_AP ("AND expected");
3632 Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr);
3634 Set_Abstract_Present (Typedef_Node);
3635 Set_Interface_Present (Typedef_Node);
3636 Set_Subtype_Indication (Typedef_Node, P_Qualified_Simple_Name);
3638 Set_Record_Extension_Part (Typedef_Node,
3639 New_Node (N_Record_Definition, Token_Ptr));
3640 Set_Null_Present (Record_Extension_Part (Typedef_Node));
3642 if Token = Tok_And then
3643 Set_Interface_List (Typedef_Node, New_List);
3647 Append (P_Qualified_Simple_Name,
3648 Interface_List (Typedef_Node));
3649 exit when Token /= Tok_And;
3655 return Typedef_Node;
3656 end P_Interface_Type_Definition;
3658 ----------------------------------
3659 -- 3.10 Access Type Definition --
3660 ----------------------------------
3662 -- ACCESS_TYPE_DEFINITION ::=
3663 -- ACCESS_TO_OBJECT_DEFINITION
3664 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3666 -- ACCESS_TO_OBJECT_DEFINITION ::=
3667 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
3669 -- GENERAL_ACCESS_MODIFIER ::= all | constant
3671 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3672 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3673 -- | [NULL_EXCLUSION] access [protected] function
3674 -- PARAMETER_AND_RESULT_PROFILE
3676 -- PARAMETER_PROFILE ::= [FORMAL_PART]
3678 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
3680 -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already
3681 -- parsed the null_exclusion part and has also removed the ACCESS token;
3682 -- otherwise the caller has just checked that the initial token is ACCESS
3684 -- Error recovery: can raise Error_Resync
3686 function P_Access_Type_Definition
3687 (Header_Already_Parsed : Boolean := False) return Node_Id
3689 Access_Loc : constant Source_Ptr := Token_Ptr;
3690 Prot_Flag : Boolean;
3691 Not_Null_Present : Boolean := False;
3692 Type_Def_Node : Node_Id;
3693 Result_Not_Null : Boolean;
3694 Result_Node : Node_Id;
3696 procedure Check_Junk_Subprogram_Name;
3697 -- Used in access to subprogram definition cases to check for an
3698 -- identifier or operator symbol that does not belong.
3700 --------------------------------
3701 -- Check_Junk_Subprogram_Name --
3702 --------------------------------
3704 procedure Check_Junk_Subprogram_Name is
3705 Saved_State : Saved_Scan_State;
3708 if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then
3709 Save_Scan_State (Saved_State);
3710 Scan; -- past possible junk subprogram name
3712 if Token = Tok_Left_Paren or else Token = Tok_Semicolon then
3713 Error_Msg_SP ("unexpected subprogram name ignored");
3717 Restore_Scan_State (Saved_State);
3720 end Check_Junk_Subprogram_Name;
3722 -- Start of processing for P_Access_Type_Definition
3725 if not Header_Already_Parsed then
3726 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231)
3727 Scan; -- past ACCESS
3730 if Token_Name = Name_Protected then
3731 Check_95_Keyword (Tok_Protected, Tok_Procedure);
3732 Check_95_Keyword (Tok_Protected, Tok_Function);
3735 Prot_Flag := (Token = Tok_Protected);
3738 Scan; -- past PROTECTED
3740 if Token /= Tok_Procedure and then Token /= Tok_Function then
3741 Error_Msg_SC ("FUNCTION or PROCEDURE expected");
3745 if Token = Tok_Procedure then
3746 if Ada_Version = Ada_83 then
3747 Error_Msg_SC ("(Ada 83) access to procedure not allowed!");
3750 Type_Def_Node := New_Node (N_Access_Procedure_Definition, Access_Loc);
3751 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3752 Scan; -- past PROCEDURE
3753 Check_Junk_Subprogram_Name;
3754 Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
3755 Set_Protected_Present (Type_Def_Node, Prot_Flag);
3757 elsif Token = Tok_Function then
3758 if Ada_Version = Ada_83 then
3759 Error_Msg_SC ("(Ada 83) access to function not allowed!");
3762 Type_Def_Node := New_Node (N_Access_Function_Definition, Access_Loc);
3763 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3764 Scan; -- past FUNCTION
3765 Check_Junk_Subprogram_Name;
3766 Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile);
3767 Set_Protected_Present (Type_Def_Node, Prot_Flag);
3770 Result_Not_Null := P_Null_Exclusion; -- Ada 2005 (AI-231)
3772 -- Ada 2005 (AI-318-02)
3774 if Token = Tok_Access then
3775 if Ada_Version < Ada_05 then
3777 ("anonymous access result type is an Ada 2005 extension");
3778 Error_Msg_SC ("\unit must be compiled with -gnat05 switch");
3781 Result_Node := P_Access_Definition (Result_Not_Null);
3784 Result_Node := P_Subtype_Mark;
3788 -- Note: A null exclusion given on the result type needs to
3789 -- be coded by a distinct flag, since Null_Exclusion_Present
3790 -- on an access-to-function type pertains to a null exclusion
3791 -- on the access type itself (as set above). ???
3792 -- Set_Null_Exclusion_Present??? (Type_Def_Node, Result_Not_Null);
3794 Set_Result_Definition (Type_Def_Node, Result_Node);
3798 New_Node (N_Access_To_Object_Definition, Access_Loc);
3799 Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present);
3801 if Token = Tok_All or else Token = Tok_Constant then
3802 if Ada_Version = Ada_83 then
3803 Error_Msg_SC ("(Ada 83) access modifier not allowed!");
3806 if Token = Tok_All then
3807 Set_All_Present (Type_Def_Node, True);
3810 Set_Constant_Present (Type_Def_Node, True);
3813 Scan; -- past ALL or CONSTANT
3816 Set_Subtype_Indication (Type_Def_Node,
3817 P_Subtype_Indication (Not_Null_Present));
3820 return Type_Def_Node;
3821 end P_Access_Type_Definition;
3823 ---------------------------------------
3824 -- 3.10 Access To Object Definition --
3825 ---------------------------------------
3827 -- Parsed by P_Access_Type_Definition (3.10)
3829 -----------------------------------
3830 -- 3.10 General Access Modifier --
3831 -----------------------------------
3833 -- Parsed by P_Access_Type_Definition (3.10)
3835 -------------------------------------------
3836 -- 3.10 Access To Subprogram Definition --
3837 -------------------------------------------
3839 -- Parsed by P_Access_Type_Definition (3.10)
3841 -----------------------------
3842 -- 3.10 Access Definition --
3843 -----------------------------
3845 -- ACCESS_DEFINITION ::=
3846 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3847 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3849 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3850 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3851 -- | [NULL_EXCLUSION] access [protected] function
3852 -- PARAMETER_AND_RESULT_PROFILE
3854 -- The caller has parsed the null-exclusion part and it has also checked
3855 -- that the next token is ACCESS
3857 -- Error recovery: cannot raise Error_Resync
3859 function P_Access_Definition
3860 (Null_Exclusion_Present : Boolean) return Node_Id
3863 Subp_Node : Node_Id;
3866 Def_Node := New_Node (N_Access_Definition, Token_Ptr);
3867 Scan; -- past ACCESS
3869 -- Ada 2005 (AI-254): Access_To_Subprogram_Definition
3871 if Token = Tok_Protected
3872 or else Token = Tok_Procedure
3873 or else Token = Tok_Function
3875 if Ada_Version < Ada_05 then
3876 Error_Msg_SP ("access-to-subprogram is an Ada 2005 extension");
3877 Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
3880 Subp_Node := P_Access_Type_Definition (Header_Already_Parsed => True);
3881 Set_Null_Exclusion_Present (Subp_Node, Null_Exclusion_Present);
3882 Set_Access_To_Subprogram_Definition (Def_Node, Subp_Node);
3884 -- Ada 2005 (AI-231)
3885 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3888 Set_Null_Exclusion_Present (Def_Node, Null_Exclusion_Present);
3890 if Token = Tok_All then
3891 if Ada_Version < Ada_05 then
3893 ("access-all in this context is an Ada 2005 extension");
3894 Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
3898 Set_All_Present (Def_Node);
3900 elsif Token = Tok_Constant then
3901 if Ada_Version < Ada_05 then
3902 Error_Msg_SP ("access-to-constant is an Ada 2005 extension");
3903 Error_Msg_SP ("\unit should be compiled with -gnat05 switch");
3906 Scan; -- past CONSTANT
3907 Set_Constant_Present (Def_Node);
3910 Set_Subtype_Mark (Def_Node, P_Subtype_Mark);
3915 end P_Access_Definition;
3917 -----------------------------------------
3918 -- 3.10.1 Incomplete Type Declaration --
3919 -----------------------------------------
3921 -- Parsed by P_Type_Declaration (3.2.1)
3923 ----------------------------
3924 -- 3.11 Declarative Part --
3925 ----------------------------
3927 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
3929 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items
3930 -- handles errors, and returns cleanly after an error has occurred)
3932 function P_Declarative_Part return List_Id is
3937 -- Indicate no bad declarations detected yet. This will be reset by
3938 -- P_Declarative_Items if a bad declaration is discovered.
3940 Missing_Begin_Msg := No_Error_Msg;
3942 -- Get rid of active SIS entry from outer scope. This means we will
3943 -- miss some nested cases, but it doesn't seem worth the effort. See
3944 -- discussion in Par for further details
3946 SIS_Entry_Active := False;
3949 -- Loop to scan out the declarations
3952 P_Declarative_Items (Decls, Done, In_Spec => False);
3956 -- Get rid of active SIS entry which is left set only if we scanned a
3957 -- procedure declaration and have not found the body. We could give
3958 -- an error message, but that really would be usurping the role of
3959 -- semantic analysis (this really is a missing body case).
3961 SIS_Entry_Active := False;
3963 end P_Declarative_Part;
3965 ----------------------------
3966 -- 3.11 Declarative Item --
3967 ----------------------------
3969 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
3971 -- Can return Error if a junk declaration is found, or Empty if no
3972 -- declaration is found (i.e. a token ending declarations, such as
3973 -- BEGIN or END is encountered).
3975 -- Error recovery: cannot raise Error_Resync. If an error resync occurs,
3976 -- then the scan is set past the next semicolon and Error is returned.
3978 procedure P_Declarative_Items
3983 Scan_State : Saved_Scan_State;
3987 Style.Check_Indentation;
3992 when Tok_Function =>
3994 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4000 -- Check for loop (premature statement)
4002 Save_Scan_State (Scan_State);
4005 if Token = Tok_Identifier then
4006 Scan; -- past identifier
4008 if Token = Tok_In then
4009 Restore_Scan_State (Scan_State);
4010 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
4015 -- Not a loop, so must be rep clause
4017 Restore_Scan_State (Scan_State);
4018 Append (P_Representation_Clause, Decls);
4023 Append (P_Generic, Decls);
4026 when Tok_Identifier =>
4028 P_Identifier_Declarations (Decls, Done, In_Spec);
4030 -- Ada2005: A subprogram declaration can start with "not" or
4031 -- "overriding". In older versions, "overriding" is handled
4032 -- like an identifier, with the appropriate warning.
4036 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4039 when Tok_Overriding =>
4041 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4046 Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4050 Append (P_Pragma, Decls);
4053 when Tok_Procedure =>
4055 Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls);
4058 when Tok_Protected =>
4060 Scan; -- past PROTECTED
4061 Append (P_Protected, Decls);
4066 Append (P_Subtype_Declaration, Decls);
4072 Append (P_Task, Decls);
4077 Append (P_Type_Declaration, Decls);
4082 Append (P_Use_Clause, Decls);
4087 Error_Msg_SC ("WITH can only appear in context clause");
4090 -- BEGIN terminates the scan of a sequence of declarations unless
4091 -- there is a missing subprogram body, see section on handling
4092 -- semicolon in place of IS. We only treat the begin as satisfying
4093 -- the subprogram declaration if it falls in the expected column
4097 if SIS_Entry_Active and then Start_Column >= SIS_Ecol then
4099 -- Here we have the case where a BEGIN is encountered during
4100 -- declarations in a declarative part, or at the outer level,
4101 -- and there is a subprogram declaration outstanding for which
4102 -- no body has been supplied. This is the case where we assume
4103 -- that the semicolon in the subprogram declaration should
4104 -- really have been is. The active SIS entry describes the
4105 -- subprogram declaration. On return the declaration has been
4106 -- modified to become a body.
4109 Specification_Node : Node_Id;
4110 Decl_Node : Node_Id;
4111 Body_Node : Node_Id;
4114 -- First issue the error message. If we had a missing
4115 -- semicolon in the declaration, then change the message
4116 -- to <missing "is">
4118 if SIS_Missing_Semicolon_Message /= No_Error_Msg then
4119 Change_Error_Text -- Replace: "missing "";"" "
4120 (SIS_Missing_Semicolon_Message, "missing ""is""");
4122 -- Otherwise we saved the semicolon position, so complain
4125 Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc);
4128 -- The next job is to fix up any declarations that occurred
4129 -- between the procedure header and the BEGIN. These got
4130 -- chained to the outer declarative region (immediately
4131 -- after the procedure declaration) and they should be
4132 -- chained to the subprogram itself, which is a body
4133 -- rather than a spec.
4135 Specification_Node := Specification (SIS_Declaration_Node);
4136 Change_Node (SIS_Declaration_Node, N_Subprogram_Body);
4137 Body_Node := SIS_Declaration_Node;
4138 Set_Specification (Body_Node, Specification_Node);
4139 Set_Declarations (Body_Node, New_List);
4142 Decl_Node := Remove_Next (Body_Node);
4143 exit when Decl_Node = Empty;
4144 Append (Decl_Node, Declarations (Body_Node));
4147 -- Now make the scope table entry for the Begin-End and
4151 Scope.Table (Scope.Last).Sloc := SIS_Sloc;
4152 Scope.Table (Scope.Last).Etyp := E_Name;
4153 Scope.Table (Scope.Last).Ecol := SIS_Ecol;
4154 Scope.Table (Scope.Last).Labl := SIS_Labl;
4155 Scope.Table (Scope.Last).Lreq := False;
4156 SIS_Entry_Active := False;
4158 Set_Handled_Statement_Sequence (Body_Node,
4159 P_Handled_Sequence_Of_Statements);
4160 End_Statements (Handled_Statement_Sequence (Body_Node));
4169 -- Normally an END terminates the scan for basic declarative
4170 -- items. The one exception is END RECORD, which is probably
4171 -- left over from some other junk.
4174 Save_Scan_State (Scan_State); -- at END
4177 if Token = Tok_Record then
4178 Error_Msg_SP ("no RECORD for this `end record`!");
4179 Scan; -- past RECORD
4183 Restore_Scan_State (Scan_State); -- to END
4187 -- The following tokens which can only be the start of a statement
4188 -- are considered to end a declarative part (i.e. we have a missing
4189 -- BEGIN situation). We are fairly conservative in making this
4190 -- judgment, because it is a real mess to go into statement mode
4191 -- prematurely in response to a junk declaration.
4206 -- But before we decide that it's a statement, let's check for
4207 -- a reserved word misused as an identifier.
4209 if Is_Reserved_Identifier then
4210 Save_Scan_State (Scan_State);
4211 Scan; -- past the token
4213 -- If reserved identifier not followed by colon or comma, then
4214 -- this is most likely an assignment statement to the bad id.
4216 if Token /= Tok_Colon and then Token /= Tok_Comma then
4217 Restore_Scan_State (Scan_State);
4218 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
4221 -- Otherwise we have a declaration of the bad id
4224 Restore_Scan_State (Scan_State);
4225 Scan_Reserved_Identifier (Force_Msg => True);
4226 P_Identifier_Declarations (Decls, Done, In_Spec);
4229 -- If not reserved identifier, then it's definitely a statement
4232 Statement_When_Declaration_Expected (Decls, Done, In_Spec);
4236 -- The token RETURN may well also signal a missing BEGIN situation,
4237 -- however, we never let it end the declarative part, because it may
4238 -- also be part of a half-baked function declaration.
4241 Error_Msg_SC ("misplaced RETURN statement");
4244 -- PRIVATE definitely terminates the declarations in a spec,
4245 -- and is an error in a body.
4251 Error_Msg_SC ("PRIVATE not allowed in body");
4252 Scan; -- past PRIVATE
4255 -- An end of file definitely terminates the declarations!
4260 -- The remaining tokens do not end the scan, but cannot start a
4261 -- valid declaration, so we signal an error and resynchronize.
4262 -- But first check for misuse of a reserved identifier.
4266 -- Here we check for a reserved identifier
4268 if Is_Reserved_Identifier then
4269 Save_Scan_State (Scan_State);
4270 Scan; -- past the token
4272 if Token /= Tok_Colon and then Token /= Tok_Comma then
4273 Restore_Scan_State (Scan_State);
4274 Set_Declaration_Expected;
4277 Restore_Scan_State (Scan_State);
4278 Scan_Reserved_Identifier (Force_Msg => True);
4280 P_Identifier_Declarations (Decls, Done, In_Spec);
4284 Set_Declaration_Expected;
4289 -- To resynchronize after an error, we scan to the next semicolon and
4290 -- return with Done = False, indicating that there may still be more
4291 -- valid declarations to come.
4294 when Error_Resync =>
4295 Resync_Past_Semicolon;
4297 end P_Declarative_Items;
4299 ----------------------------------
4300 -- 3.11 Basic Declarative Item --
4301 ----------------------------------
4303 -- BASIC_DECLARATIVE_ITEM ::=
4304 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
4306 -- Scan zero or more basic declarative items
4308 -- Error recovery: cannot raise Error_Resync. If an error is detected, then
4309 -- the scan pointer is repositioned past the next semicolon, and the scan
4310 -- for declarative items continues.
4312 function P_Basic_Declarative_Items return List_Id is
4319 -- Indicate no bad declarations detected yet in the current context:
4320 -- visible or private declarations of a package spec.
4322 Missing_Begin_Msg := No_Error_Msg;
4324 -- Get rid of active SIS entry from outer scope. This means we will
4325 -- miss some nested cases, but it doesn't seem worth the effort. See
4326 -- discussion in Par for further details
4328 SIS_Entry_Active := False;
4330 -- Loop to scan out declarations
4335 P_Declarative_Items (Decls, Done, In_Spec => True);
4339 -- Get rid of active SIS entry. This is set only if we have scanned a
4340 -- procedure declaration and have not found the body. We could give
4341 -- an error message, but that really would be usurping the role of
4342 -- semantic analysis (this really is a case of a missing body).
4344 SIS_Entry_Active := False;
4346 -- Test for assorted illegal declarations not diagnosed elsewhere
4348 Decl := First (Decls);
4350 while Present (Decl) loop
4351 Kind := Nkind (Decl);
4353 -- Test for body scanned, not acceptable as basic decl item
4355 if Kind = N_Subprogram_Body or else
4356 Kind = N_Package_Body or else
4357 Kind = N_Task_Body or else
4358 Kind = N_Protected_Body
4361 ("proper body not allowed in package spec", Sloc (Decl));
4363 -- Test for body stub scanned, not acceptable as basic decl item
4365 elsif Kind in N_Body_Stub then
4367 ("body stub not allowed in package spec", Sloc (Decl));
4369 elsif Kind = N_Assignment_Statement then
4371 ("assignment statement not allowed in package spec",
4379 end P_Basic_Declarative_Items;
4385 -- For proper body, see below
4386 -- For body stub, see 10.1.3
4388 -----------------------
4389 -- 3.11 Proper Body --
4390 -----------------------
4392 -- Subprogram body is parsed by P_Subprogram (6.1)
4393 -- Package body is parsed by P_Package (7.1)
4394 -- Task body is parsed by P_Task (9.1)
4395 -- Protected body is parsed by P_Protected (9.4)
4397 ------------------------------
4398 -- Set_Declaration_Expected --
4399 ------------------------------
4401 procedure Set_Declaration_Expected is
4403 Error_Msg_SC ("declaration expected");
4405 if Missing_Begin_Msg = No_Error_Msg then
4406 Missing_Begin_Msg := Get_Msg_Id;
4408 end Set_Declaration_Expected;
4410 ----------------------
4411 -- Skip_Declaration --
4412 ----------------------
4414 procedure Skip_Declaration (S : List_Id) is
4415 Dummy_Done : Boolean;
4418 P_Declarative_Items (S, Dummy_Done, False);
4419 end Skip_Declaration;
4421 -----------------------------------------
4422 -- Statement_When_Declaration_Expected --
4423 -----------------------------------------
4425 procedure Statement_When_Declaration_Expected
4431 -- Case of second occurrence of statement in one declaration sequence
4433 if Missing_Begin_Msg /= No_Error_Msg then
4435 -- In the procedure spec case, just ignore it, we only give one
4436 -- message for the first occurrence, since otherwise we may get
4437 -- horrible cascading if BODY was missing in the header line.
4442 -- In the declarative part case, take a second statement as a sure
4443 -- sign that we really have a missing BEGIN, and end the declarative
4444 -- part now. Note that the caller will fix up the first message to
4445 -- say "missing BEGIN" so that's how the error will be signalled.
4452 -- Case of first occurrence of unexpected statement
4455 -- If we are in a package spec, then give message of statement
4456 -- not allowed in package spec. This message never gets changed.
4459 Error_Msg_SC ("statement not allowed in package spec");
4461 -- If in declarative part, then we give the message complaining
4462 -- about finding a statement when a declaration is expected. This
4463 -- gets changed to a complaint about a missing BEGIN if we later
4464 -- find that no BEGIN is present.
4467 Error_Msg_SC ("statement not allowed in declarative part");
4470 -- Capture message Id. This is used for two purposes, first to
4471 -- stop multiple messages, see test above, and second, to allow
4472 -- the replacement of the message in the declarative part case.
4474 Missing_Begin_Msg := Get_Msg_Id;
4477 -- In all cases except the case in which we decided to terminate the
4478 -- declaration sequence on a second error, we scan out the statement
4479 -- and append it to the list of declarations (note that the semantics
4480 -- can handle statements in a declaration list so if we proceed to
4481 -- call the semantic phase, all will be (reasonably) well!
4483 Append_List_To (Decls, P_Sequence_Of_Statements (SS_Unco));
4485 -- Done is set to False, since we want to continue the scan of
4486 -- declarations, hoping that this statement was a temporary glitch.
4487 -- If we indeed are now in the statement part (i.e. this was a missing
4488 -- BEGIN, then it's not terrible, we will simply keep calling this
4489 -- procedure to process the statements one by one, and then finally
4490 -- hit the missing BEGIN, which will clean up the error message.
4493 end Statement_When_Declaration_Expected;