1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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 if Token
= Tok_Identifier
then
215 -- Ada 2005 (AI-284): Compiling in Ada95 mode we warn that INTERFACE,
216 -- OVERRIDING, and SYNCHRONIZED are new reserved words. Note that
217 -- in the case where these keywords are misused in Ada 95 mode,
218 -- this routine will generally not be called at all.
220 if Ada_Version
= Ada_95
221 and then Warn_On_Ada_2005_Compatibility
223 if Token_Name
= Name_Overriding
224 or else Token_Name
= Name_Synchronized
225 or else (Token_Name
= Name_Interface
226 and then Prev_Token
/= Tok_Pragma
)
228 Error_Msg_N
("& is a reserved word in Ada 2005?", Token_Node
);
232 -- If we have a reserved identifier, manufacture an identifier with
233 -- a corresponding name after posting an appropriate error message
235 elsif Is_Reserved_Identifier
(C
) then
236 Scan_Reserved_Identifier
(Force_Msg
=> True);
238 -- Otherwise we have junk that cannot be interpreted as an identifier
241 T_Identifier
; -- to give message
245 Ident_Node
:= Token_Node
;
246 Scan
; -- past the reserved identifier
248 -- If we already have a defining identifier, clean it out and make
249 -- a new clean identifier. This situation arises in some error cases
250 -- and we need to fix it.
252 if Nkind
(Ident_Node
) = N_Defining_Identifier
then
253 Ident_Node
:= Make_Identifier
(Sloc
(Ident_Node
), Chars
(Ident_Node
));
256 -- Change identifier to defining identifier if not in error
258 if Ident_Node
/= Error
then
259 Change_Identifier_To_Defining_Identifier
(Ident_Node
);
263 end P_Defining_Identifier
;
265 -----------------------------
266 -- 3.2.1 Type Declaration --
267 -----------------------------
269 -- TYPE_DECLARATION ::=
270 -- FULL_TYPE_DECLARATION
271 -- | INCOMPLETE_TYPE_DECLARATION
272 -- | PRIVATE_TYPE_DECLARATION
273 -- | PRIVATE_EXTENSION_DECLARATION
275 -- FULL_TYPE_DECLARATION ::=
276 -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION
277 -- [ASPECT_SPECIFICATIONS];
278 -- | CONCURRENT_TYPE_DECLARATION
280 -- INCOMPLETE_TYPE_DECLARATION ::=
281 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [is tagged];
283 -- PRIVATE_TYPE_DECLARATION ::=
284 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
285 -- is [abstract] [tagged] [limited] private;
287 -- PRIVATE_EXTENSION_DECLARATION ::=
288 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
289 -- [abstract] [limited | synchronized]
290 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
293 -- TYPE_DEFINITION ::=
294 -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
295 -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION
296 -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION
297 -- | DERIVED_TYPE_DEFINITION | INTERFACE_TYPE_DEFINITION
299 -- INTEGER_TYPE_DEFINITION ::=
300 -- SIGNED_INTEGER_TYPE_DEFINITION
301 -- MODULAR_TYPE_DEFINITION
303 -- INTERFACE_TYPE_DEFINITION ::=
304 -- [limited | task | protected | synchronized ] interface
305 -- [and INTERFACE_LIST]
307 -- Error recovery: can raise Error_Resync
309 -- The processing for full type declarations, incomplete type declarations,
310 -- private type declarations and type definitions is included in this
311 -- function. The processing for concurrent type declarations is NOT here,
312 -- but rather in chapter 9 (this function handles only declarations
313 -- starting with TYPE).
315 function P_Type_Declaration
return Node_Id
is
316 Abstract_Present
: Boolean := False;
317 Abstract_Loc
: Source_Ptr
:= No_Location
;
319 Discr_List
: List_Id
;
320 Discr_Sloc
: Source_Ptr
;
322 Ident_Node
: Node_Id
;
323 Is_Derived_Iface
: Boolean := False;
324 Type_Loc
: Source_Ptr
;
325 Type_Start_Col
: Column_Number
;
326 Unknown_Dis
: Boolean;
328 Typedef_Node
: Node_Id
;
329 -- Normally holds type definition, except in the case of a private
330 -- extension declaration, in which case it holds the declaration itself
333 Type_Loc
:= Token_Ptr
;
334 Type_Start_Col
:= Start_Column
;
336 -- If we have TYPE, then proceed ahead and scan identifier
338 if Token
= Tok_Type
then
339 Type_Token_Location
:= Type_Loc
;
341 Ident_Node
:= P_Defining_Identifier
(C_Is
);
343 -- Otherwise this is an error case
347 Type_Token_Location
:= Type_Loc
;
348 Ident_Node
:= P_Defining_Identifier
(C_Is
);
351 Discr_Sloc
:= Token_Ptr
;
353 if P_Unknown_Discriminant_Part_Opt
then
355 Discr_List
:= No_List
;
357 Unknown_Dis
:= False;
358 Discr_List
:= P_Known_Discriminant_Part_Opt
;
361 -- Incomplete type declaration. We complete the processing for this
362 -- case here and return the resulting incomplete type declaration node
364 if Token
= Tok_Semicolon
then
366 Decl_Node
:= New_Node
(N_Incomplete_Type_Declaration
, Type_Loc
);
367 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
368 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
369 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
376 -- Full type declaration or private type declaration, must have IS
378 if Token
= Tok_Equal
then
380 Scan
; -- past = used in place of IS
382 elsif Token
= Tok_Renames
then
383 Error_Msg_SC
-- CODEFIX
384 ("RENAMES should be IS");
385 Scan
; -- past RENAMES used in place of IS
391 -- First an error check, if we have two identifiers in a row, a likely
392 -- possibility is that the first of the identifiers is an incorrectly
395 if Token
= Tok_Identifier
then
397 SS
: Saved_Scan_State
;
401 Save_Scan_State
(SS
);
402 Scan
; -- past initial identifier
403 I2
:= (Token
= Tok_Identifier
);
404 Restore_Scan_State
(SS
);
408 (Bad_Spelling_Of
(Tok_Abstract
) or else
409 Bad_Spelling_Of
(Tok_Access
) or else
410 Bad_Spelling_Of
(Tok_Aliased
) or else
411 Bad_Spelling_Of
(Tok_Constant
))
418 -- Check for misuse of Ada 95 keyword abstract in Ada 83 mode
420 if Token_Name
= Name_Abstract
then
421 Check_95_Keyword
(Tok_Abstract
, Tok_Tagged
);
422 Check_95_Keyword
(Tok_Abstract
, Tok_New
);
425 -- Check cases of misuse of ABSTRACT
427 if Token
= Tok_Abstract
then
428 Abstract_Present
:= True;
429 Abstract_Loc
:= Token_Ptr
;
430 Scan
; -- past ABSTRACT
432 -- Ada 2005 (AI-419): AARM 3.4 (2/2)
434 if (Ada_Version
< Ada_2005
and then Token
= Tok_Limited
)
435 or else Token
= Tok_Private
436 or else Token
= Tok_Record
437 or else Token
= Tok_Null
439 Error_Msg_AP
("TAGGED expected");
443 -- Check for misuse of Ada 95 keyword Tagged
445 if Token_Name
= Name_Tagged
then
446 Check_95_Keyword
(Tok_Tagged
, Tok_Private
);
447 Check_95_Keyword
(Tok_Tagged
, Tok_Limited
);
448 Check_95_Keyword
(Tok_Tagged
, Tok_Record
);
451 -- Special check for misuse of Aliased
453 if Token
= Tok_Aliased
or else Token_Name
= Name_Aliased
then
454 Error_Msg_SC
("ALIASED not allowed in type definition");
455 Scan
; -- past ALIASED
458 -- The following processing deals with either a private type declaration
459 -- or a full type declaration. In the private type case, we build the
460 -- N_Private_Type_Declaration node, setting its Tagged_Present and
461 -- Limited_Present flags, on encountering the Private keyword, and
462 -- leave Typedef_Node set to Empty. For the full type declaration
463 -- case, Typedef_Node gets set to the type definition.
465 Typedef_Node
:= Empty
;
467 -- Switch on token following the IS. The loop normally runs once. It
468 -- only runs more than once if an error is detected, to try again after
469 -- detecting and fixing up the error.
475 Tok_Not
=> -- Ada 2005 (AI-231)
476 Typedef_Node
:= P_Access_Type_Definition
;
480 Typedef_Node
:= P_Array_Type_Definition
;
484 Typedef_Node
:= P_Fixed_Point_Definition
;
488 Typedef_Node
:= P_Floating_Point_Definition
;
494 when Tok_Integer_Literal
=>
496 Typedef_Node
:= P_Signed_Integer_Type_Definition
;
500 Typedef_Node
:= P_Record_Definition
;
503 when Tok_Left_Paren
=>
504 Typedef_Node
:= P_Enumeration_Type_Definition
;
506 End_Labl
:= Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
507 Set_Comes_From_Source
(End_Labl
, False);
509 Set_End_Label
(Typedef_Node
, End_Labl
);
513 Typedef_Node
:= P_Modular_Type_Definition
;
517 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
519 if Nkind
(Typedef_Node
) = N_Derived_Type_Definition
520 and then Present
(Record_Extension_Part
(Typedef_Node
))
522 End_Labl
:= Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
523 Set_Comes_From_Source
(End_Labl
, False);
526 (Record_Extension_Part
(Typedef_Node
), End_Labl
);
532 Typedef_Node
:= P_Signed_Integer_Type_Definition
;
536 Typedef_Node
:= P_Record_Definition
;
538 End_Labl
:= Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
539 Set_Comes_From_Source
(End_Labl
, False);
541 Set_End_Label
(Typedef_Node
, End_Labl
);
547 -- Ada 2005 (AI-326): If the words IS TAGGED appear, the type
548 -- is a tagged incomplete type.
550 if Ada_Version
>= Ada_2005
551 and then Token
= Tok_Semicolon
556 New_Node
(N_Incomplete_Type_Declaration
, Type_Loc
);
557 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
558 Set_Tagged_Present
(Decl_Node
);
559 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
560 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
565 if Token
= Tok_Abstract
then
566 Error_Msg_SC
-- CODEFIX
567 ("ABSTRACT must come before TAGGED");
568 Abstract_Present
:= True;
569 Abstract_Loc
:= Token_Ptr
;
570 Scan
; -- past ABSTRACT
573 if Token
= Tok_Limited
then
574 Scan
; -- past LIMITED
576 -- TAGGED LIMITED PRIVATE case
578 if Token
= Tok_Private
then
580 New_Node
(N_Private_Type_Declaration
, Type_Loc
);
581 Set_Tagged_Present
(Decl_Node
, True);
582 Set_Limited_Present
(Decl_Node
, True);
583 Scan
; -- past PRIVATE
585 -- TAGGED LIMITED RECORD
588 Typedef_Node
:= P_Record_Definition
;
589 Set_Tagged_Present
(Typedef_Node
, True);
590 Set_Limited_Present
(Typedef_Node
, True);
593 Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
594 Set_Comes_From_Source
(End_Labl
, False);
596 Set_End_Label
(Typedef_Node
, End_Labl
);
602 if Token
= Tok_Private
then
604 New_Node
(N_Private_Type_Declaration
, Type_Loc
);
605 Set_Tagged_Present
(Decl_Node
, True);
606 Scan
; -- past PRIVATE
611 Typedef_Node
:= P_Record_Definition
;
612 Set_Tagged_Present
(Typedef_Node
, True);
615 Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
616 Set_Comes_From_Source
(End_Labl
, False);
618 Set_End_Label
(Typedef_Node
, End_Labl
);
625 Scan
; -- past LIMITED
628 if Token
= Tok_Tagged
then
629 Error_Msg_SC
-- CODEFIX
630 ("TAGGED must come before LIMITED");
633 elsif Token
= Tok_Abstract
then
634 Error_Msg_SC
-- CODEFIX
635 ("ABSTRACT must come before LIMITED");
636 Scan
; -- past ABSTRACT
643 -- LIMITED RECORD or LIMITED NULL RECORD
645 if Token
= Tok_Record
or else Token
= Tok_Null
then
646 if Ada_Version
= Ada_83
then
648 ("(Ada 83) limited record declaration not allowed!");
650 -- In Ada2005, "abstract limited" can appear before "new",
651 -- but it cannot be part of an untagged record declaration.
653 elsif Abstract_Present
654 and then Prev_Token
/= Tok_Tagged
656 Error_Msg_SP
("TAGGED expected");
659 Typedef_Node
:= P_Record_Definition
;
660 Set_Limited_Present
(Typedef_Node
, True);
662 -- Ada 2005 (AI-251): LIMITED INTERFACE
664 -- If we are compiling in Ada 83 or Ada 95 mode, "interface"
665 -- is not a reserved word but we force its analysis to
666 -- generate the corresponding usage error.
668 elsif Token
= Tok_Interface
669 or else (Token
= Tok_Identifier
670 and then Chars
(Token_Node
) = Name_Interface
)
673 P_Interface_Type_Definition
(Abstract_Present
);
674 Abstract_Present
:= True;
675 Set_Limited_Present
(Typedef_Node
);
677 if Nkind
(Typedef_Node
) = N_Derived_Type_Definition
then
678 Is_Derived_Iface
:= True;
681 -- Ada 2005 (AI-419): LIMITED NEW
683 elsif Token
= Tok_New
then
684 if Ada_Version
< Ada_2005
then
686 ("LIMITED in derived type is an Ada 2005 extension");
688 ("\unit must be compiled with -gnat05 switch");
691 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
692 Set_Limited_Present
(Typedef_Node
);
694 if Nkind
(Typedef_Node
) = N_Derived_Type_Definition
695 and then Present
(Record_Extension_Part
(Typedef_Node
))
698 Make_Identifier
(Token_Ptr
, Chars
(Ident_Node
));
699 Set_Comes_From_Source
(End_Labl
, False);
702 (Record_Extension_Part
(Typedef_Node
), End_Labl
);
705 -- LIMITED PRIVATE is the only remaining possibility here
708 Decl_Node
:= New_Node
(N_Private_Type_Declaration
, Type_Loc
);
709 Set_Limited_Present
(Decl_Node
, True);
710 T_Private
; -- past PRIVATE (or complain if not there!)
715 -- Here we have an identifier after the IS, which is certainly
716 -- wrong and which might be one of several different mistakes.
718 when Tok_Identifier
=>
720 -- First case, if identifier is on same line, then probably we
721 -- have something like "type X is Integer .." and the best
722 -- diagnosis is a missing NEW. Note: the missing new message
723 -- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl.
725 if not Token_Is_At_Start_Of_Line
then
726 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
728 -- If the identifier is at the start of the line, and is in the
729 -- same column as the type declaration itself then we consider
730 -- that we had a missing type definition on the previous line
732 elsif Start_Column
<= Type_Start_Col
then
733 Error_Msg_AP
("type definition expected");
734 Typedef_Node
:= Error
;
736 -- If the identifier is at the start of the line, and is in
737 -- a column to the right of the type declaration line, then we
738 -- may have something like:
743 -- and the best diagnosis is a missing record keyword
746 Typedef_Node
:= P_Record_Definition
;
751 -- Ada 2005 (AI-251): INTERFACE
753 when Tok_Interface
=>
754 Typedef_Node
:= P_Interface_Type_Definition
(Abstract_Present
);
755 Abstract_Present
:= True;
759 Decl_Node
:= New_Node
(N_Private_Type_Declaration
, Type_Loc
);
760 Scan
; -- past PRIVATE
762 -- Check error cases of private [abstract] tagged
764 if Token
= Tok_Abstract
then
765 Error_Msg_SC
("`ABSTRACT TAGGED` must come before PRIVATE");
766 Scan
; -- past ABSTRACT
768 if Token
= Tok_Tagged
then
772 elsif Token
= Tok_Tagged
then
773 Error_Msg_SC
("TAGGED must come before PRIVATE");
779 -- Ada 2005 (AI-345): Protected, synchronized or task interface
780 -- or Ada 2005 (AI-443): Synchronized private extension.
787 Saved_Token
: constant Token_Type
:= Token
;
790 Scan
; -- past TASK, PROTECTED or SYNCHRONIZED
792 -- Synchronized private extension
794 if Token
= Tok_New
then
795 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
797 if Saved_Token
= Tok_Synchronized
then
798 if Nkind
(Typedef_Node
) =
799 N_Derived_Type_Definition
802 ("SYNCHRONIZED not allowed for record extension",
805 Set_Synchronized_Present
(Typedef_Node
);
809 Error_Msg_SC
("invalid kind of private extension");
815 if Token
/= Tok_Interface
then
816 Error_Msg_SC
("NEW or INTERFACE expected");
820 P_Interface_Type_Definition
(Abstract_Present
);
821 Abstract_Present
:= True;
825 Set_Task_Present
(Typedef_Node
);
827 when Tok_Protected
=>
828 Set_Protected_Present
(Typedef_Node
);
830 when Tok_Synchronized
=>
831 Set_Synchronized_Present
(Typedef_Node
);
834 pragma Assert
(False);
842 -- Anything else is an error
845 if Bad_Spelling_Of
(Tok_Access
)
847 Bad_Spelling_Of
(Tok_Array
)
849 Bad_Spelling_Of
(Tok_Delta
)
851 Bad_Spelling_Of
(Tok_Digits
)
853 Bad_Spelling_Of
(Tok_Limited
)
855 Bad_Spelling_Of
(Tok_Private
)
857 Bad_Spelling_Of
(Tok_Range
)
859 Bad_Spelling_Of
(Tok_Record
)
861 Bad_Spelling_Of
(Tok_Tagged
)
866 Error_Msg_AP
("type definition expected");
873 -- For the private type declaration case, the private type declaration
874 -- node has been built, with the Tagged_Present and Limited_Present
875 -- flags set as needed, and Typedef_Node is left set to Empty.
877 if No
(Typedef_Node
) then
878 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
879 Set_Abstract_Present
(Decl_Node
, Abstract_Present
);
881 -- For a private extension declaration, Typedef_Node contains the
882 -- N_Private_Extension_Declaration node, which we now complete. Note
883 -- that the private extension declaration, unlike a full type
884 -- declaration, does permit unknown discriminants.
886 elsif Nkind
(Typedef_Node
) = N_Private_Extension_Declaration
then
887 Decl_Node
:= Typedef_Node
;
888 Set_Sloc
(Decl_Node
, Type_Loc
);
889 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
890 Set_Abstract_Present
(Typedef_Node
, Abstract_Present
);
892 -- In the full type declaration case, Typedef_Node has the type
893 -- definition and here is where we build the full type declaration
894 -- node. This is also where we check for improper use of an unknown
895 -- discriminant part (not allowed for full type declaration).
898 if Nkind
(Typedef_Node
) = N_Record_Definition
899 or else (Nkind
(Typedef_Node
) = N_Derived_Type_Definition
900 and then Present
(Record_Extension_Part
(Typedef_Node
)))
901 or else Is_Derived_Iface
903 Set_Abstract_Present
(Typedef_Node
, Abstract_Present
);
905 elsif Abstract_Present
then
906 Error_Msg
("ABSTRACT not allowed here, ignored", Abstract_Loc
);
909 Decl_Node
:= New_Node
(N_Full_Type_Declaration
, Type_Loc
);
910 Set_Type_Definition
(Decl_Node
, Typedef_Node
);
914 ("Full type declaration cannot have unknown discriminants",
919 -- Remaining processing is common for all three cases
921 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
922 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
923 P_Aspect_Specifications
(Decl_Node
);
925 end P_Type_Declaration
;
927 ----------------------------------
928 -- 3.2.1 Full Type Declaration --
929 ----------------------------------
931 -- Parsed by P_Type_Declaration (3.2.1)
933 ----------------------------
934 -- 3.2.1 Type Definition --
935 ----------------------------
937 -- Parsed by P_Type_Declaration (3.2.1)
939 --------------------------------
940 -- 3.2.2 Subtype Declaration --
941 --------------------------------
943 -- SUBTYPE_DECLARATION ::=
944 -- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION;
946 -- The caller has checked that the initial token is SUBTYPE
948 -- Error recovery: can raise Error_Resync
950 function P_Subtype_Declaration
return Node_Id
is
952 Not_Null_Present
: Boolean := False;
955 Decl_Node
:= New_Node
(N_Subtype_Declaration
, Token_Ptr
);
956 Scan
; -- past SUBTYPE
957 Set_Defining_Identifier
(Decl_Node
, P_Defining_Identifier
(C_Is
));
960 if Token
= Tok_New
then
961 Error_Msg_SC
-- CODEFIX
962 ("NEW ignored (only allowed in type declaration)");
966 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
967 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
969 Set_Subtype_Indication
970 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
971 P_Aspect_Specifications
(Decl_Node
);
973 end P_Subtype_Declaration
;
975 -------------------------------
976 -- 3.2.2 Subtype Indication --
977 -------------------------------
979 -- SUBTYPE_INDICATION ::=
980 -- [not null] SUBTYPE_MARK [CONSTRAINT]
982 -- Error recovery: can raise Error_Resync
984 function P_Null_Exclusion
985 (Allow_Anonymous_In_95
: Boolean := False) return Boolean
987 Not_Loc
: constant Source_Ptr
:= Token_Ptr
;
988 -- Source position of "not", if present
991 if Token
/= Tok_Not
then
997 if Token
= Tok_Null
then
1000 -- Ada 2005 (AI-441, AI-447): null_exclusion is illegal in Ada 95,
1001 -- except in the case of anonymous access types.
1003 -- Allow_Anonymous_In_95 will be True if we're parsing a formal
1004 -- parameter or discriminant, which are the only places where
1005 -- anonymous access types occur in Ada 95. "Formal : not null
1006 -- access ..." is legal in Ada 95, whereas "Formal : not null
1007 -- Named_Access_Type" is not.
1009 if Ada_Version
>= Ada_2005
1010 or else (Ada_Version
>= Ada_95
1011 and then Allow_Anonymous_In_95
1012 and then Token
= Tok_Access
)
1018 ("`NOT NULL` access type is an Ada 2005 extension", Not_Loc
);
1020 ("\unit should be compiled with -gnat05 switch", Not_Loc
);
1024 Error_Msg_SP
("NULL expected");
1027 if Token
= Tok_New
then
1028 Error_Msg
("`NOT NULL` comes after NEW, not before", Not_Loc
);
1033 end P_Null_Exclusion
;
1035 function P_Subtype_Indication
1036 (Not_Null_Present
: Boolean := False) return Node_Id
1038 Type_Node
: Node_Id
;
1041 if Token
= Tok_Identifier
or else Token
= Tok_Operator_Symbol
then
1042 Type_Node
:= P_Subtype_Mark
;
1043 return P_Subtype_Indication
(Type_Node
, Not_Null_Present
);
1046 -- Check for error of using record definition and treat it nicely,
1047 -- otherwise things are really messed up, so resynchronize.
1049 if Token
= Tok_Record
then
1050 Error_Msg_SC
("anonymous record definitions are not permitted");
1051 Discard_Junk_Node
(P_Record_Definition
);
1055 Error_Msg_AP
("subtype indication expected");
1059 end P_Subtype_Indication
;
1061 -- The following function is identical except that it is called with
1062 -- the subtype mark already scanned out, and it scans out the constraint
1064 -- Error recovery: can raise Error_Resync
1066 function P_Subtype_Indication
1067 (Subtype_Mark
: Node_Id
;
1068 Not_Null_Present
: Boolean := False) return Node_Id
1070 Indic_Node
: Node_Id
;
1071 Constr_Node
: Node_Id
;
1074 Constr_Node
:= P_Constraint_Opt
;
1076 if No
(Constr_Node
) then
1077 return Subtype_Mark
;
1079 if Not_Null_Present
then
1080 Error_Msg_SP
("`NOT NULL` not allowed if constraint given");
1083 Indic_Node
:= New_Node
(N_Subtype_Indication
, Sloc
(Subtype_Mark
));
1084 Set_Subtype_Mark
(Indic_Node
, Check_Subtype_Mark
(Subtype_Mark
));
1085 Set_Constraint
(Indic_Node
, Constr_Node
);
1088 end P_Subtype_Indication
;
1090 -------------------------
1091 -- 3.2.2 Subtype Mark --
1092 -------------------------
1094 -- SUBTYPE_MARK ::= subtype_NAME;
1096 -- Note: The subtype mark which appears after an IN or NOT IN
1097 -- operator is parsed by P_Range_Or_Subtype_Mark (3.5)
1099 -- Error recovery: cannot raise Error_Resync
1101 function P_Subtype_Mark
return Node_Id
is
1103 return P_Subtype_Mark_Resync
;
1105 when Error_Resync
=>
1109 -- This routine differs from P_Subtype_Mark in that it insists that an
1110 -- identifier be present, and if it is not, it raises Error_Resync.
1112 -- Error recovery: can raise Error_Resync
1114 function P_Subtype_Mark_Resync
return Node_Id
is
1115 Type_Node
: Node_Id
;
1118 if Token
= Tok_Access
then
1119 Error_Msg_SC
("anonymous access type definition not allowed here");
1120 Scan
; -- past ACCESS
1123 if Token
= Tok_Array
then
1124 Error_Msg_SC
("anonymous array definition not allowed here");
1125 Discard_Junk_Node
(P_Array_Type_Definition
);
1128 -- If Some becomes a keyword, the following is needed to make it
1129 -- acceptable in older versions of Ada.
1131 elsif Token
= Tok_Some
1132 and then Ada_Version
< Ada_2012
1134 Scan_Reserved_Identifier
(False);
1139 Type_Node
:= P_Qualified_Simple_Name_Resync
;
1141 -- Check for a subtype mark attribute. The only valid possibilities
1142 -- are 'CLASS and 'BASE. Anything else is a definite error. We may
1143 -- as well catch it here.
1145 if Token
= Tok_Apostrophe
then
1146 return P_Subtype_Mark_Attribute
(Type_Node
);
1151 end P_Subtype_Mark_Resync
;
1153 -- The following function is called to scan out a subtype mark attribute.
1154 -- The caller has already scanned out the subtype mark, which is passed in
1155 -- as the argument, and has checked that the current token is apostrophe.
1157 -- Only a special subclass of attributes, called type attributes
1158 -- (see Snames package) are allowed in this syntactic position.
1160 -- Note: if the apostrophe is followed by other than an identifier, then
1161 -- the input expression is returned unchanged, and the scan pointer is
1162 -- left pointing to the apostrophe.
1164 -- Error recovery: can raise Error_Resync
1166 function P_Subtype_Mark_Attribute
(Type_Node
: Node_Id
) return Node_Id
is
1167 Attr_Node
: Node_Id
:= Empty
;
1168 Scan_State
: Saved_Scan_State
;
1172 Prefix
:= Check_Subtype_Mark
(Type_Node
);
1174 if Prefix
= Error
then
1178 -- Loop through attributes appearing (more than one can appear as for
1179 -- for example in X'Base'Class). We are at an apostrophe on entry to
1180 -- this loop, and it runs once for each attribute parsed, with
1181 -- Prefix being the current possible prefix if it is an attribute.
1184 Save_Scan_State
(Scan_State
); -- at Apostrophe
1185 Scan
; -- past apostrophe
1187 if Token
/= Tok_Identifier
then
1188 Restore_Scan_State
(Scan_State
); -- to apostrophe
1189 return Prefix
; -- no attribute after all
1191 elsif not Is_Type_Attribute_Name
(Token_Name
) then
1193 ("attribute & may not be used in a subtype mark", Token_Node
);
1198 Make_Attribute_Reference
(Prev_Token_Ptr
,
1200 Attribute_Name
=> Token_Name
);
1201 Scan
; -- past type attribute identifier
1204 exit when Token
/= Tok_Apostrophe
;
1205 Prefix
:= Attr_Node
;
1208 -- Fall through here after scanning type attribute
1211 end P_Subtype_Mark_Attribute
;
1213 -----------------------
1214 -- 3.2.2 Constraint --
1215 -----------------------
1217 -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
1219 -- SCALAR_CONSTRAINT ::=
1220 -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
1222 -- COMPOSITE_CONSTRAINT ::=
1223 -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
1225 -- If no constraint is present, this function returns Empty
1227 -- Error recovery: can raise Error_Resync
1229 function P_Constraint_Opt
return Node_Id
is
1231 if Token
= Tok_Range
1232 or else Bad_Spelling_Of
(Tok_Range
)
1234 return P_Range_Constraint
;
1236 elsif Token
= Tok_Digits
1237 or else Bad_Spelling_Of
(Tok_Digits
)
1239 return P_Digits_Constraint
;
1241 elsif Token
= Tok_Delta
1242 or else Bad_Spelling_Of
(Tok_Delta
)
1244 return P_Delta_Constraint
;
1246 elsif Token
= Tok_Left_Paren
then
1247 return P_Index_Or_Discriminant_Constraint
;
1249 elsif Token
= Tok_In
then
1251 return P_Constraint_Opt
;
1256 end P_Constraint_Opt
;
1258 ------------------------------
1259 -- 3.2.2 Scalar Constraint --
1260 ------------------------------
1262 -- Parsed by P_Constraint_Opt (3.2.2)
1264 ---------------------------------
1265 -- 3.2.2 Composite Constraint --
1266 ---------------------------------
1268 -- Parsed by P_Constraint_Opt (3.2.2)
1270 --------------------------------------------------------
1271 -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) --
1272 --------------------------------------------------------
1274 -- This routine scans out a declaration starting with an identifier:
1276 -- OBJECT_DECLARATION ::=
1277 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1278 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION]
1279 -- [ASPECT_SPECIFICATIONS];
1280 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1281 -- ACCESS_DEFINITION [:= EXPRESSION]
1282 -- [ASPECT_SPECIFICATIONS];
1283 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1284 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]
1285 -- [ASPECT_SPECIFICATIONS];
1287 -- NUMBER_DECLARATION ::=
1288 -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
1290 -- OBJECT_RENAMING_DECLARATION ::=
1291 -- DEFINING_IDENTIFIER :
1292 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
1293 -- | DEFINING_IDENTIFIER :
1294 -- ACCESS_DEFINITION renames object_NAME;
1296 -- EXCEPTION_RENAMING_DECLARATION ::=
1297 -- DEFINING_IDENTIFIER : exception renames exception_NAME;
1299 -- EXCEPTION_DECLARATION ::=
1300 -- DEFINING_IDENTIFIER_LIST : exception
1301 -- [ASPECT_SPECIFICATIONS];
1303 -- Note that the ALIASED indication in an object declaration is
1304 -- marked by a flag in the parent node.
1306 -- The caller has checked that the initial token is an identifier
1308 -- The value returned is a list of declarations, one for each identifier
1309 -- in the list (as described in Sinfo, we always split up multiple
1310 -- declarations into the equivalent sequence of single declarations
1311 -- using the More_Ids and Prev_Ids flags to preserve the source).
1313 -- If the identifier turns out to be a probable statement rather than
1314 -- an identifier, then the scan is left pointing to the identifier and
1315 -- No_List is returned.
1317 -- Error recovery: can raise Error_Resync
1319 procedure P_Identifier_Declarations
1325 Decl_Node
: Node_Id
;
1326 Type_Node
: Node_Id
;
1327 Ident_Sloc
: Source_Ptr
;
1328 Scan_State
: Saved_Scan_State
;
1329 List_OK
: Boolean := True;
1331 Init_Expr
: Node_Id
;
1332 Init_Loc
: Source_Ptr
;
1333 Con_Loc
: Source_Ptr
;
1334 Not_Null_Present
: Boolean := False;
1336 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
1337 -- Used to save identifiers in the identifier list. The upper bound
1338 -- of 4096 is expected to be infinite in practice, and we do not even
1339 -- bother to check if this upper bound is exceeded.
1341 Num_Idents
: Nat
:= 1;
1342 -- Number of identifiers stored in Idents
1345 -- This procedure is called in renames cases to make sure that we do
1346 -- not have more than one identifier. If we do have more than one
1347 -- then an error message is issued (and the declaration is split into
1348 -- multiple declarations)
1350 function Token_Is_Renames
return Boolean;
1351 -- Checks if current token is RENAMES, and if so, scans past it and
1352 -- returns True, otherwise returns False. Includes checking for some
1353 -- common error cases.
1359 procedure No_List
is
1361 if Num_Idents
> 1 then
1363 ("identifier list not allowed for RENAMES",
1370 ----------------------
1371 -- Token_Is_Renames --
1372 ----------------------
1374 function Token_Is_Renames
return Boolean is
1375 At_Colon
: Saved_Scan_State
;
1378 if Token
= Tok_Colon
then
1379 Save_Scan_State
(At_Colon
);
1381 Check_Misspelling_Of
(Tok_Renames
);
1383 if Token
= Tok_Renames
then
1384 Error_Msg_SP
-- CODEFIX
1385 ("|extra "":"" ignored");
1386 Scan
; -- past RENAMES
1389 Restore_Scan_State
(At_Colon
);
1394 Check_Misspelling_Of
(Tok_Renames
);
1396 if Token
= Tok_Renames
then
1397 Scan
; -- past RENAMES
1403 end Token_Is_Renames
;
1405 -- Start of processing for P_Identifier_Declarations
1408 Ident_Sloc
:= Token_Ptr
;
1409 Save_Scan_State
(Scan_State
); -- at first identifier
1410 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
1412 -- If we have a colon after the identifier, then we can assume that
1413 -- this is in fact a valid identifier declaration and can steam ahead.
1415 if Token
= Tok_Colon
then
1418 -- If we have a comma, then scan out the list of identifiers
1420 elsif Token
= Tok_Comma
then
1421 while Comma_Present
loop
1422 Num_Idents
:= Num_Idents
+ 1;
1423 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
1426 Save_Scan_State
(Scan_State
); -- at colon
1429 -- If we have identifier followed by := then we assume that what is
1430 -- really meant is an assignment statement. The assignment statement
1431 -- is scanned out and added to the list of declarations. An exception
1432 -- occurs if the := is followed by the keyword constant, in which case
1433 -- we assume it was meant to be a colon.
1435 elsif Token
= Tok_Colon_Equal
then
1438 if Token
= Tok_Constant
then
1439 Error_Msg_SP
("colon expected");
1442 Restore_Scan_State
(Scan_State
);
1443 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
1447 -- If we have an IS keyword, then assume the TYPE keyword was missing
1449 elsif Token
= Tok_Is
then
1450 Restore_Scan_State
(Scan_State
);
1451 Append_To
(Decls
, P_Type_Declaration
);
1455 -- Otherwise we have an error situation
1458 Restore_Scan_State
(Scan_State
);
1460 -- First case is possible misuse of PROTECTED in Ada 83 mode. If
1461 -- so, fix the keyword and return to scan the protected declaration.
1463 if Token_Name
= Name_Protected
then
1464 Check_95_Keyword
(Tok_Protected
, Tok_Identifier
);
1465 Check_95_Keyword
(Tok_Protected
, Tok_Type
);
1466 Check_95_Keyword
(Tok_Protected
, Tok_Body
);
1468 if Token
= Tok_Protected
then
1473 -- Check misspelling possibilities. If so, correct the misspelling
1474 -- and return to scan out the resulting declaration.
1476 elsif Bad_Spelling_Of
(Tok_Function
)
1477 or else Bad_Spelling_Of
(Tok_Procedure
)
1478 or else Bad_Spelling_Of
(Tok_Package
)
1479 or else Bad_Spelling_Of
(Tok_Pragma
)
1480 or else Bad_Spelling_Of
(Tok_Protected
)
1481 or else Bad_Spelling_Of
(Tok_Generic
)
1482 or else Bad_Spelling_Of
(Tok_Subtype
)
1483 or else Bad_Spelling_Of
(Tok_Type
)
1484 or else Bad_Spelling_Of
(Tok_Task
)
1485 or else Bad_Spelling_Of
(Tok_Use
)
1486 or else Bad_Spelling_Of
(Tok_For
)
1491 -- Otherwise we definitely have an ordinary identifier with a junk
1492 -- token after it. Just complain that we expect a declaration, and
1493 -- skip to a semicolon
1496 Set_Declaration_Expected
;
1497 Resync_Past_Semicolon
;
1503 -- Come here with an identifier list and colon scanned out. We now
1504 -- build the nodes for the declarative items. One node is built for
1505 -- each identifier in the list, with the type information being
1506 -- repeated by rescanning the appropriate section of source.
1508 -- First an error check, if we have two identifiers in a row, a likely
1509 -- possibility is that the first of the identifiers is an incorrectly
1512 if Token
= Tok_Identifier
then
1514 SS
: Saved_Scan_State
;
1518 Save_Scan_State
(SS
);
1519 Scan
; -- past initial identifier
1520 I2
:= (Token
= Tok_Identifier
);
1521 Restore_Scan_State
(SS
);
1525 (Bad_Spelling_Of
(Tok_Access
) or else
1526 Bad_Spelling_Of
(Tok_Aliased
) or else
1527 Bad_Spelling_Of
(Tok_Constant
))
1534 -- Loop through identifiers
1539 -- Check for some cases of misused Ada 95 keywords
1541 if Token_Name
= Name_Aliased
then
1542 Check_95_Keyword
(Tok_Aliased
, Tok_Array
);
1543 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
1544 Check_95_Keyword
(Tok_Aliased
, Tok_Constant
);
1549 if Token
= Tok_Constant
then
1550 Con_Loc
:= Token_Ptr
;
1551 Scan
; -- past CONSTANT
1553 -- Number declaration, initialization required
1555 Init_Expr
:= Init_Expr_Opt
;
1557 if Present
(Init_Expr
) then
1558 if Not_Null_Present
then
1560 ("`NOT NULL` not allowed in numeric expression");
1563 Decl_Node
:= New_Node
(N_Number_Declaration
, Ident_Sloc
);
1564 Set_Expression
(Decl_Node
, Init_Expr
);
1566 -- Constant object declaration
1569 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1570 Set_Constant_Present
(Decl_Node
, True);
1572 if Token_Name
= Name_Aliased
then
1573 Check_95_Keyword
(Tok_Aliased
, Tok_Array
);
1574 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
1577 if Token
= Tok_Aliased
then
1578 Error_Msg_SC
-- CODEFIX
1579 ("ALIASED should be before CONSTANT");
1580 Scan
; -- past ALIASED
1581 Set_Aliased_Present
(Decl_Node
, True);
1584 if Token
= Tok_Array
then
1585 Set_Object_Definition
1586 (Decl_Node
, P_Array_Type_Definition
);
1589 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1590 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1592 if Token
= Tok_Access
then
1593 if Ada_Version
< Ada_2005
then
1595 ("generalized use of anonymous access types " &
1596 "is an Ada 2005 extension");
1598 ("\unit must be compiled with -gnat05 switch");
1601 Set_Object_Definition
1602 (Decl_Node
, P_Access_Definition
(Not_Null_Present
));
1604 Set_Object_Definition
1605 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
1609 if Token
= Tok_Renames
then
1611 ("CONSTANT not permitted in renaming declaration",
1613 Scan
; -- Past renames
1614 Discard_Junk_Node
(P_Name
);
1620 elsif Token
= Tok_Exception
then
1621 Scan
; -- past EXCEPTION
1623 if Token_Is_Renames
then
1626 New_Node
(N_Exception_Renaming_Declaration
, Ident_Sloc
);
1627 Set_Name
(Decl_Node
, P_Qualified_Simple_Name_Resync
);
1630 Decl_Node
:= New_Node
(N_Exception_Declaration
, Prev_Token_Ptr
);
1633 -- Aliased case (note that an object definition is required)
1635 elsif Token
= Tok_Aliased
then
1636 Scan
; -- past ALIASED
1637 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1638 Set_Aliased_Present
(Decl_Node
, True);
1640 if Token
= Tok_Constant
then
1641 Scan
; -- past CONSTANT
1642 Set_Constant_Present
(Decl_Node
, True);
1645 if Token
= Tok_Array
then
1646 Set_Object_Definition
1647 (Decl_Node
, P_Array_Type_Definition
);
1650 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1651 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1653 -- Access definition (AI-406) or subtype indication
1655 if Token
= Tok_Access
then
1656 if Ada_Version
< Ada_2005
then
1658 ("generalized use of anonymous access types " &
1659 "is an Ada 2005 extension");
1661 ("\unit must be compiled with -gnat05 switch");
1664 Set_Object_Definition
1665 (Decl_Node
, P_Access_Definition
(Not_Null_Present
));
1667 Set_Object_Definition
1668 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
1674 elsif Token
= Tok_Array
then
1675 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1676 Set_Object_Definition
(Decl_Node
, P_Array_Type_Definition
);
1678 -- Ada 2005 (AI-254, AI-406)
1680 elsif Token
= Tok_Not
then
1682 -- OBJECT_DECLARATION ::=
1683 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1684 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1685 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1686 -- ACCESS_DEFINITION [:= EXPRESSION];
1688 -- OBJECT_RENAMING_DECLARATION ::=
1689 -- DEFINING_IDENTIFIER :
1690 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
1691 -- | DEFINING_IDENTIFIER :
1692 -- ACCESS_DEFINITION renames object_NAME;
1694 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/423)
1696 if Token
= Tok_Access
then
1697 if Ada_Version
< Ada_2005
then
1699 ("generalized use of anonymous access types " &
1700 "is an Ada 2005 extension");
1701 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1704 Acc_Node
:= P_Access_Definition
(Not_Null_Present
);
1706 if Token
/= Tok_Renames
then
1707 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1708 Set_Object_Definition
(Decl_Node
, Acc_Node
);
1711 Scan
; -- past renames
1714 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1715 Set_Access_Definition
(Decl_Node
, Acc_Node
);
1716 Set_Name
(Decl_Node
, P_Name
);
1720 Type_Node
:= P_Subtype_Mark
;
1722 -- Object renaming declaration
1724 if Token_Is_Renames
then
1725 if Ada_Version
< Ada_2005
then
1727 ("`NOT NULL` not allowed in object renaming");
1730 -- Ada 2005 (AI-423): Object renaming declaration with
1731 -- a null exclusion.
1736 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1737 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1738 Set_Subtype_Mark
(Decl_Node
, Type_Node
);
1739 Set_Name
(Decl_Node
, P_Name
);
1742 -- Object declaration
1745 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1746 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1747 Set_Object_Definition
1749 P_Subtype_Indication
(Type_Node
, Not_Null_Present
));
1751 -- RENAMES at this point means that we had the combination
1752 -- of a constraint on the Type_Node and renames, which is
1755 if Token_Is_Renames
then
1757 ("constraint not allowed in object renaming "
1759 Constraint
(Object_Definition
(Decl_Node
)));
1765 -- Ada 2005 (AI-230): Access Definition case
1767 elsif Token
= Tok_Access
then
1768 if Ada_Version
< Ada_2005
then
1770 ("generalized use of anonymous access types " &
1771 "is an Ada 2005 extension");
1772 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1775 Acc_Node
:= P_Access_Definition
(Null_Exclusion_Present
=> False);
1777 -- Object declaration with access definition, or renaming
1779 if Token
/= Tok_Renames
then
1780 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1781 Set_Object_Definition
(Decl_Node
, Acc_Node
);
1784 Scan
; -- past renames
1787 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1788 Set_Access_Definition
(Decl_Node
, Acc_Node
);
1789 Set_Name
(Decl_Node
, P_Name
);
1792 -- Subtype indication case
1795 Type_Node
:= P_Subtype_Mark
;
1797 -- Object renaming declaration
1799 if Token_Is_Renames
then
1802 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1803 Set_Subtype_Mark
(Decl_Node
, Type_Node
);
1804 Set_Name
(Decl_Node
, P_Name
);
1806 -- Object declaration
1809 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1810 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1811 Set_Object_Definition
1813 P_Subtype_Indication
(Type_Node
, Not_Null_Present
));
1815 -- RENAMES at this point means that we had the combination of
1816 -- a constraint on the Type_Node and renames, which is illegal
1818 if Token_Is_Renames
then
1820 ("constraint not allowed in object renaming declaration",
1821 Constraint
(Object_Definition
(Decl_Node
)));
1827 -- Scan out initialization, allowed only for object declaration
1829 Init_Loc
:= Token_Ptr
;
1830 Init_Expr
:= Init_Expr_Opt
;
1832 if Present
(Init_Expr
) then
1833 if Nkind
(Decl_Node
) = N_Object_Declaration
then
1834 Set_Expression
(Decl_Node
, Init_Expr
);
1835 Set_Has_Init_Expression
(Decl_Node
);
1837 Error_Msg
("initialization not allowed here", Init_Loc
);
1841 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
1842 P_Aspect_Specifications
(Decl_Node
);
1845 if Ident
< Num_Idents
then
1846 Set_More_Ids
(Decl_Node
, True);
1850 Set_Prev_Ids
(Decl_Node
, True);
1854 Append
(Decl_Node
, Decls
);
1855 exit Ident_Loop
when Ident
= Num_Idents
;
1856 Restore_Scan_State
(Scan_State
);
1859 end loop Ident_Loop
;
1862 end P_Identifier_Declarations
;
1864 -------------------------------
1865 -- 3.3.1 Object Declaration --
1866 -------------------------------
1868 -- OBJECT DECLARATION ::=
1869 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1870 -- SUBTYPE_INDICATION [:= EXPRESSION];
1871 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1872 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1873 -- | SINGLE_TASK_DECLARATION
1874 -- | SINGLE_PROTECTED_DECLARATION
1876 -- Cases starting with TASK are parsed by P_Task (9.1)
1877 -- Cases starting with PROTECTED are parsed by P_Protected (9.4)
1878 -- All other cases are parsed by P_Identifier_Declarations (3.3)
1880 -------------------------------------
1881 -- 3.3.1 Defining Identifier List --
1882 -------------------------------------
1884 -- DEFINING_IDENTIFIER_LIST ::=
1885 -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
1887 -- Always parsed by the construct in which it appears. See special
1888 -- section on "Handling of Defining Identifier Lists" in this unit.
1890 -------------------------------
1891 -- 3.3.2 Number Declaration --
1892 -------------------------------
1894 -- Parsed by P_Identifier_Declarations (3.3)
1896 -------------------------------------------------------------------------
1897 -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) --
1898 -------------------------------------------------------------------------
1900 -- DERIVED_TYPE_DEFINITION ::=
1901 -- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
1902 -- [[and INTERFACE_LIST] RECORD_EXTENSION_PART]
1904 -- PRIVATE_EXTENSION_DECLARATION ::=
1905 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
1906 -- [abstract] [limited | synchronized]
1907 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
1910 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
1912 -- The caller has already scanned out the part up to the NEW, and Token
1913 -- either contains Tok_New (or ought to, if it doesn't this procedure
1914 -- will post an appropriate "NEW expected" message).
1916 -- Note: the caller is responsible for filling in the Sloc field of
1917 -- the returned node in the private extension declaration case as
1918 -- well as the stuff relating to the discriminant part.
1920 -- Error recovery: can raise Error_Resync;
1922 function P_Derived_Type_Def_Or_Private_Ext_Decl
return Node_Id
is
1923 Typedef_Node
: Node_Id
;
1924 Typedecl_Node
: Node_Id
;
1925 Not_Null_Present
: Boolean := False;
1928 Typedef_Node
:= New_Node
(N_Derived_Type_Definition
, Token_Ptr
);
1930 if Ada_Version
< Ada_2005
1931 and then Token
= Tok_Identifier
1932 and then Token_Name
= Name_Interface
1935 ("abstract interface is an Ada 2005 extension");
1936 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1941 if Token
= Tok_Abstract
then
1942 Error_Msg_SC
-- CODEFIX
1943 ("ABSTRACT must come before NEW, not after");
1947 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1948 Set_Null_Exclusion_Present
(Typedef_Node
, Not_Null_Present
);
1949 Set_Subtype_Indication
(Typedef_Node
,
1950 P_Subtype_Indication
(Not_Null_Present
));
1952 -- Ada 2005 (AI-251): Deal with interfaces
1954 if Token
= Tok_And
then
1957 if Ada_Version
< Ada_2005
then
1959 ("abstract interface is an Ada 2005 extension");
1960 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1963 Set_Interface_List
(Typedef_Node
, New_List
);
1966 Append
(P_Qualified_Simple_Name
, Interface_List
(Typedef_Node
));
1967 exit when Token
/= Tok_And
;
1971 if Token
/= Tok_With
then
1972 Error_Msg_SC
("WITH expected");
1977 -- Deal with record extension, note that we assume that a WITH is
1978 -- missing in the case of "type X is new Y record ..." or in the
1979 -- case of "type X is new Y null record".
1981 -- First make sure we don't have an aspect specification. If we do
1982 -- return now, so that our caller can check it (the WITH here is not
1983 -- part of a type extension).
1985 if Aspect_Specifications_Present
then
1986 return Typedef_Node
;
1988 -- OK, not an aspect specification, so continue test for extension
1990 elsif Token
= Tok_With
1991 or else Token
= Tok_Record
1992 or else Token
= Tok_Null
1994 T_With
; -- past WITH or give error message
1996 if Token
= Tok_Limited
then
1997 Error_Msg_SC
("LIMITED keyword not allowed in private extension");
1998 Scan
; -- ignore LIMITED
2001 -- Private extension declaration
2003 if Token
= Tok_Private
then
2004 Scan
; -- past PRIVATE
2006 -- Throw away the type definition node and build the type
2007 -- declaration node. Note the caller must set the Sloc,
2008 -- Discriminant_Specifications, Unknown_Discriminants_Present,
2009 -- and Defined_Identifier fields in the returned node.
2012 Make_Private_Extension_Declaration
(No_Location
,
2013 Defining_Identifier
=> Empty
,
2014 Subtype_Indication
=> Subtype_Indication
(Typedef_Node
),
2015 Abstract_Present
=> Abstract_Present
(Typedef_Node
),
2016 Interface_List
=> Interface_List
(Typedef_Node
));
2018 return Typedecl_Node
;
2020 -- Derived type definition with record extension part
2023 Set_Record_Extension_Part
(Typedef_Node
, P_Record_Definition
);
2024 return Typedef_Node
;
2027 -- Derived type definition with no record extension part
2030 return Typedef_Node
;
2032 end P_Derived_Type_Def_Or_Private_Ext_Decl
;
2034 ---------------------------
2035 -- 3.5 Range Constraint --
2036 ---------------------------
2038 -- RANGE_CONSTRAINT ::= range RANGE
2040 -- The caller has checked that the initial token is RANGE
2042 -- Error recovery: cannot raise Error_Resync
2044 function P_Range_Constraint
return Node_Id
is
2045 Range_Node
: Node_Id
;
2048 Range_Node
:= New_Node
(N_Range_Constraint
, Token_Ptr
);
2050 Set_Range_Expression
(Range_Node
, P_Range
);
2052 end P_Range_Constraint
;
2059 -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
2061 -- Note: the range that appears in a membership test is parsed by
2062 -- P_Range_Or_Subtype_Mark (3.5).
2064 -- Error recovery: cannot raise Error_Resync
2066 function P_Range
return Node_Id
is
2067 Expr_Node
: Node_Id
;
2068 Range_Node
: Node_Id
;
2071 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2073 if Expr_Form
= EF_Range_Attr
then
2076 elsif Token
= Tok_Dot_Dot
then
2077 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2078 Set_Low_Bound
(Range_Node
, Expr_Node
);
2080 Expr_Node
:= P_Expression
;
2081 Check_Simple_Expression
(Expr_Node
);
2082 Set_High_Bound
(Range_Node
, Expr_Node
);
2085 -- Anything else is an error
2088 T_Dot_Dot
; -- force missing .. message
2093 ----------------------------------
2094 -- 3.5 P_Range_Or_Subtype_Mark --
2095 ----------------------------------
2098 -- RANGE_ATTRIBUTE_REFERENCE
2099 -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
2101 -- This routine scans out the range or subtype mark that forms the right
2102 -- operand of a membership test (it is not used in any other contexts, and
2103 -- error messages are specialized with this knowledge in mind).
2105 -- Note: as documented in the Sinfo interface, although the syntax only
2106 -- allows a subtype mark, we in fact allow any simple expression to be
2107 -- returned from this routine. The semantics is responsible for issuing
2108 -- an appropriate message complaining if the argument is not a name.
2109 -- This simplifies the coding and error recovery processing in the
2110 -- parser, and in any case it is preferable not to consider this a
2111 -- syntax error and to continue with the semantic analysis.
2113 -- Error recovery: cannot raise Error_Resync
2115 function P_Range_Or_Subtype_Mark
2116 (Allow_Simple_Expression
: Boolean := False) return Node_Id
2118 Expr_Node
: Node_Id
;
2119 Range_Node
: Node_Id
;
2120 Save_Loc
: Source_Ptr
;
2122 -- Start of processing for P_Range_Or_Subtype_Mark
2125 -- Save location of possible junk parentheses
2127 Save_Loc
:= Token_Ptr
;
2129 -- Scan out either a simple expression or a range (this accepts more
2130 -- than is legal here, but as explained above, we like to allow more
2131 -- with a proper diagnostic, and in the case of a membership operation
2132 -- where sets are allowed, a simple expression is permissible anyway.
2134 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2138 if Expr_Form
= EF_Range_Attr
then
2141 -- Simple_Expression .. Simple_Expression
2143 elsif Token
= Tok_Dot_Dot
then
2144 Check_Simple_Expression
(Expr_Node
);
2145 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2146 Set_Low_Bound
(Range_Node
, Expr_Node
);
2148 Set_High_Bound
(Range_Node
, P_Simple_Expression
);
2151 -- Case of subtype mark (optionally qualified simple name or an
2152 -- attribute whose prefix is an optionally qualified simple name)
2154 elsif Expr_Form
= EF_Simple_Name
2155 or else Nkind
(Expr_Node
) = N_Attribute_Reference
2157 -- Check for error of range constraint after a subtype mark
2159 if Token
= Tok_Range
then
2160 Error_Msg_SC
("range constraint not allowed in membership test");
2164 -- Check for error of DIGITS or DELTA after a subtype mark
2166 elsif Token
= Tok_Digits
or else Token
= Tok_Delta
then
2168 ("accuracy definition not allowed in membership test");
2169 Scan
; -- past DIGITS or DELTA
2172 -- Attribute reference, may or may not be OK, but in any case we
2175 elsif Token
= Tok_Apostrophe
then
2176 return P_Subtype_Mark_Attribute
(Expr_Node
);
2178 -- OK case of simple name, just return it
2184 -- Simple expression case
2186 elsif Expr_Form
= EF_Simple
and then Allow_Simple_Expression
then
2189 -- Here we have some kind of error situation. Check for junk parens
2190 -- then return what we have, caller will deal with other errors.
2193 if Nkind
(Expr_Node
) in N_Subexpr
2194 and then Paren_Count
(Expr_Node
) /= 0
2196 Error_Msg
("|parentheses not allowed for subtype mark", Save_Loc
);
2197 Set_Paren_Count
(Expr_Node
, 0);
2202 end P_Range_Or_Subtype_Mark
;
2204 ----------------------------------------
2205 -- 3.5.1 Enumeration Type Definition --
2206 ----------------------------------------
2208 -- ENUMERATION_TYPE_DEFINITION ::=
2209 -- (ENUMERATION_LITERAL_SPECIFICATION
2210 -- {, ENUMERATION_LITERAL_SPECIFICATION})
2212 -- The caller has already scanned out the TYPE keyword
2214 -- Error recovery: can raise Error_Resync;
2216 function P_Enumeration_Type_Definition
return Node_Id
is
2217 Typedef_Node
: Node_Id
;
2220 Typedef_Node
:= New_Node
(N_Enumeration_Type_Definition
, Token_Ptr
);
2221 Set_Literals
(Typedef_Node
, New_List
);
2226 Append
(P_Enumeration_Literal_Specification
, Literals
(Typedef_Node
));
2227 exit when not Comma_Present
;
2231 return Typedef_Node
;
2232 end P_Enumeration_Type_Definition
;
2234 ----------------------------------------------
2235 -- 3.5.1 Enumeration Literal Specification --
2236 ----------------------------------------------
2238 -- ENUMERATION_LITERAL_SPECIFICATION ::=
2239 -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
2241 -- Error recovery: can raise Error_Resync
2243 function P_Enumeration_Literal_Specification
return Node_Id
is
2245 if Token
= Tok_Char_Literal
then
2246 return P_Defining_Character_Literal
;
2248 return P_Defining_Identifier
(C_Comma_Right_Paren
);
2250 end P_Enumeration_Literal_Specification
;
2252 ---------------------------------------
2253 -- 3.5.1 Defining_Character_Literal --
2254 ---------------------------------------
2256 -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
2258 -- Error recovery: cannot raise Error_Resync
2260 -- The caller has checked that the current token is a character literal
2262 function P_Defining_Character_Literal
return Node_Id
is
2263 Literal_Node
: Node_Id
;
2265 Literal_Node
:= Token_Node
;
2266 Change_Character_Literal_To_Defining_Character_Literal
(Literal_Node
);
2267 Scan
; -- past character literal
2268 return Literal_Node
;
2269 end P_Defining_Character_Literal
;
2271 ------------------------------------
2272 -- 3.5.4 Integer Type Definition --
2273 ------------------------------------
2275 -- Parsed by P_Type_Declaration (3.2.1)
2277 -------------------------------------------
2278 -- 3.5.4 Signed Integer Type Definition --
2279 -------------------------------------------
2281 -- SIGNED_INTEGER_TYPE_DEFINITION ::=
2282 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2284 -- Normally the initial token on entry is RANGE, but in some
2285 -- error conditions, the range token was missing and control is
2286 -- passed with Token pointing to first token of the first expression.
2288 -- Error recovery: cannot raise Error_Resync
2290 function P_Signed_Integer_Type_Definition
return Node_Id
is
2291 Typedef_Node
: Node_Id
;
2292 Expr_Node
: Node_Id
;
2295 Typedef_Node
:= New_Node
(N_Signed_Integer_Type_Definition
, Token_Ptr
);
2297 if Token
= Tok_Range
then
2301 Expr_Node
:= P_Expression
;
2302 Check_Simple_Expression
(Expr_Node
);
2303 Set_Low_Bound
(Typedef_Node
, Expr_Node
);
2305 Expr_Node
:= P_Expression
;
2306 Check_Simple_Expression
(Expr_Node
);
2307 Set_High_Bound
(Typedef_Node
, Expr_Node
);
2308 return Typedef_Node
;
2309 end P_Signed_Integer_Type_Definition
;
2311 ------------------------------------
2312 -- 3.5.4 Modular Type Definition --
2313 ------------------------------------
2315 -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
2317 -- The caller has checked that the initial token is MOD
2319 -- Error recovery: cannot raise Error_Resync
2321 function P_Modular_Type_Definition
return Node_Id
is
2322 Typedef_Node
: Node_Id
;
2325 if Ada_Version
= Ada_83
then
2326 Error_Msg_SC
("(Ada 83): modular types not allowed");
2329 Typedef_Node
:= New_Node
(N_Modular_Type_Definition
, Token_Ptr
);
2331 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
2333 -- Handle mod L..R cleanly
2335 if Token
= Tok_Dot_Dot
then
2336 Error_Msg_SC
("range not allowed for modular type");
2338 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
2341 return Typedef_Node
;
2342 end P_Modular_Type_Definition
;
2344 ---------------------------------
2345 -- 3.5.6 Real Type Definition --
2346 ---------------------------------
2348 -- Parsed by P_Type_Declaration (3.2.1)
2350 --------------------------------------
2351 -- 3.5.7 Floating Point Definition --
2352 --------------------------------------
2354 -- FLOATING_POINT_DEFINITION ::=
2355 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2357 -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
2359 -- The caller has checked that the initial token is DIGITS
2361 -- Error recovery: cannot raise Error_Resync
2363 function P_Floating_Point_Definition
return Node_Id
is
2364 Digits_Loc
: constant Source_Ptr
:= Token_Ptr
;
2366 Expr_Node
: Node_Id
;
2369 Scan
; -- past DIGITS
2370 Expr_Node
:= P_Expression_No_Right_Paren
;
2371 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2373 -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
2375 if Token
= Tok_Delta
then
2376 Error_Msg_SC
-- CODEFIX
2377 ("|DELTA must come before DIGITS");
2378 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Digits_Loc
);
2380 Set_Delta_Expression
(Def_Node
, P_Expression_No_Right_Paren
);
2382 -- OK floating-point definition
2385 Def_Node
:= New_Node
(N_Floating_Point_Definition
, Digits_Loc
);
2388 Set_Digits_Expression
(Def_Node
, Expr_Node
);
2389 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
2391 end P_Floating_Point_Definition
;
2393 -------------------------------------
2394 -- 3.5.7 Real Range Specification --
2395 -------------------------------------
2397 -- REAL_RANGE_SPECIFICATION ::=
2398 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2400 -- Error recovery: cannot raise Error_Resync
2402 function P_Real_Range_Specification_Opt
return Node_Id
is
2403 Specification_Node
: Node_Id
;
2404 Expr_Node
: Node_Id
;
2407 if Token
= Tok_Range
then
2408 Specification_Node
:=
2409 New_Node
(N_Real_Range_Specification
, Token_Ptr
);
2411 Expr_Node
:= P_Expression_No_Right_Paren
;
2412 Check_Simple_Expression
(Expr_Node
);
2413 Set_Low_Bound
(Specification_Node
, Expr_Node
);
2415 Expr_Node
:= P_Expression_No_Right_Paren
;
2416 Check_Simple_Expression
(Expr_Node
);
2417 Set_High_Bound
(Specification_Node
, Expr_Node
);
2418 return Specification_Node
;
2422 end P_Real_Range_Specification_Opt
;
2424 -----------------------------------
2425 -- 3.5.9 Fixed Point Definition --
2426 -----------------------------------
2428 -- FIXED_POINT_DEFINITION ::=
2429 -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
2431 -- ORDINARY_FIXED_POINT_DEFINITION ::=
2432 -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION
2434 -- DECIMAL_FIXED_POINT_DEFINITION ::=
2435 -- delta static_EXPRESSION
2436 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2438 -- The caller has checked that the initial token is DELTA
2440 -- Error recovery: cannot raise Error_Resync
2442 function P_Fixed_Point_Definition
return Node_Id
is
2443 Delta_Node
: Node_Id
;
2444 Delta_Loc
: Source_Ptr
;
2446 Expr_Node
: Node_Id
;
2449 Delta_Loc
:= Token_Ptr
;
2451 Delta_Node
:= P_Expression_No_Right_Paren
;
2452 Check_Simple_Expression_In_Ada_83
(Delta_Node
);
2454 if Token
= Tok_Digits
then
2455 if Ada_Version
= Ada_83
then
2456 Error_Msg_SC
("(Ada 83) decimal fixed type not allowed!");
2459 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Delta_Loc
);
2460 Scan
; -- past DIGITS
2461 Expr_Node
:= P_Expression_No_Right_Paren
;
2462 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2463 Set_Digits_Expression
(Def_Node
, Expr_Node
);
2466 Def_Node
:= New_Node
(N_Ordinary_Fixed_Point_Definition
, Delta_Loc
);
2468 -- Range is required in ordinary fixed point case
2470 if Token
/= Tok_Range
then
2471 Error_Msg_AP
("range must be given for fixed-point type");
2476 Set_Delta_Expression
(Def_Node
, Delta_Node
);
2477 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
2479 end P_Fixed_Point_Definition
;
2481 --------------------------------------------
2482 -- 3.5.9 Ordinary Fixed Point Definition --
2483 --------------------------------------------
2485 -- Parsed by P_Fixed_Point_Definition (3.5.9)
2487 -------------------------------------------
2488 -- 3.5.9 Decimal Fixed Point Definition --
2489 -------------------------------------------
2491 -- Parsed by P_Decimal_Point_Definition (3.5.9)
2493 ------------------------------
2494 -- 3.5.9 Digits Constraint --
2495 ------------------------------
2497 -- DIGITS_CONSTRAINT ::=
2498 -- digits static_EXPRESSION [RANGE_CONSTRAINT]
2500 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2502 -- The caller has checked that the initial token is DIGITS
2504 function P_Digits_Constraint
return Node_Id
is
2505 Constraint_Node
: Node_Id
;
2506 Expr_Node
: Node_Id
;
2509 Constraint_Node
:= New_Node
(N_Digits_Constraint
, Token_Ptr
);
2510 Scan
; -- past DIGITS
2511 Expr_Node
:= P_Expression
;
2512 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2513 Set_Digits_Expression
(Constraint_Node
, Expr_Node
);
2515 if Token
= Tok_Range
then
2516 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
2519 return Constraint_Node
;
2520 end P_Digits_Constraint
;
2522 -----------------------------
2523 -- 3.5.9 Delta Constraint --
2524 -----------------------------
2526 -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
2528 -- Note: this is an obsolescent feature in Ada 95 (I.3)
2530 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2532 -- The caller has checked that the initial token is DELTA
2534 -- Error recovery: cannot raise Error_Resync
2536 function P_Delta_Constraint
return Node_Id
is
2537 Constraint_Node
: Node_Id
;
2538 Expr_Node
: Node_Id
;
2541 Constraint_Node
:= New_Node
(N_Delta_Constraint
, Token_Ptr
);
2543 Expr_Node
:= P_Expression
;
2544 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2545 Set_Delta_Expression
(Constraint_Node
, Expr_Node
);
2547 if Token
= Tok_Range
then
2548 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
2551 return Constraint_Node
;
2552 end P_Delta_Constraint
;
2554 --------------------------------
2555 -- 3.6 Array Type Definition --
2556 --------------------------------
2558 -- ARRAY_TYPE_DEFINITION ::=
2559 -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
2561 -- UNCONSTRAINED_ARRAY_DEFINITION ::=
2562 -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
2563 -- COMPONENT_DEFINITION
2565 -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
2567 -- CONSTRAINED_ARRAY_DEFINITION ::=
2568 -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
2569 -- COMPONENT_DEFINITION
2571 -- DISCRETE_SUBTYPE_DEFINITION ::=
2572 -- DISCRETE_SUBTYPE_INDICATION | RANGE
2574 -- COMPONENT_DEFINITION ::=
2575 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
2577 -- The caller has checked that the initial token is ARRAY
2579 -- Error recovery: can raise Error_Resync
2581 function P_Array_Type_Definition
return Node_Id
is
2582 Array_Loc
: Source_Ptr
;
2583 CompDef_Node
: Node_Id
;
2585 Not_Null_Present
: Boolean := False;
2586 Subs_List
: List_Id
;
2587 Scan_State
: Saved_Scan_State
;
2588 Aliased_Present
: Boolean := False;
2591 Array_Loc
:= Token_Ptr
;
2593 Subs_List
:= New_List
;
2596 -- It's quite tricky to disentangle these two possibilities, so we do
2597 -- a prescan to determine which case we have and then reset the scan.
2598 -- The prescan skips past possible subtype mark tokens.
2600 Save_Scan_State
(Scan_State
); -- just after paren
2602 while Token
in Token_Class_Desig
or else
2603 Token
= Tok_Dot
or else
2604 Token
= Tok_Apostrophe
-- because of 'BASE, 'CLASS
2609 -- If we end up on RANGE <> then we have the unconstrained case. We
2610 -- will also allow the RANGE to be omitted, just to improve error
2611 -- handling for a case like array (integer <>) of integer;
2613 Scan
; -- past possible RANGE or <>
2615 if (Prev_Token
= Tok_Range
and then Token
= Tok_Box
) or else
2616 Prev_Token
= Tok_Box
2618 Def_Node
:= New_Node
(N_Unconstrained_Array_Definition
, Array_Loc
);
2619 Restore_Scan_State
(Scan_State
); -- to first subtype mark
2622 Append
(P_Subtype_Mark_Resync
, Subs_List
);
2625 exit when Token
= Tok_Right_Paren
or else Token
= Tok_Of
;
2629 Set_Subtype_Marks
(Def_Node
, Subs_List
);
2632 Def_Node
:= New_Node
(N_Constrained_Array_Definition
, Array_Loc
);
2633 Restore_Scan_State
(Scan_State
); -- to first discrete range
2636 Append
(P_Discrete_Subtype_Definition
, Subs_List
);
2637 exit when not Comma_Present
;
2640 Set_Discrete_Subtype_Definitions
(Def_Node
, Subs_List
);
2646 CompDef_Node
:= New_Node
(N_Component_Definition
, Token_Ptr
);
2648 if Token_Name
= Name_Aliased
then
2649 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
2652 if Token
= Tok_Aliased
then
2653 Aliased_Present
:= True;
2654 Scan
; -- past ALIASED
2657 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/AI-254)
2659 -- Ada 2005 (AI-230): Access Definition case
2661 if Token
= Tok_Access
then
2662 if Ada_Version
< Ada_2005
then
2664 ("generalized use of anonymous access types " &
2665 "is an Ada 2005 extension");
2666 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
2669 if Aliased_Present
then
2670 Error_Msg_SP
("ALIASED not allowed here");
2673 Set_Subtype_Indication
(CompDef_Node
, Empty
);
2674 Set_Aliased_Present
(CompDef_Node
, False);
2675 Set_Access_Definition
(CompDef_Node
,
2676 P_Access_Definition
(Not_Null_Present
));
2679 Set_Access_Definition
(CompDef_Node
, Empty
);
2680 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
2681 Set_Null_Exclusion_Present
(CompDef_Node
, Not_Null_Present
);
2682 Set_Subtype_Indication
(CompDef_Node
,
2683 P_Subtype_Indication
(Not_Null_Present
));
2686 Set_Component_Definition
(Def_Node
, CompDef_Node
);
2689 end P_Array_Type_Definition
;
2691 -----------------------------------------
2692 -- 3.6 Unconstrained Array Definition --
2693 -----------------------------------------
2695 -- Parsed by P_Array_Type_Definition (3.6)
2697 ---------------------------------------
2698 -- 3.6 Constrained Array Definition --
2699 ---------------------------------------
2701 -- Parsed by P_Array_Type_Definition (3.6)
2703 --------------------------------------
2704 -- 3.6 Discrete Subtype Definition --
2705 --------------------------------------
2707 -- DISCRETE_SUBTYPE_DEFINITION ::=
2708 -- discrete_SUBTYPE_INDICATION | RANGE
2710 -- Note: the discrete subtype definition appearing in a constrained
2711 -- array definition is parsed by P_Array_Type_Definition (3.6)
2713 -- Error recovery: cannot raise Error_Resync
2715 function P_Discrete_Subtype_Definition
return Node_Id
is
2717 -- The syntax of a discrete subtype definition is identical to that
2718 -- of a discrete range, so we simply share the same parsing code.
2720 return P_Discrete_Range
;
2721 end P_Discrete_Subtype_Definition
;
2723 -------------------------------
2724 -- 3.6 Component Definition --
2725 -------------------------------
2727 -- For the array case, parsed by P_Array_Type_Definition (3.6)
2728 -- For the record case, parsed by P_Component_Declaration (3.8)
2730 -----------------------------
2731 -- 3.6.1 Index Constraint --
2732 -----------------------------
2734 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2736 ---------------------------
2737 -- 3.6.1 Discrete Range --
2738 ---------------------------
2740 -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
2742 -- The possible forms for a discrete range are:
2744 -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2)
2745 -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2)
2746 -- Range_Attribute (RANGE, 3.5)
2747 -- Simple_Expression .. Simple_Expression (RANGE, 3.5)
2749 -- Error recovery: cannot raise Error_Resync
2751 function P_Discrete_Range
return Node_Id
is
2752 Expr_Node
: Node_Id
;
2753 Range_Node
: Node_Id
;
2756 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2758 if Expr_Form
= EF_Range_Attr
then
2761 elsif Token
= Tok_Range
then
2762 if Expr_Form
/= EF_Simple_Name
then
2763 Error_Msg_SC
("range must be preceded by subtype mark");
2766 return P_Subtype_Indication
(Expr_Node
);
2768 -- Check Expression .. Expression case
2770 elsif Token
= Tok_Dot_Dot
then
2771 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2772 Set_Low_Bound
(Range_Node
, Expr_Node
);
2774 Expr_Node
:= P_Expression
;
2775 Check_Simple_Expression
(Expr_Node
);
2776 Set_High_Bound
(Range_Node
, Expr_Node
);
2779 -- Otherwise we must have a subtype mark
2781 elsif Expr_Form
= EF_Simple_Name
then
2784 -- If incorrect, complain that we expect ..
2790 end P_Discrete_Range
;
2792 ----------------------------
2793 -- 3.7 Discriminant Part --
2794 ----------------------------
2796 -- DISCRIMINANT_PART ::=
2797 -- UNKNOWN_DISCRIMINANT_PART
2798 -- | KNOWN_DISCRIMINANT_PART
2800 -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
2801 -- or P_Unknown_Discriminant_Part (3.7), since we know which we want.
2803 ------------------------------------
2804 -- 3.7 Unknown Discriminant Part --
2805 ------------------------------------
2807 -- UNKNOWN_DISCRIMINANT_PART ::= (<>)
2809 -- If no unknown discriminant part is present, then False is returned,
2810 -- otherwise the unknown discriminant is scanned out and True is returned.
2812 -- Error recovery: cannot raise Error_Resync
2814 function P_Unknown_Discriminant_Part_Opt
return Boolean is
2815 Scan_State
: Saved_Scan_State
;
2818 -- If <> right now, then this is missing left paren
2820 if Token
= Tok_Box
then
2823 -- If not <> or left paren, then definitely no box
2825 elsif Token
/= Tok_Left_Paren
then
2828 -- Left paren, so might be a box after it
2831 Save_Scan_State
(Scan_State
);
2832 Scan
; -- past the left paren
2834 if Token
/= Tok_Box
then
2835 Restore_Scan_State
(Scan_State
);
2840 -- We are now pointing to the box
2842 if Ada_Version
= Ada_83
then
2843 Error_Msg_SC
("(Ada 83) unknown discriminant not allowed!");
2846 Scan
; -- past the box
2847 U_Right_Paren
; -- must be followed by right paren
2849 end P_Unknown_Discriminant_Part_Opt
;
2851 ----------------------------------
2852 -- 3.7 Known Discriminant Part --
2853 ----------------------------------
2855 -- KNOWN_DISCRIMINANT_PART ::=
2856 -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
2858 -- DISCRIMINANT_SPECIFICATION ::=
2859 -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
2860 -- [:= DEFAULT_EXPRESSION]
2861 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
2862 -- [:= DEFAULT_EXPRESSION]
2864 -- If no known discriminant part is present, then No_List is returned
2866 -- Error recovery: cannot raise Error_Resync
2868 function P_Known_Discriminant_Part_Opt
return List_Id
is
2869 Specification_Node
: Node_Id
;
2870 Specification_List
: List_Id
;
2871 Ident_Sloc
: Source_Ptr
;
2872 Scan_State
: Saved_Scan_State
;
2874 Not_Null_Present
: Boolean;
2877 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
2878 -- This array holds the list of defining identifiers. The upper bound
2879 -- of 4096 is intended to be essentially infinite, and we do not even
2880 -- bother to check for it being exceeded.
2883 if Token
= Tok_Left_Paren
then
2884 Specification_List
:= New_List
;
2886 P_Pragmas_Misplaced
;
2888 Specification_Loop
: loop
2890 Ident_Sloc
:= Token_Ptr
;
2891 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
2894 while Comma_Present
loop
2895 Num_Idents
:= Num_Idents
+ 1;
2896 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
2899 -- If there are multiple identifiers, we repeatedly scan the
2900 -- type and initialization expression information by resetting
2901 -- the scan pointer (so that we get completely separate trees
2902 -- for each occurrence).
2904 if Num_Idents
> 1 then
2905 Save_Scan_State
(Scan_State
);
2910 -- Loop through defining identifiers in list
2914 Specification_Node
:=
2915 New_Node
(N_Discriminant_Specification
, Ident_Sloc
);
2916 Set_Defining_Identifier
(Specification_Node
, Idents
(Ident
));
2917 Not_Null_Present
:= -- Ada 2005 (AI-231, AI-447)
2918 P_Null_Exclusion
(Allow_Anonymous_In_95
=> True);
2920 if Token
= Tok_Access
then
2921 if Ada_Version
= Ada_83
then
2923 ("(Ada 83) access discriminant not allowed!");
2926 Set_Discriminant_Type
2927 (Specification_Node
,
2928 P_Access_Definition
(Not_Null_Present
));
2931 Set_Discriminant_Type
2932 (Specification_Node
, P_Subtype_Mark
);
2934 Set_Null_Exclusion_Present
-- Ada 2005 (AI-231)
2935 (Specification_Node
, Not_Null_Present
);
2939 (Specification_Node
, Init_Expr_Opt
(True));
2942 Set_Prev_Ids
(Specification_Node
, True);
2945 if Ident
< Num_Idents
then
2946 Set_More_Ids
(Specification_Node
, True);
2949 Append
(Specification_Node
, Specification_List
);
2950 exit Ident_Loop
when Ident
= Num_Idents
;
2952 Restore_Scan_State
(Scan_State
);
2954 end loop Ident_Loop
;
2956 exit Specification_Loop
when Token
/= Tok_Semicolon
;
2958 P_Pragmas_Misplaced
;
2959 end loop Specification_Loop
;
2962 return Specification_List
;
2967 end P_Known_Discriminant_Part_Opt
;
2969 -------------------------------------
2970 -- 3.7 Discriminant Specification --
2971 -------------------------------------
2973 -- Parsed by P_Known_Discriminant_Part_Opt (3.7)
2975 -----------------------------
2976 -- 3.7 Default Expression --
2977 -----------------------------
2979 -- Always parsed (simply as an Expression) by the parent construct
2981 ------------------------------------
2982 -- 3.7.1 Discriminant Constraint --
2983 ------------------------------------
2985 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2987 --------------------------------------------------------
2988 -- 3.7.1 Index or Discriminant Constraint (also 3.6) --
2989 --------------------------------------------------------
2991 -- DISCRIMINANT_CONSTRAINT ::=
2992 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
2994 -- DISCRIMINANT_ASSOCIATION ::=
2995 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2998 -- This routine parses either an index or a discriminant constraint. As
2999 -- is clear from the above grammar, it is often possible to clearly
3000 -- determine which of the two possibilities we have, but there are
3001 -- cases (those in which we have a series of expressions of the same
3002 -- syntactic form as subtype indications), where we cannot tell. Since
3003 -- this means that in any case the semantic phase has to distinguish
3004 -- between the two, there is not much point in the parser trying to
3005 -- distinguish even those cases where the difference is clear. In any
3006 -- case, if we have a situation like:
3008 -- (A => 123, 235 .. 500)
3010 -- it is not clear which of the two items is the wrong one, better to
3011 -- let the semantic phase give a clear message. Consequently, this
3012 -- routine in general returns a list of items which can be either
3013 -- discrete ranges or discriminant associations.
3015 -- The caller has checked that the initial token is a left paren
3017 -- Error recovery: can raise Error_Resync
3019 function P_Index_Or_Discriminant_Constraint
return Node_Id
is
3020 Scan_State
: Saved_Scan_State
;
3021 Constr_Node
: Node_Id
;
3022 Constr_List
: List_Id
;
3023 Expr_Node
: Node_Id
;
3024 Result_Node
: Node_Id
;
3027 Result_Node
:= New_Node
(N_Index_Or_Discriminant_Constraint
, Token_Ptr
);
3029 Constr_List
:= New_List
;
3030 Set_Constraints
(Result_Node
, Constr_List
);
3032 -- The two syntactic forms are a little mixed up, so what we are doing
3033 -- here is looking at the first entry to determine which case we have
3035 -- A discriminant constraint is a list of discriminant associations,
3036 -- which have one of the following possible forms:
3040 -- Id | Id | .. | Id => Expression
3042 -- An index constraint is a list of discrete ranges which have one
3043 -- of the following possible forms:
3046 -- Subtype_Mark range Range
3048 -- Simple_Expression .. Simple_Expression
3050 -- Loop through discriminants in list
3053 -- Check cases of Id => Expression or Id | Id => Expression
3055 if Token
= Tok_Identifier
then
3056 Save_Scan_State
(Scan_State
); -- at Id
3059 if Token
= Tok_Arrow
or else Token
= Tok_Vertical_Bar
then
3060 Restore_Scan_State
(Scan_State
); -- to Id
3061 Append
(P_Discriminant_Association
, Constr_List
);
3064 Restore_Scan_State
(Scan_State
); -- to Id
3068 -- Otherwise scan out an expression and see what we have got
3070 Expr_Node
:= P_Expression_Or_Range_Attribute
;
3072 if Expr_Form
= EF_Range_Attr
then
3073 Append
(Expr_Node
, Constr_List
);
3075 elsif Token
= Tok_Range
then
3076 if Expr_Form
/= EF_Simple_Name
then
3077 Error_Msg_SC
("subtype mark required before RANGE");
3080 Append
(P_Subtype_Indication
(Expr_Node
), Constr_List
);
3083 -- Check Simple_Expression .. Simple_Expression case
3085 elsif Token
= Tok_Dot_Dot
then
3086 Check_Simple_Expression
(Expr_Node
);
3087 Constr_Node
:= New_Node
(N_Range
, Token_Ptr
);
3088 Set_Low_Bound
(Constr_Node
, Expr_Node
);
3090 Expr_Node
:= P_Expression
;
3091 Check_Simple_Expression
(Expr_Node
);
3092 Set_High_Bound
(Constr_Node
, Expr_Node
);
3093 Append
(Constr_Node
, Constr_List
);
3096 -- Case of an expression which could be either form
3099 Append
(Expr_Node
, Constr_List
);
3103 -- Here with a single entry scanned
3106 exit when not Comma_Present
;
3112 end P_Index_Or_Discriminant_Constraint
;
3114 -------------------------------------
3115 -- 3.7.1 Discriminant Association --
3116 -------------------------------------
3118 -- DISCRIMINANT_ASSOCIATION ::=
3119 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
3122 -- This routine is used only when the name list is present and the caller
3123 -- has already checked this (by scanning ahead and repositioning the
3126 -- Error_Recovery: cannot raise Error_Resync;
3128 function P_Discriminant_Association
return Node_Id
is
3129 Discr_Node
: Node_Id
;
3130 Names_List
: List_Id
;
3131 Ident_Sloc
: Source_Ptr
;
3134 Ident_Sloc
:= Token_Ptr
;
3135 Names_List
:= New_List
;
3138 Append
(P_Identifier
(C_Vertical_Bar_Arrow
), Names_List
);
3139 exit when Token
/= Tok_Vertical_Bar
;
3143 Discr_Node
:= New_Node
(N_Discriminant_Association
, Ident_Sloc
);
3144 Set_Selector_Names
(Discr_Node
, Names_List
);
3146 Set_Expression
(Discr_Node
, P_Expression
);
3148 end P_Discriminant_Association
;
3150 ---------------------------------
3151 -- 3.8 Record Type Definition --
3152 ---------------------------------
3154 -- RECORD_TYPE_DEFINITION ::=
3155 -- [[abstract] tagged] [limited] RECORD_DEFINITION
3157 -- There is no node in the tree for a record type definition. Instead
3158 -- a record definition node appears, with possible Abstract_Present,
3159 -- Tagged_Present, and Limited_Present flags set appropriately.
3161 ----------------------------
3162 -- 3.8 Record Definition --
3163 ----------------------------
3165 -- RECORD_DEFINITION ::=
3171 -- Note: in the case where a record definition node is used to represent
3172 -- a record type definition, the caller sets the Tagged_Present and
3173 -- Limited_Present flags in the resulting N_Record_Definition node as
3176 -- Note that the RECORD token at the start may be missing in certain
3177 -- error situations, so this function is expected to post the error
3179 -- Error recovery: can raise Error_Resync
3181 function P_Record_Definition
return Node_Id
is
3185 Rec_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
3189 if Token
= Tok_Null
then
3192 Set_Null_Present
(Rec_Node
, True);
3194 -- Catch incomplete declaration to prevent cascaded errors, see
3195 -- ACATS B393002 for an example.
3197 elsif Token
= Tok_Semicolon
then
3198 Error_Msg_AP
("missing record definition");
3200 -- Case starting with RECORD keyword. Build scope stack entry. For the
3201 -- column, we use the first non-blank character on the line, to deal
3202 -- with situations such as:
3208 -- which is not official RM indentation, but is not uncommon usage, and
3209 -- in particular is standard GNAT coding style, so handle it nicely.
3213 Scope
.Table
(Scope
.Last
).Etyp
:= E_Record
;
3214 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
3215 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
3216 Scope
.Table
(Scope
.Last
).Labl
:= Error
;
3217 Scope
.Table
(Scope
.Last
).Junk
:= (Token
/= Tok_Record
);
3221 Set_Component_List
(Rec_Node
, P_Component_List
);
3224 exit when Check_End
;
3225 Discard_Junk_Node
(P_Component_List
);
3230 end P_Record_Definition
;
3232 -------------------------
3233 -- 3.8 Component List --
3234 -------------------------
3236 -- COMPONENT_LIST ::=
3237 -- COMPONENT_ITEM {COMPONENT_ITEM}
3238 -- | {COMPONENT_ITEM} VARIANT_PART
3241 -- Error recovery: cannot raise Error_Resync
3243 function P_Component_List
return Node_Id
is
3244 Component_List_Node
: Node_Id
;
3245 Decls_List
: List_Id
;
3246 Scan_State
: Saved_Scan_State
;
3249 Component_List_Node
:= New_Node
(N_Component_List
, Token_Ptr
);
3250 Decls_List
:= New_List
;
3252 if Token
= Tok_Null
then
3255 P_Pragmas_Opt
(Decls_List
);
3256 Set_Null_Present
(Component_List_Node
, True);
3257 return Component_List_Node
;
3260 P_Pragmas_Opt
(Decls_List
);
3262 if Token
/= Tok_Case
then
3263 Component_Scan_Loop
: loop
3264 P_Component_Items
(Decls_List
);
3265 P_Pragmas_Opt
(Decls_List
);
3267 exit Component_Scan_Loop
when Token
= Tok_End
3268 or else Token
= Tok_Case
3269 or else Token
= Tok_When
;
3271 -- We are done if we do not have an identifier. However, if
3272 -- we have a misspelled reserved identifier that is in a column
3273 -- to the right of the record definition, we will treat it as
3274 -- an identifier. It turns out to be too dangerous in practice
3275 -- to accept such a mis-spelled identifier which does not have
3276 -- this additional clue that confirms the incorrect spelling.
3278 if Token
/= Tok_Identifier
then
3279 if Start_Column
> Scope
.Table
(Scope
.Last
).Ecol
3280 and then Is_Reserved_Identifier
3282 Save_Scan_State
(Scan_State
); -- at reserved id
3283 Scan
; -- possible reserved id
3285 if Token
= Tok_Comma
or else Token
= Tok_Colon
then
3286 Restore_Scan_State
(Scan_State
);
3287 Scan_Reserved_Identifier
(Force_Msg
=> True);
3289 -- Note reserved identifier used as field name after
3290 -- all because not followed by colon or comma
3293 Restore_Scan_State
(Scan_State
);
3294 exit Component_Scan_Loop
;
3297 -- Non-identifier that definitely was not reserved id
3300 exit Component_Scan_Loop
;
3303 end loop Component_Scan_Loop
;
3306 if Token
= Tok_Case
then
3307 Set_Variant_Part
(Component_List_Node
, P_Variant_Part
);
3309 -- Check for junk after variant part
3311 if Token
= Tok_Identifier
then
3312 Save_Scan_State
(Scan_State
);
3313 Scan
; -- past identifier
3315 if Token
= Tok_Colon
then
3316 Restore_Scan_State
(Scan_State
);
3317 Error_Msg_SC
("component may not follow variant part");
3318 Discard_Junk_Node
(P_Component_List
);
3320 elsif Token
= Tok_Case
then
3321 Restore_Scan_State
(Scan_State
);
3322 Error_Msg_SC
("only one variant part allowed in a record");
3323 Discard_Junk_Node
(P_Component_List
);
3326 Restore_Scan_State
(Scan_State
);
3332 Set_Component_Items
(Component_List_Node
, Decls_List
);
3333 return Component_List_Node
;
3334 end P_Component_List
;
3336 -------------------------
3337 -- 3.8 Component Item --
3338 -------------------------
3340 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
3342 -- COMPONENT_DECLARATION ::=
3343 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
3344 -- [:= DEFAULT_EXPRESSION]
3345 -- [ASPECT_SPECIFICATIONS];
3347 -- COMPONENT_DEFINITION ::=
3348 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
3350 -- Error recovery: cannot raise Error_Resync, if an error occurs,
3351 -- the scan is positioned past the following semicolon.
3353 -- Note: we do not yet allow representation clauses to appear as component
3354 -- items, do we need to add this capability sometime in the future ???
3356 procedure P_Component_Items
(Decls
: List_Id
) is
3357 Aliased_Present
: Boolean := False;
3358 CompDef_Node
: Node_Id
;
3359 Decl_Node
: Node_Id
;
3360 Scan_State
: Saved_Scan_State
;
3361 Not_Null_Present
: Boolean := False;
3364 Ident_Sloc
: Source_Ptr
;
3366 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
3367 -- This array holds the list of defining identifiers. The upper bound
3368 -- of 4096 is intended to be essentially infinite, and we do not even
3369 -- bother to check for it being exceeded.
3372 if Token
/= Tok_Identifier
then
3373 Error_Msg_SC
("component declaration expected");
3374 Resync_Past_Semicolon
;
3378 Ident_Sloc
:= Token_Ptr
;
3379 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
3382 while Comma_Present
loop
3383 Num_Idents
:= Num_Idents
+ 1;
3384 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
3387 -- If there are multiple identifiers, we repeatedly scan the
3388 -- type and initialization expression information by resetting
3389 -- the scan pointer (so that we get completely separate trees
3390 -- for each occurrence).
3392 if Num_Idents
> 1 then
3393 Save_Scan_State
(Scan_State
);
3398 -- Loop through defining identifiers in list
3403 -- The following block is present to catch Error_Resync
3404 -- which causes the parse to be reset past the semicolon
3407 Decl_Node
:= New_Node
(N_Component_Declaration
, Ident_Sloc
);
3408 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
3410 if Token
= Tok_Constant
then
3411 Error_Msg_SC
("constant components are not permitted");
3415 CompDef_Node
:= New_Node
(N_Component_Definition
, Token_Ptr
);
3417 if Token_Name
= Name_Aliased
then
3418 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
3421 if Token
= Tok_Aliased
then
3422 Aliased_Present
:= True;
3423 Scan
; -- past ALIASED
3426 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/AI-254)
3428 -- Ada 2005 (AI-230): Access Definition case
3430 if Token
= Tok_Access
then
3431 if Ada_Version
< Ada_2005
then
3433 ("generalized use of anonymous access types " &
3434 "is an Ada 2005 extension");
3435 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
3438 if Aliased_Present
then
3439 Error_Msg_SP
("ALIASED not allowed here");
3442 Set_Subtype_Indication
(CompDef_Node
, Empty
);
3443 Set_Aliased_Present
(CompDef_Node
, False);
3444 Set_Access_Definition
(CompDef_Node
,
3445 P_Access_Definition
(Not_Null_Present
));
3448 Set_Access_Definition
(CompDef_Node
, Empty
);
3449 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
3450 Set_Null_Exclusion_Present
(CompDef_Node
, Not_Null_Present
);
3452 if Token
= Tok_Array
then
3453 Error_Msg_SC
("anonymous arrays not allowed as components");
3457 Set_Subtype_Indication
(CompDef_Node
,
3458 P_Subtype_Indication
(Not_Null_Present
));
3461 Set_Component_Definition
(Decl_Node
, CompDef_Node
);
3462 Set_Expression
(Decl_Node
, Init_Expr_Opt
);
3465 Set_Prev_Ids
(Decl_Node
, True);
3468 if Ident
< Num_Idents
then
3469 Set_More_Ids
(Decl_Node
, True);
3472 Append
(Decl_Node
, Decls
);
3475 when Error_Resync
=>
3476 if Token
/= Tok_End
then
3477 Resync_Past_Semicolon
;
3481 exit Ident_Loop
when Ident
= Num_Idents
;
3483 Restore_Scan_State
(Scan_State
);
3485 end loop Ident_Loop
;
3487 P_Aspect_Specifications
(Decl_Node
);
3488 end P_Component_Items
;
3490 --------------------------------
3491 -- 3.8 Component Declaration --
3492 --------------------------------
3494 -- Parsed by P_Component_Items (3.8)
3496 -------------------------
3497 -- 3.8.1 Variant Part --
3498 -------------------------
3501 -- case discriminant_DIRECT_NAME is
3506 -- The caller has checked that the initial token is CASE
3508 -- Error recovery: cannot raise Error_Resync
3510 function P_Variant_Part
return Node_Id
is
3511 Variant_Part_Node
: Node_Id
;
3512 Variants_List
: List_Id
;
3513 Case_Node
: Node_Id
;
3516 Variant_Part_Node
:= New_Node
(N_Variant_Part
, Token_Ptr
);
3518 Scope
.Table
(Scope
.Last
).Etyp
:= E_Case
;
3519 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
3520 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
3523 Case_Node
:= P_Expression
;
3524 Set_Name
(Variant_Part_Node
, Case_Node
);
3526 if Nkind
(Case_Node
) /= N_Identifier
then
3527 Set_Name
(Variant_Part_Node
, Error
);
3528 Error_Msg
("discriminant name expected", Sloc
(Case_Node
));
3530 elsif Paren_Count
(Case_Node
) /= 0 then
3532 ("|discriminant name may not be parenthesized",
3534 Set_Paren_Count
(Case_Node
, 0);
3538 Variants_List
:= New_List
;
3539 P_Pragmas_Opt
(Variants_List
);
3541 -- Test missing variant
3543 if Token
= Tok_End
then
3544 Error_Msg_BC
("WHEN expected (must have at least one variant)");
3546 Append
(P_Variant
, Variants_List
);
3549 -- Loop through variants, note that we allow if in place of when,
3550 -- this error will be detected and handled in P_Variant.
3553 P_Pragmas_Opt
(Variants_List
);
3555 if Token
/= Tok_When
3556 and then Token
/= Tok_If
3557 and then Token
/= Tok_Others
3559 exit when Check_End
;
3562 Append
(P_Variant
, Variants_List
);
3565 Set_Variants
(Variant_Part_Node
, Variants_List
);
3566 return Variant_Part_Node
;
3569 --------------------
3571 --------------------
3574 -- when DISCRETE_CHOICE_LIST =>
3577 -- Error recovery: cannot raise Error_Resync
3579 -- The initial token on entry is either WHEN, IF or OTHERS
3581 function P_Variant
return Node_Id
is
3582 Variant_Node
: Node_Id
;
3585 -- Special check to recover nicely from use of IF in place of WHEN
3587 if Token
= Tok_If
then
3594 Variant_Node
:= New_Node
(N_Variant
, Prev_Token_Ptr
);
3595 Set_Discrete_Choices
(Variant_Node
, P_Discrete_Choice_List
);
3597 Set_Component_List
(Variant_Node
, P_Component_List
);
3598 return Variant_Node
;
3601 ---------------------------------
3602 -- 3.8.1 Discrete Choice List --
3603 ---------------------------------
3605 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
3607 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
3609 -- Note: in Ada 83, the expression must be a simple expression
3611 -- Error recovery: cannot raise Error_Resync
3613 function P_Discrete_Choice_List
return List_Id
is
3615 Expr_Node
: Node_Id
;
3616 Choice_Node
: Node_Id
;
3619 Choices
:= New_List
;
3621 if Token
= Tok_Others
then
3622 Append
(New_Node
(N_Others_Choice
, Token_Ptr
), Choices
);
3623 Scan
; -- past OTHERS
3627 -- Scan out expression or range attribute
3629 Expr_Node
:= P_Expression_Or_Range_Attribute
;
3630 Ignore
(Tok_Right_Paren
);
3632 if Token
= Tok_Colon
3633 and then Nkind
(Expr_Node
) = N_Identifier
3635 Error_Msg_SP
("label not permitted in this context");
3640 elsif Expr_Form
= EF_Range_Attr
then
3641 Append
(Expr_Node
, Choices
);
3645 elsif Token
= Tok_Dot_Dot
then
3646 Check_Simple_Expression
(Expr_Node
);
3647 Choice_Node
:= New_Node
(N_Range
, Token_Ptr
);
3648 Set_Low_Bound
(Choice_Node
, Expr_Node
);
3650 Expr_Node
:= P_Expression_No_Right_Paren
;
3651 Check_Simple_Expression
(Expr_Node
);
3652 Set_High_Bound
(Choice_Node
, Expr_Node
);
3653 Append
(Choice_Node
, Choices
);
3655 -- Simple name, must be subtype, so range allowed
3657 elsif Expr_Form
= EF_Simple_Name
then
3658 if Token
= Tok_Range
then
3659 Append
(P_Subtype_Indication
(Expr_Node
), Choices
);
3661 elsif Token
in Token_Class_Consk
then
3663 ("the only constraint allowed here " &
3664 "is a range constraint");
3665 Discard_Junk_Node
(P_Constraint_Opt
);
3666 Append
(Expr_Node
, Choices
);
3669 Append
(Expr_Node
, Choices
);
3675 -- In Ada 2012 mode, the expression must be a simple
3676 -- expression. The resaon for this restriction (i.e. going
3677 -- back to the Ada 83 rule) is to avoid ambiguities when set
3678 -- membership operations are allowed, consider the
3681 -- when A in 1 .. 10 | 12 =>
3683 -- This is ambiguous without parentheses, so we require one
3684 -- of the following two parenthesized forms to disambuguate:
3686 -- one of the following:
3688 -- when (A in 1 .. 10 | 12) =>
3689 -- when (A in 1 .. 10) | 12 =>
3691 -- To solve this, in Ada 2012 mode, we disallow the use of
3692 -- membership operations in expressions in choices.
3694 -- Technically in the grammar, the expression must match the
3695 -- grammar for restricted expression.
3697 if Ada_Version
>= Ada_2012
then
3698 Check_Restricted_Expression
(Expr_Node
);
3700 -- In Ada 83 mode, the syntax required a simple expression
3703 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
3706 Append
(Expr_Node
, Choices
);
3710 when Error_Resync
=>
3716 if Token
= Tok_Comma
then
3717 Error_Msg_SC
-- CODEFIX
3718 (""","" should be ""'|""");
3720 exit when Token
/= Tok_Vertical_Bar
;
3723 Scan
; -- past | or comma
3727 end P_Discrete_Choice_List
;
3729 ----------------------------
3730 -- 3.8.1 Discrete Choice --
3731 ----------------------------
3733 -- Parsed by P_Discrete_Choice_List (3.8.1)
3735 ----------------------------------
3736 -- 3.9.1 Record Extension Part --
3737 ----------------------------------
3739 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
3741 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
3743 --------------------------------------
3744 -- 3.9.4 Interface Type Definition --
3745 --------------------------------------
3747 -- INTERFACE_TYPE_DEFINITION ::=
3748 -- [limited | task | protected | synchronized] interface
3749 -- [and INTERFACE_LIST]
3751 -- Error recovery: cannot raise Error_Resync
3753 function P_Interface_Type_Definition
3754 (Abstract_Present
: Boolean) return Node_Id
3756 Typedef_Node
: Node_Id
;
3759 if Ada_Version
< Ada_2005
then
3760 Error_Msg_SP
("abstract interface is an Ada 2005 extension");
3761 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
3764 if Abstract_Present
then
3766 ("ABSTRACT not allowed in interface type definition " &
3770 Scan
; -- past INTERFACE
3772 -- Ada 2005 (AI-345): In case of interfaces with a null list of
3773 -- interfaces we build a record_definition node.
3775 if Token
= Tok_Semicolon
or else Aspect_Specifications_Present
then
3776 Typedef_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
3778 Set_Abstract_Present
(Typedef_Node
);
3779 Set_Tagged_Present
(Typedef_Node
);
3780 Set_Null_Present
(Typedef_Node
);
3781 Set_Interface_Present
(Typedef_Node
);
3783 -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have
3784 -- a list of interfaces we build a derived_type_definition node. This
3785 -- simplifies the semantic analysis (and hence further maintenance)
3788 if Token
/= Tok_And
then
3789 Error_Msg_AP
("AND expected");
3794 Typedef_Node
:= New_Node
(N_Derived_Type_Definition
, Token_Ptr
);
3796 Set_Abstract_Present
(Typedef_Node
);
3797 Set_Interface_Present
(Typedef_Node
);
3798 Set_Subtype_Indication
(Typedef_Node
, P_Qualified_Simple_Name
);
3800 Set_Record_Extension_Part
(Typedef_Node
,
3801 New_Node
(N_Record_Definition
, Token_Ptr
));
3802 Set_Null_Present
(Record_Extension_Part
(Typedef_Node
));
3804 if Token
= Tok_And
then
3805 Set_Interface_List
(Typedef_Node
, New_List
);
3809 Append
(P_Qualified_Simple_Name
,
3810 Interface_List
(Typedef_Node
));
3811 exit when Token
/= Tok_And
;
3817 return Typedef_Node
;
3818 end P_Interface_Type_Definition
;
3820 ----------------------------------
3821 -- 3.10 Access Type Definition --
3822 ----------------------------------
3824 -- ACCESS_TYPE_DEFINITION ::=
3825 -- ACCESS_TO_OBJECT_DEFINITION
3826 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3828 -- ACCESS_TO_OBJECT_DEFINITION ::=
3829 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
3831 -- GENERAL_ACCESS_MODIFIER ::= all | constant
3833 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3834 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3835 -- | [NULL_EXCLUSION] access [protected] function
3836 -- PARAMETER_AND_RESULT_PROFILE
3838 -- PARAMETER_PROFILE ::= [FORMAL_PART]
3840 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
3842 -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already
3843 -- parsed the null_exclusion part and has also removed the ACCESS token;
3844 -- otherwise the caller has just checked that the initial token is ACCESS
3846 -- Error recovery: can raise Error_Resync
3848 function P_Access_Type_Definition
3849 (Header_Already_Parsed
: Boolean := False) return Node_Id
3851 Access_Loc
: constant Source_Ptr
:= Token_Ptr
;
3852 Prot_Flag
: Boolean;
3853 Not_Null_Present
: Boolean := False;
3854 Type_Def_Node
: Node_Id
;
3855 Result_Not_Null
: Boolean;
3856 Result_Node
: Node_Id
;
3858 procedure Check_Junk_Subprogram_Name
;
3859 -- Used in access to subprogram definition cases to check for an
3860 -- identifier or operator symbol that does not belong.
3862 --------------------------------
3863 -- Check_Junk_Subprogram_Name --
3864 --------------------------------
3866 procedure Check_Junk_Subprogram_Name
is
3867 Saved_State
: Saved_Scan_State
;
3870 if Token
= Tok_Identifier
or else Token
= Tok_Operator_Symbol
then
3871 Save_Scan_State
(Saved_State
);
3872 Scan
; -- past possible junk subprogram name
3874 if Token
= Tok_Left_Paren
or else Token
= Tok_Semicolon
then
3875 Error_Msg_SP
("unexpected subprogram name ignored");
3879 Restore_Scan_State
(Saved_State
);
3882 end Check_Junk_Subprogram_Name
;
3884 -- Start of processing for P_Access_Type_Definition
3887 if not Header_Already_Parsed
then
3888 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
3889 Scan
; -- past ACCESS
3892 if Token_Name
= Name_Protected
then
3893 Check_95_Keyword
(Tok_Protected
, Tok_Procedure
);
3894 Check_95_Keyword
(Tok_Protected
, Tok_Function
);
3897 Prot_Flag
:= (Token
= Tok_Protected
);
3900 Scan
; -- past PROTECTED
3902 if Token
/= Tok_Procedure
and then Token
/= Tok_Function
then
3903 Error_Msg_SC
-- CODEFIX
3904 ("FUNCTION or PROCEDURE expected");
3908 if Token
= Tok_Procedure
then
3909 if Ada_Version
= Ada_83
then
3910 Error_Msg_SC
("(Ada 83) access to procedure not allowed!");
3913 Type_Def_Node
:= New_Node
(N_Access_Procedure_Definition
, Access_Loc
);
3914 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3915 Scan
; -- past PROCEDURE
3916 Check_Junk_Subprogram_Name
;
3917 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
3918 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
3920 elsif Token
= Tok_Function
then
3921 if Ada_Version
= Ada_83
then
3922 Error_Msg_SC
("(Ada 83) access to function not allowed!");
3925 Type_Def_Node
:= New_Node
(N_Access_Function_Definition
, Access_Loc
);
3926 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3927 Scan
; -- past FUNCTION
3928 Check_Junk_Subprogram_Name
;
3929 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
3930 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
3933 Result_Not_Null
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
3935 -- Ada 2005 (AI-318-02)
3937 if Token
= Tok_Access
then
3938 if Ada_Version
< Ada_2005
then
3940 ("anonymous access result type is an Ada 2005 extension");
3941 Error_Msg_SC
("\unit must be compiled with -gnat05 switch");
3944 Result_Node
:= P_Access_Definition
(Result_Not_Null
);
3947 Result_Node
:= P_Subtype_Mark
;
3950 -- A null exclusion on the result type must be recorded in a flag
3951 -- distinct from the one used for the access-to-subprogram type's
3954 Set_Null_Exclusion_In_Return_Present
3955 (Type_Def_Node
, Result_Not_Null
);
3958 Set_Result_Definition
(Type_Def_Node
, Result_Node
);
3962 New_Node
(N_Access_To_Object_Definition
, Access_Loc
);
3963 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3965 if Token
= Tok_All
or else Token
= Tok_Constant
then
3966 if Ada_Version
= Ada_83
then
3967 Error_Msg_SC
("(Ada 83) access modifier not allowed!");
3970 if Token
= Tok_All
then
3971 Set_All_Present
(Type_Def_Node
, True);
3974 Set_Constant_Present
(Type_Def_Node
, True);
3977 Scan
; -- past ALL or CONSTANT
3980 Set_Subtype_Indication
(Type_Def_Node
,
3981 P_Subtype_Indication
(Not_Null_Present
));
3984 return Type_Def_Node
;
3985 end P_Access_Type_Definition
;
3987 ---------------------------------------
3988 -- 3.10 Access To Object Definition --
3989 ---------------------------------------
3991 -- Parsed by P_Access_Type_Definition (3.10)
3993 -----------------------------------
3994 -- 3.10 General Access Modifier --
3995 -----------------------------------
3997 -- Parsed by P_Access_Type_Definition (3.10)
3999 -------------------------------------------
4000 -- 3.10 Access To Subprogram Definition --
4001 -------------------------------------------
4003 -- Parsed by P_Access_Type_Definition (3.10)
4005 -----------------------------
4006 -- 3.10 Access Definition --
4007 -----------------------------
4009 -- ACCESS_DEFINITION ::=
4010 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
4011 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
4013 -- ACCESS_TO_SUBPROGRAM_DEFINITION
4014 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
4015 -- | [NULL_EXCLUSION] access [protected] function
4016 -- PARAMETER_AND_RESULT_PROFILE
4018 -- The caller has parsed the null-exclusion part and it has also checked
4019 -- that the next token is ACCESS
4021 -- Error recovery: cannot raise Error_Resync
4023 function P_Access_Definition
4024 (Null_Exclusion_Present
: Boolean) return Node_Id
4027 Subp_Node
: Node_Id
;
4030 Def_Node
:= New_Node
(N_Access_Definition
, Token_Ptr
);
4031 Scan
; -- past ACCESS
4033 -- Ada 2005 (AI-254): Access_To_Subprogram_Definition
4035 if Token
= Tok_Protected
4036 or else Token
= Tok_Procedure
4037 or else Token
= Tok_Function
4039 if Ada_Version
< Ada_2005
then
4040 Error_Msg_SP
("access-to-subprogram is an Ada 2005 extension");
4041 Error_Msg_SP
("\unit should be compiled with -gnat05 switch");
4044 Subp_Node
:= P_Access_Type_Definition
(Header_Already_Parsed
=> True);
4045 Set_Null_Exclusion_Present
(Subp_Node
, Null_Exclusion_Present
);
4046 Set_Access_To_Subprogram_Definition
(Def_Node
, Subp_Node
);
4048 -- Ada 2005 (AI-231)
4049 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
4052 Set_Null_Exclusion_Present
(Def_Node
, Null_Exclusion_Present
);
4054 if Token
= Tok_All
then
4055 if Ada_Version
< Ada_2005
then
4057 ("ALL is not permitted for anonymous access types");
4061 Set_All_Present
(Def_Node
);
4063 elsif Token
= Tok_Constant
then
4064 if Ada_Version
< Ada_2005
then
4065 Error_Msg_SP
("access-to-constant is an Ada 2005 extension");
4066 Error_Msg_SP
("\unit should be compiled with -gnat05 switch");
4069 Scan
; -- past CONSTANT
4070 Set_Constant_Present
(Def_Node
);
4073 Set_Subtype_Mark
(Def_Node
, P_Subtype_Mark
);
4078 end P_Access_Definition
;
4080 -----------------------------------------
4081 -- 3.10.1 Incomplete Type Declaration --
4082 -----------------------------------------
4084 -- Parsed by P_Type_Declaration (3.2.1)
4086 ----------------------------
4087 -- 3.11 Declarative Part --
4088 ----------------------------
4090 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
4092 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items
4093 -- handles errors, and returns cleanly after an error has occurred)
4095 function P_Declarative_Part
return List_Id
is
4100 -- Indicate no bad declarations detected yet. This will be reset by
4101 -- P_Declarative_Items if a bad declaration is discovered.
4103 Missing_Begin_Msg
:= No_Error_Msg
;
4105 -- Get rid of active SIS entry from outer scope. This means we will
4106 -- miss some nested cases, but it doesn't seem worth the effort. See
4107 -- discussion in Par for further details
4109 SIS_Entry_Active
:= False;
4112 -- Loop to scan out the declarations
4115 P_Declarative_Items
(Decls
, Done
, In_Spec
=> False);
4119 -- Get rid of active SIS entry which is left set only if we scanned a
4120 -- procedure declaration and have not found the body. We could give
4121 -- an error message, but that really would be usurping the role of
4122 -- semantic analysis (this really is a missing body case).
4124 SIS_Entry_Active
:= False;
4126 end P_Declarative_Part
;
4128 ----------------------------
4129 -- 3.11 Declarative Item --
4130 ----------------------------
4132 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
4134 -- Can return Error if a junk declaration is found, or Empty if no
4135 -- declaration is found (i.e. a token ending declarations, such as
4136 -- BEGIN or END is encountered).
4138 -- Error recovery: cannot raise Error_Resync. If an error resync occurs,
4139 -- then the scan is set past the next semicolon and Error is returned.
4141 procedure P_Declarative_Items
4146 Scan_State
: Saved_Scan_State
;
4150 Style
.Check_Indentation
;
4155 when Tok_Function
=>
4157 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4163 -- Check for loop (premature statement)
4165 Save_Scan_State
(Scan_State
);
4168 if Token
= Tok_Identifier
then
4169 Scan
; -- past identifier
4171 if Token
= Tok_In
then
4172 Restore_Scan_State
(Scan_State
);
4173 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4178 -- Not a loop, so must be rep clause
4180 Restore_Scan_State
(Scan_State
);
4181 Append
(P_Representation_Clause
, Decls
);
4186 Append
(P_Generic
, Decls
);
4189 when Tok_Identifier
=>
4192 -- Special check for misuse of overriding not in Ada 2005 mode
4194 if Token_Name
= Name_Overriding
4195 and then not Next_Token_Is
(Tok_Colon
)
4197 Error_Msg_SC
("overriding indicator is an Ada 2005 extension");
4198 Error_Msg_SC
("\unit must be compiled with -gnat05 switch");
4200 Token
:= Tok_Overriding
;
4201 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4204 -- Normal case, no overriding, or overriding followed by colon
4207 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4210 -- Ada2005: A subprogram declaration can start with "not" or
4211 -- "overriding". In older versions, "overriding" is handled
4212 -- like an identifier, with the appropriate messages.
4216 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4219 when Tok_Overriding
=>
4221 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4226 Append
(P_Package
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4230 Append
(P_Pragma
, Decls
);
4233 when Tok_Procedure
=>
4235 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp
), Decls
);
4238 when Tok_Protected
=>
4240 Scan
; -- past PROTECTED
4241 Append
(P_Protected
, Decls
);
4246 Append
(P_Subtype_Declaration
, Decls
);
4252 Append
(P_Task
, Decls
);
4257 Append
(P_Type_Declaration
, Decls
);
4262 Append
(P_Use_Clause
, Decls
);
4267 Error_Msg_SC
("WITH can only appear in context clause");
4270 -- BEGIN terminates the scan of a sequence of declarations unless
4271 -- there is a missing subprogram body, see section on handling
4272 -- semicolon in place of IS. We only treat the begin as satisfying
4273 -- the subprogram declaration if it falls in the expected column
4277 if SIS_Entry_Active
and then Start_Column
>= SIS_Ecol
then
4279 -- Here we have the case where a BEGIN is encountered during
4280 -- declarations in a declarative part, or at the outer level,
4281 -- and there is a subprogram declaration outstanding for which
4282 -- no body has been supplied. This is the case where we assume
4283 -- that the semicolon in the subprogram declaration should
4284 -- really have been is. The active SIS entry describes the
4285 -- subprogram declaration. On return the declaration has been
4286 -- modified to become a body.
4289 Specification_Node
: Node_Id
;
4290 Decl_Node
: Node_Id
;
4291 Body_Node
: Node_Id
;
4294 -- First issue the error message. If we had a missing
4295 -- semicolon in the declaration, then change the message
4296 -- to <missing "is">
4298 if SIS_Missing_Semicolon_Message
/= No_Error_Msg
then
4299 Change_Error_Text
-- Replace: "missing "";"" "
4300 (SIS_Missing_Semicolon_Message
, "missing ""is""");
4302 -- Otherwise we saved the semicolon position, so complain
4305 Error_Msg
-- CODEFIX
4306 ("|"";"" should be IS", SIS_Semicolon_Sloc
);
4309 -- The next job is to fix up any declarations that occurred
4310 -- between the procedure header and the BEGIN. These got
4311 -- chained to the outer declarative region (immediately
4312 -- after the procedure declaration) and they should be
4313 -- chained to the subprogram itself, which is a body
4314 -- rather than a spec.
4316 Specification_Node
:= Specification
(SIS_Declaration_Node
);
4317 Change_Node
(SIS_Declaration_Node
, N_Subprogram_Body
);
4318 Body_Node
:= SIS_Declaration_Node
;
4319 Set_Specification
(Body_Node
, Specification_Node
);
4320 Set_Declarations
(Body_Node
, New_List
);
4323 Decl_Node
:= Remove_Next
(Body_Node
);
4324 exit when Decl_Node
= Empty
;
4325 Append
(Decl_Node
, Declarations
(Body_Node
));
4328 -- Now make the scope table entry for the Begin-End and
4332 Scope
.Table
(Scope
.Last
).Sloc
:= SIS_Sloc
;
4333 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
4334 Scope
.Table
(Scope
.Last
).Ecol
:= SIS_Ecol
;
4335 Scope
.Table
(Scope
.Last
).Labl
:= SIS_Labl
;
4336 Scope
.Table
(Scope
.Last
).Lreq
:= False;
4337 SIS_Entry_Active
:= False;
4339 Set_Handled_Statement_Sequence
(Body_Node
,
4340 P_Handled_Sequence_Of_Statements
);
4341 End_Statements
(Handled_Statement_Sequence
(Body_Node
));
4350 -- Normally an END terminates the scan for basic declarative items.
4351 -- The one exception is END RECORD, which is probably left over from
4355 Save_Scan_State
(Scan_State
); -- at END
4358 if Token
= Tok_Record
then
4359 Error_Msg_SP
("no RECORD for this `end record`!");
4360 Scan
; -- past RECORD
4364 Restore_Scan_State
(Scan_State
); -- to END
4368 -- The following tokens which can only be the start of a statement
4369 -- are considered to end a declarative part (i.e. we have a missing
4370 -- BEGIN situation). We are fairly conservative in making this
4371 -- judgment, because it is a real mess to go into statement mode
4372 -- prematurely in response to a junk declaration.
4387 -- But before we decide that it's a statement, let's check for
4388 -- a reserved word misused as an identifier.
4390 if Is_Reserved_Identifier
then
4391 Save_Scan_State
(Scan_State
);
4392 Scan
; -- past the token
4394 -- If reserved identifier not followed by colon or comma, then
4395 -- this is most likely an assignment statement to the bad id.
4397 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
4398 Restore_Scan_State
(Scan_State
);
4399 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4402 -- Otherwise we have a declaration of the bad id
4405 Restore_Scan_State
(Scan_State
);
4406 Scan_Reserved_Identifier
(Force_Msg
=> True);
4407 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4410 -- If not reserved identifier, then it's definitely a statement
4413 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4417 -- The token RETURN may well also signal a missing BEGIN situation,
4418 -- however, we never let it end the declarative part, because it may
4419 -- also be part of a half-baked function declaration.
4422 Error_Msg_SC
("misplaced RETURN statement");
4425 -- PRIVATE definitely terminates the declarations in a spec,
4426 -- and is an error in a body.
4432 Error_Msg_SC
("PRIVATE not allowed in body");
4433 Scan
; -- past PRIVATE
4436 -- An end of file definitely terminates the declarations!
4441 -- The remaining tokens do not end the scan, but cannot start a
4442 -- valid declaration, so we signal an error and resynchronize.
4443 -- But first check for misuse of a reserved identifier.
4447 -- Here we check for a reserved identifier
4449 if Is_Reserved_Identifier
then
4450 Save_Scan_State
(Scan_State
);
4451 Scan
; -- past the token
4453 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
4454 Restore_Scan_State
(Scan_State
);
4455 Set_Declaration_Expected
;
4458 Restore_Scan_State
(Scan_State
);
4459 Scan_Reserved_Identifier
(Force_Msg
=> True);
4461 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4465 Set_Declaration_Expected
;
4470 -- To resynchronize after an error, we scan to the next semicolon and
4471 -- return with Done = False, indicating that there may still be more
4472 -- valid declarations to come.
4475 when Error_Resync
=>
4476 Resync_Past_Semicolon
;
4478 end P_Declarative_Items
;
4480 ----------------------------------
4481 -- 3.11 Basic Declarative Item --
4482 ----------------------------------
4484 -- BASIC_DECLARATIVE_ITEM ::=
4485 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
4487 -- Scan zero or more basic declarative items
4489 -- Error recovery: cannot raise Error_Resync. If an error is detected, then
4490 -- the scan pointer is repositioned past the next semicolon, and the scan
4491 -- for declarative items continues.
4493 function P_Basic_Declarative_Items
return List_Id
is
4500 -- Indicate no bad declarations detected yet in the current context:
4501 -- visible or private declarations of a package spec.
4503 Missing_Begin_Msg
:= No_Error_Msg
;
4505 -- Get rid of active SIS entry from outer scope. This means we will
4506 -- miss some nested cases, but it doesn't seem worth the effort. See
4507 -- discussion in Par for further details
4509 SIS_Entry_Active
:= False;
4511 -- Loop to scan out declarations
4516 P_Declarative_Items
(Decls
, Done
, In_Spec
=> True);
4520 -- Get rid of active SIS entry. This is set only if we have scanned a
4521 -- procedure declaration and have not found the body. We could give
4522 -- an error message, but that really would be usurping the role of
4523 -- semantic analysis (this really is a case of a missing body).
4525 SIS_Entry_Active
:= False;
4527 -- Test for assorted illegal declarations not diagnosed elsewhere
4529 Decl
:= First
(Decls
);
4531 while Present
(Decl
) loop
4532 Kind
:= Nkind
(Decl
);
4534 -- Test for body scanned, not acceptable as basic decl item
4536 if Kind
= N_Subprogram_Body
or else
4537 Kind
= N_Package_Body
or else
4538 Kind
= N_Task_Body
or else
4539 Kind
= N_Protected_Body
4541 Error_Msg
("proper body not allowed in package spec", Sloc
(Decl
));
4543 -- Test for body stub scanned, not acceptable as basic decl item
4545 elsif Kind
in N_Body_Stub
then
4546 Error_Msg
("body stub not allowed in package spec", Sloc
(Decl
));
4548 elsif Kind
= N_Assignment_Statement
then
4550 ("assignment statement not allowed in package spec",
4558 end P_Basic_Declarative_Items
;
4564 -- For proper body, see below
4565 -- For body stub, see 10.1.3
4567 -----------------------
4568 -- 3.11 Proper Body --
4569 -----------------------
4571 -- Subprogram body is parsed by P_Subprogram (6.1)
4572 -- Package body is parsed by P_Package (7.1)
4573 -- Task body is parsed by P_Task (9.1)
4574 -- Protected body is parsed by P_Protected (9.4)
4576 ------------------------------
4577 -- Set_Declaration_Expected --
4578 ------------------------------
4580 procedure Set_Declaration_Expected
is
4582 Error_Msg_SC
("declaration expected");
4584 if Missing_Begin_Msg
= No_Error_Msg
then
4585 Missing_Begin_Msg
:= Get_Msg_Id
;
4587 end Set_Declaration_Expected
;
4589 ----------------------
4590 -- Skip_Declaration --
4591 ----------------------
4593 procedure Skip_Declaration
(S
: List_Id
) is
4594 Dummy_Done
: Boolean;
4595 pragma Warnings
(Off
, Dummy_Done
);
4597 P_Declarative_Items
(S
, Dummy_Done
, False);
4598 end Skip_Declaration
;
4600 -----------------------------------------
4601 -- Statement_When_Declaration_Expected --
4602 -----------------------------------------
4604 procedure Statement_When_Declaration_Expected
4610 -- Case of second occurrence of statement in one declaration sequence
4612 if Missing_Begin_Msg
/= No_Error_Msg
then
4614 -- In the procedure spec case, just ignore it, we only give one
4615 -- message for the first occurrence, since otherwise we may get
4616 -- horrible cascading if BODY was missing in the header line.
4621 -- In the declarative part case, take a second statement as a sure
4622 -- sign that we really have a missing BEGIN, and end the declarative
4623 -- part now. Note that the caller will fix up the first message to
4624 -- say "missing BEGIN" so that's how the error will be signalled.
4631 -- Case of first occurrence of unexpected statement
4634 -- If we are in a package spec, then give message of statement
4635 -- not allowed in package spec. This message never gets changed.
4638 Error_Msg_SC
("statement not allowed in package spec");
4640 -- If in declarative part, then we give the message complaining
4641 -- about finding a statement when a declaration is expected. This
4642 -- gets changed to a complaint about a missing BEGIN if we later
4643 -- find that no BEGIN is present.
4646 Error_Msg_SC
("statement not allowed in declarative part");
4649 -- Capture message Id. This is used for two purposes, first to
4650 -- stop multiple messages, see test above, and second, to allow
4651 -- the replacement of the message in the declarative part case.
4653 Missing_Begin_Msg
:= Get_Msg_Id
;
4656 -- In all cases except the case in which we decided to terminate the
4657 -- declaration sequence on a second error, we scan out the statement
4658 -- and append it to the list of declarations (note that the semantics
4659 -- can handle statements in a declaration list so if we proceed to
4660 -- call the semantic phase, all will be (reasonably) well!
4662 Append_List_To
(Decls
, P_Sequence_Of_Statements
(SS_Unco
));
4664 -- Done is set to False, since we want to continue the scan of
4665 -- declarations, hoping that this statement was a temporary glitch.
4666 -- If we indeed are now in the statement part (i.e. this was a missing
4667 -- BEGIN, then it's not terrible, we will simply keep calling this
4668 -- procedure to process the statements one by one, and then finally
4669 -- hit the missing BEGIN, which will clean up the error message.
4672 end Statement_When_Declaration_Expected
;