1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2012, 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_Or_Range_Attribute
;
2284 -- Range case (not permitted by the grammar, this is surprising but
2285 -- the grammar in the RM is as quoted above, and does not allow Range).
2287 if Expr_Form
= EF_Range_Attr
then
2289 ("Range attribute not allowed here, use First .. Last", Expr_Node
);
2290 Set_Low_Bound
(Typedef_Node
, Expr_Node
);
2291 Set_Attribute_Name
(Expr_Node
, Name_First
);
2292 Set_High_Bound
(Typedef_Node
, Copy_Separate_Tree
(Expr_Node
));
2293 Set_Attribute_Name
(High_Bound
(Typedef_Node
), Name_Last
);
2295 -- Normal case of explicit range
2298 Check_Simple_Expression
(Expr_Node
);
2299 Set_Low_Bound
(Typedef_Node
, Expr_Node
);
2301 Expr_Node
:= P_Expression
;
2302 Check_Simple_Expression
(Expr_Node
);
2303 Set_High_Bound
(Typedef_Node
, Expr_Node
);
2306 return Typedef_Node
;
2307 end P_Signed_Integer_Type_Definition
;
2309 ------------------------------------
2310 -- 3.5.4 Modular Type Definition --
2311 ------------------------------------
2313 -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
2315 -- The caller has checked that the initial token is MOD
2317 -- Error recovery: cannot raise Error_Resync
2319 function P_Modular_Type_Definition
return Node_Id
is
2320 Typedef_Node
: Node_Id
;
2323 if Ada_Version
= Ada_83
then
2324 Error_Msg_SC
("(Ada 83): modular types not allowed");
2327 Typedef_Node
:= New_Node
(N_Modular_Type_Definition
, Token_Ptr
);
2329 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
2331 -- Handle mod L..R cleanly
2333 if Token
= Tok_Dot_Dot
then
2334 Error_Msg_SC
("range not allowed for modular type");
2336 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
2339 return Typedef_Node
;
2340 end P_Modular_Type_Definition
;
2342 ---------------------------------
2343 -- 3.5.6 Real Type Definition --
2344 ---------------------------------
2346 -- Parsed by P_Type_Declaration (3.2.1)
2348 --------------------------------------
2349 -- 3.5.7 Floating Point Definition --
2350 --------------------------------------
2352 -- FLOATING_POINT_DEFINITION ::=
2353 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2355 -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
2357 -- The caller has checked that the initial token is DIGITS
2359 -- Error recovery: cannot raise Error_Resync
2361 function P_Floating_Point_Definition
return Node_Id
is
2362 Digits_Loc
: constant Source_Ptr
:= Token_Ptr
;
2364 Expr_Node
: Node_Id
;
2367 Scan
; -- past DIGITS
2368 Expr_Node
:= P_Expression_No_Right_Paren
;
2369 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2371 -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
2373 if Token
= Tok_Delta
then
2374 Error_Msg_SC
-- CODEFIX
2375 ("|DELTA must come before DIGITS");
2376 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Digits_Loc
);
2378 Set_Delta_Expression
(Def_Node
, P_Expression_No_Right_Paren
);
2380 -- OK floating-point definition
2383 Def_Node
:= New_Node
(N_Floating_Point_Definition
, Digits_Loc
);
2386 Set_Digits_Expression
(Def_Node
, Expr_Node
);
2387 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
2389 end P_Floating_Point_Definition
;
2391 -------------------------------------
2392 -- 3.5.7 Real Range Specification --
2393 -------------------------------------
2395 -- REAL_RANGE_SPECIFICATION ::=
2396 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2398 -- Error recovery: cannot raise Error_Resync
2400 function P_Real_Range_Specification_Opt
return Node_Id
is
2401 Specification_Node
: Node_Id
;
2402 Expr_Node
: Node_Id
;
2405 if Token
= Tok_Range
then
2406 Specification_Node
:=
2407 New_Node
(N_Real_Range_Specification
, Token_Ptr
);
2409 Expr_Node
:= P_Expression_No_Right_Paren
;
2410 Check_Simple_Expression
(Expr_Node
);
2411 Set_Low_Bound
(Specification_Node
, Expr_Node
);
2413 Expr_Node
:= P_Expression_No_Right_Paren
;
2414 Check_Simple_Expression
(Expr_Node
);
2415 Set_High_Bound
(Specification_Node
, Expr_Node
);
2416 return Specification_Node
;
2420 end P_Real_Range_Specification_Opt
;
2422 -----------------------------------
2423 -- 3.5.9 Fixed Point Definition --
2424 -----------------------------------
2426 -- FIXED_POINT_DEFINITION ::=
2427 -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
2429 -- ORDINARY_FIXED_POINT_DEFINITION ::=
2430 -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION
2432 -- DECIMAL_FIXED_POINT_DEFINITION ::=
2433 -- delta static_EXPRESSION
2434 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2436 -- The caller has checked that the initial token is DELTA
2438 -- Error recovery: cannot raise Error_Resync
2440 function P_Fixed_Point_Definition
return Node_Id
is
2441 Delta_Node
: Node_Id
;
2442 Delta_Loc
: Source_Ptr
;
2444 Expr_Node
: Node_Id
;
2447 Delta_Loc
:= Token_Ptr
;
2449 Delta_Node
:= P_Expression_No_Right_Paren
;
2450 Check_Simple_Expression_In_Ada_83
(Delta_Node
);
2452 if Token
= Tok_Digits
then
2453 if Ada_Version
= Ada_83
then
2454 Error_Msg_SC
("(Ada 83) decimal fixed type not allowed!");
2457 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Delta_Loc
);
2458 Scan
; -- past DIGITS
2459 Expr_Node
:= P_Expression_No_Right_Paren
;
2460 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2461 Set_Digits_Expression
(Def_Node
, Expr_Node
);
2464 Def_Node
:= New_Node
(N_Ordinary_Fixed_Point_Definition
, Delta_Loc
);
2466 -- Range is required in ordinary fixed point case
2468 if Token
/= Tok_Range
then
2469 Error_Msg_AP
("range must be given for fixed-point type");
2474 Set_Delta_Expression
(Def_Node
, Delta_Node
);
2475 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
2477 end P_Fixed_Point_Definition
;
2479 --------------------------------------------
2480 -- 3.5.9 Ordinary Fixed Point Definition --
2481 --------------------------------------------
2483 -- Parsed by P_Fixed_Point_Definition (3.5.9)
2485 -------------------------------------------
2486 -- 3.5.9 Decimal Fixed Point Definition --
2487 -------------------------------------------
2489 -- Parsed by P_Decimal_Point_Definition (3.5.9)
2491 ------------------------------
2492 -- 3.5.9 Digits Constraint --
2493 ------------------------------
2495 -- DIGITS_CONSTRAINT ::=
2496 -- digits static_EXPRESSION [RANGE_CONSTRAINT]
2498 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2500 -- The caller has checked that the initial token is DIGITS
2502 function P_Digits_Constraint
return Node_Id
is
2503 Constraint_Node
: Node_Id
;
2504 Expr_Node
: Node_Id
;
2507 Constraint_Node
:= New_Node
(N_Digits_Constraint
, Token_Ptr
);
2508 Scan
; -- past DIGITS
2509 Expr_Node
:= P_Expression
;
2510 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2511 Set_Digits_Expression
(Constraint_Node
, Expr_Node
);
2513 if Token
= Tok_Range
then
2514 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
2517 return Constraint_Node
;
2518 end P_Digits_Constraint
;
2520 -----------------------------
2521 -- 3.5.9 Delta Constraint --
2522 -----------------------------
2524 -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
2526 -- Note: this is an obsolescent feature in Ada 95 (I.3)
2528 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2529 -- (also true in formal modes).
2531 -- The caller has checked that the initial token is DELTA
2533 -- Error recovery: cannot raise Error_Resync
2535 function P_Delta_Constraint
return Node_Id
is
2536 Constraint_Node
: Node_Id
;
2537 Expr_Node
: Node_Id
;
2540 Constraint_Node
:= New_Node
(N_Delta_Constraint
, Token_Ptr
);
2542 Expr_Node
:= P_Expression
;
2543 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2545 Set_Delta_Expression
(Constraint_Node
, Expr_Node
);
2547 if Token
= Tok_Range
then
2548 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
2551 return Constraint_Node
;
2552 end P_Delta_Constraint
;
2554 --------------------------------
2555 -- 3.6 Array Type Definition --
2556 --------------------------------
2558 -- ARRAY_TYPE_DEFINITION ::=
2559 -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
2561 -- UNCONSTRAINED_ARRAY_DEFINITION ::=
2562 -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
2563 -- COMPONENT_DEFINITION
2565 -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
2567 -- CONSTRAINED_ARRAY_DEFINITION ::=
2568 -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
2569 -- COMPONENT_DEFINITION
2571 -- DISCRETE_SUBTYPE_DEFINITION ::=
2572 -- DISCRETE_SUBTYPE_INDICATION | RANGE
2574 -- COMPONENT_DEFINITION ::=
2575 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
2577 -- The caller has checked that the initial token is ARRAY
2579 -- Error recovery: can raise Error_Resync
2581 function P_Array_Type_Definition
return Node_Id
is
2582 Array_Loc
: Source_Ptr
;
2583 CompDef_Node
: Node_Id
;
2585 Not_Null_Present
: Boolean := False;
2586 Subs_List
: List_Id
;
2587 Scan_State
: Saved_Scan_State
;
2588 Aliased_Present
: Boolean := False;
2591 Array_Loc
:= Token_Ptr
;
2593 Subs_List
:= New_List
;
2596 -- It's quite tricky to disentangle these two possibilities, so we do
2597 -- a prescan to determine which case we have and then reset the scan.
2598 -- The prescan skips past possible subtype mark tokens.
2600 Save_Scan_State
(Scan_State
); -- just after paren
2602 while Token
in Token_Class_Desig
or else
2603 Token
= Tok_Dot
or else
2604 Token
= Tok_Apostrophe
-- because of 'BASE, 'CLASS
2609 -- If we end up on RANGE <> then we have the unconstrained case. We
2610 -- will also allow the RANGE to be omitted, just to improve error
2611 -- handling for a case like array (integer <>) of integer;
2613 Scan
; -- past possible RANGE or <>
2615 if (Prev_Token
= Tok_Range
and then Token
= Tok_Box
) or else
2616 Prev_Token
= Tok_Box
2618 Def_Node
:= New_Node
(N_Unconstrained_Array_Definition
, Array_Loc
);
2619 Restore_Scan_State
(Scan_State
); -- to first subtype mark
2622 Append
(P_Subtype_Mark_Resync
, Subs_List
);
2625 exit when Token
= Tok_Right_Paren
or else Token
= Tok_Of
;
2629 Set_Subtype_Marks
(Def_Node
, Subs_List
);
2632 Def_Node
:= New_Node
(N_Constrained_Array_Definition
, Array_Loc
);
2633 Restore_Scan_State
(Scan_State
); -- to first discrete range
2636 Append
(P_Discrete_Subtype_Definition
, Subs_List
);
2637 exit when not Comma_Present
;
2640 Set_Discrete_Subtype_Definitions
(Def_Node
, Subs_List
);
2646 CompDef_Node
:= New_Node
(N_Component_Definition
, Token_Ptr
);
2648 if Token_Name
= Name_Aliased
then
2649 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
2652 if Token
= Tok_Aliased
then
2653 Aliased_Present
:= True;
2654 Scan
; -- past ALIASED
2657 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/AI-254)
2659 -- Ada 2005 (AI-230): Access Definition case
2661 if Token
= Tok_Access
then
2662 if Ada_Version
< Ada_2005
then
2664 ("generalized use of anonymous access types " &
2665 "is an Ada 2005 extension");
2666 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
2669 -- AI95-406 makes "aliased" legal (and useless) in this context so
2670 -- followintg code which used to be needed is commented out.
2672 -- if Aliased_Present then
2673 -- Error_Msg_SP ("ALIASED not allowed here");
2676 Set_Subtype_Indication
(CompDef_Node
, Empty
);
2677 Set_Aliased_Present
(CompDef_Node
, False);
2678 Set_Access_Definition
(CompDef_Node
,
2679 P_Access_Definition
(Not_Null_Present
));
2682 Set_Access_Definition
(CompDef_Node
, Empty
);
2683 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
2684 Set_Null_Exclusion_Present
(CompDef_Node
, Not_Null_Present
);
2685 Set_Subtype_Indication
(CompDef_Node
,
2686 P_Subtype_Indication
(Not_Null_Present
));
2689 Set_Component_Definition
(Def_Node
, CompDef_Node
);
2692 end P_Array_Type_Definition
;
2694 -----------------------------------------
2695 -- 3.6 Unconstrained Array Definition --
2696 -----------------------------------------
2698 -- Parsed by P_Array_Type_Definition (3.6)
2700 ---------------------------------------
2701 -- 3.6 Constrained Array Definition --
2702 ---------------------------------------
2704 -- Parsed by P_Array_Type_Definition (3.6)
2706 --------------------------------------
2707 -- 3.6 Discrete Subtype Definition --
2708 --------------------------------------
2710 -- DISCRETE_SUBTYPE_DEFINITION ::=
2711 -- discrete_SUBTYPE_INDICATION | RANGE
2713 -- Note: the discrete subtype definition appearing in a constrained
2714 -- array definition is parsed by P_Array_Type_Definition (3.6)
2716 -- Error recovery: cannot raise Error_Resync
2718 function P_Discrete_Subtype_Definition
return Node_Id
is
2720 -- The syntax of a discrete subtype definition is identical to that
2721 -- of a discrete range, so we simply share the same parsing code.
2723 return P_Discrete_Range
;
2724 end P_Discrete_Subtype_Definition
;
2726 -------------------------------
2727 -- 3.6 Component Definition --
2728 -------------------------------
2730 -- For the array case, parsed by P_Array_Type_Definition (3.6)
2731 -- For the record case, parsed by P_Component_Declaration (3.8)
2733 -----------------------------
2734 -- 3.6.1 Index Constraint --
2735 -----------------------------
2737 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2739 ---------------------------
2740 -- 3.6.1 Discrete Range --
2741 ---------------------------
2743 -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
2745 -- The possible forms for a discrete range are:
2747 -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2)
2748 -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2)
2749 -- Range_Attribute (RANGE, 3.5)
2750 -- Simple_Expression .. Simple_Expression (RANGE, 3.5)
2752 -- Error recovery: cannot raise Error_Resync
2754 function P_Discrete_Range
return Node_Id
is
2755 Expr_Node
: Node_Id
;
2756 Range_Node
: Node_Id
;
2759 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2761 if Expr_Form
= EF_Range_Attr
then
2764 elsif Token
= Tok_Range
then
2765 if Expr_Form
/= EF_Simple_Name
then
2766 Error_Msg_SC
("range must be preceded by subtype mark");
2769 return P_Subtype_Indication
(Expr_Node
);
2771 -- Check Expression .. Expression case
2773 elsif Token
= Tok_Dot_Dot
then
2774 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2775 Set_Low_Bound
(Range_Node
, Expr_Node
);
2777 Expr_Node
:= P_Expression
;
2778 Check_Simple_Expression
(Expr_Node
);
2779 Set_High_Bound
(Range_Node
, Expr_Node
);
2782 -- Otherwise we must have a subtype mark, or an Ada 2012 iterator
2784 elsif Expr_Form
= EF_Simple_Name
then
2787 -- The domain of iteration must be a name. Semantics will determine that
2788 -- the expression has the proper form.
2790 elsif Ada_Version
>= Ada_2012
then
2793 -- If incorrect, complain that we expect ..
2799 end P_Discrete_Range
;
2801 ----------------------------
2802 -- 3.7 Discriminant Part --
2803 ----------------------------
2805 -- DISCRIMINANT_PART ::=
2806 -- UNKNOWN_DISCRIMINANT_PART
2807 -- | KNOWN_DISCRIMINANT_PART
2809 -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
2810 -- or P_Unknown_Discriminant_Part (3.7), since we know which we want.
2812 ------------------------------------
2813 -- 3.7 Unknown Discriminant Part --
2814 ------------------------------------
2816 -- UNKNOWN_DISCRIMINANT_PART ::= (<>)
2818 -- If no unknown discriminant part is present, then False is returned,
2819 -- otherwise the unknown discriminant is scanned out and True is returned.
2821 -- Error recovery: cannot raise Error_Resync
2823 function P_Unknown_Discriminant_Part_Opt
return Boolean is
2824 Scan_State
: Saved_Scan_State
;
2827 -- If <> right now, then this is missing left paren
2829 if Token
= Tok_Box
then
2832 -- If not <> or left paren, then definitely no box
2834 elsif Token
/= Tok_Left_Paren
then
2837 -- Left paren, so might be a box after it
2840 Save_Scan_State
(Scan_State
);
2841 Scan
; -- past the left paren
2843 if Token
/= Tok_Box
then
2844 Restore_Scan_State
(Scan_State
);
2849 -- We are now pointing to the box
2851 if Ada_Version
= Ada_83
then
2852 Error_Msg_SC
("(Ada 83) unknown discriminant not allowed!");
2855 Scan
; -- past the box
2856 U_Right_Paren
; -- must be followed by right paren
2858 end P_Unknown_Discriminant_Part_Opt
;
2860 ----------------------------------
2861 -- 3.7 Known Discriminant Part --
2862 ----------------------------------
2864 -- KNOWN_DISCRIMINANT_PART ::=
2865 -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
2867 -- DISCRIMINANT_SPECIFICATION ::=
2868 -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
2869 -- [:= DEFAULT_EXPRESSION]
2870 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
2871 -- [:= DEFAULT_EXPRESSION]
2873 -- If no known discriminant part is present, then No_List is returned
2875 -- Error recovery: cannot raise Error_Resync
2877 function P_Known_Discriminant_Part_Opt
return List_Id
is
2878 Specification_Node
: Node_Id
;
2879 Specification_List
: List_Id
;
2880 Ident_Sloc
: Source_Ptr
;
2881 Scan_State
: Saved_Scan_State
;
2883 Not_Null_Present
: Boolean;
2886 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
2887 -- This array holds the list of defining identifiers. The upper bound
2888 -- of 4096 is intended to be essentially infinite, and we do not even
2889 -- bother to check for it being exceeded.
2892 if Token
= Tok_Left_Paren
then
2893 Specification_List
:= New_List
;
2895 P_Pragmas_Misplaced
;
2897 Specification_Loop
: loop
2899 Ident_Sloc
:= Token_Ptr
;
2900 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
2903 while Comma_Present
loop
2904 Num_Idents
:= Num_Idents
+ 1;
2905 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
2908 -- If there are multiple identifiers, we repeatedly scan the
2909 -- type and initialization expression information by resetting
2910 -- the scan pointer (so that we get completely separate trees
2911 -- for each occurrence).
2913 if Num_Idents
> 1 then
2914 Save_Scan_State
(Scan_State
);
2919 -- Loop through defining identifiers in list
2923 Specification_Node
:=
2924 New_Node
(N_Discriminant_Specification
, Ident_Sloc
);
2925 Set_Defining_Identifier
(Specification_Node
, Idents
(Ident
));
2926 Not_Null_Present
:= -- Ada 2005 (AI-231, AI-447)
2927 P_Null_Exclusion
(Allow_Anonymous_In_95
=> True);
2929 if Token
= Tok_Access
then
2930 if Ada_Version
= Ada_83
then
2932 ("(Ada 83) access discriminant not allowed!");
2935 Set_Discriminant_Type
2936 (Specification_Node
,
2937 P_Access_Definition
(Not_Null_Present
));
2940 Set_Discriminant_Type
2941 (Specification_Node
, P_Subtype_Mark
);
2943 Set_Null_Exclusion_Present
-- Ada 2005 (AI-231)
2944 (Specification_Node
, Not_Null_Present
);
2948 (Specification_Node
, Init_Expr_Opt
(True));
2951 Set_Prev_Ids
(Specification_Node
, True);
2954 if Ident
< Num_Idents
then
2955 Set_More_Ids
(Specification_Node
, True);
2958 Append
(Specification_Node
, Specification_List
);
2959 exit Ident_Loop
when Ident
= Num_Idents
;
2961 Restore_Scan_State
(Scan_State
);
2963 end loop Ident_Loop
;
2965 exit Specification_Loop
when Token
/= Tok_Semicolon
;
2967 P_Pragmas_Misplaced
;
2968 end loop Specification_Loop
;
2971 return Specification_List
;
2976 end P_Known_Discriminant_Part_Opt
;
2978 -------------------------------------
2979 -- 3.7 Discriminant Specification --
2980 -------------------------------------
2982 -- Parsed by P_Known_Discriminant_Part_Opt (3.7)
2984 -----------------------------
2985 -- 3.7 Default Expression --
2986 -----------------------------
2988 -- Always parsed (simply as an Expression) by the parent construct
2990 ------------------------------------
2991 -- 3.7.1 Discriminant Constraint --
2992 ------------------------------------
2994 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2996 --------------------------------------------------------
2997 -- 3.7.1 Index or Discriminant Constraint (also 3.6) --
2998 --------------------------------------------------------
3000 -- DISCRIMINANT_CONSTRAINT ::=
3001 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
3003 -- DISCRIMINANT_ASSOCIATION ::=
3004 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
3007 -- This routine parses either an index or a discriminant constraint. As
3008 -- is clear from the above grammar, it is often possible to clearly
3009 -- determine which of the two possibilities we have, but there are
3010 -- cases (those in which we have a series of expressions of the same
3011 -- syntactic form as subtype indications), where we cannot tell. Since
3012 -- this means that in any case the semantic phase has to distinguish
3013 -- between the two, there is not much point in the parser trying to
3014 -- distinguish even those cases where the difference is clear. In any
3015 -- case, if we have a situation like:
3017 -- (A => 123, 235 .. 500)
3019 -- it is not clear which of the two items is the wrong one, better to
3020 -- let the semantic phase give a clear message. Consequently, this
3021 -- routine in general returns a list of items which can be either
3022 -- discrete ranges or discriminant associations.
3024 -- The caller has checked that the initial token is a left paren
3026 -- Error recovery: can raise Error_Resync
3028 function P_Index_Or_Discriminant_Constraint
return Node_Id
is
3029 Scan_State
: Saved_Scan_State
;
3030 Constr_Node
: Node_Id
;
3031 Constr_List
: List_Id
;
3032 Expr_Node
: Node_Id
;
3033 Result_Node
: Node_Id
;
3036 Result_Node
:= New_Node
(N_Index_Or_Discriminant_Constraint
, Token_Ptr
);
3038 Constr_List
:= New_List
;
3039 Set_Constraints
(Result_Node
, Constr_List
);
3041 -- The two syntactic forms are a little mixed up, so what we are doing
3042 -- here is looking at the first entry to determine which case we have
3044 -- A discriminant constraint is a list of discriminant associations,
3045 -- which have one of the following possible forms:
3049 -- Id | Id | .. | Id => Expression
3051 -- An index constraint is a list of discrete ranges which have one
3052 -- of the following possible forms:
3055 -- Subtype_Mark range Range
3057 -- Simple_Expression .. Simple_Expression
3059 -- Loop through discriminants in list
3062 -- Check cases of Id => Expression or Id | Id => Expression
3064 if Token
= Tok_Identifier
then
3065 Save_Scan_State
(Scan_State
); -- at Id
3068 if Token
= Tok_Arrow
or else Token
= Tok_Vertical_Bar
then
3069 Restore_Scan_State
(Scan_State
); -- to Id
3070 Append
(P_Discriminant_Association
, Constr_List
);
3073 Restore_Scan_State
(Scan_State
); -- to Id
3077 -- Otherwise scan out an expression and see what we have got
3079 Expr_Node
:= P_Expression_Or_Range_Attribute
;
3081 if Expr_Form
= EF_Range_Attr
then
3082 Append
(Expr_Node
, Constr_List
);
3084 elsif Token
= Tok_Range
then
3085 if Expr_Form
/= EF_Simple_Name
then
3086 Error_Msg_SC
("subtype mark required before RANGE");
3089 Append
(P_Subtype_Indication
(Expr_Node
), Constr_List
);
3092 -- Check Simple_Expression .. Simple_Expression case
3094 elsif Token
= Tok_Dot_Dot
then
3095 Check_Simple_Expression
(Expr_Node
);
3096 Constr_Node
:= New_Node
(N_Range
, Token_Ptr
);
3097 Set_Low_Bound
(Constr_Node
, Expr_Node
);
3099 Expr_Node
:= P_Expression
;
3100 Check_Simple_Expression
(Expr_Node
);
3101 Set_High_Bound
(Constr_Node
, Expr_Node
);
3102 Append
(Constr_Node
, Constr_List
);
3105 -- Case of an expression which could be either form
3108 Append
(Expr_Node
, Constr_List
);
3112 -- Here with a single entry scanned
3115 exit when not Comma_Present
;
3121 end P_Index_Or_Discriminant_Constraint
;
3123 -------------------------------------
3124 -- 3.7.1 Discriminant Association --
3125 -------------------------------------
3127 -- DISCRIMINANT_ASSOCIATION ::=
3128 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
3131 -- This routine is used only when the name list is present and the caller
3132 -- has already checked this (by scanning ahead and repositioning the
3135 -- Error_Recovery: cannot raise Error_Resync;
3137 function P_Discriminant_Association
return Node_Id
is
3138 Discr_Node
: Node_Id
;
3139 Names_List
: List_Id
;
3140 Ident_Sloc
: Source_Ptr
;
3143 Ident_Sloc
:= Token_Ptr
;
3144 Names_List
:= New_List
;
3147 Append
(P_Identifier
(C_Vertical_Bar_Arrow
), Names_List
);
3148 exit when Token
/= Tok_Vertical_Bar
;
3152 Discr_Node
:= New_Node
(N_Discriminant_Association
, Ident_Sloc
);
3153 Set_Selector_Names
(Discr_Node
, Names_List
);
3155 Set_Expression
(Discr_Node
, P_Expression
);
3157 end P_Discriminant_Association
;
3159 ---------------------------------
3160 -- 3.8 Record Type Definition --
3161 ---------------------------------
3163 -- RECORD_TYPE_DEFINITION ::=
3164 -- [[abstract] tagged] [limited] RECORD_DEFINITION
3166 -- There is no node in the tree for a record type definition. Instead
3167 -- a record definition node appears, with possible Abstract_Present,
3168 -- Tagged_Present, and Limited_Present flags set appropriately.
3170 ----------------------------
3171 -- 3.8 Record Definition --
3172 ----------------------------
3174 -- RECORD_DEFINITION ::=
3180 -- Note: in the case where a record definition node is used to represent
3181 -- a record type definition, the caller sets the Tagged_Present and
3182 -- Limited_Present flags in the resulting N_Record_Definition node as
3185 -- Note that the RECORD token at the start may be missing in certain
3186 -- error situations, so this function is expected to post the error
3188 -- Error recovery: can raise Error_Resync
3190 function P_Record_Definition
return Node_Id
is
3194 Rec_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
3198 if Token
= Tok_Null
then
3201 Set_Null_Present
(Rec_Node
, True);
3203 -- Catch incomplete declaration to prevent cascaded errors, see
3204 -- ACATS B393002 for an example.
3206 elsif Token
= Tok_Semicolon
then
3207 Error_Msg_AP
("missing record definition");
3209 -- Case starting with RECORD keyword. Build scope stack entry. For the
3210 -- column, we use the first non-blank character on the line, to deal
3211 -- with situations such as:
3217 -- which is not official RM indentation, but is not uncommon usage, and
3218 -- in particular is standard GNAT coding style, so handle it nicely.
3222 Scope
.Table
(Scope
.Last
).Etyp
:= E_Record
;
3223 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
3224 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
3225 Scope
.Table
(Scope
.Last
).Labl
:= Error
;
3226 Scope
.Table
(Scope
.Last
).Junk
:= (Token
/= Tok_Record
);
3230 Set_Component_List
(Rec_Node
, P_Component_List
);
3233 exit when Check_End
;
3234 Discard_Junk_Node
(P_Component_List
);
3239 end P_Record_Definition
;
3241 -------------------------
3242 -- 3.8 Component List --
3243 -------------------------
3245 -- COMPONENT_LIST ::=
3246 -- COMPONENT_ITEM {COMPONENT_ITEM}
3247 -- | {COMPONENT_ITEM} VARIANT_PART
3250 -- Error recovery: cannot raise Error_Resync
3252 function P_Component_List
return Node_Id
is
3253 Component_List_Node
: Node_Id
;
3254 Decls_List
: List_Id
;
3255 Scan_State
: Saved_Scan_State
;
3258 Component_List_Node
:= New_Node
(N_Component_List
, Token_Ptr
);
3259 Decls_List
:= New_List
;
3261 if Token
= Tok_Null
then
3264 P_Pragmas_Opt
(Decls_List
);
3265 Set_Null_Present
(Component_List_Node
, True);
3266 return Component_List_Node
;
3269 P_Pragmas_Opt
(Decls_List
);
3271 if Token
/= Tok_Case
then
3272 Component_Scan_Loop
: loop
3273 P_Component_Items
(Decls_List
);
3274 P_Pragmas_Opt
(Decls_List
);
3276 exit Component_Scan_Loop
when Token
= Tok_End
3277 or else Token
= Tok_Case
3278 or else Token
= Tok_When
;
3280 -- We are done if we do not have an identifier. However, if
3281 -- we have a misspelled reserved identifier that is in a column
3282 -- to the right of the record definition, we will treat it as
3283 -- an identifier. It turns out to be too dangerous in practice
3284 -- to accept such a mis-spelled identifier which does not have
3285 -- this additional clue that confirms the incorrect spelling.
3287 if Token
/= Tok_Identifier
then
3288 if Start_Column
> Scope
.Table
(Scope
.Last
).Ecol
3289 and then Is_Reserved_Identifier
3291 Save_Scan_State
(Scan_State
); -- at reserved id
3292 Scan
; -- possible reserved id
3294 if Token
= Tok_Comma
or else Token
= Tok_Colon
then
3295 Restore_Scan_State
(Scan_State
);
3296 Scan_Reserved_Identifier
(Force_Msg
=> True);
3298 -- Note reserved identifier used as field name after
3299 -- all because not followed by colon or comma
3302 Restore_Scan_State
(Scan_State
);
3303 exit Component_Scan_Loop
;
3306 -- Non-identifier that definitely was not reserved id
3309 exit Component_Scan_Loop
;
3312 end loop Component_Scan_Loop
;
3315 if Token
= Tok_Case
then
3316 Set_Variant_Part
(Component_List_Node
, P_Variant_Part
);
3318 -- Check for junk after variant part
3320 if Token
= Tok_Identifier
then
3321 Save_Scan_State
(Scan_State
);
3322 Scan
; -- past identifier
3324 if Token
= Tok_Colon
then
3325 Restore_Scan_State
(Scan_State
);
3326 Error_Msg_SC
("component may not follow variant part");
3327 Discard_Junk_Node
(P_Component_List
);
3329 elsif Token
= Tok_Case
then
3330 Restore_Scan_State
(Scan_State
);
3331 Error_Msg_SC
("only one variant part allowed in a record");
3332 Discard_Junk_Node
(P_Component_List
);
3335 Restore_Scan_State
(Scan_State
);
3341 Set_Component_Items
(Component_List_Node
, Decls_List
);
3342 return Component_List_Node
;
3343 end P_Component_List
;
3345 -------------------------
3346 -- 3.8 Component Item --
3347 -------------------------
3349 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
3351 -- COMPONENT_DECLARATION ::=
3352 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
3353 -- [:= DEFAULT_EXPRESSION]
3354 -- [ASPECT_SPECIFICATIONS];
3356 -- COMPONENT_DEFINITION ::=
3357 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
3359 -- Error recovery: cannot raise Error_Resync, if an error occurs,
3360 -- the scan is positioned past the following semicolon.
3362 -- Note: we do not yet allow representation clauses to appear as component
3363 -- items, do we need to add this capability sometime in the future ???
3365 procedure P_Component_Items
(Decls
: List_Id
) is
3366 Aliased_Present
: Boolean := False;
3367 CompDef_Node
: Node_Id
;
3368 Decl_Node
: Node_Id
;
3369 Scan_State
: Saved_Scan_State
;
3370 Not_Null_Present
: Boolean := False;
3373 Ident_Sloc
: Source_Ptr
;
3375 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
3376 -- This array holds the list of defining identifiers. The upper bound
3377 -- of 4096 is intended to be essentially infinite, and we do not even
3378 -- bother to check for it being exceeded.
3381 if Token
/= Tok_Identifier
then
3382 Error_Msg_SC
("component declaration expected");
3383 Resync_Past_Semicolon
;
3387 Ident_Sloc
:= Token_Ptr
;
3388 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
3391 while Comma_Present
loop
3392 Num_Idents
:= Num_Idents
+ 1;
3393 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
3396 -- If there are multiple identifiers, we repeatedly scan the
3397 -- type and initialization expression information by resetting
3398 -- the scan pointer (so that we get completely separate trees
3399 -- for each occurrence).
3401 if Num_Idents
> 1 then
3402 Save_Scan_State
(Scan_State
);
3407 -- Loop through defining identifiers in list
3412 -- The following block is present to catch Error_Resync
3413 -- which causes the parse to be reset past the semicolon
3416 Decl_Node
:= New_Node
(N_Component_Declaration
, Ident_Sloc
);
3417 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
3419 if Token
= Tok_Constant
then
3420 Error_Msg_SC
("constant components are not permitted");
3424 CompDef_Node
:= New_Node
(N_Component_Definition
, Token_Ptr
);
3426 if Token_Name
= Name_Aliased
then
3427 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
3430 if Token
= Tok_Aliased
then
3431 Aliased_Present
:= True;
3432 Scan
; -- past ALIASED
3435 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/AI-254)
3437 -- Ada 2005 (AI-230): Access Definition case
3439 if Token
= Tok_Access
then
3440 if Ada_Version
< Ada_2005
then
3442 ("generalized use of anonymous access types " &
3443 "is an Ada 2005 extension");
3444 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
3447 -- AI95-406 makes "aliased" legal (and useless) here, so the
3448 -- following code which used to be required is commented out.
3450 -- if Aliased_Present then
3451 -- Error_Msg_SP ("ALIASED not allowed here");
3454 Set_Subtype_Indication
(CompDef_Node
, Empty
);
3455 Set_Aliased_Present
(CompDef_Node
, False);
3456 Set_Access_Definition
(CompDef_Node
,
3457 P_Access_Definition
(Not_Null_Present
));
3460 Set_Access_Definition
(CompDef_Node
, Empty
);
3461 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
3462 Set_Null_Exclusion_Present
(CompDef_Node
, Not_Null_Present
);
3464 if Token
= Tok_Array
then
3465 Error_Msg_SC
("anonymous arrays not allowed as components");
3469 Set_Subtype_Indication
(CompDef_Node
,
3470 P_Subtype_Indication
(Not_Null_Present
));
3473 Set_Component_Definition
(Decl_Node
, CompDef_Node
);
3474 Set_Expression
(Decl_Node
, Init_Expr_Opt
);
3477 Set_Prev_Ids
(Decl_Node
, True);
3480 if Ident
< Num_Idents
then
3481 Set_More_Ids
(Decl_Node
, True);
3484 Append
(Decl_Node
, Decls
);
3487 when Error_Resync
=>
3488 if Token
/= Tok_End
then
3489 Resync_Past_Semicolon
;
3493 exit Ident_Loop
when Ident
= Num_Idents
;
3495 Restore_Scan_State
(Scan_State
);
3497 end loop Ident_Loop
;
3499 P_Aspect_Specifications
(Decl_Node
);
3500 end P_Component_Items
;
3502 --------------------------------
3503 -- 3.8 Component Declaration --
3504 --------------------------------
3506 -- Parsed by P_Component_Items (3.8)
3508 -------------------------
3509 -- 3.8.1 Variant Part --
3510 -------------------------
3513 -- case discriminant_DIRECT_NAME is
3518 -- The caller has checked that the initial token is CASE
3520 -- Error recovery: cannot raise Error_Resync
3522 function P_Variant_Part
return Node_Id
is
3523 Variant_Part_Node
: Node_Id
;
3524 Variants_List
: List_Id
;
3525 Case_Node
: Node_Id
;
3528 Variant_Part_Node
:= New_Node
(N_Variant_Part
, Token_Ptr
);
3530 Scope
.Table
(Scope
.Last
).Etyp
:= E_Case
;
3531 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
3532 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
3535 Case_Node
:= P_Expression
;
3536 Set_Name
(Variant_Part_Node
, Case_Node
);
3538 if Nkind
(Case_Node
) /= N_Identifier
then
3539 Set_Name
(Variant_Part_Node
, Error
);
3540 Error_Msg
("discriminant name expected", Sloc
(Case_Node
));
3542 elsif Paren_Count
(Case_Node
) /= 0 then
3544 ("|discriminant name may not be parenthesized",
3546 Set_Paren_Count
(Case_Node
, 0);
3550 Variants_List
:= New_List
;
3551 P_Pragmas_Opt
(Variants_List
);
3553 -- Test missing variant
3555 if Token
= Tok_End
then
3556 Error_Msg_BC
("WHEN expected (must have at least one variant)");
3558 Append
(P_Variant
, Variants_List
);
3561 -- Loop through variants, note that we allow if in place of when,
3562 -- this error will be detected and handled in P_Variant.
3565 P_Pragmas_Opt
(Variants_List
);
3567 if Token
/= Tok_When
3568 and then Token
/= Tok_If
3569 and then Token
/= Tok_Others
3571 exit when Check_End
;
3574 Append
(P_Variant
, Variants_List
);
3577 Set_Variants
(Variant_Part_Node
, Variants_List
);
3578 return Variant_Part_Node
;
3581 --------------------
3583 --------------------
3586 -- when DISCRETE_CHOICE_LIST =>
3589 -- Error recovery: cannot raise Error_Resync
3591 -- The initial token on entry is either WHEN, IF or OTHERS
3593 function P_Variant
return Node_Id
is
3594 Variant_Node
: Node_Id
;
3597 -- Special check to recover nicely from use of IF in place of WHEN
3599 if Token
= Tok_If
then
3606 Variant_Node
:= New_Node
(N_Variant
, Prev_Token_Ptr
);
3607 Set_Discrete_Choices
(Variant_Node
, P_Discrete_Choice_List
);
3609 Set_Component_List
(Variant_Node
, P_Component_List
);
3610 return Variant_Node
;
3613 ---------------------------------
3614 -- 3.8.1 Discrete Choice List --
3615 ---------------------------------
3617 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
3619 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
3621 -- Note: in Ada 83, the expression must be a simple expression
3623 -- Error recovery: cannot raise Error_Resync
3625 function P_Discrete_Choice_List
return List_Id
is
3627 Expr_Node
: Node_Id
;
3628 Choice_Node
: Node_Id
;
3631 Choices
:= New_List
;
3633 if Token
= Tok_Others
then
3634 Append
(New_Node
(N_Others_Choice
, Token_Ptr
), Choices
);
3635 Scan
; -- past OTHERS
3639 -- Scan out expression or range attribute
3641 Expr_Node
:= P_Expression_Or_Range_Attribute
;
3642 Ignore
(Tok_Right_Paren
);
3644 if Token
= Tok_Colon
3645 and then Nkind
(Expr_Node
) = N_Identifier
3647 Error_Msg_SP
("label not permitted in this context");
3652 elsif Expr_Form
= EF_Range_Attr
then
3653 Append
(Expr_Node
, Choices
);
3657 elsif Token
= Tok_Dot_Dot
then
3658 Check_Simple_Expression
(Expr_Node
);
3659 Choice_Node
:= New_Node
(N_Range
, Token_Ptr
);
3660 Set_Low_Bound
(Choice_Node
, Expr_Node
);
3662 Expr_Node
:= P_Expression_No_Right_Paren
;
3663 Check_Simple_Expression
(Expr_Node
);
3664 Set_High_Bound
(Choice_Node
, Expr_Node
);
3665 Append
(Choice_Node
, Choices
);
3667 -- Simple name, must be subtype, so range allowed
3669 elsif Expr_Form
= EF_Simple_Name
then
3670 if Token
= Tok_Range
then
3671 Append
(P_Subtype_Indication
(Expr_Node
), Choices
);
3673 elsif Token
in Token_Class_Consk
then
3675 ("the only constraint allowed here " &
3676 "is a range constraint");
3677 Discard_Junk_Node
(P_Constraint_Opt
);
3678 Append
(Expr_Node
, Choices
);
3681 Append
(Expr_Node
, Choices
);
3687 -- In Ada 2012 mode, the expression must be a simple
3688 -- expression. The reason for this restriction (i.e. going
3689 -- back to the Ada 83 rule) is to avoid ambiguities when set
3690 -- membership operations are allowed, consider the
3693 -- when A in 1 .. 10 | 12 =>
3695 -- This is ambiguous without parentheses, so we require one
3696 -- of the following two parenthesized forms to disambiguate:
3698 -- one of the following:
3700 -- when (A in 1 .. 10 | 12) =>
3701 -- when (A in 1 .. 10) | 12 =>
3703 -- To solve this, in Ada 2012 mode, we disallow the use of
3704 -- membership operations in expressions in choices.
3706 -- Technically in the grammar, the expression must match the
3707 -- grammar for restricted expression.
3709 if Ada_Version
>= Ada_2012
then
3710 Check_Restricted_Expression
(Expr_Node
);
3712 -- In Ada 83 mode, the syntax required a simple expression
3715 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
3718 Append
(Expr_Node
, Choices
);
3722 when Error_Resync
=>
3728 if Token
= Tok_Comma
then
3731 if Token
= Tok_Vertical_Bar
then
3732 Error_Msg_SP
-- CODEFIX
3733 ("|extra "","" ignored");
3737 Error_Msg_SP
-- CODEFIX
3738 (""","" should be ""'|""");
3742 exit when Token
/= Tok_Vertical_Bar
;
3749 end P_Discrete_Choice_List
;
3751 ----------------------------
3752 -- 3.8.1 Discrete Choice --
3753 ----------------------------
3755 -- Parsed by P_Discrete_Choice_List (3.8.1)
3757 ----------------------------------
3758 -- 3.9.1 Record Extension Part --
3759 ----------------------------------
3761 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
3763 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
3765 --------------------------------------
3766 -- 3.9.4 Interface Type Definition --
3767 --------------------------------------
3769 -- INTERFACE_TYPE_DEFINITION ::=
3770 -- [limited | task | protected | synchronized] interface
3771 -- [and INTERFACE_LIST]
3773 -- Error recovery: cannot raise Error_Resync
3775 function P_Interface_Type_Definition
3776 (Abstract_Present
: Boolean) return Node_Id
3778 Typedef_Node
: Node_Id
;
3781 if Ada_Version
< Ada_2005
then
3782 Error_Msg_SP
("abstract interface is an Ada 2005 extension");
3783 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
3786 if Abstract_Present
then
3788 ("ABSTRACT not allowed in interface type definition " &
3792 Scan
; -- past INTERFACE
3794 -- Ada 2005 (AI-345): In case of interfaces with a null list of
3795 -- interfaces we build a record_definition node.
3797 if Token
= Tok_Semicolon
or else Aspect_Specifications_Present
then
3798 Typedef_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
3800 Set_Abstract_Present
(Typedef_Node
);
3801 Set_Tagged_Present
(Typedef_Node
);
3802 Set_Null_Present
(Typedef_Node
);
3803 Set_Interface_Present
(Typedef_Node
);
3805 -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have
3806 -- a list of interfaces we build a derived_type_definition node. This
3807 -- simplifies the semantic analysis (and hence further maintenance)
3810 if Token
/= Tok_And
then
3811 Error_Msg_AP
("AND expected");
3816 Typedef_Node
:= New_Node
(N_Derived_Type_Definition
, Token_Ptr
);
3818 Set_Abstract_Present
(Typedef_Node
);
3819 Set_Interface_Present
(Typedef_Node
);
3820 Set_Subtype_Indication
(Typedef_Node
, P_Qualified_Simple_Name
);
3822 Set_Record_Extension_Part
(Typedef_Node
,
3823 New_Node
(N_Record_Definition
, Token_Ptr
));
3824 Set_Null_Present
(Record_Extension_Part
(Typedef_Node
));
3826 if Token
= Tok_And
then
3827 Set_Interface_List
(Typedef_Node
, New_List
);
3831 Append
(P_Qualified_Simple_Name
,
3832 Interface_List
(Typedef_Node
));
3833 exit when Token
/= Tok_And
;
3839 return Typedef_Node
;
3840 end P_Interface_Type_Definition
;
3842 ----------------------------------
3843 -- 3.10 Access Type Definition --
3844 ----------------------------------
3846 -- ACCESS_TYPE_DEFINITION ::=
3847 -- ACCESS_TO_OBJECT_DEFINITION
3848 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3850 -- ACCESS_TO_OBJECT_DEFINITION ::=
3851 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
3853 -- GENERAL_ACCESS_MODIFIER ::= all | constant
3855 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3856 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3857 -- | [NULL_EXCLUSION] access [protected] function
3858 -- PARAMETER_AND_RESULT_PROFILE
3860 -- PARAMETER_PROFILE ::= [FORMAL_PART]
3862 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
3864 -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already
3865 -- parsed the null_exclusion part and has also removed the ACCESS token;
3866 -- otherwise the caller has just checked that the initial token is ACCESS
3868 -- Error recovery: can raise Error_Resync
3870 function P_Access_Type_Definition
3871 (Header_Already_Parsed
: Boolean := False) return Node_Id
3873 Access_Loc
: constant Source_Ptr
:= Token_Ptr
;
3874 Prot_Flag
: Boolean;
3875 Not_Null_Present
: Boolean := False;
3876 Type_Def_Node
: Node_Id
;
3877 Result_Not_Null
: Boolean;
3878 Result_Node
: Node_Id
;
3880 procedure Check_Junk_Subprogram_Name
;
3881 -- Used in access to subprogram definition cases to check for an
3882 -- identifier or operator symbol that does not belong.
3884 --------------------------------
3885 -- Check_Junk_Subprogram_Name --
3886 --------------------------------
3888 procedure Check_Junk_Subprogram_Name
is
3889 Saved_State
: Saved_Scan_State
;
3892 if Token
= Tok_Identifier
or else Token
= Tok_Operator_Symbol
then
3893 Save_Scan_State
(Saved_State
);
3894 Scan
; -- past possible junk subprogram name
3896 if Token
= Tok_Left_Paren
or else Token
= Tok_Semicolon
then
3897 Error_Msg_SP
("unexpected subprogram name ignored");
3901 Restore_Scan_State
(Saved_State
);
3904 end Check_Junk_Subprogram_Name
;
3906 -- Start of processing for P_Access_Type_Definition
3909 if not Header_Already_Parsed
then
3910 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
3911 Scan
; -- past ACCESS
3914 if Token_Name
= Name_Protected
then
3915 Check_95_Keyword
(Tok_Protected
, Tok_Procedure
);
3916 Check_95_Keyword
(Tok_Protected
, Tok_Function
);
3919 Prot_Flag
:= (Token
= Tok_Protected
);
3922 Scan
; -- past PROTECTED
3924 if Token
/= Tok_Procedure
and then Token
/= Tok_Function
then
3925 Error_Msg_SC
-- CODEFIX
3926 ("FUNCTION or PROCEDURE expected");
3930 if Token
= Tok_Procedure
then
3931 if Ada_Version
= Ada_83
then
3932 Error_Msg_SC
("(Ada 83) access to procedure not allowed!");
3935 Type_Def_Node
:= New_Node
(N_Access_Procedure_Definition
, Access_Loc
);
3936 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3937 Scan
; -- past PROCEDURE
3938 Check_Junk_Subprogram_Name
;
3939 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
3940 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
3942 elsif Token
= Tok_Function
then
3943 if Ada_Version
= Ada_83
then
3944 Error_Msg_SC
("(Ada 83) access to function not allowed!");
3947 Type_Def_Node
:= New_Node
(N_Access_Function_Definition
, Access_Loc
);
3948 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3949 Scan
; -- past FUNCTION
3950 Check_Junk_Subprogram_Name
;
3951 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
3952 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
3955 Result_Not_Null
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
3957 -- Ada 2005 (AI-318-02)
3959 if Token
= Tok_Access
then
3960 if Ada_Version
< Ada_2005
then
3962 ("anonymous access result type is an Ada 2005 extension");
3963 Error_Msg_SC
("\unit must be compiled with -gnat05 switch");
3966 Result_Node
:= P_Access_Definition
(Result_Not_Null
);
3969 Result_Node
:= P_Subtype_Mark
;
3972 -- A null exclusion on the result type must be recorded in a flag
3973 -- distinct from the one used for the access-to-subprogram type's
3976 Set_Null_Exclusion_In_Return_Present
3977 (Type_Def_Node
, Result_Not_Null
);
3980 Set_Result_Definition
(Type_Def_Node
, Result_Node
);
3984 New_Node
(N_Access_To_Object_Definition
, Access_Loc
);
3985 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3987 if Token
= Tok_All
or else Token
= Tok_Constant
then
3988 if Ada_Version
= Ada_83
then
3989 Error_Msg_SC
("(Ada 83) access modifier not allowed!");
3992 if Token
= Tok_All
then
3993 Set_All_Present
(Type_Def_Node
, True);
3996 Set_Constant_Present
(Type_Def_Node
, True);
3999 Scan
; -- past ALL or CONSTANT
4002 Set_Subtype_Indication
(Type_Def_Node
,
4003 P_Subtype_Indication
(Not_Null_Present
));
4006 return Type_Def_Node
;
4007 end P_Access_Type_Definition
;
4009 ---------------------------------------
4010 -- 3.10 Access To Object Definition --
4011 ---------------------------------------
4013 -- Parsed by P_Access_Type_Definition (3.10)
4015 -----------------------------------
4016 -- 3.10 General Access Modifier --
4017 -----------------------------------
4019 -- Parsed by P_Access_Type_Definition (3.10)
4021 -------------------------------------------
4022 -- 3.10 Access To Subprogram Definition --
4023 -------------------------------------------
4025 -- Parsed by P_Access_Type_Definition (3.10)
4027 -----------------------------
4028 -- 3.10 Access Definition --
4029 -----------------------------
4031 -- ACCESS_DEFINITION ::=
4032 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
4033 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
4035 -- ACCESS_TO_SUBPROGRAM_DEFINITION
4036 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
4037 -- | [NULL_EXCLUSION] access [protected] function
4038 -- PARAMETER_AND_RESULT_PROFILE
4040 -- The caller has parsed the null-exclusion part and it has also checked
4041 -- that the next token is ACCESS
4043 -- Error recovery: cannot raise Error_Resync
4045 function P_Access_Definition
4046 (Null_Exclusion_Present
: Boolean) return Node_Id
4049 Subp_Node
: Node_Id
;
4052 Def_Node
:= New_Node
(N_Access_Definition
, Token_Ptr
);
4053 Scan
; -- past ACCESS
4055 -- Ada 2005 (AI-254): Access_To_Subprogram_Definition
4057 if Token
= Tok_Protected
4058 or else Token
= Tok_Procedure
4059 or else Token
= Tok_Function
4061 if Ada_Version
< Ada_2005
then
4062 Error_Msg_SP
("access-to-subprogram is an Ada 2005 extension");
4063 Error_Msg_SP
("\unit should be compiled with -gnat05 switch");
4066 Subp_Node
:= P_Access_Type_Definition
(Header_Already_Parsed
=> True);
4067 Set_Null_Exclusion_Present
(Subp_Node
, Null_Exclusion_Present
);
4068 Set_Access_To_Subprogram_Definition
(Def_Node
, Subp_Node
);
4070 -- Ada 2005 (AI-231)
4071 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
4074 Set_Null_Exclusion_Present
(Def_Node
, Null_Exclusion_Present
);
4076 if Token
= Tok_All
then
4077 if Ada_Version
< Ada_2005
then
4079 ("ALL is not permitted for anonymous access types");
4083 Set_All_Present
(Def_Node
);
4085 elsif Token
= Tok_Constant
then
4086 if Ada_Version
< Ada_2005
then
4087 Error_Msg_SP
("access-to-constant is an Ada 2005 extension");
4088 Error_Msg_SP
("\unit should be compiled with -gnat05 switch");
4091 Scan
; -- past CONSTANT
4092 Set_Constant_Present
(Def_Node
);
4095 Set_Subtype_Mark
(Def_Node
, P_Subtype_Mark
);
4100 end P_Access_Definition
;
4102 -----------------------------------------
4103 -- 3.10.1 Incomplete Type Declaration --
4104 -----------------------------------------
4106 -- Parsed by P_Type_Declaration (3.2.1)
4108 ----------------------------
4109 -- 3.11 Declarative Part --
4110 ----------------------------
4112 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
4114 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items
4115 -- handles errors, and returns cleanly after an error has occurred)
4117 function P_Declarative_Part
return List_Id
is
4122 -- Indicate no bad declarations detected yet. This will be reset by
4123 -- P_Declarative_Items if a bad declaration is discovered.
4125 Missing_Begin_Msg
:= No_Error_Msg
;
4127 -- Get rid of active SIS entry from outer scope. This means we will
4128 -- miss some nested cases, but it doesn't seem worth the effort. See
4129 -- discussion in Par for further details
4131 SIS_Entry_Active
:= False;
4134 -- Loop to scan out the declarations
4137 P_Declarative_Items
(Decls
, Done
, In_Spec
=> False);
4141 -- Get rid of active SIS entry which is left set only if we scanned a
4142 -- procedure declaration and have not found the body. We could give
4143 -- an error message, but that really would be usurping the role of
4144 -- semantic analysis (this really is a missing body case).
4146 SIS_Entry_Active
:= False;
4148 end P_Declarative_Part
;
4150 ----------------------------
4151 -- 3.11 Declarative Item --
4152 ----------------------------
4154 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
4156 -- Can return Error if a junk declaration is found, or Empty if no
4157 -- declaration is found (i.e. a token ending declarations, such as
4158 -- BEGIN or END is encountered).
4160 -- Error recovery: cannot raise Error_Resync. If an error resync occurs,
4161 -- then the scan is set past the next semicolon and Error is returned.
4163 procedure P_Declarative_Items
4168 Scan_State
: Saved_Scan_State
;
4172 Style
.Check_Indentation
;
4177 when Tok_Function
=>
4179 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4185 -- Check for loop (premature statement)
4187 Save_Scan_State
(Scan_State
);
4190 if Token
= Tok_Identifier
then
4191 Scan
; -- past identifier
4193 if Token
= Tok_In
then
4194 Restore_Scan_State
(Scan_State
);
4195 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4200 -- Not a loop, so must be rep clause
4202 Restore_Scan_State
(Scan_State
);
4203 Append
(P_Representation_Clause
, Decls
);
4208 Append
(P_Generic
, Decls
);
4211 when Tok_Identifier
=>
4214 -- Special check for misuse of overriding not in Ada 2005 mode
4216 if Token_Name
= Name_Overriding
4217 and then not Next_Token_Is
(Tok_Colon
)
4219 Error_Msg_SC
("overriding indicator is an Ada 2005 extension");
4220 Error_Msg_SC
("\unit must be compiled with -gnat05 switch");
4222 Token
:= Tok_Overriding
;
4223 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4226 -- Normal case, no overriding, or overriding followed by colon
4229 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4232 -- Ada 2005: A subprogram declaration can start with "not" or
4233 -- "overriding". In older versions, "overriding" is handled
4234 -- like an identifier, with the appropriate messages.
4238 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4241 when Tok_Overriding
=>
4243 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4248 Append
(P_Package
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4252 Append
(P_Pragma
, Decls
);
4255 when Tok_Procedure
=>
4257 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4260 when Tok_Protected
=>
4262 Scan
; -- past PROTECTED
4263 Append
(P_Protected
, Decls
);
4268 Append
(P_Subtype_Declaration
, Decls
);
4274 Append
(P_Task
, Decls
);
4279 Append
(P_Type_Declaration
, Decls
);
4284 Append
(P_Use_Clause
, Decls
);
4290 if Aspect_Specifications_Present
then
4292 -- If we are after a semicolon, complain that it was ignored.
4293 -- But we don't really ignore it, since we dump the aspects,
4294 -- so we make the error message a normal fatal message which
4295 -- will inhibit semantic analysis anyway).
4297 if Prev_Token
= Tok_Semicolon
then
4298 Error_Msg_SP
-- CODEFIX
4299 ("extra "";"" ignored");
4301 -- If not just past semicolon, just complain that aspects are
4302 -- not allowed at this point.
4305 Error_Msg_SC
("aspect specifications not allowed here");
4309 Dummy_Node
: constant Node_Id
:=
4310 New_Node
(N_Package_Specification
, Token_Ptr
);
4311 pragma Warnings
(Off
, Dummy_Node
);
4312 -- Dummy node to attach aspect specifications to. We will
4313 -- then throw them away.
4316 P_Aspect_Specifications
(Dummy_Node
, Semicolon
=> True);
4319 -- Here if not aspect specifications case
4322 Error_Msg_SC
("WITH can only appear in context clause");
4326 -- BEGIN terminates the scan of a sequence of declarations unless
4327 -- there is a missing subprogram body, see section on handling
4328 -- semicolon in place of IS. We only treat the begin as satisfying
4329 -- the subprogram declaration if it falls in the expected column
4333 if SIS_Entry_Active
and then Start_Column
>= SIS_Ecol
then
4335 -- Here we have the case where a BEGIN is encountered during
4336 -- declarations in a declarative part, or at the outer level,
4337 -- and there is a subprogram declaration outstanding for which
4338 -- no body has been supplied. This is the case where we assume
4339 -- that the semicolon in the subprogram declaration should
4340 -- really have been is. The active SIS entry describes the
4341 -- subprogram declaration. On return the declaration has been
4342 -- modified to become a body.
4345 Specification_Node
: Node_Id
;
4346 Decl_Node
: Node_Id
;
4347 Body_Node
: Node_Id
;
4350 -- First issue the error message. If we had a missing
4351 -- semicolon in the declaration, then change the message
4352 -- to <missing "is">
4354 if SIS_Missing_Semicolon_Message
/= No_Error_Msg
then
4355 Change_Error_Text
-- Replace: "missing "";"" "
4356 (SIS_Missing_Semicolon_Message
, "missing ""is""");
4358 -- Otherwise we saved the semicolon position, so complain
4361 Error_Msg
-- CODEFIX
4362 ("|"";"" should be IS", SIS_Semicolon_Sloc
);
4365 -- The next job is to fix up any declarations that occurred
4366 -- between the procedure header and the BEGIN. These got
4367 -- chained to the outer declarative region (immediately
4368 -- after the procedure declaration) and they should be
4369 -- chained to the subprogram itself, which is a body
4370 -- rather than a spec.
4372 Specification_Node
:= Specification
(SIS_Declaration_Node
);
4373 Change_Node
(SIS_Declaration_Node
, N_Subprogram_Body
);
4374 Body_Node
:= SIS_Declaration_Node
;
4375 Set_Specification
(Body_Node
, Specification_Node
);
4376 Set_Declarations
(Body_Node
, New_List
);
4379 Decl_Node
:= Remove_Next
(Body_Node
);
4380 exit when Decl_Node
= Empty
;
4381 Append
(Decl_Node
, Declarations
(Body_Node
));
4384 -- Now make the scope table entry for the Begin-End and
4388 Scope
.Table
(Scope
.Last
).Sloc
:= SIS_Sloc
;
4389 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
4390 Scope
.Table
(Scope
.Last
).Ecol
:= SIS_Ecol
;
4391 Scope
.Table
(Scope
.Last
).Labl
:= SIS_Labl
;
4392 Scope
.Table
(Scope
.Last
).Lreq
:= False;
4393 SIS_Entry_Active
:= False;
4395 Set_Handled_Statement_Sequence
(Body_Node
,
4396 P_Handled_Sequence_Of_Statements
);
4397 End_Statements
(Handled_Statement_Sequence
(Body_Node
));
4406 -- Normally an END terminates the scan for basic declarative items.
4407 -- The one exception is END RECORD, which is probably left over from
4411 Save_Scan_State
(Scan_State
); -- at END
4414 if Token
= Tok_Record
then
4415 Error_Msg_SP
("no RECORD for this `end record`!");
4416 Scan
; -- past RECORD
4420 Restore_Scan_State
(Scan_State
); -- to END
4424 -- The following tokens which can only be the start of a statement
4425 -- are considered to end a declarative part (i.e. we have a missing
4426 -- BEGIN situation). We are fairly conservative in making this
4427 -- judgment, because it is a real mess to go into statement mode
4428 -- prematurely in response to a junk declaration.
4443 -- But before we decide that it's a statement, let's check for
4444 -- a reserved word misused as an identifier.
4446 if Is_Reserved_Identifier
then
4447 Save_Scan_State
(Scan_State
);
4448 Scan
; -- past the token
4450 -- If reserved identifier not followed by colon or comma, then
4451 -- this is most likely an assignment statement to the bad id.
4453 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
4454 Restore_Scan_State
(Scan_State
);
4455 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4458 -- Otherwise we have a declaration of the bad id
4461 Restore_Scan_State
(Scan_State
);
4462 Scan_Reserved_Identifier
(Force_Msg
=> True);
4463 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4466 -- If not reserved identifier, then it's definitely a statement
4469 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4473 -- The token RETURN may well also signal a missing BEGIN situation,
4474 -- however, we never let it end the declarative part, because it may
4475 -- also be part of a half-baked function declaration.
4478 Error_Msg_SC
("misplaced RETURN statement");
4481 -- PRIVATE definitely terminates the declarations in a spec,
4482 -- and is an error in a body.
4488 Error_Msg_SC
("PRIVATE not allowed in body");
4489 Scan
; -- past PRIVATE
4492 -- An end of file definitely terminates the declarations!
4497 -- The remaining tokens do not end the scan, but cannot start a
4498 -- valid declaration, so we signal an error and resynchronize.
4499 -- But first check for misuse of a reserved identifier.
4503 -- Here we check for a reserved identifier
4505 if Is_Reserved_Identifier
then
4506 Save_Scan_State
(Scan_State
);
4507 Scan
; -- past the token
4509 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
4510 Restore_Scan_State
(Scan_State
);
4511 Set_Declaration_Expected
;
4514 Restore_Scan_State
(Scan_State
);
4515 Scan_Reserved_Identifier
(Force_Msg
=> True);
4517 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4521 Set_Declaration_Expected
;
4526 -- To resynchronize after an error, we scan to the next semicolon and
4527 -- return with Done = False, indicating that there may still be more
4528 -- valid declarations to come.
4531 when Error_Resync
=>
4532 Resync_Past_Semicolon
;
4534 end P_Declarative_Items
;
4536 ----------------------------------
4537 -- 3.11 Basic Declarative Item --
4538 ----------------------------------
4540 -- BASIC_DECLARATIVE_ITEM ::=
4541 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
4543 -- Scan zero or more basic declarative items
4545 -- Error recovery: cannot raise Error_Resync. If an error is detected, then
4546 -- the scan pointer is repositioned past the next semicolon, and the scan
4547 -- for declarative items continues.
4549 function P_Basic_Declarative_Items
return List_Id
is
4556 -- Indicate no bad declarations detected yet in the current context:
4557 -- visible or private declarations of a package spec.
4559 Missing_Begin_Msg
:= No_Error_Msg
;
4561 -- Get rid of active SIS entry from outer scope. This means we will
4562 -- miss some nested cases, but it doesn't seem worth the effort. See
4563 -- discussion in Par for further details
4565 SIS_Entry_Active
:= False;
4567 -- Loop to scan out declarations
4572 P_Declarative_Items
(Decls
, Done
, In_Spec
=> True);
4576 -- Get rid of active SIS entry. This is set only if we have scanned a
4577 -- procedure declaration and have not found the body. We could give
4578 -- an error message, but that really would be usurping the role of
4579 -- semantic analysis (this really is a case of a missing body).
4581 SIS_Entry_Active
:= False;
4583 -- Test for assorted illegal declarations not diagnosed elsewhere
4585 Decl
:= First
(Decls
);
4587 while Present
(Decl
) loop
4588 Kind
:= Nkind
(Decl
);
4590 -- Test for body scanned, not acceptable as basic decl item
4592 if Kind
= N_Subprogram_Body
or else
4593 Kind
= N_Package_Body
or else
4594 Kind
= N_Task_Body
or else
4595 Kind
= N_Protected_Body
4597 Error_Msg
("proper body not allowed in package spec", Sloc
(Decl
));
4599 -- Test for body stub scanned, not acceptable as basic decl item
4601 elsif Kind
in N_Body_Stub
then
4602 Error_Msg
("body stub not allowed in package spec", Sloc
(Decl
));
4604 elsif Kind
= N_Assignment_Statement
then
4606 ("assignment statement not allowed in package spec",
4614 end P_Basic_Declarative_Items
;
4620 -- For proper body, see below
4621 -- For body stub, see 10.1.3
4623 -----------------------
4624 -- 3.11 Proper Body --
4625 -----------------------
4627 -- Subprogram body is parsed by P_Subprogram (6.1)
4628 -- Package body is parsed by P_Package (7.1)
4629 -- Task body is parsed by P_Task (9.1)
4630 -- Protected body is parsed by P_Protected (9.4)
4632 ------------------------------
4633 -- Set_Declaration_Expected --
4634 ------------------------------
4636 procedure Set_Declaration_Expected
is
4638 Error_Msg_SC
("declaration expected");
4640 if Missing_Begin_Msg
= No_Error_Msg
then
4641 Missing_Begin_Msg
:= Get_Msg_Id
;
4643 end Set_Declaration_Expected
;
4645 ----------------------
4646 -- Skip_Declaration --
4647 ----------------------
4649 procedure Skip_Declaration
(S
: List_Id
) is
4650 Dummy_Done
: Boolean;
4651 pragma Warnings
(Off
, Dummy_Done
);
4653 P_Declarative_Items
(S
, Dummy_Done
, False);
4654 end Skip_Declaration
;
4656 -----------------------------------------
4657 -- Statement_When_Declaration_Expected --
4658 -----------------------------------------
4660 procedure Statement_When_Declaration_Expected
4666 -- Case of second occurrence of statement in one declaration sequence
4668 if Missing_Begin_Msg
/= No_Error_Msg
then
4670 -- In the procedure spec case, just ignore it, we only give one
4671 -- message for the first occurrence, since otherwise we may get
4672 -- horrible cascading if BODY was missing in the header line.
4677 -- In the declarative part case, take a second statement as a sure
4678 -- sign that we really have a missing BEGIN, and end the declarative
4679 -- part now. Note that the caller will fix up the first message to
4680 -- say "missing BEGIN" so that's how the error will be signalled.
4687 -- Case of first occurrence of unexpected statement
4690 -- If we are in a package spec, then give message of statement
4691 -- not allowed in package spec. This message never gets changed.
4694 Error_Msg_SC
("statement not allowed in package spec");
4696 -- If in declarative part, then we give the message complaining
4697 -- about finding a statement when a declaration is expected. This
4698 -- gets changed to a complaint about a missing BEGIN if we later
4699 -- find that no BEGIN is present.
4702 Error_Msg_SC
("statement not allowed in declarative part");
4705 -- Capture message Id. This is used for two purposes, first to
4706 -- stop multiple messages, see test above, and second, to allow
4707 -- the replacement of the message in the declarative part case.
4709 Missing_Begin_Msg
:= Get_Msg_Id
;
4712 -- In all cases except the case in which we decided to terminate the
4713 -- declaration sequence on a second error, we scan out the statement
4714 -- and append it to the list of declarations (note that the semantics
4715 -- can handle statements in a declaration list so if we proceed to
4716 -- call the semantic phase, all will be (reasonably) well!
4718 Append_List_To
(Decls
, P_Sequence_Of_Statements
(SS_Unco
));
4720 -- Done is set to False, since we want to continue the scan of
4721 -- declarations, hoping that this statement was a temporary glitch.
4722 -- If we indeed are now in the statement part (i.e. this was a missing
4723 -- BEGIN, then it's not terrible, we will simply keep calling this
4724 -- procedure to process the statements one by one, and then finally
4725 -- hit the missing BEGIN, which will clean up the error message.
4728 end Statement_When_Declaration_Expected
;