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
);
247 -- Warn if standard redefinition, except that we never warn on a
248 -- record field definition (since this is always a harmless case).
250 if not Inside_Record_Definition
then
251 Warn_If_Standard_Redefinition
(Ident_Node
);
256 end P_Defining_Identifier
;
258 -----------------------------
259 -- 3.2.1 Type Declaration --
260 -----------------------------
262 -- TYPE_DECLARATION ::=
263 -- FULL_TYPE_DECLARATION
264 -- | INCOMPLETE_TYPE_DECLARATION
265 -- | PRIVATE_TYPE_DECLARATION
266 -- | PRIVATE_EXTENSION_DECLARATION
268 -- FULL_TYPE_DECLARATION ::=
269 -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION
270 -- [ASPECT_SPECIFICATIONS];
271 -- | CONCURRENT_TYPE_DECLARATION
273 -- INCOMPLETE_TYPE_DECLARATION ::=
274 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [is tagged];
276 -- PRIVATE_TYPE_DECLARATION ::=
277 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
278 -- is [abstract] [tagged] [limited] private;
280 -- PRIVATE_EXTENSION_DECLARATION ::=
281 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
282 -- [abstract] [limited | synchronized]
283 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
286 -- TYPE_DEFINITION ::=
287 -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
288 -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION
289 -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION
290 -- | DERIVED_TYPE_DEFINITION | INTERFACE_TYPE_DEFINITION
292 -- INTEGER_TYPE_DEFINITION ::=
293 -- SIGNED_INTEGER_TYPE_DEFINITION
294 -- MODULAR_TYPE_DEFINITION
296 -- INTERFACE_TYPE_DEFINITION ::=
297 -- [limited | task | protected | synchronized ] interface
298 -- [and INTERFACE_LIST]
300 -- Error recovery: can raise Error_Resync
302 -- The processing for full type declarations, incomplete type declarations,
303 -- private type declarations and type definitions is included in this
304 -- function. The processing for concurrent type declarations is NOT here,
305 -- but rather in chapter 9 (this function handles only declarations
306 -- starting with TYPE).
308 function P_Type_Declaration
return Node_Id
is
309 Abstract_Present
: Boolean := False;
310 Abstract_Loc
: Source_Ptr
:= No_Location
;
312 Discr_List
: List_Id
;
313 Discr_Sloc
: Source_Ptr
;
315 Ident_Node
: Node_Id
;
316 Is_Derived_Iface
: Boolean := False;
317 Type_Loc
: Source_Ptr
;
318 Type_Start_Col
: Column_Number
;
319 Unknown_Dis
: Boolean;
321 Typedef_Node
: Node_Id
;
322 -- Normally holds type definition, except in the case of a private
323 -- extension declaration, in which case it holds the declaration itself
326 Type_Loc
:= Token_Ptr
;
327 Type_Start_Col
:= Start_Column
;
329 -- If we have TYPE, then proceed ahead and scan identifier
331 if Token
= Tok_Type
then
332 Type_Token_Location
:= Type_Loc
;
334 Ident_Node
:= P_Defining_Identifier
(C_Is
);
336 -- Otherwise this is an error case
340 Type_Token_Location
:= Type_Loc
;
341 Ident_Node
:= P_Defining_Identifier
(C_Is
);
344 Discr_Sloc
:= Token_Ptr
;
346 if P_Unknown_Discriminant_Part_Opt
then
348 Discr_List
:= No_List
;
350 Unknown_Dis
:= False;
351 Discr_List
:= P_Known_Discriminant_Part_Opt
;
354 -- Incomplete type declaration. We complete the processing for this
355 -- case here and return the resulting incomplete type declaration node
357 if Token
= Tok_Semicolon
then
359 Decl_Node
:= New_Node
(N_Incomplete_Type_Declaration
, Type_Loc
);
360 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
361 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
362 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
369 -- Full type declaration or private type declaration, must have IS
371 if Token
= Tok_Equal
then
373 Scan
; -- past = used in place of IS
375 elsif Token
= Tok_Renames
then
376 Error_Msg_SC
-- CODEFIX
377 ("RENAMES should be IS");
378 Scan
; -- past RENAMES used in place of IS
384 -- First an error check, if we have two identifiers in a row, a likely
385 -- possibility is that the first of the identifiers is an incorrectly
388 if Token
= Tok_Identifier
then
390 SS
: Saved_Scan_State
;
394 Save_Scan_State
(SS
);
395 Scan
; -- past initial identifier
396 I2
:= (Token
= Tok_Identifier
);
397 Restore_Scan_State
(SS
);
401 (Bad_Spelling_Of
(Tok_Abstract
) or else
402 Bad_Spelling_Of
(Tok_Access
) or else
403 Bad_Spelling_Of
(Tok_Aliased
) or else
404 Bad_Spelling_Of
(Tok_Constant
))
411 -- Check for misuse of Ada 95 keyword abstract in Ada 83 mode
413 if Token_Name
= Name_Abstract
then
414 Check_95_Keyword
(Tok_Abstract
, Tok_Tagged
);
415 Check_95_Keyword
(Tok_Abstract
, Tok_New
);
418 -- Check cases of misuse of ABSTRACT
420 if Token
= Tok_Abstract
then
421 Abstract_Present
:= True;
422 Abstract_Loc
:= Token_Ptr
;
423 Scan
; -- past ABSTRACT
425 -- Ada 2005 (AI-419): AARM 3.4 (2/2)
427 if (Ada_Version
< Ada_2005
and then Token
= Tok_Limited
)
428 or else Token
= Tok_Private
429 or else Token
= Tok_Record
430 or else Token
= Tok_Null
432 Error_Msg_AP
("TAGGED expected");
436 -- Check for misuse of Ada 95 keyword Tagged
438 if Token_Name
= Name_Tagged
then
439 Check_95_Keyword
(Tok_Tagged
, Tok_Private
);
440 Check_95_Keyword
(Tok_Tagged
, Tok_Limited
);
441 Check_95_Keyword
(Tok_Tagged
, Tok_Record
);
444 -- Special check for misuse of Aliased
446 if Token
= Tok_Aliased
or else Token_Name
= Name_Aliased
then
447 Error_Msg_SC
("ALIASED not allowed in type definition");
448 Scan
; -- past ALIASED
451 -- The following processing deals with either a private type declaration
452 -- or a full type declaration. In the private type case, we build the
453 -- N_Private_Type_Declaration node, setting its Tagged_Present and
454 -- Limited_Present flags, on encountering the Private keyword, and
455 -- leave Typedef_Node set to Empty. For the full type declaration
456 -- case, Typedef_Node gets set to the type definition.
458 Typedef_Node
:= Empty
;
460 -- Switch on token following the IS. The loop normally runs once. It
461 -- only runs more than once if an error is detected, to try again after
462 -- detecting and fixing up the error.
468 Tok_Not
=> -- Ada 2005 (AI-231)
469 Typedef_Node
:= P_Access_Type_Definition
;
473 Typedef_Node
:= P_Array_Type_Definition
;
477 Typedef_Node
:= P_Fixed_Point_Definition
;
481 Typedef_Node
:= P_Floating_Point_Definition
;
487 when Tok_Integer_Literal
=>
489 Typedef_Node
:= P_Signed_Integer_Type_Definition
;
493 Typedef_Node
:= P_Record_Definition
;
496 when Tok_Left_Paren
=>
497 Typedef_Node
:= P_Enumeration_Type_Definition
;
499 End_Labl
:= Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
500 Set_Comes_From_Source
(End_Labl
, False);
502 Set_End_Label
(Typedef_Node
, End_Labl
);
506 Typedef_Node
:= P_Modular_Type_Definition
;
510 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
512 if Nkind
(Typedef_Node
) = N_Derived_Type_Definition
513 and then Present
(Record_Extension_Part
(Typedef_Node
))
515 End_Labl
:= Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
516 Set_Comes_From_Source
(End_Labl
, False);
519 (Record_Extension_Part
(Typedef_Node
), End_Labl
);
525 Typedef_Node
:= P_Signed_Integer_Type_Definition
;
529 Typedef_Node
:= P_Record_Definition
;
531 End_Labl
:= Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
532 Set_Comes_From_Source
(End_Labl
, False);
534 Set_End_Label
(Typedef_Node
, End_Labl
);
540 -- Ada 2005 (AI-326): If the words IS TAGGED appear, the type
541 -- is a tagged incomplete type.
543 if Ada_Version
>= Ada_2005
544 and then Token
= Tok_Semicolon
549 New_Node
(N_Incomplete_Type_Declaration
, Type_Loc
);
550 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
551 Set_Tagged_Present
(Decl_Node
);
552 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
553 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
558 if Token
= Tok_Abstract
then
559 Error_Msg_SC
-- CODEFIX
560 ("ABSTRACT must come before TAGGED");
561 Abstract_Present
:= True;
562 Abstract_Loc
:= Token_Ptr
;
563 Scan
; -- past ABSTRACT
566 if Token
= Tok_Limited
then
567 Scan
; -- past LIMITED
569 -- TAGGED LIMITED PRIVATE case
571 if Token
= Tok_Private
then
573 New_Node
(N_Private_Type_Declaration
, Type_Loc
);
574 Set_Tagged_Present
(Decl_Node
, True);
575 Set_Limited_Present
(Decl_Node
, True);
576 Scan
; -- past PRIVATE
578 -- TAGGED LIMITED RECORD
581 Typedef_Node
:= P_Record_Definition
;
582 Set_Tagged_Present
(Typedef_Node
, True);
583 Set_Limited_Present
(Typedef_Node
, True);
586 Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
587 Set_Comes_From_Source
(End_Labl
, False);
589 Set_End_Label
(Typedef_Node
, End_Labl
);
595 if Token
= Tok_Private
then
597 New_Node
(N_Private_Type_Declaration
, Type_Loc
);
598 Set_Tagged_Present
(Decl_Node
, True);
599 Scan
; -- past PRIVATE
604 Typedef_Node
:= P_Record_Definition
;
605 Set_Tagged_Present
(Typedef_Node
, True);
608 Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
609 Set_Comes_From_Source
(End_Labl
, False);
611 Set_End_Label
(Typedef_Node
, End_Labl
);
618 Scan
; -- past LIMITED
621 if Token
= Tok_Tagged
then
622 Error_Msg_SC
-- CODEFIX
623 ("TAGGED must come before LIMITED");
626 elsif Token
= Tok_Abstract
then
627 Error_Msg_SC
-- CODEFIX
628 ("ABSTRACT must come before LIMITED");
629 Scan
; -- past ABSTRACT
636 -- LIMITED RECORD or LIMITED NULL RECORD
638 if Token
= Tok_Record
or else Token
= Tok_Null
then
639 if Ada_Version
= Ada_83
then
641 ("(Ada 83) limited record declaration not allowed!");
643 -- In Ada 2005, "abstract limited" can appear before "new",
644 -- but it cannot be part of an untagged record declaration.
646 elsif Abstract_Present
647 and then Prev_Token
/= Tok_Tagged
649 Error_Msg_SP
("TAGGED expected");
652 Typedef_Node
:= P_Record_Definition
;
653 Set_Limited_Present
(Typedef_Node
, True);
655 -- Ada 2005 (AI-251): LIMITED INTERFACE
657 -- If we are compiling in Ada 83 or Ada 95 mode, "interface"
658 -- is not a reserved word but we force its analysis to
659 -- generate the corresponding usage error.
661 elsif Token
= Tok_Interface
662 or else (Token
= Tok_Identifier
663 and then Chars
(Token_Node
) = Name_Interface
)
666 P_Interface_Type_Definition
(Abstract_Present
);
667 Abstract_Present
:= True;
668 Set_Limited_Present
(Typedef_Node
);
670 if Nkind
(Typedef_Node
) = N_Derived_Type_Definition
then
671 Is_Derived_Iface
:= True;
674 -- Ada 2005 (AI-419): LIMITED NEW
676 elsif Token
= Tok_New
then
677 if Ada_Version
< Ada_2005
then
679 ("LIMITED in derived type is an Ada 2005 extension");
681 ("\unit must be compiled with -gnat05 switch");
684 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
685 Set_Limited_Present
(Typedef_Node
);
687 if Nkind
(Typedef_Node
) = N_Derived_Type_Definition
688 and then Present
(Record_Extension_Part
(Typedef_Node
))
691 Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
692 Set_Comes_From_Source
(End_Labl
, False);
695 (Record_Extension_Part
(Typedef_Node
), End_Labl
);
698 -- LIMITED PRIVATE is the only remaining possibility here
701 Decl_Node
:= New_Node
(N_Private_Type_Declaration
, Type_Loc
);
702 Set_Limited_Present
(Decl_Node
, True);
703 T_Private
; -- past PRIVATE (or complain if not there!)
708 -- Here we have an identifier after the IS, which is certainly
709 -- wrong and which might be one of several different mistakes.
711 when Tok_Identifier
=>
713 -- First case, if identifier is on same line, then probably we
714 -- have something like "type X is Integer .." and the best
715 -- diagnosis is a missing NEW. Note: the missing new message
716 -- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl.
718 if not Token_Is_At_Start_Of_Line
then
719 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
721 -- If the identifier is at the start of the line, and is in the
722 -- same column as the type declaration itself then we consider
723 -- that we had a missing type definition on the previous line
725 elsif Start_Column
<= Type_Start_Col
then
726 Error_Msg_AP
("type definition expected");
727 Typedef_Node
:= Error
;
729 -- If the identifier is at the start of the line, and is in
730 -- a column to the right of the type declaration line, then we
731 -- may have something like:
736 -- and the best diagnosis is a missing record keyword
739 Typedef_Node
:= P_Record_Definition
;
744 -- Ada 2005 (AI-251): INTERFACE
746 when Tok_Interface
=>
747 Typedef_Node
:= P_Interface_Type_Definition
(Abstract_Present
);
748 Abstract_Present
:= True;
752 Decl_Node
:= New_Node
(N_Private_Type_Declaration
, Type_Loc
);
753 Scan
; -- past PRIVATE
755 -- Check error cases of private [abstract] tagged
757 if Token
= Tok_Abstract
then
758 Error_Msg_SC
("`ABSTRACT TAGGED` must come before PRIVATE");
759 Scan
; -- past ABSTRACT
761 if Token
= Tok_Tagged
then
765 elsif Token
= Tok_Tagged
then
766 Error_Msg_SC
("TAGGED must come before PRIVATE");
772 -- Ada 2005 (AI-345): Protected, synchronized or task interface
773 -- or Ada 2005 (AI-443): Synchronized private extension.
780 Saved_Token
: constant Token_Type
:= Token
;
783 Scan
; -- past TASK, PROTECTED or SYNCHRONIZED
785 -- Synchronized private extension
787 if Token
= Tok_New
then
788 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
790 if Saved_Token
= Tok_Synchronized
then
791 if Nkind
(Typedef_Node
) =
792 N_Derived_Type_Definition
795 ("SYNCHRONIZED not allowed for record extension",
798 Set_Synchronized_Present
(Typedef_Node
);
802 Error_Msg_SC
("invalid kind of private extension");
808 if Token
/= Tok_Interface
then
809 Error_Msg_SC
("NEW or INTERFACE expected");
813 P_Interface_Type_Definition
(Abstract_Present
);
814 Abstract_Present
:= True;
818 Set_Task_Present
(Typedef_Node
);
820 when Tok_Protected
=>
821 Set_Protected_Present
(Typedef_Node
);
823 when Tok_Synchronized
=>
824 Set_Synchronized_Present
(Typedef_Node
);
827 pragma Assert
(False);
835 -- Anything else is an error
838 if Bad_Spelling_Of
(Tok_Access
)
840 Bad_Spelling_Of
(Tok_Array
)
842 Bad_Spelling_Of
(Tok_Delta
)
844 Bad_Spelling_Of
(Tok_Digits
)
846 Bad_Spelling_Of
(Tok_Limited
)
848 Bad_Spelling_Of
(Tok_Private
)
850 Bad_Spelling_Of
(Tok_Range
)
852 Bad_Spelling_Of
(Tok_Record
)
854 Bad_Spelling_Of
(Tok_Tagged
)
859 Error_Msg_AP
("type definition expected");
866 -- For the private type declaration case, the private type declaration
867 -- node has been built, with the Tagged_Present and Limited_Present
868 -- flags set as needed, and Typedef_Node is left set to Empty.
870 if No
(Typedef_Node
) then
871 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
872 Set_Abstract_Present
(Decl_Node
, Abstract_Present
);
874 -- For a private extension declaration, Typedef_Node contains the
875 -- N_Private_Extension_Declaration node, which we now complete. Note
876 -- that the private extension declaration, unlike a full type
877 -- declaration, does permit unknown discriminants.
879 elsif Nkind
(Typedef_Node
) = N_Private_Extension_Declaration
then
880 Decl_Node
:= Typedef_Node
;
881 Set_Sloc
(Decl_Node
, Type_Loc
);
882 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
883 Set_Abstract_Present
(Typedef_Node
, Abstract_Present
);
885 -- In the full type declaration case, Typedef_Node has the type
886 -- definition and here is where we build the full type declaration
887 -- node. This is also where we check for improper use of an unknown
888 -- discriminant part (not allowed for full type declaration).
891 if Nkind
(Typedef_Node
) = N_Record_Definition
892 or else (Nkind
(Typedef_Node
) = N_Derived_Type_Definition
893 and then Present
(Record_Extension_Part
(Typedef_Node
)))
894 or else Is_Derived_Iface
896 Set_Abstract_Present
(Typedef_Node
, Abstract_Present
);
898 elsif Abstract_Present
then
899 Error_Msg
("ABSTRACT not allowed here, ignored", Abstract_Loc
);
902 Decl_Node
:= New_Node
(N_Full_Type_Declaration
, Type_Loc
);
903 Set_Type_Definition
(Decl_Node
, Typedef_Node
);
907 ("Full type declaration cannot have unknown discriminants",
912 -- Remaining processing is common for all three cases
914 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
915 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
916 P_Aspect_Specifications
(Decl_Node
);
918 end P_Type_Declaration
;
920 ----------------------------------
921 -- 3.2.1 Full Type Declaration --
922 ----------------------------------
924 -- Parsed by P_Type_Declaration (3.2.1)
926 ----------------------------
927 -- 3.2.1 Type Definition --
928 ----------------------------
930 -- Parsed by P_Type_Declaration (3.2.1)
932 --------------------------------
933 -- 3.2.2 Subtype Declaration --
934 --------------------------------
936 -- SUBTYPE_DECLARATION ::=
937 -- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION
938 -- [ASPECT_SPECIFICATIONS];
940 -- The caller has checked that the initial token is SUBTYPE
942 -- Error recovery: can raise Error_Resync
944 function P_Subtype_Declaration
return Node_Id
is
946 Not_Null_Present
: Boolean := False;
949 Decl_Node
:= New_Node
(N_Subtype_Declaration
, Token_Ptr
);
950 Scan
; -- past SUBTYPE
951 Set_Defining_Identifier
(Decl_Node
, P_Defining_Identifier
(C_Is
));
954 if Token
= Tok_New
then
955 Error_Msg_SC
-- CODEFIX
956 ("NEW ignored (only allowed in type declaration)");
960 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
961 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
963 Set_Subtype_Indication
964 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
965 P_Aspect_Specifications
(Decl_Node
);
967 end P_Subtype_Declaration
;
969 -------------------------------
970 -- 3.2.2 Subtype Indication --
971 -------------------------------
973 -- SUBTYPE_INDICATION ::=
974 -- [not null] SUBTYPE_MARK [CONSTRAINT]
976 -- Error recovery: can raise Error_Resync
978 function P_Null_Exclusion
979 (Allow_Anonymous_In_95
: Boolean := False) return Boolean
981 Not_Loc
: constant Source_Ptr
:= Token_Ptr
;
982 -- Source position of "not", if present
985 if Token
/= Tok_Not
then
991 if Token
= Tok_Null
then
994 -- Ada 2005 (AI-441, AI-447): null_exclusion is illegal in Ada 95,
995 -- except in the case of anonymous access types.
997 -- Allow_Anonymous_In_95 will be True if we're parsing a formal
998 -- parameter or discriminant, which are the only places where
999 -- anonymous access types occur in Ada 95. "Formal : not null
1000 -- access ..." is legal in Ada 95, whereas "Formal : not null
1001 -- Named_Access_Type" is not.
1003 if Ada_Version
>= Ada_2005
1004 or else (Ada_Version
>= Ada_95
1005 and then Allow_Anonymous_In_95
1006 and then Token
= Tok_Access
)
1012 ("`NOT NULL` access type is an Ada 2005 extension", Not_Loc
);
1014 ("\unit should be compiled with -gnat05 switch", Not_Loc
);
1018 Error_Msg_SP
("NULL expected");
1021 if Token
= Tok_New
then
1022 Error_Msg
("`NOT NULL` comes after NEW, not before", Not_Loc
);
1027 end P_Null_Exclusion
;
1029 function P_Subtype_Indication
1030 (Not_Null_Present
: Boolean := False) return Node_Id
1032 Type_Node
: Node_Id
;
1035 if Token
= Tok_Identifier
or else Token
= Tok_Operator_Symbol
then
1036 Type_Node
:= P_Subtype_Mark
;
1037 return P_Subtype_Indication
(Type_Node
, Not_Null_Present
);
1040 -- Check for error of using record definition and treat it nicely,
1041 -- otherwise things are really messed up, so resynchronize.
1043 if Token
= Tok_Record
then
1044 Error_Msg_SC
("anonymous record definitions are not permitted");
1045 Discard_Junk_Node
(P_Record_Definition
);
1049 Error_Msg_AP
("subtype indication expected");
1053 end P_Subtype_Indication
;
1055 -- The following function is identical except that it is called with
1056 -- the subtype mark already scanned out, and it scans out the constraint
1058 -- Error recovery: can raise Error_Resync
1060 function P_Subtype_Indication
1061 (Subtype_Mark
: Node_Id
;
1062 Not_Null_Present
: Boolean := False) return Node_Id
1064 Indic_Node
: Node_Id
;
1065 Constr_Node
: Node_Id
;
1068 Constr_Node
:= P_Constraint_Opt
;
1072 (Nkind
(Constr_Node
) = N_Range_Constraint
1073 and then Nkind
(Range_Expression
(Constr_Node
)) = N_Error
)
1075 return Subtype_Mark
;
1077 if Not_Null_Present
then
1078 Error_Msg_SP
("`NOT NULL` not allowed if constraint given");
1081 Indic_Node
:= New_Node
(N_Subtype_Indication
, Sloc
(Subtype_Mark
));
1082 Set_Subtype_Mark
(Indic_Node
, Check_Subtype_Mark
(Subtype_Mark
));
1083 Set_Constraint
(Indic_Node
, Constr_Node
);
1086 end P_Subtype_Indication
;
1088 -------------------------
1089 -- 3.2.2 Subtype Mark --
1090 -------------------------
1092 -- SUBTYPE_MARK ::= subtype_NAME;
1094 -- Note: The subtype mark which appears after an IN or NOT IN
1095 -- operator is parsed by P_Range_Or_Subtype_Mark (3.5)
1097 -- Error recovery: cannot raise Error_Resync
1099 function P_Subtype_Mark
return Node_Id
is
1101 return P_Subtype_Mark_Resync
;
1103 when Error_Resync
=>
1107 -- This routine differs from P_Subtype_Mark in that it insists that an
1108 -- identifier be present, and if it is not, it raises Error_Resync.
1110 -- Error recovery: can raise Error_Resync
1112 function P_Subtype_Mark_Resync
return Node_Id
is
1113 Type_Node
: Node_Id
;
1116 if Token
= Tok_Access
then
1117 Error_Msg_SC
("anonymous access type definition not allowed here");
1118 Scan
; -- past ACCESS
1121 if Token
= Tok_Array
then
1122 Error_Msg_SC
("anonymous array definition not allowed here");
1123 Discard_Junk_Node
(P_Array_Type_Definition
);
1127 Type_Node
:= P_Qualified_Simple_Name_Resync
;
1129 -- Check for a subtype mark attribute. The only valid possibilities
1130 -- are 'CLASS and 'BASE. Anything else is a definite error. We may
1131 -- as well catch it here.
1133 if Token
= Tok_Apostrophe
then
1134 return P_Subtype_Mark_Attribute
(Type_Node
);
1139 end P_Subtype_Mark_Resync
;
1141 -- The following function is called to scan out a subtype mark attribute.
1142 -- The caller has already scanned out the subtype mark, which is passed in
1143 -- as the argument, and has checked that the current token is apostrophe.
1145 -- Only a special subclass of attributes, called type attributes
1146 -- (see Snames package) are allowed in this syntactic position.
1148 -- Note: if the apostrophe is followed by other than an identifier, then
1149 -- the input expression is returned unchanged, and the scan pointer is
1150 -- left pointing to the apostrophe.
1152 -- Error recovery: can raise Error_Resync
1154 function P_Subtype_Mark_Attribute
(Type_Node
: Node_Id
) return Node_Id
is
1155 Attr_Node
: Node_Id
:= Empty
;
1156 Scan_State
: Saved_Scan_State
;
1160 Prefix
:= Check_Subtype_Mark
(Type_Node
);
1162 if Prefix
= Error
then
1166 -- Loop through attributes appearing (more than one can appear as for
1167 -- for example in X'Base'Class). We are at an apostrophe on entry to
1168 -- this loop, and it runs once for each attribute parsed, with
1169 -- Prefix being the current possible prefix if it is an attribute.
1172 Save_Scan_State
(Scan_State
); -- at Apostrophe
1173 Scan
; -- past apostrophe
1175 if Token
/= Tok_Identifier
then
1176 Restore_Scan_State
(Scan_State
); -- to apostrophe
1177 return Prefix
; -- no attribute after all
1179 elsif not Is_Type_Attribute_Name
(Token_Name
) then
1181 ("attribute & may not be used in a subtype mark", Token_Node
);
1186 Make_Attribute_Reference
(Prev_Token_Ptr
,
1188 Attribute_Name
=> Token_Name
);
1189 Scan
; -- past type attribute identifier
1192 exit when Token
/= Tok_Apostrophe
;
1193 Prefix
:= Attr_Node
;
1196 -- Fall through here after scanning type attribute
1199 end P_Subtype_Mark_Attribute
;
1201 -----------------------
1202 -- 3.2.2 Constraint --
1203 -----------------------
1205 -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
1207 -- SCALAR_CONSTRAINT ::=
1208 -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
1210 -- COMPOSITE_CONSTRAINT ::=
1211 -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
1213 -- If no constraint is present, this function returns Empty
1215 -- Error recovery: can raise Error_Resync
1217 function P_Constraint_Opt
return Node_Id
is
1219 if Token
= Tok_Range
1220 or else Bad_Spelling_Of
(Tok_Range
)
1222 return P_Range_Constraint
;
1224 elsif Token
= Tok_Digits
1225 or else Bad_Spelling_Of
(Tok_Digits
)
1227 return P_Digits_Constraint
;
1229 elsif Token
= Tok_Delta
1230 or else Bad_Spelling_Of
(Tok_Delta
)
1232 return P_Delta_Constraint
;
1234 elsif Token
= Tok_Left_Paren
then
1235 return P_Index_Or_Discriminant_Constraint
;
1237 elsif Token
= Tok_In
then
1239 return P_Constraint_Opt
;
1244 end P_Constraint_Opt
;
1246 ------------------------------
1247 -- 3.2.2 Scalar Constraint --
1248 ------------------------------
1250 -- Parsed by P_Constraint_Opt (3.2.2)
1252 ---------------------------------
1253 -- 3.2.2 Composite Constraint --
1254 ---------------------------------
1256 -- Parsed by P_Constraint_Opt (3.2.2)
1258 --------------------------------------------------------
1259 -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) --
1260 --------------------------------------------------------
1262 -- This routine scans out a declaration starting with an identifier:
1264 -- OBJECT_DECLARATION ::=
1265 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1266 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION]
1267 -- [ASPECT_SPECIFICATIONS];
1268 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1269 -- ACCESS_DEFINITION [:= EXPRESSION]
1270 -- [ASPECT_SPECIFICATIONS];
1271 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1272 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]
1273 -- [ASPECT_SPECIFICATIONS];
1275 -- NUMBER_DECLARATION ::=
1276 -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
1278 -- OBJECT_RENAMING_DECLARATION ::=
1279 -- DEFINING_IDENTIFIER :
1280 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
1281 -- | DEFINING_IDENTIFIER :
1282 -- ACCESS_DEFINITION renames object_NAME;
1284 -- EXCEPTION_RENAMING_DECLARATION ::=
1285 -- DEFINING_IDENTIFIER : exception renames exception_NAME;
1287 -- EXCEPTION_DECLARATION ::=
1288 -- DEFINING_IDENTIFIER_LIST : exception
1289 -- [ASPECT_SPECIFICATIONS];
1291 -- Note that the ALIASED indication in an object declaration is
1292 -- marked by a flag in the parent node.
1294 -- The caller has checked that the initial token is an identifier
1296 -- The value returned is a list of declarations, one for each identifier
1297 -- in the list (as described in Sinfo, we always split up multiple
1298 -- declarations into the equivalent sequence of single declarations
1299 -- using the More_Ids and Prev_Ids flags to preserve the source).
1301 -- If the identifier turns out to be a probable statement rather than
1302 -- an identifier, then the scan is left pointing to the identifier and
1303 -- No_List is returned.
1305 -- Error recovery: can raise Error_Resync
1307 procedure P_Identifier_Declarations
1313 Decl_Node
: Node_Id
;
1314 Type_Node
: Node_Id
;
1315 Ident_Sloc
: Source_Ptr
;
1316 Scan_State
: Saved_Scan_State
;
1317 List_OK
: Boolean := True;
1319 Init_Expr
: Node_Id
;
1320 Init_Loc
: Source_Ptr
;
1321 Con_Loc
: Source_Ptr
;
1322 Not_Null_Present
: Boolean := False;
1324 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
1325 -- Used to save identifiers in the identifier list. The upper bound
1326 -- of 4096 is expected to be infinite in practice, and we do not even
1327 -- bother to check if this upper bound is exceeded.
1329 Num_Idents
: Nat
:= 1;
1330 -- Number of identifiers stored in Idents
1333 -- This procedure is called in renames cases to make sure that we do
1334 -- not have more than one identifier. If we do have more than one
1335 -- then an error message is issued (and the declaration is split into
1336 -- multiple declarations)
1338 function Token_Is_Renames
return Boolean;
1339 -- Checks if current token is RENAMES, and if so, scans past it and
1340 -- returns True, otherwise returns False. Includes checking for some
1341 -- common error cases.
1347 procedure No_List
is
1349 if Num_Idents
> 1 then
1351 ("identifier list not allowed for RENAMES",
1358 ----------------------
1359 -- Token_Is_Renames --
1360 ----------------------
1362 function Token_Is_Renames
return Boolean is
1363 At_Colon
: Saved_Scan_State
;
1366 if Token
= Tok_Colon
then
1367 Save_Scan_State
(At_Colon
);
1369 Check_Misspelling_Of
(Tok_Renames
);
1371 if Token
= Tok_Renames
then
1372 Error_Msg_SP
-- CODEFIX
1373 ("|extra "":"" ignored");
1374 Scan
; -- past RENAMES
1377 Restore_Scan_State
(At_Colon
);
1382 Check_Misspelling_Of
(Tok_Renames
);
1384 if Token
= Tok_Renames
then
1385 Scan
; -- past RENAMES
1391 end Token_Is_Renames
;
1393 -- Start of processing for P_Identifier_Declarations
1396 Ident_Sloc
:= Token_Ptr
;
1397 Save_Scan_State
(Scan_State
); -- at first identifier
1398 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
1400 -- If we have a colon after the identifier, then we can assume that
1401 -- this is in fact a valid identifier declaration and can steam ahead.
1403 if Token
= Tok_Colon
then
1406 -- If we have a comma, then scan out the list of identifiers
1408 elsif Token
= Tok_Comma
then
1409 while Comma_Present
loop
1410 Num_Idents
:= Num_Idents
+ 1;
1411 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
1414 Save_Scan_State
(Scan_State
); -- at colon
1417 -- If we have identifier followed by := then we assume that what is
1418 -- really meant is an assignment statement. The assignment statement
1419 -- is scanned out and added to the list of declarations. An exception
1420 -- occurs if the := is followed by the keyword constant, in which case
1421 -- we assume it was meant to be a colon.
1423 elsif Token
= Tok_Colon_Equal
then
1426 if Token
= Tok_Constant
then
1427 Error_Msg_SP
("colon expected");
1430 Restore_Scan_State
(Scan_State
);
1431 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
1435 -- If we have an IS keyword, then assume the TYPE keyword was missing
1437 elsif Token
= Tok_Is
then
1438 Restore_Scan_State
(Scan_State
);
1439 Append_To
(Decls
, P_Type_Declaration
);
1443 -- Otherwise we have an error situation
1446 Restore_Scan_State
(Scan_State
);
1448 -- First case is possible misuse of PROTECTED in Ada 83 mode. If
1449 -- so, fix the keyword and return to scan the protected declaration.
1451 if Token_Name
= Name_Protected
then
1452 Check_95_Keyword
(Tok_Protected
, Tok_Identifier
);
1453 Check_95_Keyword
(Tok_Protected
, Tok_Type
);
1454 Check_95_Keyword
(Tok_Protected
, Tok_Body
);
1456 if Token
= Tok_Protected
then
1461 -- Check misspelling possibilities. If so, correct the misspelling
1462 -- and return to scan out the resulting declaration.
1464 elsif Bad_Spelling_Of
(Tok_Function
)
1465 or else Bad_Spelling_Of
(Tok_Procedure
)
1466 or else Bad_Spelling_Of
(Tok_Package
)
1467 or else Bad_Spelling_Of
(Tok_Pragma
)
1468 or else Bad_Spelling_Of
(Tok_Protected
)
1469 or else Bad_Spelling_Of
(Tok_Generic
)
1470 or else Bad_Spelling_Of
(Tok_Subtype
)
1471 or else Bad_Spelling_Of
(Tok_Type
)
1472 or else Bad_Spelling_Of
(Tok_Task
)
1473 or else Bad_Spelling_Of
(Tok_Use
)
1474 or else Bad_Spelling_Of
(Tok_For
)
1479 -- Otherwise we definitely have an ordinary identifier with a junk
1480 -- token after it. Just complain that we expect a declaration, and
1481 -- skip to a semicolon
1484 Set_Declaration_Expected
;
1485 Resync_Past_Semicolon
;
1491 -- Come here with an identifier list and colon scanned out. We now
1492 -- build the nodes for the declarative items. One node is built for
1493 -- each identifier in the list, with the type information being
1494 -- repeated by rescanning the appropriate section of source.
1496 -- First an error check, if we have two identifiers in a row, a likely
1497 -- possibility is that the first of the identifiers is an incorrectly
1500 if Token
= Tok_Identifier
then
1502 SS
: Saved_Scan_State
;
1506 Save_Scan_State
(SS
);
1507 Scan
; -- past initial identifier
1508 I2
:= (Token
= Tok_Identifier
);
1509 Restore_Scan_State
(SS
);
1513 (Bad_Spelling_Of
(Tok_Access
) or else
1514 Bad_Spelling_Of
(Tok_Aliased
) or else
1515 Bad_Spelling_Of
(Tok_Constant
))
1522 -- Loop through identifiers
1527 -- Check for some cases of misused Ada 95 keywords
1529 if Token_Name
= Name_Aliased
then
1530 Check_95_Keyword
(Tok_Aliased
, Tok_Array
);
1531 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
1532 Check_95_Keyword
(Tok_Aliased
, Tok_Constant
);
1537 if Token
= Tok_Constant
then
1538 Con_Loc
:= Token_Ptr
;
1539 Scan
; -- past CONSTANT
1541 -- Number declaration, initialization required
1543 Init_Expr
:= Init_Expr_Opt
;
1545 if Present
(Init_Expr
) then
1546 if Not_Null_Present
then
1548 ("`NOT NULL` not allowed in numeric expression");
1551 Decl_Node
:= New_Node
(N_Number_Declaration
, Ident_Sloc
);
1552 Set_Expression
(Decl_Node
, Init_Expr
);
1554 -- Constant object declaration
1557 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1558 Set_Constant_Present
(Decl_Node
, True);
1560 if Token_Name
= Name_Aliased
then
1561 Check_95_Keyword
(Tok_Aliased
, Tok_Array
);
1562 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
1565 if Token
= Tok_Aliased
then
1566 Error_Msg_SC
-- CODEFIX
1567 ("ALIASED should be before CONSTANT");
1568 Scan
; -- past ALIASED
1569 Set_Aliased_Present
(Decl_Node
, True);
1572 if Token
= Tok_Array
then
1573 Set_Object_Definition
1574 (Decl_Node
, P_Array_Type_Definition
);
1577 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1578 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1580 if Token
= Tok_Access
then
1581 if Ada_Version
< Ada_2005
then
1583 ("generalized use of anonymous access types " &
1584 "is an Ada 2005 extension");
1586 ("\unit must be compiled with -gnat05 switch");
1589 Set_Object_Definition
1590 (Decl_Node
, P_Access_Definition
(Not_Null_Present
));
1592 Set_Object_Definition
1593 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
1597 if Token
= Tok_Renames
then
1599 ("CONSTANT not permitted in renaming declaration",
1601 Scan
; -- Past renames
1602 Discard_Junk_Node
(P_Name
);
1608 elsif Token
= Tok_Exception
then
1609 Scan
; -- past EXCEPTION
1611 if Token_Is_Renames
then
1614 New_Node
(N_Exception_Renaming_Declaration
, Ident_Sloc
);
1615 Set_Name
(Decl_Node
, P_Qualified_Simple_Name_Resync
);
1618 Decl_Node
:= New_Node
(N_Exception_Declaration
, Prev_Token_Ptr
);
1621 -- Aliased case (note that an object definition is required)
1623 elsif Token
= Tok_Aliased
then
1624 Scan
; -- past ALIASED
1625 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1626 Set_Aliased_Present
(Decl_Node
, True);
1628 if Token
= Tok_Constant
then
1629 Scan
; -- past CONSTANT
1630 Set_Constant_Present
(Decl_Node
, True);
1633 if Token
= Tok_Array
then
1634 Set_Object_Definition
1635 (Decl_Node
, P_Array_Type_Definition
);
1638 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1639 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1641 -- Access definition (AI-406) or subtype indication
1643 if Token
= Tok_Access
then
1644 if Ada_Version
< Ada_2005
then
1646 ("generalized use of anonymous access types " &
1647 "is an Ada 2005 extension");
1649 ("\unit must be compiled with -gnat05 switch");
1652 Set_Object_Definition
1653 (Decl_Node
, P_Access_Definition
(Not_Null_Present
));
1655 Set_Object_Definition
1656 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
1662 elsif Token
= Tok_Array
then
1663 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1664 Set_Object_Definition
(Decl_Node
, P_Array_Type_Definition
);
1666 -- Ada 2005 (AI-254, AI-406)
1668 elsif Token
= Tok_Not
then
1670 -- OBJECT_DECLARATION ::=
1671 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1672 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1673 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1674 -- ACCESS_DEFINITION [:= EXPRESSION];
1676 -- OBJECT_RENAMING_DECLARATION ::=
1677 -- DEFINING_IDENTIFIER :
1678 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
1679 -- | DEFINING_IDENTIFIER :
1680 -- ACCESS_DEFINITION renames object_NAME;
1682 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/423)
1684 if Token
= Tok_Access
then
1685 if Ada_Version
< Ada_2005
then
1687 ("generalized use of anonymous access types " &
1688 "is an Ada 2005 extension");
1689 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1692 Acc_Node
:= P_Access_Definition
(Not_Null_Present
);
1694 if Token
/= Tok_Renames
then
1695 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1696 Set_Object_Definition
(Decl_Node
, Acc_Node
);
1699 Scan
; -- past renames
1702 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1703 Set_Access_Definition
(Decl_Node
, Acc_Node
);
1704 Set_Name
(Decl_Node
, P_Name
);
1708 Type_Node
:= P_Subtype_Mark
;
1710 -- Object renaming declaration
1712 if Token_Is_Renames
then
1713 if Ada_Version
< Ada_2005
then
1715 ("`NOT NULL` not allowed in object renaming");
1718 -- Ada 2005 (AI-423): Object renaming declaration with
1719 -- a null exclusion.
1724 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1725 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1726 Set_Subtype_Mark
(Decl_Node
, Type_Node
);
1727 Set_Name
(Decl_Node
, P_Name
);
1730 -- Object declaration
1733 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1734 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1735 Set_Object_Definition
1737 P_Subtype_Indication
(Type_Node
, Not_Null_Present
));
1739 -- RENAMES at this point means that we had the combination
1740 -- of a constraint on the Type_Node and renames, which is
1743 if Token_Is_Renames
then
1745 ("constraint not allowed in object renaming "
1747 Constraint
(Object_Definition
(Decl_Node
)));
1753 -- Ada 2005 (AI-230): Access Definition case
1755 elsif Token
= Tok_Access
then
1756 if Ada_Version
< Ada_2005
then
1758 ("generalized use of anonymous access types " &
1759 "is an Ada 2005 extension");
1760 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1763 Acc_Node
:= P_Access_Definition
(Null_Exclusion_Present
=> False);
1765 -- Object declaration with access definition, or renaming
1767 if Token
/= Tok_Renames
then
1768 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1769 Set_Object_Definition
(Decl_Node
, Acc_Node
);
1772 Scan
; -- past renames
1775 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1776 Set_Access_Definition
(Decl_Node
, Acc_Node
);
1777 Set_Name
(Decl_Node
, P_Name
);
1780 -- Subtype indication case
1783 Type_Node
:= P_Subtype_Mark
;
1785 -- Object renaming declaration
1787 if Token_Is_Renames
then
1790 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1791 Set_Subtype_Mark
(Decl_Node
, Type_Node
);
1792 Set_Name
(Decl_Node
, P_Name
);
1794 -- Object declaration
1797 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1798 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1799 Set_Object_Definition
1801 P_Subtype_Indication
(Type_Node
, Not_Null_Present
));
1803 -- RENAMES at this point means that we had the combination of
1804 -- a constraint on the Type_Node and renames, which is illegal
1806 if Token_Is_Renames
then
1808 ("constraint not allowed in object renaming declaration",
1809 Constraint
(Object_Definition
(Decl_Node
)));
1815 -- Scan out initialization, allowed only for object declaration
1817 Init_Loc
:= Token_Ptr
;
1818 Init_Expr
:= Init_Expr_Opt
;
1820 if Present
(Init_Expr
) then
1821 if Nkind
(Decl_Node
) = N_Object_Declaration
then
1822 Set_Expression
(Decl_Node
, Init_Expr
);
1823 Set_Has_Init_Expression
(Decl_Node
);
1825 Error_Msg
("initialization not allowed here", Init_Loc
);
1829 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
1830 P_Aspect_Specifications
(Decl_Node
);
1833 if Ident
< Num_Idents
then
1834 Set_More_Ids
(Decl_Node
, True);
1838 Set_Prev_Ids
(Decl_Node
, True);
1842 Append
(Decl_Node
, Decls
);
1843 exit Ident_Loop
when Ident
= Num_Idents
;
1844 Restore_Scan_State
(Scan_State
);
1847 end loop Ident_Loop
;
1850 end P_Identifier_Declarations
;
1852 -------------------------------
1853 -- 3.3.1 Object Declaration --
1854 -------------------------------
1856 -- OBJECT DECLARATION ::=
1857 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1858 -- SUBTYPE_INDICATION [:= EXPRESSION];
1859 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1860 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1861 -- | SINGLE_TASK_DECLARATION
1862 -- | SINGLE_PROTECTED_DECLARATION
1864 -- Cases starting with TASK are parsed by P_Task (9.1)
1865 -- Cases starting with PROTECTED are parsed by P_Protected (9.4)
1866 -- All other cases are parsed by P_Identifier_Declarations (3.3)
1868 -------------------------------------
1869 -- 3.3.1 Defining Identifier List --
1870 -------------------------------------
1872 -- DEFINING_IDENTIFIER_LIST ::=
1873 -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
1875 -- Always parsed by the construct in which it appears. See special
1876 -- section on "Handling of Defining Identifier Lists" in this unit.
1878 -------------------------------
1879 -- 3.3.2 Number Declaration --
1880 -------------------------------
1882 -- Parsed by P_Identifier_Declarations (3.3)
1884 -------------------------------------------------------------------------
1885 -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) --
1886 -------------------------------------------------------------------------
1888 -- DERIVED_TYPE_DEFINITION ::=
1889 -- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
1890 -- [[and INTERFACE_LIST] RECORD_EXTENSION_PART]
1892 -- PRIVATE_EXTENSION_DECLARATION ::=
1893 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
1894 -- [abstract] [limited | synchronized]
1895 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
1898 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
1900 -- The caller has already scanned out the part up to the NEW, and Token
1901 -- either contains Tok_New (or ought to, if it doesn't this procedure
1902 -- will post an appropriate "NEW expected" message).
1904 -- Note: the caller is responsible for filling in the Sloc field of
1905 -- the returned node in the private extension declaration case as
1906 -- well as the stuff relating to the discriminant part.
1908 -- Error recovery: can raise Error_Resync;
1910 function P_Derived_Type_Def_Or_Private_Ext_Decl
return Node_Id
is
1911 Typedef_Node
: Node_Id
;
1912 Typedecl_Node
: Node_Id
;
1913 Not_Null_Present
: Boolean := False;
1916 Typedef_Node
:= New_Node
(N_Derived_Type_Definition
, Token_Ptr
);
1918 if Ada_Version
< Ada_2005
1919 and then Token
= Tok_Identifier
1920 and then Token_Name
= Name_Interface
1923 ("abstract interface is an Ada 2005 extension");
1924 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1929 if Token
= Tok_Abstract
then
1930 Error_Msg_SC
-- CODEFIX
1931 ("ABSTRACT must come before NEW, not after");
1935 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1936 Set_Null_Exclusion_Present
(Typedef_Node
, Not_Null_Present
);
1937 Set_Subtype_Indication
(Typedef_Node
,
1938 P_Subtype_Indication
(Not_Null_Present
));
1940 -- Ada 2005 (AI-251): Deal with interfaces
1942 if Token
= Tok_And
then
1945 if Ada_Version
< Ada_2005
then
1947 ("abstract interface is an Ada 2005 extension");
1948 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1951 Set_Interface_List
(Typedef_Node
, New_List
);
1954 Append
(P_Qualified_Simple_Name
, Interface_List
(Typedef_Node
));
1955 exit when Token
/= Tok_And
;
1959 if Token
/= Tok_With
then
1960 Error_Msg_SC
("WITH expected");
1965 -- Deal with record extension, note that we assume that a WITH is
1966 -- missing in the case of "type X is new Y record ..." or in the
1967 -- case of "type X is new Y null record".
1969 -- First make sure we don't have an aspect specification. If we do
1970 -- return now, so that our caller can check it (the WITH here is not
1971 -- part of a type extension).
1973 if Aspect_Specifications_Present
then
1974 return Typedef_Node
;
1976 -- OK, not an aspect specification, so continue test for extension
1978 elsif Token
= Tok_With
1979 or else Token
= Tok_Record
1980 or else Token
= Tok_Null
1982 T_With
; -- past WITH or give error message
1984 if Token
= Tok_Limited
then
1985 Error_Msg_SC
("LIMITED keyword not allowed in private extension");
1986 Scan
; -- ignore LIMITED
1989 -- Private extension declaration
1991 if Token
= Tok_Private
then
1992 Scan
; -- past PRIVATE
1994 -- Throw away the type definition node and build the type
1995 -- declaration node. Note the caller must set the Sloc,
1996 -- Discriminant_Specifications, Unknown_Discriminants_Present,
1997 -- and Defined_Identifier fields in the returned node.
2000 Make_Private_Extension_Declaration
(No_Location
,
2001 Defining_Identifier
=> Empty
,
2002 Subtype_Indication
=> Subtype_Indication
(Typedef_Node
),
2003 Abstract_Present
=> Abstract_Present
(Typedef_Node
),
2004 Interface_List
=> Interface_List
(Typedef_Node
));
2006 return Typedecl_Node
;
2008 -- Derived type definition with record extension part
2011 Set_Record_Extension_Part
(Typedef_Node
, P_Record_Definition
);
2012 return Typedef_Node
;
2015 -- Derived type definition with no record extension part
2018 return Typedef_Node
;
2020 end P_Derived_Type_Def_Or_Private_Ext_Decl
;
2022 ---------------------------
2023 -- 3.5 Range Constraint --
2024 ---------------------------
2026 -- RANGE_CONSTRAINT ::= range RANGE
2028 -- The caller has checked that the initial token is RANGE
2030 -- Error recovery: cannot raise Error_Resync
2032 function P_Range_Constraint
return Node_Id
is
2033 Range_Node
: Node_Id
;
2036 Range_Node
:= New_Node
(N_Range_Constraint
, Token_Ptr
);
2038 Set_Range_Expression
(Range_Node
, P_Range
);
2040 end P_Range_Constraint
;
2047 -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
2049 -- Note: the range that appears in a membership test is parsed by
2050 -- P_Range_Or_Subtype_Mark (3.5).
2052 -- Error recovery: cannot raise Error_Resync
2054 function P_Range
return Node_Id
is
2055 Expr_Node
: Node_Id
;
2056 Range_Node
: Node_Id
;
2059 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2061 if Expr_Form
= EF_Range_Attr
then
2064 elsif Token
= Tok_Dot_Dot
then
2065 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2066 Set_Low_Bound
(Range_Node
, Expr_Node
);
2068 Expr_Node
:= P_Expression
;
2069 Check_Simple_Expression
(Expr_Node
);
2070 Set_High_Bound
(Range_Node
, Expr_Node
);
2073 -- Anything else is an error
2076 T_Dot_Dot
; -- force missing .. message
2081 ----------------------------------
2082 -- 3.5 P_Range_Or_Subtype_Mark --
2083 ----------------------------------
2086 -- RANGE_ATTRIBUTE_REFERENCE
2087 -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
2089 -- This routine scans out the range or subtype mark that forms the right
2090 -- operand of a membership test (it is not used in any other contexts, and
2091 -- error messages are specialized with this knowledge in mind).
2093 -- Note: as documented in the Sinfo interface, although the syntax only
2094 -- allows a subtype mark, we in fact allow any simple expression to be
2095 -- returned from this routine. The semantics is responsible for issuing
2096 -- an appropriate message complaining if the argument is not a name.
2097 -- This simplifies the coding and error recovery processing in the
2098 -- parser, and in any case it is preferable not to consider this a
2099 -- syntax error and to continue with the semantic analysis.
2101 -- Error recovery: cannot raise Error_Resync
2103 function P_Range_Or_Subtype_Mark
2104 (Allow_Simple_Expression
: Boolean := False) return Node_Id
2106 Expr_Node
: Node_Id
;
2107 Range_Node
: Node_Id
;
2108 Save_Loc
: Source_Ptr
;
2110 -- Start of processing for P_Range_Or_Subtype_Mark
2113 -- Save location of possible junk parentheses
2115 Save_Loc
:= Token_Ptr
;
2117 -- Scan out either a simple expression or a range (this accepts more
2118 -- than is legal here, but as explained above, we like to allow more
2119 -- with a proper diagnostic, and in the case of a membership operation
2120 -- where sets are allowed, a simple expression is permissible anyway.
2122 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2126 if Expr_Form
= EF_Range_Attr
then
2129 -- Simple_Expression .. Simple_Expression
2131 elsif Token
= Tok_Dot_Dot
then
2132 Check_Simple_Expression
(Expr_Node
);
2133 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2134 Set_Low_Bound
(Range_Node
, Expr_Node
);
2136 Set_High_Bound
(Range_Node
, P_Simple_Expression
);
2139 -- Case of subtype mark (optionally qualified simple name or an
2140 -- attribute whose prefix is an optionally qualified simple name)
2142 elsif Expr_Form
= EF_Simple_Name
2143 or else Nkind
(Expr_Node
) = N_Attribute_Reference
2145 -- Check for error of range constraint after a subtype mark
2147 if Token
= Tok_Range
then
2148 Error_Msg_SC
("range constraint not allowed in membership test");
2152 -- Check for error of DIGITS or DELTA after a subtype mark
2154 elsif Token
= Tok_Digits
or else Token
= Tok_Delta
then
2156 ("accuracy definition not allowed in membership test");
2157 Scan
; -- past DIGITS or DELTA
2160 -- Attribute reference, may or may not be OK, but in any case we
2163 elsif Token
= Tok_Apostrophe
then
2164 return P_Subtype_Mark_Attribute
(Expr_Node
);
2166 -- OK case of simple name, just return it
2172 -- Simple expression case
2174 elsif Expr_Form
= EF_Simple
and then Allow_Simple_Expression
then
2177 -- Here we have some kind of error situation. Check for junk parens
2178 -- then return what we have, caller will deal with other errors.
2181 if Nkind
(Expr_Node
) in N_Subexpr
2182 and then Paren_Count
(Expr_Node
) /= 0
2184 Error_Msg
("|parentheses not allowed for subtype mark", Save_Loc
);
2185 Set_Paren_Count
(Expr_Node
, 0);
2190 end P_Range_Or_Subtype_Mark
;
2192 ----------------------------------------
2193 -- 3.5.1 Enumeration Type Definition --
2194 ----------------------------------------
2196 -- ENUMERATION_TYPE_DEFINITION ::=
2197 -- (ENUMERATION_LITERAL_SPECIFICATION
2198 -- {, ENUMERATION_LITERAL_SPECIFICATION})
2200 -- The caller has already scanned out the TYPE keyword
2202 -- Error recovery: can raise Error_Resync;
2204 function P_Enumeration_Type_Definition
return Node_Id
is
2205 Typedef_Node
: Node_Id
;
2208 Typedef_Node
:= New_Node
(N_Enumeration_Type_Definition
, Token_Ptr
);
2209 Set_Literals
(Typedef_Node
, New_List
);
2214 Append
(P_Enumeration_Literal_Specification
, Literals
(Typedef_Node
));
2215 exit when not Comma_Present
;
2219 return Typedef_Node
;
2220 end P_Enumeration_Type_Definition
;
2222 ----------------------------------------------
2223 -- 3.5.1 Enumeration Literal Specification --
2224 ----------------------------------------------
2226 -- ENUMERATION_LITERAL_SPECIFICATION ::=
2227 -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
2229 -- Error recovery: can raise Error_Resync
2231 function P_Enumeration_Literal_Specification
return Node_Id
is
2233 if Token
= Tok_Char_Literal
then
2234 return P_Defining_Character_Literal
;
2236 return P_Defining_Identifier
(C_Comma_Right_Paren
);
2238 end P_Enumeration_Literal_Specification
;
2240 ---------------------------------------
2241 -- 3.5.1 Defining_Character_Literal --
2242 ---------------------------------------
2244 -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
2246 -- Error recovery: cannot raise Error_Resync
2248 -- The caller has checked that the current token is a character literal
2250 function P_Defining_Character_Literal
return Node_Id
is
2251 Literal_Node
: Node_Id
;
2253 Literal_Node
:= Token_Node
;
2254 Change_Character_Literal_To_Defining_Character_Literal
(Literal_Node
);
2255 Scan
; -- past character literal
2256 return Literal_Node
;
2257 end P_Defining_Character_Literal
;
2259 ------------------------------------
2260 -- 3.5.4 Integer Type Definition --
2261 ------------------------------------
2263 -- Parsed by P_Type_Declaration (3.2.1)
2265 -------------------------------------------
2266 -- 3.5.4 Signed Integer Type Definition --
2267 -------------------------------------------
2269 -- SIGNED_INTEGER_TYPE_DEFINITION ::=
2270 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2272 -- Normally the initial token on entry is RANGE, but in some
2273 -- error conditions, the range token was missing and control is
2274 -- passed with Token pointing to first token of the first expression.
2276 -- Error recovery: cannot raise Error_Resync
2278 function P_Signed_Integer_Type_Definition
return Node_Id
is
2279 Typedef_Node
: Node_Id
;
2280 Expr_Node
: Node_Id
;
2283 Typedef_Node
:= New_Node
(N_Signed_Integer_Type_Definition
, Token_Ptr
);
2285 if Token
= Tok_Range
then
2289 Expr_Node
:= P_Expression_Or_Range_Attribute
;
2291 -- Range case (not permitted by the grammar, this is surprising but
2292 -- the grammar in the RM is as quoted above, and does not allow Range).
2294 if Expr_Form
= EF_Range_Attr
then
2296 ("Range attribute not allowed here, use First .. Last", Expr_Node
);
2297 Set_Low_Bound
(Typedef_Node
, Expr_Node
);
2298 Set_Attribute_Name
(Expr_Node
, Name_First
);
2299 Set_High_Bound
(Typedef_Node
, Copy_Separate_Tree
(Expr_Node
));
2300 Set_Attribute_Name
(High_Bound
(Typedef_Node
), Name_Last
);
2302 -- Normal case of explicit range
2305 Check_Simple_Expression
(Expr_Node
);
2306 Set_Low_Bound
(Typedef_Node
, Expr_Node
);
2308 Expr_Node
:= P_Expression
;
2309 Check_Simple_Expression
(Expr_Node
);
2310 Set_High_Bound
(Typedef_Node
, Expr_Node
);
2313 return Typedef_Node
;
2314 end P_Signed_Integer_Type_Definition
;
2316 ------------------------------------
2317 -- 3.5.4 Modular Type Definition --
2318 ------------------------------------
2320 -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
2322 -- The caller has checked that the initial token is MOD
2324 -- Error recovery: cannot raise Error_Resync
2326 function P_Modular_Type_Definition
return Node_Id
is
2327 Typedef_Node
: Node_Id
;
2330 if Ada_Version
= Ada_83
then
2331 Error_Msg_SC
("(Ada 83): modular types not allowed");
2334 Typedef_Node
:= New_Node
(N_Modular_Type_Definition
, Token_Ptr
);
2336 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
2338 -- Handle mod L..R cleanly
2340 if Token
= Tok_Dot_Dot
then
2341 Error_Msg_SC
("range not allowed for modular type");
2343 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
2346 return Typedef_Node
;
2347 end P_Modular_Type_Definition
;
2349 ---------------------------------
2350 -- 3.5.6 Real Type Definition --
2351 ---------------------------------
2353 -- Parsed by P_Type_Declaration (3.2.1)
2355 --------------------------------------
2356 -- 3.5.7 Floating Point Definition --
2357 --------------------------------------
2359 -- FLOATING_POINT_DEFINITION ::=
2360 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2362 -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
2364 -- The caller has checked that the initial token is DIGITS
2366 -- Error recovery: cannot raise Error_Resync
2368 function P_Floating_Point_Definition
return Node_Id
is
2369 Digits_Loc
: constant Source_Ptr
:= Token_Ptr
;
2371 Expr_Node
: Node_Id
;
2374 Scan
; -- past DIGITS
2375 Expr_Node
:= P_Expression_No_Right_Paren
;
2376 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2378 -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
2380 if Token
= Tok_Delta
then
2381 Error_Msg_SC
-- CODEFIX
2382 ("|DELTA must come before DIGITS");
2383 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Digits_Loc
);
2385 Set_Delta_Expression
(Def_Node
, P_Expression_No_Right_Paren
);
2387 -- OK floating-point definition
2390 Def_Node
:= New_Node
(N_Floating_Point_Definition
, Digits_Loc
);
2393 Set_Digits_Expression
(Def_Node
, Expr_Node
);
2394 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
2396 end P_Floating_Point_Definition
;
2398 -------------------------------------
2399 -- 3.5.7 Real Range Specification --
2400 -------------------------------------
2402 -- REAL_RANGE_SPECIFICATION ::=
2403 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2405 -- Error recovery: cannot raise Error_Resync
2407 function P_Real_Range_Specification_Opt
return Node_Id
is
2408 Specification_Node
: Node_Id
;
2409 Expr_Node
: Node_Id
;
2412 if Token
= Tok_Range
then
2413 Specification_Node
:=
2414 New_Node
(N_Real_Range_Specification
, Token_Ptr
);
2416 Expr_Node
:= P_Expression_No_Right_Paren
;
2417 Check_Simple_Expression
(Expr_Node
);
2418 Set_Low_Bound
(Specification_Node
, Expr_Node
);
2420 Expr_Node
:= P_Expression_No_Right_Paren
;
2421 Check_Simple_Expression
(Expr_Node
);
2422 Set_High_Bound
(Specification_Node
, Expr_Node
);
2423 return Specification_Node
;
2427 end P_Real_Range_Specification_Opt
;
2429 -----------------------------------
2430 -- 3.5.9 Fixed Point Definition --
2431 -----------------------------------
2433 -- FIXED_POINT_DEFINITION ::=
2434 -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
2436 -- ORDINARY_FIXED_POINT_DEFINITION ::=
2437 -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION
2439 -- DECIMAL_FIXED_POINT_DEFINITION ::=
2440 -- delta static_EXPRESSION
2441 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2443 -- The caller has checked that the initial token is DELTA
2445 -- Error recovery: cannot raise Error_Resync
2447 function P_Fixed_Point_Definition
return Node_Id
is
2448 Delta_Node
: Node_Id
;
2449 Delta_Loc
: Source_Ptr
;
2451 Expr_Node
: Node_Id
;
2454 Delta_Loc
:= Token_Ptr
;
2456 Delta_Node
:= P_Expression_No_Right_Paren
;
2457 Check_Simple_Expression_In_Ada_83
(Delta_Node
);
2459 if Token
= Tok_Digits
then
2460 if Ada_Version
= Ada_83
then
2461 Error_Msg_SC
("(Ada 83) decimal fixed type not allowed!");
2464 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Delta_Loc
);
2465 Scan
; -- past DIGITS
2466 Expr_Node
:= P_Expression_No_Right_Paren
;
2467 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2468 Set_Digits_Expression
(Def_Node
, Expr_Node
);
2471 Def_Node
:= New_Node
(N_Ordinary_Fixed_Point_Definition
, Delta_Loc
);
2473 -- Range is required in ordinary fixed point case
2475 if Token
/= Tok_Range
then
2476 Error_Msg_AP
("range must be given for fixed-point type");
2481 Set_Delta_Expression
(Def_Node
, Delta_Node
);
2482 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
2484 end P_Fixed_Point_Definition
;
2486 --------------------------------------------
2487 -- 3.5.9 Ordinary Fixed Point Definition --
2488 --------------------------------------------
2490 -- Parsed by P_Fixed_Point_Definition (3.5.9)
2492 -------------------------------------------
2493 -- 3.5.9 Decimal Fixed Point Definition --
2494 -------------------------------------------
2496 -- Parsed by P_Decimal_Point_Definition (3.5.9)
2498 ------------------------------
2499 -- 3.5.9 Digits Constraint --
2500 ------------------------------
2502 -- DIGITS_CONSTRAINT ::=
2503 -- digits static_EXPRESSION [RANGE_CONSTRAINT]
2505 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2507 -- The caller has checked that the initial token is DIGITS
2509 function P_Digits_Constraint
return Node_Id
is
2510 Constraint_Node
: Node_Id
;
2511 Expr_Node
: Node_Id
;
2514 Constraint_Node
:= New_Node
(N_Digits_Constraint
, Token_Ptr
);
2515 Scan
; -- past DIGITS
2516 Expr_Node
:= P_Expression
;
2517 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2518 Set_Digits_Expression
(Constraint_Node
, Expr_Node
);
2520 if Token
= Tok_Range
then
2521 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
2524 return Constraint_Node
;
2525 end P_Digits_Constraint
;
2527 -----------------------------
2528 -- 3.5.9 Delta Constraint --
2529 -----------------------------
2531 -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
2533 -- Note: this is an obsolescent feature in Ada 95 (I.3)
2535 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2536 -- (also true in formal modes).
2538 -- The caller has checked that the initial token is DELTA
2540 -- Error recovery: cannot raise Error_Resync
2542 function P_Delta_Constraint
return Node_Id
is
2543 Constraint_Node
: Node_Id
;
2544 Expr_Node
: Node_Id
;
2547 Constraint_Node
:= New_Node
(N_Delta_Constraint
, Token_Ptr
);
2549 Expr_Node
:= P_Expression
;
2550 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2552 Set_Delta_Expression
(Constraint_Node
, Expr_Node
);
2554 if Token
= Tok_Range
then
2555 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
2558 return Constraint_Node
;
2559 end P_Delta_Constraint
;
2561 --------------------------------
2562 -- 3.6 Array Type Definition --
2563 --------------------------------
2565 -- ARRAY_TYPE_DEFINITION ::=
2566 -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
2568 -- UNCONSTRAINED_ARRAY_DEFINITION ::=
2569 -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
2570 -- COMPONENT_DEFINITION
2572 -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
2574 -- CONSTRAINED_ARRAY_DEFINITION ::=
2575 -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
2576 -- COMPONENT_DEFINITION
2578 -- DISCRETE_SUBTYPE_DEFINITION ::=
2579 -- DISCRETE_SUBTYPE_INDICATION | RANGE
2581 -- COMPONENT_DEFINITION ::=
2582 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
2584 -- The caller has checked that the initial token is ARRAY
2586 -- Error recovery: can raise Error_Resync
2588 function P_Array_Type_Definition
return Node_Id
is
2589 Array_Loc
: Source_Ptr
;
2590 CompDef_Node
: Node_Id
;
2592 Not_Null_Present
: Boolean := False;
2593 Subs_List
: List_Id
;
2594 Scan_State
: Saved_Scan_State
;
2595 Aliased_Present
: Boolean := False;
2598 Array_Loc
:= Token_Ptr
;
2600 Subs_List
:= New_List
;
2603 -- It's quite tricky to disentangle these two possibilities, so we do
2604 -- a prescan to determine which case we have and then reset the scan.
2605 -- The prescan skips past possible subtype mark tokens.
2607 Save_Scan_State
(Scan_State
); -- just after paren
2609 while Token
in Token_Class_Desig
or else
2610 Token
= Tok_Dot
or else
2611 Token
= Tok_Apostrophe
-- because of 'BASE, 'CLASS
2616 -- If we end up on RANGE <> then we have the unconstrained case. We
2617 -- will also allow the RANGE to be omitted, just to improve error
2618 -- handling for a case like array (integer <>) of integer;
2620 Scan
; -- past possible RANGE or <>
2622 if (Prev_Token
= Tok_Range
and then Token
= Tok_Box
) or else
2623 Prev_Token
= Tok_Box
2625 Def_Node
:= New_Node
(N_Unconstrained_Array_Definition
, Array_Loc
);
2626 Restore_Scan_State
(Scan_State
); -- to first subtype mark
2629 Append
(P_Subtype_Mark_Resync
, Subs_List
);
2632 exit when Token
= Tok_Right_Paren
or else Token
= Tok_Of
;
2636 Set_Subtype_Marks
(Def_Node
, Subs_List
);
2639 Def_Node
:= New_Node
(N_Constrained_Array_Definition
, Array_Loc
);
2640 Restore_Scan_State
(Scan_State
); -- to first discrete range
2643 Append
(P_Discrete_Subtype_Definition
, Subs_List
);
2644 exit when not Comma_Present
;
2647 Set_Discrete_Subtype_Definitions
(Def_Node
, Subs_List
);
2653 CompDef_Node
:= New_Node
(N_Component_Definition
, Token_Ptr
);
2655 if Token_Name
= Name_Aliased
then
2656 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
2659 if Token
= Tok_Aliased
then
2660 Aliased_Present
:= True;
2661 Scan
; -- past ALIASED
2664 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/AI-254)
2666 -- Ada 2005 (AI-230): Access Definition case
2668 if Token
= Tok_Access
then
2669 if Ada_Version
< Ada_2005
then
2671 ("generalized use of anonymous access types " &
2672 "is an Ada 2005 extension");
2673 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
2676 -- AI95-406 makes "aliased" legal (and useless) in this context so
2677 -- followintg code which used to be needed is commented out.
2679 -- if Aliased_Present then
2680 -- Error_Msg_SP ("ALIASED not allowed here");
2683 Set_Subtype_Indication
(CompDef_Node
, Empty
);
2684 Set_Aliased_Present
(CompDef_Node
, False);
2685 Set_Access_Definition
(CompDef_Node
,
2686 P_Access_Definition
(Not_Null_Present
));
2689 Set_Access_Definition
(CompDef_Node
, Empty
);
2690 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
2691 Set_Null_Exclusion_Present
(CompDef_Node
, Not_Null_Present
);
2692 Set_Subtype_Indication
(CompDef_Node
,
2693 P_Subtype_Indication
(Not_Null_Present
));
2696 Set_Component_Definition
(Def_Node
, CompDef_Node
);
2699 end P_Array_Type_Definition
;
2701 -----------------------------------------
2702 -- 3.6 Unconstrained Array Definition --
2703 -----------------------------------------
2705 -- Parsed by P_Array_Type_Definition (3.6)
2707 ---------------------------------------
2708 -- 3.6 Constrained Array Definition --
2709 ---------------------------------------
2711 -- Parsed by P_Array_Type_Definition (3.6)
2713 --------------------------------------
2714 -- 3.6 Discrete Subtype Definition --
2715 --------------------------------------
2717 -- DISCRETE_SUBTYPE_DEFINITION ::=
2718 -- discrete_SUBTYPE_INDICATION | RANGE
2720 -- Note: the discrete subtype definition appearing in a constrained
2721 -- array definition is parsed by P_Array_Type_Definition (3.6)
2723 -- Error recovery: cannot raise Error_Resync
2725 function P_Discrete_Subtype_Definition
return Node_Id
is
2727 -- The syntax of a discrete subtype definition is identical to that
2728 -- of a discrete range, so we simply share the same parsing code.
2730 return P_Discrete_Range
;
2731 end P_Discrete_Subtype_Definition
;
2733 -------------------------------
2734 -- 3.6 Component Definition --
2735 -------------------------------
2737 -- For the array case, parsed by P_Array_Type_Definition (3.6)
2738 -- For the record case, parsed by P_Component_Declaration (3.8)
2740 -----------------------------
2741 -- 3.6.1 Index Constraint --
2742 -----------------------------
2744 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2746 ---------------------------
2747 -- 3.6.1 Discrete Range --
2748 ---------------------------
2750 -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
2752 -- The possible forms for a discrete range are:
2754 -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2)
2755 -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2)
2756 -- Range_Attribute (RANGE, 3.5)
2757 -- Simple_Expression .. Simple_Expression (RANGE, 3.5)
2759 -- Error recovery: cannot raise Error_Resync
2761 function P_Discrete_Range
return Node_Id
is
2762 Expr_Node
: Node_Id
;
2763 Range_Node
: Node_Id
;
2766 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2768 if Expr_Form
= EF_Range_Attr
then
2771 elsif Token
= Tok_Range
then
2772 if Expr_Form
/= EF_Simple_Name
then
2773 Error_Msg_SC
("range must be preceded by subtype mark");
2776 return P_Subtype_Indication
(Expr_Node
);
2778 -- Check Expression .. Expression case
2780 elsif Token
= Tok_Dot_Dot
then
2781 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2782 Set_Low_Bound
(Range_Node
, Expr_Node
);
2784 Expr_Node
:= P_Expression
;
2785 Check_Simple_Expression
(Expr_Node
);
2786 Set_High_Bound
(Range_Node
, Expr_Node
);
2789 -- Otherwise we must have a subtype mark, or an Ada 2012 iterator
2791 elsif Expr_Form
= EF_Simple_Name
then
2794 -- The domain of iteration must be a name. Semantics will determine that
2795 -- the expression has the proper form.
2797 elsif Ada_Version
>= Ada_2012
then
2800 -- If incorrect, complain that we expect ..
2806 end P_Discrete_Range
;
2808 ----------------------------
2809 -- 3.7 Discriminant Part --
2810 ----------------------------
2812 -- DISCRIMINANT_PART ::=
2813 -- UNKNOWN_DISCRIMINANT_PART
2814 -- | KNOWN_DISCRIMINANT_PART
2816 -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
2817 -- or P_Unknown_Discriminant_Part (3.7), since we know which we want.
2819 ------------------------------------
2820 -- 3.7 Unknown Discriminant Part --
2821 ------------------------------------
2823 -- UNKNOWN_DISCRIMINANT_PART ::= (<>)
2825 -- If no unknown discriminant part is present, then False is returned,
2826 -- otherwise the unknown discriminant is scanned out and True is returned.
2828 -- Error recovery: cannot raise Error_Resync
2830 function P_Unknown_Discriminant_Part_Opt
return Boolean is
2831 Scan_State
: Saved_Scan_State
;
2834 -- If <> right now, then this is missing left paren
2836 if Token
= Tok_Box
then
2839 -- If not <> or left paren, then definitely no box
2841 elsif Token
/= Tok_Left_Paren
then
2844 -- Left paren, so might be a box after it
2847 Save_Scan_State
(Scan_State
);
2848 Scan
; -- past the left paren
2850 if Token
/= Tok_Box
then
2851 Restore_Scan_State
(Scan_State
);
2856 -- We are now pointing to the box
2858 if Ada_Version
= Ada_83
then
2859 Error_Msg_SC
("(Ada 83) unknown discriminant not allowed!");
2862 Scan
; -- past the box
2863 U_Right_Paren
; -- must be followed by right paren
2865 end P_Unknown_Discriminant_Part_Opt
;
2867 ----------------------------------
2868 -- 3.7 Known Discriminant Part --
2869 ----------------------------------
2871 -- KNOWN_DISCRIMINANT_PART ::=
2872 -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
2874 -- DISCRIMINANT_SPECIFICATION ::=
2875 -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
2876 -- [:= DEFAULT_EXPRESSION]
2877 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
2878 -- [:= DEFAULT_EXPRESSION]
2880 -- If no known discriminant part is present, then No_List is returned
2882 -- Error recovery: cannot raise Error_Resync
2884 function P_Known_Discriminant_Part_Opt
return List_Id
is
2885 Specification_Node
: Node_Id
;
2886 Specification_List
: List_Id
;
2887 Ident_Sloc
: Source_Ptr
;
2888 Scan_State
: Saved_Scan_State
;
2890 Not_Null_Present
: Boolean;
2893 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
2894 -- This array holds the list of defining identifiers. The upper bound
2895 -- of 4096 is intended to be essentially infinite, and we do not even
2896 -- bother to check for it being exceeded.
2899 if Token
= Tok_Left_Paren
then
2900 Specification_List
:= New_List
;
2902 P_Pragmas_Misplaced
;
2904 Specification_Loop
: loop
2906 Ident_Sloc
:= Token_Ptr
;
2907 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
2910 while Comma_Present
loop
2911 Num_Idents
:= Num_Idents
+ 1;
2912 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
2915 -- If there are multiple identifiers, we repeatedly scan the
2916 -- type and initialization expression information by resetting
2917 -- the scan pointer (so that we get completely separate trees
2918 -- for each occurrence).
2920 if Num_Idents
> 1 then
2921 Save_Scan_State
(Scan_State
);
2926 -- Loop through defining identifiers in list
2930 Specification_Node
:=
2931 New_Node
(N_Discriminant_Specification
, Ident_Sloc
);
2932 Set_Defining_Identifier
(Specification_Node
, Idents
(Ident
));
2933 Not_Null_Present
:= -- Ada 2005 (AI-231, AI-447)
2934 P_Null_Exclusion
(Allow_Anonymous_In_95
=> True);
2936 if Token
= Tok_Access
then
2937 if Ada_Version
= Ada_83
then
2939 ("(Ada 83) access discriminant not allowed!");
2942 Set_Discriminant_Type
2943 (Specification_Node
,
2944 P_Access_Definition
(Not_Null_Present
));
2947 Set_Discriminant_Type
2948 (Specification_Node
, P_Subtype_Mark
);
2950 Set_Null_Exclusion_Present
-- Ada 2005 (AI-231)
2951 (Specification_Node
, Not_Null_Present
);
2955 (Specification_Node
, Init_Expr_Opt
(True));
2958 Set_Prev_Ids
(Specification_Node
, True);
2961 if Ident
< Num_Idents
then
2962 Set_More_Ids
(Specification_Node
, True);
2965 Append
(Specification_Node
, Specification_List
);
2966 exit Ident_Loop
when Ident
= Num_Idents
;
2968 Restore_Scan_State
(Scan_State
);
2970 end loop Ident_Loop
;
2972 exit Specification_Loop
when Token
/= Tok_Semicolon
;
2974 P_Pragmas_Misplaced
;
2975 end loop Specification_Loop
;
2978 return Specification_List
;
2983 end P_Known_Discriminant_Part_Opt
;
2985 -------------------------------------
2986 -- 3.7 Discriminant Specification --
2987 -------------------------------------
2989 -- Parsed by P_Known_Discriminant_Part_Opt (3.7)
2991 -----------------------------
2992 -- 3.7 Default Expression --
2993 -----------------------------
2995 -- Always parsed (simply as an Expression) by the parent construct
2997 ------------------------------------
2998 -- 3.7.1 Discriminant Constraint --
2999 ------------------------------------
3001 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
3003 --------------------------------------------------------
3004 -- 3.7.1 Index or Discriminant Constraint (also 3.6) --
3005 --------------------------------------------------------
3007 -- DISCRIMINANT_CONSTRAINT ::=
3008 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
3010 -- DISCRIMINANT_ASSOCIATION ::=
3011 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
3014 -- This routine parses either an index or a discriminant constraint. As
3015 -- is clear from the above grammar, it is often possible to clearly
3016 -- determine which of the two possibilities we have, but there are
3017 -- cases (those in which we have a series of expressions of the same
3018 -- syntactic form as subtype indications), where we cannot tell. Since
3019 -- this means that in any case the semantic phase has to distinguish
3020 -- between the two, there is not much point in the parser trying to
3021 -- distinguish even those cases where the difference is clear. In any
3022 -- case, if we have a situation like:
3024 -- (A => 123, 235 .. 500)
3026 -- it is not clear which of the two items is the wrong one, better to
3027 -- let the semantic phase give a clear message. Consequently, this
3028 -- routine in general returns a list of items which can be either
3029 -- discrete ranges or discriminant associations.
3031 -- The caller has checked that the initial token is a left paren
3033 -- Error recovery: can raise Error_Resync
3035 function P_Index_Or_Discriminant_Constraint
return Node_Id
is
3036 Scan_State
: Saved_Scan_State
;
3037 Constr_Node
: Node_Id
;
3038 Constr_List
: List_Id
;
3039 Expr_Node
: Node_Id
;
3040 Result_Node
: Node_Id
;
3043 Result_Node
:= New_Node
(N_Index_Or_Discriminant_Constraint
, Token_Ptr
);
3045 Constr_List
:= New_List
;
3046 Set_Constraints
(Result_Node
, Constr_List
);
3048 -- The two syntactic forms are a little mixed up, so what we are doing
3049 -- here is looking at the first entry to determine which case we have
3051 -- A discriminant constraint is a list of discriminant associations,
3052 -- which have one of the following possible forms:
3056 -- Id | Id | .. | Id => Expression
3058 -- An index constraint is a list of discrete ranges which have one
3059 -- of the following possible forms:
3062 -- Subtype_Mark range Range
3064 -- Simple_Expression .. Simple_Expression
3066 -- Loop through discriminants in list
3069 -- Check cases of Id => Expression or Id | Id => Expression
3071 if Token
= Tok_Identifier
then
3072 Save_Scan_State
(Scan_State
); -- at Id
3075 if Token
= Tok_Arrow
or else Token
= Tok_Vertical_Bar
then
3076 Restore_Scan_State
(Scan_State
); -- to Id
3077 Append
(P_Discriminant_Association
, Constr_List
);
3080 Restore_Scan_State
(Scan_State
); -- to Id
3084 -- Otherwise scan out an expression and see what we have got
3086 Expr_Node
:= P_Expression_Or_Range_Attribute
;
3088 if Expr_Form
= EF_Range_Attr
then
3089 Append
(Expr_Node
, Constr_List
);
3091 elsif Token
= Tok_Range
then
3092 if Expr_Form
/= EF_Simple_Name
then
3093 Error_Msg_SC
("subtype mark required before RANGE");
3096 Append
(P_Subtype_Indication
(Expr_Node
), Constr_List
);
3099 -- Check Simple_Expression .. Simple_Expression case
3101 elsif Token
= Tok_Dot_Dot
then
3102 Check_Simple_Expression
(Expr_Node
);
3103 Constr_Node
:= New_Node
(N_Range
, Token_Ptr
);
3104 Set_Low_Bound
(Constr_Node
, Expr_Node
);
3106 Expr_Node
:= P_Expression
;
3107 Check_Simple_Expression
(Expr_Node
);
3108 Set_High_Bound
(Constr_Node
, Expr_Node
);
3109 Append
(Constr_Node
, Constr_List
);
3112 -- Case of an expression which could be either form
3115 Append
(Expr_Node
, Constr_List
);
3119 -- Here with a single entry scanned
3122 exit when not Comma_Present
;
3128 end P_Index_Or_Discriminant_Constraint
;
3130 -------------------------------------
3131 -- 3.7.1 Discriminant Association --
3132 -------------------------------------
3134 -- DISCRIMINANT_ASSOCIATION ::=
3135 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
3138 -- This routine is used only when the name list is present and the caller
3139 -- has already checked this (by scanning ahead and repositioning the
3142 -- Error_Recovery: cannot raise Error_Resync;
3144 function P_Discriminant_Association
return Node_Id
is
3145 Discr_Node
: Node_Id
;
3146 Names_List
: List_Id
;
3147 Ident_Sloc
: Source_Ptr
;
3150 Ident_Sloc
:= Token_Ptr
;
3151 Names_List
:= New_List
;
3154 Append
(P_Identifier
(C_Vertical_Bar_Arrow
), Names_List
);
3155 exit when Token
/= Tok_Vertical_Bar
;
3159 Discr_Node
:= New_Node
(N_Discriminant_Association
, Ident_Sloc
);
3160 Set_Selector_Names
(Discr_Node
, Names_List
);
3162 Set_Expression
(Discr_Node
, P_Expression
);
3164 end P_Discriminant_Association
;
3166 ---------------------------------
3167 -- 3.8 Record Type Definition --
3168 ---------------------------------
3170 -- RECORD_TYPE_DEFINITION ::=
3171 -- [[abstract] tagged] [limited] RECORD_DEFINITION
3173 -- There is no node in the tree for a record type definition. Instead
3174 -- a record definition node appears, with possible Abstract_Present,
3175 -- Tagged_Present, and Limited_Present flags set appropriately.
3177 ----------------------------
3178 -- 3.8 Record Definition --
3179 ----------------------------
3181 -- RECORD_DEFINITION ::=
3187 -- Note: in the case where a record definition node is used to represent
3188 -- a record type definition, the caller sets the Tagged_Present and
3189 -- Limited_Present flags in the resulting N_Record_Definition node as
3192 -- Note that the RECORD token at the start may be missing in certain
3193 -- error situations, so this function is expected to post the error
3195 -- Error recovery: can raise Error_Resync
3197 function P_Record_Definition
return Node_Id
is
3201 Inside_Record_Definition
:= True;
3202 Rec_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
3206 if Token
= Tok_Null
then
3209 Set_Null_Present
(Rec_Node
, True);
3211 -- Catch incomplete declaration to prevent cascaded errors, see
3212 -- ACATS B393002 for an example.
3214 elsif Token
= Tok_Semicolon
then
3215 Error_Msg_AP
("missing record definition");
3217 -- Case starting with RECORD keyword. Build scope stack entry. For the
3218 -- column, we use the first non-blank character on the line, to deal
3219 -- with situations such as:
3225 -- which is not official RM indentation, but is not uncommon usage, and
3226 -- in particular is standard GNAT coding style, so handle it nicely.
3230 Scope
.Table
(Scope
.Last
).Etyp
:= E_Record
;
3231 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
3232 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
3233 Scope
.Table
(Scope
.Last
).Labl
:= Error
;
3234 Scope
.Table
(Scope
.Last
).Junk
:= (Token
/= Tok_Record
);
3238 Set_Component_List
(Rec_Node
, P_Component_List
);
3241 exit when Check_End
;
3242 Discard_Junk_Node
(P_Component_List
);
3246 Inside_Record_Definition
:= False;
3248 end P_Record_Definition
;
3250 -------------------------
3251 -- 3.8 Component List --
3252 -------------------------
3254 -- COMPONENT_LIST ::=
3255 -- COMPONENT_ITEM {COMPONENT_ITEM}
3256 -- | {COMPONENT_ITEM} VARIANT_PART
3259 -- Error recovery: cannot raise Error_Resync
3261 function P_Component_List
return Node_Id
is
3262 Component_List_Node
: Node_Id
;
3263 Decls_List
: List_Id
;
3264 Scan_State
: Saved_Scan_State
;
3267 Component_List_Node
:= New_Node
(N_Component_List
, Token_Ptr
);
3268 Decls_List
:= New_List
;
3270 if Token
= Tok_Null
then
3273 P_Pragmas_Opt
(Decls_List
);
3274 Set_Null_Present
(Component_List_Node
, True);
3275 return Component_List_Node
;
3278 P_Pragmas_Opt
(Decls_List
);
3280 if Token
/= Tok_Case
then
3281 Component_Scan_Loop
: loop
3282 P_Component_Items
(Decls_List
);
3283 P_Pragmas_Opt
(Decls_List
);
3285 exit Component_Scan_Loop
when Token
= Tok_End
3286 or else Token
= Tok_Case
3287 or else Token
= Tok_When
;
3289 -- We are done if we do not have an identifier. However, if
3290 -- we have a misspelled reserved identifier that is in a column
3291 -- to the right of the record definition, we will treat it as
3292 -- an identifier. It turns out to be too dangerous in practice
3293 -- to accept such a mis-spelled identifier which does not have
3294 -- this additional clue that confirms the incorrect spelling.
3296 if Token
/= Tok_Identifier
then
3297 if Start_Column
> Scope
.Table
(Scope
.Last
).Ecol
3298 and then Is_Reserved_Identifier
3300 Save_Scan_State
(Scan_State
); -- at reserved id
3301 Scan
; -- possible reserved id
3303 if Token
= Tok_Comma
or else Token
= Tok_Colon
then
3304 Restore_Scan_State
(Scan_State
);
3305 Scan_Reserved_Identifier
(Force_Msg
=> True);
3307 -- Note reserved identifier used as field name after
3308 -- all because not followed by colon or comma
3311 Restore_Scan_State
(Scan_State
);
3312 exit Component_Scan_Loop
;
3315 -- Non-identifier that definitely was not reserved id
3318 exit Component_Scan_Loop
;
3321 end loop Component_Scan_Loop
;
3324 if Token
= Tok_Case
then
3325 Set_Variant_Part
(Component_List_Node
, P_Variant_Part
);
3327 -- Check for junk after variant part
3329 if Token
= Tok_Identifier
then
3330 Save_Scan_State
(Scan_State
);
3331 Scan
; -- past identifier
3333 if Token
= Tok_Colon
then
3334 Restore_Scan_State
(Scan_State
);
3335 Error_Msg_SC
("component may not follow variant part");
3336 Discard_Junk_Node
(P_Component_List
);
3338 elsif Token
= Tok_Case
then
3339 Restore_Scan_State
(Scan_State
);
3340 Error_Msg_SC
("only one variant part allowed in a record");
3341 Discard_Junk_Node
(P_Component_List
);
3344 Restore_Scan_State
(Scan_State
);
3350 Set_Component_Items
(Component_List_Node
, Decls_List
);
3351 return Component_List_Node
;
3352 end P_Component_List
;
3354 -------------------------
3355 -- 3.8 Component Item --
3356 -------------------------
3358 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
3360 -- COMPONENT_DECLARATION ::=
3361 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
3362 -- [:= DEFAULT_EXPRESSION]
3363 -- [ASPECT_SPECIFICATIONS];
3365 -- COMPONENT_DEFINITION ::=
3366 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
3368 -- Error recovery: cannot raise Error_Resync, if an error occurs,
3369 -- the scan is positioned past the following semicolon.
3371 -- Note: we do not yet allow representation clauses to appear as component
3372 -- items, do we need to add this capability sometime in the future ???
3374 procedure P_Component_Items
(Decls
: List_Id
) is
3375 Aliased_Present
: Boolean := False;
3376 CompDef_Node
: Node_Id
;
3377 Decl_Node
: Node_Id
;
3378 Scan_State
: Saved_Scan_State
;
3379 Not_Null_Present
: Boolean := False;
3382 Ident_Sloc
: Source_Ptr
;
3384 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
3385 -- This array holds the list of defining identifiers. The upper bound
3386 -- of 4096 is intended to be essentially infinite, and we do not even
3387 -- bother to check for it being exceeded.
3390 if Token
/= Tok_Identifier
then
3391 Error_Msg_SC
("component declaration expected");
3392 Resync_Past_Semicolon
;
3396 Ident_Sloc
:= Token_Ptr
;
3397 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
3400 while Comma_Present
loop
3401 Num_Idents
:= Num_Idents
+ 1;
3402 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
3405 -- If there are multiple identifiers, we repeatedly scan the
3406 -- type and initialization expression information by resetting
3407 -- the scan pointer (so that we get completely separate trees
3408 -- for each occurrence).
3410 if Num_Idents
> 1 then
3411 Save_Scan_State
(Scan_State
);
3416 -- Loop through defining identifiers in list
3421 -- The following block is present to catch Error_Resync
3422 -- which causes the parse to be reset past the semicolon
3425 Decl_Node
:= New_Node
(N_Component_Declaration
, Ident_Sloc
);
3426 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
3428 if Token
= Tok_Constant
then
3429 Error_Msg_SC
("constant components are not permitted");
3433 CompDef_Node
:= New_Node
(N_Component_Definition
, Token_Ptr
);
3435 if Token_Name
= Name_Aliased
then
3436 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
3439 if Token
= Tok_Aliased
then
3440 Aliased_Present
:= True;
3441 Scan
; -- past ALIASED
3444 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/AI-254)
3446 -- Ada 2005 (AI-230): Access Definition case
3448 if Token
= Tok_Access
then
3449 if Ada_Version
< Ada_2005
then
3451 ("generalized use of anonymous access types " &
3452 "is an Ada 2005 extension");
3453 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
3456 -- AI95-406 makes "aliased" legal (and useless) here, so the
3457 -- following code which used to be required is commented out.
3459 -- if Aliased_Present then
3460 -- Error_Msg_SP ("ALIASED not allowed here");
3463 Set_Subtype_Indication
(CompDef_Node
, Empty
);
3464 Set_Aliased_Present
(CompDef_Node
, False);
3465 Set_Access_Definition
(CompDef_Node
,
3466 P_Access_Definition
(Not_Null_Present
));
3469 Set_Access_Definition
(CompDef_Node
, Empty
);
3470 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
3471 Set_Null_Exclusion_Present
(CompDef_Node
, Not_Null_Present
);
3473 if Token
= Tok_Array
then
3474 Error_Msg_SC
("anonymous arrays not allowed as components");
3478 Set_Subtype_Indication
(CompDef_Node
,
3479 P_Subtype_Indication
(Not_Null_Present
));
3482 Set_Component_Definition
(Decl_Node
, CompDef_Node
);
3483 Set_Expression
(Decl_Node
, Init_Expr_Opt
);
3486 Set_Prev_Ids
(Decl_Node
, True);
3489 if Ident
< Num_Idents
then
3490 Set_More_Ids
(Decl_Node
, True);
3493 Append
(Decl_Node
, Decls
);
3496 when Error_Resync
=>
3497 if Token
/= Tok_End
then
3498 Resync_Past_Semicolon
;
3502 exit Ident_Loop
when Ident
= Num_Idents
;
3504 Restore_Scan_State
(Scan_State
);
3506 end loop Ident_Loop
;
3508 P_Aspect_Specifications
(Decl_Node
);
3509 end P_Component_Items
;
3511 --------------------------------
3512 -- 3.8 Component Declaration --
3513 --------------------------------
3515 -- Parsed by P_Component_Items (3.8)
3517 -------------------------
3518 -- 3.8.1 Variant Part --
3519 -------------------------
3522 -- case discriminant_DIRECT_NAME is
3527 -- The caller has checked that the initial token is CASE
3529 -- Error recovery: cannot raise Error_Resync
3531 function P_Variant_Part
return Node_Id
is
3532 Variant_Part_Node
: Node_Id
;
3533 Variants_List
: List_Id
;
3534 Case_Node
: Node_Id
;
3537 Variant_Part_Node
:= New_Node
(N_Variant_Part
, Token_Ptr
);
3539 Scope
.Table
(Scope
.Last
).Etyp
:= E_Case
;
3540 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
3541 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
3544 Case_Node
:= P_Expression
;
3545 Set_Name
(Variant_Part_Node
, Case_Node
);
3547 if Nkind
(Case_Node
) /= N_Identifier
then
3548 Set_Name
(Variant_Part_Node
, Error
);
3549 Error_Msg
("discriminant name expected", Sloc
(Case_Node
));
3551 elsif Paren_Count
(Case_Node
) /= 0 then
3553 ("|discriminant name may not be parenthesized",
3555 Set_Paren_Count
(Case_Node
, 0);
3559 Variants_List
:= New_List
;
3560 P_Pragmas_Opt
(Variants_List
);
3562 -- Test missing variant
3564 if Token
= Tok_End
then
3565 Error_Msg_BC
("WHEN expected (must have at least one variant)");
3567 Append
(P_Variant
, Variants_List
);
3570 -- Loop through variants, note that we allow if in place of when,
3571 -- this error will be detected and handled in P_Variant.
3574 P_Pragmas_Opt
(Variants_List
);
3576 if Token
/= Tok_When
3577 and then Token
/= Tok_If
3578 and then Token
/= Tok_Others
3580 exit when Check_End
;
3583 Append
(P_Variant
, Variants_List
);
3586 Set_Variants
(Variant_Part_Node
, Variants_List
);
3587 return Variant_Part_Node
;
3590 --------------------
3592 --------------------
3595 -- when DISCRETE_CHOICE_LIST =>
3598 -- Error recovery: cannot raise Error_Resync
3600 -- The initial token on entry is either WHEN, IF or OTHERS
3602 function P_Variant
return Node_Id
is
3603 Variant_Node
: Node_Id
;
3606 -- Special check to recover nicely from use of IF in place of WHEN
3608 if Token
= Tok_If
then
3615 Variant_Node
:= New_Node
(N_Variant
, Prev_Token_Ptr
);
3616 Set_Discrete_Choices
(Variant_Node
, P_Discrete_Choice_List
);
3618 Set_Component_List
(Variant_Node
, P_Component_List
);
3619 return Variant_Node
;
3622 ---------------------------------
3623 -- 3.8.1 Discrete Choice List --
3624 ---------------------------------
3626 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
3628 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
3630 -- Note: in Ada 83, the expression must be a simple expression
3632 -- Error recovery: cannot raise Error_Resync
3634 function P_Discrete_Choice_List
return List_Id
is
3636 Expr_Node
: Node_Id
;
3637 Choice_Node
: Node_Id
;
3640 Choices
:= New_List
;
3642 if Token
= Tok_Others
then
3643 Append
(New_Node
(N_Others_Choice
, Token_Ptr
), Choices
);
3644 Scan
; -- past OTHERS
3648 -- Scan out expression or range attribute
3650 Expr_Node
:= P_Expression_Or_Range_Attribute
;
3651 Ignore
(Tok_Right_Paren
);
3653 if Token
= Tok_Colon
3654 and then Nkind
(Expr_Node
) = N_Identifier
3656 Error_Msg_SP
("label not permitted in this context");
3661 elsif Expr_Form
= EF_Range_Attr
then
3662 Append
(Expr_Node
, Choices
);
3666 elsif Token
= Tok_Dot_Dot
then
3667 Check_Simple_Expression
(Expr_Node
);
3668 Choice_Node
:= New_Node
(N_Range
, Token_Ptr
);
3669 Set_Low_Bound
(Choice_Node
, Expr_Node
);
3671 Expr_Node
:= P_Expression_No_Right_Paren
;
3672 Check_Simple_Expression
(Expr_Node
);
3673 Set_High_Bound
(Choice_Node
, Expr_Node
);
3674 Append
(Choice_Node
, Choices
);
3676 -- Simple name, must be subtype, so range allowed
3678 elsif Expr_Form
= EF_Simple_Name
then
3679 if Token
= Tok_Range
then
3680 Append
(P_Subtype_Indication
(Expr_Node
), Choices
);
3682 elsif Token
in Token_Class_Consk
then
3684 ("the only constraint allowed here " &
3685 "is a range constraint");
3686 Discard_Junk_Node
(P_Constraint_Opt
);
3687 Append
(Expr_Node
, Choices
);
3690 Append
(Expr_Node
, Choices
);
3696 -- In Ada 2012 mode, the expression must be a simple
3697 -- expression. The reason for this restriction (i.e. going
3698 -- back to the Ada 83 rule) is to avoid ambiguities when set
3699 -- membership operations are allowed, consider the
3702 -- when A in 1 .. 10 | 12 =>
3704 -- This is ambiguous without parentheses, so we require one
3705 -- of the following two parenthesized forms to disambiguate:
3707 -- one of the following:
3709 -- when (A in 1 .. 10 | 12) =>
3710 -- when (A in 1 .. 10) | 12 =>
3712 -- To solve this, in Ada 2012 mode, we disallow the use of
3713 -- membership operations in expressions in choices.
3715 -- Technically in the grammar, the expression must match the
3716 -- grammar for restricted expression.
3718 if Ada_Version
>= Ada_2012
then
3719 Check_Restricted_Expression
(Expr_Node
);
3721 -- In Ada 83 mode, the syntax required a simple expression
3724 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
3727 Append
(Expr_Node
, Choices
);
3731 when Error_Resync
=>
3737 if Token
= Tok_Comma
then
3740 if Token
= Tok_Vertical_Bar
then
3741 Error_Msg_SP
-- CODEFIX
3742 ("|extra "","" ignored");
3746 Error_Msg_SP
-- CODEFIX
3747 (""","" should be ""'|""");
3751 exit when Token
/= Tok_Vertical_Bar
;
3758 end P_Discrete_Choice_List
;
3760 ----------------------------
3761 -- 3.8.1 Discrete Choice --
3762 ----------------------------
3764 -- Parsed by P_Discrete_Choice_List (3.8.1)
3766 ----------------------------------
3767 -- 3.9.1 Record Extension Part --
3768 ----------------------------------
3770 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
3772 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
3774 --------------------------------------
3775 -- 3.9.4 Interface Type Definition --
3776 --------------------------------------
3778 -- INTERFACE_TYPE_DEFINITION ::=
3779 -- [limited | task | protected | synchronized] interface
3780 -- [and INTERFACE_LIST]
3782 -- Error recovery: cannot raise Error_Resync
3784 function P_Interface_Type_Definition
3785 (Abstract_Present
: Boolean) return Node_Id
3787 Typedef_Node
: Node_Id
;
3790 if Ada_Version
< Ada_2005
then
3791 Error_Msg_SP
("abstract interface is an Ada 2005 extension");
3792 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
3795 if Abstract_Present
then
3797 ("ABSTRACT not allowed in interface type definition " &
3801 Scan
; -- past INTERFACE
3803 -- Ada 2005 (AI-345): In case of interfaces with a null list of
3804 -- interfaces we build a record_definition node.
3806 if Token
= Tok_Semicolon
or else Aspect_Specifications_Present
then
3807 Typedef_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
3809 Set_Abstract_Present
(Typedef_Node
);
3810 Set_Tagged_Present
(Typedef_Node
);
3811 Set_Null_Present
(Typedef_Node
);
3812 Set_Interface_Present
(Typedef_Node
);
3814 -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have
3815 -- a list of interfaces we build a derived_type_definition node. This
3816 -- simplifies the semantic analysis (and hence further maintenance)
3819 if Token
/= Tok_And
then
3820 Error_Msg_AP
("AND expected");
3825 Typedef_Node
:= New_Node
(N_Derived_Type_Definition
, Token_Ptr
);
3827 Set_Abstract_Present
(Typedef_Node
);
3828 Set_Interface_Present
(Typedef_Node
);
3829 Set_Subtype_Indication
(Typedef_Node
, P_Qualified_Simple_Name
);
3831 Set_Record_Extension_Part
(Typedef_Node
,
3832 New_Node
(N_Record_Definition
, Token_Ptr
));
3833 Set_Null_Present
(Record_Extension_Part
(Typedef_Node
));
3835 if Token
= Tok_And
then
3836 Set_Interface_List
(Typedef_Node
, New_List
);
3840 Append
(P_Qualified_Simple_Name
,
3841 Interface_List
(Typedef_Node
));
3842 exit when Token
/= Tok_And
;
3848 return Typedef_Node
;
3849 end P_Interface_Type_Definition
;
3851 ----------------------------------
3852 -- 3.10 Access Type Definition --
3853 ----------------------------------
3855 -- ACCESS_TYPE_DEFINITION ::=
3856 -- ACCESS_TO_OBJECT_DEFINITION
3857 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3859 -- ACCESS_TO_OBJECT_DEFINITION ::=
3860 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
3862 -- GENERAL_ACCESS_MODIFIER ::= all | constant
3864 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3865 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3866 -- | [NULL_EXCLUSION] access [protected] function
3867 -- PARAMETER_AND_RESULT_PROFILE
3869 -- PARAMETER_PROFILE ::= [FORMAL_PART]
3871 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
3873 -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already
3874 -- parsed the null_exclusion part and has also removed the ACCESS token;
3875 -- otherwise the caller has just checked that the initial token is ACCESS
3877 -- Error recovery: can raise Error_Resync
3879 function P_Access_Type_Definition
3880 (Header_Already_Parsed
: Boolean := False) return Node_Id
3882 Access_Loc
: constant Source_Ptr
:= Token_Ptr
;
3883 Prot_Flag
: Boolean;
3884 Not_Null_Present
: Boolean := False;
3885 Type_Def_Node
: Node_Id
;
3886 Result_Not_Null
: Boolean;
3887 Result_Node
: Node_Id
;
3889 procedure Check_Junk_Subprogram_Name
;
3890 -- Used in access to subprogram definition cases to check for an
3891 -- identifier or operator symbol that does not belong.
3893 --------------------------------
3894 -- Check_Junk_Subprogram_Name --
3895 --------------------------------
3897 procedure Check_Junk_Subprogram_Name
is
3898 Saved_State
: Saved_Scan_State
;
3901 if Token
= Tok_Identifier
or else Token
= Tok_Operator_Symbol
then
3902 Save_Scan_State
(Saved_State
);
3903 Scan
; -- past possible junk subprogram name
3905 if Token
= Tok_Left_Paren
or else Token
= Tok_Semicolon
then
3906 Error_Msg_SP
("unexpected subprogram name ignored");
3910 Restore_Scan_State
(Saved_State
);
3913 end Check_Junk_Subprogram_Name
;
3915 -- Start of processing for P_Access_Type_Definition
3918 if not Header_Already_Parsed
then
3919 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
3920 Scan
; -- past ACCESS
3923 if Token_Name
= Name_Protected
then
3924 Check_95_Keyword
(Tok_Protected
, Tok_Procedure
);
3925 Check_95_Keyword
(Tok_Protected
, Tok_Function
);
3928 Prot_Flag
:= (Token
= Tok_Protected
);
3931 Scan
; -- past PROTECTED
3933 if Token
/= Tok_Procedure
and then Token
/= Tok_Function
then
3934 Error_Msg_SC
-- CODEFIX
3935 ("FUNCTION or PROCEDURE expected");
3939 if Token
= Tok_Procedure
then
3940 if Ada_Version
= Ada_83
then
3941 Error_Msg_SC
("(Ada 83) access to procedure not allowed!");
3944 Type_Def_Node
:= New_Node
(N_Access_Procedure_Definition
, Access_Loc
);
3945 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3946 Scan
; -- past PROCEDURE
3947 Check_Junk_Subprogram_Name
;
3948 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
3949 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
3951 elsif Token
= Tok_Function
then
3952 if Ada_Version
= Ada_83
then
3953 Error_Msg_SC
("(Ada 83) access to function not allowed!");
3956 Type_Def_Node
:= New_Node
(N_Access_Function_Definition
, Access_Loc
);
3957 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3958 Scan
; -- past FUNCTION
3959 Check_Junk_Subprogram_Name
;
3960 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
3961 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
3964 Result_Not_Null
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
3966 -- Ada 2005 (AI-318-02)
3968 if Token
= Tok_Access
then
3969 if Ada_Version
< Ada_2005
then
3971 ("anonymous access result type is an Ada 2005 extension");
3972 Error_Msg_SC
("\unit must be compiled with -gnat05 switch");
3975 Result_Node
:= P_Access_Definition
(Result_Not_Null
);
3978 Result_Node
:= P_Subtype_Mark
;
3981 -- A null exclusion on the result type must be recorded in a flag
3982 -- distinct from the one used for the access-to-subprogram type's
3985 Set_Null_Exclusion_In_Return_Present
3986 (Type_Def_Node
, Result_Not_Null
);
3989 Set_Result_Definition
(Type_Def_Node
, Result_Node
);
3993 New_Node
(N_Access_To_Object_Definition
, Access_Loc
);
3994 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3996 if Token
= Tok_All
or else Token
= Tok_Constant
then
3997 if Ada_Version
= Ada_83
then
3998 Error_Msg_SC
("(Ada 83) access modifier not allowed!");
4001 if Token
= Tok_All
then
4002 Set_All_Present
(Type_Def_Node
, True);
4005 Set_Constant_Present
(Type_Def_Node
, True);
4008 Scan
; -- past ALL or CONSTANT
4011 Set_Subtype_Indication
(Type_Def_Node
,
4012 P_Subtype_Indication
(Not_Null_Present
));
4015 return Type_Def_Node
;
4016 end P_Access_Type_Definition
;
4018 ---------------------------------------
4019 -- 3.10 Access To Object Definition --
4020 ---------------------------------------
4022 -- Parsed by P_Access_Type_Definition (3.10)
4024 -----------------------------------
4025 -- 3.10 General Access Modifier --
4026 -----------------------------------
4028 -- Parsed by P_Access_Type_Definition (3.10)
4030 -------------------------------------------
4031 -- 3.10 Access To Subprogram Definition --
4032 -------------------------------------------
4034 -- Parsed by P_Access_Type_Definition (3.10)
4036 -----------------------------
4037 -- 3.10 Access Definition --
4038 -----------------------------
4040 -- ACCESS_DEFINITION ::=
4041 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
4042 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
4044 -- ACCESS_TO_SUBPROGRAM_DEFINITION
4045 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
4046 -- | [NULL_EXCLUSION] access [protected] function
4047 -- PARAMETER_AND_RESULT_PROFILE
4049 -- The caller has parsed the null-exclusion part and it has also checked
4050 -- that the next token is ACCESS
4052 -- Error recovery: cannot raise Error_Resync
4054 function P_Access_Definition
4055 (Null_Exclusion_Present
: Boolean) return Node_Id
4058 Subp_Node
: Node_Id
;
4061 Def_Node
:= New_Node
(N_Access_Definition
, Token_Ptr
);
4062 Scan
; -- past ACCESS
4064 -- Ada 2005 (AI-254): Access_To_Subprogram_Definition
4066 if Token
= Tok_Protected
4067 or else Token
= Tok_Procedure
4068 or else Token
= Tok_Function
4070 if Ada_Version
< Ada_2005
then
4071 Error_Msg_SP
("access-to-subprogram is an Ada 2005 extension");
4072 Error_Msg_SP
("\unit should be compiled with -gnat05 switch");
4075 Subp_Node
:= P_Access_Type_Definition
(Header_Already_Parsed
=> True);
4076 Set_Null_Exclusion_Present
(Subp_Node
, Null_Exclusion_Present
);
4077 Set_Access_To_Subprogram_Definition
(Def_Node
, Subp_Node
);
4079 -- Ada 2005 (AI-231)
4080 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
4083 Set_Null_Exclusion_Present
(Def_Node
, Null_Exclusion_Present
);
4085 if Token
= Tok_All
then
4086 if Ada_Version
< Ada_2005
then
4088 ("ALL is not permitted for anonymous access types");
4092 Set_All_Present
(Def_Node
);
4094 elsif Token
= Tok_Constant
then
4095 if Ada_Version
< Ada_2005
then
4096 Error_Msg_SP
("access-to-constant is an Ada 2005 extension");
4097 Error_Msg_SP
("\unit should be compiled with -gnat05 switch");
4100 Scan
; -- past CONSTANT
4101 Set_Constant_Present
(Def_Node
);
4104 Set_Subtype_Mark
(Def_Node
, P_Subtype_Mark
);
4109 end P_Access_Definition
;
4111 -----------------------------------------
4112 -- 3.10.1 Incomplete Type Declaration --
4113 -----------------------------------------
4115 -- Parsed by P_Type_Declaration (3.2.1)
4117 ----------------------------
4118 -- 3.11 Declarative Part --
4119 ----------------------------
4121 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
4123 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items
4124 -- handles errors, and returns cleanly after an error has occurred)
4126 function P_Declarative_Part
return List_Id
is
4131 -- Indicate no bad declarations detected yet. This will be reset by
4132 -- P_Declarative_Items if a bad declaration is discovered.
4134 Missing_Begin_Msg
:= No_Error_Msg
;
4136 -- Get rid of active SIS entry from outer scope. This means we will
4137 -- miss some nested cases, but it doesn't seem worth the effort. See
4138 -- discussion in Par for further details
4140 SIS_Entry_Active
:= False;
4143 -- Loop to scan out the declarations
4146 P_Declarative_Items
(Decls
, Done
, In_Spec
=> False);
4150 -- Get rid of active SIS entry which is left set only if we scanned a
4151 -- procedure declaration and have not found the body. We could give
4152 -- an error message, but that really would be usurping the role of
4153 -- semantic analysis (this really is a missing body case).
4155 SIS_Entry_Active
:= False;
4157 end P_Declarative_Part
;
4159 ----------------------------
4160 -- 3.11 Declarative Item --
4161 ----------------------------
4163 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
4165 -- Can return Error if a junk declaration is found, or Empty if no
4166 -- declaration is found (i.e. a token ending declarations, such as
4167 -- BEGIN or END is encountered).
4169 -- Error recovery: cannot raise Error_Resync. If an error resync occurs,
4170 -- then the scan is set past the next semicolon and Error is returned.
4172 procedure P_Declarative_Items
4177 Scan_State
: Saved_Scan_State
;
4181 Style
.Check_Indentation
;
4186 when Tok_Function
=>
4188 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4194 -- Check for loop (premature statement)
4196 Save_Scan_State
(Scan_State
);
4199 if Token
= Tok_Identifier
then
4200 Scan
; -- past identifier
4202 if Token
= Tok_In
then
4203 Restore_Scan_State
(Scan_State
);
4204 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4209 -- Not a loop, so must be rep clause
4211 Restore_Scan_State
(Scan_State
);
4212 Append
(P_Representation_Clause
, Decls
);
4217 Append
(P_Generic
, Decls
);
4220 when Tok_Identifier
=>
4223 -- Special check for misuse of overriding not in Ada 2005 mode
4225 if Token_Name
= Name_Overriding
4226 and then not Next_Token_Is
(Tok_Colon
)
4228 Error_Msg_SC
("overriding indicator is an Ada 2005 extension");
4229 Error_Msg_SC
("\unit must be compiled with -gnat05 switch");
4231 Token
:= Tok_Overriding
;
4232 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4235 -- Normal case, no overriding, or overriding followed by colon
4238 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4241 -- Ada 2005: A subprogram declaration can start with "not" or
4242 -- "overriding". In older versions, "overriding" is handled
4243 -- like an identifier, with the appropriate messages.
4247 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4250 when Tok_Overriding
=>
4252 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4257 Append
(P_Package
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4261 Append
(P_Pragma
, Decls
);
4264 when Tok_Procedure
=>
4266 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4269 when Tok_Protected
=>
4271 Scan
; -- past PROTECTED
4272 Append
(P_Protected
, Decls
);
4277 Append
(P_Subtype_Declaration
, Decls
);
4283 Append
(P_Task
, Decls
);
4288 Append
(P_Type_Declaration
, Decls
);
4293 Append
(P_Use_Clause
, Decls
);
4299 if Aspect_Specifications_Present
then
4301 -- If we are after a semicolon, complain that it was ignored.
4302 -- But we don't really ignore it, since we dump the aspects,
4303 -- so we make the error message a normal fatal message which
4304 -- will inhibit semantic analysis anyway).
4306 if Prev_Token
= Tok_Semicolon
then
4307 Error_Msg_SP
-- CODEFIX
4308 ("extra "";"" ignored");
4310 -- If not just past semicolon, just complain that aspects are
4311 -- not allowed at this point.
4314 Error_Msg_SC
("aspect specifications not allowed here");
4318 Dummy_Node
: constant Node_Id
:=
4319 New_Node
(N_Package_Specification
, Token_Ptr
);
4320 pragma Warnings
(Off
, Dummy_Node
);
4321 -- Dummy node to attach aspect specifications to. We will
4322 -- then throw them away.
4325 P_Aspect_Specifications
(Dummy_Node
, Semicolon
=> True);
4328 -- Here if not aspect specifications case
4331 Error_Msg_SC
("WITH can only appear in context clause");
4335 -- BEGIN terminates the scan of a sequence of declarations unless
4336 -- there is a missing subprogram body, see section on handling
4337 -- semicolon in place of IS. We only treat the begin as satisfying
4338 -- the subprogram declaration if it falls in the expected column
4342 if SIS_Entry_Active
and then Start_Column
>= SIS_Ecol
then
4344 -- Here we have the case where a BEGIN is encountered during
4345 -- declarations in a declarative part, or at the outer level,
4346 -- and there is a subprogram declaration outstanding for which
4347 -- no body has been supplied. This is the case where we assume
4348 -- that the semicolon in the subprogram declaration should
4349 -- really have been is. The active SIS entry describes the
4350 -- subprogram declaration. On return the declaration has been
4351 -- modified to become a body.
4354 Specification_Node
: Node_Id
;
4355 Decl_Node
: Node_Id
;
4356 Body_Node
: Node_Id
;
4359 -- First issue the error message. If we had a missing
4360 -- semicolon in the declaration, then change the message
4361 -- to <missing "is">
4363 if SIS_Missing_Semicolon_Message
/= No_Error_Msg
then
4364 Change_Error_Text
-- Replace: "missing "";"" "
4365 (SIS_Missing_Semicolon_Message
, "missing ""is""");
4367 -- Otherwise we saved the semicolon position, so complain
4370 Error_Msg
-- CODEFIX
4371 ("|"";"" should be IS", SIS_Semicolon_Sloc
);
4374 -- The next job is to fix up any declarations that occurred
4375 -- between the procedure header and the BEGIN. These got
4376 -- chained to the outer declarative region (immediately
4377 -- after the procedure declaration) and they should be
4378 -- chained to the subprogram itself, which is a body
4379 -- rather than a spec.
4381 Specification_Node
:= Specification
(SIS_Declaration_Node
);
4382 Change_Node
(SIS_Declaration_Node
, N_Subprogram_Body
);
4383 Body_Node
:= SIS_Declaration_Node
;
4384 Set_Specification
(Body_Node
, Specification_Node
);
4385 Set_Declarations
(Body_Node
, New_List
);
4388 Decl_Node
:= Remove_Next
(Body_Node
);
4389 exit when Decl_Node
= Empty
;
4390 Append
(Decl_Node
, Declarations
(Body_Node
));
4393 -- Now make the scope table entry for the Begin-End and
4397 Scope
.Table
(Scope
.Last
).Sloc
:= SIS_Sloc
;
4398 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
4399 Scope
.Table
(Scope
.Last
).Ecol
:= SIS_Ecol
;
4400 Scope
.Table
(Scope
.Last
).Labl
:= SIS_Labl
;
4401 Scope
.Table
(Scope
.Last
).Lreq
:= False;
4402 SIS_Entry_Active
:= False;
4404 Set_Handled_Statement_Sequence
(Body_Node
,
4405 P_Handled_Sequence_Of_Statements
);
4406 End_Statements
(Handled_Statement_Sequence
(Body_Node
));
4415 -- Normally an END terminates the scan for basic declarative items.
4416 -- The one exception is END RECORD, which is probably left over from
4420 Save_Scan_State
(Scan_State
); -- at END
4423 if Token
= Tok_Record
then
4424 Error_Msg_SP
("no RECORD for this `end record`!");
4425 Scan
; -- past RECORD
4429 Restore_Scan_State
(Scan_State
); -- to END
4433 -- The following tokens which can only be the start of a statement
4434 -- are considered to end a declarative part (i.e. we have a missing
4435 -- BEGIN situation). We are fairly conservative in making this
4436 -- judgment, because it is a real mess to go into statement mode
4437 -- prematurely in response to a junk declaration.
4452 -- But before we decide that it's a statement, let's check for
4453 -- a reserved word misused as an identifier.
4455 if Is_Reserved_Identifier
then
4456 Save_Scan_State
(Scan_State
);
4457 Scan
; -- past the token
4459 -- If reserved identifier not followed by colon or comma, then
4460 -- this is most likely an assignment statement to the bad id.
4462 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
4463 Restore_Scan_State
(Scan_State
);
4464 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4467 -- Otherwise we have a declaration of the bad id
4470 Restore_Scan_State
(Scan_State
);
4471 Scan_Reserved_Identifier
(Force_Msg
=> True);
4472 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4475 -- If not reserved identifier, then it's definitely a statement
4478 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4482 -- The token RETURN may well also signal a missing BEGIN situation,
4483 -- however, we never let it end the declarative part, because it may
4484 -- also be part of a half-baked function declaration.
4487 Error_Msg_SC
("misplaced RETURN statement");
4490 -- PRIVATE definitely terminates the declarations in a spec,
4491 -- and is an error in a body.
4497 Error_Msg_SC
("PRIVATE not allowed in body");
4498 Scan
; -- past PRIVATE
4501 -- An end of file definitely terminates the declarations!
4506 -- The remaining tokens do not end the scan, but cannot start a
4507 -- valid declaration, so we signal an error and resynchronize.
4508 -- But first check for misuse of a reserved identifier.
4512 -- Here we check for a reserved identifier
4514 if Is_Reserved_Identifier
then
4515 Save_Scan_State
(Scan_State
);
4516 Scan
; -- past the token
4518 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
4519 Restore_Scan_State
(Scan_State
);
4520 Set_Declaration_Expected
;
4523 Restore_Scan_State
(Scan_State
);
4524 Scan_Reserved_Identifier
(Force_Msg
=> True);
4526 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4530 Set_Declaration_Expected
;
4535 -- To resynchronize after an error, we scan to the next semicolon and
4536 -- return with Done = False, indicating that there may still be more
4537 -- valid declarations to come.
4540 when Error_Resync
=>
4541 Resync_Past_Semicolon
;
4543 end P_Declarative_Items
;
4545 ----------------------------------
4546 -- 3.11 Basic Declarative Item --
4547 ----------------------------------
4549 -- BASIC_DECLARATIVE_ITEM ::=
4550 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
4552 -- Scan zero or more basic declarative items
4554 -- Error recovery: cannot raise Error_Resync. If an error is detected, then
4555 -- the scan pointer is repositioned past the next semicolon, and the scan
4556 -- for declarative items continues.
4558 function P_Basic_Declarative_Items
return List_Id
is
4565 -- Indicate no bad declarations detected yet in the current context:
4566 -- visible or private declarations of a package spec.
4568 Missing_Begin_Msg
:= No_Error_Msg
;
4570 -- Get rid of active SIS entry from outer scope. This means we will
4571 -- miss some nested cases, but it doesn't seem worth the effort. See
4572 -- discussion in Par for further details
4574 SIS_Entry_Active
:= False;
4576 -- Loop to scan out declarations
4581 P_Declarative_Items
(Decls
, Done
, In_Spec
=> True);
4585 -- Get rid of active SIS entry. This is set only if we have scanned a
4586 -- procedure declaration and have not found the body. We could give
4587 -- an error message, but that really would be usurping the role of
4588 -- semantic analysis (this really is a case of a missing body).
4590 SIS_Entry_Active
:= False;
4592 -- Test for assorted illegal declarations not diagnosed elsewhere
4594 Decl
:= First
(Decls
);
4596 while Present
(Decl
) loop
4597 Kind
:= Nkind
(Decl
);
4599 -- Test for body scanned, not acceptable as basic decl item
4601 if Kind
= N_Subprogram_Body
or else
4602 Kind
= N_Package_Body
or else
4603 Kind
= N_Task_Body
or else
4604 Kind
= N_Protected_Body
4606 Error_Msg
("proper body not allowed in package spec", Sloc
(Decl
));
4608 -- Test for body stub scanned, not acceptable as basic decl item
4610 elsif Kind
in N_Body_Stub
then
4611 Error_Msg
("body stub not allowed in package spec", Sloc
(Decl
));
4613 elsif Kind
= N_Assignment_Statement
then
4615 ("assignment statement not allowed in package spec",
4623 end P_Basic_Declarative_Items
;
4629 -- For proper body, see below
4630 -- For body stub, see 10.1.3
4632 -----------------------
4633 -- 3.11 Proper Body --
4634 -----------------------
4636 -- Subprogram body is parsed by P_Subprogram (6.1)
4637 -- Package body is parsed by P_Package (7.1)
4638 -- Task body is parsed by P_Task (9.1)
4639 -- Protected body is parsed by P_Protected (9.4)
4641 ------------------------------
4642 -- Set_Declaration_Expected --
4643 ------------------------------
4645 procedure Set_Declaration_Expected
is
4647 Error_Msg_SC
("declaration expected");
4649 if Missing_Begin_Msg
= No_Error_Msg
then
4650 Missing_Begin_Msg
:= Get_Msg_Id
;
4652 end Set_Declaration_Expected
;
4654 ----------------------
4655 -- Skip_Declaration --
4656 ----------------------
4658 procedure Skip_Declaration
(S
: List_Id
) is
4659 Dummy_Done
: Boolean;
4660 pragma Warnings
(Off
, Dummy_Done
);
4662 P_Declarative_Items
(S
, Dummy_Done
, False);
4663 end Skip_Declaration
;
4665 -----------------------------------------
4666 -- Statement_When_Declaration_Expected --
4667 -----------------------------------------
4669 procedure Statement_When_Declaration_Expected
4675 -- Case of second occurrence of statement in one declaration sequence
4677 if Missing_Begin_Msg
/= No_Error_Msg
then
4679 -- In the procedure spec case, just ignore it, we only give one
4680 -- message for the first occurrence, since otherwise we may get
4681 -- horrible cascading if BODY was missing in the header line.
4686 -- In the declarative part case, take a second statement as a sure
4687 -- sign that we really have a missing BEGIN, and end the declarative
4688 -- part now. Note that the caller will fix up the first message to
4689 -- say "missing BEGIN" so that's how the error will be signalled.
4696 -- Case of first occurrence of unexpected statement
4699 -- If we are in a package spec, then give message of statement
4700 -- not allowed in package spec. This message never gets changed.
4703 Error_Msg_SC
("statement not allowed in package spec");
4705 -- If in declarative part, then we give the message complaining
4706 -- about finding a statement when a declaration is expected. This
4707 -- gets changed to a complaint about a missing BEGIN if we later
4708 -- find that no BEGIN is present.
4711 Error_Msg_SC
("statement not allowed in declarative part");
4714 -- Capture message Id. This is used for two purposes, first to
4715 -- stop multiple messages, see test above, and second, to allow
4716 -- the replacement of the message in the declarative part case.
4718 Missing_Begin_Msg
:= Get_Msg_Id
;
4721 -- In all cases except the case in which we decided to terminate the
4722 -- declaration sequence on a second error, we scan out the statement
4723 -- and append it to the list of declarations (note that the semantics
4724 -- can handle statements in a declaration list so if we proceed to
4725 -- call the semantic phase, all will be (reasonably) well!
4727 Append_List_To
(Decls
, P_Sequence_Of_Statements
(SS_Unco
));
4729 -- Done is set to False, since we want to continue the scan of
4730 -- declarations, hoping that this statement was a temporary glitch.
4731 -- If we indeed are now in the statement part (i.e. this was a missing
4732 -- BEGIN, then it's not terrible, we will simply keep calling this
4733 -- procedure to process the statements one by one, and then finally
4734 -- hit the missing BEGIN, which will clean up the error message.
4737 end Statement_When_Declaration_Expected
;