1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2022, 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_Items
83 Declare_Expression
: Boolean;
85 -- Scans out a single declarative item, or, in the case of a declaration
86 -- with a list of identifiers, a list of declarations, one for each of the
87 -- identifiers in the list. The declaration or declarations scanned are
88 -- appended to the given list. Done indicates whether or not there may be
89 -- additional declarative items to scan. If Done is True, then a decision
90 -- has been made that there are no more items to scan. If Done is False,
91 -- then there may be additional declarations to scan.
93 -- Declare_Expression is true if we are parsing a declare_expression, in
94 -- which case we want to suppress certain style checking.
96 -- In_Spec is true if we are scanning a package declaration, and is used to
97 -- generate an appropriate message if a statement is encountered in such a
100 procedure P_Identifier_Declarations
104 -- Scans out a set of declarations for an identifier or list of
105 -- identifiers, and appends them to the given list. The parameters have
106 -- the same significance as for P_Declarative_Items.
108 procedure Statement_When_Declaration_Expected
112 -- Called when a statement is found at a point where a declaration was
113 -- expected. The parameters are as described for P_Declarative_Items.
115 procedure Set_Declaration_Expected
;
116 -- Posts a "declaration expected" error messages at the start of the
117 -- current token, and if this is the first such message issued, saves
118 -- the message id in Missing_Begin_Msg, for possible later replacement.
120 ---------------------------------
121 -- Check_Restricted_Expression --
122 ---------------------------------
124 procedure Check_Restricted_Expression
(N
: Node_Id
) is
126 if Nkind
(N
) in N_Op_And | N_Op_Or | N_Op_Xor | N_And_Then | N_Or_Else
128 Check_Restricted_Expression
(Left_Opnd
(N
));
129 Check_Restricted_Expression
(Right_Opnd
(N
));
131 elsif Nkind
(N
) in N_In | N_Not_In
132 and then Paren_Count
(N
) = 0
134 Error_Msg_N
("|this expression must be parenthesized!", N
);
136 end Check_Restricted_Expression
;
142 function Init_Expr_Opt
(P
: Boolean := False) return Node_Id
is
144 -- For colon, assume it means := unless it is at the end of
145 -- a line, in which case guess that it means a semicolon.
147 if Token
= Tok_Colon
then
148 if Token_Is_At_End_Of_Line
then
153 -- Here if := or something that we will take as equivalent
155 elsif Token
= Tok_Colon_Equal
156 or else Token
= Tok_Equal
157 or else Token
= Tok_Is
161 -- Another possibility. If we have a literal followed by a semicolon,
162 -- we assume that we have a missing colon-equal.
164 elsif Token
in Token_Class_Literal
then
166 Scan_State
: Saved_Scan_State
;
169 Save_Scan_State
(Scan_State
);
170 Scan
; -- past literal or identifier
172 if Token
= Tok_Semicolon
then
173 Restore_Scan_State
(Scan_State
);
175 Restore_Scan_State
(Scan_State
);
180 -- Otherwise we definitely have no initialization expression
186 -- Merge here if we have an initialization expression
193 return P_Expression_No_Right_Paren
;
197 ----------------------------
198 -- 3.1 Basic Declaration --
199 ----------------------------
201 -- Parsed by P_Basic_Declarative_Items (3.9)
203 ------------------------------
204 -- 3.1 Defining Identifier --
205 ------------------------------
207 -- DEFINING_IDENTIFIER ::= IDENTIFIER
209 -- Error recovery: can raise Error_Resync
211 function P_Defining_Identifier
(C
: Id_Check
:= None
) return Node_Id
is
212 Ident_Node
: Node_Id
:= P_Identifier
(C
, True);
215 -- If we already have a defining identifier, clean it out and make
216 -- a new clean identifier. This situation arises in some error cases
217 -- and we need to fix it.
219 if Nkind
(Ident_Node
) = N_Defining_Identifier
then
220 Ident_Node
:= Make_Identifier
(Sloc
(Ident_Node
), Chars
(Ident_Node
));
223 -- Change identifier to defining identifier if not in error
225 if Ident_Node
/= Error
then
226 Change_Identifier_To_Defining_Identifier
(Ident_Node
);
228 -- Warn if standard redefinition, except that we never warn on a
229 -- record field definition (since this is always a harmless case).
231 if not Inside_Record_Definition
then
232 Warn_If_Standard_Redefinition
(Ident_Node
);
237 end P_Defining_Identifier
;
239 -----------------------------
240 -- 3.2.1 Type Declaration --
241 -----------------------------
243 -- TYPE_DECLARATION ::=
244 -- FULL_TYPE_DECLARATION
245 -- | INCOMPLETE_TYPE_DECLARATION
246 -- | PRIVATE_TYPE_DECLARATION
247 -- | PRIVATE_EXTENSION_DECLARATION
249 -- FULL_TYPE_DECLARATION ::=
250 -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION
251 -- [ASPECT_SPECIFICATIONS];
252 -- | CONCURRENT_TYPE_DECLARATION
254 -- INCOMPLETE_TYPE_DECLARATION ::=
255 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [is tagged];
257 -- PRIVATE_TYPE_DECLARATION ::=
258 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
259 -- is [abstract] [tagged] [limited] private
260 -- [ASPECT_SPECIFICATIONS];
262 -- PRIVATE_EXTENSION_DECLARATION ::=
263 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
264 -- [abstract] [limited | synchronized]
265 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
266 -- with private [ASPECT_SPECIFICATIONS];
268 -- TYPE_DEFINITION ::=
269 -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
270 -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION
271 -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION
272 -- | DERIVED_TYPE_DEFINITION | INTERFACE_TYPE_DEFINITION
274 -- INTEGER_TYPE_DEFINITION ::=
275 -- SIGNED_INTEGER_TYPE_DEFINITION
276 -- MODULAR_TYPE_DEFINITION
278 -- INTERFACE_TYPE_DEFINITION ::=
279 -- [limited | task | protected | synchronized ] interface
280 -- [and INTERFACE_LIST]
282 -- Error recovery: can raise Error_Resync
284 -- The processing for full type declarations, incomplete type declarations,
285 -- private type declarations and type definitions is included in this
286 -- function. The processing for concurrent type declarations is NOT here,
287 -- but rather in chapter 9 (this function handles only declarations
288 -- starting with TYPE).
290 function P_Type_Declaration
return Node_Id
is
291 Abstract_Present
: Boolean := False;
292 Abstract_Loc
: Source_Ptr
:= No_Location
;
294 Discr_List
: List_Id
;
295 Discr_Sloc
: Source_Ptr
;
297 Ident_Node
: Node_Id
;
298 Is_Derived_Iface
: Boolean := False;
299 Type_Loc
: Source_Ptr
;
300 Type_Start_Col
: Column_Number
;
301 Unknown_Dis
: Boolean;
303 Typedef_Node
: Node_Id
;
304 -- Normally holds type definition, except in the case of a private
305 -- extension declaration, in which case it holds the declaration itself
308 Type_Loc
:= Token_Ptr
;
309 Type_Start_Col
:= Start_Column
;
311 -- If we have TYPE, then proceed ahead and scan identifier
313 if Token
= Tok_Type
then
314 Type_Token_Location
:= Type_Loc
;
316 Ident_Node
:= P_Defining_Identifier
(C_Is
);
318 -- Otherwise this is an error case
322 Type_Token_Location
:= Type_Loc
;
323 Ident_Node
:= P_Defining_Identifier
(C_Is
);
326 Discr_Sloc
:= Token_Ptr
;
328 if P_Unknown_Discriminant_Part_Opt
then
330 Discr_List
:= No_List
;
332 Unknown_Dis
:= False;
333 Discr_List
:= P_Known_Discriminant_Part_Opt
;
336 -- Incomplete type declaration. We complete the processing for this
337 -- case here and return the resulting incomplete type declaration node
339 if Token
= Tok_Semicolon
then
341 Decl_Node
:= New_Node
(N_Incomplete_Type_Declaration
, Type_Loc
);
342 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
343 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
344 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
351 -- Full type declaration or private type declaration, must have IS
353 if Token
= Tok_Equal
then
355 Scan
; -- past = used in place of IS
357 elsif Token
= Tok_Renames
then
358 Error_Msg_SC
-- CODEFIX
359 ("RENAMES should be IS");
360 Scan
; -- past RENAMES used in place of IS
366 -- First an error check, if we have two identifiers in a row, a likely
367 -- possibility is that the first of the identifiers is an incorrectly
370 if Token
= Tok_Identifier
then
372 SS
: Saved_Scan_State
;
376 Save_Scan_State
(SS
);
377 Scan
; -- past initial identifier
378 I2
:= (Token
= Tok_Identifier
);
379 Restore_Scan_State
(SS
);
383 (Bad_Spelling_Of
(Tok_Abstract
) or else
384 Bad_Spelling_Of
(Tok_Access
) or else
385 Bad_Spelling_Of
(Tok_Aliased
) or else
386 Bad_Spelling_Of
(Tok_Constant
))
393 -- Check for misuse of Ada 95 keyword abstract in Ada 83 mode
395 if Token_Name
= Name_Abstract
then
396 Check_95_Keyword
(Tok_Abstract
, Tok_Tagged
);
397 Check_95_Keyword
(Tok_Abstract
, Tok_New
);
400 -- Check cases of misuse of ABSTRACT
402 if Token
= Tok_Abstract
then
403 Abstract_Present
:= True;
404 Abstract_Loc
:= Token_Ptr
;
405 Scan
; -- past ABSTRACT
407 -- Ada 2005 (AI-419): AARM 3.4 (2/2)
409 if (Ada_Version
< Ada_2005
and then Token
= Tok_Limited
)
410 or else Token
= Tok_Private
411 or else Token
= Tok_Record
412 or else Token
= Tok_Null
414 Error_Msg_AP
("TAGGED expected");
418 -- Check for misuse of Ada 95 keyword Tagged
420 if Token_Name
= Name_Tagged
then
421 Check_95_Keyword
(Tok_Tagged
, Tok_Private
);
422 Check_95_Keyword
(Tok_Tagged
, Tok_Limited
);
423 Check_95_Keyword
(Tok_Tagged
, Tok_Record
);
426 -- Special check for misuse of Aliased
428 if Token
= Tok_Aliased
or else Token_Name
= Name_Aliased
then
429 Error_Msg_SC
("ALIASED not allowed in type definition");
430 Scan
; -- past ALIASED
433 -- The following processing deals with either a private type declaration
434 -- or a full type declaration. In the private type case, we build the
435 -- N_Private_Type_Declaration node, setting its Tagged_Present and
436 -- Limited_Present flags, on encountering the Private keyword, and
437 -- leave Typedef_Node set to Empty. For the full type declaration
438 -- case, Typedef_Node gets set to the type definition.
440 Typedef_Node
:= Empty
;
442 -- Switch on token following the IS. The loop normally runs once. It
443 -- only runs more than once if an error is detected, to try again after
444 -- detecting and fixing up the error.
449 | Tok_Not
-- Ada 2005 (AI-231)
451 Typedef_Node
:= P_Access_Type_Definition
;
455 Typedef_Node
:= P_Array_Type_Definition
;
459 Typedef_Node
:= P_Fixed_Point_Definition
;
463 Typedef_Node
:= P_Floating_Point_Definition
;
469 when Tok_Integer_Literal
=>
471 Typedef_Node
:= P_Signed_Integer_Type_Definition
;
475 Typedef_Node
:= P_Record_Definition
;
478 when Tok_Left_Paren
=>
479 Typedef_Node
:= P_Enumeration_Type_Definition
;
481 End_Labl
:= Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
482 Set_Comes_From_Source
(End_Labl
, False);
484 Set_End_Label
(Typedef_Node
, End_Labl
);
488 Typedef_Node
:= P_Modular_Type_Definition
;
492 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
494 if Nkind
(Typedef_Node
) = N_Derived_Type_Definition
495 and then Present
(Record_Extension_Part
(Typedef_Node
))
497 End_Labl
:= Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
498 Set_Comes_From_Source
(End_Labl
, False);
501 (Record_Extension_Part
(Typedef_Node
), End_Labl
);
507 Typedef_Node
:= P_Signed_Integer_Type_Definition
;
511 Typedef_Node
:= P_Record_Definition
;
513 End_Labl
:= Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
514 Set_Comes_From_Source
(End_Labl
, False);
516 Set_End_Label
(Typedef_Node
, End_Labl
);
522 -- Ada 2005 (AI-326): If the words IS TAGGED appear, the type
523 -- is a tagged incomplete type.
525 if Ada_Version
>= Ada_2005
526 and then Token
= Tok_Semicolon
531 New_Node
(N_Incomplete_Type_Declaration
, Type_Loc
);
532 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
533 Set_Tagged_Present
(Decl_Node
);
534 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
535 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
540 if Token
= Tok_Abstract
then
541 Error_Msg_SC
-- CODEFIX
542 ("ABSTRACT must come before TAGGED");
543 Abstract_Present
:= True;
544 Abstract_Loc
:= Token_Ptr
;
545 Scan
; -- past ABSTRACT
548 if Token
= Tok_Limited
then
549 Scan
; -- past LIMITED
551 -- TAGGED LIMITED PRIVATE case
553 if Token
= Tok_Private
then
555 New_Node
(N_Private_Type_Declaration
, Type_Loc
);
556 Set_Tagged_Present
(Decl_Node
, True);
557 Set_Limited_Present
(Decl_Node
, True);
558 Scan
; -- past PRIVATE
560 -- TAGGED LIMITED RECORD
563 Typedef_Node
:= P_Record_Definition
;
564 Set_Tagged_Present
(Typedef_Node
, True);
565 Set_Limited_Present
(Typedef_Node
, True);
568 Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
569 Set_Comes_From_Source
(End_Labl
, False);
571 Set_End_Label
(Typedef_Node
, End_Labl
);
577 if Token
= Tok_Private
then
579 New_Node
(N_Private_Type_Declaration
, Type_Loc
);
580 Set_Tagged_Present
(Decl_Node
, True);
581 Scan
; -- past PRIVATE
586 Typedef_Node
:= P_Record_Definition
;
587 Set_Tagged_Present
(Typedef_Node
, True);
590 Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
591 Set_Comes_From_Source
(End_Labl
, False);
593 Set_End_Label
(Typedef_Node
, End_Labl
);
600 Scan
; -- past LIMITED
603 if Token
= Tok_Tagged
then
604 Error_Msg_SC
-- CODEFIX
605 ("TAGGED must come before LIMITED");
608 elsif Token
= Tok_Abstract
then
609 Error_Msg_SC
-- CODEFIX
610 ("ABSTRACT must come before LIMITED");
611 Scan
; -- past ABSTRACT
618 -- LIMITED RECORD or LIMITED NULL RECORD
620 if Token
= Tok_Record
or else Token
= Tok_Null
then
621 if Ada_Version
= Ada_83
then
623 ("(Ada 83) limited record declaration not allowed!");
625 -- In Ada 2005, "abstract limited" can appear before "new",
626 -- but it cannot be part of an untagged record declaration.
628 elsif Abstract_Present
629 and then Prev_Token
/= Tok_Tagged
631 Error_Msg_SP
("TAGGED expected");
634 Typedef_Node
:= P_Record_Definition
;
635 Set_Limited_Present
(Typedef_Node
, True);
636 End_Labl
:= Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
637 Set_Comes_From_Source
(End_Labl
, False);
639 Set_End_Label
(Typedef_Node
, End_Labl
);
641 -- Ada 2005 (AI-251): LIMITED INTERFACE
643 -- If we are compiling in Ada 83 or Ada 95 mode, "interface"
644 -- is not a reserved word but we force its analysis to
645 -- generate the corresponding usage error.
647 elsif Token
= Tok_Interface
648 or else (Token
= Tok_Identifier
649 and then Chars
(Token_Node
) = Name_Interface
)
652 P_Interface_Type_Definition
(Abstract_Present
);
653 Abstract_Present
:= True;
654 Set_Limited_Present
(Typedef_Node
);
656 if Nkind
(Typedef_Node
) = N_Derived_Type_Definition
then
657 Is_Derived_Iface
:= True;
660 -- Ada 2005 (AI-419): LIMITED NEW
662 elsif Token
= Tok_New
then
663 Error_Msg_Ada_2005_Extension
("LIMITED in derived type");
665 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
666 Set_Limited_Present
(Typedef_Node
);
668 if Nkind
(Typedef_Node
) = N_Derived_Type_Definition
669 and then Present
(Record_Extension_Part
(Typedef_Node
))
672 Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
673 Set_Comes_From_Source
(End_Labl
, False);
676 (Record_Extension_Part
(Typedef_Node
), End_Labl
);
679 -- LIMITED PRIVATE is the only remaining possibility here
682 Decl_Node
:= New_Node
(N_Private_Type_Declaration
, Type_Loc
);
683 Set_Limited_Present
(Decl_Node
, True);
684 T_Private
; -- past PRIVATE (or complain if not there)
689 -- Here we have an identifier after the IS, which is certainly
690 -- wrong and which might be one of several different mistakes.
692 when Tok_Identifier
=>
694 -- First case, if identifier is on same line, then probably we
695 -- have something like "type X is Integer .." and the best
696 -- diagnosis is a missing NEW. Note: the missing new message
697 -- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl.
699 if not Token_Is_At_Start_Of_Line
then
700 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
702 -- If the identifier is at the start of the line, and is in the
703 -- same column as the type declaration itself then we consider
704 -- that we had a missing type definition on the previous line
706 elsif Start_Column
<= Type_Start_Col
then
707 Error_Msg_AP
("type definition expected");
708 Typedef_Node
:= Error
;
710 -- If the identifier is at the start of the line, and is in
711 -- a column to the right of the type declaration line, then we
712 -- may have something like:
717 -- and the best diagnosis is a missing record keyword
720 Typedef_Node
:= P_Record_Definition
;
725 -- Ada 2005 (AI-251): INTERFACE
727 when Tok_Interface
=>
728 Typedef_Node
:= P_Interface_Type_Definition
(Abstract_Present
);
729 Abstract_Present
:= True;
733 Decl_Node
:= New_Node
(N_Private_Type_Declaration
, Type_Loc
);
734 Scan
; -- past PRIVATE
736 -- Check error cases of private [abstract] tagged
738 if Token
= Tok_Abstract
then
739 Error_Msg_SC
("`ABSTRACT TAGGED` must come before PRIVATE");
740 Scan
; -- past ABSTRACT
742 if Token
= Tok_Tagged
then
746 elsif Token
= Tok_Tagged
then
747 Error_Msg_SC
("TAGGED must come before PRIVATE");
753 -- Ada 2005 (AI-345): Protected, synchronized or task interface
754 -- or Ada 2005 (AI-443): Synchronized private extension.
761 Saved_Token
: constant Token_Type
:= Token
;
764 Scan
; -- past TASK, PROTECTED or SYNCHRONIZED
766 -- Synchronized private extension
768 if Token
= Tok_New
then
769 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
771 if Saved_Token
= Tok_Synchronized
then
772 if Nkind
(Typedef_Node
) =
773 N_Derived_Type_Definition
776 ("SYNCHRONIZED not allowed for record extension",
779 Set_Synchronized_Present
(Typedef_Node
);
783 Error_Msg_SC
("invalid kind of private extension");
789 if Token
/= Tok_Interface
then
790 Error_Msg_SC
("NEW or INTERFACE expected");
794 P_Interface_Type_Definition
(Abstract_Present
);
795 Abstract_Present
:= True;
799 Set_Task_Present
(Typedef_Node
);
801 when Tok_Protected
=>
802 Set_Protected_Present
(Typedef_Node
);
804 when Tok_Synchronized
=>
805 Set_Synchronized_Present
(Typedef_Node
);
808 pragma Assert
(False);
816 -- Anything else is an error
819 if Bad_Spelling_Of
(Tok_Access
)
821 Bad_Spelling_Of
(Tok_Array
)
823 Bad_Spelling_Of
(Tok_Delta
)
825 Bad_Spelling_Of
(Tok_Digits
)
827 Bad_Spelling_Of
(Tok_Limited
)
829 Bad_Spelling_Of
(Tok_Private
)
831 Bad_Spelling_Of
(Tok_Range
)
833 Bad_Spelling_Of
(Tok_Record
)
835 Bad_Spelling_Of
(Tok_Tagged
)
840 Error_Msg_AP
("type definition expected");
846 -- For the private type declaration case, the private type declaration
847 -- node has been built, with the Tagged_Present and Limited_Present
848 -- flags set as needed, and Typedef_Node is left set to Empty.
850 if No
(Typedef_Node
) then
851 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
852 Set_Abstract_Present
(Decl_Node
, Abstract_Present
);
854 -- For a private extension declaration, Typedef_Node contains the
855 -- N_Private_Extension_Declaration node, which we now complete. Note
856 -- that the private extension declaration, unlike a full type
857 -- declaration, does permit unknown discriminants.
859 elsif Nkind
(Typedef_Node
) = N_Private_Extension_Declaration
then
860 Decl_Node
:= Typedef_Node
;
861 Set_Sloc
(Decl_Node
, Type_Loc
);
862 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
863 Set_Abstract_Present
(Typedef_Node
, Abstract_Present
);
865 -- In the full type declaration case, Typedef_Node has the type
866 -- definition and here is where we build the full type declaration
867 -- node. This is also where we check for improper use of an unknown
868 -- discriminant part (not allowed for full type declaration).
871 if Nkind
(Typedef_Node
) = N_Record_Definition
872 or else (Nkind
(Typedef_Node
) = N_Derived_Type_Definition
873 and then Present
(Record_Extension_Part
(Typedef_Node
)))
874 or else Is_Derived_Iface
876 Set_Abstract_Present
(Typedef_Node
, Abstract_Present
);
878 elsif Abstract_Present
then
879 Error_Msg
("ABSTRACT not allowed here, ignored", Abstract_Loc
);
882 Decl_Node
:= New_Node
(N_Full_Type_Declaration
, Type_Loc
);
883 Set_Type_Definition
(Decl_Node
, Typedef_Node
);
887 ("full type declaration cannot have unknown discriminants",
892 -- Remaining processing is common for all three cases
894 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
895 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
896 P_Aspect_Specifications
(Decl_Node
);
898 end P_Type_Declaration
;
900 ----------------------------------
901 -- 3.2.1 Full Type Declaration --
902 ----------------------------------
904 -- Parsed by P_Type_Declaration (3.2.1)
906 ----------------------------
907 -- 3.2.1 Type Definition --
908 ----------------------------
910 -- Parsed by P_Type_Declaration (3.2.1)
912 --------------------------------
913 -- 3.2.2 Subtype Declaration --
914 --------------------------------
916 -- SUBTYPE_DECLARATION ::=
917 -- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION
918 -- [ASPECT_SPECIFICATIONS];
920 -- The caller has checked that the initial token is SUBTYPE
922 -- Error recovery: can raise Error_Resync
924 function P_Subtype_Declaration
return Node_Id
is
926 Not_Null_Present
: Boolean := False;
929 Decl_Node
:= New_Node
(N_Subtype_Declaration
, Token_Ptr
);
930 Scan
; -- past SUBTYPE
931 Set_Defining_Identifier
(Decl_Node
, P_Defining_Identifier
(C_Is
));
934 if Token
= Tok_New
then
935 Error_Msg_SC
-- CODEFIX
936 ("NEW ignored (only allowed in type declaration)");
940 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
941 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
943 Set_Subtype_Indication
944 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
945 P_Aspect_Specifications
(Decl_Node
);
947 end P_Subtype_Declaration
;
949 -------------------------------
950 -- 3.2.2 Subtype Indication --
951 -------------------------------
953 -- SUBTYPE_INDICATION ::=
954 -- [not null] SUBTYPE_MARK [CONSTRAINT]
956 -- Error recovery: can raise Error_Resync
958 function P_Null_Exclusion
959 (Allow_Anonymous_In_95
: Boolean := False) return Boolean
961 Not_Loc
: constant Source_Ptr
:= Token_Ptr
;
962 -- Source position of "not", if present
965 if Token
/= Tok_Not
then
971 if Token
= Tok_Null
then
974 -- Ada 2005 (AI-441, AI-447): null_exclusion is illegal in Ada 95,
975 -- except in the case of anonymous access types.
977 -- Allow_Anonymous_In_95 will be True if we're parsing a formal
978 -- parameter or discriminant, which are the only places where
979 -- anonymous access types occur in Ada 95. "Formal : not null
980 -- access ..." is legal in Ada 95, whereas "Formal : not null
981 -- Named_Access_Type" is not.
983 if Ada_Version
>= Ada_2005
984 or else (Ada_Version
>= Ada_95
985 and then Allow_Anonymous_In_95
986 and then Token
= Tok_Access
)
992 ("`NOT NULL` access type is an Ada 2005 extension", Not_Loc
);
994 ("\unit should be compiled with -gnat05 switch", Not_Loc
);
998 Error_Msg_SP
("NULL expected");
1001 if Token
= Tok_New
then
1002 Error_Msg
("`NOT NULL` comes after NEW, not before", Not_Loc
);
1007 end P_Null_Exclusion
;
1009 function P_Subtype_Indication
1010 (Not_Null_Present
: Boolean := False) return Node_Id
1012 Type_Node
: Node_Id
;
1015 if Token
= Tok_Identifier
or else Token
= Tok_Operator_Symbol
then
1016 Type_Node
:= P_Subtype_Mark
;
1017 return P_Subtype_Indication
(Type_Node
, Not_Null_Present
);
1020 -- Check for error of using record definition and treat it nicely,
1021 -- otherwise things are really messed up, so resynchronize.
1023 if Token
= Tok_Record
then
1024 Error_Msg_SC
("anonymous record definition not permitted");
1025 Discard_Junk_Node
(P_Record_Definition
);
1029 Error_Msg_AP
("subtype indication expected");
1033 end P_Subtype_Indication
;
1035 -- The following function is identical except that it is called with
1036 -- the subtype mark already scanned out, and it scans out the constraint
1038 -- Error recovery: can raise Error_Resync
1040 function P_Subtype_Indication
1041 (Subtype_Mark
: Node_Id
;
1042 Not_Null_Present
: Boolean := False) return Node_Id
1044 Indic_Node
: Node_Id
;
1045 Constr_Node
: Node_Id
;
1048 Constr_Node
:= P_Constraint_Opt
;
1052 (Nkind
(Constr_Node
) = N_Range_Constraint
1053 and then Nkind
(Range_Expression
(Constr_Node
)) = N_Error
)
1055 return Subtype_Mark
;
1057 if Not_Null_Present
then
1058 Error_Msg_SP
("`NOT NULL` not allowed if constraint given");
1061 Indic_Node
:= New_Node
(N_Subtype_Indication
, Sloc
(Subtype_Mark
));
1062 Set_Subtype_Mark
(Indic_Node
, Check_Subtype_Mark
(Subtype_Mark
));
1063 Set_Constraint
(Indic_Node
, Constr_Node
);
1066 end P_Subtype_Indication
;
1068 -------------------------
1069 -- 3.2.2 Subtype Mark --
1070 -------------------------
1072 -- SUBTYPE_MARK ::= subtype_NAME;
1074 -- Note: The subtype mark which appears after an IN or NOT IN
1075 -- operator is parsed by P_Range_Or_Subtype_Mark (3.5)
1077 -- Error recovery: cannot raise Error_Resync
1079 function P_Subtype_Mark
return Node_Id
is
1081 return P_Subtype_Mark_Resync
;
1083 when Error_Resync
=>
1087 -- This routine differs from P_Subtype_Mark in that it insists that an
1088 -- identifier be present, and if it is not, it raises Error_Resync.
1090 -- Error recovery: can raise Error_Resync
1092 function P_Subtype_Mark_Resync
return Node_Id
is
1093 Type_Node
: Node_Id
;
1096 if Token
= Tok_Access
then
1097 Error_Msg_SC
("anonymous access type definition not allowed here");
1098 Scan
; -- past ACCESS
1101 if Token
= Tok_Array
then
1102 Error_Msg_SC
("anonymous array definition not allowed here");
1103 Discard_Junk_Node
(P_Array_Type_Definition
);
1107 Type_Node
:= P_Qualified_Simple_Name_Resync
;
1109 -- Check for a subtype mark attribute. The only valid possibilities
1110 -- are 'CLASS and 'BASE. Anything else is a definite error. We may
1111 -- as well catch it here.
1113 if Token
= Tok_Apostrophe
then
1114 return P_Subtype_Mark_Attribute
(Type_Node
);
1119 end P_Subtype_Mark_Resync
;
1121 -- The following function is called to scan out a subtype mark attribute.
1122 -- The caller has already scanned out the subtype mark, which is passed in
1123 -- as the argument, and has checked that the current token is apostrophe.
1125 -- Only a special subclass of attributes, called type attributes
1126 -- (see Snames package) are allowed in this syntactic position.
1128 -- Note: if the apostrophe is followed by other than an identifier, then
1129 -- the input expression is returned unchanged, and the scan pointer is
1130 -- left pointing to the apostrophe.
1132 -- Error recovery: can raise Error_Resync
1134 function P_Subtype_Mark_Attribute
(Type_Node
: Node_Id
) return Node_Id
is
1135 Attr_Node
: Node_Id
:= Empty
;
1136 Scan_State
: Saved_Scan_State
;
1140 Prefix
:= Check_Subtype_Mark
(Type_Node
);
1142 if Prefix
= Error
then
1146 -- Loop through attributes appearing (more than one can appear as for
1147 -- for example in X'Base'Class). We are at an apostrophe on entry to
1148 -- this loop, and it runs once for each attribute parsed, with
1149 -- Prefix being the current possible prefix if it is an attribute.
1152 Save_Scan_State
(Scan_State
); -- at Apostrophe
1153 Scan
; -- past apostrophe
1155 if Token
/= Tok_Identifier
then
1156 Restore_Scan_State
(Scan_State
); -- to apostrophe
1157 return Prefix
; -- no attribute after all
1159 elsif not Is_Type_Attribute_Name
(Token_Name
) then
1161 ("attribute & may not be used in a subtype mark", Token_Node
);
1166 Make_Attribute_Reference
(Prev_Token_Ptr
,
1168 Attribute_Name
=> Token_Name
);
1169 Scan
; -- past type attribute identifier
1172 exit when Token
/= Tok_Apostrophe
;
1173 Prefix
:= Attr_Node
;
1176 -- Fall through here after scanning type attribute
1179 end P_Subtype_Mark_Attribute
;
1181 -----------------------
1182 -- 3.2.2 Constraint --
1183 -----------------------
1185 -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
1187 -- SCALAR_CONSTRAINT ::=
1188 -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
1190 -- COMPOSITE_CONSTRAINT ::=
1191 -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
1193 -- If no constraint is present, this function returns Empty
1195 -- Error recovery: can raise Error_Resync
1197 function P_Constraint_Opt
return Node_Id
is
1199 if Token
= Tok_Range
or else Bad_Spelling_Of
(Tok_Range
) then
1200 return P_Range_Constraint
;
1202 elsif Token
= Tok_Digits
or else Bad_Spelling_Of
(Tok_Digits
) then
1203 return P_Digits_Constraint
;
1205 elsif Token
= Tok_Delta
or else Bad_Spelling_Of
(Tok_Delta
) then
1206 return P_Delta_Constraint
;
1208 elsif Token
= Tok_Left_Paren
then
1209 return P_Index_Or_Discriminant_Constraint
;
1211 elsif Token
= Tok_In
then
1213 return P_Constraint_Opt
;
1215 -- One more possibility is e.g. 1 .. 10 (i.e. missing RANGE keyword)
1217 elsif Token
= Tok_Identifier
or else
1218 Token
= Tok_Integer_Literal
or else
1219 Token
= Tok_Real_Literal
1222 Scan_State
: Saved_Scan_State
;
1225 Save_Scan_State
(Scan_State
); -- at identifier or literal
1226 Scan
; -- past identifier or literal
1228 if Token
= Tok_Dot_Dot
then
1229 Restore_Scan_State
(Scan_State
);
1230 Error_Msg_BC
("missing RANGE keyword");
1231 return P_Range_Constraint
;
1233 Restore_Scan_State
(Scan_State
);
1238 -- Nothing worked, no constraint there
1243 end P_Constraint_Opt
;
1245 ------------------------------
1246 -- 3.2.2 Scalar Constraint --
1247 ------------------------------
1249 -- Parsed by P_Constraint_Opt (3.2.2)
1251 ---------------------------------
1252 -- 3.2.2 Composite Constraint --
1253 ---------------------------------
1255 -- Parsed by P_Constraint_Opt (3.2.2)
1257 --------------------------------------------------------
1258 -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) --
1259 --------------------------------------------------------
1261 -- This routine scans out a declaration starting with an identifier:
1263 -- OBJECT_DECLARATION ::=
1264 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1265 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION]
1266 -- [ASPECT_SPECIFICATIONS];
1267 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1268 -- ACCESS_DEFINITION [:= EXPRESSION]
1269 -- [ASPECT_SPECIFICATIONS];
1270 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1271 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]
1272 -- [ASPECT_SPECIFICATIONS];
1274 -- NUMBER_DECLARATION ::=
1275 -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
1277 -- OBJECT_RENAMING_DECLARATION ::=
1278 -- DEFINING_IDENTIFIER :
1279 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME
1280 -- [ASPECT_SPECIFICATIONS];
1281 -- | DEFINING_IDENTIFIER :
1282 -- ACCESS_DEFINITION renames object_NAME
1283 -- [ASPECT_SPECIFICATIONS];
1285 -- EXCEPTION_RENAMING_DECLARATION ::=
1286 -- DEFINING_IDENTIFIER : exception renames exception_NAME
1287 -- [ASPECT_SPECIFICATIONS];
1289 -- EXCEPTION_DECLARATION ::=
1290 -- DEFINING_IDENTIFIER_LIST : exception
1291 -- [ASPECT_SPECIFICATIONS];
1293 -- Note that the ALIASED indication in an object declaration is
1294 -- marked by a flag in the parent node.
1296 -- The caller has checked that the initial token is an identifier
1298 -- The value returned is a list of declarations, one for each identifier
1299 -- in the list (as described in Sinfo, we always split up multiple
1300 -- declarations into the equivalent sequence of single declarations
1301 -- using the More_Ids and Prev_Ids flags to preserve the source).
1303 -- If the identifier turns out to be a probable statement rather than
1304 -- an identifier, then the scan is left pointing to the identifier and
1305 -- No_List is returned.
1307 -- Error recovery: can raise Error_Resync
1309 procedure P_Identifier_Declarations
1315 Decl_Node
: Node_Id
;
1316 Type_Node
: Node_Id
;
1317 Ident_Sloc
: Source_Ptr
;
1318 Scan_State
: Saved_Scan_State
;
1319 List_OK
: Boolean := True;
1321 Init_Expr
: Node_Id
;
1322 Init_Loc
: Source_Ptr
;
1323 Con_Loc
: Source_Ptr
;
1324 Not_Null_Present
: Boolean := False;
1326 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
1327 -- Used to save identifiers in the identifier list. The upper bound
1328 -- of 4096 is expected to be infinite in practice, and we do not even
1329 -- bother to check if this upper bound is exceeded.
1331 Num_Idents
: Nat
:= 1;
1332 -- Number of identifiers stored in Idents
1335 -- This procedure is called in renames cases to make sure that we do
1336 -- not have more than one identifier. If we do have more than one
1337 -- then an error message is issued (and the declaration is split into
1338 -- multiple declarations)
1340 function Token_Is_Renames
return Boolean;
1341 -- Checks if current token is RENAMES, and if so, scans past it and
1342 -- returns True, otherwise returns False. Includes checking for some
1343 -- common error cases.
1349 procedure No_List
is
1351 if Num_Idents
> 1 then
1353 ("identifier list not allowed for RENAMES",
1360 ----------------------
1361 -- Token_Is_Renames --
1362 ----------------------
1364 function Token_Is_Renames
return Boolean is
1365 At_Colon
: Saved_Scan_State
;
1368 if Token
= Tok_Colon
then
1369 Save_Scan_State
(At_Colon
);
1371 Check_Misspelling_Of
(Tok_Renames
);
1373 if Token
= Tok_Renames
then
1374 Error_Msg_SP
-- CODEFIX
1375 ("|extra "":"" ignored");
1376 Scan
; -- past RENAMES
1379 Restore_Scan_State
(At_Colon
);
1384 Check_Misspelling_Of
(Tok_Renames
);
1386 if Token
= Tok_Renames
then
1387 Scan
; -- past RENAMES
1393 end Token_Is_Renames
;
1395 -- Start of processing for P_Identifier_Declarations
1398 Ident_Sloc
:= Token_Ptr
;
1399 Save_Scan_State
(Scan_State
); -- at first identifier
1400 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
1402 -- If we have a colon after the identifier, then we can assume that
1403 -- this is in fact a valid identifier declaration and can steam ahead.
1405 if Token
= Tok_Colon
then
1408 -- If we have a comma, then scan out the list of identifiers
1410 elsif Token
= Tok_Comma
then
1411 while Comma_Present
loop
1412 Num_Idents
:= Num_Idents
+ 1;
1413 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
1416 Save_Scan_State
(Scan_State
); -- at colon
1419 -- If we have identifier followed by := then we assume that what is
1420 -- really meant is an assignment statement. The assignment statement
1421 -- is scanned out and added to the list of declarations. An exception
1422 -- occurs if the := is followed by the keyword constant, in which case
1423 -- we assume it was meant to be a colon.
1425 elsif Token
= Tok_Colon_Equal
then
1428 if Token
= Tok_Constant
then
1429 Error_Msg_SP
("colon expected");
1432 Restore_Scan_State
(Scan_State
);
1434 -- Reset Token_Node, because it already got changed from an
1435 -- Identifier to a Defining_Identifier, and we don't want that
1439 Make_Identifier
(Sloc
(Token_Node
), Chars
(Token_Node
));
1441 -- And now scan out one or more statements
1443 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
1447 -- If we have an IS keyword, then assume the TYPE keyword was missing
1449 elsif Token
= Tok_Is
then
1450 Restore_Scan_State
(Scan_State
);
1451 Append_To
(Decls
, P_Type_Declaration
);
1455 -- AI12-0275: Object renaming declaration without subtype_mark or
1456 -- access_definition
1458 elsif Token
= Tok_Renames
then
1459 Error_Msg_Ada_2022_Feature
1460 ("object renaming without subtype", Token_Ptr
);
1462 Scan
; -- past renames
1465 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1466 Set_Name
(Decl_Node
, P_Name
);
1467 Set_Defining_Identifier
(Decl_Node
, Idents
(1));
1469 P_Aspect_Specifications
(Decl_Node
, Semicolon
=> False);
1473 Append
(Decl_Node
, Decls
);
1478 -- Otherwise we have an error situation
1481 Restore_Scan_State
(Scan_State
);
1483 -- First case is possible misuse of PROTECTED in Ada 83 mode. If
1484 -- so, fix the keyword and return to scan the protected declaration.
1486 if Token_Name
= Name_Protected
then
1487 Check_95_Keyword
(Tok_Protected
, Tok_Identifier
);
1488 Check_95_Keyword
(Tok_Protected
, Tok_Type
);
1489 Check_95_Keyword
(Tok_Protected
, Tok_Body
);
1491 if Token
= Tok_Protected
then
1496 -- Check misspelling possibilities. If so, correct the misspelling
1497 -- and return to scan out the resulting declaration.
1499 elsif Bad_Spelling_Of
(Tok_Function
)
1500 or else Bad_Spelling_Of
(Tok_Procedure
)
1501 or else Bad_Spelling_Of
(Tok_Package
)
1502 or else Bad_Spelling_Of
(Tok_Pragma
)
1503 or else Bad_Spelling_Of
(Tok_Protected
)
1504 or else Bad_Spelling_Of
(Tok_Generic
)
1505 or else Bad_Spelling_Of
(Tok_Subtype
)
1506 or else Bad_Spelling_Of
(Tok_Type
)
1507 or else Bad_Spelling_Of
(Tok_Task
)
1508 or else Bad_Spelling_Of
(Tok_Use
)
1509 or else Bad_Spelling_Of
(Tok_For
)
1514 -- Otherwise we definitely have an ordinary identifier with a junk
1518 -- If in -gnatd.2 mode, try for statements
1520 if Debug_Flag_Dot_2
then
1521 Restore_Scan_State
(Scan_State
);
1523 -- Reset Token_Node, because it already got changed from an
1524 -- Identifier to a Defining_Identifier, and we don't want that
1528 Make_Identifier
(Sloc
(Token_Node
), Chars
(Token_Node
));
1530 -- And now scan out one or more statements
1532 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
1535 -- Normal case, just complain and skip to semicolon
1538 Set_Declaration_Expected
;
1539 Resync_Past_Semicolon
;
1546 -- Come here with an identifier list and colon scanned out. We now
1547 -- build the nodes for the declarative items. One node is built for
1548 -- each identifier in the list, with the type information being
1549 -- repeated by rescanning the appropriate section of source.
1551 -- First an error check, if we have two identifiers in a row, a likely
1552 -- possibility is that the first of the identifiers is an incorrectly
1555 if Token
= Tok_Identifier
then
1557 SS
: Saved_Scan_State
;
1561 Save_Scan_State
(SS
);
1562 Scan
; -- past initial identifier
1563 I2
:= (Token
= Tok_Identifier
);
1564 Restore_Scan_State
(SS
);
1568 (Bad_Spelling_Of
(Tok_Access
) or else
1569 Bad_Spelling_Of
(Tok_Aliased
) or else
1570 Bad_Spelling_Of
(Tok_Constant
))
1577 -- Loop through identifiers
1582 -- Check for some cases of misused Ada 95 keywords
1584 if Token_Name
= Name_Aliased
then
1585 Check_95_Keyword
(Tok_Aliased
, Tok_Array
);
1586 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
1587 Check_95_Keyword
(Tok_Aliased
, Tok_Constant
);
1592 if Token
= Tok_Constant
then
1593 Con_Loc
:= Token_Ptr
;
1594 Scan
; -- past CONSTANT
1596 -- Number declaration, initialization required
1598 Init_Expr
:= Init_Expr_Opt
;
1600 if Present
(Init_Expr
) then
1601 if Not_Null_Present
then
1603 ("`NOT NULL` not allowed in numeric expression");
1606 Decl_Node
:= New_Node
(N_Number_Declaration
, Ident_Sloc
);
1607 Set_Expression
(Decl_Node
, Init_Expr
);
1609 -- Constant object declaration
1612 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1613 Set_Constant_Present
(Decl_Node
, True);
1615 if Token_Name
= Name_Aliased
then
1616 Check_95_Keyword
(Tok_Aliased
, Tok_Array
);
1617 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
1620 if Token
= Tok_Aliased
then
1621 Error_Msg_SC
-- CODEFIX
1622 ("ALIASED should be before CONSTANT");
1623 Scan
; -- past ALIASED
1624 Set_Aliased_Present
(Decl_Node
, True);
1627 if Token
= Tok_Array
then
1628 Set_Object_Definition
1629 (Decl_Node
, P_Array_Type_Definition
);
1632 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1633 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1635 if Token
= Tok_Access
then
1636 Error_Msg_Ada_2005_Extension
1637 ("generalized use of anonymous access types");
1639 Set_Object_Definition
1640 (Decl_Node
, P_Access_Definition
(Not_Null_Present
));
1642 Set_Object_Definition
1643 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
1647 if Token
= Tok_Renames
then
1649 ("CONSTANT not permitted in renaming declaration",
1651 Scan
; -- Past renames
1652 Discard_Junk_Node
(P_Name
);
1658 elsif Token
= Tok_Exception
then
1659 Scan
; -- past EXCEPTION
1661 if Token_Is_Renames
then
1664 New_Node
(N_Exception_Renaming_Declaration
, Ident_Sloc
);
1665 Set_Name
(Decl_Node
, P_Qualified_Simple_Name_Resync
);
1668 Decl_Node
:= New_Node
(N_Exception_Declaration
, Prev_Token_Ptr
);
1671 -- Aliased case (note that an object definition is required)
1673 elsif Token
= Tok_Aliased
then
1674 Scan
; -- past ALIASED
1675 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1676 Set_Aliased_Present
(Decl_Node
, True);
1678 if Token
= Tok_Constant
then
1679 Scan
; -- past CONSTANT
1680 Set_Constant_Present
(Decl_Node
, True);
1683 if Token
= Tok_Array
then
1684 Set_Object_Definition
1685 (Decl_Node
, P_Array_Type_Definition
);
1688 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1689 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1691 -- Access definition (AI-406) or subtype indication
1693 if Token
= Tok_Access
then
1694 Error_Msg_Ada_2005_Extension
1695 ("generalized use of anonymous access types");
1697 Set_Object_Definition
1698 (Decl_Node
, P_Access_Definition
(Not_Null_Present
));
1700 Set_Object_Definition
1701 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
1707 elsif Token
= Tok_Array
then
1708 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1709 Set_Object_Definition
(Decl_Node
, P_Array_Type_Definition
);
1711 -- Ada 2005 (AI-254, AI-406)
1713 elsif Token
= Tok_Not
then
1715 -- OBJECT_DECLARATION ::=
1716 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1717 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION]
1718 -- [ASPECT_SPECIFICATIONS];
1719 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1720 -- ACCESS_DEFINITION [:= EXPRESSION]
1721 -- [ASPECT_SPECIFICATIONS];
1723 -- OBJECT_RENAMING_DECLARATION ::=
1724 -- DEFINING_IDENTIFIER :
1725 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME
1726 -- [ASPECT_SPECIFICATIONS];
1727 -- | DEFINING_IDENTIFIER :
1728 -- ACCESS_DEFINITION renames object_NAME
1729 -- [ASPECT_SPECIFICATIONS];
1731 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/423)
1733 if Token
= Tok_Access
then
1734 Error_Msg_Ada_2005_Extension
1735 ("generalized use of anonymous access types");
1737 Acc_Node
:= P_Access_Definition
(Not_Null_Present
);
1739 if Token
/= Tok_Renames
then
1740 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1741 Set_Object_Definition
(Decl_Node
, Acc_Node
);
1744 Scan
; -- past renames
1747 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1748 Set_Access_Definition
(Decl_Node
, Acc_Node
);
1749 Set_Name
(Decl_Node
, P_Name
);
1753 Type_Node
:= P_Subtype_Mark
;
1755 -- Object renaming declaration
1757 if Token_Is_Renames
then
1758 if Ada_Version
< Ada_2005
then
1760 ("`NOT NULL` not allowed in object renaming");
1763 -- Ada 2005 (AI-423): Object renaming declaration with
1764 -- a null exclusion.
1769 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1770 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1771 Set_Subtype_Mark
(Decl_Node
, Type_Node
);
1772 Set_Name
(Decl_Node
, P_Name
);
1775 -- Object declaration
1778 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1779 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1780 Set_Object_Definition
1782 P_Subtype_Indication
(Type_Node
, Not_Null_Present
));
1784 -- RENAMES at this point means that we had the combination
1785 -- of a constraint on the Type_Node and renames, which is
1788 if Token_Is_Renames
then
1790 ("constraint not allowed in object renaming "
1792 Constraint
(Object_Definition
(Decl_Node
)));
1798 -- Ada 2005 (AI-230): Access Definition case
1800 elsif Token
= Tok_Access
then
1801 Error_Msg_Ada_2005_Extension
1802 ("generalized use of anonymous access types");
1804 Acc_Node
:= P_Access_Definition
(Null_Exclusion_Present
=> False);
1806 -- Object declaration with access definition, or renaming
1808 if Token
/= Tok_Renames
then
1809 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1810 Set_Object_Definition
(Decl_Node
, Acc_Node
);
1813 Scan
; -- past renames
1816 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1817 Set_Access_Definition
(Decl_Node
, Acc_Node
);
1818 Set_Name
(Decl_Node
, P_Name
);
1821 -- Subtype indication case
1824 Type_Node
:= P_Subtype_Mark
;
1826 -- Object renaming declaration
1828 if Token_Is_Renames
then
1831 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1832 Set_Subtype_Mark
(Decl_Node
, Type_Node
);
1833 Set_Name
(Decl_Node
, P_Name
);
1835 -- Object declaration
1838 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1839 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1840 Set_Object_Definition
1842 P_Subtype_Indication
(Type_Node
, Not_Null_Present
));
1844 -- RENAMES at this point means that we had the combination of
1845 -- a constraint on the Type_Node and renames, which is illegal
1847 if Token_Is_Renames
then
1849 ("constraint not allowed in object renaming declaration",
1850 Constraint
(Object_Definition
(Decl_Node
)));
1856 -- Scan out initialization, allowed only for object declaration
1858 Init_Loc
:= Token_Ptr
;
1859 Init_Expr
:= Init_Expr_Opt
;
1861 if Present
(Init_Expr
) then
1862 if Nkind
(Decl_Node
) = N_Object_Declaration
then
1863 Set_Expression
(Decl_Node
, Init_Expr
);
1864 Set_Has_Init_Expression
(Decl_Node
);
1866 Error_Msg
("initialization not allowed here", Init_Loc
);
1870 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
1871 P_Aspect_Specifications
(Decl_Node
, Semicolon
=> False);
1873 -- Allow initialization expression to follow aspects (note that in
1874 -- this case P_Aspect_Specifications already issued an error msg).
1876 if Token
= Tok_Colon_Equal
then
1877 if Is_Non_Empty_List
(Aspect_Specifications
(Decl_Node
)) then
1879 ("aspect specifications must come after initialization "
1881 Sloc
(First
(Aspect_Specifications
(Decl_Node
))));
1884 -- In any case, the assignment symbol doesn't belong.
1886 Error_Msg
("misplaced assignment symbol", Scan_Ptr
);
1889 Set_Expression
(Decl_Node
, Init_Expr_Opt
);
1890 Set_Has_Init_Expression
(Decl_Node
);
1893 -- Now scan out the semicolon, which we deferred above
1898 if Ident
< Num_Idents
then
1899 Set_More_Ids
(Decl_Node
, True);
1903 Set_Prev_Ids
(Decl_Node
, True);
1907 Append
(Decl_Node
, Decls
);
1908 exit Ident_Loop
when Ident
= Num_Idents
;
1909 Restore_Scan_State
(Scan_State
);
1912 end loop Ident_Loop
;
1915 end P_Identifier_Declarations
;
1917 -------------------------------
1918 -- 3.3.1 Object Declaration --
1919 -------------------------------
1921 -- OBJECT DECLARATION ::=
1922 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1923 -- SUBTYPE_INDICATION [:= EXPRESSION];
1924 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1925 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1926 -- | SINGLE_TASK_DECLARATION
1927 -- | SINGLE_PROTECTED_DECLARATION
1929 -- Cases starting with TASK are parsed by P_Task (9.1)
1930 -- Cases starting with PROTECTED are parsed by P_Protected (9.4)
1931 -- All other cases are parsed by P_Identifier_Declarations (3.3)
1933 -------------------------------------
1934 -- 3.3.1 Defining Identifier List --
1935 -------------------------------------
1937 -- DEFINING_IDENTIFIER_LIST ::=
1938 -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
1940 -- Always parsed by the construct in which it appears. See special
1941 -- section on "Handling of Defining Identifier Lists" in this unit.
1943 -------------------------------
1944 -- 3.3.2 Number Declaration --
1945 -------------------------------
1947 -- Parsed by P_Identifier_Declarations (3.3)
1949 -------------------------------------------------------------------------
1950 -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) --
1951 -------------------------------------------------------------------------
1953 -- DERIVED_TYPE_DEFINITION ::=
1954 -- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
1955 -- [[and INTERFACE_LIST] RECORD_EXTENSION_PART]
1957 -- PRIVATE_EXTENSION_DECLARATION ::=
1958 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
1959 -- [abstract] [limited | synchronized]
1960 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
1961 -- with private [ASPECT_SPECIFICATIONS];
1963 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
1965 -- The caller has already scanned out the part up to the NEW, and Token
1966 -- either contains Tok_New (or ought to, if it doesn't this procedure
1967 -- will post an appropriate "NEW expected" message).
1969 -- Note: the caller is responsible for filling in the Sloc field of
1970 -- the returned node in the private extension declaration case as
1971 -- well as the stuff relating to the discriminant part.
1973 -- Error recovery: can raise Error_Resync;
1975 function P_Derived_Type_Def_Or_Private_Ext_Decl
return Node_Id
is
1976 Typedef_Node
: Node_Id
;
1977 Typedecl_Node
: Node_Id
;
1978 Not_Null_Present
: Boolean := False;
1981 Typedef_Node
:= New_Node
(N_Derived_Type_Definition
, Token_Ptr
);
1983 if Ada_Version
< Ada_2005
1984 and then Token
= Tok_Identifier
1985 and then Token_Name
= Name_Interface
1988 ("abstract interface is an Ada 2005 extension");
1989 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1994 if Token
= Tok_Abstract
then
1995 Error_Msg_SC
-- CODEFIX
1996 ("ABSTRACT must come before NEW, not after");
2000 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
2001 Set_Null_Exclusion_Present
(Typedef_Node
, Not_Null_Present
);
2002 Set_Subtype_Indication
(Typedef_Node
,
2003 P_Subtype_Indication
(Not_Null_Present
));
2005 -- Ada 2005 (AI-251): Deal with interfaces
2007 if Token
= Tok_And
then
2010 Error_Msg_Ada_2005_Extension
("abstract interface");
2012 Set_Interface_List
(Typedef_Node
, New_List
);
2015 Append
(P_Qualified_Simple_Name
, Interface_List
(Typedef_Node
));
2016 exit when Token
/= Tok_And
;
2020 if Token
/= Tok_With
then
2021 Error_Msg_SC
("WITH expected");
2026 -- Deal with record extension, note that we assume that a WITH is
2027 -- missing in the case of "type X is new Y record ..." or in the
2028 -- case of "type X is new Y null record".
2030 -- First make sure we don't have an aspect specification. If we do
2031 -- return now, so that our caller can check it (the WITH here is not
2032 -- part of a type extension).
2034 if Aspect_Specifications_Present
then
2035 return Typedef_Node
;
2037 -- OK, not an aspect specification, so continue test for extension
2039 elsif Token
= Tok_With
2040 or else Token
= Tok_Record
2041 or else Token
= Tok_Null
2043 T_With
; -- past WITH or give error message
2045 if Token
= Tok_Limited
then
2046 Error_Msg_SC
("LIMITED keyword not allowed in private extension");
2047 Scan
; -- ignore LIMITED
2050 -- Private extension declaration
2052 if Token
= Tok_Private
then
2053 Scan
; -- past PRIVATE
2055 -- Throw away the type definition node and build the type
2056 -- declaration node. Note the caller must set the Sloc,
2057 -- Discriminant_Specifications, Unknown_Discriminants_Present,
2058 -- and Defined_Identifier fields in the returned node.
2061 Make_Private_Extension_Declaration
(No_Location
,
2062 Defining_Identifier
=> Empty
,
2063 Subtype_Indication
=> Subtype_Indication
(Typedef_Node
),
2064 Abstract_Present
=> Abstract_Present
(Typedef_Node
),
2065 Interface_List
=> Interface_List
(Typedef_Node
));
2067 return Typedecl_Node
;
2069 -- Derived type definition with record extension part
2072 Set_Record_Extension_Part
(Typedef_Node
, P_Record_Definition
);
2073 return Typedef_Node
;
2076 -- Derived type definition with no record extension part
2079 return Typedef_Node
;
2081 end P_Derived_Type_Def_Or_Private_Ext_Decl
;
2083 ---------------------------
2084 -- 3.5 Range Constraint --
2085 ---------------------------
2087 -- RANGE_CONSTRAINT ::= range RANGE
2089 -- The caller has checked that the initial token is RANGE or some
2090 -- misspelling of it, or it may be absent completely (and a message
2091 -- has already been issued).
2093 -- Error recovery: cannot raise Error_Resync
2095 function P_Range_Constraint
return Node_Id
is
2096 Range_Node
: Node_Id
;
2099 Range_Node
:= New_Node
(N_Range_Constraint
, Token_Ptr
);
2101 -- Skip range keyword if present
2103 if Token
= Tok_Range
or else Bad_Spelling_Of
(Tok_Range
) then
2107 Set_Range_Expression
(Range_Node
, P_Range
);
2109 end P_Range_Constraint
;
2116 -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
2118 -- Note: the range that appears in a membership test is parsed by
2119 -- P_Range_Or_Subtype_Mark (3.5).
2121 -- Error recovery: cannot raise Error_Resync
2123 function P_Range
return Node_Id
is
2124 Expr_Node
: Node_Id
;
2125 Range_Node
: Node_Id
;
2128 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2130 if Expr_Form
= EF_Range_Attr
then
2133 elsif Token
= Tok_Dot_Dot
then
2134 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2135 Set_Low_Bound
(Range_Node
, Expr_Node
);
2137 Expr_Node
:= P_Expression
;
2138 Check_Simple_Expression
(Expr_Node
);
2139 Set_High_Bound
(Range_Node
, Expr_Node
);
2142 -- Anything else is an error
2145 T_Dot_Dot
; -- force missing .. message
2150 ----------------------------------
2151 -- 3.5 P_Range_Or_Subtype_Mark --
2152 ----------------------------------
2155 -- RANGE_ATTRIBUTE_REFERENCE
2156 -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
2158 -- This routine scans out the range or subtype mark that forms the right
2159 -- operand of a membership test (it is not used in any other contexts, and
2160 -- error messages are specialized with this knowledge in mind).
2162 -- Note: as documented in the Sinfo interface, although the syntax only
2163 -- allows a subtype mark, we in fact allow any simple expression to be
2164 -- returned from this routine. The semantics is responsible for issuing
2165 -- an appropriate message complaining if the argument is not a name.
2166 -- This simplifies the coding and error recovery processing in the
2167 -- parser, and in any case it is preferable not to consider this a
2168 -- syntax error and to continue with the semantic analysis.
2170 -- Error recovery: cannot raise Error_Resync
2172 function P_Range_Or_Subtype_Mark
2173 (Allow_Simple_Expression
: Boolean := False) return Node_Id
2175 Expr_Node
: Node_Id
;
2176 Range_Node
: Node_Id
;
2177 Save_Loc
: Source_Ptr
;
2179 -- Start of processing for P_Range_Or_Subtype_Mark
2182 -- Save location of possible junk parentheses
2184 Save_Loc
:= Token_Ptr
;
2186 -- Scan out either a simple expression or a range (this accepts more
2187 -- than is legal here, but as explained above, we like to allow more
2188 -- with a proper diagnostic, and in the case of a membership operation
2189 -- where sets are allowed, a simple expression is permissible anyway.
2191 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2195 if Expr_Form
= EF_Range_Attr
then
2198 -- Simple_Expression .. Simple_Expression
2200 elsif Token
= Tok_Dot_Dot
then
2201 Check_Simple_Expression
(Expr_Node
);
2202 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2203 Set_Low_Bound
(Range_Node
, Expr_Node
);
2205 Set_High_Bound
(Range_Node
, P_Simple_Expression
);
2208 -- Case of subtype mark (optionally qualified simple name or an
2209 -- attribute whose prefix is an optionally qualified simple name)
2211 elsif Expr_Form
= EF_Simple_Name
2212 or else Nkind
(Expr_Node
) = N_Attribute_Reference
2214 -- Check for error of range constraint after a subtype mark
2216 if Token
= Tok_Range
then
2217 Error_Msg_SC
("range constraint not allowed in membership test");
2221 -- Check for error of DIGITS or DELTA after a subtype mark
2223 elsif Token
= Tok_Digits
or else Token
= Tok_Delta
then
2225 ("accuracy definition not allowed in membership test");
2226 Scan
; -- past DIGITS or DELTA
2229 -- Attribute reference, may or may not be OK, but in any case we
2232 elsif Token
= Tok_Apostrophe
then
2233 return P_Subtype_Mark_Attribute
(Expr_Node
);
2235 -- OK case of simple name, just return it
2241 -- Simple expression case
2243 elsif Expr_Form
= EF_Simple
and then Allow_Simple_Expression
then
2246 -- Here we have some kind of error situation. Check for junk parens
2247 -- then return what we have, caller will deal with other errors.
2250 if Nkind
(Expr_Node
) in N_Subexpr
2251 and then Paren_Count
(Expr_Node
) /= 0
2253 Error_Msg
("|parentheses not allowed for subtype mark", Save_Loc
);
2254 Set_Paren_Count
(Expr_Node
, 0);
2259 end P_Range_Or_Subtype_Mark
;
2261 ----------------------------------------
2262 -- 3.5.1 Enumeration Type Definition --
2263 ----------------------------------------
2265 -- ENUMERATION_TYPE_DEFINITION ::=
2266 -- (ENUMERATION_LITERAL_SPECIFICATION
2267 -- {, ENUMERATION_LITERAL_SPECIFICATION})
2269 -- The caller has already scanned out the TYPE keyword
2271 -- Error recovery: can raise Error_Resync;
2273 function P_Enumeration_Type_Definition
return Node_Id
is
2274 Typedef_Node
: Node_Id
;
2277 Typedef_Node
:= New_Node
(N_Enumeration_Type_Definition
, Token_Ptr
);
2278 Set_Literals
(Typedef_Node
, New_List
);
2283 Append
(P_Enumeration_Literal_Specification
, Literals
(Typedef_Node
));
2284 exit when not Comma_Present
;
2288 return Typedef_Node
;
2289 end P_Enumeration_Type_Definition
;
2291 ----------------------------------------------
2292 -- 3.5.1 Enumeration Literal Specification --
2293 ----------------------------------------------
2295 -- ENUMERATION_LITERAL_SPECIFICATION ::=
2296 -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
2298 -- Error recovery: can raise Error_Resync
2300 function P_Enumeration_Literal_Specification
return Node_Id
is
2302 if Token
= Tok_Char_Literal
then
2303 return P_Defining_Character_Literal
;
2305 return P_Defining_Identifier
(C_Comma_Right_Paren
);
2307 end P_Enumeration_Literal_Specification
;
2309 ---------------------------------------
2310 -- 3.5.1 Defining_Character_Literal --
2311 ---------------------------------------
2313 -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
2315 -- Error recovery: cannot raise Error_Resync
2317 -- The caller has checked that the current token is a character literal
2319 function P_Defining_Character_Literal
return Node_Id
is
2320 Literal_Node
: Node_Id
;
2322 Literal_Node
:= Token_Node
;
2323 Change_Character_Literal_To_Defining_Character_Literal
(Literal_Node
);
2324 Scan
; -- past character literal
2325 return Literal_Node
;
2326 end P_Defining_Character_Literal
;
2328 ------------------------------------
2329 -- 3.5.4 Integer Type Definition --
2330 ------------------------------------
2332 -- Parsed by P_Type_Declaration (3.2.1)
2334 -------------------------------------------
2335 -- 3.5.4 Signed Integer Type Definition --
2336 -------------------------------------------
2338 -- SIGNED_INTEGER_TYPE_DEFINITION ::=
2339 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2341 -- Normally the initial token on entry is RANGE, but in some
2342 -- error conditions, the range token was missing and control is
2343 -- passed with Token pointing to first token of the first expression.
2345 -- Error recovery: cannot raise Error_Resync
2347 function P_Signed_Integer_Type_Definition
return Node_Id
is
2348 Typedef_Node
: Node_Id
;
2349 Expr_Node
: Node_Id
;
2352 Typedef_Node
:= New_Node
(N_Signed_Integer_Type_Definition
, Token_Ptr
);
2354 if Token
= Tok_Range
then
2358 Expr_Node
:= P_Expression_Or_Range_Attribute
;
2360 -- Range case (not permitted by the grammar, this is surprising but
2361 -- the grammar in the RM is as quoted above, and does not allow Range).
2363 if Expr_Form
= EF_Range_Attr
then
2365 ("Range attribute not allowed here, use First .. Last", Expr_Node
);
2366 Set_Low_Bound
(Typedef_Node
, Expr_Node
);
2367 Set_Attribute_Name
(Expr_Node
, Name_First
);
2368 Set_High_Bound
(Typedef_Node
, Copy_Separate_Tree
(Expr_Node
));
2369 Set_Attribute_Name
(High_Bound
(Typedef_Node
), Name_Last
);
2371 -- Normal case of explicit range
2374 Check_Simple_Expression
(Expr_Node
);
2375 Set_Low_Bound
(Typedef_Node
, Expr_Node
);
2377 Expr_Node
:= P_Expression
;
2378 Check_Simple_Expression
(Expr_Node
);
2379 Set_High_Bound
(Typedef_Node
, Expr_Node
);
2382 return Typedef_Node
;
2383 end P_Signed_Integer_Type_Definition
;
2385 ------------------------------------
2386 -- 3.5.4 Modular Type Definition --
2387 ------------------------------------
2389 -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
2391 -- The caller has checked that the initial token is MOD
2393 -- Error recovery: cannot raise Error_Resync
2395 function P_Modular_Type_Definition
return Node_Id
is
2396 Typedef_Node
: Node_Id
;
2399 if Ada_Version
= Ada_83
then
2400 Error_Msg_SC
("(Ada 83) modular types not allowed");
2403 Typedef_Node
:= New_Node
(N_Modular_Type_Definition
, Token_Ptr
);
2405 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
2407 -- Handle mod L..R cleanly
2409 if Token
= Tok_Dot_Dot
then
2410 Error_Msg_SC
("range not allowed for modular type");
2412 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
2415 return Typedef_Node
;
2416 end P_Modular_Type_Definition
;
2418 ---------------------------------
2419 -- 3.5.6 Real Type Definition --
2420 ---------------------------------
2422 -- Parsed by P_Type_Declaration (3.2.1)
2424 --------------------------------------
2425 -- 3.5.7 Floating Point Definition --
2426 --------------------------------------
2428 -- FLOATING_POINT_DEFINITION ::=
2429 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2431 -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
2433 -- The caller has checked that the initial token is DIGITS
2435 -- Error recovery: cannot raise Error_Resync
2437 function P_Floating_Point_Definition
return Node_Id
is
2438 Digits_Loc
: constant Source_Ptr
:= Token_Ptr
;
2440 Expr_Node
: Node_Id
;
2443 Scan
; -- past DIGITS
2444 Expr_Node
:= P_Expression_No_Right_Paren
;
2445 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2447 -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
2449 if Token
= Tok_Delta
then
2450 Error_Msg_SC
-- CODEFIX
2451 ("|DELTA must come before DIGITS");
2452 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Digits_Loc
);
2454 Set_Delta_Expression
(Def_Node
, P_Expression_No_Right_Paren
);
2456 -- OK floating-point definition
2459 Def_Node
:= New_Node
(N_Floating_Point_Definition
, Digits_Loc
);
2462 Set_Digits_Expression
(Def_Node
, Expr_Node
);
2463 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
2465 end P_Floating_Point_Definition
;
2467 -------------------------------------
2468 -- 3.5.7 Real Range Specification --
2469 -------------------------------------
2471 -- REAL_RANGE_SPECIFICATION ::=
2472 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2474 -- Error recovery: cannot raise Error_Resync
2476 function P_Real_Range_Specification_Opt
return Node_Id
is
2477 Specification_Node
: Node_Id
;
2478 Expr_Node
: Node_Id
;
2481 if Token
= Tok_Range
then
2482 Specification_Node
:=
2483 New_Node
(N_Real_Range_Specification
, Token_Ptr
);
2485 Expr_Node
:= P_Expression_No_Right_Paren
;
2486 Check_Simple_Expression
(Expr_Node
);
2487 Set_Low_Bound
(Specification_Node
, Expr_Node
);
2489 Expr_Node
:= P_Expression_No_Right_Paren
;
2490 Check_Simple_Expression
(Expr_Node
);
2491 Set_High_Bound
(Specification_Node
, Expr_Node
);
2492 return Specification_Node
;
2496 end P_Real_Range_Specification_Opt
;
2498 -----------------------------------
2499 -- 3.5.9 Fixed Point Definition --
2500 -----------------------------------
2502 -- FIXED_POINT_DEFINITION ::=
2503 -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
2505 -- ORDINARY_FIXED_POINT_DEFINITION ::=
2506 -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION
2508 -- DECIMAL_FIXED_POINT_DEFINITION ::=
2509 -- delta static_EXPRESSION
2510 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2512 -- The caller has checked that the initial token is DELTA
2514 -- Error recovery: cannot raise Error_Resync
2516 function P_Fixed_Point_Definition
return Node_Id
is
2517 Delta_Node
: Node_Id
;
2518 Delta_Loc
: Source_Ptr
;
2520 Expr_Node
: Node_Id
;
2523 Delta_Loc
:= Token_Ptr
;
2525 Delta_Node
:= P_Expression_No_Right_Paren
;
2526 Check_Simple_Expression_In_Ada_83
(Delta_Node
);
2528 if Token
= Tok_Digits
then
2529 if Ada_Version
= Ada_83
then
2530 Error_Msg_SC
("(Ada 83) decimal fixed type not allowed!");
2533 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Delta_Loc
);
2534 Scan
; -- past DIGITS
2535 Expr_Node
:= P_Expression_No_Right_Paren
;
2536 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2537 Set_Digits_Expression
(Def_Node
, Expr_Node
);
2540 Def_Node
:= New_Node
(N_Ordinary_Fixed_Point_Definition
, Delta_Loc
);
2542 -- Range is required in ordinary fixed point case
2544 if Token
/= Tok_Range
then
2545 Error_Msg_AP
("range must be given for fixed-point type");
2550 Set_Delta_Expression
(Def_Node
, Delta_Node
);
2551 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
2553 end P_Fixed_Point_Definition
;
2555 --------------------------------------------
2556 -- 3.5.9 Ordinary Fixed Point Definition --
2557 --------------------------------------------
2559 -- Parsed by P_Fixed_Point_Definition (3.5.9)
2561 -------------------------------------------
2562 -- 3.5.9 Decimal Fixed Point Definition --
2563 -------------------------------------------
2565 -- Parsed by P_Decimal_Point_Definition (3.5.9)
2567 ------------------------------
2568 -- 3.5.9 Digits Constraint --
2569 ------------------------------
2571 -- DIGITS_CONSTRAINT ::=
2572 -- digits static_EXPRESSION [RANGE_CONSTRAINT]
2574 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2576 -- The caller has checked that the initial token is DIGITS
2578 function P_Digits_Constraint
return Node_Id
is
2579 Constraint_Node
: Node_Id
;
2580 Expr_Node
: Node_Id
;
2583 Constraint_Node
:= New_Node
(N_Digits_Constraint
, Token_Ptr
);
2584 Scan
; -- past DIGITS
2585 Expr_Node
:= P_Expression
;
2586 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2587 Set_Digits_Expression
(Constraint_Node
, Expr_Node
);
2589 if Token
= Tok_Range
then
2590 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
2593 return Constraint_Node
;
2594 end P_Digits_Constraint
;
2596 -----------------------------
2597 -- 3.5.9 Delta Constraint --
2598 -----------------------------
2600 -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
2602 -- Note: this is an obsolescent feature in Ada 95 (I.3)
2604 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2605 -- (also true in formal modes).
2607 -- The caller has checked that the initial token is DELTA
2609 -- Error recovery: cannot raise Error_Resync
2611 function P_Delta_Constraint
return Node_Id
is
2612 Constraint_Node
: Node_Id
;
2613 Expr_Node
: Node_Id
;
2616 Constraint_Node
:= New_Node
(N_Delta_Constraint
, Token_Ptr
);
2618 Expr_Node
:= P_Expression
;
2619 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2621 Set_Delta_Expression
(Constraint_Node
, Expr_Node
);
2623 if Token
= Tok_Range
then
2624 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
2627 return Constraint_Node
;
2628 end P_Delta_Constraint
;
2630 --------------------------------
2631 -- 3.6 Array Type Definition --
2632 --------------------------------
2634 -- ARRAY_TYPE_DEFINITION ::=
2635 -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
2637 -- UNCONSTRAINED_ARRAY_DEFINITION ::=
2638 -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
2639 -- COMPONENT_DEFINITION
2641 -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
2643 -- CONSTRAINED_ARRAY_DEFINITION ::=
2644 -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
2645 -- COMPONENT_DEFINITION
2647 -- DISCRETE_SUBTYPE_DEFINITION ::=
2648 -- DISCRETE_SUBTYPE_INDICATION | RANGE
2650 -- COMPONENT_DEFINITION ::=
2651 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
2653 -- The caller has checked that the initial token is ARRAY
2655 -- Error recovery: can raise Error_Resync
2657 function P_Array_Type_Definition
return Node_Id
is
2658 Array_Loc
: Source_Ptr
;
2659 CompDef_Node
: Node_Id
;
2661 Not_Null_Present
: Boolean := False;
2662 Subs_List
: List_Id
;
2663 Scan_State
: Saved_Scan_State
;
2664 Aliased_Present
: Boolean := False;
2666 procedure P_Index_Subtype_Def_With_Fixed_Lower_Bound
2667 (Subtype_Mark
: Node_Id
);
2668 -- Parse an unconstrained index range with a fixed lower bound:
2669 -- subtype_mark range <expression> .. <>
2670 -- This procedure creates a subtype_indication node for the index.
2672 --------------------------------------------
2673 -- P_Index_Range_With_Fixed_Lower_Bound --
2674 --------------------------------------------
2676 procedure P_Index_Subtype_Def_With_Fixed_Lower_Bound
2677 (Subtype_Mark
: Node_Id
)
2679 Low_Expr_Node
: constant Node_Id
:= P_Expression
;
2680 High_Expr_Node
: Node_Id
;
2681 Indic_Node
: Node_Id
;
2682 Constr_Node
: Node_Id
;
2683 Range_Node
: Node_Id
;
2686 T_Dot_Dot
; -- Error if no ..
2688 -- A box is required at this point, and we'll set the upper bound to
2689 -- the same expression as the lower bound (see further below), to
2690 -- avoid problems with trying to analyze an Empty node. Analysis can
2691 -- still tell that this is a fixed-lower-bound range because the
2692 -- index is represented by a subtype_indication in an unconstrained
2693 -- array type definition.
2695 if Token
= Tok_Box
then
2697 High_Expr_Node
:= Low_Expr_Node
;
2699 -- Error if no <> was found, and try to parse an expression since
2700 -- it's likely one was given in place of the <>.
2703 Error_Msg_AP
-- CODEFIX
2704 ("missing ""'<'>""");
2706 High_Expr_Node
:= P_Expression
;
2709 Constr_Node
:= New_Node
(N_Range_Constraint
, Token_Ptr
);
2710 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2711 Set_Range_Expression
(Constr_Node
, Range_Node
);
2713 Check_Simple_Expression
(Low_Expr_Node
);
2715 Set_Low_Bound
(Range_Node
, Low_Expr_Node
);
2716 Set_High_Bound
(Range_Node
, High_Expr_Node
);
2719 New_Node
(N_Subtype_Indication
, Sloc
(Subtype_Mark
));
2720 Set_Subtype_Mark
(Indic_Node
, Check_Subtype_Mark
(Subtype_Mark
));
2721 Set_Constraint
(Indic_Node
, Constr_Node
);
2723 Append
(Indic_Node
, Subs_List
);
2724 end P_Index_Subtype_Def_With_Fixed_Lower_Bound
;
2728 Is_Constrained_Array_Def
: Boolean := True;
2729 Subtype_Mark_Node
: Node_Id
;
2731 -- Start of processing for P_Array_Type_Definition
2734 Array_Loc
:= Token_Ptr
;
2736 Subs_List
:= New_List
;
2739 -- It's quite tricky to disentangle these two possibilities, so we do
2740 -- a prescan to determine which case we have and then reset the scan.
2741 -- The prescan skips past possible subtype mark tokens.
2743 Save_Scan_State
(Scan_State
); -- just after paren
2745 while Token
in Token_Class_Desig
or else
2746 Token
= Tok_Dot
or else
2747 Token
= Tok_Apostrophe
-- because of 'BASE, 'CLASS
2752 -- If we end up on RANGE <> then we have the unconstrained case. We
2753 -- will also allow the RANGE to be omitted, just to improve error
2754 -- handling for a case like array (integer <>) of integer;
2756 Scan
; -- past possible RANGE or <>
2758 if (Prev_Token
= Tok_Range
and then Token
= Tok_Box
) or else
2759 Prev_Token
= Tok_Box
2761 Def_Node
:= New_Node
(N_Unconstrained_Array_Definition
, Array_Loc
);
2762 Restore_Scan_State
(Scan_State
); -- to first subtype mark
2764 Is_Constrained_Array_Def
:= False;
2766 -- Now parse a sequence of indexes where each is either of form:
2767 -- <subtype_mark> range <>
2769 -- <subtype_mark> range <expr> .. <>
2771 -- The latter syntax indicates an index with a fixed lower bound,
2772 -- and only applies when extensions are enabled (-gnatX).
2775 Subtype_Mark_Node
:= P_Subtype_Mark_Resync
;
2779 -- Normal "subtype_mark range <>" form, so simply append
2780 -- the subtype reference.
2782 if Token
= Tok_Box
then
2783 Append
(Subtype_Mark_Node
, Subs_List
);
2786 -- Fixed-lower-bound form ("subtype_mark range <expr> .. <>")
2789 P_Index_Subtype_Def_With_Fixed_Lower_Bound
(Subtype_Mark_Node
);
2791 Error_Msg_GNAT_Extension
("fixed-lower-bound array", Token_Ptr
);
2794 exit when Token
= Tok_Right_Paren
or else Token
= Tok_Of
;
2798 Set_Subtype_Marks
(Def_Node
, Subs_List
);
2800 -- If we don't have "range <>", then "range" will be followed by an
2801 -- expression, for either a normal range or a fixed-lower-bound range
2802 -- ("<exp> .. <>"), and we have to know which, in order to determine
2803 -- whether to parse the indexes for an unconstrained or constrained
2804 -- array definition. So we look ahead to see if "<>" follows the "..".
2805 -- If not, then this must be a discrete_subtype_indication for a
2806 -- constrained_array_definition, which will be processed further below.
2808 elsif Prev_Token
= Tok_Range
2809 and then Token
/= Tok_Right_Paren
and then Token
/= Tok_Comma
2811 -- If we have an expression followed by "..", then scan farther
2812 -- and check for "<>" to see if we have a fixed-lower-bound range.
2814 if P_Expression_Or_Range_Attribute
/= Error
2815 and then Expr_Form
/= EF_Range_Attr
2816 and then Token
= Tok_Dot_Dot
2820 -- If there's a "<>", then we know we have a fixed-lower-bound
2821 -- index, so we can proceed with parsing an unconstrained array
2824 if Token
= Tok_Box
then
2825 Is_Constrained_Array_Def
:= False;
2828 New_Node
(N_Unconstrained_Array_Definition
, Array_Loc
);
2830 Restore_Scan_State
(Scan_State
); -- to first subtype mark
2832 -- Now parse a sequence of indexes where each is either of
2834 -- <subtype_mark> range <>
2836 -- <subtype_mark> range <expr> .. <>
2838 -- The latter indicates an index with a fixed lower bound,
2839 -- and only applies when extensions are enabled (-gnatX).
2842 Subtype_Mark_Node
:= P_Subtype_Mark_Resync
;
2846 -- Normal "subtype_mark range <>" form, so simply append
2847 -- the subtype reference.
2849 if Token
= Tok_Box
then
2850 Append
(Subtype_Mark_Node
, Subs_List
);
2853 -- This must be an index of form:
2854 -- <subtype_mark> range <expr> .. <>"
2857 P_Index_Subtype_Def_With_Fixed_Lower_Bound
2858 (Subtype_Mark_Node
);
2860 Error_Msg_GNAT_Extension
2861 ("fixed-lower-bound array", Token_Ptr
);
2864 exit when Token
= Tok_Right_Paren
or else Token
= Tok_Of
;
2868 Set_Subtype_Marks
(Def_Node
, Subs_List
);
2873 if Is_Constrained_Array_Def
then
2874 Def_Node
:= New_Node
(N_Constrained_Array_Definition
, Array_Loc
);
2875 Restore_Scan_State
(Scan_State
); -- to first discrete range
2878 Append
(P_Discrete_Subtype_Definition
, Subs_List
);
2879 exit when not Comma_Present
;
2882 Set_Discrete_Subtype_Definitions
(Def_Node
, Subs_List
);
2888 CompDef_Node
:= New_Node
(N_Component_Definition
, Token_Ptr
);
2890 if Token_Name
= Name_Aliased
then
2891 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
2894 if Token
= Tok_Aliased
then
2895 Aliased_Present
:= True;
2896 Scan
; -- past ALIASED
2899 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/AI-254)
2901 -- Ada 2005 (AI-230): Access Definition case
2903 if Token
= Tok_Access
then
2904 Error_Msg_Ada_2005_Extension
2905 ("generalized use of anonymous access types");
2907 -- AI95-406 makes "aliased" legal (and useless) in this context so
2908 -- followintg code which used to be needed is commented out.
2910 -- if Aliased_Present then
2911 -- Error_Msg_SP ("ALIASED not allowed here");
2914 Set_Subtype_Indication
(CompDef_Node
, Empty
);
2915 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
2916 Set_Access_Definition
(CompDef_Node
,
2917 P_Access_Definition
(Not_Null_Present
));
2920 Set_Access_Definition
(CompDef_Node
, Empty
);
2921 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
2922 Set_Null_Exclusion_Present
(CompDef_Node
, Not_Null_Present
);
2923 Set_Subtype_Indication
(CompDef_Node
,
2924 P_Subtype_Indication
(Not_Null_Present
));
2927 Set_Component_Definition
(Def_Node
, CompDef_Node
);
2930 end P_Array_Type_Definition
;
2932 -----------------------------------------
2933 -- 3.6 Unconstrained Array Definition --
2934 -----------------------------------------
2936 -- Parsed by P_Array_Type_Definition (3.6)
2938 ---------------------------------------
2939 -- 3.6 Constrained Array Definition --
2940 ---------------------------------------
2942 -- Parsed by P_Array_Type_Definition (3.6)
2944 --------------------------------------
2945 -- 3.6 Discrete Subtype Definition --
2946 --------------------------------------
2948 -- DISCRETE_SUBTYPE_DEFINITION ::=
2949 -- discrete_SUBTYPE_INDICATION | RANGE
2951 -- Note: the discrete subtype definition appearing in a constrained
2952 -- array definition is parsed by P_Array_Type_Definition (3.6)
2954 -- Error recovery: cannot raise Error_Resync
2956 function P_Discrete_Subtype_Definition
return Node_Id
is
2958 -- The syntax of a discrete subtype definition is identical to that
2959 -- of a discrete range, so we simply share the same parsing code.
2961 return P_Discrete_Range
;
2962 end P_Discrete_Subtype_Definition
;
2964 -------------------------------
2965 -- 3.6 Component Definition --
2966 -------------------------------
2968 -- For the array case, parsed by P_Array_Type_Definition (3.6)
2969 -- For the record case, parsed by P_Component_Declaration (3.8)
2971 -----------------------------
2972 -- 3.6.1 Index Constraint --
2973 -----------------------------
2975 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2977 ---------------------------
2978 -- 3.6.1 Discrete Range --
2979 ---------------------------
2981 -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
2983 -- The possible forms for a discrete range are:
2985 -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2)
2986 -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2)
2987 -- Range_Attribute (RANGE, 3.5)
2988 -- Simple_Expression .. Simple_Expression (RANGE, 3.5)
2990 -- Error recovery: cannot raise Error_Resync
2992 function P_Discrete_Range
return Node_Id
is
2993 Expr_Node
: Node_Id
;
2994 Range_Node
: Node_Id
;
2997 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2999 if Expr_Form
= EF_Range_Attr
then
3002 elsif Token
= Tok_Range
then
3003 if Expr_Form
/= EF_Simple_Name
then
3004 Error_Msg_SC
("range must be preceded by subtype mark");
3007 return P_Subtype_Indication
(Expr_Node
);
3009 -- Check Expression .. Expression case
3011 elsif Token
= Tok_Dot_Dot
then
3012 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
3013 Set_Low_Bound
(Range_Node
, Expr_Node
);
3015 Expr_Node
:= P_Expression
;
3016 Check_Simple_Expression
(Expr_Node
);
3017 Set_High_Bound
(Range_Node
, Expr_Node
);
3020 -- Otherwise we must have a subtype mark, or an Ada 2012 iterator
3022 elsif Expr_Form
= EF_Simple_Name
then
3025 -- The domain of iteration must be a name. Semantics will determine that
3026 -- the expression has the proper form.
3028 elsif Ada_Version
>= Ada_2012
then
3031 -- If incorrect, complain that we expect ..
3037 end P_Discrete_Range
;
3039 ----------------------------
3040 -- 3.7 Discriminant Part --
3041 ----------------------------
3043 -- DISCRIMINANT_PART ::=
3044 -- UNKNOWN_DISCRIMINANT_PART
3045 -- | KNOWN_DISCRIMINANT_PART
3047 -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
3048 -- or P_Unknown_Discriminant_Part (3.7), since we know which we want.
3050 ------------------------------------
3051 -- 3.7 Unknown Discriminant Part --
3052 ------------------------------------
3054 -- UNKNOWN_DISCRIMINANT_PART ::= (<>)
3056 -- If no unknown discriminant part is present, then False is returned,
3057 -- otherwise the unknown discriminant is scanned out and True is returned.
3059 -- Error recovery: cannot raise Error_Resync
3061 function P_Unknown_Discriminant_Part_Opt
return Boolean is
3062 Scan_State
: Saved_Scan_State
;
3065 -- If <> right now, then this is missing left paren
3067 if Token
= Tok_Box
then
3070 -- If not <> or left paren, then definitely no box
3072 elsif Token
/= Tok_Left_Paren
then
3075 -- Left paren, so might be a box after it
3078 Save_Scan_State
(Scan_State
);
3079 Scan
; -- past the left paren
3081 if Token
/= Tok_Box
then
3082 Restore_Scan_State
(Scan_State
);
3087 -- We are now pointing to the box
3089 if Ada_Version
= Ada_83
then
3090 Error_Msg_SC
("(Ada 83) unknown discriminant not allowed!");
3093 Scan
; -- past the box
3094 U_Right_Paren
; -- must be followed by right paren
3096 end P_Unknown_Discriminant_Part_Opt
;
3098 ----------------------------------
3099 -- 3.7 Known Discriminant Part --
3100 ----------------------------------
3102 -- KNOWN_DISCRIMINANT_PART ::=
3103 -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
3105 -- DISCRIMINANT_SPECIFICATION ::=
3106 -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
3107 -- [:= DEFAULT_EXPRESSION] [ASPECT_SPECIFICATION]
3108 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
3109 -- [:= DEFAULT_EXPRESSION] [ASPECT_SPECIFICATION]
3111 -- If no known discriminant part is present, then No_List is returned
3113 -- Error recovery: cannot raise Error_Resync
3115 function P_Known_Discriminant_Part_Opt
return List_Id
is
3116 Specification_Node
: Node_Id
;
3117 Specification_List
: List_Id
;
3118 Ident_Sloc
: Source_Ptr
;
3119 Scan_State
: Saved_Scan_State
;
3121 Not_Null_Present
: Boolean;
3124 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
3125 -- This array holds the list of defining identifiers. The upper bound
3126 -- of 4096 is intended to be essentially infinite, and we do not even
3127 -- bother to check for it being exceeded.
3130 if Token
= Tok_Left_Paren
then
3131 Specification_List
:= New_List
;
3133 P_Pragmas_Misplaced
;
3135 Specification_Loop
: loop
3137 Ident_Sloc
:= Token_Ptr
;
3138 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
3141 while Comma_Present
loop
3142 Num_Idents
:= Num_Idents
+ 1;
3143 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
3146 -- If there are multiple identifiers, we repeatedly scan the
3147 -- type and initialization expression information by resetting
3148 -- the scan pointer (so that we get completely separate trees
3149 -- for each occurrence).
3151 if Num_Idents
> 1 then
3152 Save_Scan_State
(Scan_State
);
3157 -- Loop through defining identifiers in list
3161 Specification_Node
:=
3162 New_Node
(N_Discriminant_Specification
, Ident_Sloc
);
3163 Set_Defining_Identifier
(Specification_Node
, Idents
(Ident
));
3164 Not_Null_Present
:= -- Ada 2005 (AI-231, AI-447)
3165 P_Null_Exclusion
(Allow_Anonymous_In_95
=> True);
3167 if Token
= Tok_Access
then
3168 if Ada_Version
= Ada_83
then
3170 ("(Ada 83) access discriminant not allowed!");
3173 Set_Discriminant_Type
3174 (Specification_Node
,
3175 P_Access_Definition
(Not_Null_Present
));
3177 -- Catch ouf-of-order keywords
3179 elsif Token
= Tok_Constant
then
3182 if Token
= Tok_Access
then
3183 Error_Msg_SC
-- CODEFIX
3184 ("ACCESS must come before CONSTANT");
3185 Set_Discriminant_Type
3186 (Specification_Node
,
3187 P_Access_Definition
(Not_Null_Present
));
3190 Error_Msg_SC
("misplaced CONSTANT");
3194 Set_Discriminant_Type
3195 (Specification_Node
, P_Subtype_Mark
);
3197 Set_Null_Exclusion_Present
-- Ada 2005 (AI-231)
3198 (Specification_Node
, Not_Null_Present
);
3202 (Specification_Node
, Init_Expr_Opt
(True));
3204 if Token
= Tok_With
then
3205 P_Aspect_Specifications
(Specification_Node
, False);
3209 Set_Prev_Ids
(Specification_Node
, True);
3212 if Ident
< Num_Idents
then
3213 Set_More_Ids
(Specification_Node
, True);
3216 Append
(Specification_Node
, Specification_List
);
3217 exit Ident_Loop
when Ident
= Num_Idents
;
3219 Restore_Scan_State
(Scan_State
);
3221 end loop Ident_Loop
;
3223 exit Specification_Loop
when Token
/= Tok_Semicolon
;
3225 P_Pragmas_Misplaced
;
3226 end loop Specification_Loop
;
3229 return Specification_List
;
3234 end P_Known_Discriminant_Part_Opt
;
3236 -------------------------------------
3237 -- 3.7 Discriminant Specification --
3238 -------------------------------------
3240 -- Parsed by P_Known_Discriminant_Part_Opt (3.7)
3242 -----------------------------
3243 -- 3.7 Default Expression --
3244 -----------------------------
3246 -- Always parsed (simply as an Expression) by the parent construct
3248 ------------------------------------
3249 -- 3.7.1 Discriminant Constraint --
3250 ------------------------------------
3252 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
3254 --------------------------------------------------------
3255 -- 3.7.1 Index or Discriminant Constraint (also 3.6) --
3256 --------------------------------------------------------
3258 -- DISCRIMINANT_CONSTRAINT ::=
3259 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
3261 -- DISCRIMINANT_ASSOCIATION ::=
3262 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
3265 -- This routine parses either an index or a discriminant constraint. As
3266 -- is clear from the above grammar, it is often possible to clearly
3267 -- determine which of the two possibilities we have, but there are
3268 -- cases (those in which we have a series of expressions of the same
3269 -- syntactic form as subtype indications), where we cannot tell. Since
3270 -- this means that in any case the semantic phase has to distinguish
3271 -- between the two, there is not much point in the parser trying to
3272 -- distinguish even those cases where the difference is clear. In any
3273 -- case, if we have a situation like:
3275 -- (A => 123, 235 .. 500)
3277 -- it is not clear which of the two items is the wrong one, better to
3278 -- let the semantic phase give a clear message. Consequently, this
3279 -- routine in general returns a list of items which can be either
3280 -- discrete ranges or discriminant associations.
3282 -- The caller has checked that the initial token is a left paren
3284 -- Error recovery: can raise Error_Resync
3286 function P_Index_Or_Discriminant_Constraint
return Node_Id
is
3287 Scan_State
: Saved_Scan_State
;
3288 Constr_Node
: Node_Id
;
3289 Constr_List
: List_Id
;
3290 Expr_Node
: Node_Id
;
3291 Result_Node
: Node_Id
;
3294 Result_Node
:= New_Node
(N_Index_Or_Discriminant_Constraint
, Token_Ptr
);
3296 Constr_List
:= New_List
;
3297 Set_Constraints
(Result_Node
, Constr_List
);
3299 -- The two syntactic forms are a little mixed up, so what we are doing
3300 -- here is looking at the first entry to determine which case we have
3302 -- A discriminant constraint is a list of discriminant associations,
3303 -- which have one of the following possible forms:
3307 -- Id | Id | .. | Id => Expression
3309 -- An index constraint is a list of discrete ranges which have one
3310 -- of the following possible forms:
3313 -- Subtype_Mark range Range
3315 -- Simple_Expression .. Simple_Expression
3317 -- Loop through discriminants in list
3320 -- Check cases of Id => Expression or Id | Id => Expression
3322 if Token
= Tok_Identifier
then
3323 Save_Scan_State
(Scan_State
); -- at Id
3326 if Token
= Tok_Arrow
or else Token
= Tok_Vertical_Bar
then
3327 Restore_Scan_State
(Scan_State
); -- to Id
3328 Append
(P_Discriminant_Association
, Constr_List
);
3331 Restore_Scan_State
(Scan_State
); -- to Id
3335 -- Otherwise scan out an expression and see what we have got
3337 Expr_Node
:= P_Expression_Or_Range_Attribute
;
3339 if Expr_Form
= EF_Range_Attr
then
3340 Append
(Expr_Node
, Constr_List
);
3342 elsif Token
= Tok_Range
then
3343 if Expr_Form
/= EF_Simple_Name
then
3344 Error_Msg_SC
("subtype mark required before RANGE");
3347 Append
(P_Subtype_Indication
(Expr_Node
), Constr_List
);
3350 -- Check Simple_Expression .. Simple_Expression case
3352 elsif Token
= Tok_Dot_Dot
then
3353 Check_Simple_Expression
(Expr_Node
);
3354 Constr_Node
:= New_Node
(N_Range
, Token_Ptr
);
3355 Set_Low_Bound
(Constr_Node
, Expr_Node
);
3358 -- If the upper bound is given by "<>", this is an index for
3359 -- a fixed-lower-bound subtype, so set the expression to Empty
3360 -- for now (it will be set to the ranges maximum upper bound
3361 -- later during analysis), and scan to the next token.
3363 if Token
= Tok_Box
then
3364 Error_Msg_GNAT_Extension
("fixed-lower-bound array", Token_Ptr
);
3369 -- Otherwise parse the range's upper bound expression
3372 Expr_Node
:= P_Expression
;
3373 Check_Simple_Expression
(Expr_Node
);
3376 Set_High_Bound
(Constr_Node
, Expr_Node
);
3377 Append
(Constr_Node
, Constr_List
);
3380 -- Case of an expression which could be either form
3383 Append
(Expr_Node
, Constr_List
);
3387 -- Here with a single entry scanned
3390 exit when not Comma_Present
;
3396 end P_Index_Or_Discriminant_Constraint
;
3398 -------------------------------------
3399 -- 3.7.1 Discriminant Association --
3400 -------------------------------------
3402 -- DISCRIMINANT_ASSOCIATION ::=
3403 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
3406 -- This routine is used only when the name list is present and the caller
3407 -- has already checked this (by scanning ahead and repositioning the
3410 -- Error_Recovery: cannot raise Error_Resync;
3412 function P_Discriminant_Association
return Node_Id
is
3413 Discr_Node
: Node_Id
;
3414 Names_List
: List_Id
;
3415 Ident_Sloc
: Source_Ptr
;
3418 Ident_Sloc
:= Token_Ptr
;
3419 Names_List
:= New_List
;
3422 Append
(P_Identifier
(C_Vertical_Bar_Arrow
), Names_List
);
3423 exit when Token
/= Tok_Vertical_Bar
;
3427 Discr_Node
:= New_Node
(N_Discriminant_Association
, Ident_Sloc
);
3428 Set_Selector_Names
(Discr_Node
, Names_List
);
3430 Set_Expression
(Discr_Node
, P_Expression
);
3432 end P_Discriminant_Association
;
3434 ---------------------------------
3435 -- 3.8 Record Type Definition --
3436 ---------------------------------
3438 -- RECORD_TYPE_DEFINITION ::=
3439 -- [[abstract] tagged] [limited] RECORD_DEFINITION
3441 -- There is no node in the tree for a record type definition. Instead
3442 -- a record definition node appears, with possible Abstract_Present,
3443 -- Tagged_Present, and Limited_Present flags set appropriately.
3445 ----------------------------
3446 -- 3.8 Record Definition --
3447 ----------------------------
3449 -- RECORD_DEFINITION ::=
3455 -- Note: in the case where a record definition node is used to represent
3456 -- a record type definition, the caller sets the Tagged_Present and
3457 -- Limited_Present flags in the resulting N_Record_Definition node as
3460 -- Note that the RECORD token at the start may be missing in certain
3461 -- error situations, so this function is expected to post the error
3463 -- Error recovery: can raise Error_Resync
3465 function P_Record_Definition
return Node_Id
is
3467 procedure Catch_Out_Of_Order_Keywords
(Keyword
: String);
3468 -- Catch ouf-of-order keywords in a record definition
3470 ---------------------------------
3471 -- Catch_Out_Of_Order_Keywords --
3472 ---------------------------------
3474 procedure Catch_Out_Of_Order_Keywords
(Keyword
: String) is
3477 if Token
= Tok_Abstract
then
3478 Error_Msg_SC
-- CODEFIX
3479 ("ABSTRACT must come before " & Keyword
);
3480 Scan
; -- past ABSTRACT
3482 elsif Token
= Tok_Tagged
then
3483 Error_Msg_SC
-- CODEFIX
3484 ("TAGGED must come before " & Keyword
);
3485 Scan
; -- past TAGGED
3487 elsif Token
= Tok_Limited
then
3488 Error_Msg_SC
-- CODEFIX
3489 ("LIMITED must come before " & Keyword
);
3490 Scan
; -- past LIMITED
3496 end Catch_Out_Of_Order_Keywords
;
3500 -- Start of processing for P_Record_Definition
3503 Inside_Record_Definition
:= True;
3504 Rec_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
3508 if Token
= Tok_Null
then
3511 Catch_Out_Of_Order_Keywords
("NULL");
3513 Set_Null_Present
(Rec_Node
, True);
3514 Catch_Out_Of_Order_Keywords
("RECORD");
3516 -- Catch incomplete declaration to prevent cascaded errors, see
3517 -- ACATS B393002 for an example.
3519 elsif Token
= Tok_Semicolon
then
3520 Error_Msg_AP
("missing record definition");
3522 -- Case starting with RECORD keyword. Build scope stack entry. For the
3523 -- column, we use the first non-blank character on the line, to deal
3524 -- with situations such as:
3530 -- which is not official RM indentation, but is not uncommon usage, and
3531 -- in particular is standard GNAT coding style, so handle it nicely.
3535 Scopes
(Scope
.Last
).Etyp
:= E_Record
;
3536 Scopes
(Scope
.Last
).Ecol
:= Start_Column
;
3537 Scopes
(Scope
.Last
).Sloc
:= Token_Ptr
;
3538 Scopes
(Scope
.Last
).Labl
:= Error
;
3539 Scopes
(Scope
.Last
).Junk
:= (Token
/= Tok_Record
);
3542 Catch_Out_Of_Order_Keywords
("RECORD");
3544 Set_Component_List
(Rec_Node
, P_Component_List
);
3547 exit when Check_End
;
3548 Discard_Junk_Node
(P_Component_List
);
3552 Inside_Record_Definition
:= False;
3554 end P_Record_Definition
;
3556 -------------------------
3557 -- 3.8 Component List --
3558 -------------------------
3560 -- COMPONENT_LIST ::=
3561 -- COMPONENT_ITEM {COMPONENT_ITEM}
3562 -- | {COMPONENT_ITEM} VARIANT_PART
3565 -- Error recovery: cannot raise Error_Resync
3567 function P_Component_List
return Node_Id
is
3568 Component_List_Node
: Node_Id
;
3569 Decls_List
: List_Id
;
3570 Scan_State
: Saved_Scan_State
;
3571 Null_Loc
: Source_Ptr
;
3574 Component_List_Node
:= New_Node
(N_Component_List
, Token_Ptr
);
3575 Decls_List
:= New_List
;
3579 if Token
= Tok_Null
then
3580 Null_Loc
:= Token_Ptr
;
3583 P_Pragmas_Opt
(Decls_List
);
3585 -- If we have an END or WHEN now, everything is fine, otherwise we
3586 -- complain about the null, ignore it, and scan for more components.
3588 if Token
= Tok_End
or else Token
= Tok_When
then
3589 Set_Null_Present
(Component_List_Node
, True);
3590 return Component_List_Node
;
3592 Error_Msg
("NULL component only allowed in null record", Null_Loc
);
3596 -- Scan components for non-null record
3598 P_Pragmas_Opt
(Decls_List
);
3600 if Token
/= Tok_Case
then
3601 Component_Scan_Loop
: loop
3602 P_Component_Items
(Decls_List
);
3603 P_Pragmas_Opt
(Decls_List
);
3605 exit Component_Scan_Loop
when Token
= Tok_End
3606 or else Token
= Tok_Case
3607 or else Token
= Tok_When
;
3609 -- We are done if we do not have an identifier. However, if we
3610 -- have a misspelled reserved identifier that is in a column to
3611 -- the right of the record definition, we will treat it as an
3612 -- identifier. It turns out to be too dangerous in practice to
3613 -- accept such a mis-spelled identifier which does not have this
3614 -- additional clue that confirms the incorrect spelling.
3616 if Token
/= Tok_Identifier
then
3617 if Start_Column
> Scopes
(Scope
.Last
).Ecol
3618 and then Is_Reserved_Identifier
3620 Save_Scan_State
(Scan_State
); -- at reserved id
3621 Scan
; -- possible reserved id
3623 if Token
= Tok_Comma
or else Token
= Tok_Colon
then
3624 Restore_Scan_State
(Scan_State
);
3625 Scan_Reserved_Identifier
(Force_Msg
=> True);
3627 -- Note reserved identifier used as field name after all
3628 -- because not followed by colon or comma.
3631 Restore_Scan_State
(Scan_State
);
3632 exit Component_Scan_Loop
;
3635 -- Non-identifier that definitely was not reserved id
3638 exit Component_Scan_Loop
;
3641 end loop Component_Scan_Loop
;
3644 if Token
= Tok_Case
then
3645 Set_Variant_Part
(Component_List_Node
, P_Variant_Part
);
3647 -- Check for junk after variant part
3649 if Token
= Tok_Identifier
then
3650 Save_Scan_State
(Scan_State
);
3651 Scan
; -- past identifier
3653 if Token
= Tok_Colon
then
3654 Restore_Scan_State
(Scan_State
);
3655 Error_Msg_SC
("component may not follow variant part");
3656 Discard_Junk_Node
(P_Component_List
);
3658 elsif Token
= Tok_Case
then
3659 Restore_Scan_State
(Scan_State
);
3660 Error_Msg_SC
("only one variant part allowed in a record");
3661 Discard_Junk_Node
(P_Component_List
);
3664 Restore_Scan_State
(Scan_State
);
3669 Set_Component_Items
(Component_List_Node
, Decls_List
);
3670 return Component_List_Node
;
3671 end P_Component_List
;
3673 -------------------------
3674 -- 3.8 Component Item --
3675 -------------------------
3677 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
3679 -- COMPONENT_DECLARATION ::=
3680 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
3681 -- [:= DEFAULT_EXPRESSION]
3682 -- [ASPECT_SPECIFICATIONS];
3684 -- COMPONENT_DEFINITION ::=
3685 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
3687 -- Error recovery: cannot raise Error_Resync, if an error occurs,
3688 -- the scan is positioned past the following semicolon.
3690 -- Note: we do not yet allow representation clauses to appear as component
3691 -- items, do we need to add this capability sometime in the future ???
3693 procedure P_Component_Items
(Decls
: List_Id
) is
3694 Aliased_Present
: Boolean := False;
3695 CompDef_Node
: Node_Id
;
3696 Decl_Node
: Node_Id
:= Empty
; -- initialize to prevent warning
3697 Scan_State
: Saved_Scan_State
;
3698 Not_Null_Present
: Boolean := False;
3701 Ident_Sloc
: Source_Ptr
;
3703 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
3704 -- This array holds the list of defining identifiers. The upper bound
3705 -- of 4096 is intended to be essentially infinite, and we do not even
3706 -- bother to check for it being exceeded.
3709 if Token
/= Tok_Identifier
then
3710 Error_Msg_SC
("component declaration expected");
3711 Resync_Past_Semicolon
;
3715 Ident_Sloc
:= Token_Ptr
;
3717 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
3720 while Comma_Present
loop
3721 Num_Idents
:= Num_Idents
+ 1;
3722 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
3725 -- If there are multiple identifiers, we repeatedly scan the
3726 -- type and initialization expression information by resetting
3727 -- the scan pointer (so that we get completely separate trees
3728 -- for each occurrence).
3730 if Num_Idents
> 1 then
3731 Save_Scan_State
(Scan_State
);
3736 -- Loop through defining identifiers in list
3741 -- The following block is present to catch Error_Resync
3742 -- which causes the parse to be reset past the semicolon
3745 Decl_Node
:= New_Node
(N_Component_Declaration
, Ident_Sloc
);
3746 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
3748 if Token
= Tok_Constant
then
3749 Error_Msg_SC
("constant component not permitted");
3753 CompDef_Node
:= New_Node
(N_Component_Definition
, Token_Ptr
);
3755 if Token_Name
= Name_Aliased
then
3756 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
3759 if Token
= Tok_Aliased
then
3760 Aliased_Present
:= True;
3761 Scan
; -- past ALIASED
3764 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/AI-254)
3766 -- Ada 2005 (AI-230): Access Definition case
3768 if Token
= Tok_Access
then
3769 Error_Msg_Ada_2005_Extension
3770 ("generalized use of anonymous access types");
3772 -- AI95-406 makes "aliased" legal (and useless) here, so the
3773 -- following code which used to be required is commented out.
3775 -- if Aliased_Present then
3776 -- Error_Msg_SP ("ALIASED not allowed here");
3779 Set_Subtype_Indication
(CompDef_Node
, Empty
);
3780 Set_Aliased_Present
(CompDef_Node
, False);
3781 Set_Access_Definition
(CompDef_Node
,
3782 P_Access_Definition
(Not_Null_Present
));
3785 Set_Access_Definition
(CompDef_Node
, Empty
);
3786 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
3787 Set_Null_Exclusion_Present
(CompDef_Node
, Not_Null_Present
);
3789 if Token
= Tok_Array
then
3790 Error_Msg_SC
("anonymous array not allowed as component");
3794 Set_Subtype_Indication
(CompDef_Node
,
3795 P_Subtype_Indication
(Not_Null_Present
));
3798 Set_Component_Definition
(Decl_Node
, CompDef_Node
);
3799 Set_Expression
(Decl_Node
, Init_Expr_Opt
);
3802 Set_Prev_Ids
(Decl_Node
, True);
3805 if Ident
< Num_Idents
then
3806 Set_More_Ids
(Decl_Node
, True);
3809 Append
(Decl_Node
, Decls
);
3812 when Error_Resync
=>
3813 if Token
/= Tok_End
then
3814 Resync_Past_Semicolon
;
3818 exit Ident_Loop
when Ident
= Num_Idents
;
3820 Restore_Scan_State
(Scan_State
);
3822 end loop Ident_Loop
;
3824 P_Aspect_Specifications
(Decl_Node
);
3825 end P_Component_Items
;
3827 --------------------------------
3828 -- 3.8 Component Declaration --
3829 --------------------------------
3831 -- Parsed by P_Component_Items (3.8)
3833 -------------------------
3834 -- 3.8.1 Variant Part --
3835 -------------------------
3838 -- case discriminant_DIRECT_NAME is
3843 -- The caller has checked that the initial token is CASE
3845 -- Error recovery: cannot raise Error_Resync
3847 function P_Variant_Part
return Node_Id
is
3848 Variant_Part_Node
: Node_Id
;
3849 Variants_List
: List_Id
;
3850 Case_Node
: Node_Id
;
3853 Variant_Part_Node
:= New_Node
(N_Variant_Part
, Token_Ptr
);
3855 Scopes
(Scope
.Last
).Etyp
:= E_Case
;
3856 Scopes
(Scope
.Last
).Sloc
:= Token_Ptr
;
3857 Scopes
(Scope
.Last
).Ecol
:= Start_Column
;
3860 Case_Node
:= P_Expression
;
3861 Set_Name
(Variant_Part_Node
, Case_Node
);
3863 if Nkind
(Case_Node
) /= N_Identifier
then
3864 Set_Name
(Variant_Part_Node
, Error
);
3865 Error_Msg
("discriminant name expected", Sloc
(Case_Node
));
3867 elsif Paren_Count
(Case_Node
) /= 0 then
3869 ("|discriminant name may not be parenthesized",
3871 Set_Paren_Count
(Case_Node
, 0);
3875 Variants_List
:= New_List
;
3876 P_Pragmas_Opt
(Variants_List
);
3878 -- Test missing variant
3880 if Token
= Tok_End
then
3881 Error_Msg_BC
("WHEN expected (must have at least one variant)");
3883 Append
(P_Variant
, Variants_List
);
3886 -- Loop through variants, note that we allow if in place of when,
3887 -- this error will be detected and handled in P_Variant.
3890 P_Pragmas_Opt
(Variants_List
);
3892 if Token
/= Tok_When
3893 and then Token
/= Tok_If
3894 and then Token
/= Tok_Others
3896 exit when Check_End
;
3899 Append
(P_Variant
, Variants_List
);
3902 Set_Variants
(Variant_Part_Node
, Variants_List
);
3903 return Variant_Part_Node
;
3906 --------------------
3908 --------------------
3911 -- when DISCRETE_CHOICE_LIST =>
3914 -- Error recovery: cannot raise Error_Resync
3916 -- The initial token on entry is either WHEN, IF or OTHERS
3918 function P_Variant
return Node_Id
is
3919 Variant_Node
: Node_Id
;
3922 -- Special check to recover nicely from use of IF in place of WHEN
3924 if Token
= Tok_If
then
3931 Variant_Node
:= New_Node
(N_Variant
, Prev_Token_Ptr
);
3932 Set_Discrete_Choices
(Variant_Node
, P_Discrete_Choice_List
);
3934 Set_Component_List
(Variant_Node
, P_Component_List
);
3935 return Variant_Node
;
3938 ---------------------------------
3939 -- 3.8.1 Discrete Choice List --
3940 ---------------------------------
3942 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
3944 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
3946 -- Note: in Ada 83, the expression must be a simple expression
3948 -- Error recovery: cannot raise Error_Resync
3950 function P_Discrete_Choice_List
return List_Id
is
3952 Expr_Node
: Node_Id
:= Empty
; -- initialize to prevent warning
3953 Choice_Node
: Node_Id
;
3956 Choices
:= New_List
;
3958 if Token
= Tok_Others
then
3959 Append
(New_Node
(N_Others_Choice
, Token_Ptr
), Choices
);
3960 Scan
; -- past OTHERS
3964 -- Scan out expression or range attribute
3966 Expr_Node
:= P_Expression_Or_Range_Attribute
;
3967 Ignore
(Tok_Right_Paren
);
3969 if Token
= Tok_Colon
3970 and then Nkind
(Expr_Node
) = N_Identifier
3972 Error_Msg_SP
("label not permitted in this context");
3977 elsif Expr_Form
= EF_Range_Attr
then
3978 Append
(Expr_Node
, Choices
);
3982 elsif Token
= Tok_Dot_Dot
then
3983 Check_Simple_Expression
(Expr_Node
);
3984 Choice_Node
:= New_Node
(N_Range
, Token_Ptr
);
3985 Set_Low_Bound
(Choice_Node
, Expr_Node
);
3987 Expr_Node
:= P_Expression_No_Right_Paren
;
3988 Check_Simple_Expression
(Expr_Node
);
3989 Set_High_Bound
(Choice_Node
, Expr_Node
);
3990 Append
(Choice_Node
, Choices
);
3992 -- Simple name, must be subtype, so range allowed
3994 elsif Expr_Form
= EF_Simple_Name
then
3995 if Token
= Tok_Range
then
3996 Append
(P_Subtype_Indication
(Expr_Node
), Choices
);
3998 elsif Token
in Token_Class_Consk
then
4000 ("the only constraint allowed here " &
4001 "is a range constraint");
4002 Discard_Junk_Node
(P_Constraint_Opt
);
4003 Append
(Expr_Node
, Choices
);
4006 Append
(Expr_Node
, Choices
);
4012 -- In Ada 2012 mode, the expression must be a simple
4013 -- expression. The reason for this restriction (i.e. going
4014 -- back to the Ada 83 rule) is to avoid ambiguities when set
4015 -- membership operations are allowed, consider the
4018 -- when A in 1 .. 10 | 12 =>
4020 -- This is ambiguous without parentheses, so we require one
4021 -- of the following two parenthesized forms to disambiguate:
4023 -- one of the following:
4025 -- when (A in 1 .. 10 | 12) =>
4026 -- when (A in 1 .. 10) | 12 =>
4028 -- To solve this, in Ada 2012 mode, we disallow the use of
4029 -- membership operations in expressions in choices.
4031 -- Technically in the grammar, the expression must match the
4032 -- grammar for restricted expression.
4034 if Ada_Version
>= Ada_2012
then
4035 Check_Restricted_Expression
(Expr_Node
);
4037 -- In Ada 83 mode, the syntax required a simple expression
4040 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
4043 Append
(Expr_Node
, Choices
);
4047 when Error_Resync
=>
4053 if Token
= Tok_Comma
then
4054 if Nkind
(Expr_Node
) = N_Iterated_Component_Association
then
4060 if Token
= Tok_Vertical_Bar
then
4061 Error_Msg_SP
-- CODEFIX
4062 ("|extra "","" ignored");
4066 Error_Msg_SP
-- CODEFIX
4067 (""","" should be ""'|""");
4071 exit when Token
/= Tok_Vertical_Bar
;
4078 end P_Discrete_Choice_List
;
4080 ----------------------------
4081 -- 3.8.1 Discrete Choice --
4082 ----------------------------
4084 -- Parsed by P_Discrete_Choice_List (3.8.1)
4086 ----------------------------------
4087 -- 3.9.1 Record Extension Part --
4088 ----------------------------------
4090 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
4092 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
4094 --------------------------------------
4095 -- 3.9.4 Interface Type Definition --
4096 --------------------------------------
4098 -- INTERFACE_TYPE_DEFINITION ::=
4099 -- [limited | task | protected | synchronized] interface
4100 -- [and INTERFACE_LIST]
4102 -- Error recovery: cannot raise Error_Resync
4104 function P_Interface_Type_Definition
4105 (Abstract_Present
: Boolean) return Node_Id
4107 Typedef_Node
: Node_Id
;
4110 Error_Msg_Ada_2005_Extension
("abstract interface");
4112 if Abstract_Present
then
4114 ("ABSTRACT not allowed in interface type definition " &
4118 Scan
; -- past INTERFACE
4120 -- Ada 2005 (AI-345): In case of interfaces with a null list of
4121 -- interfaces we build a record_definition node.
4123 if Token
= Tok_Semicolon
or else Aspect_Specifications_Present
then
4124 Typedef_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
4126 Set_Abstract_Present
(Typedef_Node
);
4127 Set_Tagged_Present
(Typedef_Node
);
4128 Set_Null_Present
(Typedef_Node
);
4129 Set_Interface_Present
(Typedef_Node
);
4131 -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have
4132 -- a list of interfaces we build a derived_type_definition node. This
4133 -- simplifies the semantic analysis (and hence further maintenance)
4136 if Token
/= Tok_And
then
4137 Error_Msg_AP
("AND expected");
4142 Typedef_Node
:= New_Node
(N_Derived_Type_Definition
, Token_Ptr
);
4144 Set_Abstract_Present
(Typedef_Node
);
4145 Set_Interface_Present
(Typedef_Node
);
4146 Set_Subtype_Indication
(Typedef_Node
, P_Qualified_Simple_Name
);
4148 Set_Record_Extension_Part
(Typedef_Node
,
4149 New_Node
(N_Record_Definition
, Token_Ptr
));
4150 Set_Null_Present
(Record_Extension_Part
(Typedef_Node
));
4152 if Token
= Tok_And
then
4153 Set_Interface_List
(Typedef_Node
, New_List
);
4157 Append
(P_Qualified_Simple_Name
,
4158 Interface_List
(Typedef_Node
));
4159 exit when Token
/= Tok_And
;
4165 return Typedef_Node
;
4166 end P_Interface_Type_Definition
;
4168 ----------------------------------
4169 -- 3.10 Access Type Definition --
4170 ----------------------------------
4172 -- ACCESS_TYPE_DEFINITION ::=
4173 -- ACCESS_TO_OBJECT_DEFINITION
4174 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
4176 -- ACCESS_TO_OBJECT_DEFINITION ::=
4177 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
4179 -- GENERAL_ACCESS_MODIFIER ::= all | constant
4181 -- ACCESS_TO_SUBPROGRAM_DEFINITION
4182 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
4183 -- | [NULL_EXCLUSION] access [protected] function
4184 -- PARAMETER_AND_RESULT_PROFILE
4186 -- PARAMETER_PROFILE ::= [FORMAL_PART]
4188 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
4190 -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already
4191 -- parsed the null_exclusion part and has also removed the ACCESS token;
4192 -- otherwise the caller has just checked that the initial token is ACCESS
4194 -- Error recovery: can raise Error_Resync
4196 function P_Access_Type_Definition
4197 (Header_Already_Parsed
: Boolean := False) return Node_Id
4199 procedure Check_Junk_Subprogram_Name
;
4200 -- Used in access to subprogram definition cases to check for an
4201 -- identifier or operator symbol that does not belong.
4203 --------------------------------
4204 -- Check_Junk_Subprogram_Name --
4205 --------------------------------
4207 procedure Check_Junk_Subprogram_Name
is
4208 Saved_State
: Saved_Scan_State
;
4211 if Token
= Tok_Identifier
or else Token
= Tok_Operator_Symbol
then
4212 Save_Scan_State
(Saved_State
);
4213 Scan
; -- past possible junk subprogram name
4215 if Token
= Tok_Left_Paren
or else Token
= Tok_Semicolon
then
4216 Error_Msg_SP
("unexpected subprogram name ignored");
4220 Restore_Scan_State
(Saved_State
);
4223 end Check_Junk_Subprogram_Name
;
4225 Access_Loc
: constant Source_Ptr
:= Token_Ptr
;
4226 Prot_Flag
: Boolean;
4227 Not_Null_Present
: Boolean := False;
4228 Not_Null_Subtype
: Boolean := False;
4229 Not_Null_Subtype_Loc
: Source_Ptr
; -- loc of second "not null"
4230 Type_Def_Node
: Node_Id
;
4231 Result_Not_Null
: Boolean;
4232 Result_Node
: Node_Id
;
4234 -- Start of processing for P_Access_Type_Definition
4237 if not Header_Already_Parsed
then
4238 -- NOT NULL ACCESS... is a common form of access definition. ACCESS
4239 -- NOT NULL... is certainly rare, but syntactically legal. NOT NULL
4240 -- ACCESS NOT NULL... is rarer yet, and also legal. The last two
4241 -- cases are only meaningful if the following subtype indication
4242 -- denotes an access type. We check below for "not null procedure"
4243 -- and "not null function"; in the access-to-object case it is a
4244 -- semantic check. The flag Not_Null_Subtype indicates that this
4245 -- second null exclusion is present in the access type definition.
4247 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
4249 if Token
/= Tok_Access
then
4255 Scan
; -- past ACCESS
4257 Not_Null_Subtype_Loc
:= Token_Ptr
;
4258 Not_Null_Subtype
:= P_Null_Exclusion
; -- Might also appear
4261 if Token_Name
= Name_Protected
then
4262 Check_95_Keyword
(Tok_Protected
, Tok_Procedure
);
4263 Check_95_Keyword
(Tok_Protected
, Tok_Function
);
4266 Prot_Flag
:= (Token
= Tok_Protected
);
4269 Scan
; -- past PROTECTED
4271 if Token
/= Tok_Procedure
and then Token
/= Tok_Function
then
4272 Error_Msg_SC
-- CODEFIX
4273 ("FUNCTION or PROCEDURE expected");
4277 -- Access-to-subprogram case
4279 if Token
in Tok_Procedure | Tok_Function
then
4281 -- Check for "not null [protected] procedure" and "not null
4282 -- [protected] function".
4284 if Not_Null_Subtype
then
4286 ("null exclusion must apply to access type",
4287 Not_Null_Subtype_Loc
);
4291 if Token
= Tok_Procedure
then
4292 if Ada_Version
= Ada_83
then
4293 Error_Msg_SC
("(Ada 83) access to procedure not allowed!");
4296 Type_Def_Node
:= New_Node
(N_Access_Procedure_Definition
, Access_Loc
);
4297 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
4298 Scan
; -- past PROCEDURE
4299 Check_Junk_Subprogram_Name
;
4300 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
4301 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
4303 elsif Token
= Tok_Function
then
4304 if Ada_Version
= Ada_83
then
4305 Error_Msg_SC
("(Ada 83) access to function not allowed!");
4308 Type_Def_Node
:= New_Node
(N_Access_Function_Definition
, Access_Loc
);
4309 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
4310 Scan
; -- past FUNCTION
4311 Check_Junk_Subprogram_Name
;
4312 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
4313 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
4316 Result_Not_Null
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
4318 -- Ada 2005 (AI-318-02)
4320 if Token
= Tok_Access
then
4321 Error_Msg_Ada_2005_Extension
("anonymous access result type");
4323 Result_Node
:= P_Access_Definition
(Result_Not_Null
);
4326 Result_Node
:= P_Subtype_Mark
;
4329 -- A null exclusion on the result type must be recorded in a flag
4330 -- distinct from the one used for the access-to-subprogram type's
4333 Set_Null_Exclusion_In_Return_Present
4334 (Type_Def_Node
, Result_Not_Null
);
4337 Set_Result_Definition
(Type_Def_Node
, Result_Node
);
4339 -- Access-to-object case
4342 Type_Def_Node
:= New_Node
(N_Access_To_Object_Definition
, Access_Loc
);
4343 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
4344 Set_Null_Excluding_Subtype
(Type_Def_Node
, Not_Null_Subtype
);
4346 if Token
= Tok_All
or else Token
= Tok_Constant
then
4347 if Ada_Version
= Ada_83
then
4348 Error_Msg_SC
("(Ada 83) access modifier not allowed!");
4351 if Token
= Tok_All
then
4352 Set_All_Present
(Type_Def_Node
, True);
4355 Set_Constant_Present
(Type_Def_Node
, True);
4358 Scan
; -- past ALL or CONSTANT
4361 Set_Subtype_Indication
(Type_Def_Node
,
4362 P_Subtype_Indication
(Not_Null_Present
));
4365 return Type_Def_Node
;
4366 end P_Access_Type_Definition
;
4368 ---------------------------------------
4369 -- 3.10 Access To Object Definition --
4370 ---------------------------------------
4372 -- Parsed by P_Access_Type_Definition (3.10)
4374 -----------------------------------
4375 -- 3.10 General Access Modifier --
4376 -----------------------------------
4378 -- Parsed by P_Access_Type_Definition (3.10)
4380 -------------------------------------------
4381 -- 3.10 Access To Subprogram Definition --
4382 -------------------------------------------
4384 -- Parsed by P_Access_Type_Definition (3.10)
4386 -----------------------------
4387 -- 3.10 Access Definition --
4388 -----------------------------
4390 -- ACCESS_DEFINITION ::=
4391 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
4392 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
4394 -- ACCESS_TO_SUBPROGRAM_DEFINITION
4395 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
4396 -- | [NULL_EXCLUSION] access [protected] function
4397 -- PARAMETER_AND_RESULT_PROFILE
4399 -- The caller has parsed the null-exclusion part and it has also checked
4400 -- that the next token is ACCESS
4402 -- Error recovery: cannot raise Error_Resync
4404 function P_Access_Definition
4405 (Null_Exclusion_Present
: Boolean) return Node_Id
4408 Subp_Node
: Node_Id
;
4411 Def_Node
:= New_Node
(N_Access_Definition
, Token_Ptr
);
4412 Scan
; -- past ACCESS
4414 -- Ada 2005 (AI-254): Access_To_Subprogram_Definition
4416 if Token
= Tok_Protected
4417 or else Token
= Tok_Procedure
4418 or else Token
= Tok_Function
4420 Error_Msg_Ada_2005_Extension
("access-to-subprogram");
4422 Subp_Node
:= P_Access_Type_Definition
(Header_Already_Parsed
=> True);
4423 Set_Null_Exclusion_Present
(Subp_Node
, Null_Exclusion_Present
);
4424 Set_Access_To_Subprogram_Definition
(Def_Node
, Subp_Node
);
4426 -- Ada 2005 (AI-231)
4427 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
4430 Set_Null_Exclusion_Present
(Def_Node
, Null_Exclusion_Present
);
4432 if Token
= Tok_All
then
4433 if Ada_Version
< Ada_2005
then
4435 ("ALL not permitted for anonymous access type");
4439 Set_All_Present
(Def_Node
);
4441 elsif Token
= Tok_Constant
then
4442 Error_Msg_Ada_2005_Extension
("access-to-constant");
4444 Scan
; -- past CONSTANT
4445 Set_Constant_Present
(Def_Node
);
4448 Set_Subtype_Mark
(Def_Node
, P_Subtype_Mark
);
4453 end P_Access_Definition
;
4455 -----------------------------------------
4456 -- 3.10.1 Incomplete Type Declaration --
4457 -----------------------------------------
4459 -- Parsed by P_Type_Declaration (3.2.1)
4461 ----------------------------
4462 -- 3.11 Declarative Part --
4463 ----------------------------
4465 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
4467 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items
4468 -- handles errors, and returns cleanly after an error has occurred)
4470 function P_Declarative_Part
return List_Id
is
4475 -- Indicate no bad declarations detected yet. This will be reset by
4476 -- P_Declarative_Items if a bad declaration is discovered.
4478 Missing_Begin_Msg
:= No_Error_Msg
;
4480 -- Get rid of active SIS entry from outer scope. This means we will
4481 -- miss some nested cases, but it doesn't seem worth the effort. See
4482 -- discussion in Par for further details
4484 SIS_Entry_Active
:= False;
4487 -- Loop to scan out the declarations
4491 (Decls
, Done
, Declare_Expression
=> False, In_Spec
=> False);
4495 -- Get rid of active SIS entry which is left set only if we scanned a
4496 -- procedure declaration and have not found the body. We could give
4497 -- an error message, but that really would be usurping the role of
4498 -- semantic analysis (this really is a missing body case).
4500 SIS_Entry_Active
:= False;
4502 end P_Declarative_Part
;
4504 ----------------------------
4505 -- 3.11 Declarative Item --
4506 ----------------------------
4508 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
4510 -- Can return Error if a junk declaration is found, or Empty if no
4511 -- declaration is found (i.e. a token ending declarations, such as
4512 -- BEGIN or END is encountered).
4514 -- Error recovery: cannot raise Error_Resync. If an error resync occurs,
4515 -- then the scan is set past the next semicolon and Error is returned.
4517 procedure P_Declarative_Items
4520 Declare_Expression
: Boolean;
4523 Scan_State
: Saved_Scan_State
;
4528 -- In -gnatg mode, we don't want a "bad indentation" error inside a
4529 -- declare_expression.
4531 if Style_Check
and not Declare_Expression
then
4532 Style
.Check_Indentation
;
4542 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4547 -- Check for loop (premature statement)
4549 Save_Scan_State
(Scan_State
);
4552 if Token
= Tok_Identifier
then
4553 Scan
; -- past identifier
4555 if Token
= Tok_In
then
4556 Restore_Scan_State
(Scan_State
);
4557 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4562 -- Not a loop, so must be rep clause
4564 Restore_Scan_State
(Scan_State
);
4565 Append
(P_Representation_Clause
, Decls
);
4569 Append
(P_Generic
, Decls
);
4571 when Tok_Identifier
=>
4574 -- Special check for misuse of overriding not in Ada 2005 mode
4576 if Token_Name
= Name_Overriding
4577 and then not Next_Token_Is
(Tok_Colon
)
4579 Error_Msg_SC
("overriding indicator is an Ada 2005 extension");
4580 Error_Msg_SC
("\unit must be compiled with -gnat05 switch");
4582 Token
:= Tok_Overriding
;
4583 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4585 -- Normal case, no overriding, or overriding followed by colon
4588 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4593 Append
(P_Package
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4596 Append
(P_Pragma
, Decls
);
4598 when Tok_Protected
=>
4600 Scan
; -- past PROTECTED
4601 Append
(P_Protected
, Decls
);
4605 Append
(P_Subtype_Declaration
, Decls
);
4610 Append
(P_Task
, Decls
);
4614 Append
(P_Type_Declaration
, Decls
);
4618 P_Use_Clause
(Decls
);
4623 if Aspect_Specifications_Present
then
4625 -- If we are after a semicolon, complain that it was ignored.
4626 -- But we don't really ignore it, since we dump the aspects,
4627 -- so we make the error message a normal fatal message which
4628 -- will inhibit semantic analysis anyway).
4630 if Prev_Token
= Tok_Semicolon
then
4631 Error_Msg_SP
-- CODEFIX
4632 ("extra "";"" ignored");
4634 -- If not just past semicolon, just complain that aspects are
4635 -- not allowed at this point.
4638 Error_Msg_SC
("aspect specifications not allowed here");
4641 -- Assume that this is a misplaced aspect specification within
4642 -- a declarative list. After discarding the misplaced aspects
4643 -- we can continue the scan.
4646 Dummy_Node
: constant Node_Id
:=
4647 New_Node
(N_Package_Specification
, Token_Ptr
);
4648 pragma Warnings
(Off
, Dummy_Node
);
4649 -- Dummy node to attach aspect specifications to. We will
4650 -- then throw them away.
4653 P_Aspect_Specifications
(Dummy_Node
, Semicolon
=> True);
4656 -- Here if not aspect specifications case
4659 Error_Msg_SC
("WITH can only appear in context clause");
4663 -- BEGIN terminates the scan of a sequence of declarations unless
4664 -- there is a missing subprogram body, see section on handling
4665 -- semicolon in place of IS. We only treat the begin as satisfying
4666 -- the subprogram declaration if it falls in the expected column
4670 if SIS_Entry_Active
and then Start_Column
>= SIS_Ecol
then
4672 -- Here we have the case where a BEGIN is encountered during
4673 -- declarations in a declarative part, or at the outer level,
4674 -- and there is a subprogram declaration outstanding for which
4675 -- no body has been supplied. This is the case where we assume
4676 -- that the semicolon in the subprogram declaration should
4677 -- really have been is. The active SIS entry describes the
4678 -- subprogram declaration. On return the declaration has been
4679 -- modified to become a body.
4682 Specification_Node
: Node_Id
;
4683 Decl_Node
: Node_Id
;
4684 Body_Node
: Node_Id
;
4687 -- First issue the error message. If we had a missing
4688 -- semicolon in the declaration, then change the message
4689 -- to <missing "is">
4691 if SIS_Missing_Semicolon_Message
/= No_Error_Msg
then
4692 Change_Error_Text
-- Replace: "missing "";"" "
4693 (SIS_Missing_Semicolon_Message
, "missing ""is""");
4695 -- Otherwise we saved the semicolon position, so complain
4698 Error_Msg
-- CODEFIX
4699 ("|"";"" should be IS", SIS_Semicolon_Sloc
);
4702 -- The next job is to fix up any declarations that occurred
4703 -- between the procedure header and the BEGIN. These got
4704 -- chained to the outer declarative region (immediately
4705 -- after the procedure declaration) and they should be
4706 -- chained to the subprogram itself, which is a body
4707 -- rather than a spec.
4709 Specification_Node
:= Specification
(SIS_Declaration_Node
);
4710 Change_Node
(SIS_Declaration_Node
, N_Subprogram_Body
);
4711 Body_Node
:= SIS_Declaration_Node
;
4712 Set_Specification
(Body_Node
, Specification_Node
);
4713 Set_Declarations
(Body_Node
, New_List
);
4716 Decl_Node
:= Remove_Next
(Body_Node
);
4717 exit when Decl_Node
= Empty
;
4718 Append
(Decl_Node
, Declarations
(Body_Node
));
4721 -- Now make the scope table entry for the Begin-End and
4725 Scopes
(Scope
.Last
).Sloc
:= SIS_Sloc
;
4726 Scopes
(Scope
.Last
).Etyp
:= E_Name
;
4727 Scopes
(Scope
.Last
).Ecol
:= SIS_Ecol
;
4728 Scopes
(Scope
.Last
).Labl
:= SIS_Labl
;
4729 Scopes
(Scope
.Last
).Lreq
:= False;
4730 SIS_Entry_Active
:= False;
4732 Set_Handled_Statement_Sequence
(Body_Node
,
4733 P_Handled_Sequence_Of_Statements
);
4734 End_Statements
(Handled_Statement_Sequence
(Body_Node
));
4741 -- Normally an END terminates the scan for basic declarative items.
4742 -- The one exception is END RECORD, which is probably left over from
4746 Save_Scan_State
(Scan_State
); -- at END
4749 if Token
= Tok_Record
then
4750 Error_Msg_SP
("no RECORD for this `end record`!");
4751 Scan
; -- past RECORD
4754 -- This might happen because of misplaced aspect specification.
4755 -- After discarding the misplaced aspects we can continue the
4759 Restore_Scan_State
(Scan_State
); -- to END
4763 -- The following tokens which can only be the start of a statement
4764 -- are considered to end a declarative part (i.e. we have a missing
4765 -- BEGIN situation). We are fairly conservative in making this
4766 -- judgment, because it is a real mess to go into statement mode
4767 -- prematurely in response to a junk declaration.
4782 -- But before we decide that it's a statement, let's check for
4783 -- a reserved word misused as an identifier.
4785 if Is_Reserved_Identifier
then
4786 Save_Scan_State
(Scan_State
);
4787 Scan
; -- past the token
4789 -- If reserved identifier not followed by colon or comma, then
4790 -- this is most likely an assignment statement to the bad id.
4792 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
4793 Restore_Scan_State
(Scan_State
);
4794 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4797 -- Otherwise we have a declaration of the bad id
4800 Restore_Scan_State
(Scan_State
);
4801 Scan_Reserved_Identifier
(Force_Msg
=> True);
4802 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4805 -- If not reserved identifier, then it's definitely a statement
4808 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4812 -- The token RETURN may well also signal a missing BEGIN situation,
4813 -- however, we never let it end the declarative part, because it may
4814 -- also be part of a half-baked function declaration.
4817 Error_Msg_SC
("misplaced RETURN statement");
4820 -- PRIVATE definitely terminates the declarations in a spec,
4821 -- and is an error in a body.
4827 Error_Msg_SC
("PRIVATE not allowed in body");
4828 Scan
; -- past PRIVATE
4831 -- An end of file definitely terminates the declarations
4836 -- The remaining tokens do not end the scan, but cannot start a
4837 -- valid declaration, so we signal an error and resynchronize.
4838 -- But first check for misuse of a reserved identifier.
4842 -- Here we check for a reserved identifier
4844 if Is_Reserved_Identifier
then
4845 Save_Scan_State
(Scan_State
);
4846 Scan
; -- past the token
4848 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
4849 Restore_Scan_State
(Scan_State
);
4850 Set_Declaration_Expected
;
4853 Restore_Scan_State
(Scan_State
);
4854 Scan_Reserved_Identifier
(Force_Msg
=> True);
4856 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4860 Set_Declaration_Expected
;
4865 -- To resynchronize after an error, we scan to the next semicolon and
4866 -- return with Done = False, indicating that there may still be more
4867 -- valid declarations to come.
4870 when Error_Resync
=>
4871 Resync_Past_Semicolon
;
4872 end P_Declarative_Items
;
4874 ----------------------------------
4875 -- 3.11 Basic Declarative Item --
4876 ----------------------------------
4878 -- BASIC_DECLARATIVE_ITEM ::=
4879 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
4881 -- Scan zero or more basic declarative items
4883 -- Error recovery: cannot raise Error_Resync. If an error is detected, then
4884 -- the scan pointer is repositioned past the next semicolon, and the scan
4885 -- for declarative items continues.
4887 function P_Basic_Declarative_Items
4888 (Declare_Expression
: Boolean) return List_Id
4896 -- Indicate no bad declarations detected yet in the current context:
4897 -- visible or private declarations of a package spec.
4899 Missing_Begin_Msg
:= No_Error_Msg
;
4901 -- Get rid of active SIS entry from outer scope. This means we will
4902 -- miss some nested cases, but it doesn't seem worth the effort. See
4903 -- discussion in Par for further details
4905 SIS_Entry_Active
:= False;
4907 -- Loop to scan out declarations
4913 (Decls
, Done
, Declare_Expression
, In_Spec
=> True);
4917 -- Get rid of active SIS entry. This is set only if we have scanned a
4918 -- procedure declaration and have not found the body. We could give
4919 -- an error message, but that really would be usurping the role of
4920 -- semantic analysis (this really is a case of a missing body).
4922 SIS_Entry_Active
:= False;
4924 -- Test for assorted illegal declarations not diagnosed elsewhere
4926 Decl
:= First
(Decls
);
4928 while Present
(Decl
) loop
4929 Kind
:= Nkind
(Decl
);
4931 -- Test for body scanned, not acceptable as basic decl item
4933 if Kind
= N_Subprogram_Body
or else
4934 Kind
= N_Package_Body
or else
4935 Kind
= N_Task_Body
or else
4936 Kind
= N_Protected_Body
4938 if Declare_Expression
then
4940 ("proper body not allowed in declare_expression",
4944 ("proper body not allowed in package spec",
4948 -- Complete declaration of mangled subprogram body, for better
4949 -- recovery if analysis is attempted.
4951 if Nkind
(Decl
) in N_Subprogram_Body | N_Package_Body | N_Task_Body
4952 and then No
(Handled_Statement_Sequence
(Decl
))
4954 Set_Handled_Statement_Sequence
(Decl
,
4955 Make_Handled_Sequence_Of_Statements
(Sloc
(Decl
),
4956 Statements
=> New_List
));
4959 -- Test for body stub scanned, not acceptable as basic decl item
4961 elsif Kind
in N_Body_Stub
then
4962 Error_Msg
("body stub not allowed in package spec", Sloc
(Decl
));
4964 elsif Kind
= N_Assignment_Statement
then
4966 ("assignment statement not allowed in package spec",
4974 end P_Basic_Declarative_Items
;
4980 -- For proper body, see below
4981 -- For body stub, see 10.1.3
4983 -----------------------
4984 -- 3.11 Proper Body --
4985 -----------------------
4987 -- Subprogram body is parsed by P_Subprogram (6.1)
4988 -- Package body is parsed by P_Package (7.1)
4989 -- Task body is parsed by P_Task (9.1)
4990 -- Protected body is parsed by P_Protected (9.4)
4992 ------------------------------
4993 -- Set_Declaration_Expected --
4994 ------------------------------
4996 procedure Set_Declaration_Expected
is
4998 Error_Msg_SC
("declaration expected");
5000 if Missing_Begin_Msg
= No_Error_Msg
then
5001 Missing_Begin_Msg
:= Get_Msg_Id
;
5003 end Set_Declaration_Expected
;
5005 ----------------------
5006 -- Skip_Declaration --
5007 ----------------------
5009 procedure Skip_Declaration
(S
: List_Id
) is
5010 Dummy_Done
: Boolean;
5011 pragma Warnings
(Off
, Dummy_Done
);
5014 (S
, Dummy_Done
, Declare_Expression
=> False, In_Spec
=> False);
5015 end Skip_Declaration
;
5017 -----------------------------------------
5018 -- Statement_When_Declaration_Expected --
5019 -----------------------------------------
5021 procedure Statement_When_Declaration_Expected
5027 -- Case of second occurrence of statement in one declaration sequence
5029 if Missing_Begin_Msg
/= No_Error_Msg
then
5031 -- In the procedure spec case, just ignore it, we only give one
5032 -- message for the first occurrence, since otherwise we may get
5033 -- horrible cascading if BODY was missing in the header line.
5038 -- Just ignore it if we are in -gnatd.2 (allow statements to appear
5039 -- in declaration sequences) mode.
5041 elsif Debug_Flag_Dot_2
then
5044 -- In the declarative part case, take a second statement as a sure
5045 -- sign that we really have a missing BEGIN, and end the declarative
5046 -- part now. Note that the caller will fix up the first message to
5047 -- say "missing BEGIN" so that's how the error will be signalled.
5054 -- Case of first occurrence of unexpected statement
5057 -- Do not give error message if we are operating in -gnatd.2 mode
5058 -- (alllow statements to appear in declarative parts).
5060 if not Debug_Flag_Dot_2
then
5062 -- If we are in a package spec, then give message of statement
5063 -- not allowed in package spec. This message never gets changed.
5066 Error_Msg_SC
("statement not allowed in package spec");
5068 -- If in declarative part, then we give the message complaining
5069 -- about finding a statement when a declaration is expected. This
5070 -- gets changed to a complaint about a missing BEGIN if we later
5071 -- find that no BEGIN is present.
5074 Error_Msg_SC
("statement not allowed in declarative part");
5077 -- Capture message Id. This is used for two purposes, first to
5078 -- stop multiple messages, see test above, and second, to allow
5079 -- the replacement of the message in the declarative part case.
5081 Missing_Begin_Msg
:= Get_Msg_Id
;
5085 -- In all cases except the case in which we decided to terminate the
5086 -- declaration sequence on a second error, we scan out the statement
5087 -- and append it to the list of declarations (note that the semantics
5088 -- can handle statements in a declaration list so if we proceed to
5089 -- call the semantic phase, all will be (reasonably) well.
5091 Append_List_To
(Decls
, P_Sequence_Of_Statements
(SS_Unco
));
5093 -- Done is set to False, since we want to continue the scan of
5094 -- declarations, hoping that this statement was a temporary glitch.
5095 -- If we indeed are now in the statement part (i.e. this was a missing
5096 -- BEGIN, then it's not terrible, we will simply keep calling this
5097 -- procedure to process the statements one by one, and then finally
5098 -- hit the missing BEGIN, which will clean up the error message.
5101 end Statement_When_Declaration_Expected
;