1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, 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
84 -- Scans out a single declarative item, or, in the case of a declaration
85 -- with a list of identifiers, a list of declarations, one for each of the
86 -- identifiers in the list. The declaration or declarations scanned are
87 -- appended to the given list. Done indicates whether or not there may be
88 -- additional declarative items to scan. If Done is True, then a decision
89 -- has been made that there are no more items to scan. If Done is False,
90 -- then there may be additional declarations to scan. In_Spec is true if
91 -- we are scanning a package declaration, and is used to generate an
92 -- appropriate message if a statement is encountered in such a context.
94 procedure P_Identifier_Declarations
98 -- Scans out a set of declarations for an identifier or list of
99 -- identifiers, and appends them to the given list. The parameters have
100 -- the same significance as for P_Declarative_Items.
102 procedure Statement_When_Declaration_Expected
106 -- Called when a statement is found at a point where a declaration was
107 -- expected. The parameters are as described for P_Declarative_Items.
109 procedure Set_Declaration_Expected
;
110 -- Posts a "declaration expected" error messages at the start of the
111 -- current token, and if this is the first such message issued, saves
112 -- the message id in Missing_Begin_Msg, for possible later replacement.
114 ---------------------------------
115 -- Check_Restricted_Expression --
116 ---------------------------------
118 procedure Check_Restricted_Expression
(N
: Node_Id
) is
120 if Nkind_In
(N
, N_Op_And
, N_Op_Or
, N_Op_Xor
, N_And_Then
, N_Or_Else
) then
121 Check_Restricted_Expression
(Left_Opnd
(N
));
122 Check_Restricted_Expression
(Right_Opnd
(N
));
124 elsif Nkind_In
(N
, N_In
, N_Not_In
)
125 and then Paren_Count
(N
) = 0
127 Error_Msg_N
("|this expression must be parenthesized!", N
);
129 end Check_Restricted_Expression
;
135 function Init_Expr_Opt
(P
: Boolean := False) return Node_Id
is
137 -- For colon, assume it means := unless it is at the end of
138 -- a line, in which case guess that it means a semicolon.
140 if Token
= Tok_Colon
then
141 if Token_Is_At_End_Of_Line
then
146 -- Here if := or something that we will take as equivalent
148 elsif Token
= Tok_Colon_Equal
149 or else Token
= Tok_Equal
150 or else Token
= Tok_Is
154 -- Another possibility. If we have a literal followed by a semicolon,
155 -- we assume that we have a missing colon-equal.
157 elsif Token
in Token_Class_Literal
then
159 Scan_State
: Saved_Scan_State
;
162 Save_Scan_State
(Scan_State
);
163 Scan
; -- past literal or identifier
165 if Token
= Tok_Semicolon
then
166 Restore_Scan_State
(Scan_State
);
168 Restore_Scan_State
(Scan_State
);
173 -- Otherwise we definitely have no initialization expression
179 -- Merge here if we have an initialization expression
186 return P_Expression_No_Right_Paren
;
190 ----------------------------
191 -- 3.1 Basic Declaration --
192 ----------------------------
194 -- Parsed by P_Basic_Declarative_Items (3.9)
196 ------------------------------
197 -- 3.1 Defining Identifier --
198 ------------------------------
200 -- DEFINING_IDENTIFIER ::= IDENTIFIER
202 -- Error recovery: can raise Error_Resync
204 function P_Defining_Identifier
(C
: Id_Check
:= None
) return Node_Id
is
205 Ident_Node
: Node_Id
;
208 -- Scan out the identifier. Note that this code is essentially identical
209 -- to P_Identifier, except that in the call to Scan_Reserved_Identifier
210 -- we set Force_Msg to True, since we want at least one message for each
211 -- separate declaration (but not use) of a reserved identifier.
213 -- Duplication should be removed, common code should be factored???
215 if Token
= Tok_Identifier
then
216 Check_Future_Keyword
;
218 -- If we have a reserved identifier, manufacture an identifier with
219 -- a corresponding name after posting an appropriate error message
221 elsif Is_Reserved_Identifier
(C
) then
222 Scan_Reserved_Identifier
(Force_Msg
=> True);
224 -- Otherwise we have junk that cannot be interpreted as an identifier
227 T_Identifier
; -- to give message
231 Ident_Node
:= Token_Node
;
232 Scan
; -- past the reserved identifier
234 -- If we already have a defining identifier, clean it out and make
235 -- a new clean identifier. This situation arises in some error cases
236 -- and we need to fix it.
238 if Nkind
(Ident_Node
) = N_Defining_Identifier
then
239 Ident_Node
:= Make_Identifier
(Sloc
(Ident_Node
), Chars
(Ident_Node
));
242 -- Change identifier to defining identifier if not in error
244 if Ident_Node
/= Error
then
245 Change_Identifier_To_Defining_Identifier
(Ident_Node
);
249 end P_Defining_Identifier
;
251 -----------------------------
252 -- 3.2.1 Type Declaration --
253 -----------------------------
255 -- TYPE_DECLARATION ::=
256 -- FULL_TYPE_DECLARATION
257 -- | INCOMPLETE_TYPE_DECLARATION
258 -- | PRIVATE_TYPE_DECLARATION
259 -- | PRIVATE_EXTENSION_DECLARATION
261 -- FULL_TYPE_DECLARATION ::=
262 -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION
263 -- [ASPECT_SPECIFICATIONS];
264 -- | CONCURRENT_TYPE_DECLARATION
266 -- INCOMPLETE_TYPE_DECLARATION ::=
267 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [is tagged];
269 -- PRIVATE_TYPE_DECLARATION ::=
270 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
271 -- is [abstract] [tagged] [limited] private;
273 -- PRIVATE_EXTENSION_DECLARATION ::=
274 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
275 -- [abstract] [limited | synchronized]
276 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
279 -- TYPE_DEFINITION ::=
280 -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
281 -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION
282 -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION
283 -- | DERIVED_TYPE_DEFINITION | INTERFACE_TYPE_DEFINITION
285 -- INTEGER_TYPE_DEFINITION ::=
286 -- SIGNED_INTEGER_TYPE_DEFINITION
287 -- MODULAR_TYPE_DEFINITION
289 -- INTERFACE_TYPE_DEFINITION ::=
290 -- [limited | task | protected | synchronized ] interface
291 -- [and INTERFACE_LIST]
293 -- Error recovery: can raise Error_Resync
295 -- The processing for full type declarations, incomplete type declarations,
296 -- private type declarations and type definitions is included in this
297 -- function. The processing for concurrent type declarations is NOT here,
298 -- but rather in chapter 9 (this function handles only declarations
299 -- starting with TYPE).
301 function P_Type_Declaration
return Node_Id
is
302 Abstract_Present
: Boolean := False;
303 Abstract_Loc
: Source_Ptr
:= No_Location
;
305 Discr_List
: List_Id
;
306 Discr_Sloc
: Source_Ptr
;
308 Ident_Node
: Node_Id
;
309 Is_Derived_Iface
: Boolean := False;
310 Type_Loc
: Source_Ptr
;
311 Type_Start_Col
: Column_Number
;
312 Unknown_Dis
: Boolean;
314 Typedef_Node
: Node_Id
;
315 -- Normally holds type definition, except in the case of a private
316 -- extension declaration, in which case it holds the declaration itself
319 Type_Loc
:= Token_Ptr
;
320 Type_Start_Col
:= Start_Column
;
322 -- If we have TYPE, then proceed ahead and scan identifier
324 if Token
= Tok_Type
then
325 Type_Token_Location
:= Type_Loc
;
327 Ident_Node
:= P_Defining_Identifier
(C_Is
);
329 -- Otherwise this is an error case
333 Type_Token_Location
:= Type_Loc
;
334 Ident_Node
:= P_Defining_Identifier
(C_Is
);
337 Discr_Sloc
:= Token_Ptr
;
339 if P_Unknown_Discriminant_Part_Opt
then
341 Discr_List
:= No_List
;
343 Unknown_Dis
:= False;
344 Discr_List
:= P_Known_Discriminant_Part_Opt
;
347 -- Incomplete type declaration. We complete the processing for this
348 -- case here and return the resulting incomplete type declaration node
350 if Token
= Tok_Semicolon
then
352 Decl_Node
:= New_Node
(N_Incomplete_Type_Declaration
, Type_Loc
);
353 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
354 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
355 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
362 -- Full type declaration or private type declaration, must have IS
364 if Token
= Tok_Equal
then
366 Scan
; -- past = used in place of IS
368 elsif Token
= Tok_Renames
then
369 Error_Msg_SC
-- CODEFIX
370 ("RENAMES should be IS");
371 Scan
; -- past RENAMES used in place of IS
377 -- First an error check, if we have two identifiers in a row, a likely
378 -- possibility is that the first of the identifiers is an incorrectly
381 if Token
= Tok_Identifier
then
383 SS
: Saved_Scan_State
;
387 Save_Scan_State
(SS
);
388 Scan
; -- past initial identifier
389 I2
:= (Token
= Tok_Identifier
);
390 Restore_Scan_State
(SS
);
394 (Bad_Spelling_Of
(Tok_Abstract
) or else
395 Bad_Spelling_Of
(Tok_Access
) or else
396 Bad_Spelling_Of
(Tok_Aliased
) or else
397 Bad_Spelling_Of
(Tok_Constant
))
404 -- Check for misuse of Ada 95 keyword abstract in Ada 83 mode
406 if Token_Name
= Name_Abstract
then
407 Check_95_Keyword
(Tok_Abstract
, Tok_Tagged
);
408 Check_95_Keyword
(Tok_Abstract
, Tok_New
);
411 -- Check cases of misuse of ABSTRACT
413 if Token
= Tok_Abstract
then
414 Abstract_Present
:= True;
415 Abstract_Loc
:= Token_Ptr
;
416 Scan
; -- past ABSTRACT
418 -- Ada 2005 (AI-419): AARM 3.4 (2/2)
420 if (Ada_Version
< Ada_2005
and then Token
= Tok_Limited
)
421 or else Token
= Tok_Private
422 or else Token
= Tok_Record
423 or else Token
= Tok_Null
425 Error_Msg_AP
("TAGGED expected");
429 -- Check for misuse of Ada 95 keyword Tagged
431 if Token_Name
= Name_Tagged
then
432 Check_95_Keyword
(Tok_Tagged
, Tok_Private
);
433 Check_95_Keyword
(Tok_Tagged
, Tok_Limited
);
434 Check_95_Keyword
(Tok_Tagged
, Tok_Record
);
437 -- Special check for misuse of Aliased
439 if Token
= Tok_Aliased
or else Token_Name
= Name_Aliased
then
440 Error_Msg_SC
("ALIASED not allowed in type definition");
441 Scan
; -- past ALIASED
444 -- The following processing deals with either a private type declaration
445 -- or a full type declaration. In the private type case, we build the
446 -- N_Private_Type_Declaration node, setting its Tagged_Present and
447 -- Limited_Present flags, on encountering the Private keyword, and
448 -- leave Typedef_Node set to Empty. For the full type declaration
449 -- case, Typedef_Node gets set to the type definition.
451 Typedef_Node
:= Empty
;
453 -- Switch on token following the IS. The loop normally runs once. It
454 -- only runs more than once if an error is detected, to try again after
455 -- detecting and fixing up the error.
461 Tok_Not
=> -- Ada 2005 (AI-231)
462 Typedef_Node
:= P_Access_Type_Definition
;
466 Typedef_Node
:= P_Array_Type_Definition
;
470 Typedef_Node
:= P_Fixed_Point_Definition
;
474 Typedef_Node
:= P_Floating_Point_Definition
;
480 when Tok_Integer_Literal
=>
482 Typedef_Node
:= P_Signed_Integer_Type_Definition
;
486 Typedef_Node
:= P_Record_Definition
;
489 when Tok_Left_Paren
=>
490 Typedef_Node
:= P_Enumeration_Type_Definition
;
492 End_Labl
:= Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
493 Set_Comes_From_Source
(End_Labl
, False);
495 Set_End_Label
(Typedef_Node
, End_Labl
);
499 Typedef_Node
:= P_Modular_Type_Definition
;
503 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
505 if Nkind
(Typedef_Node
) = N_Derived_Type_Definition
506 and then Present
(Record_Extension_Part
(Typedef_Node
))
508 End_Labl
:= Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
509 Set_Comes_From_Source
(End_Labl
, False);
512 (Record_Extension_Part
(Typedef_Node
), End_Labl
);
518 Typedef_Node
:= P_Signed_Integer_Type_Definition
;
522 Typedef_Node
:= P_Record_Definition
;
524 End_Labl
:= Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
525 Set_Comes_From_Source
(End_Labl
, False);
527 Set_End_Label
(Typedef_Node
, End_Labl
);
533 -- Ada 2005 (AI-326): If the words IS TAGGED appear, the type
534 -- is a tagged incomplete type.
536 if Ada_Version
>= Ada_2005
537 and then Token
= Tok_Semicolon
542 New_Node
(N_Incomplete_Type_Declaration
, Type_Loc
);
543 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
544 Set_Tagged_Present
(Decl_Node
);
545 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
546 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
551 if Token
= Tok_Abstract
then
552 Error_Msg_SC
-- CODEFIX
553 ("ABSTRACT must come before TAGGED");
554 Abstract_Present
:= True;
555 Abstract_Loc
:= Token_Ptr
;
556 Scan
; -- past ABSTRACT
559 if Token
= Tok_Limited
then
560 Scan
; -- past LIMITED
562 -- TAGGED LIMITED PRIVATE case
564 if Token
= Tok_Private
then
566 New_Node
(N_Private_Type_Declaration
, Type_Loc
);
567 Set_Tagged_Present
(Decl_Node
, True);
568 Set_Limited_Present
(Decl_Node
, True);
569 Scan
; -- past PRIVATE
571 -- TAGGED LIMITED RECORD
574 Typedef_Node
:= P_Record_Definition
;
575 Set_Tagged_Present
(Typedef_Node
, True);
576 Set_Limited_Present
(Typedef_Node
, True);
579 Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
580 Set_Comes_From_Source
(End_Labl
, False);
582 Set_End_Label
(Typedef_Node
, End_Labl
);
588 if Token
= Tok_Private
then
590 New_Node
(N_Private_Type_Declaration
, Type_Loc
);
591 Set_Tagged_Present
(Decl_Node
, True);
592 Scan
; -- past PRIVATE
597 Typedef_Node
:= P_Record_Definition
;
598 Set_Tagged_Present
(Typedef_Node
, True);
601 Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
602 Set_Comes_From_Source
(End_Labl
, False);
604 Set_End_Label
(Typedef_Node
, End_Labl
);
611 Scan
; -- past LIMITED
614 if Token
= Tok_Tagged
then
615 Error_Msg_SC
-- CODEFIX
616 ("TAGGED must come before LIMITED");
619 elsif Token
= Tok_Abstract
then
620 Error_Msg_SC
-- CODEFIX
621 ("ABSTRACT must come before LIMITED");
622 Scan
; -- past ABSTRACT
629 -- LIMITED RECORD or LIMITED NULL RECORD
631 if Token
= Tok_Record
or else Token
= Tok_Null
then
632 if Ada_Version
= Ada_83
then
634 ("(Ada 83) limited record declaration not allowed!");
636 -- In Ada 2005, "abstract limited" can appear before "new",
637 -- but it cannot be part of an untagged record declaration.
639 elsif Abstract_Present
640 and then Prev_Token
/= Tok_Tagged
642 Error_Msg_SP
("TAGGED expected");
645 Typedef_Node
:= P_Record_Definition
;
646 Set_Limited_Present
(Typedef_Node
, True);
648 -- Ada 2005 (AI-251): LIMITED INTERFACE
650 -- If we are compiling in Ada 83 or Ada 95 mode, "interface"
651 -- is not a reserved word but we force its analysis to
652 -- generate the corresponding usage error.
654 elsif Token
= Tok_Interface
655 or else (Token
= Tok_Identifier
656 and then Chars
(Token_Node
) = Name_Interface
)
659 P_Interface_Type_Definition
(Abstract_Present
);
660 Abstract_Present
:= True;
661 Set_Limited_Present
(Typedef_Node
);
663 if Nkind
(Typedef_Node
) = N_Derived_Type_Definition
then
664 Is_Derived_Iface
:= True;
667 -- Ada 2005 (AI-419): LIMITED NEW
669 elsif Token
= Tok_New
then
670 if Ada_Version
< Ada_2005
then
672 ("LIMITED in derived type is an Ada 2005 extension");
674 ("\unit must be compiled with -gnat05 switch");
677 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
678 Set_Limited_Present
(Typedef_Node
);
680 if Nkind
(Typedef_Node
) = N_Derived_Type_Definition
681 and then Present
(Record_Extension_Part
(Typedef_Node
))
684 Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
685 Set_Comes_From_Source
(End_Labl
, False);
688 (Record_Extension_Part
(Typedef_Node
), End_Labl
);
691 -- LIMITED PRIVATE is the only remaining possibility here
694 Decl_Node
:= New_Node
(N_Private_Type_Declaration
, Type_Loc
);
695 Set_Limited_Present
(Decl_Node
, True);
696 T_Private
; -- past PRIVATE (or complain if not there!)
701 -- Here we have an identifier after the IS, which is certainly
702 -- wrong and which might be one of several different mistakes.
704 when Tok_Identifier
=>
706 -- First case, if identifier is on same line, then probably we
707 -- have something like "type X is Integer .." and the best
708 -- diagnosis is a missing NEW. Note: the missing new message
709 -- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl.
711 if not Token_Is_At_Start_Of_Line
then
712 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
714 -- If the identifier is at the start of the line, and is in the
715 -- same column as the type declaration itself then we consider
716 -- that we had a missing type definition on the previous line
718 elsif Start_Column
<= Type_Start_Col
then
719 Error_Msg_AP
("type definition expected");
720 Typedef_Node
:= Error
;
722 -- If the identifier is at the start of the line, and is in
723 -- a column to the right of the type declaration line, then we
724 -- may have something like:
729 -- and the best diagnosis is a missing record keyword
732 Typedef_Node
:= P_Record_Definition
;
737 -- Ada 2005 (AI-251): INTERFACE
739 when Tok_Interface
=>
740 Typedef_Node
:= P_Interface_Type_Definition
(Abstract_Present
);
741 Abstract_Present
:= True;
745 Decl_Node
:= New_Node
(N_Private_Type_Declaration
, Type_Loc
);
746 Scan
; -- past PRIVATE
748 -- Check error cases of private [abstract] tagged
750 if Token
= Tok_Abstract
then
751 Error_Msg_SC
("`ABSTRACT TAGGED` must come before PRIVATE");
752 Scan
; -- past ABSTRACT
754 if Token
= Tok_Tagged
then
758 elsif Token
= Tok_Tagged
then
759 Error_Msg_SC
("TAGGED must come before PRIVATE");
765 -- Ada 2005 (AI-345): Protected, synchronized or task interface
766 -- or Ada 2005 (AI-443): Synchronized private extension.
773 Saved_Token
: constant Token_Type
:= Token
;
776 Scan
; -- past TASK, PROTECTED or SYNCHRONIZED
778 -- Synchronized private extension
780 if Token
= Tok_New
then
781 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
783 if Saved_Token
= Tok_Synchronized
then
784 if Nkind
(Typedef_Node
) =
785 N_Derived_Type_Definition
788 ("SYNCHRONIZED not allowed for record extension",
791 Set_Synchronized_Present
(Typedef_Node
);
795 Error_Msg_SC
("invalid kind of private extension");
801 if Token
/= Tok_Interface
then
802 Error_Msg_SC
("NEW or INTERFACE expected");
806 P_Interface_Type_Definition
(Abstract_Present
);
807 Abstract_Present
:= True;
811 Set_Task_Present
(Typedef_Node
);
813 when Tok_Protected
=>
814 Set_Protected_Present
(Typedef_Node
);
816 when Tok_Synchronized
=>
817 Set_Synchronized_Present
(Typedef_Node
);
820 pragma Assert
(False);
828 -- Anything else is an error
831 if Bad_Spelling_Of
(Tok_Access
)
833 Bad_Spelling_Of
(Tok_Array
)
835 Bad_Spelling_Of
(Tok_Delta
)
837 Bad_Spelling_Of
(Tok_Digits
)
839 Bad_Spelling_Of
(Tok_Limited
)
841 Bad_Spelling_Of
(Tok_Private
)
843 Bad_Spelling_Of
(Tok_Range
)
845 Bad_Spelling_Of
(Tok_Record
)
847 Bad_Spelling_Of
(Tok_Tagged
)
852 Error_Msg_AP
("type definition expected");
859 -- For the private type declaration case, the private type declaration
860 -- node has been built, with the Tagged_Present and Limited_Present
861 -- flags set as needed, and Typedef_Node is left set to Empty.
863 if No
(Typedef_Node
) then
864 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
865 Set_Abstract_Present
(Decl_Node
, Abstract_Present
);
867 -- For a private extension declaration, Typedef_Node contains the
868 -- N_Private_Extension_Declaration node, which we now complete. Note
869 -- that the private extension declaration, unlike a full type
870 -- declaration, does permit unknown discriminants.
872 elsif Nkind
(Typedef_Node
) = N_Private_Extension_Declaration
then
873 Decl_Node
:= Typedef_Node
;
874 Set_Sloc
(Decl_Node
, Type_Loc
);
875 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
876 Set_Abstract_Present
(Typedef_Node
, Abstract_Present
);
878 -- In the full type declaration case, Typedef_Node has the type
879 -- definition and here is where we build the full type declaration
880 -- node. This is also where we check for improper use of an unknown
881 -- discriminant part (not allowed for full type declaration).
884 if Nkind
(Typedef_Node
) = N_Record_Definition
885 or else (Nkind
(Typedef_Node
) = N_Derived_Type_Definition
886 and then Present
(Record_Extension_Part
(Typedef_Node
)))
887 or else Is_Derived_Iface
889 Set_Abstract_Present
(Typedef_Node
, Abstract_Present
);
891 elsif Abstract_Present
then
892 Error_Msg
("ABSTRACT not allowed here, ignored", Abstract_Loc
);
895 Decl_Node
:= New_Node
(N_Full_Type_Declaration
, Type_Loc
);
896 Set_Type_Definition
(Decl_Node
, Typedef_Node
);
900 ("Full type declaration cannot have unknown discriminants",
905 -- Remaining processing is common for all three cases
907 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
908 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
909 P_Aspect_Specifications
(Decl_Node
);
911 end P_Type_Declaration
;
913 ----------------------------------
914 -- 3.2.1 Full Type Declaration --
915 ----------------------------------
917 -- Parsed by P_Type_Declaration (3.2.1)
919 ----------------------------
920 -- 3.2.1 Type Definition --
921 ----------------------------
923 -- Parsed by P_Type_Declaration (3.2.1)
925 --------------------------------
926 -- 3.2.2 Subtype Declaration --
927 --------------------------------
929 -- SUBTYPE_DECLARATION ::=
930 -- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION
931 -- {ASPECT_SPECIFICATIONS];
933 -- The caller has checked that the initial token is SUBTYPE
935 -- Error recovery: can raise Error_Resync
937 function P_Subtype_Declaration
return Node_Id
is
939 Not_Null_Present
: Boolean := False;
942 Decl_Node
:= New_Node
(N_Subtype_Declaration
, Token_Ptr
);
943 Scan
; -- past SUBTYPE
944 Set_Defining_Identifier
(Decl_Node
, P_Defining_Identifier
(C_Is
));
947 if Token
= Tok_New
then
948 Error_Msg_SC
-- CODEFIX
949 ("NEW ignored (only allowed in type declaration)");
953 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
954 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
956 Set_Subtype_Indication
957 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
958 P_Aspect_Specifications
(Decl_Node
);
960 end P_Subtype_Declaration
;
962 -------------------------------
963 -- 3.2.2 Subtype Indication --
964 -------------------------------
966 -- SUBTYPE_INDICATION ::=
967 -- [not null] SUBTYPE_MARK [CONSTRAINT]
969 -- Error recovery: can raise Error_Resync
971 function P_Null_Exclusion
972 (Allow_Anonymous_In_95
: Boolean := False) return Boolean
974 Not_Loc
: constant Source_Ptr
:= Token_Ptr
;
975 -- Source position of "not", if present
978 if Token
/= Tok_Not
then
984 if Token
= Tok_Null
then
987 -- Ada 2005 (AI-441, AI-447): null_exclusion is illegal in Ada 95,
988 -- except in the case of anonymous access types.
990 -- Allow_Anonymous_In_95 will be True if we're parsing a formal
991 -- parameter or discriminant, which are the only places where
992 -- anonymous access types occur in Ada 95. "Formal : not null
993 -- access ..." is legal in Ada 95, whereas "Formal : not null
994 -- Named_Access_Type" is not.
996 if Ada_Version
>= Ada_2005
997 or else (Ada_Version
>= Ada_95
998 and then Allow_Anonymous_In_95
999 and then Token
= Tok_Access
)
1005 ("`NOT NULL` access type is an Ada 2005 extension", Not_Loc
);
1007 ("\unit should be compiled with -gnat05 switch", Not_Loc
);
1011 Error_Msg_SP
("NULL expected");
1014 if Token
= Tok_New
then
1015 Error_Msg
("`NOT NULL` comes after NEW, not before", Not_Loc
);
1020 end P_Null_Exclusion
;
1022 function P_Subtype_Indication
1023 (Not_Null_Present
: Boolean := False) return Node_Id
1025 Type_Node
: Node_Id
;
1028 if Token
= Tok_Identifier
or else Token
= Tok_Operator_Symbol
then
1029 Type_Node
:= P_Subtype_Mark
;
1030 return P_Subtype_Indication
(Type_Node
, Not_Null_Present
);
1033 -- Check for error of using record definition and treat it nicely,
1034 -- otherwise things are really messed up, so resynchronize.
1036 if Token
= Tok_Record
then
1037 Error_Msg_SC
("anonymous record definitions are not permitted");
1038 Discard_Junk_Node
(P_Record_Definition
);
1042 Error_Msg_AP
("subtype indication expected");
1046 end P_Subtype_Indication
;
1048 -- The following function is identical except that it is called with
1049 -- the subtype mark already scanned out, and it scans out the constraint
1051 -- Error recovery: can raise Error_Resync
1053 function P_Subtype_Indication
1054 (Subtype_Mark
: Node_Id
;
1055 Not_Null_Present
: Boolean := False) return Node_Id
1057 Indic_Node
: Node_Id
;
1058 Constr_Node
: Node_Id
;
1061 Constr_Node
:= P_Constraint_Opt
;
1065 (Nkind
(Constr_Node
) = N_Range_Constraint
1066 and then Nkind
(Range_Expression
(Constr_Node
)) = N_Error
)
1068 return Subtype_Mark
;
1070 if Not_Null_Present
then
1071 Error_Msg_SP
("`NOT NULL` not allowed if constraint given");
1074 Indic_Node
:= New_Node
(N_Subtype_Indication
, Sloc
(Subtype_Mark
));
1075 Set_Subtype_Mark
(Indic_Node
, Check_Subtype_Mark
(Subtype_Mark
));
1076 Set_Constraint
(Indic_Node
, Constr_Node
);
1079 end P_Subtype_Indication
;
1081 -------------------------
1082 -- 3.2.2 Subtype Mark --
1083 -------------------------
1085 -- SUBTYPE_MARK ::= subtype_NAME;
1087 -- Note: The subtype mark which appears after an IN or NOT IN
1088 -- operator is parsed by P_Range_Or_Subtype_Mark (3.5)
1090 -- Error recovery: cannot raise Error_Resync
1092 function P_Subtype_Mark
return Node_Id
is
1094 return P_Subtype_Mark_Resync
;
1096 when Error_Resync
=>
1100 -- This routine differs from P_Subtype_Mark in that it insists that an
1101 -- identifier be present, and if it is not, it raises Error_Resync.
1103 -- Error recovery: can raise Error_Resync
1105 function P_Subtype_Mark_Resync
return Node_Id
is
1106 Type_Node
: Node_Id
;
1109 if Token
= Tok_Access
then
1110 Error_Msg_SC
("anonymous access type definition not allowed here");
1111 Scan
; -- past ACCESS
1114 if Token
= Tok_Array
then
1115 Error_Msg_SC
("anonymous array definition not allowed here");
1116 Discard_Junk_Node
(P_Array_Type_Definition
);
1120 Type_Node
:= P_Qualified_Simple_Name_Resync
;
1122 -- Check for a subtype mark attribute. The only valid possibilities
1123 -- are 'CLASS and 'BASE. Anything else is a definite error. We may
1124 -- as well catch it here.
1126 if Token
= Tok_Apostrophe
then
1127 return P_Subtype_Mark_Attribute
(Type_Node
);
1132 end P_Subtype_Mark_Resync
;
1134 -- The following function is called to scan out a subtype mark attribute.
1135 -- The caller has already scanned out the subtype mark, which is passed in
1136 -- as the argument, and has checked that the current token is apostrophe.
1138 -- Only a special subclass of attributes, called type attributes
1139 -- (see Snames package) are allowed in this syntactic position.
1141 -- Note: if the apostrophe is followed by other than an identifier, then
1142 -- the input expression is returned unchanged, and the scan pointer is
1143 -- left pointing to the apostrophe.
1145 -- Error recovery: can raise Error_Resync
1147 function P_Subtype_Mark_Attribute
(Type_Node
: Node_Id
) return Node_Id
is
1148 Attr_Node
: Node_Id
:= Empty
;
1149 Scan_State
: Saved_Scan_State
;
1153 Prefix
:= Check_Subtype_Mark
(Type_Node
);
1155 if Prefix
= Error
then
1159 -- Loop through attributes appearing (more than one can appear as for
1160 -- for example in X'Base'Class). We are at an apostrophe on entry to
1161 -- this loop, and it runs once for each attribute parsed, with
1162 -- Prefix being the current possible prefix if it is an attribute.
1165 Save_Scan_State
(Scan_State
); -- at Apostrophe
1166 Scan
; -- past apostrophe
1168 if Token
/= Tok_Identifier
then
1169 Restore_Scan_State
(Scan_State
); -- to apostrophe
1170 return Prefix
; -- no attribute after all
1172 elsif not Is_Type_Attribute_Name
(Token_Name
) then
1174 ("attribute & may not be used in a subtype mark", Token_Node
);
1179 Make_Attribute_Reference
(Prev_Token_Ptr
,
1181 Attribute_Name
=> Token_Name
);
1182 Scan
; -- past type attribute identifier
1185 exit when Token
/= Tok_Apostrophe
;
1186 Prefix
:= Attr_Node
;
1189 -- Fall through here after scanning type attribute
1192 end P_Subtype_Mark_Attribute
;
1194 -----------------------
1195 -- 3.2.2 Constraint --
1196 -----------------------
1198 -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
1200 -- SCALAR_CONSTRAINT ::=
1201 -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
1203 -- COMPOSITE_CONSTRAINT ::=
1204 -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
1206 -- If no constraint is present, this function returns Empty
1208 -- Error recovery: can raise Error_Resync
1210 function P_Constraint_Opt
return Node_Id
is
1212 if Token
= Tok_Range
1213 or else Bad_Spelling_Of
(Tok_Range
)
1215 return P_Range_Constraint
;
1217 elsif Token
= Tok_Digits
1218 or else Bad_Spelling_Of
(Tok_Digits
)
1220 return P_Digits_Constraint
;
1222 elsif Token
= Tok_Delta
1223 or else Bad_Spelling_Of
(Tok_Delta
)
1225 return P_Delta_Constraint
;
1227 elsif Token
= Tok_Left_Paren
then
1228 return P_Index_Or_Discriminant_Constraint
;
1230 elsif Token
= Tok_In
then
1232 return P_Constraint_Opt
;
1237 end P_Constraint_Opt
;
1239 ------------------------------
1240 -- 3.2.2 Scalar Constraint --
1241 ------------------------------
1243 -- Parsed by P_Constraint_Opt (3.2.2)
1245 ---------------------------------
1246 -- 3.2.2 Composite Constraint --
1247 ---------------------------------
1249 -- Parsed by P_Constraint_Opt (3.2.2)
1251 --------------------------------------------------------
1252 -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) --
1253 --------------------------------------------------------
1255 -- This routine scans out a declaration starting with an identifier:
1257 -- OBJECT_DECLARATION ::=
1258 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1259 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION]
1260 -- [ASPECT_SPECIFICATIONS];
1261 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1262 -- ACCESS_DEFINITION [:= EXPRESSION]
1263 -- [ASPECT_SPECIFICATIONS];
1264 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1265 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]
1266 -- [ASPECT_SPECIFICATIONS];
1268 -- NUMBER_DECLARATION ::=
1269 -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
1271 -- OBJECT_RENAMING_DECLARATION ::=
1272 -- DEFINING_IDENTIFIER :
1273 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
1274 -- | DEFINING_IDENTIFIER :
1275 -- ACCESS_DEFINITION renames object_NAME;
1277 -- EXCEPTION_RENAMING_DECLARATION ::=
1278 -- DEFINING_IDENTIFIER : exception renames exception_NAME;
1280 -- EXCEPTION_DECLARATION ::=
1281 -- DEFINING_IDENTIFIER_LIST : exception
1282 -- [ASPECT_SPECIFICATIONS];
1284 -- Note that the ALIASED indication in an object declaration is
1285 -- marked by a flag in the parent node.
1287 -- The caller has checked that the initial token is an identifier
1289 -- The value returned is a list of declarations, one for each identifier
1290 -- in the list (as described in Sinfo, we always split up multiple
1291 -- declarations into the equivalent sequence of single declarations
1292 -- using the More_Ids and Prev_Ids flags to preserve the source).
1294 -- If the identifier turns out to be a probable statement rather than
1295 -- an identifier, then the scan is left pointing to the identifier and
1296 -- No_List is returned.
1298 -- Error recovery: can raise Error_Resync
1300 procedure P_Identifier_Declarations
1306 Decl_Node
: Node_Id
;
1307 Type_Node
: Node_Id
;
1308 Ident_Sloc
: Source_Ptr
;
1309 Scan_State
: Saved_Scan_State
;
1310 List_OK
: Boolean := True;
1312 Init_Expr
: Node_Id
;
1313 Init_Loc
: Source_Ptr
;
1314 Con_Loc
: Source_Ptr
;
1315 Not_Null_Present
: Boolean := False;
1317 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
1318 -- Used to save identifiers in the identifier list. The upper bound
1319 -- of 4096 is expected to be infinite in practice, and we do not even
1320 -- bother to check if this upper bound is exceeded.
1322 Num_Idents
: Nat
:= 1;
1323 -- Number of identifiers stored in Idents
1326 -- This procedure is called in renames cases to make sure that we do
1327 -- not have more than one identifier. If we do have more than one
1328 -- then an error message is issued (and the declaration is split into
1329 -- multiple declarations)
1331 function Token_Is_Renames
return Boolean;
1332 -- Checks if current token is RENAMES, and if so, scans past it and
1333 -- returns True, otherwise returns False. Includes checking for some
1334 -- common error cases.
1340 procedure No_List
is
1342 if Num_Idents
> 1 then
1344 ("identifier list not allowed for RENAMES",
1351 ----------------------
1352 -- Token_Is_Renames --
1353 ----------------------
1355 function Token_Is_Renames
return Boolean is
1356 At_Colon
: Saved_Scan_State
;
1359 if Token
= Tok_Colon
then
1360 Save_Scan_State
(At_Colon
);
1362 Check_Misspelling_Of
(Tok_Renames
);
1364 if Token
= Tok_Renames
then
1365 Error_Msg_SP
-- CODEFIX
1366 ("|extra "":"" ignored");
1367 Scan
; -- past RENAMES
1370 Restore_Scan_State
(At_Colon
);
1375 Check_Misspelling_Of
(Tok_Renames
);
1377 if Token
= Tok_Renames
then
1378 Scan
; -- past RENAMES
1384 end Token_Is_Renames
;
1386 -- Start of processing for P_Identifier_Declarations
1389 Ident_Sloc
:= Token_Ptr
;
1390 Save_Scan_State
(Scan_State
); -- at first identifier
1391 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
1393 -- If we have a colon after the identifier, then we can assume that
1394 -- this is in fact a valid identifier declaration and can steam ahead.
1396 if Token
= Tok_Colon
then
1399 -- If we have a comma, then scan out the list of identifiers
1401 elsif Token
= Tok_Comma
then
1402 while Comma_Present
loop
1403 Num_Idents
:= Num_Idents
+ 1;
1404 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
1407 Save_Scan_State
(Scan_State
); -- at colon
1410 -- If we have identifier followed by := then we assume that what is
1411 -- really meant is an assignment statement. The assignment statement
1412 -- is scanned out and added to the list of declarations. An exception
1413 -- occurs if the := is followed by the keyword constant, in which case
1414 -- we assume it was meant to be a colon.
1416 elsif Token
= Tok_Colon_Equal
then
1419 if Token
= Tok_Constant
then
1420 Error_Msg_SP
("colon expected");
1423 Restore_Scan_State
(Scan_State
);
1424 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
1428 -- If we have an IS keyword, then assume the TYPE keyword was missing
1430 elsif Token
= Tok_Is
then
1431 Restore_Scan_State
(Scan_State
);
1432 Append_To
(Decls
, P_Type_Declaration
);
1436 -- Otherwise we have an error situation
1439 Restore_Scan_State
(Scan_State
);
1441 -- First case is possible misuse of PROTECTED in Ada 83 mode. If
1442 -- so, fix the keyword and return to scan the protected declaration.
1444 if Token_Name
= Name_Protected
then
1445 Check_95_Keyword
(Tok_Protected
, Tok_Identifier
);
1446 Check_95_Keyword
(Tok_Protected
, Tok_Type
);
1447 Check_95_Keyword
(Tok_Protected
, Tok_Body
);
1449 if Token
= Tok_Protected
then
1454 -- Check misspelling possibilities. If so, correct the misspelling
1455 -- and return to scan out the resulting declaration.
1457 elsif Bad_Spelling_Of
(Tok_Function
)
1458 or else Bad_Spelling_Of
(Tok_Procedure
)
1459 or else Bad_Spelling_Of
(Tok_Package
)
1460 or else Bad_Spelling_Of
(Tok_Pragma
)
1461 or else Bad_Spelling_Of
(Tok_Protected
)
1462 or else Bad_Spelling_Of
(Tok_Generic
)
1463 or else Bad_Spelling_Of
(Tok_Subtype
)
1464 or else Bad_Spelling_Of
(Tok_Type
)
1465 or else Bad_Spelling_Of
(Tok_Task
)
1466 or else Bad_Spelling_Of
(Tok_Use
)
1467 or else Bad_Spelling_Of
(Tok_For
)
1472 -- Otherwise we definitely have an ordinary identifier with a junk
1473 -- token after it. Just complain that we expect a declaration, and
1474 -- skip to a semicolon
1477 Set_Declaration_Expected
;
1478 Resync_Past_Semicolon
;
1484 -- Come here with an identifier list and colon scanned out. We now
1485 -- build the nodes for the declarative items. One node is built for
1486 -- each identifier in the list, with the type information being
1487 -- repeated by rescanning the appropriate section of source.
1489 -- First an error check, if we have two identifiers in a row, a likely
1490 -- possibility is that the first of the identifiers is an incorrectly
1493 if Token
= Tok_Identifier
then
1495 SS
: Saved_Scan_State
;
1499 Save_Scan_State
(SS
);
1500 Scan
; -- past initial identifier
1501 I2
:= (Token
= Tok_Identifier
);
1502 Restore_Scan_State
(SS
);
1506 (Bad_Spelling_Of
(Tok_Access
) or else
1507 Bad_Spelling_Of
(Tok_Aliased
) or else
1508 Bad_Spelling_Of
(Tok_Constant
))
1515 -- Loop through identifiers
1520 -- Check for some cases of misused Ada 95 keywords
1522 if Token_Name
= Name_Aliased
then
1523 Check_95_Keyword
(Tok_Aliased
, Tok_Array
);
1524 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
1525 Check_95_Keyword
(Tok_Aliased
, Tok_Constant
);
1530 if Token
= Tok_Constant
then
1531 Con_Loc
:= Token_Ptr
;
1532 Scan
; -- past CONSTANT
1534 -- Number declaration, initialization required
1536 Init_Expr
:= Init_Expr_Opt
;
1538 if Present
(Init_Expr
) then
1539 if Not_Null_Present
then
1541 ("`NOT NULL` not allowed in numeric expression");
1544 Decl_Node
:= New_Node
(N_Number_Declaration
, Ident_Sloc
);
1545 Set_Expression
(Decl_Node
, Init_Expr
);
1547 -- Constant object declaration
1550 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1551 Set_Constant_Present
(Decl_Node
, True);
1553 if Token_Name
= Name_Aliased
then
1554 Check_95_Keyword
(Tok_Aliased
, Tok_Array
);
1555 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
1558 if Token
= Tok_Aliased
then
1559 Error_Msg_SC
-- CODEFIX
1560 ("ALIASED should be before CONSTANT");
1561 Scan
; -- past ALIASED
1562 Set_Aliased_Present
(Decl_Node
, True);
1565 if Token
= Tok_Array
then
1566 Set_Object_Definition
1567 (Decl_Node
, P_Array_Type_Definition
);
1570 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1571 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1573 if Token
= Tok_Access
then
1574 if Ada_Version
< Ada_2005
then
1576 ("generalized use of anonymous access types " &
1577 "is an Ada 2005 extension");
1579 ("\unit must be compiled with -gnat05 switch");
1582 Set_Object_Definition
1583 (Decl_Node
, P_Access_Definition
(Not_Null_Present
));
1585 Set_Object_Definition
1586 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
1590 if Token
= Tok_Renames
then
1592 ("CONSTANT not permitted in renaming declaration",
1594 Scan
; -- Past renames
1595 Discard_Junk_Node
(P_Name
);
1601 elsif Token
= Tok_Exception
then
1602 Scan
; -- past EXCEPTION
1604 if Token_Is_Renames
then
1607 New_Node
(N_Exception_Renaming_Declaration
, Ident_Sloc
);
1608 Set_Name
(Decl_Node
, P_Qualified_Simple_Name_Resync
);
1611 Decl_Node
:= New_Node
(N_Exception_Declaration
, Prev_Token_Ptr
);
1614 -- Aliased case (note that an object definition is required)
1616 elsif Token
= Tok_Aliased
then
1617 Scan
; -- past ALIASED
1618 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1619 Set_Aliased_Present
(Decl_Node
, True);
1621 if Token
= Tok_Constant
then
1622 Scan
; -- past CONSTANT
1623 Set_Constant_Present
(Decl_Node
, True);
1626 if Token
= Tok_Array
then
1627 Set_Object_Definition
1628 (Decl_Node
, P_Array_Type_Definition
);
1631 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1632 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1634 -- Access definition (AI-406) or subtype indication
1636 if Token
= Tok_Access
then
1637 if Ada_Version
< Ada_2005
then
1639 ("generalized use of anonymous access types " &
1640 "is an Ada 2005 extension");
1642 ("\unit must be compiled with -gnat05 switch");
1645 Set_Object_Definition
1646 (Decl_Node
, P_Access_Definition
(Not_Null_Present
));
1648 Set_Object_Definition
1649 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
1655 elsif Token
= Tok_Array
then
1656 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1657 Set_Object_Definition
(Decl_Node
, P_Array_Type_Definition
);
1659 -- Ada 2005 (AI-254, AI-406)
1661 elsif Token
= Tok_Not
then
1663 -- OBJECT_DECLARATION ::=
1664 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1665 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1666 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1667 -- ACCESS_DEFINITION [:= EXPRESSION];
1669 -- OBJECT_RENAMING_DECLARATION ::=
1670 -- DEFINING_IDENTIFIER :
1671 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
1672 -- | DEFINING_IDENTIFIER :
1673 -- ACCESS_DEFINITION renames object_NAME;
1675 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/423)
1677 if Token
= Tok_Access
then
1678 if Ada_Version
< Ada_2005
then
1680 ("generalized use of anonymous access types " &
1681 "is an Ada 2005 extension");
1682 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1685 Acc_Node
:= P_Access_Definition
(Not_Null_Present
);
1687 if Token
/= Tok_Renames
then
1688 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1689 Set_Object_Definition
(Decl_Node
, Acc_Node
);
1692 Scan
; -- past renames
1695 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1696 Set_Access_Definition
(Decl_Node
, Acc_Node
);
1697 Set_Name
(Decl_Node
, P_Name
);
1701 Type_Node
:= P_Subtype_Mark
;
1703 -- Object renaming declaration
1705 if Token_Is_Renames
then
1706 if Ada_Version
< Ada_2005
then
1708 ("`NOT NULL` not allowed in object renaming");
1711 -- Ada 2005 (AI-423): Object renaming declaration with
1712 -- a null exclusion.
1717 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1718 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1719 Set_Subtype_Mark
(Decl_Node
, Type_Node
);
1720 Set_Name
(Decl_Node
, P_Name
);
1723 -- Object declaration
1726 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1727 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1728 Set_Object_Definition
1730 P_Subtype_Indication
(Type_Node
, Not_Null_Present
));
1732 -- RENAMES at this point means that we had the combination
1733 -- of a constraint on the Type_Node and renames, which is
1736 if Token_Is_Renames
then
1738 ("constraint not allowed in object renaming "
1740 Constraint
(Object_Definition
(Decl_Node
)));
1746 -- Ada 2005 (AI-230): Access Definition case
1748 elsif Token
= Tok_Access
then
1749 if Ada_Version
< Ada_2005
then
1751 ("generalized use of anonymous access types " &
1752 "is an Ada 2005 extension");
1753 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1756 Acc_Node
:= P_Access_Definition
(Null_Exclusion_Present
=> False);
1758 -- Object declaration with access definition, or renaming
1760 if Token
/= Tok_Renames
then
1761 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1762 Set_Object_Definition
(Decl_Node
, Acc_Node
);
1765 Scan
; -- past renames
1768 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1769 Set_Access_Definition
(Decl_Node
, Acc_Node
);
1770 Set_Name
(Decl_Node
, P_Name
);
1773 -- Subtype indication case
1776 Type_Node
:= P_Subtype_Mark
;
1778 -- Object renaming declaration
1780 if Token_Is_Renames
then
1783 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1784 Set_Subtype_Mark
(Decl_Node
, Type_Node
);
1785 Set_Name
(Decl_Node
, P_Name
);
1787 -- Object declaration
1790 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1791 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1792 Set_Object_Definition
1794 P_Subtype_Indication
(Type_Node
, Not_Null_Present
));
1796 -- RENAMES at this point means that we had the combination of
1797 -- a constraint on the Type_Node and renames, which is illegal
1799 if Token_Is_Renames
then
1801 ("constraint not allowed in object renaming declaration",
1802 Constraint
(Object_Definition
(Decl_Node
)));
1808 -- Scan out initialization, allowed only for object declaration
1810 Init_Loc
:= Token_Ptr
;
1811 Init_Expr
:= Init_Expr_Opt
;
1813 if Present
(Init_Expr
) then
1814 if Nkind
(Decl_Node
) = N_Object_Declaration
then
1815 Set_Expression
(Decl_Node
, Init_Expr
);
1816 Set_Has_Init_Expression
(Decl_Node
);
1818 Error_Msg
("initialization not allowed here", Init_Loc
);
1822 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
1823 P_Aspect_Specifications
(Decl_Node
);
1826 if Ident
< Num_Idents
then
1827 Set_More_Ids
(Decl_Node
, True);
1831 Set_Prev_Ids
(Decl_Node
, True);
1835 Append
(Decl_Node
, Decls
);
1836 exit Ident_Loop
when Ident
= Num_Idents
;
1837 Restore_Scan_State
(Scan_State
);
1840 end loop Ident_Loop
;
1843 end P_Identifier_Declarations
;
1845 -------------------------------
1846 -- 3.3.1 Object Declaration --
1847 -------------------------------
1849 -- OBJECT DECLARATION ::=
1850 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1851 -- SUBTYPE_INDICATION [:= EXPRESSION];
1852 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1853 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1854 -- | SINGLE_TASK_DECLARATION
1855 -- | SINGLE_PROTECTED_DECLARATION
1857 -- Cases starting with TASK are parsed by P_Task (9.1)
1858 -- Cases starting with PROTECTED are parsed by P_Protected (9.4)
1859 -- All other cases are parsed by P_Identifier_Declarations (3.3)
1861 -------------------------------------
1862 -- 3.3.1 Defining Identifier List --
1863 -------------------------------------
1865 -- DEFINING_IDENTIFIER_LIST ::=
1866 -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
1868 -- Always parsed by the construct in which it appears. See special
1869 -- section on "Handling of Defining Identifier Lists" in this unit.
1871 -------------------------------
1872 -- 3.3.2 Number Declaration --
1873 -------------------------------
1875 -- Parsed by P_Identifier_Declarations (3.3)
1877 -------------------------------------------------------------------------
1878 -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) --
1879 -------------------------------------------------------------------------
1881 -- DERIVED_TYPE_DEFINITION ::=
1882 -- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
1883 -- [[and INTERFACE_LIST] RECORD_EXTENSION_PART]
1885 -- PRIVATE_EXTENSION_DECLARATION ::=
1886 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
1887 -- [abstract] [limited | synchronized]
1888 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
1891 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
1893 -- The caller has already scanned out the part up to the NEW, and Token
1894 -- either contains Tok_New (or ought to, if it doesn't this procedure
1895 -- will post an appropriate "NEW expected" message).
1897 -- Note: the caller is responsible for filling in the Sloc field of
1898 -- the returned node in the private extension declaration case as
1899 -- well as the stuff relating to the discriminant part.
1901 -- Error recovery: can raise Error_Resync;
1903 function P_Derived_Type_Def_Or_Private_Ext_Decl
return Node_Id
is
1904 Typedef_Node
: Node_Id
;
1905 Typedecl_Node
: Node_Id
;
1906 Not_Null_Present
: Boolean := False;
1909 Typedef_Node
:= New_Node
(N_Derived_Type_Definition
, Token_Ptr
);
1911 if Ada_Version
< Ada_2005
1912 and then Token
= Tok_Identifier
1913 and then Token_Name
= Name_Interface
1916 ("abstract interface is an Ada 2005 extension");
1917 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1922 if Token
= Tok_Abstract
then
1923 Error_Msg_SC
-- CODEFIX
1924 ("ABSTRACT must come before NEW, not after");
1928 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1929 Set_Null_Exclusion_Present
(Typedef_Node
, Not_Null_Present
);
1930 Set_Subtype_Indication
(Typedef_Node
,
1931 P_Subtype_Indication
(Not_Null_Present
));
1933 -- Ada 2005 (AI-251): Deal with interfaces
1935 if Token
= Tok_And
then
1938 if Ada_Version
< Ada_2005
then
1940 ("abstract interface is an Ada 2005 extension");
1941 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1944 Set_Interface_List
(Typedef_Node
, New_List
);
1947 Append
(P_Qualified_Simple_Name
, Interface_List
(Typedef_Node
));
1948 exit when Token
/= Tok_And
;
1952 if Token
/= Tok_With
then
1953 Error_Msg_SC
("WITH expected");
1958 -- Deal with record extension, note that we assume that a WITH is
1959 -- missing in the case of "type X is new Y record ..." or in the
1960 -- case of "type X is new Y null record".
1962 -- First make sure we don't have an aspect specification. If we do
1963 -- return now, so that our caller can check it (the WITH here is not
1964 -- part of a type extension).
1966 if Aspect_Specifications_Present
then
1967 return Typedef_Node
;
1969 -- OK, not an aspect specification, so continue test for extension
1971 elsif Token
= Tok_With
1972 or else Token
= Tok_Record
1973 or else Token
= Tok_Null
1975 T_With
; -- past WITH or give error message
1977 if Token
= Tok_Limited
then
1978 Error_Msg_SC
("LIMITED keyword not allowed in private extension");
1979 Scan
; -- ignore LIMITED
1982 -- Private extension declaration
1984 if Token
= Tok_Private
then
1985 Scan
; -- past PRIVATE
1987 -- Throw away the type definition node and build the type
1988 -- declaration node. Note the caller must set the Sloc,
1989 -- Discriminant_Specifications, Unknown_Discriminants_Present,
1990 -- and Defined_Identifier fields in the returned node.
1993 Make_Private_Extension_Declaration
(No_Location
,
1994 Defining_Identifier
=> Empty
,
1995 Subtype_Indication
=> Subtype_Indication
(Typedef_Node
),
1996 Abstract_Present
=> Abstract_Present
(Typedef_Node
),
1997 Interface_List
=> Interface_List
(Typedef_Node
));
1999 return Typedecl_Node
;
2001 -- Derived type definition with record extension part
2004 Set_Record_Extension_Part
(Typedef_Node
, P_Record_Definition
);
2005 return Typedef_Node
;
2008 -- Derived type definition with no record extension part
2011 return Typedef_Node
;
2013 end P_Derived_Type_Def_Or_Private_Ext_Decl
;
2015 ---------------------------
2016 -- 3.5 Range Constraint --
2017 ---------------------------
2019 -- RANGE_CONSTRAINT ::= range RANGE
2021 -- The caller has checked that the initial token is RANGE
2023 -- Error recovery: cannot raise Error_Resync
2025 function P_Range_Constraint
return Node_Id
is
2026 Range_Node
: Node_Id
;
2029 Range_Node
:= New_Node
(N_Range_Constraint
, Token_Ptr
);
2031 Set_Range_Expression
(Range_Node
, P_Range
);
2033 end P_Range_Constraint
;
2040 -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
2042 -- Note: the range that appears in a membership test is parsed by
2043 -- P_Range_Or_Subtype_Mark (3.5).
2045 -- Error recovery: cannot raise Error_Resync
2047 function P_Range
return Node_Id
is
2048 Expr_Node
: Node_Id
;
2049 Range_Node
: Node_Id
;
2052 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2054 if Expr_Form
= EF_Range_Attr
then
2057 elsif Token
= Tok_Dot_Dot
then
2058 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2059 Set_Low_Bound
(Range_Node
, Expr_Node
);
2061 Expr_Node
:= P_Expression
;
2062 Check_Simple_Expression
(Expr_Node
);
2063 Set_High_Bound
(Range_Node
, Expr_Node
);
2066 -- Anything else is an error
2069 T_Dot_Dot
; -- force missing .. message
2074 ----------------------------------
2075 -- 3.5 P_Range_Or_Subtype_Mark --
2076 ----------------------------------
2079 -- RANGE_ATTRIBUTE_REFERENCE
2080 -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
2082 -- This routine scans out the range or subtype mark that forms the right
2083 -- operand of a membership test (it is not used in any other contexts, and
2084 -- error messages are specialized with this knowledge in mind).
2086 -- Note: as documented in the Sinfo interface, although the syntax only
2087 -- allows a subtype mark, we in fact allow any simple expression to be
2088 -- returned from this routine. The semantics is responsible for issuing
2089 -- an appropriate message complaining if the argument is not a name.
2090 -- This simplifies the coding and error recovery processing in the
2091 -- parser, and in any case it is preferable not to consider this a
2092 -- syntax error and to continue with the semantic analysis.
2094 -- Error recovery: cannot raise Error_Resync
2096 function P_Range_Or_Subtype_Mark
2097 (Allow_Simple_Expression
: Boolean := False) return Node_Id
2099 Expr_Node
: Node_Id
;
2100 Range_Node
: Node_Id
;
2101 Save_Loc
: Source_Ptr
;
2103 -- Start of processing for P_Range_Or_Subtype_Mark
2106 -- Save location of possible junk parentheses
2108 Save_Loc
:= Token_Ptr
;
2110 -- Scan out either a simple expression or a range (this accepts more
2111 -- than is legal here, but as explained above, we like to allow more
2112 -- with a proper diagnostic, and in the case of a membership operation
2113 -- where sets are allowed, a simple expression is permissible anyway.
2115 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2119 if Expr_Form
= EF_Range_Attr
then
2122 -- Simple_Expression .. Simple_Expression
2124 elsif Token
= Tok_Dot_Dot
then
2125 Check_Simple_Expression
(Expr_Node
);
2126 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2127 Set_Low_Bound
(Range_Node
, Expr_Node
);
2129 Set_High_Bound
(Range_Node
, P_Simple_Expression
);
2132 -- Case of subtype mark (optionally qualified simple name or an
2133 -- attribute whose prefix is an optionally qualified simple name)
2135 elsif Expr_Form
= EF_Simple_Name
2136 or else Nkind
(Expr_Node
) = N_Attribute_Reference
2138 -- Check for error of range constraint after a subtype mark
2140 if Token
= Tok_Range
then
2141 Error_Msg_SC
("range constraint not allowed in membership test");
2145 -- Check for error of DIGITS or DELTA after a subtype mark
2147 elsif Token
= Tok_Digits
or else Token
= Tok_Delta
then
2149 ("accuracy definition not allowed in membership test");
2150 Scan
; -- past DIGITS or DELTA
2153 -- Attribute reference, may or may not be OK, but in any case we
2156 elsif Token
= Tok_Apostrophe
then
2157 return P_Subtype_Mark_Attribute
(Expr_Node
);
2159 -- OK case of simple name, just return it
2165 -- Simple expression case
2167 elsif Expr_Form
= EF_Simple
and then Allow_Simple_Expression
then
2170 -- Here we have some kind of error situation. Check for junk parens
2171 -- then return what we have, caller will deal with other errors.
2174 if Nkind
(Expr_Node
) in N_Subexpr
2175 and then Paren_Count
(Expr_Node
) /= 0
2177 Error_Msg
("|parentheses not allowed for subtype mark", Save_Loc
);
2178 Set_Paren_Count
(Expr_Node
, 0);
2183 end P_Range_Or_Subtype_Mark
;
2185 ----------------------------------------
2186 -- 3.5.1 Enumeration Type Definition --
2187 ----------------------------------------
2189 -- ENUMERATION_TYPE_DEFINITION ::=
2190 -- (ENUMERATION_LITERAL_SPECIFICATION
2191 -- {, ENUMERATION_LITERAL_SPECIFICATION})
2193 -- The caller has already scanned out the TYPE keyword
2195 -- Error recovery: can raise Error_Resync;
2197 function P_Enumeration_Type_Definition
return Node_Id
is
2198 Typedef_Node
: Node_Id
;
2201 Typedef_Node
:= New_Node
(N_Enumeration_Type_Definition
, Token_Ptr
);
2202 Set_Literals
(Typedef_Node
, New_List
);
2207 Append
(P_Enumeration_Literal_Specification
, Literals
(Typedef_Node
));
2208 exit when not Comma_Present
;
2212 return Typedef_Node
;
2213 end P_Enumeration_Type_Definition
;
2215 ----------------------------------------------
2216 -- 3.5.1 Enumeration Literal Specification --
2217 ----------------------------------------------
2219 -- ENUMERATION_LITERAL_SPECIFICATION ::=
2220 -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
2222 -- Error recovery: can raise Error_Resync
2224 function P_Enumeration_Literal_Specification
return Node_Id
is
2226 if Token
= Tok_Char_Literal
then
2227 return P_Defining_Character_Literal
;
2229 return P_Defining_Identifier
(C_Comma_Right_Paren
);
2231 end P_Enumeration_Literal_Specification
;
2233 ---------------------------------------
2234 -- 3.5.1 Defining_Character_Literal --
2235 ---------------------------------------
2237 -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
2239 -- Error recovery: cannot raise Error_Resync
2241 -- The caller has checked that the current token is a character literal
2243 function P_Defining_Character_Literal
return Node_Id
is
2244 Literal_Node
: Node_Id
;
2246 Literal_Node
:= Token_Node
;
2247 Change_Character_Literal_To_Defining_Character_Literal
(Literal_Node
);
2248 Scan
; -- past character literal
2249 return Literal_Node
;
2250 end P_Defining_Character_Literal
;
2252 ------------------------------------
2253 -- 3.5.4 Integer Type Definition --
2254 ------------------------------------
2256 -- Parsed by P_Type_Declaration (3.2.1)
2258 -------------------------------------------
2259 -- 3.5.4 Signed Integer Type Definition --
2260 -------------------------------------------
2262 -- SIGNED_INTEGER_TYPE_DEFINITION ::=
2263 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2265 -- Normally the initial token on entry is RANGE, but in some
2266 -- error conditions, the range token was missing and control is
2267 -- passed with Token pointing to first token of the first expression.
2269 -- Error recovery: cannot raise Error_Resync
2271 function P_Signed_Integer_Type_Definition
return Node_Id
is
2272 Typedef_Node
: Node_Id
;
2273 Expr_Node
: Node_Id
;
2276 Typedef_Node
:= New_Node
(N_Signed_Integer_Type_Definition
, Token_Ptr
);
2278 if Token
= Tok_Range
then
2282 Expr_Node
:= P_Expression
;
2283 Check_Simple_Expression
(Expr_Node
);
2284 Set_Low_Bound
(Typedef_Node
, Expr_Node
);
2286 Expr_Node
:= P_Expression
;
2287 Check_Simple_Expression
(Expr_Node
);
2288 Set_High_Bound
(Typedef_Node
, Expr_Node
);
2289 return Typedef_Node
;
2290 end P_Signed_Integer_Type_Definition
;
2292 ------------------------------------
2293 -- 3.5.4 Modular Type Definition --
2294 ------------------------------------
2296 -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
2298 -- The caller has checked that the initial token is MOD
2300 -- Error recovery: cannot raise Error_Resync
2302 function P_Modular_Type_Definition
return Node_Id
is
2303 Typedef_Node
: Node_Id
;
2306 if Ada_Version
= Ada_83
then
2307 Error_Msg_SC
("(Ada 83): modular types not allowed");
2310 Typedef_Node
:= New_Node
(N_Modular_Type_Definition
, Token_Ptr
);
2312 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
2314 -- Handle mod L..R cleanly
2316 if Token
= Tok_Dot_Dot
then
2317 Error_Msg_SC
("range not allowed for modular type");
2319 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
2322 return Typedef_Node
;
2323 end P_Modular_Type_Definition
;
2325 ---------------------------------
2326 -- 3.5.6 Real Type Definition --
2327 ---------------------------------
2329 -- Parsed by P_Type_Declaration (3.2.1)
2331 --------------------------------------
2332 -- 3.5.7 Floating Point Definition --
2333 --------------------------------------
2335 -- FLOATING_POINT_DEFINITION ::=
2336 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2338 -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
2340 -- The caller has checked that the initial token is DIGITS
2342 -- Error recovery: cannot raise Error_Resync
2344 function P_Floating_Point_Definition
return Node_Id
is
2345 Digits_Loc
: constant Source_Ptr
:= Token_Ptr
;
2347 Expr_Node
: Node_Id
;
2350 Scan
; -- past DIGITS
2351 Expr_Node
:= P_Expression_No_Right_Paren
;
2352 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2354 -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
2356 if Token
= Tok_Delta
then
2357 Error_Msg_SC
-- CODEFIX
2358 ("|DELTA must come before DIGITS");
2359 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Digits_Loc
);
2361 Set_Delta_Expression
(Def_Node
, P_Expression_No_Right_Paren
);
2363 -- OK floating-point definition
2366 Def_Node
:= New_Node
(N_Floating_Point_Definition
, Digits_Loc
);
2369 Set_Digits_Expression
(Def_Node
, Expr_Node
);
2370 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
2372 end P_Floating_Point_Definition
;
2374 -------------------------------------
2375 -- 3.5.7 Real Range Specification --
2376 -------------------------------------
2378 -- REAL_RANGE_SPECIFICATION ::=
2379 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2381 -- Error recovery: cannot raise Error_Resync
2383 function P_Real_Range_Specification_Opt
return Node_Id
is
2384 Specification_Node
: Node_Id
;
2385 Expr_Node
: Node_Id
;
2388 if Token
= Tok_Range
then
2389 Specification_Node
:=
2390 New_Node
(N_Real_Range_Specification
, Token_Ptr
);
2392 Expr_Node
:= P_Expression_No_Right_Paren
;
2393 Check_Simple_Expression
(Expr_Node
);
2394 Set_Low_Bound
(Specification_Node
, Expr_Node
);
2396 Expr_Node
:= P_Expression_No_Right_Paren
;
2397 Check_Simple_Expression
(Expr_Node
);
2398 Set_High_Bound
(Specification_Node
, Expr_Node
);
2399 return Specification_Node
;
2403 end P_Real_Range_Specification_Opt
;
2405 -----------------------------------
2406 -- 3.5.9 Fixed Point Definition --
2407 -----------------------------------
2409 -- FIXED_POINT_DEFINITION ::=
2410 -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
2412 -- ORDINARY_FIXED_POINT_DEFINITION ::=
2413 -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION
2415 -- DECIMAL_FIXED_POINT_DEFINITION ::=
2416 -- delta static_EXPRESSION
2417 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2419 -- The caller has checked that the initial token is DELTA
2421 -- Error recovery: cannot raise Error_Resync
2423 function P_Fixed_Point_Definition
return Node_Id
is
2424 Delta_Node
: Node_Id
;
2425 Delta_Loc
: Source_Ptr
;
2427 Expr_Node
: Node_Id
;
2430 Delta_Loc
:= Token_Ptr
;
2432 Delta_Node
:= P_Expression_No_Right_Paren
;
2433 Check_Simple_Expression_In_Ada_83
(Delta_Node
);
2435 if Token
= Tok_Digits
then
2436 if Ada_Version
= Ada_83
then
2437 Error_Msg_SC
("(Ada 83) decimal fixed type not allowed!");
2440 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Delta_Loc
);
2441 Scan
; -- past DIGITS
2442 Expr_Node
:= P_Expression_No_Right_Paren
;
2443 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2444 Set_Digits_Expression
(Def_Node
, Expr_Node
);
2447 Def_Node
:= New_Node
(N_Ordinary_Fixed_Point_Definition
, Delta_Loc
);
2449 -- Range is required in ordinary fixed point case
2451 if Token
/= Tok_Range
then
2452 Error_Msg_AP
("range must be given for fixed-point type");
2457 Set_Delta_Expression
(Def_Node
, Delta_Node
);
2458 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
2460 end P_Fixed_Point_Definition
;
2462 --------------------------------------------
2463 -- 3.5.9 Ordinary Fixed Point Definition --
2464 --------------------------------------------
2466 -- Parsed by P_Fixed_Point_Definition (3.5.9)
2468 -------------------------------------------
2469 -- 3.5.9 Decimal Fixed Point Definition --
2470 -------------------------------------------
2472 -- Parsed by P_Decimal_Point_Definition (3.5.9)
2474 ------------------------------
2475 -- 3.5.9 Digits Constraint --
2476 ------------------------------
2478 -- DIGITS_CONSTRAINT ::=
2479 -- digits static_EXPRESSION [RANGE_CONSTRAINT]
2481 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2483 -- The caller has checked that the initial token is DIGITS
2485 function P_Digits_Constraint
return Node_Id
is
2486 Constraint_Node
: Node_Id
;
2487 Expr_Node
: Node_Id
;
2490 Constraint_Node
:= New_Node
(N_Digits_Constraint
, Token_Ptr
);
2491 Scan
; -- past DIGITS
2492 Expr_Node
:= P_Expression
;
2493 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2494 Set_Digits_Expression
(Constraint_Node
, Expr_Node
);
2496 if Token
= Tok_Range
then
2497 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
2500 return Constraint_Node
;
2501 end P_Digits_Constraint
;
2503 -----------------------------
2504 -- 3.5.9 Delta Constraint --
2505 -----------------------------
2507 -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
2509 -- Note: this is an obsolescent feature in Ada 95 (I.3)
2511 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2512 -- (also true in formal modes).
2514 -- The caller has checked that the initial token is DELTA
2516 -- Error recovery: cannot raise Error_Resync
2518 function P_Delta_Constraint
return Node_Id
is
2519 Constraint_Node
: Node_Id
;
2520 Expr_Node
: Node_Id
;
2523 Constraint_Node
:= New_Node
(N_Delta_Constraint
, Token_Ptr
);
2525 Expr_Node
:= P_Expression
;
2526 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2528 Set_Delta_Expression
(Constraint_Node
, Expr_Node
);
2530 if Token
= Tok_Range
then
2531 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
2534 return Constraint_Node
;
2535 end P_Delta_Constraint
;
2537 --------------------------------
2538 -- 3.6 Array Type Definition --
2539 --------------------------------
2541 -- ARRAY_TYPE_DEFINITION ::=
2542 -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
2544 -- UNCONSTRAINED_ARRAY_DEFINITION ::=
2545 -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
2546 -- COMPONENT_DEFINITION
2548 -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
2550 -- CONSTRAINED_ARRAY_DEFINITION ::=
2551 -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
2552 -- COMPONENT_DEFINITION
2554 -- DISCRETE_SUBTYPE_DEFINITION ::=
2555 -- DISCRETE_SUBTYPE_INDICATION | RANGE
2557 -- COMPONENT_DEFINITION ::=
2558 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
2560 -- The caller has checked that the initial token is ARRAY
2562 -- Error recovery: can raise Error_Resync
2564 function P_Array_Type_Definition
return Node_Id
is
2565 Array_Loc
: Source_Ptr
;
2566 CompDef_Node
: Node_Id
;
2568 Not_Null_Present
: Boolean := False;
2569 Subs_List
: List_Id
;
2570 Scan_State
: Saved_Scan_State
;
2571 Aliased_Present
: Boolean := False;
2574 Array_Loc
:= Token_Ptr
;
2576 Subs_List
:= New_List
;
2579 -- It's quite tricky to disentangle these two possibilities, so we do
2580 -- a prescan to determine which case we have and then reset the scan.
2581 -- The prescan skips past possible subtype mark tokens.
2583 Save_Scan_State
(Scan_State
); -- just after paren
2585 while Token
in Token_Class_Desig
or else
2586 Token
= Tok_Dot
or else
2587 Token
= Tok_Apostrophe
-- because of 'BASE, 'CLASS
2592 -- If we end up on RANGE <> then we have the unconstrained case. We
2593 -- will also allow the RANGE to be omitted, just to improve error
2594 -- handling for a case like array (integer <>) of integer;
2596 Scan
; -- past possible RANGE or <>
2598 if (Prev_Token
= Tok_Range
and then Token
= Tok_Box
) or else
2599 Prev_Token
= Tok_Box
2601 Def_Node
:= New_Node
(N_Unconstrained_Array_Definition
, Array_Loc
);
2602 Restore_Scan_State
(Scan_State
); -- to first subtype mark
2605 Append
(P_Subtype_Mark_Resync
, Subs_List
);
2608 exit when Token
= Tok_Right_Paren
or else Token
= Tok_Of
;
2612 Set_Subtype_Marks
(Def_Node
, Subs_List
);
2615 Def_Node
:= New_Node
(N_Constrained_Array_Definition
, Array_Loc
);
2616 Restore_Scan_State
(Scan_State
); -- to first discrete range
2619 Append
(P_Discrete_Subtype_Definition
, Subs_List
);
2620 exit when not Comma_Present
;
2623 Set_Discrete_Subtype_Definitions
(Def_Node
, Subs_List
);
2629 CompDef_Node
:= New_Node
(N_Component_Definition
, Token_Ptr
);
2631 if Token_Name
= Name_Aliased
then
2632 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
2635 if Token
= Tok_Aliased
then
2636 Aliased_Present
:= True;
2637 Scan
; -- past ALIASED
2640 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/AI-254)
2642 -- Ada 2005 (AI-230): Access Definition case
2644 if Token
= Tok_Access
then
2645 if Ada_Version
< Ada_2005
then
2647 ("generalized use of anonymous access types " &
2648 "is an Ada 2005 extension");
2649 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
2652 -- AI95-406 makes "aliased" legal (and useless) in this context so
2653 -- followintg code which used to be needed is commented out.
2655 -- if Aliased_Present then
2656 -- Error_Msg_SP ("ALIASED not allowed here");
2659 Set_Subtype_Indication
(CompDef_Node
, Empty
);
2660 Set_Aliased_Present
(CompDef_Node
, False);
2661 Set_Access_Definition
(CompDef_Node
,
2662 P_Access_Definition
(Not_Null_Present
));
2665 Set_Access_Definition
(CompDef_Node
, Empty
);
2666 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
2667 Set_Null_Exclusion_Present
(CompDef_Node
, Not_Null_Present
);
2668 Set_Subtype_Indication
(CompDef_Node
,
2669 P_Subtype_Indication
(Not_Null_Present
));
2672 Set_Component_Definition
(Def_Node
, CompDef_Node
);
2675 end P_Array_Type_Definition
;
2677 -----------------------------------------
2678 -- 3.6 Unconstrained Array Definition --
2679 -----------------------------------------
2681 -- Parsed by P_Array_Type_Definition (3.6)
2683 ---------------------------------------
2684 -- 3.6 Constrained Array Definition --
2685 ---------------------------------------
2687 -- Parsed by P_Array_Type_Definition (3.6)
2689 --------------------------------------
2690 -- 3.6 Discrete Subtype Definition --
2691 --------------------------------------
2693 -- DISCRETE_SUBTYPE_DEFINITION ::=
2694 -- discrete_SUBTYPE_INDICATION | RANGE
2696 -- Note: the discrete subtype definition appearing in a constrained
2697 -- array definition is parsed by P_Array_Type_Definition (3.6)
2699 -- Error recovery: cannot raise Error_Resync
2701 function P_Discrete_Subtype_Definition
return Node_Id
is
2703 -- The syntax of a discrete subtype definition is identical to that
2704 -- of a discrete range, so we simply share the same parsing code.
2706 return P_Discrete_Range
;
2707 end P_Discrete_Subtype_Definition
;
2709 -------------------------------
2710 -- 3.6 Component Definition --
2711 -------------------------------
2713 -- For the array case, parsed by P_Array_Type_Definition (3.6)
2714 -- For the record case, parsed by P_Component_Declaration (3.8)
2716 -----------------------------
2717 -- 3.6.1 Index Constraint --
2718 -----------------------------
2720 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2722 ---------------------------
2723 -- 3.6.1 Discrete Range --
2724 ---------------------------
2726 -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
2728 -- The possible forms for a discrete range are:
2730 -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2)
2731 -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2)
2732 -- Range_Attribute (RANGE, 3.5)
2733 -- Simple_Expression .. Simple_Expression (RANGE, 3.5)
2735 -- Error recovery: cannot raise Error_Resync
2737 function P_Discrete_Range
return Node_Id
is
2738 Expr_Node
: Node_Id
;
2739 Range_Node
: Node_Id
;
2742 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2744 if Expr_Form
= EF_Range_Attr
then
2747 elsif Token
= Tok_Range
then
2748 if Expr_Form
/= EF_Simple_Name
then
2749 Error_Msg_SC
("range must be preceded by subtype mark");
2752 return P_Subtype_Indication
(Expr_Node
);
2754 -- Check Expression .. Expression case
2756 elsif Token
= Tok_Dot_Dot
then
2757 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2758 Set_Low_Bound
(Range_Node
, Expr_Node
);
2760 Expr_Node
:= P_Expression
;
2761 Check_Simple_Expression
(Expr_Node
);
2762 Set_High_Bound
(Range_Node
, Expr_Node
);
2765 -- Otherwise we must have a subtype mark, or an Ada 2012 iterator
2767 elsif Expr_Form
= EF_Simple_Name
then
2770 -- The domain of iteration must be a name. Semantics will determine that
2771 -- the expression has the proper form.
2773 elsif Ada_Version
>= Ada_2012
then
2776 -- If incorrect, complain that we expect ..
2782 end P_Discrete_Range
;
2784 ----------------------------
2785 -- 3.7 Discriminant Part --
2786 ----------------------------
2788 -- DISCRIMINANT_PART ::=
2789 -- UNKNOWN_DISCRIMINANT_PART
2790 -- | KNOWN_DISCRIMINANT_PART
2792 -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
2793 -- or P_Unknown_Discriminant_Part (3.7), since we know which we want.
2795 ------------------------------------
2796 -- 3.7 Unknown Discriminant Part --
2797 ------------------------------------
2799 -- UNKNOWN_DISCRIMINANT_PART ::= (<>)
2801 -- If no unknown discriminant part is present, then False is returned,
2802 -- otherwise the unknown discriminant is scanned out and True is returned.
2804 -- Error recovery: cannot raise Error_Resync
2806 function P_Unknown_Discriminant_Part_Opt
return Boolean is
2807 Scan_State
: Saved_Scan_State
;
2810 -- If <> right now, then this is missing left paren
2812 if Token
= Tok_Box
then
2815 -- If not <> or left paren, then definitely no box
2817 elsif Token
/= Tok_Left_Paren
then
2820 -- Left paren, so might be a box after it
2823 Save_Scan_State
(Scan_State
);
2824 Scan
; -- past the left paren
2826 if Token
/= Tok_Box
then
2827 Restore_Scan_State
(Scan_State
);
2832 -- We are now pointing to the box
2834 if Ada_Version
= Ada_83
then
2835 Error_Msg_SC
("(Ada 83) unknown discriminant not allowed!");
2838 Scan
; -- past the box
2839 U_Right_Paren
; -- must be followed by right paren
2841 end P_Unknown_Discriminant_Part_Opt
;
2843 ----------------------------------
2844 -- 3.7 Known Discriminant Part --
2845 ----------------------------------
2847 -- KNOWN_DISCRIMINANT_PART ::=
2848 -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
2850 -- DISCRIMINANT_SPECIFICATION ::=
2851 -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
2852 -- [:= DEFAULT_EXPRESSION]
2853 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
2854 -- [:= DEFAULT_EXPRESSION]
2856 -- If no known discriminant part is present, then No_List is returned
2858 -- Error recovery: cannot raise Error_Resync
2860 function P_Known_Discriminant_Part_Opt
return List_Id
is
2861 Specification_Node
: Node_Id
;
2862 Specification_List
: List_Id
;
2863 Ident_Sloc
: Source_Ptr
;
2864 Scan_State
: Saved_Scan_State
;
2866 Not_Null_Present
: Boolean;
2869 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
2870 -- This array holds the list of defining identifiers. The upper bound
2871 -- of 4096 is intended to be essentially infinite, and we do not even
2872 -- bother to check for it being exceeded.
2875 if Token
= Tok_Left_Paren
then
2876 Specification_List
:= New_List
;
2878 P_Pragmas_Misplaced
;
2880 Specification_Loop
: loop
2882 Ident_Sloc
:= Token_Ptr
;
2883 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
2886 while Comma_Present
loop
2887 Num_Idents
:= Num_Idents
+ 1;
2888 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
2891 -- If there are multiple identifiers, we repeatedly scan the
2892 -- type and initialization expression information by resetting
2893 -- the scan pointer (so that we get completely separate trees
2894 -- for each occurrence).
2896 if Num_Idents
> 1 then
2897 Save_Scan_State
(Scan_State
);
2902 -- Loop through defining identifiers in list
2906 Specification_Node
:=
2907 New_Node
(N_Discriminant_Specification
, Ident_Sloc
);
2908 Set_Defining_Identifier
(Specification_Node
, Idents
(Ident
));
2909 Not_Null_Present
:= -- Ada 2005 (AI-231, AI-447)
2910 P_Null_Exclusion
(Allow_Anonymous_In_95
=> True);
2912 if Token
= Tok_Access
then
2913 if Ada_Version
= Ada_83
then
2915 ("(Ada 83) access discriminant not allowed!");
2918 Set_Discriminant_Type
2919 (Specification_Node
,
2920 P_Access_Definition
(Not_Null_Present
));
2923 Set_Discriminant_Type
2924 (Specification_Node
, P_Subtype_Mark
);
2926 Set_Null_Exclusion_Present
-- Ada 2005 (AI-231)
2927 (Specification_Node
, Not_Null_Present
);
2931 (Specification_Node
, Init_Expr_Opt
(True));
2934 Set_Prev_Ids
(Specification_Node
, True);
2937 if Ident
< Num_Idents
then
2938 Set_More_Ids
(Specification_Node
, True);
2941 Append
(Specification_Node
, Specification_List
);
2942 exit Ident_Loop
when Ident
= Num_Idents
;
2944 Restore_Scan_State
(Scan_State
);
2946 end loop Ident_Loop
;
2948 exit Specification_Loop
when Token
/= Tok_Semicolon
;
2950 P_Pragmas_Misplaced
;
2951 end loop Specification_Loop
;
2954 return Specification_List
;
2959 end P_Known_Discriminant_Part_Opt
;
2961 -------------------------------------
2962 -- 3.7 Discriminant Specification --
2963 -------------------------------------
2965 -- Parsed by P_Known_Discriminant_Part_Opt (3.7)
2967 -----------------------------
2968 -- 3.7 Default Expression --
2969 -----------------------------
2971 -- Always parsed (simply as an Expression) by the parent construct
2973 ------------------------------------
2974 -- 3.7.1 Discriminant Constraint --
2975 ------------------------------------
2977 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2979 --------------------------------------------------------
2980 -- 3.7.1 Index or Discriminant Constraint (also 3.6) --
2981 --------------------------------------------------------
2983 -- DISCRIMINANT_CONSTRAINT ::=
2984 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
2986 -- DISCRIMINANT_ASSOCIATION ::=
2987 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2990 -- This routine parses either an index or a discriminant constraint. As
2991 -- is clear from the above grammar, it is often possible to clearly
2992 -- determine which of the two possibilities we have, but there are
2993 -- cases (those in which we have a series of expressions of the same
2994 -- syntactic form as subtype indications), where we cannot tell. Since
2995 -- this means that in any case the semantic phase has to distinguish
2996 -- between the two, there is not much point in the parser trying to
2997 -- distinguish even those cases where the difference is clear. In any
2998 -- case, if we have a situation like:
3000 -- (A => 123, 235 .. 500)
3002 -- it is not clear which of the two items is the wrong one, better to
3003 -- let the semantic phase give a clear message. Consequently, this
3004 -- routine in general returns a list of items which can be either
3005 -- discrete ranges or discriminant associations.
3007 -- The caller has checked that the initial token is a left paren
3009 -- Error recovery: can raise Error_Resync
3011 function P_Index_Or_Discriminant_Constraint
return Node_Id
is
3012 Scan_State
: Saved_Scan_State
;
3013 Constr_Node
: Node_Id
;
3014 Constr_List
: List_Id
;
3015 Expr_Node
: Node_Id
;
3016 Result_Node
: Node_Id
;
3019 Result_Node
:= New_Node
(N_Index_Or_Discriminant_Constraint
, Token_Ptr
);
3021 Constr_List
:= New_List
;
3022 Set_Constraints
(Result_Node
, Constr_List
);
3024 -- The two syntactic forms are a little mixed up, so what we are doing
3025 -- here is looking at the first entry to determine which case we have
3027 -- A discriminant constraint is a list of discriminant associations,
3028 -- which have one of the following possible forms:
3032 -- Id | Id | .. | Id => Expression
3034 -- An index constraint is a list of discrete ranges which have one
3035 -- of the following possible forms:
3038 -- Subtype_Mark range Range
3040 -- Simple_Expression .. Simple_Expression
3042 -- Loop through discriminants in list
3045 -- Check cases of Id => Expression or Id | Id => Expression
3047 if Token
= Tok_Identifier
then
3048 Save_Scan_State
(Scan_State
); -- at Id
3051 if Token
= Tok_Arrow
or else Token
= Tok_Vertical_Bar
then
3052 Restore_Scan_State
(Scan_State
); -- to Id
3053 Append
(P_Discriminant_Association
, Constr_List
);
3056 Restore_Scan_State
(Scan_State
); -- to Id
3060 -- Otherwise scan out an expression and see what we have got
3062 Expr_Node
:= P_Expression_Or_Range_Attribute
;
3064 if Expr_Form
= EF_Range_Attr
then
3065 Append
(Expr_Node
, Constr_List
);
3067 elsif Token
= Tok_Range
then
3068 if Expr_Form
/= EF_Simple_Name
then
3069 Error_Msg_SC
("subtype mark required before RANGE");
3072 Append
(P_Subtype_Indication
(Expr_Node
), Constr_List
);
3075 -- Check Simple_Expression .. Simple_Expression case
3077 elsif Token
= Tok_Dot_Dot
then
3078 Check_Simple_Expression
(Expr_Node
);
3079 Constr_Node
:= New_Node
(N_Range
, Token_Ptr
);
3080 Set_Low_Bound
(Constr_Node
, Expr_Node
);
3082 Expr_Node
:= P_Expression
;
3083 Check_Simple_Expression
(Expr_Node
);
3084 Set_High_Bound
(Constr_Node
, Expr_Node
);
3085 Append
(Constr_Node
, Constr_List
);
3088 -- Case of an expression which could be either form
3091 Append
(Expr_Node
, Constr_List
);
3095 -- Here with a single entry scanned
3098 exit when not Comma_Present
;
3104 end P_Index_Or_Discriminant_Constraint
;
3106 -------------------------------------
3107 -- 3.7.1 Discriminant Association --
3108 -------------------------------------
3110 -- DISCRIMINANT_ASSOCIATION ::=
3111 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
3114 -- This routine is used only when the name list is present and the caller
3115 -- has already checked this (by scanning ahead and repositioning the
3118 -- Error_Recovery: cannot raise Error_Resync;
3120 function P_Discriminant_Association
return Node_Id
is
3121 Discr_Node
: Node_Id
;
3122 Names_List
: List_Id
;
3123 Ident_Sloc
: Source_Ptr
;
3126 Ident_Sloc
:= Token_Ptr
;
3127 Names_List
:= New_List
;
3130 Append
(P_Identifier
(C_Vertical_Bar_Arrow
), Names_List
);
3131 exit when Token
/= Tok_Vertical_Bar
;
3135 Discr_Node
:= New_Node
(N_Discriminant_Association
, Ident_Sloc
);
3136 Set_Selector_Names
(Discr_Node
, Names_List
);
3138 Set_Expression
(Discr_Node
, P_Expression
);
3140 end P_Discriminant_Association
;
3142 ---------------------------------
3143 -- 3.8 Record Type Definition --
3144 ---------------------------------
3146 -- RECORD_TYPE_DEFINITION ::=
3147 -- [[abstract] tagged] [limited] RECORD_DEFINITION
3149 -- There is no node in the tree for a record type definition. Instead
3150 -- a record definition node appears, with possible Abstract_Present,
3151 -- Tagged_Present, and Limited_Present flags set appropriately.
3153 ----------------------------
3154 -- 3.8 Record Definition --
3155 ----------------------------
3157 -- RECORD_DEFINITION ::=
3163 -- Note: in the case where a record definition node is used to represent
3164 -- a record type definition, the caller sets the Tagged_Present and
3165 -- Limited_Present flags in the resulting N_Record_Definition node as
3168 -- Note that the RECORD token at the start may be missing in certain
3169 -- error situations, so this function is expected to post the error
3171 -- Error recovery: can raise Error_Resync
3173 function P_Record_Definition
return Node_Id
is
3177 Rec_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
3181 if Token
= Tok_Null
then
3184 Set_Null_Present
(Rec_Node
, True);
3186 -- Catch incomplete declaration to prevent cascaded errors, see
3187 -- ACATS B393002 for an example.
3189 elsif Token
= Tok_Semicolon
then
3190 Error_Msg_AP
("missing record definition");
3192 -- Case starting with RECORD keyword. Build scope stack entry. For the
3193 -- column, we use the first non-blank character on the line, to deal
3194 -- with situations such as:
3200 -- which is not official RM indentation, but is not uncommon usage, and
3201 -- in particular is standard GNAT coding style, so handle it nicely.
3205 Scope
.Table
(Scope
.Last
).Etyp
:= E_Record
;
3206 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
3207 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
3208 Scope
.Table
(Scope
.Last
).Labl
:= Error
;
3209 Scope
.Table
(Scope
.Last
).Junk
:= (Token
/= Tok_Record
);
3213 Set_Component_List
(Rec_Node
, P_Component_List
);
3216 exit when Check_End
;
3217 Discard_Junk_Node
(P_Component_List
);
3222 end P_Record_Definition
;
3224 -------------------------
3225 -- 3.8 Component List --
3226 -------------------------
3228 -- COMPONENT_LIST ::=
3229 -- COMPONENT_ITEM {COMPONENT_ITEM}
3230 -- | {COMPONENT_ITEM} VARIANT_PART
3233 -- Error recovery: cannot raise Error_Resync
3235 function P_Component_List
return Node_Id
is
3236 Component_List_Node
: Node_Id
;
3237 Decls_List
: List_Id
;
3238 Scan_State
: Saved_Scan_State
;
3241 Component_List_Node
:= New_Node
(N_Component_List
, Token_Ptr
);
3242 Decls_List
:= New_List
;
3244 if Token
= Tok_Null
then
3247 P_Pragmas_Opt
(Decls_List
);
3248 Set_Null_Present
(Component_List_Node
, True);
3249 return Component_List_Node
;
3252 P_Pragmas_Opt
(Decls_List
);
3254 if Token
/= Tok_Case
then
3255 Component_Scan_Loop
: loop
3256 P_Component_Items
(Decls_List
);
3257 P_Pragmas_Opt
(Decls_List
);
3259 exit Component_Scan_Loop
when Token
= Tok_End
3260 or else Token
= Tok_Case
3261 or else Token
= Tok_When
;
3263 -- We are done if we do not have an identifier. However, if
3264 -- we have a misspelled reserved identifier that is in a column
3265 -- to the right of the record definition, we will treat it as
3266 -- an identifier. It turns out to be too dangerous in practice
3267 -- to accept such a mis-spelled identifier which does not have
3268 -- this additional clue that confirms the incorrect spelling.
3270 if Token
/= Tok_Identifier
then
3271 if Start_Column
> Scope
.Table
(Scope
.Last
).Ecol
3272 and then Is_Reserved_Identifier
3274 Save_Scan_State
(Scan_State
); -- at reserved id
3275 Scan
; -- possible reserved id
3277 if Token
= Tok_Comma
or else Token
= Tok_Colon
then
3278 Restore_Scan_State
(Scan_State
);
3279 Scan_Reserved_Identifier
(Force_Msg
=> True);
3281 -- Note reserved identifier used as field name after
3282 -- all because not followed by colon or comma
3285 Restore_Scan_State
(Scan_State
);
3286 exit Component_Scan_Loop
;
3289 -- Non-identifier that definitely was not reserved id
3292 exit Component_Scan_Loop
;
3295 end loop Component_Scan_Loop
;
3298 if Token
= Tok_Case
then
3299 Set_Variant_Part
(Component_List_Node
, P_Variant_Part
);
3301 -- Check for junk after variant part
3303 if Token
= Tok_Identifier
then
3304 Save_Scan_State
(Scan_State
);
3305 Scan
; -- past identifier
3307 if Token
= Tok_Colon
then
3308 Restore_Scan_State
(Scan_State
);
3309 Error_Msg_SC
("component may not follow variant part");
3310 Discard_Junk_Node
(P_Component_List
);
3312 elsif Token
= Tok_Case
then
3313 Restore_Scan_State
(Scan_State
);
3314 Error_Msg_SC
("only one variant part allowed in a record");
3315 Discard_Junk_Node
(P_Component_List
);
3318 Restore_Scan_State
(Scan_State
);
3324 Set_Component_Items
(Component_List_Node
, Decls_List
);
3325 return Component_List_Node
;
3326 end P_Component_List
;
3328 -------------------------
3329 -- 3.8 Component Item --
3330 -------------------------
3332 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
3334 -- COMPONENT_DECLARATION ::=
3335 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
3336 -- [:= DEFAULT_EXPRESSION]
3337 -- [ASPECT_SPECIFICATIONS];
3339 -- COMPONENT_DEFINITION ::=
3340 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
3342 -- Error recovery: cannot raise Error_Resync, if an error occurs,
3343 -- the scan is positioned past the following semicolon.
3345 -- Note: we do not yet allow representation clauses to appear as component
3346 -- items, do we need to add this capability sometime in the future ???
3348 procedure P_Component_Items
(Decls
: List_Id
) is
3349 Aliased_Present
: Boolean := False;
3350 CompDef_Node
: Node_Id
;
3351 Decl_Node
: Node_Id
;
3352 Scan_State
: Saved_Scan_State
;
3353 Not_Null_Present
: Boolean := False;
3356 Ident_Sloc
: Source_Ptr
;
3358 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
3359 -- This array holds the list of defining identifiers. The upper bound
3360 -- of 4096 is intended to be essentially infinite, and we do not even
3361 -- bother to check for it being exceeded.
3364 if Token
/= Tok_Identifier
then
3365 Error_Msg_SC
("component declaration expected");
3366 Resync_Past_Semicolon
;
3370 Ident_Sloc
:= Token_Ptr
;
3371 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
3374 while Comma_Present
loop
3375 Num_Idents
:= Num_Idents
+ 1;
3376 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
3379 -- If there are multiple identifiers, we repeatedly scan the
3380 -- type and initialization expression information by resetting
3381 -- the scan pointer (so that we get completely separate trees
3382 -- for each occurrence).
3384 if Num_Idents
> 1 then
3385 Save_Scan_State
(Scan_State
);
3390 -- Loop through defining identifiers in list
3395 -- The following block is present to catch Error_Resync
3396 -- which causes the parse to be reset past the semicolon
3399 Decl_Node
:= New_Node
(N_Component_Declaration
, Ident_Sloc
);
3400 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
3402 if Token
= Tok_Constant
then
3403 Error_Msg_SC
("constant components are not permitted");
3407 CompDef_Node
:= New_Node
(N_Component_Definition
, Token_Ptr
);
3409 if Token_Name
= Name_Aliased
then
3410 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
3413 if Token
= Tok_Aliased
then
3414 Aliased_Present
:= True;
3415 Scan
; -- past ALIASED
3418 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/AI-254)
3420 -- Ada 2005 (AI-230): Access Definition case
3422 if Token
= Tok_Access
then
3423 if Ada_Version
< Ada_2005
then
3425 ("generalized use of anonymous access types " &
3426 "is an Ada 2005 extension");
3427 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
3430 -- AI95-406 makes "aliased" legal (and useless) here, so the
3431 -- following code which used to be required is commented out.
3433 -- if Aliased_Present then
3434 -- Error_Msg_SP ("ALIASED not allowed here");
3437 Set_Subtype_Indication
(CompDef_Node
, Empty
);
3438 Set_Aliased_Present
(CompDef_Node
, False);
3439 Set_Access_Definition
(CompDef_Node
,
3440 P_Access_Definition
(Not_Null_Present
));
3443 Set_Access_Definition
(CompDef_Node
, Empty
);
3444 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
3445 Set_Null_Exclusion_Present
(CompDef_Node
, Not_Null_Present
);
3447 if Token
= Tok_Array
then
3448 Error_Msg_SC
("anonymous arrays not allowed as components");
3452 Set_Subtype_Indication
(CompDef_Node
,
3453 P_Subtype_Indication
(Not_Null_Present
));
3456 Set_Component_Definition
(Decl_Node
, CompDef_Node
);
3457 Set_Expression
(Decl_Node
, Init_Expr_Opt
);
3460 Set_Prev_Ids
(Decl_Node
, True);
3463 if Ident
< Num_Idents
then
3464 Set_More_Ids
(Decl_Node
, True);
3467 Append
(Decl_Node
, Decls
);
3470 when Error_Resync
=>
3471 if Token
/= Tok_End
then
3472 Resync_Past_Semicolon
;
3476 exit Ident_Loop
when Ident
= Num_Idents
;
3478 Restore_Scan_State
(Scan_State
);
3480 end loop Ident_Loop
;
3482 P_Aspect_Specifications
(Decl_Node
);
3483 end P_Component_Items
;
3485 --------------------------------
3486 -- 3.8 Component Declaration --
3487 --------------------------------
3489 -- Parsed by P_Component_Items (3.8)
3491 -------------------------
3492 -- 3.8.1 Variant Part --
3493 -------------------------
3496 -- case discriminant_DIRECT_NAME is
3501 -- The caller has checked that the initial token is CASE
3503 -- Error recovery: cannot raise Error_Resync
3505 function P_Variant_Part
return Node_Id
is
3506 Variant_Part_Node
: Node_Id
;
3507 Variants_List
: List_Id
;
3508 Case_Node
: Node_Id
;
3511 Variant_Part_Node
:= New_Node
(N_Variant_Part
, Token_Ptr
);
3513 Scope
.Table
(Scope
.Last
).Etyp
:= E_Case
;
3514 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
3515 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
3518 Case_Node
:= P_Expression
;
3519 Set_Name
(Variant_Part_Node
, Case_Node
);
3521 if Nkind
(Case_Node
) /= N_Identifier
then
3522 Set_Name
(Variant_Part_Node
, Error
);
3523 Error_Msg
("discriminant name expected", Sloc
(Case_Node
));
3525 elsif Paren_Count
(Case_Node
) /= 0 then
3527 ("|discriminant name may not be parenthesized",
3529 Set_Paren_Count
(Case_Node
, 0);
3533 Variants_List
:= New_List
;
3534 P_Pragmas_Opt
(Variants_List
);
3536 -- Test missing variant
3538 if Token
= Tok_End
then
3539 Error_Msg_BC
("WHEN expected (must have at least one variant)");
3541 Append
(P_Variant
, Variants_List
);
3544 -- Loop through variants, note that we allow if in place of when,
3545 -- this error will be detected and handled in P_Variant.
3548 P_Pragmas_Opt
(Variants_List
);
3550 if Token
/= Tok_When
3551 and then Token
/= Tok_If
3552 and then Token
/= Tok_Others
3554 exit when Check_End
;
3557 Append
(P_Variant
, Variants_List
);
3560 Set_Variants
(Variant_Part_Node
, Variants_List
);
3561 return Variant_Part_Node
;
3564 --------------------
3566 --------------------
3569 -- when DISCRETE_CHOICE_LIST =>
3572 -- Error recovery: cannot raise Error_Resync
3574 -- The initial token on entry is either WHEN, IF or OTHERS
3576 function P_Variant
return Node_Id
is
3577 Variant_Node
: Node_Id
;
3580 -- Special check to recover nicely from use of IF in place of WHEN
3582 if Token
= Tok_If
then
3589 Variant_Node
:= New_Node
(N_Variant
, Prev_Token_Ptr
);
3590 Set_Discrete_Choices
(Variant_Node
, P_Discrete_Choice_List
);
3592 Set_Component_List
(Variant_Node
, P_Component_List
);
3593 return Variant_Node
;
3596 ---------------------------------
3597 -- 3.8.1 Discrete Choice List --
3598 ---------------------------------
3600 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
3602 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
3604 -- Note: in Ada 83, the expression must be a simple expression
3606 -- Error recovery: cannot raise Error_Resync
3608 function P_Discrete_Choice_List
return List_Id
is
3610 Expr_Node
: Node_Id
;
3611 Choice_Node
: Node_Id
;
3614 Choices
:= New_List
;
3616 if Token
= Tok_Others
then
3617 Append
(New_Node
(N_Others_Choice
, Token_Ptr
), Choices
);
3618 Scan
; -- past OTHERS
3622 -- Scan out expression or range attribute
3624 Expr_Node
:= P_Expression_Or_Range_Attribute
;
3625 Ignore
(Tok_Right_Paren
);
3627 if Token
= Tok_Colon
3628 and then Nkind
(Expr_Node
) = N_Identifier
3630 Error_Msg_SP
("label not permitted in this context");
3635 elsif Expr_Form
= EF_Range_Attr
then
3636 Append
(Expr_Node
, Choices
);
3640 elsif Token
= Tok_Dot_Dot
then
3641 Check_Simple_Expression
(Expr_Node
);
3642 Choice_Node
:= New_Node
(N_Range
, Token_Ptr
);
3643 Set_Low_Bound
(Choice_Node
, Expr_Node
);
3645 Expr_Node
:= P_Expression_No_Right_Paren
;
3646 Check_Simple_Expression
(Expr_Node
);
3647 Set_High_Bound
(Choice_Node
, Expr_Node
);
3648 Append
(Choice_Node
, Choices
);
3650 -- Simple name, must be subtype, so range allowed
3652 elsif Expr_Form
= EF_Simple_Name
then
3653 if Token
= Tok_Range
then
3654 Append
(P_Subtype_Indication
(Expr_Node
), Choices
);
3656 elsif Token
in Token_Class_Consk
then
3658 ("the only constraint allowed here " &
3659 "is a range constraint");
3660 Discard_Junk_Node
(P_Constraint_Opt
);
3661 Append
(Expr_Node
, Choices
);
3664 Append
(Expr_Node
, Choices
);
3670 -- In Ada 2012 mode, the expression must be a simple
3671 -- expression. The reason for this restriction (i.e. going
3672 -- back to the Ada 83 rule) is to avoid ambiguities when set
3673 -- membership operations are allowed, consider the
3676 -- when A in 1 .. 10 | 12 =>
3678 -- This is ambiguous without parentheses, so we require one
3679 -- of the following two parenthesized forms to disambiguate:
3681 -- one of the following:
3683 -- when (A in 1 .. 10 | 12) =>
3684 -- when (A in 1 .. 10) | 12 =>
3686 -- To solve this, in Ada 2012 mode, we disallow the use of
3687 -- membership operations in expressions in choices.
3689 -- Technically in the grammar, the expression must match the
3690 -- grammar for restricted expression.
3692 if Ada_Version
>= Ada_2012
then
3693 Check_Restricted_Expression
(Expr_Node
);
3695 -- In Ada 83 mode, the syntax required a simple expression
3698 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
3701 Append
(Expr_Node
, Choices
);
3705 when Error_Resync
=>
3711 if Token
= Tok_Comma
then
3714 if Token
= Tok_Vertical_Bar
then
3715 Error_Msg_SP
-- CODEFIX
3716 ("|extra "","" ignored");
3720 Error_Msg_SP
-- CODEFIX
3721 (""","" should be ""'|""");
3725 exit when Token
/= Tok_Vertical_Bar
;
3732 end P_Discrete_Choice_List
;
3734 ----------------------------
3735 -- 3.8.1 Discrete Choice --
3736 ----------------------------
3738 -- Parsed by P_Discrete_Choice_List (3.8.1)
3740 ----------------------------------
3741 -- 3.9.1 Record Extension Part --
3742 ----------------------------------
3744 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
3746 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
3748 --------------------------------------
3749 -- 3.9.4 Interface Type Definition --
3750 --------------------------------------
3752 -- INTERFACE_TYPE_DEFINITION ::=
3753 -- [limited | task | protected | synchronized] interface
3754 -- [and INTERFACE_LIST]
3756 -- Error recovery: cannot raise Error_Resync
3758 function P_Interface_Type_Definition
3759 (Abstract_Present
: Boolean) return Node_Id
3761 Typedef_Node
: Node_Id
;
3764 if Ada_Version
< Ada_2005
then
3765 Error_Msg_SP
("abstract interface is an Ada 2005 extension");
3766 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
3769 if Abstract_Present
then
3771 ("ABSTRACT not allowed in interface type definition " &
3775 Scan
; -- past INTERFACE
3777 -- Ada 2005 (AI-345): In case of interfaces with a null list of
3778 -- interfaces we build a record_definition node.
3780 if Token
= Tok_Semicolon
or else Aspect_Specifications_Present
then
3781 Typedef_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
3783 Set_Abstract_Present
(Typedef_Node
);
3784 Set_Tagged_Present
(Typedef_Node
);
3785 Set_Null_Present
(Typedef_Node
);
3786 Set_Interface_Present
(Typedef_Node
);
3788 -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have
3789 -- a list of interfaces we build a derived_type_definition node. This
3790 -- simplifies the semantic analysis (and hence further maintenance)
3793 if Token
/= Tok_And
then
3794 Error_Msg_AP
("AND expected");
3799 Typedef_Node
:= New_Node
(N_Derived_Type_Definition
, Token_Ptr
);
3801 Set_Abstract_Present
(Typedef_Node
);
3802 Set_Interface_Present
(Typedef_Node
);
3803 Set_Subtype_Indication
(Typedef_Node
, P_Qualified_Simple_Name
);
3805 Set_Record_Extension_Part
(Typedef_Node
,
3806 New_Node
(N_Record_Definition
, Token_Ptr
));
3807 Set_Null_Present
(Record_Extension_Part
(Typedef_Node
));
3809 if Token
= Tok_And
then
3810 Set_Interface_List
(Typedef_Node
, New_List
);
3814 Append
(P_Qualified_Simple_Name
,
3815 Interface_List
(Typedef_Node
));
3816 exit when Token
/= Tok_And
;
3822 return Typedef_Node
;
3823 end P_Interface_Type_Definition
;
3825 ----------------------------------
3826 -- 3.10 Access Type Definition --
3827 ----------------------------------
3829 -- ACCESS_TYPE_DEFINITION ::=
3830 -- ACCESS_TO_OBJECT_DEFINITION
3831 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3833 -- ACCESS_TO_OBJECT_DEFINITION ::=
3834 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
3836 -- GENERAL_ACCESS_MODIFIER ::= all | constant
3838 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3839 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3840 -- | [NULL_EXCLUSION] access [protected] function
3841 -- PARAMETER_AND_RESULT_PROFILE
3843 -- PARAMETER_PROFILE ::= [FORMAL_PART]
3845 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
3847 -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already
3848 -- parsed the null_exclusion part and has also removed the ACCESS token;
3849 -- otherwise the caller has just checked that the initial token is ACCESS
3851 -- Error recovery: can raise Error_Resync
3853 function P_Access_Type_Definition
3854 (Header_Already_Parsed
: Boolean := False) return Node_Id
3856 Access_Loc
: constant Source_Ptr
:= Token_Ptr
;
3857 Prot_Flag
: Boolean;
3858 Not_Null_Present
: Boolean := False;
3859 Type_Def_Node
: Node_Id
;
3860 Result_Not_Null
: Boolean;
3861 Result_Node
: Node_Id
;
3863 procedure Check_Junk_Subprogram_Name
;
3864 -- Used in access to subprogram definition cases to check for an
3865 -- identifier or operator symbol that does not belong.
3867 --------------------------------
3868 -- Check_Junk_Subprogram_Name --
3869 --------------------------------
3871 procedure Check_Junk_Subprogram_Name
is
3872 Saved_State
: Saved_Scan_State
;
3875 if Token
= Tok_Identifier
or else Token
= Tok_Operator_Symbol
then
3876 Save_Scan_State
(Saved_State
);
3877 Scan
; -- past possible junk subprogram name
3879 if Token
= Tok_Left_Paren
or else Token
= Tok_Semicolon
then
3880 Error_Msg_SP
("unexpected subprogram name ignored");
3884 Restore_Scan_State
(Saved_State
);
3887 end Check_Junk_Subprogram_Name
;
3889 -- Start of processing for P_Access_Type_Definition
3892 if not Header_Already_Parsed
then
3893 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
3894 Scan
; -- past ACCESS
3897 if Token_Name
= Name_Protected
then
3898 Check_95_Keyword
(Tok_Protected
, Tok_Procedure
);
3899 Check_95_Keyword
(Tok_Protected
, Tok_Function
);
3902 Prot_Flag
:= (Token
= Tok_Protected
);
3905 Scan
; -- past PROTECTED
3907 if Token
/= Tok_Procedure
and then Token
/= Tok_Function
then
3908 Error_Msg_SC
-- CODEFIX
3909 ("FUNCTION or PROCEDURE expected");
3913 if Token
= Tok_Procedure
then
3914 if Ada_Version
= Ada_83
then
3915 Error_Msg_SC
("(Ada 83) access to procedure not allowed!");
3918 Type_Def_Node
:= New_Node
(N_Access_Procedure_Definition
, Access_Loc
);
3919 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3920 Scan
; -- past PROCEDURE
3921 Check_Junk_Subprogram_Name
;
3922 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
3923 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
3925 elsif Token
= Tok_Function
then
3926 if Ada_Version
= Ada_83
then
3927 Error_Msg_SC
("(Ada 83) access to function not allowed!");
3930 Type_Def_Node
:= New_Node
(N_Access_Function_Definition
, Access_Loc
);
3931 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3932 Scan
; -- past FUNCTION
3933 Check_Junk_Subprogram_Name
;
3934 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
3935 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
3938 Result_Not_Null
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
3940 -- Ada 2005 (AI-318-02)
3942 if Token
= Tok_Access
then
3943 if Ada_Version
< Ada_2005
then
3945 ("anonymous access result type is an Ada 2005 extension");
3946 Error_Msg_SC
("\unit must be compiled with -gnat05 switch");
3949 Result_Node
:= P_Access_Definition
(Result_Not_Null
);
3952 Result_Node
:= P_Subtype_Mark
;
3955 -- A null exclusion on the result type must be recorded in a flag
3956 -- distinct from the one used for the access-to-subprogram type's
3959 Set_Null_Exclusion_In_Return_Present
3960 (Type_Def_Node
, Result_Not_Null
);
3963 Set_Result_Definition
(Type_Def_Node
, Result_Node
);
3967 New_Node
(N_Access_To_Object_Definition
, Access_Loc
);
3968 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3970 if Token
= Tok_All
or else Token
= Tok_Constant
then
3971 if Ada_Version
= Ada_83
then
3972 Error_Msg_SC
("(Ada 83) access modifier not allowed!");
3975 if Token
= Tok_All
then
3976 Set_All_Present
(Type_Def_Node
, True);
3979 Set_Constant_Present
(Type_Def_Node
, True);
3982 Scan
; -- past ALL or CONSTANT
3985 Set_Subtype_Indication
(Type_Def_Node
,
3986 P_Subtype_Indication
(Not_Null_Present
));
3989 return Type_Def_Node
;
3990 end P_Access_Type_Definition
;
3992 ---------------------------------------
3993 -- 3.10 Access To Object Definition --
3994 ---------------------------------------
3996 -- Parsed by P_Access_Type_Definition (3.10)
3998 -----------------------------------
3999 -- 3.10 General Access Modifier --
4000 -----------------------------------
4002 -- Parsed by P_Access_Type_Definition (3.10)
4004 -------------------------------------------
4005 -- 3.10 Access To Subprogram Definition --
4006 -------------------------------------------
4008 -- Parsed by P_Access_Type_Definition (3.10)
4010 -----------------------------
4011 -- 3.10 Access Definition --
4012 -----------------------------
4014 -- ACCESS_DEFINITION ::=
4015 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
4016 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
4018 -- ACCESS_TO_SUBPROGRAM_DEFINITION
4019 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
4020 -- | [NULL_EXCLUSION] access [protected] function
4021 -- PARAMETER_AND_RESULT_PROFILE
4023 -- The caller has parsed the null-exclusion part and it has also checked
4024 -- that the next token is ACCESS
4026 -- Error recovery: cannot raise Error_Resync
4028 function P_Access_Definition
4029 (Null_Exclusion_Present
: Boolean) return Node_Id
4032 Subp_Node
: Node_Id
;
4035 Def_Node
:= New_Node
(N_Access_Definition
, Token_Ptr
);
4036 Scan
; -- past ACCESS
4038 -- Ada 2005 (AI-254): Access_To_Subprogram_Definition
4040 if Token
= Tok_Protected
4041 or else Token
= Tok_Procedure
4042 or else Token
= Tok_Function
4044 if Ada_Version
< Ada_2005
then
4045 Error_Msg_SP
("access-to-subprogram is an Ada 2005 extension");
4046 Error_Msg_SP
("\unit should be compiled with -gnat05 switch");
4049 Subp_Node
:= P_Access_Type_Definition
(Header_Already_Parsed
=> True);
4050 Set_Null_Exclusion_Present
(Subp_Node
, Null_Exclusion_Present
);
4051 Set_Access_To_Subprogram_Definition
(Def_Node
, Subp_Node
);
4053 -- Ada 2005 (AI-231)
4054 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
4057 Set_Null_Exclusion_Present
(Def_Node
, Null_Exclusion_Present
);
4059 if Token
= Tok_All
then
4060 if Ada_Version
< Ada_2005
then
4062 ("ALL is not permitted for anonymous access types");
4066 Set_All_Present
(Def_Node
);
4068 elsif Token
= Tok_Constant
then
4069 if Ada_Version
< Ada_2005
then
4070 Error_Msg_SP
("access-to-constant is an Ada 2005 extension");
4071 Error_Msg_SP
("\unit should be compiled with -gnat05 switch");
4074 Scan
; -- past CONSTANT
4075 Set_Constant_Present
(Def_Node
);
4078 Set_Subtype_Mark
(Def_Node
, P_Subtype_Mark
);
4083 end P_Access_Definition
;
4085 -----------------------------------------
4086 -- 3.10.1 Incomplete Type Declaration --
4087 -----------------------------------------
4089 -- Parsed by P_Type_Declaration (3.2.1)
4091 ----------------------------
4092 -- 3.11 Declarative Part --
4093 ----------------------------
4095 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
4097 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items
4098 -- handles errors, and returns cleanly after an error has occurred)
4100 function P_Declarative_Part
return List_Id
is
4105 -- Indicate no bad declarations detected yet. This will be reset by
4106 -- P_Declarative_Items if a bad declaration is discovered.
4108 Missing_Begin_Msg
:= No_Error_Msg
;
4110 -- Get rid of active SIS entry from outer scope. This means we will
4111 -- miss some nested cases, but it doesn't seem worth the effort. See
4112 -- discussion in Par for further details
4114 SIS_Entry_Active
:= False;
4117 -- Loop to scan out the declarations
4120 P_Declarative_Items
(Decls
, Done
, In_Spec
=> False);
4124 -- Get rid of active SIS entry which is left set only if we scanned a
4125 -- procedure declaration and have not found the body. We could give
4126 -- an error message, but that really would be usurping the role of
4127 -- semantic analysis (this really is a missing body case).
4129 SIS_Entry_Active
:= False;
4131 end P_Declarative_Part
;
4133 ----------------------------
4134 -- 3.11 Declarative Item --
4135 ----------------------------
4137 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
4139 -- Can return Error if a junk declaration is found, or Empty if no
4140 -- declaration is found (i.e. a token ending declarations, such as
4141 -- BEGIN or END is encountered).
4143 -- Error recovery: cannot raise Error_Resync. If an error resync occurs,
4144 -- then the scan is set past the next semicolon and Error is returned.
4146 procedure P_Declarative_Items
4151 Scan_State
: Saved_Scan_State
;
4155 Style
.Check_Indentation
;
4160 when Tok_Function
=>
4162 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4168 -- Check for loop (premature statement)
4170 Save_Scan_State
(Scan_State
);
4173 if Token
= Tok_Identifier
then
4174 Scan
; -- past identifier
4176 if Token
= Tok_In
then
4177 Restore_Scan_State
(Scan_State
);
4178 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4183 -- Not a loop, so must be rep clause
4185 Restore_Scan_State
(Scan_State
);
4186 Append
(P_Representation_Clause
, Decls
);
4191 Append
(P_Generic
, Decls
);
4194 when Tok_Identifier
=>
4197 -- Special check for misuse of overriding not in Ada 2005 mode
4199 if Token_Name
= Name_Overriding
4200 and then not Next_Token_Is
(Tok_Colon
)
4202 Error_Msg_SC
("overriding indicator is an Ada 2005 extension");
4203 Error_Msg_SC
("\unit must be compiled with -gnat05 switch");
4205 Token
:= Tok_Overriding
;
4206 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4209 -- Normal case, no overriding, or overriding followed by colon
4212 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4215 -- Ada 2005: A subprogram declaration can start with "not" or
4216 -- "overriding". In older versions, "overriding" is handled
4217 -- like an identifier, with the appropriate messages.
4221 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4224 when Tok_Overriding
=>
4226 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4231 Append
(P_Package
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4235 Append
(P_Pragma
, Decls
);
4238 when Tok_Procedure
=>
4240 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4243 when Tok_Protected
=>
4245 Scan
; -- past PROTECTED
4246 Append
(P_Protected
, Decls
);
4251 Append
(P_Subtype_Declaration
, Decls
);
4257 Append
(P_Task
, Decls
);
4262 Append
(P_Type_Declaration
, Decls
);
4267 Append
(P_Use_Clause
, Decls
);
4273 if Aspect_Specifications_Present
then
4275 -- If we are after a semicolon, complain that it was ignored.
4276 -- But we don't really ignore it, since we dump the aspects,
4277 -- so we make the error message a normal fatal message which
4278 -- will inhibit semantic analysis anyway).
4280 if Prev_Token
= Tok_Semicolon
then
4281 Error_Msg_SP
-- CODEFIX
4282 ("extra "";"" ignored");
4284 -- If not just past semicolon, just complain that aspects are
4285 -- not allowed at this point.
4288 Error_Msg_SC
("aspect specifications not allowed here");
4292 Dummy_Node
: constant Node_Id
:=
4293 New_Node
(N_Package_Specification
, Token_Ptr
);
4294 pragma Warnings
(Off
, Dummy_Node
);
4295 -- Dummy node to attach aspect specifications to. We will
4296 -- then throw them away.
4299 P_Aspect_Specifications
(Dummy_Node
, Semicolon
=> True);
4302 -- Here if not aspect specifications case
4305 Error_Msg_SC
("WITH can only appear in context clause");
4309 -- BEGIN terminates the scan of a sequence of declarations unless
4310 -- there is a missing subprogram body, see section on handling
4311 -- semicolon in place of IS. We only treat the begin as satisfying
4312 -- the subprogram declaration if it falls in the expected column
4316 if SIS_Entry_Active
and then Start_Column
>= SIS_Ecol
then
4318 -- Here we have the case where a BEGIN is encountered during
4319 -- declarations in a declarative part, or at the outer level,
4320 -- and there is a subprogram declaration outstanding for which
4321 -- no body has been supplied. This is the case where we assume
4322 -- that the semicolon in the subprogram declaration should
4323 -- really have been is. The active SIS entry describes the
4324 -- subprogram declaration. On return the declaration has been
4325 -- modified to become a body.
4328 Specification_Node
: Node_Id
;
4329 Decl_Node
: Node_Id
;
4330 Body_Node
: Node_Id
;
4333 -- First issue the error message. If we had a missing
4334 -- semicolon in the declaration, then change the message
4335 -- to <missing "is">
4337 if SIS_Missing_Semicolon_Message
/= No_Error_Msg
then
4338 Change_Error_Text
-- Replace: "missing "";"" "
4339 (SIS_Missing_Semicolon_Message
, "missing ""is""");
4341 -- Otherwise we saved the semicolon position, so complain
4344 Error_Msg
-- CODEFIX
4345 ("|"";"" should be IS", SIS_Semicolon_Sloc
);
4348 -- The next job is to fix up any declarations that occurred
4349 -- between the procedure header and the BEGIN. These got
4350 -- chained to the outer declarative region (immediately
4351 -- after the procedure declaration) and they should be
4352 -- chained to the subprogram itself, which is a body
4353 -- rather than a spec.
4355 Specification_Node
:= Specification
(SIS_Declaration_Node
);
4356 Change_Node
(SIS_Declaration_Node
, N_Subprogram_Body
);
4357 Body_Node
:= SIS_Declaration_Node
;
4358 Set_Specification
(Body_Node
, Specification_Node
);
4359 Set_Declarations
(Body_Node
, New_List
);
4362 Decl_Node
:= Remove_Next
(Body_Node
);
4363 exit when Decl_Node
= Empty
;
4364 Append
(Decl_Node
, Declarations
(Body_Node
));
4367 -- Now make the scope table entry for the Begin-End and
4371 Scope
.Table
(Scope
.Last
).Sloc
:= SIS_Sloc
;
4372 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
4373 Scope
.Table
(Scope
.Last
).Ecol
:= SIS_Ecol
;
4374 Scope
.Table
(Scope
.Last
).Labl
:= SIS_Labl
;
4375 Scope
.Table
(Scope
.Last
).Lreq
:= False;
4376 SIS_Entry_Active
:= False;
4378 Set_Handled_Statement_Sequence
(Body_Node
,
4379 P_Handled_Sequence_Of_Statements
);
4380 End_Statements
(Handled_Statement_Sequence
(Body_Node
));
4389 -- Normally an END terminates the scan for basic declarative items.
4390 -- The one exception is END RECORD, which is probably left over from
4394 Save_Scan_State
(Scan_State
); -- at END
4397 if Token
= Tok_Record
then
4398 Error_Msg_SP
("no RECORD for this `end record`!");
4399 Scan
; -- past RECORD
4403 Restore_Scan_State
(Scan_State
); -- to END
4407 -- The following tokens which can only be the start of a statement
4408 -- are considered to end a declarative part (i.e. we have a missing
4409 -- BEGIN situation). We are fairly conservative in making this
4410 -- judgment, because it is a real mess to go into statement mode
4411 -- prematurely in response to a junk declaration.
4426 -- But before we decide that it's a statement, let's check for
4427 -- a reserved word misused as an identifier.
4429 if Is_Reserved_Identifier
then
4430 Save_Scan_State
(Scan_State
);
4431 Scan
; -- past the token
4433 -- If reserved identifier not followed by colon or comma, then
4434 -- this is most likely an assignment statement to the bad id.
4436 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
4437 Restore_Scan_State
(Scan_State
);
4438 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4441 -- Otherwise we have a declaration of the bad id
4444 Restore_Scan_State
(Scan_State
);
4445 Scan_Reserved_Identifier
(Force_Msg
=> True);
4446 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4449 -- If not reserved identifier, then it's definitely a statement
4452 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4456 -- The token RETURN may well also signal a missing BEGIN situation,
4457 -- however, we never let it end the declarative part, because it may
4458 -- also be part of a half-baked function declaration.
4461 Error_Msg_SC
("misplaced RETURN statement");
4464 -- PRIVATE definitely terminates the declarations in a spec,
4465 -- and is an error in a body.
4471 Error_Msg_SC
("PRIVATE not allowed in body");
4472 Scan
; -- past PRIVATE
4475 -- An end of file definitely terminates the declarations!
4480 -- The remaining tokens do not end the scan, but cannot start a
4481 -- valid declaration, so we signal an error and resynchronize.
4482 -- But first check for misuse of a reserved identifier.
4486 -- Here we check for a reserved identifier
4488 if Is_Reserved_Identifier
then
4489 Save_Scan_State
(Scan_State
);
4490 Scan
; -- past the token
4492 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
4493 Restore_Scan_State
(Scan_State
);
4494 Set_Declaration_Expected
;
4497 Restore_Scan_State
(Scan_State
);
4498 Scan_Reserved_Identifier
(Force_Msg
=> True);
4500 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4504 Set_Declaration_Expected
;
4509 -- To resynchronize after an error, we scan to the next semicolon and
4510 -- return with Done = False, indicating that there may still be more
4511 -- valid declarations to come.
4514 when Error_Resync
=>
4515 Resync_Past_Semicolon
;
4517 end P_Declarative_Items
;
4519 ----------------------------------
4520 -- 3.11 Basic Declarative Item --
4521 ----------------------------------
4523 -- BASIC_DECLARATIVE_ITEM ::=
4524 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
4526 -- Scan zero or more basic declarative items
4528 -- Error recovery: cannot raise Error_Resync. If an error is detected, then
4529 -- the scan pointer is repositioned past the next semicolon, and the scan
4530 -- for declarative items continues.
4532 function P_Basic_Declarative_Items
return List_Id
is
4539 -- Indicate no bad declarations detected yet in the current context:
4540 -- visible or private declarations of a package spec.
4542 Missing_Begin_Msg
:= No_Error_Msg
;
4544 -- Get rid of active SIS entry from outer scope. This means we will
4545 -- miss some nested cases, but it doesn't seem worth the effort. See
4546 -- discussion in Par for further details
4548 SIS_Entry_Active
:= False;
4550 -- Loop to scan out declarations
4555 P_Declarative_Items
(Decls
, Done
, In_Spec
=> True);
4559 -- Get rid of active SIS entry. This is set only if we have scanned a
4560 -- procedure declaration and have not found the body. We could give
4561 -- an error message, but that really would be usurping the role of
4562 -- semantic analysis (this really is a case of a missing body).
4564 SIS_Entry_Active
:= False;
4566 -- Test for assorted illegal declarations not diagnosed elsewhere
4568 Decl
:= First
(Decls
);
4570 while Present
(Decl
) loop
4571 Kind
:= Nkind
(Decl
);
4573 -- Test for body scanned, not acceptable as basic decl item
4575 if Kind
= N_Subprogram_Body
or else
4576 Kind
= N_Package_Body
or else
4577 Kind
= N_Task_Body
or else
4578 Kind
= N_Protected_Body
4580 Error_Msg
("proper body not allowed in package spec", Sloc
(Decl
));
4582 -- Test for body stub scanned, not acceptable as basic decl item
4584 elsif Kind
in N_Body_Stub
then
4585 Error_Msg
("body stub not allowed in package spec", Sloc
(Decl
));
4587 elsif Kind
= N_Assignment_Statement
then
4589 ("assignment statement not allowed in package spec",
4597 end P_Basic_Declarative_Items
;
4603 -- For proper body, see below
4604 -- For body stub, see 10.1.3
4606 -----------------------
4607 -- 3.11 Proper Body --
4608 -----------------------
4610 -- Subprogram body is parsed by P_Subprogram (6.1)
4611 -- Package body is parsed by P_Package (7.1)
4612 -- Task body is parsed by P_Task (9.1)
4613 -- Protected body is parsed by P_Protected (9.4)
4615 ------------------------------
4616 -- Set_Declaration_Expected --
4617 ------------------------------
4619 procedure Set_Declaration_Expected
is
4621 Error_Msg_SC
("declaration expected");
4623 if Missing_Begin_Msg
= No_Error_Msg
then
4624 Missing_Begin_Msg
:= Get_Msg_Id
;
4626 end Set_Declaration_Expected
;
4628 ----------------------
4629 -- Skip_Declaration --
4630 ----------------------
4632 procedure Skip_Declaration
(S
: List_Id
) is
4633 Dummy_Done
: Boolean;
4634 pragma Warnings
(Off
, Dummy_Done
);
4636 P_Declarative_Items
(S
, Dummy_Done
, False);
4637 end Skip_Declaration
;
4639 -----------------------------------------
4640 -- Statement_When_Declaration_Expected --
4641 -----------------------------------------
4643 procedure Statement_When_Declaration_Expected
4649 -- Case of second occurrence of statement in one declaration sequence
4651 if Missing_Begin_Msg
/= No_Error_Msg
then
4653 -- In the procedure spec case, just ignore it, we only give one
4654 -- message for the first occurrence, since otherwise we may get
4655 -- horrible cascading if BODY was missing in the header line.
4660 -- In the declarative part case, take a second statement as a sure
4661 -- sign that we really have a missing BEGIN, and end the declarative
4662 -- part now. Note that the caller will fix up the first message to
4663 -- say "missing BEGIN" so that's how the error will be signalled.
4670 -- Case of first occurrence of unexpected statement
4673 -- If we are in a package spec, then give message of statement
4674 -- not allowed in package spec. This message never gets changed.
4677 Error_Msg_SC
("statement not allowed in package spec");
4679 -- If in declarative part, then we give the message complaining
4680 -- about finding a statement when a declaration is expected. This
4681 -- gets changed to a complaint about a missing BEGIN if we later
4682 -- find that no BEGIN is present.
4685 Error_Msg_SC
("statement not allowed in declarative part");
4688 -- Capture message Id. This is used for two purposes, first to
4689 -- stop multiple messages, see test above, and second, to allow
4690 -- the replacement of the message in the declarative part case.
4692 Missing_Begin_Msg
:= Get_Msg_Id
;
4695 -- In all cases except the case in which we decided to terminate the
4696 -- declaration sequence on a second error, we scan out the statement
4697 -- and append it to the list of declarations (note that the semantics
4698 -- can handle statements in a declaration list so if we proceed to
4699 -- call the semantic phase, all will be (reasonably) well!
4701 Append_List_To
(Decls
, P_Sequence_Of_Statements
(SS_Unco
));
4703 -- Done is set to False, since we want to continue the scan of
4704 -- declarations, hoping that this statement was a temporary glitch.
4705 -- If we indeed are now in the statement part (i.e. this was a missing
4706 -- BEGIN, then it's not terrible, we will simply keep calling this
4707 -- procedure to process the statements one by one, and then finally
4708 -- hit the missing BEGIN, which will clean up the error message.
4711 end Statement_When_Declaration_Expected
;