1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2024, 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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 pragma Style_Checks
(All_Checks
);
27 -- Turn off subprogram body ordering check. Subprograms are in order
28 -- by RM section rather than alphabetical.
30 with Sinfo
.CN
; use Sinfo
.CN
;
40 -----------------------
41 -- Local Subprograms --
42 -----------------------
44 function P_Component_List
return Node_Id
;
45 function P_Defining_Character_Literal
return Node_Id
;
46 function P_Delta_Constraint
return Node_Id
;
47 function P_Derived_Type_Def_Or_Private_Ext_Decl
return Node_Id
;
48 function P_Digits_Constraint
return Node_Id
;
49 function P_Discriminant_Association
return Node_Id
;
50 function P_Enumeration_Literal_Specification
return Node_Id
;
51 function P_Enumeration_Type_Definition
return Node_Id
;
52 function P_Fixed_Point_Definition
return Node_Id
;
53 function P_Floating_Point_Definition
return Node_Id
;
54 function P_Index_Or_Discriminant_Constraint
return Node_Id
;
55 function P_Real_Range_Specification_Opt
return Node_Id
;
56 function P_Subtype_Declaration
return Node_Id
;
57 function P_Type_Declaration
return Node_Id
;
58 function P_Modular_Type_Definition
return Node_Id
;
59 function P_Variant
return Node_Id
;
60 function P_Variant_Part
return Node_Id
;
62 procedure Check_Restricted_Expression
(N
: Node_Id
);
63 -- Check that the expression N meets the Restricted_Expression syntax.
64 -- The syntax is as follows:
66 -- RESTRICTED_EXPRESSION ::=
67 -- RESTRICTED_RELATION {and RESTRICTED_RELATION}
68 -- | RESTRICTED_RELATION {and then RESTRICTED_RELATION}
69 -- | RESTRICTED_RELATION {or RESTRICTED_RELATION}
70 -- | RESTRICTED_RELATION {or else RESTRICTED_RELATION}
71 -- | RESTRICTED_RELATION {xor RESTRICTED_RELATION}
73 -- RESTRICTED_RELATION ::=
74 -- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION]
76 -- This syntax is used for choices when extensions (and set notations)
77 -- are enabled, to remove the ambiguity of "when X in A | B". We consider
78 -- it very unlikely that this will ever arise in practice.
80 procedure P_Declarative_Item
83 Declare_Expression
: Boolean;
85 In_Statements
: Boolean);
86 -- Parses a single declarative item. The parameters have the same meaning
87 -- as for P_Declarative_Items. If the declarative item has multiple
88 -- identifiers, as in "X, Y, Z : ...", then one declaration is appended to
89 -- Decls for each of the identifiers.
91 procedure P_Identifier_Declarations
95 In_Statements
: Boolean);
96 -- Parses a sequence of declarations for an identifier or list of
97 -- identifiers, and appends them to the given list. The parameters
98 -- have the same meaning as for P_Declarative_Items.
100 procedure Statement_When_Declaration_Expected
104 -- Called when a statement is found at a point where a declaration was
105 -- expected. The parameters have the same meaning as for
106 -- P_Declarative_Items.
108 procedure Set_Declaration_Expected
;
109 -- Posts a "declaration expected" error messages at the start of the
110 -- current token, and if this is the first such message issued, saves
111 -- the message id in Missing_Begin_Msg, for possible later replacement.
113 ---------------------------------
114 -- Check_Restricted_Expression --
115 ---------------------------------
117 procedure Check_Restricted_Expression
(N
: Node_Id
) is
119 if Nkind
(N
) in N_Op_And | N_Op_Or | N_Op_Xor | N_And_Then | N_Or_Else
121 Check_Restricted_Expression
(Left_Opnd
(N
));
122 Check_Restricted_Expression
(Right_Opnd
(N
));
124 elsif Nkind
(N
) in N_In | N_Not_In
125 and then Paren_Count
(N
) = 0
127 Error_Msg_N
("|this expression must be parenthesized!", N
);
129 end Check_Restricted_Expression
;
135 function Init_Expr_Opt
(P
: Boolean := False) return Node_Id
is
137 -- For colon, assume it means := unless it is at the end of
138 -- a line, in which case guess that it means a semicolon.
140 if Token
= Tok_Colon
then
141 if Token_Is_At_End_Of_Line
then
146 -- Here if := or something that we will take as equivalent
148 elsif Token
in Tok_Colon_Equal | Tok_Equal | Tok_Is
then
151 -- Another possibility. If we have a literal followed by a semicolon,
152 -- we assume that we have a missing colon-equal.
154 elsif Token
in Token_Class_Literal
then
156 Scan_State
: Saved_Scan_State
;
159 Save_Scan_State
(Scan_State
);
160 Scan
; -- past literal or identifier
162 if Token
= Tok_Semicolon
then
163 Restore_Scan_State
(Scan_State
);
165 Restore_Scan_State
(Scan_State
);
170 -- Otherwise we definitely have no initialization expression
176 -- Merge here if we have an initialization expression
183 return P_Expression_No_Right_Paren
;
187 ----------------------------
188 -- 3.1 Basic Declaration --
189 ----------------------------
191 -- Parsed by P_Basic_Declarative_Items (3.9)
193 ------------------------------
194 -- 3.1 Defining Identifier --
195 ------------------------------
197 -- DEFINING_IDENTIFIER ::= IDENTIFIER
199 -- Error recovery: can raise Error_Resync
201 function P_Defining_Identifier
(C
: Id_Check
:= None
) return Node_Id
is
202 Ident_Node
: Node_Id
:= P_Identifier
(C
, True);
205 -- If we already have a defining identifier, clean it out and make
206 -- a new clean identifier. This situation arises in some error cases
207 -- and we need to fix it.
209 if Nkind
(Ident_Node
) = N_Defining_Identifier
then
210 Ident_Node
:= Make_Identifier
(Sloc
(Ident_Node
), Chars
(Ident_Node
));
213 -- Change identifier to defining identifier if not in error
215 if Ident_Node
/= Error
then
216 Change_Identifier_To_Defining_Identifier
(Ident_Node
);
218 -- Warn if standard redefinition, except that we never warn on a
219 -- record field definition (since this is always a harmless case).
221 if not Inside_Record_Definition
then
222 Warn_If_Standard_Redefinition
(Ident_Node
);
227 end P_Defining_Identifier
;
229 -----------------------------
230 -- 3.2.1 Type Declaration --
231 -----------------------------
233 -- TYPE_DECLARATION ::=
234 -- FULL_TYPE_DECLARATION
235 -- | INCOMPLETE_TYPE_DECLARATION
236 -- | PRIVATE_TYPE_DECLARATION
237 -- | PRIVATE_EXTENSION_DECLARATION
239 -- FULL_TYPE_DECLARATION ::=
240 -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION
241 -- [ASPECT_SPECIFICATIONS];
242 -- | CONCURRENT_TYPE_DECLARATION
244 -- INCOMPLETE_TYPE_DECLARATION ::=
245 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [is tagged];
247 -- PRIVATE_TYPE_DECLARATION ::=
248 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
249 -- is [abstract] [tagged] [limited] private
250 -- [ASPECT_SPECIFICATIONS];
252 -- PRIVATE_EXTENSION_DECLARATION ::=
253 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
254 -- [abstract] [limited | synchronized]
255 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
256 -- with private [ASPECT_SPECIFICATIONS];
258 -- TYPE_DEFINITION ::=
259 -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
260 -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION
261 -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION
262 -- | DERIVED_TYPE_DEFINITION | INTERFACE_TYPE_DEFINITION
264 -- INTEGER_TYPE_DEFINITION ::=
265 -- SIGNED_INTEGER_TYPE_DEFINITION
266 -- MODULAR_TYPE_DEFINITION
268 -- INTERFACE_TYPE_DEFINITION ::=
269 -- [limited | task | protected | synchronized ] interface
270 -- [and INTERFACE_LIST]
272 -- Error recovery: can raise Error_Resync
274 -- The processing for full type declarations, incomplete type declarations,
275 -- private type declarations and type definitions is included in this
276 -- function. The processing for concurrent type declarations is NOT here,
277 -- but rather in chapter 9 (this function handles only declarations
278 -- starting with TYPE).
280 function P_Type_Declaration
return Node_Id
is
281 Abstract_Present
: Boolean := False;
282 Abstract_Loc
: Source_Ptr
:= No_Location
;
284 Discr_List
: List_Id
;
285 Discr_Sloc
: Source_Ptr
;
287 Ident_Node
: Node_Id
;
288 Is_Derived_Iface
: Boolean := False;
289 Type_Loc
: Source_Ptr
;
290 Type_Start_Col
: Column_Number
;
291 Unknown_Dis
: Boolean;
293 Typedef_Node
: Node_Id
;
294 -- Normally holds type definition, except in the case of a private
295 -- extension declaration, in which case it holds the declaration itself
298 Type_Loc
:= Token_Ptr
;
299 Type_Start_Col
:= Start_Column
;
301 -- If we have TYPE, then proceed ahead and scan identifier
303 if Token
= Tok_Type
then
304 Type_Token_Location
:= Type_Loc
;
306 Ident_Node
:= P_Defining_Identifier
(C_Is
);
308 -- Otherwise this is an error case
312 Type_Token_Location
:= Type_Loc
;
313 Ident_Node
:= P_Defining_Identifier
(C_Is
);
316 Discr_Sloc
:= Token_Ptr
;
318 if P_Unknown_Discriminant_Part_Opt
then
320 Discr_List
:= No_List
;
322 Unknown_Dis
:= False;
323 Discr_List
:= P_Known_Discriminant_Part_Opt
;
326 -- Incomplete type declaration. We complete the processing for this
327 -- case here and return the resulting incomplete type declaration node
329 if Token
= Tok_Semicolon
then
331 Decl_Node
:= New_Node
(N_Incomplete_Type_Declaration
, Type_Loc
);
332 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
333 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
334 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
341 -- Full type declaration or private type declaration, must have IS
343 if Token
= Tok_Equal
then
345 Scan
; -- past = used in place of IS
347 elsif Token
= Tok_Renames
then
348 Error_Msg_SC
-- CODEFIX
349 ("RENAMES should be IS");
350 Scan
; -- past RENAMES used in place of IS
356 -- First an error check, if we have two identifiers in a row, a likely
357 -- possibility is that the first of the identifiers is an incorrectly
360 if Token
= Tok_Identifier
then
362 SS
: Saved_Scan_State
;
366 Save_Scan_State
(SS
);
367 Scan
; -- past initial identifier
368 I2
:= (Token
= Tok_Identifier
);
369 Restore_Scan_State
(SS
);
373 (Bad_Spelling_Of
(Tok_Abstract
) or else
374 Bad_Spelling_Of
(Tok_Access
) or else
375 Bad_Spelling_Of
(Tok_Aliased
) or else
376 Bad_Spelling_Of
(Tok_Constant
))
383 -- Check for misuse of Ada 95 keyword abstract in Ada 83 mode
385 if Token_Name
= Name_Abstract
then
386 Check_95_Keyword
(Tok_Abstract
, Tok_Tagged
);
387 Check_95_Keyword
(Tok_Abstract
, Tok_New
);
390 -- Check cases of misuse of ABSTRACT
392 if Token
= Tok_Abstract
then
393 Abstract_Present
:= True;
394 Abstract_Loc
:= Token_Ptr
;
395 Scan
; -- past ABSTRACT
397 -- Ada 2005 (AI-419): AARM 3.4 (2/2)
399 if (Ada_Version
< Ada_2005
and then Token
= Tok_Limited
)
400 or else Token
in Tok_Private | Tok_Record | Tok_Null
402 Error_Msg_AP
("TAGGED expected");
406 -- Check for misuse of Ada 95 keyword Tagged
408 if Token_Name
= Name_Tagged
then
409 Check_95_Keyword
(Tok_Tagged
, Tok_Private
);
410 Check_95_Keyword
(Tok_Tagged
, Tok_Limited
);
411 Check_95_Keyword
(Tok_Tagged
, Tok_Record
);
414 -- Special check for misuse of Aliased
416 if Token
= Tok_Aliased
or else Token_Name
= Name_Aliased
then
417 Error_Msg_SC
("ALIASED not allowed in type definition");
418 Scan
; -- past ALIASED
421 -- The following processing deals with either a private type declaration
422 -- or a full type declaration. In the private type case, we build the
423 -- N_Private_Type_Declaration node, setting its Tagged_Present and
424 -- Limited_Present flags, on encountering the Private keyword, and
425 -- leave Typedef_Node set to Empty. For the full type declaration
426 -- case, Typedef_Node gets set to the type definition.
428 Typedef_Node
:= Empty
;
430 -- Switch on token following the IS. The loop normally runs once. It
431 -- only runs more than once if an error is detected, to try again after
432 -- detecting and fixing up the error.
437 | Tok_Not
-- Ada 2005 (AI-231)
439 Typedef_Node
:= P_Access_Type_Definition
;
443 Typedef_Node
:= P_Array_Type_Definition
;
447 Typedef_Node
:= P_Fixed_Point_Definition
;
451 Typedef_Node
:= P_Floating_Point_Definition
;
457 when Tok_Integer_Literal
=>
459 Typedef_Node
:= P_Signed_Integer_Type_Definition
;
463 Typedef_Node
:= P_Record_Definition
;
466 when Tok_Left_Paren
=>
467 Typedef_Node
:= P_Enumeration_Type_Definition
;
469 End_Labl
:= Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
470 Set_Comes_From_Source
(End_Labl
, False);
472 Set_End_Label
(Typedef_Node
, End_Labl
);
476 Typedef_Node
:= P_Modular_Type_Definition
;
480 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
482 if Nkind
(Typedef_Node
) = N_Derived_Type_Definition
483 and then Present
(Record_Extension_Part
(Typedef_Node
))
485 End_Labl
:= Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
486 Set_Comes_From_Source
(End_Labl
, False);
489 (Record_Extension_Part
(Typedef_Node
), End_Labl
);
495 Typedef_Node
:= P_Signed_Integer_Type_Definition
;
499 Typedef_Node
:= P_Record_Definition
;
501 End_Labl
:= Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
502 Set_Comes_From_Source
(End_Labl
, False);
504 Set_End_Label
(Typedef_Node
, End_Labl
);
510 -- Ada 2005 (AI-326): If the words IS TAGGED appear, the type
511 -- is a tagged incomplete type.
513 if Ada_Version
>= Ada_2005
514 and then Token
= Tok_Semicolon
519 New_Node
(N_Incomplete_Type_Declaration
, Type_Loc
);
520 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
521 Set_Tagged_Present
(Decl_Node
);
522 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
523 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
528 if Token
= Tok_Abstract
then
529 Error_Msg_SC
-- CODEFIX
530 ("ABSTRACT must come before TAGGED");
531 Abstract_Present
:= True;
532 Abstract_Loc
:= Token_Ptr
;
533 Scan
; -- past ABSTRACT
536 if Token
= Tok_Limited
then
537 Scan
; -- past LIMITED
539 -- TAGGED LIMITED PRIVATE case
541 if Token
= Tok_Private
then
543 New_Node
(N_Private_Type_Declaration
, Type_Loc
);
544 Set_Tagged_Present
(Decl_Node
, True);
545 Set_Limited_Present
(Decl_Node
, True);
546 Scan
; -- past PRIVATE
548 -- TAGGED LIMITED RECORD
551 Typedef_Node
:= P_Record_Definition
;
552 Set_Tagged_Present
(Typedef_Node
, True);
553 Set_Limited_Present
(Typedef_Node
, True);
556 Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
557 Set_Comes_From_Source
(End_Labl
, False);
559 Set_End_Label
(Typedef_Node
, End_Labl
);
565 if Token
= Tok_Private
then
567 New_Node
(N_Private_Type_Declaration
, Type_Loc
);
568 Set_Tagged_Present
(Decl_Node
, True);
569 Scan
; -- past PRIVATE
574 Typedef_Node
:= P_Record_Definition
;
575 Set_Tagged_Present
(Typedef_Node
, True);
578 Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
579 Set_Comes_From_Source
(End_Labl
, False);
581 Set_End_Label
(Typedef_Node
, End_Labl
);
588 Scan
; -- past LIMITED
591 if Token
= Tok_Tagged
then
592 Error_Msg_SC
-- CODEFIX
593 ("TAGGED must come before LIMITED");
596 elsif Token
= Tok_Abstract
then
597 Error_Msg_SC
-- CODEFIX
598 ("ABSTRACT must come before LIMITED");
599 Scan
; -- past ABSTRACT
606 -- LIMITED RECORD or LIMITED NULL RECORD
608 if Token
in Tok_Record | Tok_Null
then
609 if Ada_Version
= Ada_83
then
611 ("(Ada 83) limited record declaration not allowed!");
613 -- In Ada 2005, "abstract limited" can appear before "new",
614 -- but it cannot be part of an untagged record declaration.
616 elsif Abstract_Present
617 and then Prev_Token
/= Tok_Tagged
619 Error_Msg_SP
("TAGGED expected");
622 Typedef_Node
:= P_Record_Definition
;
623 Set_Limited_Present
(Typedef_Node
, True);
624 End_Labl
:= Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
625 Set_Comes_From_Source
(End_Labl
, False);
627 Set_End_Label
(Typedef_Node
, End_Labl
);
629 -- Ada 2005 (AI-251): LIMITED INTERFACE
631 -- If we are compiling in Ada 83 or Ada 95 mode, "interface"
632 -- is not a reserved word but we force its analysis to
633 -- generate the corresponding usage error.
635 elsif Token
= Tok_Interface
636 or else (Token
= Tok_Identifier
637 and then Chars
(Token_Node
) = Name_Interface
)
640 P_Interface_Type_Definition
(Abstract_Present
);
641 Abstract_Present
:= True;
642 Set_Limited_Present
(Typedef_Node
);
644 if Nkind
(Typedef_Node
) = N_Derived_Type_Definition
then
645 Is_Derived_Iface
:= True;
648 -- Ada 2005 (AI-419): LIMITED NEW
650 elsif Token
= Tok_New
then
651 Error_Msg_Ada_2005_Extension
("LIMITED in derived type");
653 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
654 Set_Limited_Present
(Typedef_Node
);
656 if Nkind
(Typedef_Node
) = N_Derived_Type_Definition
657 and then Present
(Record_Extension_Part
(Typedef_Node
))
660 Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
661 Set_Comes_From_Source
(End_Labl
, False);
664 (Record_Extension_Part
(Typedef_Node
), End_Labl
);
667 -- LIMITED PRIVATE is the only remaining possibility here
670 Decl_Node
:= New_Node
(N_Private_Type_Declaration
, Type_Loc
);
671 Set_Limited_Present
(Decl_Node
, True);
672 T_Private
; -- past PRIVATE (or complain if not there)
677 -- Here we have an identifier after the IS, which is certainly
678 -- wrong and which might be one of several different mistakes.
680 when Tok_Identifier
=>
682 -- First case, if identifier is on same line, then probably we
683 -- have something like "type X is Integer .." and the best
684 -- diagnosis is a missing NEW. Note: the missing new message
685 -- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl.
687 if not Token_Is_At_Start_Of_Line
then
688 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
690 -- If the identifier is at the start of the line, and is in the
691 -- same column as the type declaration itself then we consider
692 -- that we had a missing type definition on the previous line
694 elsif Start_Column
<= Type_Start_Col
then
695 Error_Msg_AP
("type definition expected");
696 Typedef_Node
:= Error
;
698 -- If the identifier is at the start of the line, and is in
699 -- a column to the right of the type declaration line, then we
700 -- may have something like:
705 -- and the best diagnosis is a missing record keyword
708 Typedef_Node
:= P_Record_Definition
;
713 -- Ada 2005 (AI-251): INTERFACE
715 when Tok_Interface
=>
716 Typedef_Node
:= P_Interface_Type_Definition
(Abstract_Present
);
717 Abstract_Present
:= True;
721 Decl_Node
:= New_Node
(N_Private_Type_Declaration
, Type_Loc
);
722 Scan
; -- past PRIVATE
724 -- Check error cases of private [abstract] tagged
726 if Token
= Tok_Abstract
then
727 Error_Msg_SC
("`ABSTRACT TAGGED` must come before PRIVATE");
728 Scan
; -- past ABSTRACT
730 if Token
= Tok_Tagged
then
734 elsif Token
= Tok_Tagged
then
735 Error_Msg_SC
("TAGGED must come before PRIVATE");
741 -- Ada 2005 (AI-345): Protected, synchronized or task interface
742 -- or Ada 2005 (AI-443): Synchronized private extension.
749 Saved_Token
: constant Token_Type
:= Token
;
752 Scan
; -- past TASK, PROTECTED or SYNCHRONIZED
754 -- Synchronized private extension
756 if Token
= Tok_New
then
757 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
759 if Saved_Token
= Tok_Synchronized
then
760 if Nkind
(Typedef_Node
) =
761 N_Derived_Type_Definition
764 ("SYNCHRONIZED not allowed for record extension",
767 Set_Synchronized_Present
(Typedef_Node
);
771 Error_Msg_SC
("invalid kind of private extension");
777 if Token
/= Tok_Interface
then
778 Error_Msg_SC
("NEW or INTERFACE expected");
782 P_Interface_Type_Definition
(Abstract_Present
);
783 Abstract_Present
:= True;
787 Set_Task_Present
(Typedef_Node
);
789 when Tok_Protected
=>
790 Set_Protected_Present
(Typedef_Node
);
792 when Tok_Synchronized
=>
793 Set_Synchronized_Present
(Typedef_Node
);
796 pragma Assert
(False);
804 -- Anything else is an error
807 if Bad_Spelling_Of
(Tok_Access
)
809 Bad_Spelling_Of
(Tok_Array
)
811 Bad_Spelling_Of
(Tok_Delta
)
813 Bad_Spelling_Of
(Tok_Digits
)
815 Bad_Spelling_Of
(Tok_Limited
)
817 Bad_Spelling_Of
(Tok_Private
)
819 Bad_Spelling_Of
(Tok_Range
)
821 Bad_Spelling_Of
(Tok_Record
)
823 Bad_Spelling_Of
(Tok_Tagged
)
828 Error_Msg_AP
("type definition expected");
834 -- For the private type declaration case, the private type declaration
835 -- node has been built, with the Tagged_Present and Limited_Present
836 -- flags set as needed, and Typedef_Node is left set to Empty.
838 if No
(Typedef_Node
) then
839 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
840 Set_Abstract_Present
(Decl_Node
, Abstract_Present
);
842 -- For a private extension declaration, Typedef_Node contains the
843 -- N_Private_Extension_Declaration node, which we now complete. Note
844 -- that the private extension declaration, unlike a full type
845 -- declaration, does permit unknown discriminants.
847 elsif Nkind
(Typedef_Node
) = N_Private_Extension_Declaration
then
848 Decl_Node
:= Typedef_Node
;
849 Set_Sloc
(Decl_Node
, Type_Loc
);
850 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
851 Set_Abstract_Present
(Typedef_Node
, Abstract_Present
);
853 -- In the full type declaration case, Typedef_Node has the type
854 -- definition and here is where we build the full type declaration
855 -- node. This is also where we check for improper use of an unknown
856 -- discriminant part (not allowed for full type declaration).
859 if Nkind
(Typedef_Node
) = N_Record_Definition
860 or else (Nkind
(Typedef_Node
) = N_Derived_Type_Definition
861 and then Present
(Record_Extension_Part
(Typedef_Node
)))
862 or else Is_Derived_Iface
864 Set_Abstract_Present
(Typedef_Node
, Abstract_Present
);
866 elsif Abstract_Present
then
867 Error_Msg
("ABSTRACT not allowed here, ignored", Abstract_Loc
);
870 Decl_Node
:= New_Node
(N_Full_Type_Declaration
, Type_Loc
);
871 Set_Type_Definition
(Decl_Node
, Typedef_Node
);
875 ("full type declaration cannot have unknown discriminants",
880 -- Remaining processing is common for all three cases
882 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
883 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
884 P_Aspect_Specifications
(Decl_Node
, Semicolon
=> True);
886 end P_Type_Declaration
;
888 ----------------------------------
889 -- 3.2.1 Full Type Declaration --
890 ----------------------------------
892 -- Parsed by P_Type_Declaration (3.2.1)
894 ----------------------------
895 -- 3.2.1 Type Definition --
896 ----------------------------
898 -- Parsed by P_Type_Declaration (3.2.1)
900 --------------------------------
901 -- 3.2.2 Subtype Declaration --
902 --------------------------------
904 -- SUBTYPE_DECLARATION ::=
905 -- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION
906 -- [ASPECT_SPECIFICATIONS];
908 -- The caller has checked that the initial token is SUBTYPE
910 -- Error recovery: can raise Error_Resync
912 function P_Subtype_Declaration
return Node_Id
is
914 Not_Null_Present
: Boolean := False;
917 Decl_Node
:= New_Node
(N_Subtype_Declaration
, Token_Ptr
);
918 Scan
; -- past SUBTYPE
919 Set_Defining_Identifier
(Decl_Node
, P_Defining_Identifier
(C_Is
));
922 if Token
= Tok_New
then
923 Error_Msg_SC
-- CODEFIX
924 ("NEW ignored (only allowed in type declaration)");
928 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
929 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
931 Set_Subtype_Indication
932 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
933 P_Aspect_Specifications
(Decl_Node
, Semicolon
=> True);
935 end P_Subtype_Declaration
;
937 -------------------------------
938 -- 3.2.2 Subtype Indication --
939 -------------------------------
941 -- SUBTYPE_INDICATION ::=
942 -- [not null] SUBTYPE_MARK [CONSTRAINT]
944 -- Error recovery: can raise Error_Resync
946 function P_Null_Exclusion
947 (Allow_Anonymous_In_95
: Boolean := False) return Boolean
949 Not_Loc
: constant Source_Ptr
:= Token_Ptr
;
950 -- Source position of "not", if present
953 if Token
/= Tok_Not
then
959 if Token
= Tok_Null
then
962 -- Ada 2005 (AI-441, AI-447): null_exclusion is illegal in Ada 95,
963 -- except in the case of anonymous access types.
965 -- Allow_Anonymous_In_95 will be True if we're parsing a formal
966 -- parameter or discriminant, which are the only places where
967 -- anonymous access types occur in Ada 95. "Formal : not null
968 -- access ..." is legal in Ada 95, whereas "Formal : not null
969 -- Named_Access_Type" is not.
971 if Ada_Version
>= Ada_2005
972 or else (Ada_Version
>= Ada_95
973 and then Allow_Anonymous_In_95
974 and then Token
= Tok_Access
)
980 ("`NOT NULL` access type is an Ada 2005 extension", Not_Loc
);
982 ("\unit should be compiled with -gnat05 switch", Not_Loc
);
986 Error_Msg_SP
("NULL expected");
989 if Token
= Tok_New
then
990 Error_Msg
("`NOT NULL` comes after NEW, not before", Not_Loc
);
995 end P_Null_Exclusion
;
997 function P_Subtype_Indication
998 (Not_Null_Present
: Boolean := False) return Node_Id
1000 Type_Node
: Node_Id
;
1003 if Token
in Tok_Identifier | Tok_Operator_Symbol
then
1004 Type_Node
:= P_Subtype_Mark
;
1005 return P_Subtype_Indication
(Type_Node
, Not_Null_Present
);
1008 -- Check for error of using record definition and treat it nicely,
1009 -- otherwise things are really messed up, so resynchronize.
1011 if Token
= Tok_Record
then
1012 Error_Msg_SC
("anonymous record definition not permitted");
1013 Discard_Junk_Node
(P_Record_Definition
);
1017 Error_Msg_AP
("subtype indication expected");
1021 end P_Subtype_Indication
;
1023 -- The following function is identical except that it is called with
1024 -- the subtype mark already scanned out, and it scans out the constraint
1026 -- Error recovery: can raise Error_Resync
1028 function P_Subtype_Indication
1029 (Subtype_Mark
: Node_Id
;
1030 Not_Null_Present
: Boolean := False) return Node_Id
1032 Indic_Node
: Node_Id
;
1033 Constr_Node
: Node_Id
;
1036 Constr_Node
:= P_Constraint_Opt
;
1040 (Nkind
(Constr_Node
) = N_Range_Constraint
1041 and then Nkind
(Range_Expression
(Constr_Node
)) = N_Error
)
1043 return Subtype_Mark
;
1045 if Not_Null_Present
then
1046 Error_Msg_SP
("`NOT NULL` not allowed if constraint given");
1049 Indic_Node
:= New_Node
(N_Subtype_Indication
, Sloc
(Subtype_Mark
));
1050 Set_Subtype_Mark
(Indic_Node
, Check_Subtype_Mark
(Subtype_Mark
));
1051 Set_Constraint
(Indic_Node
, Constr_Node
);
1054 end P_Subtype_Indication
;
1056 -------------------------
1057 -- 3.2.2 Subtype Mark --
1058 -------------------------
1060 -- SUBTYPE_MARK ::= subtype_NAME;
1062 -- Note: The subtype mark which appears after an IN or NOT IN
1063 -- operator is parsed by P_Range_Or_Subtype_Mark (3.5)
1065 -- Error recovery: cannot raise Error_Resync
1067 function P_Subtype_Mark
return Node_Id
is
1069 return P_Subtype_Mark_Resync
;
1071 when Error_Resync
=>
1075 -- This routine differs from P_Subtype_Mark in that it insists that an
1076 -- identifier be present, and if it is not, it raises Error_Resync.
1078 -- Error recovery: can raise Error_Resync
1080 function P_Subtype_Mark_Resync
return Node_Id
is
1081 Type_Node
: Node_Id
;
1084 if Token
= Tok_Access
then
1085 Error_Msg_SC
("anonymous access type definition not allowed here");
1086 Scan
; -- past ACCESS
1089 if Token
= Tok_Array
then
1090 Error_Msg_SC
("anonymous array definition not allowed here");
1091 Discard_Junk_Node
(P_Array_Type_Definition
);
1095 Type_Node
:= P_Qualified_Simple_Name_Resync
;
1097 -- Check for a subtype mark attribute. The only valid possibilities
1098 -- are 'CLASS and 'BASE. Anything else is a definite error. We may
1099 -- as well catch it here.
1101 if Token
= Tok_Apostrophe
then
1102 return P_Subtype_Mark_Attribute
(Type_Node
);
1107 end P_Subtype_Mark_Resync
;
1109 -- The following function is called to scan out a subtype mark attribute.
1110 -- The caller has already scanned out the subtype mark, which is passed in
1111 -- as the argument, and has checked that the current token is apostrophe.
1113 -- Only a special subclass of attributes, called type attributes
1114 -- (see Snames package) are allowed in this syntactic position.
1116 -- Note: if the apostrophe is followed by other than an identifier, then
1117 -- the input expression is returned unchanged, and the scan pointer is
1118 -- left pointing to the apostrophe.
1120 -- Error recovery: can raise Error_Resync
1122 function P_Subtype_Mark_Attribute
(Type_Node
: Node_Id
) return Node_Id
is
1123 Attr_Node
: Node_Id
:= Empty
;
1124 Scan_State
: Saved_Scan_State
;
1128 Prefix
:= Check_Subtype_Mark
(Type_Node
);
1130 if Prefix
= Error
then
1134 -- Loop through attributes appearing (more than one can appear as for
1135 -- for example in X'Base'Class). We are at an apostrophe on entry to
1136 -- this loop, and it runs once for each attribute parsed, with
1137 -- Prefix being the current possible prefix if it is an attribute.
1140 Save_Scan_State
(Scan_State
); -- at Apostrophe
1141 Scan
; -- past apostrophe
1143 if Token
/= Tok_Identifier
then
1144 Restore_Scan_State
(Scan_State
); -- to apostrophe
1145 return Prefix
; -- no attribute after all
1147 elsif not Is_Type_Attribute_Name
(Token_Name
) then
1149 ("attribute & may not be used in a subtype mark", Token_Node
);
1154 Make_Attribute_Reference
(Prev_Token_Ptr
,
1156 Attribute_Name
=> Token_Name
);
1157 Scan
; -- past type attribute identifier
1160 exit when Token
/= Tok_Apostrophe
;
1161 Prefix
:= Attr_Node
;
1164 -- Fall through here after scanning type attribute
1167 end P_Subtype_Mark_Attribute
;
1169 -----------------------
1170 -- 3.2.2 Constraint --
1171 -----------------------
1173 -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
1175 -- SCALAR_CONSTRAINT ::=
1176 -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
1178 -- COMPOSITE_CONSTRAINT ::=
1179 -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
1181 -- If no constraint is present, this function returns Empty
1183 -- Error recovery: can raise Error_Resync
1185 function P_Constraint_Opt
return Node_Id
is
1187 if Token
= Tok_Range
or else Bad_Spelling_Of
(Tok_Range
) then
1188 return P_Range_Constraint
;
1190 elsif Token
= Tok_Digits
or else Bad_Spelling_Of
(Tok_Digits
) then
1191 return P_Digits_Constraint
;
1193 elsif Token
= Tok_Delta
or else Bad_Spelling_Of
(Tok_Delta
) then
1194 return P_Delta_Constraint
;
1196 elsif Token
= Tok_Left_Paren
then
1197 return P_Index_Or_Discriminant_Constraint
;
1199 -- One more possibility is e.g. 1 .. 10 (i.e. missing RANGE keyword)
1201 elsif Token
= Tok_Identifier
or else
1202 Token
= Tok_Integer_Literal
or else
1203 Token
= Tok_Real_Literal
1206 Scan_State
: Saved_Scan_State
;
1209 Save_Scan_State
(Scan_State
); -- at identifier or literal
1210 Scan
; -- past identifier or literal
1212 if Token
= Tok_Dot_Dot
then
1213 Restore_Scan_State
(Scan_State
);
1214 Error_Msg_BC
("missing RANGE keyword");
1215 return P_Range_Constraint
;
1217 Restore_Scan_State
(Scan_State
);
1222 -- Nothing worked, no constraint there
1227 end P_Constraint_Opt
;
1229 ------------------------------
1230 -- 3.2.2 Scalar Constraint --
1231 ------------------------------
1233 -- Parsed by P_Constraint_Opt (3.2.2)
1235 ---------------------------------
1236 -- 3.2.2 Composite Constraint --
1237 ---------------------------------
1239 -- Parsed by P_Constraint_Opt (3.2.2)
1241 --------------------------------------------------------
1242 -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) --
1243 --------------------------------------------------------
1245 -- This routine scans out a declaration starting with an identifier:
1247 -- OBJECT_DECLARATION ::=
1248 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1249 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION]
1250 -- [ASPECT_SPECIFICATIONS];
1251 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1252 -- ACCESS_DEFINITION [:= EXPRESSION]
1253 -- [ASPECT_SPECIFICATIONS];
1254 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1255 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]
1256 -- [ASPECT_SPECIFICATIONS];
1258 -- NUMBER_DECLARATION ::=
1259 -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
1261 -- OBJECT_RENAMING_DECLARATION ::=
1262 -- DEFINING_IDENTIFIER :
1263 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME
1264 -- [ASPECT_SPECIFICATIONS];
1265 -- | DEFINING_IDENTIFIER :
1266 -- ACCESS_DEFINITION renames object_NAME
1267 -- [ASPECT_SPECIFICATIONS];
1269 -- EXCEPTION_RENAMING_DECLARATION ::=
1270 -- DEFINING_IDENTIFIER : exception renames exception_NAME
1271 -- [ASPECT_SPECIFICATIONS];
1273 -- EXCEPTION_DECLARATION ::=
1274 -- DEFINING_IDENTIFIER_LIST : exception
1275 -- [ASPECT_SPECIFICATIONS];
1277 -- Note that the ALIASED indication in an object declaration is
1278 -- marked by a flag in the parent node.
1280 -- The caller has checked that the initial token is an identifier
1282 -- The value returned is a list of declarations, one for each identifier
1283 -- in the list (as described in Sinfo, we always split up multiple
1284 -- declarations into the equivalent sequence of single declarations
1285 -- using the More_Ids and Prev_Ids flags to preserve the source).
1287 -- If the identifier turns out to be a probable statement rather than
1288 -- an identifier, then the scan is left pointing to the identifier and
1289 -- No_List is returned.
1291 -- Error recovery: can raise Error_Resync
1293 procedure P_Identifier_Declarations
1297 In_Statements
: Boolean)
1300 Decl_Node
: Node_Id
;
1301 Type_Node
: Node_Id
;
1302 Ident_Sloc
: Source_Ptr
;
1303 Scan_State
: Saved_Scan_State
;
1304 List_OK
: Boolean := True;
1306 Init_Expr
: Node_Id
;
1307 Init_Loc
: Source_Ptr
;
1308 Con_Loc
: Source_Ptr
;
1309 Not_Null_Present
: Boolean := False;
1311 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
1312 -- Used to save identifiers in the identifier list. The upper bound
1313 -- of 4096 is expected to be infinite in practice, and we do not even
1314 -- bother to check if this upper bound is exceeded.
1316 Num_Idents
: Nat
:= 1;
1317 -- Number of identifiers stored in Idents
1319 function Identifier_Starts_Statement
return Boolean;
1320 -- Called with Token being an identifier that might start a declaration
1321 -- or a statement. True if we are parsing declarations in a sequence of
1322 -- statements, and this identifier is the start of a statement. If this
1323 -- is true, we quit parsing declarations, and return Done = True so the
1324 -- caller will switch to parsing statements.
1327 -- This procedure is called in renames cases to make sure that we do
1328 -- not have more than one identifier. If we do have more than one
1329 -- then an error message is issued (and the declaration is split into
1330 -- multiple declarations)
1332 function Token_Is_Renames
return Boolean;
1333 -- Checks if current token is RENAMES, and if so, scans past it and
1334 -- returns True, otherwise returns False. Includes checking for some
1335 -- common error cases.
1337 ---------------------------------
1338 -- Identifier_Starts_Statement --
1339 ---------------------------------
1341 function Identifier_Starts_Statement
return Boolean is
1342 pragma Assert
(Token
= Tok_Identifier
);
1343 Scan_State
: Saved_Scan_State
;
1344 Result
: Boolean := False;
1346 if not In_Statements
then
1350 Save_Scan_State
(Scan_State
);
1354 when Tok_Comma
=> -- "X, ..." is a declaration
1358 -- "X : ..." is usually a declaration, but "X : begin..." is
1359 -- not. We return true for things like "X : Y : begin...",
1360 -- which is a syntax error, because that gives better error
1361 -- recovery for some ACATS.
1365 if Token
in Token_Class_Labeled_Stmt
then
1368 elsif Token
= Tok_Identifier
then
1370 if Token
= Tok_Colon
then
1372 if Token
in Token_Class_Labeled_Stmt
then
1382 Restore_Scan_State
(Scan_State
);
1384 end Identifier_Starts_Statement
;
1390 procedure No_List
is
1392 if Num_Idents
> 1 then
1394 ("identifier list not allowed for RENAMES",
1401 ----------------------
1402 -- Token_Is_Renames --
1403 ----------------------
1405 function Token_Is_Renames
return Boolean is
1406 At_Colon
: Saved_Scan_State
;
1409 if Token
= Tok_Colon
then
1410 Save_Scan_State
(At_Colon
);
1412 Check_Misspelling_Of
(Tok_Renames
);
1414 if Token
= Tok_Renames
then
1415 Error_Msg_SP
-- CODEFIX
1416 ("|extra "":"" ignored");
1417 Scan
; -- past RENAMES
1420 Restore_Scan_State
(At_Colon
);
1425 Check_Misspelling_Of
(Tok_Renames
);
1427 if Token
= Tok_Renames
then
1428 Scan
; -- past RENAMES
1434 end Token_Is_Renames
;
1436 -- Start of processing for P_Identifier_Declarations
1439 if Identifier_Starts_Statement
then
1444 Ident_Sloc
:= Token_Ptr
;
1445 Save_Scan_State
(Scan_State
); -- at first identifier
1446 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
1448 -- If we have a colon after the identifier, then we can assume that
1449 -- this is in fact a valid identifier declaration and can steam ahead.
1451 if Token
= Tok_Colon
then
1454 -- If we have a comma, then scan out the list of identifiers
1456 elsif Token
= Tok_Comma
then
1457 while Comma_Present
loop
1458 Num_Idents
:= Num_Idents
+ 1;
1459 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
1462 Save_Scan_State
(Scan_State
); -- at colon
1465 -- If we have an identifier followed by := then we assume that what is
1466 -- really meant is an assignment statement. The assignment statement
1467 -- is scanned out and added to the list of declarations. An exception
1468 -- occurs if the := is followed by the keyword constant, in which case
1469 -- we assume it was meant to be a colon.
1471 elsif Token
= Tok_Colon_Equal
then
1474 if Token
= Tok_Constant
then
1475 Error_Msg_SP
("colon expected");
1478 Restore_Scan_State
(Scan_State
);
1480 -- Reset Token_Node, because it already got changed from an
1481 -- Identifier to a Defining_Identifier, and we don't want that
1485 Make_Identifier
(Sloc
(Token_Node
), Chars
(Token_Node
));
1487 -- And now scan out one or more statements
1489 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
1493 -- If we have an IS keyword, then assume the TYPE keyword was missing
1495 elsif Token
= Tok_Is
then
1496 Restore_Scan_State
(Scan_State
);
1497 Append_To
(Decls
, P_Type_Declaration
);
1501 -- AI12-0275: Object renaming declaration without subtype_mark or
1502 -- access_definition
1504 elsif Token
= Tok_Renames
then
1505 Error_Msg_Ada_2022_Feature
1506 ("object renaming without subtype", Token_Ptr
);
1508 Scan
; -- past renames
1511 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1512 Set_Name
(Decl_Node
, P_Name
);
1513 Set_Defining_Identifier
(Decl_Node
, Idents
(1));
1515 P_Aspect_Specifications
(Decl_Node
, Semicolon
=> False);
1519 Append
(Decl_Node
, Decls
);
1524 -- Otherwise we have an error situation
1527 Restore_Scan_State
(Scan_State
);
1529 -- First case is possible misuse of PROTECTED in Ada 83 mode. If
1530 -- so, fix the keyword and return to scan the protected declaration.
1532 if Token_Name
= Name_Protected
then
1533 Check_95_Keyword
(Tok_Protected
, Tok_Identifier
);
1534 Check_95_Keyword
(Tok_Protected
, Tok_Type
);
1535 Check_95_Keyword
(Tok_Protected
, Tok_Body
);
1537 if Token
= Tok_Protected
then
1542 -- Check misspelling possibilities. If so, correct the misspelling
1543 -- and return to scan out the resulting declaration.
1545 elsif Bad_Spelling_Of
(Tok_Function
)
1546 or else Bad_Spelling_Of
(Tok_Procedure
)
1547 or else Bad_Spelling_Of
(Tok_Package
)
1548 or else Bad_Spelling_Of
(Tok_Pragma
)
1549 or else Bad_Spelling_Of
(Tok_Protected
)
1550 or else Bad_Spelling_Of
(Tok_Generic
)
1551 or else Bad_Spelling_Of
(Tok_Subtype
)
1552 or else Bad_Spelling_Of
(Tok_Type
)
1553 or else Bad_Spelling_Of
(Tok_Task
)
1554 or else Bad_Spelling_Of
(Tok_Use
)
1555 or else Bad_Spelling_Of
(Tok_For
)
1560 -- Otherwise we definitely have an ordinary identifier with a junk
1563 elsif In_Statements
then
1568 -- If in -gnatd.2 mode, try for statements
1570 if Debug_Flag_Dot_2
then
1571 Restore_Scan_State
(Scan_State
);
1573 -- Reset Token_Node, because it already got changed from an
1574 -- Identifier to a Defining_Identifier, and we don't want that
1578 Make_Identifier
(Sloc
(Token_Node
), Chars
(Token_Node
));
1580 -- And now scan out one or more statements
1582 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
1585 -- Normal case, just complain and skip to semicolon
1588 Set_Declaration_Expected
;
1589 Resync_Past_Semicolon
;
1596 -- Come here with an identifier list and colon scanned out. We now
1597 -- build the nodes for the declarative items. One node is built for
1598 -- each identifier in the list, with the type information being
1599 -- repeated by rescanning the appropriate section of source.
1601 -- First an error check, if we have two identifiers in a row, a likely
1602 -- possibility is that the first of the identifiers is an incorrectly
1605 if Token
= Tok_Identifier
then
1607 SS
: Saved_Scan_State
;
1611 Save_Scan_State
(SS
);
1612 Scan
; -- past initial identifier
1613 I2
:= (Token
= Tok_Identifier
);
1614 Restore_Scan_State
(SS
);
1618 (Bad_Spelling_Of
(Tok_Access
) or else
1619 Bad_Spelling_Of
(Tok_Aliased
) or else
1620 Bad_Spelling_Of
(Tok_Constant
))
1627 -- Loop through identifiers
1632 -- Check for some cases of misused Ada 95 keywords
1634 if Token_Name
= Name_Aliased
then
1635 Check_95_Keyword
(Tok_Aliased
, Tok_Array
);
1636 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
1637 Check_95_Keyword
(Tok_Aliased
, Tok_Constant
);
1642 if Token
= Tok_Constant
then
1643 Con_Loc
:= Token_Ptr
;
1644 Scan
; -- past CONSTANT
1646 -- Number declaration, initialization required
1648 Init_Expr
:= Init_Expr_Opt
;
1650 if Present
(Init_Expr
) then
1651 if Not_Null_Present
then
1653 ("`NOT NULL` not allowed in numeric expression");
1656 Decl_Node
:= New_Node
(N_Number_Declaration
, Ident_Sloc
);
1657 Set_Expression
(Decl_Node
, Init_Expr
);
1659 -- Constant object declaration
1662 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1663 Set_Constant_Present
(Decl_Node
, True);
1665 if Token_Name
= Name_Aliased
then
1666 Check_95_Keyword
(Tok_Aliased
, Tok_Array
);
1667 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
1670 if Token
= Tok_Aliased
then
1671 Error_Msg_SC
-- CODEFIX
1672 ("ALIASED should be before CONSTANT");
1673 Scan
; -- past ALIASED
1674 Set_Aliased_Present
(Decl_Node
, True);
1677 if Token
= Tok_Array
then
1678 Set_Object_Definition
1679 (Decl_Node
, P_Array_Type_Definition
);
1682 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1683 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1685 if Token
= Tok_Access
then
1686 Error_Msg_Ada_2005_Extension
1687 ("generalized use of anonymous access types");
1689 Set_Object_Definition
1690 (Decl_Node
, P_Access_Definition
(Not_Null_Present
));
1692 Set_Object_Definition
1693 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
1697 if Token
= Tok_Renames
then
1699 ("CONSTANT not permitted in renaming declaration",
1701 Scan
; -- Past renames
1702 Discard_Junk_Node
(P_Name
);
1708 elsif Token
= Tok_Exception
then
1709 Scan
; -- past EXCEPTION
1711 if Token_Is_Renames
then
1714 New_Node
(N_Exception_Renaming_Declaration
, Ident_Sloc
);
1715 Set_Name
(Decl_Node
, P_Qualified_Simple_Name_Resync
);
1718 Decl_Node
:= New_Node
(N_Exception_Declaration
, Prev_Token_Ptr
);
1721 -- Aliased case (note that an object definition is required)
1723 elsif Token
= Tok_Aliased
then
1724 Scan
; -- past ALIASED
1725 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1726 Set_Aliased_Present
(Decl_Node
, True);
1728 if Token
= Tok_Constant
then
1729 Scan
; -- past CONSTANT
1730 Set_Constant_Present
(Decl_Node
, True);
1733 if Token
= Tok_Array
then
1734 Set_Object_Definition
1735 (Decl_Node
, P_Array_Type_Definition
);
1738 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1739 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1741 -- Access definition (AI-406) or subtype indication
1743 if Token
= Tok_Access
then
1744 Error_Msg_Ada_2005_Extension
1745 ("generalized use of anonymous access types");
1747 Set_Object_Definition
1748 (Decl_Node
, P_Access_Definition
(Not_Null_Present
));
1750 Set_Object_Definition
1751 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
1757 elsif Token
= Tok_Array
then
1758 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1759 Set_Object_Definition
(Decl_Node
, P_Array_Type_Definition
);
1761 -- Ada 2005 (AI-254, AI-406)
1763 elsif Token
= Tok_Not
then
1765 -- OBJECT_DECLARATION ::=
1766 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1767 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION]
1768 -- [ASPECT_SPECIFICATIONS];
1769 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1770 -- ACCESS_DEFINITION [:= EXPRESSION]
1771 -- [ASPECT_SPECIFICATIONS];
1773 -- OBJECT_RENAMING_DECLARATION ::=
1774 -- DEFINING_IDENTIFIER :
1775 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME
1776 -- [ASPECT_SPECIFICATIONS];
1777 -- | DEFINING_IDENTIFIER :
1778 -- ACCESS_DEFINITION renames object_NAME
1779 -- [ASPECT_SPECIFICATIONS];
1781 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/423)
1783 if Token
= Tok_Access
then
1784 Error_Msg_Ada_2005_Extension
1785 ("generalized use of anonymous access types");
1787 Acc_Node
:= P_Access_Definition
(Not_Null_Present
);
1789 if Token
/= Tok_Renames
then
1790 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1791 Set_Object_Definition
(Decl_Node
, Acc_Node
);
1794 Scan
; -- past renames
1797 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1798 Set_Access_Definition
(Decl_Node
, Acc_Node
);
1799 Set_Name
(Decl_Node
, P_Name
);
1803 Type_Node
:= P_Subtype_Mark
;
1805 -- Object renaming declaration
1807 if Token_Is_Renames
then
1808 if Ada_Version
< Ada_2005
then
1810 ("`NOT NULL` not allowed in object renaming");
1813 -- Ada 2005 (AI-423): Object renaming declaration with
1814 -- a null exclusion.
1819 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1820 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1821 Set_Subtype_Mark
(Decl_Node
, Type_Node
);
1822 Set_Name
(Decl_Node
, P_Name
);
1825 -- Object declaration
1828 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1829 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1830 Set_Object_Definition
1832 P_Subtype_Indication
(Type_Node
, Not_Null_Present
));
1834 -- RENAMES at this point means that we had the combination
1835 -- of a constraint on the Type_Node and renames, which is
1838 if Token_Is_Renames
then
1840 ("constraint not allowed in object renaming "
1842 Constraint
(Object_Definition
(Decl_Node
)));
1848 -- Ada 2005 (AI-230): Access Definition case
1850 elsif Token
= Tok_Access
then
1851 Error_Msg_Ada_2005_Extension
1852 ("generalized use of anonymous access types");
1854 Acc_Node
:= P_Access_Definition
(Null_Exclusion_Present
=> False);
1856 -- Object declaration with access definition, or renaming
1858 if Token
/= Tok_Renames
then
1859 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1860 Set_Object_Definition
(Decl_Node
, Acc_Node
);
1863 Scan
; -- past renames
1866 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1867 Set_Access_Definition
(Decl_Node
, Acc_Node
);
1868 Set_Name
(Decl_Node
, P_Name
);
1871 -- Subtype indication case
1874 Type_Node
:= P_Subtype_Mark
;
1876 -- Object renaming declaration
1878 if Token_Is_Renames
then
1881 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1882 Set_Subtype_Mark
(Decl_Node
, Type_Node
);
1883 Set_Name
(Decl_Node
, P_Name
);
1885 -- Object declaration
1888 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1889 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1890 Set_Object_Definition
1892 P_Subtype_Indication
(Type_Node
, Not_Null_Present
));
1894 -- RENAMES at this point means that we had the combination of
1895 -- a constraint on the Type_Node and renames, which is illegal
1897 if Token_Is_Renames
then
1899 ("constraint not allowed in object renaming declaration",
1900 Constraint
(Object_Definition
(Decl_Node
)));
1906 -- Scan out initialization, allowed only for object declaration
1908 Init_Loc
:= Token_Ptr
;
1909 Init_Expr
:= Init_Expr_Opt
;
1911 if Present
(Init_Expr
) then
1912 if Nkind
(Decl_Node
) = N_Object_Declaration
then
1913 Set_Expression
(Decl_Node
, Init_Expr
);
1914 Set_Has_Init_Expression
(Decl_Node
);
1916 Error_Msg
("initialization not allowed here", Init_Loc
);
1920 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
1921 P_Aspect_Specifications
(Decl_Node
, Semicolon
=> False);
1923 -- Allow initialization expression to follow aspects (note that in
1924 -- this case P_Aspect_Specifications already issued an error msg).
1926 if Token
= Tok_Colon_Equal
then
1927 if Is_Non_Empty_List
(Aspect_Specifications
(Decl_Node
)) then
1929 ("aspect specifications must come after initialization "
1931 Sloc
(First
(Aspect_Specifications
(Decl_Node
))));
1934 -- In any case, the assignment symbol doesn't belong.
1936 Error_Msg
("misplaced assignment symbol", Scan_Ptr
);
1939 Set_Expression
(Decl_Node
, Init_Expr_Opt
);
1940 Set_Has_Init_Expression
(Decl_Node
);
1943 -- Now scan out the semicolon, which we deferred above
1948 if Ident
< Num_Idents
then
1949 Set_More_Ids
(Decl_Node
, True);
1953 Set_Prev_Ids
(Decl_Node
, True);
1957 Append
(Decl_Node
, Decls
);
1958 exit Ident_Loop
when Ident
= Num_Idents
;
1959 Restore_Scan_State
(Scan_State
);
1962 end loop Ident_Loop
;
1965 end P_Identifier_Declarations
;
1967 -------------------------------
1968 -- 3.3.1 Object Declaration --
1969 -------------------------------
1971 -- OBJECT DECLARATION ::=
1972 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1973 -- SUBTYPE_INDICATION [:= EXPRESSION];
1974 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1975 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1976 -- | SINGLE_TASK_DECLARATION
1977 -- | SINGLE_PROTECTED_DECLARATION
1979 -- Cases starting with TASK are parsed by P_Task (9.1)
1980 -- Cases starting with PROTECTED are parsed by P_Protected (9.4)
1981 -- All other cases are parsed by P_Identifier_Declarations (3.3)
1983 -------------------------------------
1984 -- 3.3.1 Defining Identifier List --
1985 -------------------------------------
1987 -- DEFINING_IDENTIFIER_LIST ::=
1988 -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
1990 -- Always parsed by the construct in which it appears. See special
1991 -- section on "Handling of Defining Identifier Lists" in this unit.
1993 -------------------------------
1994 -- 3.3.2 Number Declaration --
1995 -------------------------------
1997 -- Parsed by P_Identifier_Declarations (3.3)
1999 -------------------------------------------------------------------------
2000 -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) --
2001 -------------------------------------------------------------------------
2003 -- DERIVED_TYPE_DEFINITION ::=
2004 -- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
2005 -- [[and INTERFACE_LIST] RECORD_EXTENSION_PART]
2007 -- PRIVATE_EXTENSION_DECLARATION ::=
2008 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
2009 -- [abstract] [limited | synchronized]
2010 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
2011 -- with private [ASPECT_SPECIFICATIONS];
2013 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
2015 -- The caller has already scanned out the part up to the NEW, and Token
2016 -- either contains Tok_New (or ought to, if it doesn't this procedure
2017 -- will post an appropriate "NEW expected" message).
2019 -- Note: the caller is responsible for filling in the Sloc field of
2020 -- the returned node in the private extension declaration case as
2021 -- well as the stuff relating to the discriminant part.
2023 -- Error recovery: can raise Error_Resync;
2025 function P_Derived_Type_Def_Or_Private_Ext_Decl
return Node_Id
is
2026 Typedef_Node
: Node_Id
;
2027 Typedecl_Node
: Node_Id
;
2028 Not_Null_Present
: Boolean := False;
2031 Typedef_Node
:= New_Node
(N_Derived_Type_Definition
, Token_Ptr
);
2033 if Ada_Version
< Ada_2005
2034 and then Token
= Tok_Identifier
2035 and then Token_Name
= Name_Interface
2038 ("abstract interface is an Ada 2005 extension");
2039 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
2044 if Token
= Tok_Abstract
then
2045 Error_Msg_SC
-- CODEFIX
2046 ("ABSTRACT must come before NEW, not after");
2050 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
2051 Set_Null_Exclusion_Present
(Typedef_Node
, Not_Null_Present
);
2052 Set_Subtype_Indication
(Typedef_Node
,
2053 P_Subtype_Indication
(Not_Null_Present
));
2055 -- Ada 2005 (AI-251): Deal with interfaces
2057 if Token
= Tok_And
then
2060 Error_Msg_Ada_2005_Extension
("abstract interface");
2062 Set_Interface_List
(Typedef_Node
, New_List
);
2065 Append
(P_Qualified_Simple_Name
, Interface_List
(Typedef_Node
));
2066 exit when Token
/= Tok_And
;
2070 if Token
/= Tok_With
then
2071 Error_Msg_SC
("WITH expected");
2076 -- Deal with record extension, note that we assume that a WITH is
2077 -- missing in the case of "type X is new Y record ..." or in the
2078 -- case of "type X is new Y null record".
2080 -- First make sure we don't have an aspect specification. If we do
2081 -- return now, so that our caller can check it (the WITH here is not
2082 -- part of a type extension).
2084 if Aspect_Specifications_Present
then
2085 return Typedef_Node
;
2087 -- OK, not an aspect specification, so continue test for extension
2089 elsif Token
in Tok_With | Tok_Record | Tok_Null
then
2090 T_With
; -- past WITH or give error message
2092 if Token
= Tok_Limited
then
2093 Error_Msg_SC
("LIMITED keyword not allowed in private extension");
2094 Scan
; -- ignore LIMITED
2097 -- Private extension declaration
2099 if Token
= Tok_Private
then
2100 Scan
; -- past PRIVATE
2102 -- Throw away the type definition node and build the type
2103 -- declaration node. Note the caller must set the Sloc,
2104 -- Discriminant_Specifications, Unknown_Discriminants_Present,
2105 -- and Defined_Identifier fields in the returned node.
2108 Make_Private_Extension_Declaration
(No_Location
,
2109 Defining_Identifier
=> Empty
,
2110 Subtype_Indication
=> Subtype_Indication
(Typedef_Node
),
2111 Abstract_Present
=> Abstract_Present
(Typedef_Node
),
2112 Interface_List
=> Interface_List
(Typedef_Node
));
2114 return Typedecl_Node
;
2116 -- Derived type definition with record extension part
2119 Set_Record_Extension_Part
(Typedef_Node
, P_Record_Definition
);
2120 return Typedef_Node
;
2123 -- Derived type definition with no record extension part
2126 return Typedef_Node
;
2128 end P_Derived_Type_Def_Or_Private_Ext_Decl
;
2130 ---------------------------
2131 -- 3.5 Range Constraint --
2132 ---------------------------
2134 -- RANGE_CONSTRAINT ::= range RANGE
2136 -- The caller has checked that the initial token is RANGE or some
2137 -- misspelling of it, or it may be absent completely (and a message
2138 -- has already been issued).
2140 -- Error recovery: cannot raise Error_Resync
2142 function P_Range_Constraint
return Node_Id
is
2143 Range_Node
: Node_Id
;
2146 Range_Node
:= New_Node
(N_Range_Constraint
, Token_Ptr
);
2148 -- Skip range keyword if present
2150 if Token
= Tok_Range
or else Bad_Spelling_Of
(Tok_Range
) then
2154 Set_Range_Expression
(Range_Node
, P_Range
);
2156 end P_Range_Constraint
;
2163 -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
2165 -- Note: the range that appears in a membership test is parsed by
2166 -- P_Range_Or_Subtype_Mark (3.5).
2168 -- Error recovery: cannot raise Error_Resync
2170 function P_Range
return Node_Id
is
2171 Expr_Node
: Node_Id
;
2172 Range_Node
: Node_Id
;
2175 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2177 if Expr_Form
= EF_Range_Attr
then
2180 elsif Token
= Tok_Dot_Dot
then
2181 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2182 Set_Low_Bound
(Range_Node
, Expr_Node
);
2184 Expr_Node
:= P_Expression
;
2185 Check_Simple_Expression
(Expr_Node
);
2186 Set_High_Bound
(Range_Node
, Expr_Node
);
2189 -- Anything else is an error
2192 T_Dot_Dot
; -- force missing .. message
2197 ----------------------------------
2198 -- 3.5 P_Range_Or_Subtype_Mark --
2199 ----------------------------------
2202 -- RANGE_ATTRIBUTE_REFERENCE
2203 -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
2205 -- This routine scans out the range or subtype mark that forms the right
2206 -- operand of a membership test (it is not used in any other contexts, and
2207 -- error messages are specialized with this knowledge in mind).
2209 -- Note: as documented in the Sinfo interface, although the syntax only
2210 -- allows a subtype mark, we in fact allow any simple expression to be
2211 -- returned from this routine. The semantics is responsible for issuing
2212 -- an appropriate message complaining if the argument is not a name.
2213 -- This simplifies the coding and error recovery processing in the
2214 -- parser, and in any case it is preferable not to consider this a
2215 -- syntax error and to continue with the semantic analysis.
2217 -- Error recovery: cannot raise Error_Resync
2219 function P_Range_Or_Subtype_Mark
2220 (Allow_Simple_Expression
: Boolean := False) return Node_Id
2222 Expr_Node
: Node_Id
;
2223 Range_Node
: Node_Id
;
2224 Save_Loc
: Source_Ptr
;
2226 -- Start of processing for P_Range_Or_Subtype_Mark
2229 -- Save location of possible junk parentheses
2231 Save_Loc
:= Token_Ptr
;
2233 -- Scan out either a simple expression or a range (this accepts more
2234 -- than is legal here, but as explained above, we like to allow more
2235 -- with a proper diagnostic, and in the case of a membership operation
2236 -- where sets are allowed, a simple expression is permissible anyway.
2238 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2242 if Expr_Form
= EF_Range_Attr
then
2245 -- Simple_Expression .. Simple_Expression
2247 elsif Token
= Tok_Dot_Dot
then
2248 Check_Simple_Expression
(Expr_Node
);
2249 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2250 Set_Low_Bound
(Range_Node
, Expr_Node
);
2252 Set_High_Bound
(Range_Node
, P_Simple_Expression
);
2255 -- Case of subtype mark (optionally qualified simple name or an
2256 -- attribute whose prefix is an optionally qualified simple name)
2258 elsif Expr_Form
= EF_Simple_Name
2259 or else Nkind
(Expr_Node
) = N_Attribute_Reference
2261 -- Check for error of range constraint after a subtype mark
2263 if Token
= Tok_Range
then
2264 Error_Msg_SC
("range constraint not allowed in membership test");
2268 -- Check for error of DIGITS or DELTA after a subtype mark
2270 elsif Token
in Tok_Digits | Tok_Delta
then
2272 ("accuracy definition not allowed in membership test");
2273 Scan
; -- past DIGITS or DELTA
2276 -- Attribute reference, may or may not be OK, but in any case we
2279 elsif Token
= Tok_Apostrophe
then
2280 return P_Subtype_Mark_Attribute
(Expr_Node
);
2282 -- OK case of simple name, just return it
2288 -- Simple expression case
2290 elsif Expr_Form
= EF_Simple
and then Allow_Simple_Expression
then
2293 -- Here we have some kind of error situation. Check for junk parens
2294 -- then return what we have, caller will deal with other errors.
2297 if Nkind
(Expr_Node
) in N_Subexpr
2298 and then Paren_Count
(Expr_Node
) /= 0
2300 Error_Msg
("|parentheses not allowed for subtype mark", Save_Loc
);
2301 Set_Paren_Count
(Expr_Node
, 0);
2306 end P_Range_Or_Subtype_Mark
;
2308 ----------------------------------------
2309 -- 3.5.1 Enumeration Type Definition --
2310 ----------------------------------------
2312 -- ENUMERATION_TYPE_DEFINITION ::=
2313 -- (ENUMERATION_LITERAL_SPECIFICATION
2314 -- {, ENUMERATION_LITERAL_SPECIFICATION})
2316 -- The caller has already scanned out the TYPE keyword
2318 -- Error recovery: can raise Error_Resync;
2320 function P_Enumeration_Type_Definition
return Node_Id
is
2321 Typedef_Node
: Node_Id
;
2324 Typedef_Node
:= New_Node
(N_Enumeration_Type_Definition
, Token_Ptr
);
2325 Set_Literals
(Typedef_Node
, New_List
);
2330 Append
(P_Enumeration_Literal_Specification
, Literals
(Typedef_Node
));
2331 exit when not Comma_Present
;
2335 return Typedef_Node
;
2336 end P_Enumeration_Type_Definition
;
2338 ----------------------------------------------
2339 -- 3.5.1 Enumeration Literal Specification --
2340 ----------------------------------------------
2342 -- ENUMERATION_LITERAL_SPECIFICATION ::=
2343 -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
2345 -- Error recovery: can raise Error_Resync
2347 function P_Enumeration_Literal_Specification
return Node_Id
is
2349 if Token
= Tok_Char_Literal
then
2350 return P_Defining_Character_Literal
;
2352 return P_Defining_Identifier
(C_Comma_Right_Paren
);
2354 end P_Enumeration_Literal_Specification
;
2356 ---------------------------------------
2357 -- 3.5.1 Defining_Character_Literal --
2358 ---------------------------------------
2360 -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
2362 -- Error recovery: cannot raise Error_Resync
2364 -- The caller has checked that the current token is a character literal
2366 function P_Defining_Character_Literal
return Node_Id
is
2367 Literal_Node
: Node_Id
;
2369 Literal_Node
:= Token_Node
;
2370 Change_Character_Literal_To_Defining_Character_Literal
(Literal_Node
);
2371 Scan
; -- past character literal
2372 return Literal_Node
;
2373 end P_Defining_Character_Literal
;
2375 ------------------------------------
2376 -- 3.5.4 Integer Type Definition --
2377 ------------------------------------
2379 -- Parsed by P_Type_Declaration (3.2.1)
2381 -------------------------------------------
2382 -- 3.5.4 Signed Integer Type Definition --
2383 -------------------------------------------
2385 -- SIGNED_INTEGER_TYPE_DEFINITION ::=
2386 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2388 -- Normally the initial token on entry is RANGE, but in some
2389 -- error conditions, the range token was missing and control is
2390 -- passed with Token pointing to first token of the first expression.
2392 -- Error recovery: cannot raise Error_Resync
2394 function P_Signed_Integer_Type_Definition
return Node_Id
is
2395 Typedef_Node
: Node_Id
;
2396 Expr_Node
: Node_Id
;
2399 Typedef_Node
:= New_Node
(N_Signed_Integer_Type_Definition
, Token_Ptr
);
2401 if Token
= Tok_Range
then
2405 Expr_Node
:= P_Expression_Or_Range_Attribute
;
2407 -- Range case (not permitted by the grammar, this is surprising but
2408 -- the grammar in the RM is as quoted above, and does not allow Range).
2410 if Expr_Form
= EF_Range_Attr
then
2412 ("Range attribute not allowed here, use First .. Last", Expr_Node
);
2413 Set_Low_Bound
(Typedef_Node
, Expr_Node
);
2414 Set_Attribute_Name
(Expr_Node
, Name_First
);
2415 Set_High_Bound
(Typedef_Node
, Copy_Separate_Tree
(Expr_Node
));
2416 Set_Attribute_Name
(High_Bound
(Typedef_Node
), Name_Last
);
2418 -- Normal case of explicit range
2421 Check_Simple_Expression
(Expr_Node
);
2422 Set_Low_Bound
(Typedef_Node
, Expr_Node
);
2424 Expr_Node
:= P_Expression
;
2425 Check_Simple_Expression
(Expr_Node
);
2426 Set_High_Bound
(Typedef_Node
, Expr_Node
);
2429 return Typedef_Node
;
2430 end P_Signed_Integer_Type_Definition
;
2432 ------------------------------------
2433 -- 3.5.4 Modular Type Definition --
2434 ------------------------------------
2436 -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
2438 -- The caller has checked that the initial token is MOD
2440 -- Error recovery: cannot raise Error_Resync
2442 function P_Modular_Type_Definition
return Node_Id
is
2443 Typedef_Node
: Node_Id
;
2446 if Ada_Version
= Ada_83
then
2447 Error_Msg_SC
("(Ada 83) modular types not allowed");
2450 Typedef_Node
:= New_Node
(N_Modular_Type_Definition
, Token_Ptr
);
2452 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
2454 -- Handle mod L..R cleanly
2456 if Token
= Tok_Dot_Dot
then
2457 Error_Msg_SC
("range not allowed for modular type");
2459 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
2462 return Typedef_Node
;
2463 end P_Modular_Type_Definition
;
2465 ---------------------------------
2466 -- 3.5.6 Real Type Definition --
2467 ---------------------------------
2469 -- Parsed by P_Type_Declaration (3.2.1)
2471 --------------------------------------
2472 -- 3.5.7 Floating Point Definition --
2473 --------------------------------------
2475 -- FLOATING_POINT_DEFINITION ::=
2476 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2478 -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
2480 -- The caller has checked that the initial token is DIGITS
2482 -- Error recovery: cannot raise Error_Resync
2484 function P_Floating_Point_Definition
return Node_Id
is
2485 Digits_Loc
: constant Source_Ptr
:= Token_Ptr
;
2487 Expr_Node
: Node_Id
;
2490 Scan
; -- past DIGITS
2491 Expr_Node
:= P_Expression_No_Right_Paren
;
2492 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2494 -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
2496 if Token
= Tok_Delta
then
2497 Error_Msg_SC
-- CODEFIX
2498 ("|DELTA must come before DIGITS");
2499 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Digits_Loc
);
2501 Set_Delta_Expression
(Def_Node
, P_Expression_No_Right_Paren
);
2503 -- OK floating-point definition
2506 Def_Node
:= New_Node
(N_Floating_Point_Definition
, Digits_Loc
);
2509 Set_Digits_Expression
(Def_Node
, Expr_Node
);
2510 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
2512 end P_Floating_Point_Definition
;
2514 -------------------------------------
2515 -- 3.5.7 Real Range Specification --
2516 -------------------------------------
2518 -- REAL_RANGE_SPECIFICATION ::=
2519 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2521 -- Error recovery: cannot raise Error_Resync
2523 function P_Real_Range_Specification_Opt
return Node_Id
is
2524 Specification_Node
: Node_Id
;
2525 Expr_Node
: Node_Id
;
2528 if Token
= Tok_Range
then
2529 Specification_Node
:=
2530 New_Node
(N_Real_Range_Specification
, Token_Ptr
);
2532 Expr_Node
:= P_Expression_No_Right_Paren
;
2533 Check_Simple_Expression
(Expr_Node
);
2534 Set_Low_Bound
(Specification_Node
, Expr_Node
);
2536 Expr_Node
:= P_Expression_No_Right_Paren
;
2537 Check_Simple_Expression
(Expr_Node
);
2538 Set_High_Bound
(Specification_Node
, Expr_Node
);
2539 return Specification_Node
;
2543 end P_Real_Range_Specification_Opt
;
2545 -----------------------------------
2546 -- 3.5.9 Fixed Point Definition --
2547 -----------------------------------
2549 -- FIXED_POINT_DEFINITION ::=
2550 -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
2552 -- ORDINARY_FIXED_POINT_DEFINITION ::=
2553 -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION
2555 -- DECIMAL_FIXED_POINT_DEFINITION ::=
2556 -- delta static_EXPRESSION
2557 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2559 -- The caller has checked that the initial token is DELTA
2561 -- Error recovery: cannot raise Error_Resync
2563 function P_Fixed_Point_Definition
return Node_Id
is
2564 Delta_Node
: Node_Id
;
2565 Delta_Loc
: Source_Ptr
;
2567 Expr_Node
: Node_Id
;
2570 Delta_Loc
:= Token_Ptr
;
2572 Delta_Node
:= P_Expression_No_Right_Paren
;
2573 Check_Simple_Expression_In_Ada_83
(Delta_Node
);
2575 if Token
= Tok_Digits
then
2576 if Ada_Version
= Ada_83
then
2577 Error_Msg_SC
("(Ada 83) decimal fixed type not allowed!");
2580 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Delta_Loc
);
2581 Scan
; -- past DIGITS
2582 Expr_Node
:= P_Expression_No_Right_Paren
;
2583 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2584 Set_Digits_Expression
(Def_Node
, Expr_Node
);
2587 Def_Node
:= New_Node
(N_Ordinary_Fixed_Point_Definition
, Delta_Loc
);
2589 -- Range is required in ordinary fixed point case
2591 if Token
/= Tok_Range
then
2592 Error_Msg_AP
("range must be given for fixed-point type");
2597 Set_Delta_Expression
(Def_Node
, Delta_Node
);
2598 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
2600 end P_Fixed_Point_Definition
;
2602 --------------------------------------------
2603 -- 3.5.9 Ordinary Fixed Point Definition --
2604 --------------------------------------------
2606 -- Parsed by P_Fixed_Point_Definition (3.5.9)
2608 -------------------------------------------
2609 -- 3.5.9 Decimal Fixed Point Definition --
2610 -------------------------------------------
2612 -- Parsed by P_Decimal_Point_Definition (3.5.9)
2614 ------------------------------
2615 -- 3.5.9 Digits Constraint --
2616 ------------------------------
2618 -- DIGITS_CONSTRAINT ::=
2619 -- digits static_EXPRESSION [RANGE_CONSTRAINT]
2621 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2623 -- The caller has checked that the initial token is DIGITS
2625 function P_Digits_Constraint
return Node_Id
is
2626 Constraint_Node
: Node_Id
;
2627 Expr_Node
: Node_Id
;
2630 Constraint_Node
:= New_Node
(N_Digits_Constraint
, Token_Ptr
);
2631 Scan
; -- past DIGITS
2632 Expr_Node
:= P_Expression
;
2633 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2634 Set_Digits_Expression
(Constraint_Node
, Expr_Node
);
2636 if Token
= Tok_Range
then
2637 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
2640 return Constraint_Node
;
2641 end P_Digits_Constraint
;
2643 -----------------------------
2644 -- 3.5.9 Delta Constraint --
2645 -----------------------------
2647 -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
2649 -- Note: this is an obsolescent feature in Ada 95 (I.3)
2651 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2652 -- (also true in formal modes).
2654 -- The caller has checked that the initial token is DELTA
2656 -- Error recovery: cannot raise Error_Resync
2658 function P_Delta_Constraint
return Node_Id
is
2659 Constraint_Node
: Node_Id
;
2660 Expr_Node
: Node_Id
;
2663 Constraint_Node
:= New_Node
(N_Delta_Constraint
, Token_Ptr
);
2665 Expr_Node
:= P_Expression
;
2666 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2668 Set_Delta_Expression
(Constraint_Node
, Expr_Node
);
2670 if Token
= Tok_Range
then
2671 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
2674 return Constraint_Node
;
2675 end P_Delta_Constraint
;
2677 --------------------------------
2678 -- 3.6 Array Type Definition --
2679 --------------------------------
2681 -- ARRAY_TYPE_DEFINITION ::=
2682 -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
2684 -- UNCONSTRAINED_ARRAY_DEFINITION ::=
2685 -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
2686 -- COMPONENT_DEFINITION
2688 -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
2690 -- CONSTRAINED_ARRAY_DEFINITION ::=
2691 -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
2692 -- COMPONENT_DEFINITION
2694 -- DISCRETE_SUBTYPE_DEFINITION ::=
2695 -- DISCRETE_SUBTYPE_INDICATION | RANGE
2697 -- COMPONENT_DEFINITION ::=
2698 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
2700 -- The caller has checked that the initial token is ARRAY
2702 -- Error recovery: can raise Error_Resync
2704 function P_Array_Type_Definition
return Node_Id
is
2705 Array_Loc
: Source_Ptr
;
2706 CompDef_Node
: Node_Id
;
2708 Not_Null_Present
: Boolean := False;
2709 Subs_List
: List_Id
;
2710 Scan_State
: Saved_Scan_State
;
2711 Aliased_Present
: Boolean := False;
2713 procedure P_Index_Subtype_Def_With_Fixed_Lower_Bound
2714 (Subtype_Mark
: Node_Id
);
2715 -- Parse an unconstrained index range with a fixed lower bound:
2716 -- subtype_mark range <expression> .. <>
2717 -- This procedure creates a subtype_indication node for the index.
2719 --------------------------------------------
2720 -- P_Index_Range_With_Fixed_Lower_Bound --
2721 --------------------------------------------
2723 procedure P_Index_Subtype_Def_With_Fixed_Lower_Bound
2724 (Subtype_Mark
: Node_Id
)
2726 Low_Expr_Node
: constant Node_Id
:= P_Expression
;
2727 High_Expr_Node
: Node_Id
;
2728 Indic_Node
: Node_Id
;
2729 Constr_Node
: Node_Id
;
2730 Range_Node
: Node_Id
;
2733 T_Dot_Dot
; -- Error if no ..
2735 -- A box is required at this point, and we'll set the upper bound to
2736 -- the same expression as the lower bound (see further below), to
2737 -- avoid problems with trying to analyze an Empty node. Analysis can
2738 -- still tell that this is a fixed-lower-bound range because the
2739 -- index is represented by a subtype_indication in an unconstrained
2740 -- array type definition.
2742 if Token
= Tok_Box
then
2744 High_Expr_Node
:= Low_Expr_Node
;
2746 -- Error if no <> was found, and try to parse an expression since
2747 -- it's likely one was given in place of the <>.
2750 Error_Msg_AP
-- CODEFIX
2751 ("missing ""'<'>""");
2753 High_Expr_Node
:= P_Expression
;
2756 Constr_Node
:= New_Node
(N_Range_Constraint
, Token_Ptr
);
2757 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2758 Set_Range_Expression
(Constr_Node
, Range_Node
);
2760 Check_Simple_Expression
(Low_Expr_Node
);
2762 Set_Low_Bound
(Range_Node
, Low_Expr_Node
);
2763 Set_High_Bound
(Range_Node
, High_Expr_Node
);
2766 New_Node
(N_Subtype_Indication
, Sloc
(Subtype_Mark
));
2767 Set_Subtype_Mark
(Indic_Node
, Check_Subtype_Mark
(Subtype_Mark
));
2768 Set_Constraint
(Indic_Node
, Constr_Node
);
2770 Append
(Indic_Node
, Subs_List
);
2771 end P_Index_Subtype_Def_With_Fixed_Lower_Bound
;
2775 Is_Constrained_Array_Def
: Boolean := True;
2776 Subtype_Mark_Node
: Node_Id
;
2778 -- Start of processing for P_Array_Type_Definition
2781 Array_Loc
:= Token_Ptr
;
2783 Subs_List
:= New_List
;
2786 -- It's quite tricky to disentangle these two possibilities, so we do
2787 -- a prescan to determine which case we have and then reset the scan.
2788 -- The prescan skips past possible subtype mark tokens.
2790 Save_Scan_State
(Scan_State
); -- just after paren
2792 while Token
in Token_Class_Desig
or else
2793 Token
= Tok_Dot
or else
2794 Token
= Tok_Apostrophe
-- because of 'BASE, 'CLASS
2799 -- If we end up on RANGE <> then we have the unconstrained case. We
2800 -- will also allow the RANGE to be omitted, just to improve error
2801 -- handling for a case like array (integer <>) of integer;
2803 Scan
; -- past possible RANGE or <>
2805 if (Prev_Token
= Tok_Range
and then Token
= Tok_Box
) or else
2806 Prev_Token
= Tok_Box
2808 Def_Node
:= New_Node
(N_Unconstrained_Array_Definition
, Array_Loc
);
2809 Restore_Scan_State
(Scan_State
); -- to first subtype mark
2811 Is_Constrained_Array_Def
:= False;
2813 -- Now parse a sequence of indexes where each is either of form:
2814 -- <subtype_mark> range <>
2816 -- <subtype_mark> range <expr> .. <>
2818 -- The latter syntax indicates an index with a fixed lower bound,
2819 -- and only applies when extensions are enabled (-gnatX).
2822 Subtype_Mark_Node
:= P_Subtype_Mark_Resync
;
2826 -- Normal "subtype_mark range <>" form, so simply append
2827 -- the subtype reference.
2829 if Token
= Tok_Box
then
2830 Append
(Subtype_Mark_Node
, Subs_List
);
2833 -- Fixed-lower-bound form ("subtype_mark range <expr> .. <>")
2836 P_Index_Subtype_Def_With_Fixed_Lower_Bound
(Subtype_Mark_Node
);
2838 Error_Msg_GNAT_Extension
("fixed-lower-bound array", Token_Ptr
,
2839 Is_Core_Extension
=> True);
2842 exit when Token
in Tok_Right_Paren | Tok_Of
;
2846 Set_Subtype_Marks
(Def_Node
, Subs_List
);
2848 -- If we don't have "range <>", then "range" will be followed by an
2849 -- expression, for either a normal range or a fixed-lower-bound range
2850 -- ("<exp> .. <>"), and we have to know which, in order to determine
2851 -- whether to parse the indexes for an unconstrained or constrained
2852 -- array definition. So we look ahead to see if "<>" follows the "..".
2853 -- If not, then this must be a discrete_subtype_indication for a
2854 -- constrained_array_definition, which will be processed further below.
2856 elsif Prev_Token
= Tok_Range
2857 and then Token
not in Tok_Right_Paren | Tok_Comma
2859 -- If we have an expression followed by "..", then scan farther
2860 -- and check for "<>" to see if we have a fixed-lower-bound range.
2862 if P_Expression_Or_Range_Attribute
/= Error
2863 and then Expr_Form
/= EF_Range_Attr
2864 and then Token
= Tok_Dot_Dot
2868 -- If there's a "<>", then we know we have a fixed-lower-bound
2869 -- index, so we can proceed with parsing an unconstrained array
2872 if Token
= Tok_Box
then
2873 Is_Constrained_Array_Def
:= False;
2876 New_Node
(N_Unconstrained_Array_Definition
, Array_Loc
);
2878 Restore_Scan_State
(Scan_State
); -- to first subtype mark
2880 -- Now parse a sequence of indexes where each is either of
2882 -- <subtype_mark> range <>
2884 -- <subtype_mark> range <expr> .. <>
2886 -- The latter indicates an index with a fixed lower bound,
2887 -- and only applies when extensions are enabled (-gnatX).
2890 Subtype_Mark_Node
:= P_Subtype_Mark_Resync
;
2894 -- Normal "subtype_mark range <>" form, so simply append
2895 -- the subtype reference.
2897 if Token
= Tok_Box
then
2898 Append
(Subtype_Mark_Node
, Subs_List
);
2901 -- This must be an index of form:
2902 -- <subtype_mark> range <expr> .. <>"
2905 P_Index_Subtype_Def_With_Fixed_Lower_Bound
2906 (Subtype_Mark_Node
);
2908 Error_Msg_GNAT_Extension
2909 ("fixed-lower-bound array", Token_Ptr
,
2910 Is_Core_Extension
=> True);
2913 exit when Token
in Tok_Right_Paren | Tok_Of
;
2917 Set_Subtype_Marks
(Def_Node
, Subs_List
);
2922 if Is_Constrained_Array_Def
then
2923 Def_Node
:= New_Node
(N_Constrained_Array_Definition
, Array_Loc
);
2924 Restore_Scan_State
(Scan_State
); -- to first discrete range
2927 Append
(P_Discrete_Subtype_Definition
, Subs_List
);
2928 exit when not Comma_Present
;
2931 Set_Discrete_Subtype_Definitions
(Def_Node
, Subs_List
);
2937 CompDef_Node
:= New_Node
(N_Component_Definition
, Token_Ptr
);
2939 if Token_Name
= Name_Aliased
then
2940 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
2943 if Token
= Tok_Aliased
then
2944 Aliased_Present
:= True;
2945 Scan
; -- past ALIASED
2948 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/AI-254)
2950 -- Ada 2005 (AI-230): Access Definition case
2952 if Token
= Tok_Access
then
2953 Error_Msg_Ada_2005_Extension
2954 ("generalized use of anonymous access types");
2956 -- AI95-406 makes "aliased" legal (and useless) in this context so
2957 -- followintg code which used to be needed is commented out.
2959 -- if Aliased_Present then
2960 -- Error_Msg_SP ("ALIASED not allowed here");
2963 Set_Subtype_Indication
(CompDef_Node
, Empty
);
2964 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
2965 Set_Access_Definition
(CompDef_Node
,
2966 P_Access_Definition
(Not_Null_Present
));
2969 Set_Access_Definition
(CompDef_Node
, Empty
);
2970 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
2971 Set_Null_Exclusion_Present
(CompDef_Node
, Not_Null_Present
);
2972 Set_Subtype_Indication
(CompDef_Node
,
2973 P_Subtype_Indication
(Not_Null_Present
));
2976 Set_Component_Definition
(Def_Node
, CompDef_Node
);
2979 end P_Array_Type_Definition
;
2981 -----------------------------------------
2982 -- 3.6 Unconstrained Array Definition --
2983 -----------------------------------------
2985 -- Parsed by P_Array_Type_Definition (3.6)
2987 ---------------------------------------
2988 -- 3.6 Constrained Array Definition --
2989 ---------------------------------------
2991 -- Parsed by P_Array_Type_Definition (3.6)
2993 --------------------------------------
2994 -- 3.6 Discrete Subtype Definition --
2995 --------------------------------------
2997 -- DISCRETE_SUBTYPE_DEFINITION ::=
2998 -- discrete_SUBTYPE_INDICATION | RANGE
3000 -- Note: the discrete subtype definition appearing in a constrained
3001 -- array definition is parsed by P_Array_Type_Definition (3.6)
3003 -- Error recovery: cannot raise Error_Resync
3005 function P_Discrete_Subtype_Definition
return Node_Id
is
3007 -- The syntax of a discrete subtype definition is identical to that
3008 -- of a discrete range, so we simply share the same parsing code.
3010 return P_Discrete_Range
;
3011 end P_Discrete_Subtype_Definition
;
3013 -------------------------------
3014 -- 3.6 Component Definition --
3015 -------------------------------
3017 -- For the array case, parsed by P_Array_Type_Definition (3.6)
3018 -- For the record case, parsed by P_Component_Declaration (3.8)
3020 -----------------------------
3021 -- 3.6.1 Index Constraint --
3022 -----------------------------
3024 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
3026 ---------------------------
3027 -- 3.6.1 Discrete Range --
3028 ---------------------------
3030 -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
3032 -- The possible forms for a discrete range are:
3034 -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2)
3035 -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2)
3036 -- Range_Attribute (RANGE, 3.5)
3037 -- Simple_Expression .. Simple_Expression (RANGE, 3.5)
3039 -- Error recovery: cannot raise Error_Resync
3041 function P_Discrete_Range
return Node_Id
is
3042 Expr_Node
: Node_Id
;
3043 Range_Node
: Node_Id
;
3046 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
3048 if Expr_Form
= EF_Range_Attr
then
3051 elsif Token
= Tok_Range
then
3052 if Expr_Form
/= EF_Simple_Name
then
3053 Error_Msg_SC
("range must be preceded by subtype mark");
3056 return P_Subtype_Indication
(Expr_Node
);
3058 -- Check Expression .. Expression case
3060 elsif Token
= Tok_Dot_Dot
then
3061 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
3062 Set_Low_Bound
(Range_Node
, Expr_Node
);
3065 Style
.Check_Xtra_Parens
(Expr_Node
);
3069 Expr_Node
:= P_Expression
;
3070 Check_Simple_Expression
(Expr_Node
);
3071 Set_High_Bound
(Range_Node
, Expr_Node
);
3073 -- If Expr_Node (ignoring parentheses) is not a simple expression
3074 -- then emit a style check.
3077 and then Nkind
(Expr_Node
) not in N_Op_Boolean | N_Subexpr
3079 Style
.Check_Xtra_Parens
(Expr_Node
);
3084 -- Otherwise we must have a subtype mark, or an Ada 2012 iterator
3086 elsif Expr_Form
= EF_Simple_Name
then
3089 -- The domain of iteration must be a name. Semantics will determine that
3090 -- the expression has the proper form.
3092 elsif Ada_Version
>= Ada_2012
then
3095 -- If incorrect, complain that we expect ..
3101 end P_Discrete_Range
;
3103 ----------------------------
3104 -- 3.7 Discriminant Part --
3105 ----------------------------
3107 -- DISCRIMINANT_PART ::=
3108 -- UNKNOWN_DISCRIMINANT_PART
3109 -- | KNOWN_DISCRIMINANT_PART
3111 -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
3112 -- or P_Unknown_Discriminant_Part (3.7), since we know which we want.
3114 ------------------------------------
3115 -- 3.7 Unknown Discriminant Part --
3116 ------------------------------------
3118 -- UNKNOWN_DISCRIMINANT_PART ::= (<>)
3120 -- If no unknown discriminant part is present, then False is returned,
3121 -- otherwise the unknown discriminant is scanned out and True is returned.
3123 -- Error recovery: cannot raise Error_Resync
3125 function P_Unknown_Discriminant_Part_Opt
return Boolean is
3126 Scan_State
: Saved_Scan_State
;
3129 -- If <> right now, then this is missing left paren
3131 if Token
= Tok_Box
then
3134 -- If not <> or left paren, then definitely no box
3136 elsif Token
/= Tok_Left_Paren
then
3139 -- Left paren, so might be a box after it
3142 Save_Scan_State
(Scan_State
);
3143 Scan
; -- past the left paren
3145 if Token
/= Tok_Box
then
3146 Restore_Scan_State
(Scan_State
);
3151 -- We are now pointing to the box
3153 if Ada_Version
= Ada_83
then
3154 Error_Msg_SC
("(Ada 83) unknown discriminant not allowed!");
3157 Scan
; -- past the box
3158 U_Right_Paren
; -- must be followed by right paren
3160 end P_Unknown_Discriminant_Part_Opt
;
3162 ----------------------------------
3163 -- 3.7 Known Discriminant Part --
3164 ----------------------------------
3166 -- KNOWN_DISCRIMINANT_PART ::=
3167 -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
3169 -- DISCRIMINANT_SPECIFICATION ::=
3170 -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
3171 -- [:= DEFAULT_EXPRESSION] [ASPECT_SPECIFICATION]
3172 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
3173 -- [:= DEFAULT_EXPRESSION] [ASPECT_SPECIFICATION]
3175 -- If no known discriminant part is present, then No_List is returned
3177 -- Error recovery: cannot raise Error_Resync
3179 function P_Known_Discriminant_Part_Opt
return List_Id
is
3180 Specification_Node
: Node_Id
;
3181 Specification_List
: List_Id
;
3182 Ident_Sloc
: Source_Ptr
;
3183 Scan_State
: Saved_Scan_State
;
3185 Not_Null_Present
: Boolean;
3188 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
3189 -- This array holds the list of defining identifiers. The upper bound
3190 -- of 4096 is intended to be essentially infinite, and we do not even
3191 -- bother to check for it being exceeded.
3194 if Token
= Tok_Left_Paren
then
3195 Specification_List
:= New_List
;
3197 P_Pragmas_Misplaced
;
3199 Specification_Loop
: loop
3201 Ident_Sloc
:= Token_Ptr
;
3202 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
3205 while Comma_Present
loop
3206 Num_Idents
:= Num_Idents
+ 1;
3207 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
3210 -- If there are multiple identifiers, we repeatedly scan the
3211 -- type and initialization expression information by resetting
3212 -- the scan pointer (so that we get completely separate trees
3213 -- for each occurrence).
3215 if Num_Idents
> 1 then
3216 Save_Scan_State
(Scan_State
);
3221 -- Loop through defining identifiers in list
3225 Specification_Node
:=
3226 New_Node
(N_Discriminant_Specification
, Ident_Sloc
);
3227 Set_Defining_Identifier
(Specification_Node
, Idents
(Ident
));
3228 Not_Null_Present
:= -- Ada 2005 (AI-231, AI-447)
3229 P_Null_Exclusion
(Allow_Anonymous_In_95
=> True);
3231 if Token
= Tok_Access
then
3232 if Ada_Version
= Ada_83
then
3234 ("(Ada 83) access discriminant not allowed!");
3237 Set_Discriminant_Type
3238 (Specification_Node
,
3239 P_Access_Definition
(Not_Null_Present
));
3241 -- Catch ouf-of-order keywords
3243 elsif Token
= Tok_Constant
then
3246 if Token
= Tok_Access
then
3247 Error_Msg_SC
-- CODEFIX
3248 ("ACCESS must come before CONSTANT");
3249 Set_Discriminant_Type
3250 (Specification_Node
,
3251 P_Access_Definition
(Not_Null_Present
));
3254 Error_Msg_SC
("misplaced CONSTANT");
3258 Set_Discriminant_Type
3259 (Specification_Node
, P_Subtype_Mark
);
3261 Set_Null_Exclusion_Present
-- Ada 2005 (AI-231)
3262 (Specification_Node
, Not_Null_Present
);
3266 (Specification_Node
, Init_Expr_Opt
(True));
3268 if Token
= Tok_With
then
3269 P_Aspect_Specifications
3270 (Specification_Node
, Semicolon
=> False);
3274 Set_Prev_Ids
(Specification_Node
, True);
3277 if Ident
< Num_Idents
then
3278 Set_More_Ids
(Specification_Node
, True);
3281 Append
(Specification_Node
, Specification_List
);
3282 exit Ident_Loop
when Ident
= Num_Idents
;
3284 Restore_Scan_State
(Scan_State
);
3286 end loop Ident_Loop
;
3288 exit Specification_Loop
when Token
/= Tok_Semicolon
;
3290 P_Pragmas_Misplaced
;
3291 end loop Specification_Loop
;
3294 return Specification_List
;
3299 end P_Known_Discriminant_Part_Opt
;
3301 -------------------------------------
3302 -- 3.7 Discriminant Specification --
3303 -------------------------------------
3305 -- Parsed by P_Known_Discriminant_Part_Opt (3.7)
3307 -----------------------------
3308 -- 3.7 Default Expression --
3309 -----------------------------
3311 -- Always parsed (simply as an Expression) by the parent construct
3313 ------------------------------------
3314 -- 3.7.1 Discriminant Constraint --
3315 ------------------------------------
3317 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
3319 --------------------------------------------------------
3320 -- 3.7.1 Index or Discriminant Constraint (also 3.6) --
3321 --------------------------------------------------------
3323 -- DISCRIMINANT_CONSTRAINT ::=
3324 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
3326 -- DISCRIMINANT_ASSOCIATION ::=
3327 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
3330 -- This routine parses either an index or a discriminant constraint. As
3331 -- is clear from the above grammar, it is often possible to clearly
3332 -- determine which of the two possibilities we have, but there are
3333 -- cases (those in which we have a series of expressions of the same
3334 -- syntactic form as subtype indications), where we cannot tell. Since
3335 -- this means that in any case the semantic phase has to distinguish
3336 -- between the two, there is not much point in the parser trying to
3337 -- distinguish even those cases where the difference is clear. In any
3338 -- case, if we have a situation like:
3340 -- (A => 123, 235 .. 500)
3342 -- it is not clear which of the two items is the wrong one, better to
3343 -- let the semantic phase give a clear message. Consequently, this
3344 -- routine in general returns a list of items which can be either
3345 -- discrete ranges or discriminant associations.
3347 -- The caller has checked that the initial token is a left paren
3349 -- Error recovery: can raise Error_Resync
3351 function P_Index_Or_Discriminant_Constraint
return Node_Id
is
3352 Scan_State
: Saved_Scan_State
;
3353 Constr_Node
: Node_Id
;
3354 Constr_List
: List_Id
;
3355 Expr_Node
: Node_Id
;
3356 Result_Node
: Node_Id
;
3359 Result_Node
:= New_Node
(N_Index_Or_Discriminant_Constraint
, Token_Ptr
);
3361 Constr_List
:= New_List
;
3362 Set_Constraints
(Result_Node
, Constr_List
);
3364 -- The two syntactic forms are a little mixed up, so what we are doing
3365 -- here is looking at the first entry to determine which case we have
3367 -- A discriminant constraint is a list of discriminant associations,
3368 -- which have one of the following possible forms:
3372 -- Id | Id | .. | Id => Expression
3374 -- An index constraint is a list of discrete ranges which have one
3375 -- of the following possible forms:
3378 -- Subtype_Mark range Range
3380 -- Simple_Expression .. Simple_Expression
3382 -- Loop through discriminants in list
3385 -- Check cases of Id => Expression or Id | Id => Expression
3387 if Token
= Tok_Identifier
then
3388 Save_Scan_State
(Scan_State
); -- at Id
3391 if Token
in Tok_Arrow | Tok_Vertical_Bar
then
3392 Restore_Scan_State
(Scan_State
); -- to Id
3393 Append
(P_Discriminant_Association
, Constr_List
);
3396 Restore_Scan_State
(Scan_State
); -- to Id
3400 -- Otherwise scan out an expression and see what we have got
3402 Expr_Node
:= P_Expression_Or_Range_Attribute
;
3404 if Expr_Form
= EF_Range_Attr
then
3405 Append
(Expr_Node
, Constr_List
);
3407 elsif Token
= Tok_Range
then
3408 if Expr_Form
/= EF_Simple_Name
then
3409 Error_Msg_SC
("subtype mark required before RANGE");
3412 Append
(P_Subtype_Indication
(Expr_Node
), Constr_List
);
3415 -- Check Simple_Expression .. Simple_Expression case
3417 elsif Token
= Tok_Dot_Dot
then
3418 Check_Simple_Expression
(Expr_Node
);
3419 Constr_Node
:= New_Node
(N_Range
, Token_Ptr
);
3420 Set_Low_Bound
(Constr_Node
, Expr_Node
);
3423 -- If the upper bound is given by "<>", this is an index for
3424 -- a fixed-lower-bound subtype, so set the expression to Empty
3425 -- for now (it will be set to the ranges maximum upper bound
3426 -- later during analysis), and scan to the next token.
3428 if Token
= Tok_Box
then
3429 Error_Msg_GNAT_Extension
("fixed-lower-bound array", Token_Ptr
,
3430 Is_Core_Extension
=> True);
3435 -- Otherwise parse the range's upper bound expression
3438 Expr_Node
:= P_Expression
;
3439 Check_Simple_Expression
(Expr_Node
);
3442 Set_High_Bound
(Constr_Node
, Expr_Node
);
3443 Append
(Constr_Node
, Constr_List
);
3446 -- Case of an expression which could be either form
3449 Append
(Expr_Node
, Constr_List
);
3453 -- Here with a single entry scanned
3456 exit when not Comma_Present
;
3462 end P_Index_Or_Discriminant_Constraint
;
3464 -------------------------------------
3465 -- 3.7.1 Discriminant Association --
3466 -------------------------------------
3468 -- DISCRIMINANT_ASSOCIATION ::=
3469 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
3472 -- This routine is used only when the name list is present and the caller
3473 -- has already checked this (by scanning ahead and repositioning the
3476 -- Error_Recovery: cannot raise Error_Resync;
3478 function P_Discriminant_Association
return Node_Id
is
3479 Discr_Node
: Node_Id
;
3480 Names_List
: List_Id
;
3481 Ident_Sloc
: Source_Ptr
;
3484 Ident_Sloc
:= Token_Ptr
;
3485 Names_List
:= New_List
;
3488 Append
(P_Identifier
(C_Vertical_Bar_Arrow
), Names_List
);
3489 exit when Token
/= Tok_Vertical_Bar
;
3493 Discr_Node
:= New_Node
(N_Discriminant_Association
, Ident_Sloc
);
3494 Set_Selector_Names
(Discr_Node
, Names_List
);
3496 Set_Expression
(Discr_Node
, P_Expression
);
3498 end P_Discriminant_Association
;
3500 ---------------------------------
3501 -- 3.8 Record Type Definition --
3502 ---------------------------------
3504 -- RECORD_TYPE_DEFINITION ::=
3505 -- [[abstract] tagged] [limited] RECORD_DEFINITION
3507 -- There is no node in the tree for a record type definition. Instead
3508 -- a record definition node appears, with possible Abstract_Present,
3509 -- Tagged_Present, and Limited_Present flags set appropriately.
3511 ----------------------------
3512 -- 3.8 Record Definition --
3513 ----------------------------
3515 -- RECORD_DEFINITION ::=
3521 -- Note: in the case where a record definition node is used to represent
3522 -- a record type definition, the caller sets the Tagged_Present and
3523 -- Limited_Present flags in the resulting N_Record_Definition node as
3526 -- Note that the RECORD token at the start may be missing in certain
3527 -- error situations, so this function is expected to post the error
3529 -- Error recovery: can raise Error_Resync
3531 function P_Record_Definition
return Node_Id
is
3533 procedure Catch_Out_Of_Order_Keywords
(Keyword
: String);
3534 -- Catch ouf-of-order keywords in a record definition
3536 ---------------------------------
3537 -- Catch_Out_Of_Order_Keywords --
3538 ---------------------------------
3540 procedure Catch_Out_Of_Order_Keywords
(Keyword
: String) is
3543 if Token
= Tok_Abstract
then
3544 Error_Msg_SC
-- CODEFIX
3545 ("ABSTRACT must come before " & Keyword
);
3546 Scan
; -- past ABSTRACT
3548 elsif Token
= Tok_Tagged
then
3549 Error_Msg_SC
-- CODEFIX
3550 ("TAGGED must come before " & Keyword
);
3551 Scan
; -- past TAGGED
3553 elsif Token
= Tok_Limited
then
3554 Error_Msg_SC
-- CODEFIX
3555 ("LIMITED must come before " & Keyword
);
3556 Scan
; -- past LIMITED
3562 end Catch_Out_Of_Order_Keywords
;
3566 -- Start of processing for P_Record_Definition
3569 Inside_Record_Definition
:= True;
3570 Rec_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
3574 if Token
= Tok_Null
then
3577 Catch_Out_Of_Order_Keywords
("NULL");
3579 Set_Null_Present
(Rec_Node
, True);
3580 Catch_Out_Of_Order_Keywords
("RECORD");
3582 -- Catch incomplete declaration to prevent cascaded errors, see
3583 -- ACATS B393002 for an example.
3585 elsif Token
= Tok_Semicolon
then
3586 Error_Msg_AP
("missing record definition");
3588 -- Case starting with RECORD keyword. Build scope stack entry. For the
3589 -- column, we use the first non-blank character on the line, to deal
3590 -- with situations such as:
3596 -- which is not official RM indentation, but is not uncommon usage, and
3597 -- in particular is standard GNAT coding style, so handle it nicely.
3601 Scopes
(Scope
.Last
).Etyp
:= E_Record
;
3602 Scopes
(Scope
.Last
).Ecol
:= Start_Column
;
3603 Scopes
(Scope
.Last
).Sloc
:= Token_Ptr
;
3604 Scopes
(Scope
.Last
).Labl
:= Error
;
3605 Scopes
(Scope
.Last
).Junk
:= (Token
/= Tok_Record
);
3608 Catch_Out_Of_Order_Keywords
("RECORD");
3610 Set_Component_List
(Rec_Node
, P_Component_List
);
3613 exit when Check_End
;
3614 Discard_Junk_Node
(P_Component_List
);
3618 Inside_Record_Definition
:= False;
3620 end P_Record_Definition
;
3622 -------------------------
3623 -- 3.8 Component List --
3624 -------------------------
3626 -- COMPONENT_LIST ::=
3627 -- COMPONENT_ITEM {COMPONENT_ITEM}
3628 -- | {COMPONENT_ITEM} VARIANT_PART
3631 -- Error recovery: cannot raise Error_Resync
3633 function P_Component_List
return Node_Id
is
3634 Component_List_Node
: Node_Id
;
3635 Decls_List
: List_Id
;
3636 Scan_State
: Saved_Scan_State
;
3637 Null_Loc
: Source_Ptr
;
3640 Component_List_Node
:= New_Node
(N_Component_List
, Token_Ptr
);
3641 Decls_List
:= New_List
;
3645 if Token
= Tok_Null
then
3646 Null_Loc
:= Token_Ptr
;
3649 P_Pragmas_Opt
(Decls_List
);
3651 -- If we have an END or WHEN now, everything is fine, otherwise we
3652 -- complain about the null, ignore it, and scan for more components.
3654 if Token
in Tok_End | Tok_When
then
3655 Set_Null_Present
(Component_List_Node
, True);
3656 return Component_List_Node
;
3658 Error_Msg
("NULL component only allowed in null record", Null_Loc
);
3662 -- Scan components for non-null record
3664 P_Pragmas_Opt
(Decls_List
);
3666 if Token
/= Tok_Case
then
3668 P_Component_Items
(Decls_List
);
3669 P_Pragmas_Opt
(Decls_List
);
3671 exit when Token
in Tok_End | Tok_Case | Tok_When
;
3673 -- We are done if we do not have an identifier. However, if we
3674 -- have a misspelled reserved identifier that is in a column to
3675 -- the right of the record definition, we will treat it as an
3676 -- identifier. It turns out to be too dangerous in practice to
3677 -- accept such a mis-spelled identifier which does not have this
3678 -- additional clue that confirms the incorrect spelling.
3680 if Token
/= Tok_Identifier
then
3681 if Start_Column
> Scopes
(Scope
.Last
).Ecol
3682 and then Is_Reserved_Identifier
3684 Save_Scan_State
(Scan_State
); -- at reserved id
3685 Scan
; -- possible reserved id
3687 if Token
in Tok_Comma | Tok_Colon
then
3688 Restore_Scan_State
(Scan_State
);
3689 Scan_Reserved_Identifier
(Force_Msg
=> True);
3691 -- Note reserved identifier used as field name after all
3692 -- because not followed by colon or comma.
3695 Restore_Scan_State
(Scan_State
);
3699 -- Non-identifier that definitely was not reserved id
3708 if Token
= Tok_Case
then
3709 Set_Variant_Part
(Component_List_Node
, P_Variant_Part
);
3711 -- Check for junk after variant part
3713 if Token
= Tok_Identifier
then
3714 Save_Scan_State
(Scan_State
);
3715 Scan
; -- past identifier
3717 if Token
= Tok_Colon
then
3718 Restore_Scan_State
(Scan_State
);
3719 Error_Msg_SC
("component may not follow variant part");
3720 Discard_Junk_Node
(P_Component_List
);
3722 elsif Token
= Tok_Case
then
3723 Restore_Scan_State
(Scan_State
);
3724 Error_Msg_SC
("only one variant part allowed in a record");
3725 Discard_Junk_Node
(P_Component_List
);
3728 Restore_Scan_State
(Scan_State
);
3733 Set_Component_Items
(Component_List_Node
, Decls_List
);
3734 return Component_List_Node
;
3735 end P_Component_List
;
3737 -------------------------
3738 -- 3.8 Component Item --
3739 -------------------------
3741 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
3743 -- COMPONENT_DECLARATION ::=
3744 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
3745 -- [:= DEFAULT_EXPRESSION]
3746 -- [ASPECT_SPECIFICATIONS];
3748 -- COMPONENT_DEFINITION ::=
3749 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
3751 -- Error recovery: cannot raise Error_Resync, if an error occurs,
3752 -- the scan is positioned past the following semicolon.
3754 -- Note: we do not yet allow representation clauses to appear as component
3755 -- items, do we need to add this capability sometime in the future ???
3757 procedure P_Component_Items
(Decls
: List_Id
) is
3758 Aliased_Present
: Boolean := False;
3759 CompDef_Node
: Node_Id
;
3760 Decl_Node
: Node_Id
:= Empty
; -- initialize to prevent warning
3761 Scan_State
: Saved_Scan_State
;
3762 Not_Null_Present
: Boolean := False;
3765 Ident_Sloc
: Source_Ptr
;
3767 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
3768 -- This array holds the list of defining identifiers. The upper bound
3769 -- of 4096 is intended to be essentially infinite, and we do not even
3770 -- bother to check for it being exceeded.
3773 if Token
/= Tok_Identifier
then
3774 Error_Msg_SC
("component declaration expected");
3775 Resync_Past_Semicolon
;
3779 Ident_Sloc
:= Token_Ptr
;
3781 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
3784 while Comma_Present
loop
3785 Num_Idents
:= Num_Idents
+ 1;
3786 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
3789 -- If there are multiple identifiers, we repeatedly scan the
3790 -- type and initialization expression information by resetting
3791 -- the scan pointer (so that we get completely separate trees
3792 -- for each occurrence).
3794 if Num_Idents
> 1 then
3795 Save_Scan_State
(Scan_State
);
3800 -- Loop through defining identifiers in list
3805 -- The following block is present to catch Error_Resync
3806 -- which causes the parse to be reset past the semicolon
3809 Decl_Node
:= New_Node
(N_Component_Declaration
, Ident_Sloc
);
3810 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
3812 if Token
= Tok_Constant
then
3813 Error_Msg_SC
("constant component not permitted");
3817 CompDef_Node
:= New_Node
(N_Component_Definition
, Token_Ptr
);
3819 if Token_Name
= Name_Aliased
then
3820 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
3823 if Token
= Tok_Aliased
then
3824 Aliased_Present
:= True;
3825 Scan
; -- past ALIASED
3828 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/AI-254)
3830 -- Ada 2005 (AI-230): Access Definition case
3832 if Token
= Tok_Access
then
3833 Error_Msg_Ada_2005_Extension
3834 ("generalized use of anonymous access types");
3836 -- AI95-406 makes "aliased" legal (and useless) here, so the
3837 -- following code which used to be required is commented out.
3839 -- if Aliased_Present then
3840 -- Error_Msg_SP ("ALIASED not allowed here");
3843 Set_Subtype_Indication
(CompDef_Node
, Empty
);
3844 Set_Aliased_Present
(CompDef_Node
, False);
3845 Set_Access_Definition
(CompDef_Node
,
3846 P_Access_Definition
(Not_Null_Present
));
3849 Set_Access_Definition
(CompDef_Node
, Empty
);
3850 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
3851 Set_Null_Exclusion_Present
(CompDef_Node
, Not_Null_Present
);
3853 if Token
= Tok_Array
then
3854 Error_Msg_SC
("anonymous array not allowed as component");
3858 Set_Subtype_Indication
(CompDef_Node
,
3859 P_Subtype_Indication
(Not_Null_Present
));
3862 Set_Component_Definition
(Decl_Node
, CompDef_Node
);
3863 Set_Expression
(Decl_Node
, Init_Expr_Opt
);
3866 Set_Prev_Ids
(Decl_Node
, True);
3869 if Ident
< Num_Idents
then
3870 Set_More_Ids
(Decl_Node
, True);
3873 P_Aspect_Specifications
(Decl_Node
, Semicolon
=> True);
3875 Append
(Decl_Node
, Decls
);
3877 when Error_Resync
=>
3878 if Token
/= Tok_End
then
3879 Resync_Past_Semicolon
;
3883 exit Ident_Loop
when Ident
= Num_Idents
;
3885 Restore_Scan_State
(Scan_State
);
3887 end loop Ident_Loop
;
3888 end P_Component_Items
;
3890 --------------------------------
3891 -- 3.8 Component Declaration --
3892 --------------------------------
3894 -- Parsed by P_Component_Items (3.8)
3896 -------------------------
3897 -- 3.8.1 Variant Part --
3898 -------------------------
3901 -- case discriminant_DIRECT_NAME is
3906 -- The caller has checked that the initial token is CASE
3908 -- Error recovery: cannot raise Error_Resync
3910 function P_Variant_Part
return Node_Id
is
3911 Variant_Part_Node
: Node_Id
;
3912 Variants_List
: List_Id
;
3913 Case_Node
: Node_Id
;
3916 Variant_Part_Node
:= New_Node
(N_Variant_Part
, Token_Ptr
);
3918 Scopes
(Scope
.Last
).Etyp
:= E_Case
;
3919 Scopes
(Scope
.Last
).Sloc
:= Token_Ptr
;
3920 Scopes
(Scope
.Last
).Ecol
:= Start_Column
;
3923 Case_Node
:= P_Expression
;
3924 Set_Name
(Variant_Part_Node
, Case_Node
);
3926 if Nkind
(Case_Node
) /= N_Identifier
then
3927 Set_Name
(Variant_Part_Node
, Error
);
3928 Error_Msg
("discriminant name expected", Sloc
(Case_Node
));
3930 elsif Paren_Count
(Case_Node
) /= 0 then
3932 ("|discriminant name may not be parenthesized",
3934 Set_Paren_Count
(Case_Node
, 0);
3938 Variants_List
:= New_List
;
3939 P_Pragmas_Opt
(Variants_List
);
3941 -- Test missing variant
3943 if Token
= Tok_End
then
3944 Error_Msg_BC
("WHEN expected (must have at least one variant)");
3946 Append
(P_Variant
, Variants_List
);
3949 -- Loop through variants, note that we allow if in place of when,
3950 -- this error will be detected and handled in P_Variant.
3953 P_Pragmas_Opt
(Variants_List
);
3955 if Token
not in Tok_When | Tok_If | Tok_Others
then
3956 exit when Check_End
;
3959 Append
(P_Variant
, Variants_List
);
3962 Set_Variants
(Variant_Part_Node
, Variants_List
);
3963 return Variant_Part_Node
;
3966 --------------------
3968 --------------------
3971 -- when DISCRETE_CHOICE_LIST =>
3974 -- Error recovery: cannot raise Error_Resync
3976 -- The initial token on entry is either WHEN, IF or OTHERS
3978 function P_Variant
return Node_Id
is
3979 Variant_Node
: Node_Id
;
3982 -- Special check to recover nicely from use of IF in place of WHEN
3984 if Token
= Tok_If
then
3991 Variant_Node
:= New_Node
(N_Variant
, Prev_Token_Ptr
);
3992 Set_Discrete_Choices
(Variant_Node
, P_Discrete_Choice_List
);
3994 Set_Component_List
(Variant_Node
, P_Component_List
);
3995 return Variant_Node
;
3998 ---------------------------------
3999 -- 3.8.1 Discrete Choice List --
4000 ---------------------------------
4002 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
4004 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
4006 -- Note: in Ada 83, the expression must be a simple expression
4008 -- Error recovery: cannot raise Error_Resync
4010 function P_Discrete_Choice_List
return List_Id
is
4012 Expr_Node
: Node_Id
:= Empty
; -- initialize to prevent warning
4013 Choice_Node
: Node_Id
;
4016 Choices
:= New_List
;
4018 if Token
= Tok_Others
then
4019 Append
(New_Node
(N_Others_Choice
, Token_Ptr
), Choices
);
4020 Scan
; -- past OTHERS
4024 -- Scan out expression or range attribute
4026 Expr_Node
:= P_Expression_Or_Range_Attribute
;
4027 Ignore
(Tok_Right_Paren
);
4029 if Token
= Tok_Colon
4030 and then Nkind
(Expr_Node
) = N_Identifier
4032 Error_Msg_SP
("label not permitted in this context");
4037 elsif Expr_Form
= EF_Range_Attr
then
4038 Append
(Expr_Node
, Choices
);
4042 elsif Token
= Tok_Dot_Dot
then
4043 Check_Simple_Expression
(Expr_Node
);
4044 Choice_Node
:= New_Node
(N_Range
, Token_Ptr
);
4045 Set_Low_Bound
(Choice_Node
, Expr_Node
);
4047 Expr_Node
:= P_Expression_No_Right_Paren
;
4048 Check_Simple_Expression
(Expr_Node
);
4049 Set_High_Bound
(Choice_Node
, Expr_Node
);
4050 Append
(Choice_Node
, Choices
);
4052 -- Simple name, must be subtype, so range allowed
4054 elsif Expr_Form
= EF_Simple_Name
then
4055 if Token
= Tok_Range
then
4056 Append
(P_Subtype_Indication
(Expr_Node
), Choices
);
4058 elsif Token
in Token_Class_Consk
then
4060 ("the only constraint allowed here " &
4061 "is a range constraint");
4062 Discard_Junk_Node
(P_Constraint_Opt
);
4063 Append
(Expr_Node
, Choices
);
4066 Append
(Expr_Node
, Choices
);
4072 -- In Ada 2012 mode, the expression must be a simple
4073 -- expression. The reason for this restriction (i.e. going
4074 -- back to the Ada 83 rule) is to avoid ambiguities when set
4075 -- membership operations are allowed, consider the
4078 -- when A in 1 .. 10 | 12 =>
4080 -- This is ambiguous without parentheses, so we require one
4081 -- of the following two parenthesized forms to disambiguate:
4083 -- one of the following:
4085 -- when (A in 1 .. 10 | 12) =>
4086 -- when (A in 1 .. 10) | 12 =>
4088 -- To solve this, in Ada 2012 mode, we disallow the use of
4089 -- membership operations in expressions in choices.
4091 -- Technically in the grammar, the expression must match the
4092 -- grammar for restricted expression.
4094 if Ada_Version
>= Ada_2012
then
4095 Check_Restricted_Expression
(Expr_Node
);
4097 -- In Ada 83 mode, the syntax required a simple expression
4100 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
4103 Append
(Expr_Node
, Choices
);
4107 when Error_Resync
=>
4113 if Token
= Tok_Comma
then
4114 if Nkind
(Expr_Node
) = N_Iterated_Component_Association
then
4120 if Token
= Tok_Vertical_Bar
then
4121 Error_Msg_SP
-- CODEFIX
4122 ("|extra "","" ignored");
4126 Error_Msg_SP
-- CODEFIX
4127 (""","" should be ""'|""");
4131 exit when Token
/= Tok_Vertical_Bar
;
4138 end P_Discrete_Choice_List
;
4140 ----------------------------
4141 -- 3.8.1 Discrete Choice --
4142 ----------------------------
4144 -- Parsed by P_Discrete_Choice_List (3.8.1)
4146 ----------------------------------
4147 -- 3.9.1 Record Extension Part --
4148 ----------------------------------
4150 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
4152 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
4154 --------------------------------------
4155 -- 3.9.4 Interface Type Definition --
4156 --------------------------------------
4158 -- INTERFACE_TYPE_DEFINITION ::=
4159 -- [limited | task | protected | synchronized] interface
4160 -- [and INTERFACE_LIST]
4162 -- Error recovery: cannot raise Error_Resync
4164 function P_Interface_Type_Definition
4165 (Abstract_Present
: Boolean) return Node_Id
4167 Typedef_Node
: Node_Id
;
4170 Error_Msg_Ada_2005_Extension
("abstract interface");
4172 if Abstract_Present
then
4174 ("ABSTRACT not allowed in interface type definition " &
4178 Scan
; -- past INTERFACE
4180 -- Ada 2005 (AI-345): In case of interfaces with a null list of
4181 -- interfaces we build a record_definition node.
4183 if Token
= Tok_Semicolon
or else Aspect_Specifications_Present
then
4184 Typedef_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
4186 Set_Abstract_Present
(Typedef_Node
);
4187 Set_Tagged_Present
(Typedef_Node
);
4188 Set_Null_Present
(Typedef_Node
);
4189 Set_Interface_Present
(Typedef_Node
);
4191 -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have
4192 -- a list of interfaces we build a derived_type_definition node. This
4193 -- simplifies the semantic analysis (and hence further maintenance)
4196 if Token
/= Tok_And
then
4197 Error_Msg_AP
("AND expected");
4202 Typedef_Node
:= New_Node
(N_Derived_Type_Definition
, Token_Ptr
);
4204 Set_Abstract_Present
(Typedef_Node
);
4205 Set_Interface_Present
(Typedef_Node
);
4206 Set_Subtype_Indication
(Typedef_Node
, P_Qualified_Simple_Name
);
4208 Set_Record_Extension_Part
(Typedef_Node
,
4209 New_Node
(N_Record_Definition
, Token_Ptr
));
4210 Set_Null_Present
(Record_Extension_Part
(Typedef_Node
));
4212 if Token
= Tok_And
then
4213 Set_Interface_List
(Typedef_Node
, New_List
);
4217 Append
(P_Qualified_Simple_Name
,
4218 Interface_List
(Typedef_Node
));
4219 exit when Token
/= Tok_And
;
4225 return Typedef_Node
;
4226 end P_Interface_Type_Definition
;
4228 ----------------------------------
4229 -- 3.10 Access Type Definition --
4230 ----------------------------------
4232 -- ACCESS_TYPE_DEFINITION ::=
4233 -- ACCESS_TO_OBJECT_DEFINITION
4234 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
4236 -- ACCESS_TO_OBJECT_DEFINITION ::=
4237 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
4239 -- GENERAL_ACCESS_MODIFIER ::= all | constant
4241 -- ACCESS_TO_SUBPROGRAM_DEFINITION
4242 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
4243 -- | [NULL_EXCLUSION] access [protected] function
4244 -- PARAMETER_AND_RESULT_PROFILE
4246 -- PARAMETER_PROFILE ::= [FORMAL_PART]
4248 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
4250 -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already
4251 -- parsed the null_exclusion part and has also removed the ACCESS token;
4252 -- otherwise the caller has just checked that the initial token is ACCESS
4254 -- Error recovery: can raise Error_Resync
4256 function P_Access_Type_Definition
4257 (Header_Already_Parsed
: Boolean := False) return Node_Id
4259 procedure Check_Junk_Subprogram_Name
;
4260 -- Used in access to subprogram definition cases to check for an
4261 -- identifier or operator symbol that does not belong.
4263 --------------------------------
4264 -- Check_Junk_Subprogram_Name --
4265 --------------------------------
4267 procedure Check_Junk_Subprogram_Name
is
4268 Saved_State
: Saved_Scan_State
;
4271 if Token
in Tok_Identifier | Tok_Operator_Symbol
then
4272 Save_Scan_State
(Saved_State
);
4273 Scan
; -- past possible junk subprogram name
4275 if Token
in Tok_Left_Paren | Tok_Semicolon
then
4276 Error_Msg_SP
("unexpected subprogram name ignored");
4278 Restore_Scan_State
(Saved_State
);
4281 end Check_Junk_Subprogram_Name
;
4283 Access_Loc
: constant Source_Ptr
:= Token_Ptr
;
4284 Prot_Flag
: Boolean;
4285 Not_Null_Present
: Boolean := False;
4286 Not_Null_Subtype
: Boolean := False;
4287 Not_Null_Subtype_Loc
: Source_Ptr
; -- loc of second "not null"
4288 Type_Def_Node
: Node_Id
;
4289 Result_Not_Null
: Boolean;
4290 Result_Node
: Node_Id
;
4292 -- Start of processing for P_Access_Type_Definition
4295 if not Header_Already_Parsed
then
4296 -- NOT NULL ACCESS... is a common form of access definition. ACCESS
4297 -- NOT NULL... is certainly rare, but syntactically legal. NOT NULL
4298 -- ACCESS NOT NULL... is rarer yet, and also legal. The last two
4299 -- cases are only meaningful if the following subtype indication
4300 -- denotes an access type. We check below for "not null procedure"
4301 -- and "not null function"; in the access-to-object case it is a
4302 -- semantic check. The flag Not_Null_Subtype indicates that this
4303 -- second null exclusion is present in the access type definition.
4305 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
4307 if Token
/= Tok_Access
then
4313 Scan
; -- past ACCESS
4315 Not_Null_Subtype_Loc
:= Token_Ptr
;
4316 Not_Null_Subtype
:= P_Null_Exclusion
; -- Might also appear
4319 if Token_Name
= Name_Protected
then
4320 Check_95_Keyword
(Tok_Protected
, Tok_Procedure
);
4321 Check_95_Keyword
(Tok_Protected
, Tok_Function
);
4324 Prot_Flag
:= (Token
= Tok_Protected
);
4327 Scan
; -- past PROTECTED
4329 if Token
not in Tok_Procedure | Tok_Function
then
4330 Error_Msg_SC
-- CODEFIX
4331 ("FUNCTION or PROCEDURE expected");
4335 -- Access-to-subprogram case
4337 if Token
in Tok_Procedure | Tok_Function
then
4339 -- Check for "not null [protected] procedure" and "not null
4340 -- [protected] function".
4342 if Not_Null_Subtype
then
4344 ("null exclusion must apply to access type",
4345 Not_Null_Subtype_Loc
);
4349 if Token
= Tok_Procedure
then
4350 if Ada_Version
= Ada_83
then
4351 Error_Msg_SC
("(Ada 83) access to procedure not allowed!");
4354 Type_Def_Node
:= New_Node
(N_Access_Procedure_Definition
, Access_Loc
);
4355 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
4356 Scan
; -- past PROCEDURE
4357 Check_Junk_Subprogram_Name
;
4358 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
4359 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
4361 elsif Token
= Tok_Function
then
4362 if Ada_Version
= Ada_83
then
4363 Error_Msg_SC
("(Ada 83) access to function not allowed!");
4366 Type_Def_Node
:= New_Node
(N_Access_Function_Definition
, Access_Loc
);
4367 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
4368 Scan
; -- past FUNCTION
4369 Check_Junk_Subprogram_Name
;
4370 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
4371 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
4374 Result_Not_Null
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
4376 -- Ada 2005 (AI-318-02)
4378 if Token
= Tok_Access
then
4379 Error_Msg_Ada_2005_Extension
("anonymous access result type");
4381 Result_Node
:= P_Access_Definition
(Result_Not_Null
);
4384 Result_Node
:= P_Subtype_Mark
;
4387 -- A null exclusion on the result type must be recorded in a flag
4388 -- distinct from the one used for the access-to-subprogram type's
4391 Set_Null_Exclusion_In_Return_Present
4392 (Type_Def_Node
, Result_Not_Null
);
4395 Set_Result_Definition
(Type_Def_Node
, Result_Node
);
4397 -- Access-to-object case
4400 Type_Def_Node
:= New_Node
(N_Access_To_Object_Definition
, Access_Loc
);
4401 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
4402 Set_Null_Excluding_Subtype
(Type_Def_Node
, Not_Null_Subtype
);
4404 if Token
in Tok_All | Tok_Constant
then
4405 if Ada_Version
= Ada_83
then
4406 Error_Msg_SC
("(Ada 83) access modifier not allowed!");
4409 if Token
= Tok_All
then
4410 Set_All_Present
(Type_Def_Node
, True);
4413 Set_Constant_Present
(Type_Def_Node
, True);
4416 Scan
; -- past ALL or CONSTANT
4419 Set_Subtype_Indication
(Type_Def_Node
,
4420 P_Subtype_Indication
(Not_Null_Present
));
4423 return Type_Def_Node
;
4424 end P_Access_Type_Definition
;
4426 ---------------------------------------
4427 -- 3.10 Access To Object Definition --
4428 ---------------------------------------
4430 -- Parsed by P_Access_Type_Definition (3.10)
4432 -----------------------------------
4433 -- 3.10 General Access Modifier --
4434 -----------------------------------
4436 -- Parsed by P_Access_Type_Definition (3.10)
4438 -------------------------------------------
4439 -- 3.10 Access To Subprogram Definition --
4440 -------------------------------------------
4442 -- Parsed by P_Access_Type_Definition (3.10)
4444 -----------------------------
4445 -- 3.10 Access Definition --
4446 -----------------------------
4448 -- ACCESS_DEFINITION ::=
4449 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
4450 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
4452 -- ACCESS_TO_SUBPROGRAM_DEFINITION
4453 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
4454 -- | [NULL_EXCLUSION] access [protected] function
4455 -- PARAMETER_AND_RESULT_PROFILE
4457 -- The caller has parsed the null-exclusion part and it has also checked
4458 -- that the next token is ACCESS
4460 -- Error recovery: cannot raise Error_Resync
4462 function P_Access_Definition
4463 (Null_Exclusion_Present
: Boolean) return Node_Id
4466 Subp_Node
: Node_Id
;
4469 Def_Node
:= New_Node
(N_Access_Definition
, Token_Ptr
);
4470 Scan
; -- past ACCESS
4472 -- Ada 2005 (AI-254): Access_To_Subprogram_Definition
4474 if Token
in Tok_Protected | Tok_Procedure | Tok_Function
then
4475 Error_Msg_Ada_2005_Extension
("access-to-subprogram");
4477 Subp_Node
:= P_Access_Type_Definition
(Header_Already_Parsed
=> True);
4478 Set_Null_Exclusion_Present
(Subp_Node
, Null_Exclusion_Present
);
4479 Set_Access_To_Subprogram_Definition
(Def_Node
, Subp_Node
);
4481 -- Ada 2005 (AI-231)
4482 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
4485 Set_Null_Exclusion_Present
(Def_Node
, Null_Exclusion_Present
);
4487 if Token
= Tok_All
then
4488 if Ada_Version
< Ada_2005
then
4490 ("ALL not permitted for anonymous access type");
4494 Set_All_Present
(Def_Node
);
4496 elsif Token
= Tok_Constant
then
4497 Error_Msg_Ada_2005_Extension
("access-to-constant");
4499 Scan
; -- past CONSTANT
4500 Set_Constant_Present
(Def_Node
);
4503 Set_Subtype_Mark
(Def_Node
, P_Subtype_Mark
);
4508 end P_Access_Definition
;
4510 -----------------------------------------
4511 -- 3.10.1 Incomplete Type Declaration --
4512 -----------------------------------------
4514 -- Parsed by P_Type_Declaration (3.2.1)
4516 ----------------------------
4517 -- 3.11 Declarative Part --
4518 ----------------------------
4520 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
4522 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Item
4523 -- handles errors, and returns cleanly after an error has occurred)
4525 function P_Declarative_Part
return List_Id
is
4526 Decls
: constant List_Id
:= New_List
;
4528 -- Indicate no bad declarations detected yet. This will be reset by
4529 -- P_Declarative_Items if a bad declaration is discovered.
4531 Missing_Begin_Msg
:= No_Error_Msg
;
4533 -- Get rid of active SIS entry from outer scope. This means we will
4534 -- miss some nested cases, but it doesn't seem worth the effort. See
4535 -- discussion in Par for further details
4537 SIS_Entry_Active
:= False;
4540 (Decls
, Declare_Expression
=> False,
4541 In_Spec
=> False, In_Statements
=> False);
4543 -- Get rid of active SIS entry which is left set only if we scanned a
4544 -- procedure declaration and have not found the body. We could give
4545 -- an error message, but that really would be usurping the role of
4546 -- semantic analysis (this really is a missing body case).
4548 SIS_Entry_Active
:= False;
4550 end P_Declarative_Part
;
4552 ----------------------------
4553 -- 3.11 Declarative Item --
4554 ----------------------------
4556 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
4558 -- Can return Error if a junk declaration is found, or Empty if no
4559 -- declaration is found (i.e. a token ending declarations, such as
4560 -- BEGIN or END is encountered).
4562 -- Error recovery: cannot raise Error_Resync. If an error resync occurs,
4563 -- then the scan is set past the next semicolon and Error is returned.
4565 procedure P_Declarative_Item
4568 Declare_Expression
: Boolean;
4570 In_Statements
: Boolean)
4572 Scan_State
: Saved_Scan_State
;
4577 -- In -gnatg mode, we don't want a "bad indentation" error inside a
4578 -- declare_expression.
4580 if Style_Check
and not Declare_Expression
then
4581 Style
.Check_Indentation
;
4591 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4596 -- Check for loop (premature statement)
4598 Save_Scan_State
(Scan_State
);
4602 Is_Statement
: Boolean := True;
4604 if Token
= Tok_Identifier
then
4605 Scan
; -- past identifier
4606 if Token
in Tok_Use | Tok_Apostrophe
then
4607 Is_Statement
:= False;
4608 elsif Token
= Tok_Dot
then
4610 if Token
= Tok_Identifier
then
4612 Is_Statement
:= Token
in Tok_In | Tok_Of
;
4616 Is_Statement
:= False;
4619 Restore_Scan_State
(Scan_State
);
4621 if Is_Statement
then
4622 if not In_Statements
then
4623 Statement_When_Declaration_Expected
4624 (Decls
, Done
, In_Spec
);
4629 Append
(P_Representation_Clause
, Decls
);
4635 Append
(P_Generic
, Decls
);
4637 when Tok_Identifier
=>
4640 -- Special check for misuse of overriding not in Ada 2005 mode
4642 if Token_Name
= Name_Overriding
4643 and then not Next_Token_Is
(Tok_Colon
)
4645 Error_Msg_SC
("overriding indicator is an Ada 2005 extension");
4646 Error_Msg_SC
("\unit must be compiled with -gnat05 switch");
4648 Token
:= Tok_Overriding
;
4649 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4651 -- Normal case, no overriding, or overriding followed by colon
4654 P_Identifier_Declarations
(Decls
, Done
, In_Spec
, In_Statements
);
4659 Append
(P_Package
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4662 -- If we see a pragma and In_Statements is true, we want to let
4663 -- the statement-parser deal with it.
4665 if In_Statements
then
4668 Append
(P_Pragma
, Decls
);
4671 when Tok_Protected
=>
4673 Scan
; -- past PROTECTED
4674 Append
(P_Protected
, Decls
);
4678 Append
(P_Subtype_Declaration
, Decls
);
4683 Append
(P_Task
, Decls
);
4687 Append
(P_Type_Declaration
, Decls
);
4691 P_Use_Clause
(Decls
);
4696 if Aspect_Specifications_Present
(Strict
=> True) then
4698 -- If we are after a semicolon, complain that it was ignored.
4699 -- But we don't really ignore it, since we dump the aspects,
4700 -- so we make the error message a normal fatal message which
4701 -- will inhibit semantic analysis anyway).
4703 if Prev_Token
= Tok_Semicolon
then
4704 Error_Msg_SP
-- CODEFIX
4705 ("extra "";"" ignored");
4707 -- If not just past semicolon, just complain that aspects are
4708 -- not allowed at this point.
4711 Error_Msg_SC
("aspect specifications not allowed here");
4714 -- Assume that this is a misplaced aspect specification within
4715 -- a declarative list. After discarding the misplaced aspects
4716 -- we can continue the scan.
4719 Dummy_Node
: constant Node_Id
:=
4720 New_Node
(N_Package_Specification
, Token_Ptr
);
4721 pragma Warnings
(Off
, Dummy_Node
);
4722 -- Dummy node to attach aspect specifications to. We will
4723 -- then throw them away.
4726 P_Aspect_Specifications
(Dummy_Node
, Semicolon
=> True);
4729 -- Here if not aspect specifications case
4732 Error_Msg_SC
("WITH can only appear in context clause");
4736 -- BEGIN terminates the scan of a sequence of declarations unless
4737 -- there is a missing subprogram body, see section on handling
4738 -- semicolon in place of IS. We only treat the begin as satisfying
4739 -- the subprogram declaration if it falls in the expected column
4743 if SIS_Entry_Active
and then Start_Column
>= SIS_Ecol
then
4745 -- Here we have the case where a BEGIN is encountered during
4746 -- declarations in a declarative part, or at the outer level,
4747 -- and there is a subprogram declaration outstanding for which
4748 -- no body has been supplied. This is the case where we assume
4749 -- that the semicolon in the subprogram declaration should
4750 -- really have been is. The active SIS entry describes the
4751 -- subprogram declaration. On return the declaration has been
4752 -- modified to become a body.
4755 Specification_Node
: Node_Id
;
4756 Decl_Node
: Node_Id
;
4757 Body_Node
: Node_Id
;
4760 -- First issue the error message. If we had a missing
4761 -- semicolon in the declaration, then change the message
4762 -- to <missing "is">
4764 if SIS_Missing_Semicolon_Message
/= No_Error_Msg
then
4765 Change_Error_Text
-- Replace: "missing "";"" "
4766 (SIS_Missing_Semicolon_Message
, "missing ""is""");
4768 -- Otherwise we saved the semicolon position, so complain
4771 Error_Msg
-- CODEFIX
4772 ("|"";"" should be IS", SIS_Semicolon_Sloc
);
4775 -- The next job is to fix up any declarations that occurred
4776 -- between the procedure header and the BEGIN. These got
4777 -- chained to the outer declarative region (immediately
4778 -- after the procedure declaration) and they should be
4779 -- chained to the subprogram itself, which is a body
4780 -- rather than a spec.
4782 Specification_Node
:= Specification
(SIS_Declaration_Node
);
4783 Change_Node
(SIS_Declaration_Node
, N_Subprogram_Body
);
4784 Body_Node
:= SIS_Declaration_Node
;
4785 Set_Specification
(Body_Node
, Specification_Node
);
4786 Set_Declarations
(Body_Node
, New_List
);
4789 Decl_Node
:= Remove_Next
(Body_Node
);
4790 exit when Decl_Node
= Empty
;
4791 Append
(Decl_Node
, Declarations
(Body_Node
));
4794 -- Now make the scope table entry for the Begin-End and
4798 Scopes
(Scope
.Last
).Sloc
:= SIS_Sloc
;
4799 Scopes
(Scope
.Last
).Etyp
:= E_Name
;
4800 Scopes
(Scope
.Last
).Ecol
:= SIS_Ecol
;
4801 Scopes
(Scope
.Last
).Labl
:= SIS_Labl
;
4802 Scopes
(Scope
.Last
).Lreq
:= False;
4803 SIS_Entry_Active
:= False;
4805 Set_Handled_Statement_Sequence
(Body_Node
,
4806 P_Handled_Sequence_Of_Statements
);
4807 End_Statements
(Handled_Statement_Sequence
(Body_Node
));
4814 -- Normally an END terminates the scan for basic declarative items.
4815 -- The one exception is END RECORD, which is probably left over from
4819 Save_Scan_State
(Scan_State
); -- at END
4822 if Token
= Tok_Record
then
4823 Error_Msg_SP
("no RECORD for this `end record`!");
4824 Scan
; -- past RECORD
4827 -- This might happen because of misplaced aspect specification.
4828 -- After discarding the misplaced aspects we can continue the
4832 Restore_Scan_State
(Scan_State
); -- to END
4836 -- The following tokens which can only be the start of a statement
4837 -- are considered to end a declarative part (i.e. we have a missing
4838 -- BEGIN situation). We are fairly conservative in making this
4839 -- judgment, because it is a real mess to go into statement mode
4840 -- prematurely in response to a junk declaration.
4855 -- If we parsing declarations in a sequence of statements, we want
4856 -- to let the caller continue parsing statements.
4858 if In_Statements
then
4861 -- Otherwise, give an error. But before we decide that it's a
4862 -- statement, check for a reserved word misused as an identifier.
4864 elsif Is_Reserved_Identifier
then
4865 Save_Scan_State
(Scan_State
);
4866 Scan
; -- past the token
4868 -- If reserved identifier not followed by colon or comma, then
4869 -- this is most likely an assignment statement to the bad id.
4871 if Token
not in Tok_Colon | Tok_Comma
then
4872 Restore_Scan_State
(Scan_State
);
4873 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4875 -- Otherwise we have a declaration of the bad id
4878 Restore_Scan_State
(Scan_State
);
4879 Scan_Reserved_Identifier
(Force_Msg
=> True);
4880 P_Identifier_Declarations
4881 (Decls
, Done
, In_Spec
, In_Statements
);
4884 -- If not reserved identifier, then it's an incorrectly placed a
4888 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4891 -- The token RETURN may well also signal a missing BEGIN situation,
4892 -- however, we never let it end the declarative part, because it
4893 -- might also be part of a half-baked function declaration. If we are
4894 -- In_Statements, then let the caller parse it; otherwise, it's an
4898 if In_Statements
then
4901 Error_Msg_SC
("misplaced RETURN statement");
4905 -- PRIVATE definitely terminates the declarations in a spec,
4906 -- and is an error in a body.
4912 Error_Msg_SC
("PRIVATE not allowed in body");
4913 Scan
; -- past PRIVATE
4916 -- An end of file definitely terminates the declarations
4921 -- The remaining tokens do not end the scan, but cannot start a
4922 -- valid declaration, so we signal an error and resynchronize.
4923 -- But first check for misuse of a reserved identifier.
4926 if In_Statements
then
4931 -- Here we check for a reserved identifier
4933 if Is_Reserved_Identifier
then
4934 Save_Scan_State
(Scan_State
);
4935 Scan
; -- past the token
4937 if Token
not in Tok_Colon | Tok_Comma
then
4938 Restore_Scan_State
(Scan_State
);
4939 Set_Declaration_Expected
;
4942 Restore_Scan_State
(Scan_State
);
4943 Scan_Reserved_Identifier
(Force_Msg
=> True);
4945 P_Identifier_Declarations
4946 (Decls
, Done
, In_Spec
, In_Statements
);
4950 Set_Declaration_Expected
;
4955 -- To resynchronize after an error, we scan to the next semicolon and
4956 -- return with Done = False, indicating that there may still be more
4957 -- valid declarations to come.
4960 when Error_Resync
=>
4961 Resync_Past_Semicolon
;
4962 end P_Declarative_Item
;
4964 procedure P_Declarative_Items
4966 Declare_Expression
: Boolean;
4968 In_Statements
: Boolean)
4974 (Decls
, Done
, Declare_Expression
, In_Spec
, In_Statements
);
4977 end P_Declarative_Items
;
4979 ----------------------------------
4980 -- 3.11 Basic Declarative Item --
4981 ----------------------------------
4983 -- BASIC_DECLARATIVE_ITEM ::=
4984 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
4986 -- Scan zero or more basic declarative items
4988 -- Error recovery: cannot raise Error_Resync. If an error is detected, then
4989 -- the scan pointer is repositioned past the next semicolon, and the scan
4990 -- for declarative items continues.
4992 function P_Basic_Declarative_Items
4993 (Declare_Expression
: Boolean) return List_Id
4996 Decls
: constant List_Id
:= New_List
;
5000 -- Indicate no bad declarations detected yet in the current context:
5001 -- visible or private declarations of a package spec.
5003 Missing_Begin_Msg
:= No_Error_Msg
;
5005 -- Get rid of active SIS entry from outer scope. This means we will
5006 -- miss some nested cases, but it doesn't seem worth the effort. See
5007 -- discussion in Par for further details
5009 SIS_Entry_Active
:= False;
5012 (Decls
, Declare_Expression
, In_Spec
=> True, In_Statements
=> False);
5014 -- Get rid of active SIS entry. This is set only if we have scanned a
5015 -- procedure declaration and have not found the body. We could give
5016 -- an error message, but that really would be usurping the role of
5017 -- semantic analysis (this really is a case of a missing body).
5019 SIS_Entry_Active
:= False;
5021 -- Test for assorted illegal declarations not diagnosed elsewhere
5023 Decl
:= First
(Decls
);
5025 while Present
(Decl
) loop
5026 Kind
:= Nkind
(Decl
);
5028 -- Test for body scanned, not acceptable as basic decl item
5030 if Kind
= N_Subprogram_Body
or else
5031 Kind
= N_Package_Body
or else
5032 Kind
= N_Task_Body
or else
5033 Kind
= N_Protected_Body
5035 if Declare_Expression
then
5037 ("proper body not allowed in declare_expression",
5041 ("proper body not allowed in package spec",
5045 -- Complete declaration of mangled subprogram body, for better
5046 -- recovery if analysis is attempted.
5048 if Nkind
(Decl
) in N_Subprogram_Body | N_Package_Body | N_Task_Body
5049 and then No
(Handled_Statement_Sequence
(Decl
))
5051 Set_Handled_Statement_Sequence
(Decl
,
5052 Make_Handled_Sequence_Of_Statements
(Sloc
(Decl
),
5053 Statements
=> New_List
));
5056 -- Test for body stub scanned, not acceptable as basic decl item
5058 elsif Kind
in N_Body_Stub
then
5059 Error_Msg
("body stub not allowed in package spec", Sloc
(Decl
));
5061 elsif Kind
= N_Assignment_Statement
then
5063 ("assignment statement not allowed in package spec",
5071 end P_Basic_Declarative_Items
;
5077 -- For proper body, see below
5078 -- For body stub, see 10.1.3
5080 -----------------------
5081 -- 3.11 Proper Body --
5082 -----------------------
5084 -- Subprogram body is parsed by P_Subprogram (6.1)
5085 -- Package body is parsed by P_Package (7.1)
5086 -- Task body is parsed by P_Task (9.1)
5087 -- Protected body is parsed by P_Protected (9.4)
5089 ------------------------------
5090 -- Set_Declaration_Expected --
5091 ------------------------------
5093 procedure Set_Declaration_Expected
is
5095 Error_Msg_SC
("declaration expected");
5097 if Missing_Begin_Msg
= No_Error_Msg
then
5098 Missing_Begin_Msg
:= Get_Msg_Id
;
5100 end Set_Declaration_Expected
;
5102 ----------------------
5103 -- Skip_Declaration --
5104 ----------------------
5106 procedure Skip_Declaration
(S
: List_Id
) is
5107 Ignored_Done
: Boolean;
5110 (S
, Ignored_Done
, Declare_Expression
=> False, In_Spec
=> False,
5111 In_Statements
=> False);
5112 end Skip_Declaration
;
5114 -----------------------------------------
5115 -- Statement_When_Declaration_Expected --
5116 -----------------------------------------
5118 procedure Statement_When_Declaration_Expected
5124 -- Case of second occurrence of statement in one declaration sequence
5126 if Missing_Begin_Msg
/= No_Error_Msg
then
5128 -- In the procedure spec case, just ignore it, we only give one
5129 -- message for the first occurrence, since otherwise we may get
5130 -- horrible cascading if BODY was missing in the header line.
5135 -- Just ignore it if we are in -gnatd.2 (allow statements to appear
5136 -- in declaration sequences) mode.
5138 elsif Debug_Flag_Dot_2
then
5141 -- In the declarative part case, take a second statement as a sure
5142 -- sign that we really have a missing BEGIN, and end the declarative
5143 -- part now. Note that the caller will fix up the first message to
5144 -- say "missing BEGIN" so that's how the error will be signalled.
5151 -- Case of first occurrence of unexpected statement
5154 -- Do not give error message if we are operating in -gnatd.2 mode
5155 -- (alllow statements to appear in declarative parts).
5157 if not Debug_Flag_Dot_2
then
5159 -- If we are in a package spec, then give message of statement
5160 -- not allowed in package spec. This message never gets changed.
5163 Error_Msg_SC
("statement not allowed in package spec");
5165 -- If in declarative part, then we give the message complaining
5166 -- about finding a statement when a declaration is expected. This
5167 -- gets changed to a complaint about a missing BEGIN if we later
5168 -- find that no BEGIN is present.
5171 Error_Msg_SC
("statement not allowed in declarative part");
5174 -- Capture message Id. This is used for two purposes, first to
5175 -- stop multiple messages, see test above, and second, to allow
5176 -- the replacement of the message in the declarative part case.
5178 Missing_Begin_Msg
:= Get_Msg_Id
;
5182 -- In all cases except the case in which we decided to terminate the
5183 -- declaration sequence on a second error, we scan out the statement
5184 -- and append it to the list of declarations (note that the semantics
5185 -- can handle statements in a declaration list so if we proceed to
5186 -- call the semantic phase, all will be (reasonably) well.
5188 Append_List_To
(Decls
, P_Sequence_Of_Statements
(SS_Unco
));
5190 -- Done is set to False, since we want to continue the scan of
5191 -- declarations, hoping that this statement was a temporary glitch.
5192 -- If we indeed are now in the statement part (i.e. this was a missing
5193 -- BEGIN, then it's not terrible, we will simply keep calling this
5194 -- procedure to process the statements one by one, and then finally
5195 -- hit the missing BEGIN, which will clean up the error message.
5198 end Statement_When_Declaration_Expected
;