1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 pragma Style_Checks
(All_Checks
);
28 -- Turn off subprogram body ordering check. Subprograms are in order
29 -- by RM section rather than alphabetical.
31 with Sinfo
.CN
; use Sinfo
.CN
;
37 -----------------------
38 -- Local Subprograms --
39 -----------------------
41 function P_Component_List
return Node_Id
;
42 function P_Defining_Character_Literal
return Node_Id
;
43 function P_Delta_Constraint
return Node_Id
;
44 function P_Derived_Type_Def_Or_Private_Ext_Decl
return Node_Id
;
45 function P_Digits_Constraint
return Node_Id
;
46 function P_Discriminant_Association
return Node_Id
;
47 function P_Enumeration_Literal_Specification
return Node_Id
;
48 function P_Enumeration_Type_Definition
return Node_Id
;
49 function P_Fixed_Point_Definition
return Node_Id
;
50 function P_Floating_Point_Definition
return Node_Id
;
51 function P_Index_Or_Discriminant_Constraint
return Node_Id
;
52 function P_Real_Range_Specification_Opt
return Node_Id
;
53 function P_Subtype_Declaration
return Node_Id
;
54 function P_Type_Declaration
return Node_Id
;
55 function P_Modular_Type_Definition
return Node_Id
;
56 function P_Variant
return Node_Id
;
57 function P_Variant_Part
return Node_Id
;
59 procedure P_Declarative_Items
63 -- Scans out a single declarative item, or, in the case of a declaration
64 -- with a list of identifiers, a list of declarations, one for each of
65 -- the identifiers in the list. The declaration or declarations scanned
66 -- are appended to the given list. Done indicates whether or not there
67 -- may be additional declarative items to scan. If Done is True, then
68 -- a decision has been made that there are no more items to scan. If
69 -- Done is False, then there may be additional declarations to scan.
70 -- In_Spec is true if we are scanning a package declaration, and is used
71 -- to generate an appropriate message if a statement is encountered in
74 procedure P_Identifier_Declarations
78 -- Scans out a set of declarations for an identifier or list of
79 -- identifiers, and appends them to the given list. The parameters have
80 -- the same significance as for P_Declarative_Items.
82 procedure Statement_When_Declaration_Expected
86 -- Called when a statement is found at a point where a declaration was
87 -- expected. The parameters are as described for P_Declarative_Items.
89 procedure Set_Declaration_Expected
;
90 -- Posts a "declaration expected" error messages at the start of the
91 -- current token, and if this is the first such message issued, saves
92 -- the message id in Missing_Begin_Msg, for possible later replacement.
98 function Init_Expr_Opt
(P
: Boolean := False) return Node_Id
is
100 -- For colon, assume it means := unless it is at the end of
101 -- a line, in which case guess that it means a semicolon.
103 if Token
= Tok_Colon
then
104 if Token_Is_At_End_Of_Line
then
109 -- Here if := or something that we will take as equivalent
111 elsif Token
= Tok_Colon_Equal
112 or else Token
= Tok_Equal
113 or else Token
= Tok_Is
117 -- Another possibility. If we have a literal followed by a semicolon,
118 -- we assume that we have a missing colon-equal.
120 elsif Token
in Token_Class_Literal
then
122 Scan_State
: Saved_Scan_State
;
125 Save_Scan_State
(Scan_State
);
126 Scan
; -- past literal or identifier
128 if Token
= Tok_Semicolon
then
129 Restore_Scan_State
(Scan_State
);
131 Restore_Scan_State
(Scan_State
);
136 -- Otherwise we definitely have no initialization expression
142 -- Merge here if we have an initialization expression
149 return P_Expression_No_Right_Paren
;
153 ----------------------------
154 -- 3.1 Basic Declaration --
155 ----------------------------
157 -- Parsed by P_Basic_Declarative_Items (3.9)
159 ------------------------------
160 -- 3.1 Defining Identifier --
161 ------------------------------
163 -- DEFINING_IDENTIFIER ::= IDENTIFIER
165 -- Error recovery: can raise Error_Resync
167 function P_Defining_Identifier
(C
: Id_Check
:= None
) return Node_Id
is
168 Ident_Node
: Node_Id
;
171 -- Scan out the identifier. Note that this code is essentially identical
172 -- to P_Identifier, except that in the call to Scan_Reserved_Identifier
173 -- we set Force_Msg to True, since we want at least one message for each
174 -- separate declaration (but not use) of a reserved identifier.
176 if Token
= Tok_Identifier
then
178 -- Ada 2005 (AI-284): Compiling in Ada95 mode we warn that INTERFACE,
179 -- OVERRIDING, and SYNCHRONIZED are new reserved words.
181 if Ada_Version
= Ada_95
182 and then Warn_On_Ada_2005_Compatibility
184 if Token_Name
= Name_Overriding
185 or else Token_Name
= Name_Synchronized
186 or else (Token_Name
= Name_Interface
187 and then Prev_Token
/= Tok_Pragma
)
189 Error_Msg_N
("& is a reserved word in Ada 2005?", Token_Node
);
193 -- If we have a reserved identifier, manufacture an identifier with
194 -- a corresponding name after posting an appropriate error message
196 elsif Is_Reserved_Identifier
(C
) then
197 Scan_Reserved_Identifier
(Force_Msg
=> True);
199 -- Otherwise we have junk that cannot be interpreted as an identifier
202 T_Identifier
; -- to give message
206 Ident_Node
:= Token_Node
;
207 Scan
; -- past the reserved identifier
209 if Ident_Node
/= Error
then
210 Change_Identifier_To_Defining_Identifier
(Ident_Node
);
214 end P_Defining_Identifier
;
216 -----------------------------
217 -- 3.2.1 Type Declaration --
218 -----------------------------
220 -- TYPE_DECLARATION ::=
221 -- FULL_TYPE_DECLARATION
222 -- | INCOMPLETE_TYPE_DECLARATION
223 -- | PRIVATE_TYPE_DECLARATION
224 -- | PRIVATE_EXTENSION_DECLARATION
226 -- FULL_TYPE_DECLARATION ::=
227 -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION;
228 -- | CONCURRENT_TYPE_DECLARATION
230 -- INCOMPLETE_TYPE_DECLARATION ::=
231 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [is tagged];
233 -- PRIVATE_TYPE_DECLARATION ::=
234 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
235 -- is [abstract] [tagged] [limited] private;
237 -- PRIVATE_EXTENSION_DECLARATION ::=
238 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
239 -- [abstract] [limited | synchronized]
240 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
243 -- TYPE_DEFINITION ::=
244 -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
245 -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION
246 -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION
247 -- | DERIVED_TYPE_DEFINITION | INTERFACE_TYPE_DEFINITION
249 -- INTEGER_TYPE_DEFINITION ::=
250 -- SIGNED_INTEGER_TYPE_DEFINITION
251 -- MODULAR_TYPE_DEFINITION
253 -- INTERFACE_TYPE_DEFINITION ::=
254 -- [limited | task | protected | synchronized ] interface
255 -- [and INTERFACE_LIST]
257 -- Error recovery: can raise Error_Resync
259 -- Note: The processing for full type declaration, incomplete type
260 -- declaration, private type declaration and type definition is
261 -- included in this function. The processing for concurrent type
262 -- declarations is NOT here, but rather in chapter 9 (i.e. this
263 -- function handles only declarations starting with TYPE).
265 function P_Type_Declaration
return Node_Id
is
266 Abstract_Present
: Boolean := False;
267 Abstract_Loc
: Source_Ptr
:= No_Location
;
269 Discr_List
: List_Id
;
270 Discr_Sloc
: Source_Ptr
;
272 Ident_Node
: Node_Id
;
273 Is_Derived_Iface
: Boolean := False;
274 Type_Loc
: Source_Ptr
;
275 Type_Start_Col
: Column_Number
;
276 Unknown_Dis
: Boolean;
278 Typedef_Node
: Node_Id
;
279 -- Normally holds type definition, except in the case of a private
280 -- extension declaration, in which case it holds the declaration itself
283 Type_Loc
:= Token_Ptr
;
284 Type_Start_Col
:= Start_Column
;
286 -- If we have TYPE, then proceed ahead and scan identifier
288 if Token
= Tok_Type
then
290 Ident_Node
:= P_Defining_Identifier
(C_Is
);
292 -- Otherwise this is an error case, and we may already have converted
293 -- the current token to a defining identifier, so don't do it again!
298 if Token
= Tok_Identifier
299 and then Nkind
(Token_Node
) = N_Defining_Identifier
301 Ident_Node
:= Token_Node
;
302 Scan
; -- past defining identifier
304 Ident_Node
:= P_Defining_Identifier
(C_Is
);
308 Discr_Sloc
:= Token_Ptr
;
310 if P_Unknown_Discriminant_Part_Opt
then
312 Discr_List
:= No_List
;
314 Unknown_Dis
:= False;
315 Discr_List
:= P_Known_Discriminant_Part_Opt
;
318 -- Incomplete type declaration. We complete the processing for this
319 -- case here and return the resulting incomplete type declaration node
321 if Token
= Tok_Semicolon
then
323 Decl_Node
:= New_Node
(N_Incomplete_Type_Declaration
, Type_Loc
);
324 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
325 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
326 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
333 -- Full type declaration or private type declaration, must have IS
335 if Token
= Tok_Equal
then
337 Scan
; -- past = used in place of IS
339 elsif Token
= Tok_Renames
then
340 Error_Msg_SC
("RENAMES should be IS");
341 Scan
; -- past RENAMES used in place of IS
347 -- First an error check, if we have two identifiers in a row, a likely
348 -- possibility is that the first of the identifiers is an incorrectly
351 if Token
= Tok_Identifier
then
353 SS
: Saved_Scan_State
;
357 Save_Scan_State
(SS
);
358 Scan
; -- past initial identifier
359 I2
:= (Token
= Tok_Identifier
);
360 Restore_Scan_State
(SS
);
364 (Bad_Spelling_Of
(Tok_Abstract
) or else
365 Bad_Spelling_Of
(Tok_Access
) or else
366 Bad_Spelling_Of
(Tok_Aliased
) or else
367 Bad_Spelling_Of
(Tok_Constant
))
374 -- Check for misuse of Ada 95 keyword abstract in Ada 83 mode
376 if Token_Name
= Name_Abstract
then
377 Check_95_Keyword
(Tok_Abstract
, Tok_Tagged
);
378 Check_95_Keyword
(Tok_Abstract
, Tok_New
);
381 -- Check cases of misuse of ABSTRACT
383 if Token
= Tok_Abstract
then
384 Abstract_Present
:= True;
385 Abstract_Loc
:= Token_Ptr
;
386 Scan
; -- past ABSTRACT
388 -- Ada 2005 (AI-419): AARM 3.4 (2/2)
390 if (Ada_Version
< Ada_05
and then Token
= Tok_Limited
)
391 or else Token
= Tok_Private
392 or else Token
= Tok_Record
393 or else Token
= Tok_Null
395 Error_Msg_AP
("TAGGED expected");
399 -- Check for misuse of Ada 95 keyword Tagged
401 if Token_Name
= Name_Tagged
then
402 Check_95_Keyword
(Tok_Tagged
, Tok_Private
);
403 Check_95_Keyword
(Tok_Tagged
, Tok_Limited
);
404 Check_95_Keyword
(Tok_Tagged
, Tok_Record
);
407 -- Special check for misuse of Aliased
409 if Token
= Tok_Aliased
or else Token_Name
= Name_Aliased
then
410 Error_Msg_SC
("ALIASED not allowed in type definition");
411 Scan
; -- past ALIASED
414 -- The following procesing deals with either a private type declaration
415 -- or a full type declaration. In the private type case, we build the
416 -- N_Private_Type_Declaration node, setting its Tagged_Present and
417 -- Limited_Present flags, on encountering the Private keyword, and
418 -- leave Typedef_Node set to Empty. For the full type declaration
419 -- case, Typedef_Node gets set to the type definition.
421 Typedef_Node
:= Empty
;
423 -- Switch on token following the IS. The loop normally runs once. It
424 -- only runs more than once if an error is detected, to try again after
425 -- detecting and fixing up the error.
431 Tok_Not
=> -- Ada 2005 (AI-231)
432 Typedef_Node
:= P_Access_Type_Definition
;
437 Typedef_Node
:= P_Array_Type_Definition
;
442 Typedef_Node
:= P_Fixed_Point_Definition
;
447 Typedef_Node
:= P_Floating_Point_Definition
;
454 when Tok_Integer_Literal
=>
456 Typedef_Node
:= P_Signed_Integer_Type_Definition
;
461 Typedef_Node
:= P_Record_Definition
;
465 when Tok_Left_Paren
=>
466 Typedef_Node
:= P_Enumeration_Type_Definition
;
469 Make_Identifier
(Token_Ptr
,
470 Chars
=> Chars
(Ident_Node
));
471 Set_Comes_From_Source
(End_Labl
, False);
473 Set_End_Label
(Typedef_Node
, End_Labl
);
478 Typedef_Node
:= P_Modular_Type_Definition
;
483 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
485 if Nkind
(Typedef_Node
) = N_Derived_Type_Definition
486 and then Present
(Record_Extension_Part
(Typedef_Node
))
489 Make_Identifier
(Token_Ptr
,
490 Chars
=> Chars
(Ident_Node
));
491 Set_Comes_From_Source
(End_Labl
, False);
494 (Record_Extension_Part
(Typedef_Node
), End_Labl
);
501 Typedef_Node
:= P_Signed_Integer_Type_Definition
;
506 Typedef_Node
:= P_Record_Definition
;
509 Make_Identifier
(Token_Ptr
,
510 Chars
=> Chars
(Ident_Node
));
511 Set_Comes_From_Source
(End_Labl
, False);
513 Set_End_Label
(Typedef_Node
, End_Labl
);
520 -- Ada 2005 (AI-326): If the words IS TAGGED appear, the type
521 -- is a tagged incomplete type.
523 if Ada_Version
>= Ada_05
524 and then Token
= Tok_Semicolon
529 New_Node
(N_Incomplete_Type_Declaration
, Type_Loc
);
530 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
531 Set_Tagged_Present
(Decl_Node
);
532 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
533 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
538 if Token
= Tok_Abstract
then
539 Error_Msg_SC
("ABSTRACT must come before TAGGED");
540 Abstract_Present
:= True;
541 Abstract_Loc
:= Token_Ptr
;
542 Scan
; -- past ABSTRACT
545 if Token
= Tok_Limited
then
546 Scan
; -- past LIMITED
548 -- TAGGED LIMITED PRIVATE case
550 if Token
= Tok_Private
then
552 New_Node
(N_Private_Type_Declaration
, Type_Loc
);
553 Set_Tagged_Present
(Decl_Node
, True);
554 Set_Limited_Present
(Decl_Node
, True);
555 Scan
; -- past PRIVATE
557 -- TAGGED LIMITED RECORD
560 Typedef_Node
:= P_Record_Definition
;
561 Set_Tagged_Present
(Typedef_Node
, True);
562 Set_Limited_Present
(Typedef_Node
, True);
565 Make_Identifier
(Token_Ptr
,
566 Chars
=> Chars
(Ident_Node
));
567 Set_Comes_From_Source
(End_Labl
, False);
569 Set_End_Label
(Typedef_Node
, End_Labl
);
575 if Token
= Tok_Private
then
577 New_Node
(N_Private_Type_Declaration
, Type_Loc
);
578 Set_Tagged_Present
(Decl_Node
, True);
579 Scan
; -- past PRIVATE
584 Typedef_Node
:= P_Record_Definition
;
585 Set_Tagged_Present
(Typedef_Node
, True);
588 Make_Identifier
(Token_Ptr
,
589 Chars
=> Chars
(Ident_Node
));
590 Set_Comes_From_Source
(End_Labl
, False);
592 Set_End_Label
(Typedef_Node
, End_Labl
);
600 Scan
; -- past LIMITED
603 if Token
= Tok_Tagged
then
604 Error_Msg_SC
("TAGGED must come before LIMITED");
607 elsif Token
= Tok_Abstract
then
608 Error_Msg_SC
("ABSTRACT must come before LIMITED");
609 Scan
; -- past ABSTRACT
616 -- LIMITED RECORD or LIMITED NULL RECORD
618 if Token
= Tok_Record
or else Token
= Tok_Null
then
619 if Ada_Version
= Ada_83
then
621 ("(Ada 83) limited record declaration not allowed!");
624 Typedef_Node
:= P_Record_Definition
;
625 Set_Limited_Present
(Typedef_Node
, True);
627 -- Ada 2005 (AI-251): LIMITED INTERFACE
629 -- If we are compiling in Ada 83 or Ada 95 mode, "interface"
630 -- is not a reserved word but we force its analysis to
631 -- generate the corresponding usage error.
633 elsif Token
= Tok_Interface
634 or else (Token
= Tok_Identifier
635 and then Chars
(Token_Node
) = Name_Interface
)
637 Typedef_Node
:= P_Interface_Type_Definition
639 Is_Synchronized
=> False);
640 Abstract_Present
:= True;
641 Set_Limited_Present
(Typedef_Node
);
643 if Nkind
(Typedef_Node
) = N_Derived_Type_Definition
then
644 Is_Derived_Iface
:= True;
647 -- Ada 2005 (AI-419): LIMITED NEW
649 elsif Token
= Tok_New
then
650 if Ada_Version
< Ada_05
then
652 ("LIMITED in derived type is an Ada 2005 extension");
654 ("\unit must be compiled with -gnat05 switch");
657 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
658 Set_Limited_Present
(Typedef_Node
);
660 if Nkind
(Typedef_Node
) = N_Derived_Type_Definition
661 and then Present
(Record_Extension_Part
(Typedef_Node
))
664 Make_Identifier
(Token_Ptr
,
665 Chars
=> Chars
(Ident_Node
));
666 Set_Comes_From_Source
(End_Labl
, False);
669 (Record_Extension_Part
(Typedef_Node
), End_Labl
);
672 -- LIMITED PRIVATE is the only remaining possibility here
675 Decl_Node
:= New_Node
(N_Private_Type_Declaration
, Type_Loc
);
676 Set_Limited_Present
(Decl_Node
, True);
677 T_Private
; -- past PRIVATE (or complain if not there!)
683 -- Here we have an identifier after the IS, which is certainly
684 -- wrong and which might be one of several different mistakes.
686 when Tok_Identifier
=>
688 -- First case, if identifier is on same line, then probably we
689 -- have something like "type X is Integer .." and the best
690 -- diagnosis is a missing NEW. Note: the missing new message
691 -- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl.
693 if not Token_Is_At_Start_Of_Line
then
694 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
697 -- If the identifier is at the start of the line, and is in the
698 -- same column as the type declaration itself then we consider
699 -- that we had a missing type definition on the previous line
701 elsif Start_Column
<= Type_Start_Col
then
702 Error_Msg_AP
("type definition expected");
703 Typedef_Node
:= Error
;
705 -- If the identifier is at the start of the line, and is in
706 -- a column to the right of the type declaration line, then we
707 -- may have something like:
712 -- and the best diagnosis is a missing record keyword
715 Typedef_Node
:= P_Record_Definition
;
721 -- Ada 2005 (AI-251): INTERFACE
723 when Tok_Interface
=>
724 Typedef_Node
:= P_Interface_Type_Definition
725 (Abstract_Present
, Is_Synchronized
=> False);
726 Abstract_Present
:= True;
731 Decl_Node
:= New_Node
(N_Private_Type_Declaration
, Type_Loc
);
732 Scan
; -- past PRIVATE
736 -- Ada 2005 (AI-345): Protected, synchronized or task interface
737 -- or Ada 2005 (AI-443): Synchronized private extension.
744 Saved_Token
: constant Token_Type
:= Token
;
747 Scan
; -- past TASK, PROTECTED or SYNCHRONIZED
749 -- Synchronized private extension
751 if Token
= Tok_New
then
752 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
754 if Saved_Token
= Tok_Synchronized
then
755 Set_Synchronized_Present
(Typedef_Node
);
757 Error_Msg_SC
("invalid kind of private extension");
764 P_Interface_Type_Definition
765 (Abstract_Present
, Is_Synchronized
=> True);
766 Abstract_Present
:= True;
770 Set_Task_Present
(Typedef_Node
);
772 when Tok_Protected
=>
773 Set_Protected_Present
(Typedef_Node
);
775 when Tok_Synchronized
=>
776 Set_Synchronized_Present
(Typedef_Node
);
779 pragma Assert
(False);
788 -- Anything else is an error
791 if Bad_Spelling_Of
(Tok_Access
)
793 Bad_Spelling_Of
(Tok_Array
)
795 Bad_Spelling_Of
(Tok_Delta
)
797 Bad_Spelling_Of
(Tok_Digits
)
799 Bad_Spelling_Of
(Tok_Limited
)
801 Bad_Spelling_Of
(Tok_Private
)
803 Bad_Spelling_Of
(Tok_Range
)
805 Bad_Spelling_Of
(Tok_Record
)
807 Bad_Spelling_Of
(Tok_Tagged
)
812 Error_Msg_AP
("type definition expected");
819 -- For the private type declaration case, the private type declaration
820 -- node has been built, with the Tagged_Present and Limited_Present
821 -- flags set as needed, and Typedef_Node is left set to Empty.
823 if No
(Typedef_Node
) then
824 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
825 Set_Abstract_Present
(Decl_Node
, Abstract_Present
);
827 -- For a private extension declaration, Typedef_Node contains the
828 -- N_Private_Extension_Declaration node, which we now complete. Note
829 -- that the private extension declaration, unlike a full type
830 -- declaration, does permit unknown discriminants.
832 elsif Nkind
(Typedef_Node
) = N_Private_Extension_Declaration
then
833 Decl_Node
:= Typedef_Node
;
834 Set_Sloc
(Decl_Node
, Type_Loc
);
835 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
836 Set_Abstract_Present
(Typedef_Node
, Abstract_Present
);
838 -- In the full type declaration case, Typedef_Node has the type
839 -- definition and here is where we build the full type declaration
840 -- node. This is also where we check for improper use of an unknown
841 -- discriminant part (not allowed for full type declaration).
844 if Nkind
(Typedef_Node
) = N_Record_Definition
845 or else (Nkind
(Typedef_Node
) = N_Derived_Type_Definition
846 and then Present
(Record_Extension_Part
(Typedef_Node
)))
847 or else Is_Derived_Iface
849 Set_Abstract_Present
(Typedef_Node
, Abstract_Present
);
851 elsif Abstract_Present
then
852 Error_Msg
("ABSTRACT not allowed here, ignored", Abstract_Loc
);
855 Decl_Node
:= New_Node
(N_Full_Type_Declaration
, Type_Loc
);
856 Set_Type_Definition
(Decl_Node
, Typedef_Node
);
860 ("Full type declaration cannot have unknown discriminants",
865 -- Remaining processing is common for all three cases
867 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
868 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
870 end P_Type_Declaration
;
872 ----------------------------------
873 -- 3.2.1 Full Type Declaration --
874 ----------------------------------
876 -- Parsed by P_Type_Declaration (3.2.1)
878 ----------------------------
879 -- 3.2.1 Type Definition --
880 ----------------------------
882 -- Parsed by P_Type_Declaration (3.2.1)
884 --------------------------------
885 -- 3.2.2 Subtype Declaration --
886 --------------------------------
888 -- SUBTYPE_DECLARATION ::=
889 -- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION;
891 -- The caller has checked that the initial token is SUBTYPE
893 -- Error recovery: can raise Error_Resync
895 function P_Subtype_Declaration
return Node_Id
is
897 Not_Null_Present
: Boolean := False;
900 Decl_Node
:= New_Node
(N_Subtype_Declaration
, Token_Ptr
);
901 Scan
; -- past SUBTYPE
902 Set_Defining_Identifier
(Decl_Node
, P_Defining_Identifier
(C_Is
));
905 if Token
= Tok_New
then
906 Error_Msg_SC
("NEW ignored (only allowed in type declaration)");
910 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
911 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
913 Set_Subtype_Indication
914 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
917 end P_Subtype_Declaration
;
919 -------------------------------
920 -- 3.2.2 Subtype Indication --
921 -------------------------------
923 -- SUBTYPE_INDICATION ::=
924 -- [not null] SUBTYPE_MARK [CONSTRAINT]
926 -- Error recovery: can raise Error_Resync
928 function P_Null_Exclusion
return Boolean is
930 if Token
/= Tok_Not
then
934 -- Ada 2005 (AI-441): The qualifier has no semantic meaning in Ada 95
935 -- (all access Parameters Are "not null" in Ada 95).
937 if Ada_Version
< Ada_05
then
939 ("null-excluding access is an Ada 2005 extension?");
940 Error_Msg_SP
("\unit should be compiled with -gnat05 switch?");
945 if Token
= Tok_Null
then
948 Error_Msg_SP
("NULL expected");
953 end P_Null_Exclusion
;
955 function P_Subtype_Indication
956 (Not_Null_Present
: Boolean := False) return Node_Id
is
960 if Token
= Tok_Identifier
or else Token
= Tok_Operator_Symbol
then
961 Type_Node
:= P_Subtype_Mark
;
962 return P_Subtype_Indication
(Type_Node
, Not_Null_Present
);
965 -- Check for error of using record definition and treat it nicely,
966 -- otherwise things are really messed up, so resynchronize.
968 if Token
= Tok_Record
then
969 Error_Msg_SC
("anonymous record definitions are not permitted");
970 Discard_Junk_Node
(P_Record_Definition
);
974 Error_Msg_AP
("subtype indication expected");
978 end P_Subtype_Indication
;
980 -- The following function is identical except that it is called with
981 -- the subtype mark already scanned out, and it scans out the constraint
983 -- Error recovery: can raise Error_Resync
985 function P_Subtype_Indication
986 (Subtype_Mark
: Node_Id
;
987 Not_Null_Present
: Boolean := False) return Node_Id
is
988 Indic_Node
: Node_Id
;
989 Constr_Node
: Node_Id
;
992 Constr_Node
:= P_Constraint_Opt
;
994 if No
(Constr_Node
) then
997 if Not_Null_Present
then
998 Error_Msg_SP
("constrained null-exclusion not allowed");
1001 Indic_Node
:= New_Node
(N_Subtype_Indication
, Sloc
(Subtype_Mark
));
1002 Set_Subtype_Mark
(Indic_Node
, Check_Subtype_Mark
(Subtype_Mark
));
1003 Set_Constraint
(Indic_Node
, Constr_Node
);
1006 end P_Subtype_Indication
;
1008 -------------------------
1009 -- 3.2.2 Subtype Mark --
1010 -------------------------
1012 -- SUBTYPE_MARK ::= subtype_NAME;
1014 -- Note: The subtype mark which appears after an IN or NOT IN
1015 -- operator is parsed by P_Range_Or_Subtype_Mark (3.5)
1017 -- Error recovery: cannot raise Error_Resync
1019 function P_Subtype_Mark
return Node_Id
is
1021 return P_Subtype_Mark_Resync
;
1024 when Error_Resync
=>
1028 -- This routine differs from P_Subtype_Mark in that it insists that an
1029 -- identifier be present, and if it is not, it raises Error_Resync.
1031 -- Error recovery: can raise Error_Resync
1033 function P_Subtype_Mark_Resync
return Node_Id
is
1034 Type_Node
: Node_Id
;
1037 if Token
= Tok_Access
then
1038 Error_Msg_SC
("anonymous access type definition not allowed here");
1039 Scan
; -- past ACCESS
1042 if Token
= Tok_Array
then
1043 Error_Msg_SC
("anonymous array definition not allowed here");
1044 Discard_Junk_Node
(P_Array_Type_Definition
);
1048 Type_Node
:= P_Qualified_Simple_Name_Resync
;
1050 -- Check for a subtype mark attribute. The only valid possibilities
1051 -- are 'CLASS and 'BASE. Anything else is a definite error. We may
1052 -- as well catch it here.
1054 if Token
= Tok_Apostrophe
then
1055 return P_Subtype_Mark_Attribute
(Type_Node
);
1060 end P_Subtype_Mark_Resync
;
1062 -- The following function is called to scan out a subtype mark attribute.
1063 -- The caller has already scanned out the subtype mark, which is passed in
1064 -- as the argument, and has checked that the current token is apostrophe.
1066 -- Only a special subclass of attributes, called type attributes
1067 -- (see Snames package) are allowed in this syntactic position.
1069 -- Note: if the apostrophe is followed by other than an identifier, then
1070 -- the input expression is returned unchanged, and the scan pointer is
1071 -- left pointing to the apostrophe.
1073 -- Error recovery: can raise Error_Resync
1075 function P_Subtype_Mark_Attribute
(Type_Node
: Node_Id
) return Node_Id
is
1076 Attr_Node
: Node_Id
:= Empty
;
1077 Scan_State
: Saved_Scan_State
;
1081 Prefix
:= Check_Subtype_Mark
(Type_Node
);
1083 if Prefix
= Error
then
1087 -- Loop through attributes appearing (more than one can appear as for
1088 -- for example in X'Base'Class). We are at an apostrophe on entry to
1089 -- this loop, and it runs once for each attribute parsed, with
1090 -- Prefix being the current possible prefix if it is an attribute.
1093 Save_Scan_State
(Scan_State
); -- at Apostrophe
1094 Scan
; -- past apostrophe
1096 if Token
/= Tok_Identifier
then
1097 Restore_Scan_State
(Scan_State
); -- to apostrophe
1098 return Prefix
; -- no attribute after all
1100 elsif not Is_Type_Attribute_Name
(Token_Name
) then
1102 ("attribute & may not be used in a subtype mark", Token_Node
);
1107 Make_Attribute_Reference
(Prev_Token_Ptr
,
1109 Attribute_Name
=> Token_Name
);
1110 Delete_Node
(Token_Node
);
1111 Scan
; -- past type attribute identifier
1114 exit when Token
/= Tok_Apostrophe
;
1115 Prefix
:= Attr_Node
;
1118 -- Fall through here after scanning type attribute
1121 end P_Subtype_Mark_Attribute
;
1123 -----------------------
1124 -- 3.2.2 Constraint --
1125 -----------------------
1127 -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
1129 -- SCALAR_CONSTRAINT ::=
1130 -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
1132 -- COMPOSITE_CONSTRAINT ::=
1133 -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
1135 -- If no constraint is present, this function returns Empty
1137 -- Error recovery: can raise Error_Resync
1139 function P_Constraint_Opt
return Node_Id
is
1141 if Token
= Tok_Range
1142 or else Bad_Spelling_Of
(Tok_Range
)
1144 return P_Range_Constraint
;
1146 elsif Token
= Tok_Digits
1147 or else Bad_Spelling_Of
(Tok_Digits
)
1149 return P_Digits_Constraint
;
1151 elsif Token
= Tok_Delta
1152 or else Bad_Spelling_Of
(Tok_Delta
)
1154 return P_Delta_Constraint
;
1156 elsif Token
= Tok_Left_Paren
then
1157 return P_Index_Or_Discriminant_Constraint
;
1159 elsif Token
= Tok_In
then
1161 return P_Constraint_Opt
;
1166 end P_Constraint_Opt
;
1168 ------------------------------
1169 -- 3.2.2 Scalar Constraint --
1170 ------------------------------
1172 -- Parsed by P_Constraint_Opt (3.2.2)
1174 ---------------------------------
1175 -- 3.2.2 Composite Constraint --
1176 ---------------------------------
1178 -- Parsed by P_Constraint_Opt (3.2.2)
1180 --------------------------------------------------------
1181 -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) --
1182 --------------------------------------------------------
1184 -- This routine scans out a declaration starting with an identifier:
1186 -- OBJECT_DECLARATION ::=
1187 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1188 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1189 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1190 -- ACCESS_DEFINITION [:= EXPRESSION];
1191 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1192 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1194 -- NUMBER_DECLARATION ::=
1195 -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
1197 -- OBJECT_RENAMING_DECLARATION ::=
1198 -- DEFINING_IDENTIFIER :
1199 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
1200 -- | DEFINING_IDENTIFIER :
1201 -- ACCESS_DEFINITION renames object_NAME;
1203 -- EXCEPTION_RENAMING_DECLARATION ::=
1204 -- DEFINING_IDENTIFIER : exception renames exception_NAME;
1206 -- EXCEPTION_DECLARATION ::=
1207 -- DEFINING_IDENTIFIER_LIST : exception;
1209 -- Note that the ALIASED indication in an object declaration is
1210 -- marked by a flag in the parent node.
1212 -- The caller has checked that the initial token is an identifier
1214 -- The value returned is a list of declarations, one for each identifier
1215 -- in the list (as described in Sinfo, we always split up multiple
1216 -- declarations into the equivalent sequence of single declarations
1217 -- using the More_Ids and Prev_Ids flags to preserve the source).
1219 -- If the identifier turns out to be a probable statement rather than
1220 -- an identifier, then the scan is left pointing to the identifier and
1221 -- No_List is returned.
1223 -- Error recovery: can raise Error_Resync
1225 procedure P_Identifier_Declarations
1231 Decl_Node
: Node_Id
;
1232 Type_Node
: Node_Id
;
1233 Ident_Sloc
: Source_Ptr
;
1234 Scan_State
: Saved_Scan_State
;
1235 List_OK
: Boolean := True;
1237 Init_Expr
: Node_Id
;
1238 Init_Loc
: Source_Ptr
;
1239 Con_Loc
: Source_Ptr
;
1240 Not_Null_Present
: Boolean := False;
1242 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
1243 -- Used to save identifiers in the identifier list. The upper bound
1244 -- of 4096 is expected to be infinite in practice, and we do not even
1245 -- bother to check if this upper bound is exceeded.
1247 Num_Idents
: Nat
:= 1;
1248 -- Number of identifiers stored in Idents
1251 -- This procedure is called in renames cases to make sure that we do
1252 -- not have more than one identifier. If we do have more than one
1253 -- then an error message is issued (and the declaration is split into
1254 -- multiple declarations)
1256 function Token_Is_Renames
return Boolean;
1257 -- Checks if current token is RENAMES, and if so, scans past it and
1258 -- returns True, otherwise returns False. Includes checking for some
1259 -- common error cases.
1261 procedure No_List
is
1263 if Num_Idents
> 1 then
1264 Error_Msg
("identifier list not allowed for RENAMES",
1271 function Token_Is_Renames
return Boolean is
1272 At_Colon
: Saved_Scan_State
;
1275 if Token
= Tok_Colon
then
1276 Save_Scan_State
(At_Colon
);
1278 Check_Misspelling_Of
(Tok_Renames
);
1280 if Token
= Tok_Renames
then
1281 Error_Msg_SP
("extra "":"" ignored");
1282 Scan
; -- past RENAMES
1285 Restore_Scan_State
(At_Colon
);
1290 Check_Misspelling_Of
(Tok_Renames
);
1292 if Token
= Tok_Renames
then
1293 Scan
; -- past RENAMES
1299 end Token_Is_Renames
;
1301 -- Start of processing for P_Identifier_Declarations
1304 Ident_Sloc
:= Token_Ptr
;
1305 Save_Scan_State
(Scan_State
); -- at first identifier
1306 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
1308 -- If we have a colon after the identifier, then we can assume that
1309 -- this is in fact a valid identifier declaration and can steam ahead.
1311 if Token
= Tok_Colon
then
1314 -- If we have a comma, then scan out the list of identifiers
1316 elsif Token
= Tok_Comma
then
1318 while Comma_Present
loop
1319 Num_Idents
:= Num_Idents
+ 1;
1320 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
1323 Save_Scan_State
(Scan_State
); -- at colon
1326 -- If we have identifier followed by := then we assume that what is
1327 -- really meant is an assignment statement. The assignment statement
1328 -- is scanned out and added to the list of declarations. An exception
1329 -- occurs if the := is followed by the keyword constant, in which case
1330 -- we assume it was meant to be a colon.
1332 elsif Token
= Tok_Colon_Equal
then
1335 if Token
= Tok_Constant
then
1336 Error_Msg_SP
("colon expected");
1339 Restore_Scan_State
(Scan_State
);
1340 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
1344 -- If we have an IS keyword, then assume the TYPE keyword was missing
1346 elsif Token
= Tok_Is
then
1347 Restore_Scan_State
(Scan_State
);
1348 Append_To
(Decls
, P_Type_Declaration
);
1352 -- Otherwise we have an error situation
1355 Restore_Scan_State
(Scan_State
);
1357 -- First case is possible misuse of PROTECTED in Ada 83 mode. If
1358 -- so, fix the keyword and return to scan the protected declaration.
1360 if Token_Name
= Name_Protected
then
1361 Check_95_Keyword
(Tok_Protected
, Tok_Identifier
);
1362 Check_95_Keyword
(Tok_Protected
, Tok_Type
);
1363 Check_95_Keyword
(Tok_Protected
, Tok_Body
);
1365 if Token
= Tok_Protected
then
1370 -- Check misspelling possibilities. If so, correct the misspelling
1371 -- and return to scan out the resulting declaration.
1373 elsif Bad_Spelling_Of
(Tok_Function
)
1374 or else Bad_Spelling_Of
(Tok_Procedure
)
1375 or else Bad_Spelling_Of
(Tok_Package
)
1376 or else Bad_Spelling_Of
(Tok_Pragma
)
1377 or else Bad_Spelling_Of
(Tok_Protected
)
1378 or else Bad_Spelling_Of
(Tok_Generic
)
1379 or else Bad_Spelling_Of
(Tok_Subtype
)
1380 or else Bad_Spelling_Of
(Tok_Type
)
1381 or else Bad_Spelling_Of
(Tok_Task
)
1382 or else Bad_Spelling_Of
(Tok_Use
)
1383 or else Bad_Spelling_Of
(Tok_For
)
1388 -- Otherwise we definitely have an ordinary identifier with a junk
1389 -- token after it. Just complain that we expect a declaration, and
1390 -- skip to a semicolon
1393 Set_Declaration_Expected
;
1394 Resync_Past_Semicolon
;
1400 -- Come here with an identifier list and colon scanned out. We now
1401 -- build the nodes for the declarative items. One node is built for
1402 -- each identifier in the list, with the type information being
1403 -- repeated by rescanning the appropriate section of source.
1405 -- First an error check, if we have two identifiers in a row, a likely
1406 -- possibility is that the first of the identifiers is an incorrectly
1409 if Token
= Tok_Identifier
then
1411 SS
: Saved_Scan_State
;
1415 Save_Scan_State
(SS
);
1416 Scan
; -- past initial identifier
1417 I2
:= (Token
= Tok_Identifier
);
1418 Restore_Scan_State
(SS
);
1422 (Bad_Spelling_Of
(Tok_Access
) or else
1423 Bad_Spelling_Of
(Tok_Aliased
) or else
1424 Bad_Spelling_Of
(Tok_Constant
))
1431 -- Loop through identifiers
1436 -- Check for some cases of misused Ada 95 keywords
1438 if Token_Name
= Name_Aliased
then
1439 Check_95_Keyword
(Tok_Aliased
, Tok_Array
);
1440 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
1441 Check_95_Keyword
(Tok_Aliased
, Tok_Constant
);
1446 if Token
= Tok_Constant
then
1447 Con_Loc
:= Token_Ptr
;
1448 Scan
; -- past CONSTANT
1450 -- Number declaration, initialization required
1452 Init_Expr
:= Init_Expr_Opt
;
1454 if Present
(Init_Expr
) then
1455 if Not_Null_Present
then
1456 Error_Msg_SP
("null-exclusion not allowed in "
1457 & "numeric expression");
1460 Decl_Node
:= New_Node
(N_Number_Declaration
, Ident_Sloc
);
1461 Set_Expression
(Decl_Node
, Init_Expr
);
1463 -- Constant object declaration
1466 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1467 Set_Constant_Present
(Decl_Node
, True);
1469 if Token_Name
= Name_Aliased
then
1470 Check_95_Keyword
(Tok_Aliased
, Tok_Array
);
1471 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
1474 if Token
= Tok_Aliased
then
1475 Error_Msg_SC
("ALIASED should be before CONSTANT");
1476 Scan
; -- past ALIASED
1477 Set_Aliased_Present
(Decl_Node
, True);
1480 if Token
= Tok_Array
then
1481 Set_Object_Definition
1482 (Decl_Node
, P_Array_Type_Definition
);
1485 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1486 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1488 if Token
= Tok_Access
then
1489 if Ada_Version
< Ada_05
then
1491 ("generalized use of anonymous access types " &
1492 "is an Ada 2005 extension");
1494 ("\unit must be compiled with -gnat05 switch");
1497 Set_Object_Definition
1498 (Decl_Node
, P_Access_Definition
(Not_Null_Present
));
1500 Set_Object_Definition
1501 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
1505 if Token
= Tok_Renames
then
1507 ("CONSTANT not permitted in renaming declaration",
1509 Scan
; -- Past renames
1510 Discard_Junk_Node
(P_Name
);
1516 elsif Token
= Tok_Exception
then
1517 Scan
; -- past EXCEPTION
1519 if Token_Is_Renames
then
1522 New_Node
(N_Exception_Renaming_Declaration
, Ident_Sloc
);
1523 Set_Name
(Decl_Node
, P_Qualified_Simple_Name_Resync
);
1526 Decl_Node
:= New_Node
(N_Exception_Declaration
, Prev_Token_Ptr
);
1529 -- Aliased case (note that an object definition is required)
1531 elsif Token
= Tok_Aliased
then
1532 Scan
; -- past ALIASED
1533 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1534 Set_Aliased_Present
(Decl_Node
, True);
1536 if Token
= Tok_Constant
then
1537 Scan
; -- past CONSTANT
1538 Set_Constant_Present
(Decl_Node
, True);
1541 if Token
= Tok_Array
then
1542 Set_Object_Definition
1543 (Decl_Node
, P_Array_Type_Definition
);
1546 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1547 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1549 -- Access definition (AI-406) or subtype indication
1551 if Token
= Tok_Access
then
1552 if Ada_Version
< Ada_05
then
1554 ("generalized use of anonymous access types " &
1555 "is an Ada 2005 extension");
1557 ("\unit must be compiled with -gnat05 switch");
1560 Set_Object_Definition
1561 (Decl_Node
, P_Access_Definition
(Not_Null_Present
));
1563 Set_Object_Definition
1564 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
1570 elsif Token
= Tok_Array
then
1571 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1572 Set_Object_Definition
(Decl_Node
, P_Array_Type_Definition
);
1574 -- Ada 2005 (AI-254, AI-406)
1576 elsif Token
= Tok_Not
then
1578 -- OBJECT_DECLARATION ::=
1579 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1580 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1581 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1582 -- ACCESS_DEFINITION [:= EXPRESSION];
1584 -- OBJECT_RENAMING_DECLARATION ::=
1585 -- DEFINING_IDENTIFIER :
1586 -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME;
1587 -- | DEFINING_IDENTIFIER :
1588 -- ACCESS_DEFINITION renames object_NAME;
1590 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/423)
1592 if Token
= Tok_Access
then
1593 if Ada_Version
< Ada_05
then
1595 ("generalized use of anonymous access types " &
1596 "is an Ada 2005 extension");
1597 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1600 Acc_Node
:= P_Access_Definition
(Not_Null_Present
);
1602 if Token
/= Tok_Renames
then
1603 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1604 Set_Object_Definition
(Decl_Node
, Acc_Node
);
1608 Scan
; -- past renames
1611 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1612 Set_Access_Definition
(Decl_Node
, Acc_Node
);
1613 Set_Name
(Decl_Node
, P_Name
);
1617 Type_Node
:= P_Subtype_Mark
;
1619 -- Object renaming declaration
1621 if Token_Is_Renames
then
1622 if Ada_Version
< Ada_05
then
1624 ("null-exclusion not allowed in object renaming");
1627 -- Ada 2005 (AI-423): Object renaming declaration with
1628 -- a null exclusion.
1633 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1634 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1635 Set_Subtype_Mark
(Decl_Node
, Type_Node
);
1636 Set_Name
(Decl_Node
, P_Name
);
1639 -- Object declaration
1642 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1643 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1644 Set_Object_Definition
1646 P_Subtype_Indication
(Type_Node
, Not_Null_Present
));
1648 -- RENAMES at this point means that we had the combination
1649 -- of a constraint on the Type_Node and renames, which is
1652 if Token_Is_Renames
then
1653 Error_Msg_N
("constraint not allowed in object renaming "
1655 Constraint
(Object_Definition
(Decl_Node
)));
1661 -- Ada 2005 (AI-230): Access Definition case
1663 elsif Token
= Tok_Access
then
1664 if Ada_Version
< Ada_05
then
1666 ("generalized use of anonymous access types " &
1667 "is an Ada 2005 extension");
1668 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1671 Acc_Node
:= P_Access_Definition
(Null_Exclusion_Present
=> False);
1673 -- Object declaration with access definition, or renaming
1675 if Token
/= Tok_Renames
then
1676 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1677 Set_Object_Definition
(Decl_Node
, Acc_Node
);
1678 goto init
; -- ??? is this really needed goes here anyway
1681 Scan
; -- past renames
1684 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1685 Set_Access_Definition
(Decl_Node
, Acc_Node
);
1686 Set_Name
(Decl_Node
, P_Name
);
1689 -- Subtype indication case
1692 Type_Node
:= P_Subtype_Mark
;
1694 -- Object renaming declaration
1696 if Token_Is_Renames
then
1699 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1700 Set_Subtype_Mark
(Decl_Node
, Type_Node
);
1701 Set_Name
(Decl_Node
, P_Name
);
1703 -- Object declaration
1706 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1707 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1708 Set_Object_Definition
1710 P_Subtype_Indication
(Type_Node
, Not_Null_Present
));
1712 -- RENAMES at this point means that we had the combination of
1713 -- a constraint on the Type_Node and renames, which is illegal
1715 if Token_Is_Renames
then
1717 ("constraint not allowed in object renaming declaration",
1718 Constraint
(Object_Definition
(Decl_Node
)));
1724 -- Scan out initialization, allowed only for object declaration
1726 <<init
>> -- is this really needed ???
1727 Init_Loc
:= Token_Ptr
;
1728 Init_Expr
:= Init_Expr_Opt
;
1730 if Present
(Init_Expr
) then
1731 if Nkind
(Decl_Node
) = N_Object_Declaration
then
1732 Set_Expression
(Decl_Node
, Init_Expr
);
1734 Error_Msg
("initialization not allowed here", Init_Loc
);
1739 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
1742 if Ident
< Num_Idents
then
1743 Set_More_Ids
(Decl_Node
, True);
1747 Set_Prev_Ids
(Decl_Node
, True);
1751 Append
(Decl_Node
, Decls
);
1752 exit Ident_Loop
when Ident
= Num_Idents
;
1753 Restore_Scan_State
(Scan_State
);
1756 end loop Ident_Loop
;
1759 end P_Identifier_Declarations
;
1761 -------------------------------
1762 -- 3.3.1 Object Declaration --
1763 -------------------------------
1765 -- OBJECT DECLARATION ::=
1766 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1767 -- SUBTYPE_INDICATION [:= EXPRESSION];
1768 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1769 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1770 -- | SINGLE_TASK_DECLARATION
1771 -- | SINGLE_PROTECTED_DECLARATION
1773 -- Cases starting with TASK are parsed by P_Task (9.1)
1774 -- Cases starting with PROTECTED are parsed by P_Protected (9.4)
1775 -- All other cases are parsed by P_Identifier_Declarations (3.3)
1777 -------------------------------------
1778 -- 3.3.1 Defining Identifier List --
1779 -------------------------------------
1781 -- DEFINING_IDENTIFIER_LIST ::=
1782 -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
1784 -- Always parsed by the construct in which it appears. See special
1785 -- section on "Handling of Defining Identifier Lists" in this unit.
1787 -------------------------------
1788 -- 3.3.2 Number Declaration --
1789 -------------------------------
1791 -- Parsed by P_Identifier_Declarations (3.3)
1793 -------------------------------------------------------------------------
1794 -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) --
1795 -------------------------------------------------------------------------
1797 -- DERIVED_TYPE_DEFINITION ::=
1798 -- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
1799 -- [[and INTERFACE_LIST] RECORD_EXTENSION_PART]
1801 -- PRIVATE_EXTENSION_DECLARATION ::=
1802 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
1803 -- [abstract] [limited | synchronized]
1804 -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST]
1807 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
1809 -- The caller has already scanned out the part up to the NEW, and Token
1810 -- either contains Tok_New (or ought to, if it doesn't this procedure
1811 -- will post an appropriate "NEW expected" message).
1813 -- Note: the caller is responsible for filling in the Sloc field of
1814 -- the returned node in the private extension declaration case as
1815 -- well as the stuff relating to the discriminant part.
1817 -- Error recovery: can raise Error_Resync;
1819 function P_Derived_Type_Def_Or_Private_Ext_Decl
return Node_Id
is
1820 Typedef_Node
: Node_Id
;
1821 Typedecl_Node
: Node_Id
;
1822 Not_Null_Present
: Boolean := False;
1825 Typedef_Node
:= New_Node
(N_Derived_Type_Definition
, Token_Ptr
);
1827 if Ada_Version
< Ada_05
1828 and then Token
= Tok_Identifier
1829 and then Token_Name
= Name_Interface
1832 ("abstract interface is an Ada 2005 extension");
1833 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1838 if Token
= Tok_Abstract
then
1839 Error_Msg_SC
("ABSTRACT must come before NEW, not after");
1843 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1844 Set_Null_Exclusion_Present
(Typedef_Node
, Not_Null_Present
);
1845 Set_Subtype_Indication
(Typedef_Node
,
1846 P_Subtype_Indication
(Not_Null_Present
));
1848 -- Ada 2005 (AI-251): Deal with interfaces
1850 if Token
= Tok_And
then
1853 if Ada_Version
< Ada_05
then
1855 ("abstract interface is an Ada 2005 extension");
1856 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1859 Set_Interface_List
(Typedef_Node
, New_List
);
1862 Append
(P_Qualified_Simple_Name
, Interface_List
(Typedef_Node
));
1863 exit when Token
/= Tok_And
;
1867 if Token
/= Tok_With
then
1868 Error_Msg_SC
("WITH expected");
1873 -- Deal with record extension, note that we assume that a WITH is
1874 -- missing in the case of "type X is new Y record ..." or in the
1875 -- case of "type X is new Y null record".
1878 or else Token
= Tok_Record
1879 or else Token
= Tok_Null
1881 T_With
; -- past WITH or give error message
1883 if Token
= Tok_Limited
then
1885 ("LIMITED keyword not allowed in private extension");
1886 Scan
; -- ignore LIMITED
1889 -- Private extension declaration
1891 if Token
= Tok_Private
then
1892 Scan
; -- past PRIVATE
1894 -- Throw away the type definition node and build the type
1895 -- declaration node. Note the caller must set the Sloc,
1896 -- Discriminant_Specifications, Unknown_Discriminants_Present,
1897 -- and Defined_Identifier fields in the returned node.
1900 Make_Private_Extension_Declaration
(No_Location
,
1901 Defining_Identifier
=> Empty
,
1902 Subtype_Indication
=> Subtype_Indication
(Typedef_Node
),
1903 Abstract_Present
=> Abstract_Present
(Typedef_Node
),
1904 Interface_List
=> Interface_List
(Typedef_Node
));
1906 Delete_Node
(Typedef_Node
);
1907 return Typedecl_Node
;
1909 -- Derived type definition with record extension part
1912 Set_Record_Extension_Part
(Typedef_Node
, P_Record_Definition
);
1913 return Typedef_Node
;
1916 -- Derived type definition with no record extension part
1919 return Typedef_Node
;
1921 end P_Derived_Type_Def_Or_Private_Ext_Decl
;
1923 ---------------------------
1924 -- 3.5 Range Constraint --
1925 ---------------------------
1927 -- RANGE_CONSTRAINT ::= range RANGE
1929 -- The caller has checked that the initial token is RANGE
1931 -- Error recovery: cannot raise Error_Resync
1933 function P_Range_Constraint
return Node_Id
is
1934 Range_Node
: Node_Id
;
1937 Range_Node
:= New_Node
(N_Range_Constraint
, Token_Ptr
);
1939 Set_Range_Expression
(Range_Node
, P_Range
);
1941 end P_Range_Constraint
;
1948 -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
1950 -- Note: the range that appears in a membership test is parsed by
1951 -- P_Range_Or_Subtype_Mark (3.5).
1953 -- Error recovery: cannot raise Error_Resync
1955 function P_Range
return Node_Id
is
1956 Expr_Node
: Node_Id
;
1957 Range_Node
: Node_Id
;
1960 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
1962 if Expr_Form
= EF_Range_Attr
then
1965 elsif Token
= Tok_Dot_Dot
then
1966 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
1967 Set_Low_Bound
(Range_Node
, Expr_Node
);
1969 Expr_Node
:= P_Expression
;
1970 Check_Simple_Expression
(Expr_Node
);
1971 Set_High_Bound
(Range_Node
, Expr_Node
);
1974 -- Anything else is an error
1977 T_Dot_Dot
; -- force missing .. message
1982 ----------------------------------
1983 -- 3.5 P_Range_Or_Subtype_Mark --
1984 ----------------------------------
1987 -- RANGE_ATTRIBUTE_REFERENCE
1988 -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
1990 -- This routine scans out the range or subtype mark that forms the right
1991 -- operand of a membership test (it is not used in any other contexts, and
1992 -- error messages are specialized with this knowledge in mind).
1994 -- Note: as documented in the Sinfo interface, although the syntax only
1995 -- allows a subtype mark, we in fact allow any simple expression to be
1996 -- returned from this routine. The semantics is responsible for issuing
1997 -- an appropriate message complaining if the argument is not a name.
1998 -- This simplifies the coding and error recovery processing in the
1999 -- parser, and in any case it is preferable not to consider this a
2000 -- syntax error and to continue with the semantic analysis.
2002 -- Error recovery: cannot raise Error_Resync
2004 function P_Range_Or_Subtype_Mark
return Node_Id
is
2005 Expr_Node
: Node_Id
;
2006 Range_Node
: Node_Id
;
2007 Save_Loc
: Source_Ptr
;
2009 -- Start of processing for P_Range_Or_Subtype_Mark
2012 -- Save location of possible junk parentheses
2014 Save_Loc
:= Token_Ptr
;
2016 -- Scan out either a simple expression or a range (this accepts more
2017 -- than is legal here, but as explained above, we like to allow more
2018 -- with a proper diagnostic.
2020 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2024 if Expr_Form
= EF_Range_Attr
then
2027 -- Simple_Expression .. Simple_Expression
2029 elsif Token
= Tok_Dot_Dot
then
2030 Check_Simple_Expression
(Expr_Node
);
2031 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2032 Set_Low_Bound
(Range_Node
, Expr_Node
);
2034 Set_High_Bound
(Range_Node
, P_Simple_Expression
);
2037 -- Case of subtype mark (optionally qualified simple name or an
2038 -- attribute whose prefix is an optionally qualifed simple name)
2040 elsif Expr_Form
= EF_Simple_Name
2041 or else Nkind
(Expr_Node
) = N_Attribute_Reference
2043 -- Check for error of range constraint after a subtype mark
2045 if Token
= Tok_Range
then
2046 Error_Msg_SC
("range constraint not allowed in membership test");
2050 -- Check for error of DIGITS or DELTA after a subtype mark
2052 elsif Token
= Tok_Digits
or else Token
= Tok_Delta
then
2054 ("accuracy definition not allowed in membership test");
2055 Scan
; -- past DIGITS or DELTA
2058 -- Attribute reference, may or may not be OK, but in any case we
2061 elsif Token
= Tok_Apostrophe
then
2062 return P_Subtype_Mark_Attribute
(Expr_Node
);
2064 -- OK case of simple name, just return it
2070 -- Here we have some kind of error situation. Check for junk parens
2071 -- then return what we have, caller will deal with other errors.
2074 if Nkind
(Expr_Node
) in N_Subexpr
2075 and then Paren_Count
(Expr_Node
) /= 0
2077 Error_Msg
("|parentheses not allowed for subtype mark", Save_Loc
);
2078 Set_Paren_Count
(Expr_Node
, 0);
2083 end P_Range_Or_Subtype_Mark
;
2085 ----------------------------------------
2086 -- 3.5.1 Enumeration Type Definition --
2087 ----------------------------------------
2089 -- ENUMERATION_TYPE_DEFINITION ::=
2090 -- (ENUMERATION_LITERAL_SPECIFICATION
2091 -- {, ENUMERATION_LITERAL_SPECIFICATION})
2093 -- The caller has already scanned out the TYPE keyword
2095 -- Error recovery: can raise Error_Resync;
2097 function P_Enumeration_Type_Definition
return Node_Id
is
2098 Typedef_Node
: Node_Id
;
2101 Typedef_Node
:= New_Node
(N_Enumeration_Type_Definition
, Token_Ptr
);
2102 Set_Literals
(Typedef_Node
, New_List
);
2107 Append
(P_Enumeration_Literal_Specification
, Literals
(Typedef_Node
));
2108 exit when not Comma_Present
;
2112 return Typedef_Node
;
2113 end P_Enumeration_Type_Definition
;
2115 ----------------------------------------------
2116 -- 3.5.1 Enumeration Literal Specification --
2117 ----------------------------------------------
2119 -- ENUMERATION_LITERAL_SPECIFICATION ::=
2120 -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
2122 -- Error recovery: can raise Error_Resync
2124 function P_Enumeration_Literal_Specification
return Node_Id
is
2126 if Token
= Tok_Char_Literal
then
2127 return P_Defining_Character_Literal
;
2129 return P_Defining_Identifier
(C_Comma_Right_Paren
);
2131 end P_Enumeration_Literal_Specification
;
2133 ---------------------------------------
2134 -- 3.5.1 Defining_Character_Literal --
2135 ---------------------------------------
2137 -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
2139 -- Error recovery: cannot raise Error_Resync
2141 -- The caller has checked that the current token is a character literal
2143 function P_Defining_Character_Literal
return Node_Id
is
2144 Literal_Node
: Node_Id
;
2147 Literal_Node
:= Token_Node
;
2148 Change_Character_Literal_To_Defining_Character_Literal
(Literal_Node
);
2149 Scan
; -- past character literal
2150 return Literal_Node
;
2151 end P_Defining_Character_Literal
;
2153 ------------------------------------
2154 -- 3.5.4 Integer Type Definition --
2155 ------------------------------------
2157 -- Parsed by P_Type_Declaration (3.2.1)
2159 -------------------------------------------
2160 -- 3.5.4 Signed Integer Type Definition --
2161 -------------------------------------------
2163 -- SIGNED_INTEGER_TYPE_DEFINITION ::=
2164 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2166 -- Normally the initial token on entry is RANGE, but in some
2167 -- error conditions, the range token was missing and control is
2168 -- passed with Token pointing to first token of the first expression.
2170 -- Error recovery: cannot raise Error_Resync
2172 function P_Signed_Integer_Type_Definition
return Node_Id
is
2173 Typedef_Node
: Node_Id
;
2174 Expr_Node
: Node_Id
;
2177 Typedef_Node
:= New_Node
(N_Signed_Integer_Type_Definition
, Token_Ptr
);
2179 if Token
= Tok_Range
then
2183 Expr_Node
:= P_Expression
;
2184 Check_Simple_Expression
(Expr_Node
);
2185 Set_Low_Bound
(Typedef_Node
, Expr_Node
);
2187 Expr_Node
:= P_Expression
;
2188 Check_Simple_Expression
(Expr_Node
);
2189 Set_High_Bound
(Typedef_Node
, Expr_Node
);
2190 return Typedef_Node
;
2191 end P_Signed_Integer_Type_Definition
;
2193 ------------------------------------
2194 -- 3.5.4 Modular Type Definition --
2195 ------------------------------------
2197 -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
2199 -- The caller has checked that the initial token is MOD
2201 -- Error recovery: cannot raise Error_Resync
2203 function P_Modular_Type_Definition
return Node_Id
is
2204 Typedef_Node
: Node_Id
;
2207 if Ada_Version
= Ada_83
then
2208 Error_Msg_SC
("(Ada 83): modular types not allowed");
2211 Typedef_Node
:= New_Node
(N_Modular_Type_Definition
, Token_Ptr
);
2213 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
2215 -- Handle mod L..R cleanly
2217 if Token
= Tok_Dot_Dot
then
2218 Error_Msg_SC
("range not allowed for modular type");
2220 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
2223 return Typedef_Node
;
2224 end P_Modular_Type_Definition
;
2226 ---------------------------------
2227 -- 3.5.6 Real Type Definition --
2228 ---------------------------------
2230 -- Parsed by P_Type_Declaration (3.2.1)
2232 --------------------------------------
2233 -- 3.5.7 Floating Point Definition --
2234 --------------------------------------
2236 -- FLOATING_POINT_DEFINITION ::=
2237 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2239 -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
2241 -- The caller has checked that the initial token is DIGITS
2243 -- Error recovery: cannot raise Error_Resync
2245 function P_Floating_Point_Definition
return Node_Id
is
2246 Digits_Loc
: constant Source_Ptr
:= Token_Ptr
;
2248 Expr_Node
: Node_Id
;
2251 Scan
; -- past DIGITS
2252 Expr_Node
:= P_Expression_No_Right_Paren
;
2253 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2255 -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
2257 if Token
= Tok_Delta
then
2258 Error_Msg_SC
("DELTA must come before DIGITS");
2259 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Digits_Loc
);
2261 Set_Delta_Expression
(Def_Node
, P_Expression_No_Right_Paren
);
2263 -- OK floating-point definition
2266 Def_Node
:= New_Node
(N_Floating_Point_Definition
, Digits_Loc
);
2269 Set_Digits_Expression
(Def_Node
, Expr_Node
);
2270 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
2272 end P_Floating_Point_Definition
;
2274 -------------------------------------
2275 -- 3.5.7 Real Range Specification --
2276 -------------------------------------
2278 -- REAL_RANGE_SPECIFICATION ::=
2279 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2281 -- Error recovery: cannot raise Error_Resync
2283 function P_Real_Range_Specification_Opt
return Node_Id
is
2284 Specification_Node
: Node_Id
;
2285 Expr_Node
: Node_Id
;
2288 if Token
= Tok_Range
then
2289 Specification_Node
:=
2290 New_Node
(N_Real_Range_Specification
, Token_Ptr
);
2292 Expr_Node
:= P_Expression_No_Right_Paren
;
2293 Check_Simple_Expression
(Expr_Node
);
2294 Set_Low_Bound
(Specification_Node
, Expr_Node
);
2296 Expr_Node
:= P_Expression_No_Right_Paren
;
2297 Check_Simple_Expression
(Expr_Node
);
2298 Set_High_Bound
(Specification_Node
, Expr_Node
);
2299 return Specification_Node
;
2303 end P_Real_Range_Specification_Opt
;
2305 -----------------------------------
2306 -- 3.5.9 Fixed Point Definition --
2307 -----------------------------------
2309 -- FIXED_POINT_DEFINITION ::=
2310 -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
2312 -- ORDINARY_FIXED_POINT_DEFINITION ::=
2313 -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION
2315 -- DECIMAL_FIXED_POINT_DEFINITION ::=
2316 -- delta static_EXPRESSION
2317 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2319 -- The caller has checked that the initial token is DELTA
2321 -- Error recovery: cannot raise Error_Resync
2323 function P_Fixed_Point_Definition
return Node_Id
is
2324 Delta_Node
: Node_Id
;
2325 Delta_Loc
: Source_Ptr
;
2327 Expr_Node
: Node_Id
;
2330 Delta_Loc
:= Token_Ptr
;
2332 Delta_Node
:= P_Expression_No_Right_Paren
;
2333 Check_Simple_Expression_In_Ada_83
(Delta_Node
);
2335 if Token
= Tok_Digits
then
2336 if Ada_Version
= Ada_83
then
2337 Error_Msg_SC
("(Ada 83) decimal fixed type not allowed!");
2340 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Delta_Loc
);
2341 Scan
; -- past DIGITS
2342 Expr_Node
:= P_Expression_No_Right_Paren
;
2343 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2344 Set_Digits_Expression
(Def_Node
, Expr_Node
);
2347 Def_Node
:= New_Node
(N_Ordinary_Fixed_Point_Definition
, Delta_Loc
);
2349 -- Range is required in ordinary fixed point case
2351 if Token
/= Tok_Range
then
2352 Error_Msg_AP
("range must be given for fixed-point type");
2357 Set_Delta_Expression
(Def_Node
, Delta_Node
);
2358 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
2360 end P_Fixed_Point_Definition
;
2362 --------------------------------------------
2363 -- 3.5.9 Ordinary Fixed Point Definition --
2364 --------------------------------------------
2366 -- Parsed by P_Fixed_Point_Definition (3.5.9)
2368 -------------------------------------------
2369 -- 3.5.9 Decimal Fixed Point Definition --
2370 -------------------------------------------
2372 -- Parsed by P_Decimal_Point_Definition (3.5.9)
2374 ------------------------------
2375 -- 3.5.9 Digits Constraint --
2376 ------------------------------
2378 -- DIGITS_CONSTRAINT ::=
2379 -- digits static_EXPRESSION [RANGE_CONSTRAINT]
2381 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2383 -- The caller has checked that the initial token is DIGITS
2385 function P_Digits_Constraint
return Node_Id
is
2386 Constraint_Node
: Node_Id
;
2387 Expr_Node
: Node_Id
;
2390 Constraint_Node
:= New_Node
(N_Digits_Constraint
, Token_Ptr
);
2391 Scan
; -- past DIGITS
2392 Expr_Node
:= P_Expression_No_Right_Paren
;
2393 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2394 Set_Digits_Expression
(Constraint_Node
, Expr_Node
);
2396 if Token
= Tok_Range
then
2397 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
2400 return Constraint_Node
;
2401 end P_Digits_Constraint
;
2403 -----------------------------
2404 -- 3.5.9 Delta Constraint --
2405 -----------------------------
2407 -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
2409 -- Note: this is an obsolescent feature in Ada 95 (I.3)
2411 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2413 -- The caller has checked that the initial token is DELTA
2415 -- Error recovery: cannot raise Error_Resync
2417 function P_Delta_Constraint
return Node_Id
is
2418 Constraint_Node
: Node_Id
;
2419 Expr_Node
: Node_Id
;
2422 Constraint_Node
:= New_Node
(N_Delta_Constraint
, Token_Ptr
);
2424 Expr_Node
:= P_Expression_No_Right_Paren
;
2425 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2426 Set_Delta_Expression
(Constraint_Node
, Expr_Node
);
2428 if Token
= Tok_Range
then
2429 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
2432 return Constraint_Node
;
2433 end P_Delta_Constraint
;
2435 --------------------------------
2436 -- 3.6 Array Type Definition --
2437 --------------------------------
2439 -- ARRAY_TYPE_DEFINITION ::=
2440 -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
2442 -- UNCONSTRAINED_ARRAY_DEFINITION ::=
2443 -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
2444 -- COMPONENT_DEFINITION
2446 -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
2448 -- CONSTRAINED_ARRAY_DEFINITION ::=
2449 -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
2450 -- COMPONENT_DEFINITION
2452 -- DISCRETE_SUBTYPE_DEFINITION ::=
2453 -- DISCRETE_SUBTYPE_INDICATION | RANGE
2455 -- COMPONENT_DEFINITION ::=
2456 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
2458 -- The caller has checked that the initial token is ARRAY
2460 -- Error recovery: can raise Error_Resync
2462 function P_Array_Type_Definition
return Node_Id
is
2463 Array_Loc
: Source_Ptr
;
2464 CompDef_Node
: Node_Id
;
2466 Not_Null_Present
: Boolean := False;
2467 Subs_List
: List_Id
;
2468 Scan_State
: Saved_Scan_State
;
2469 Aliased_Present
: Boolean := False;
2472 Array_Loc
:= Token_Ptr
;
2474 Subs_List
:= New_List
;
2477 -- It's quite tricky to disentangle these two possibilities, so we do
2478 -- a prescan to determine which case we have and then reset the scan.
2479 -- The prescan skips past possible subtype mark tokens.
2481 Save_Scan_State
(Scan_State
); -- just after paren
2483 while Token
in Token_Class_Desig
or else
2484 Token
= Tok_Dot
or else
2485 Token
= Tok_Apostrophe
-- because of 'BASE, 'CLASS
2490 -- If we end up on RANGE <> then we have the unconstrained case. We
2491 -- will also allow the RANGE to be omitted, just to improve error
2492 -- handling for a case like array (integer <>) of integer;
2494 Scan
; -- past possible RANGE or <>
2496 if (Prev_Token
= Tok_Range
and then Token
= Tok_Box
) or else
2497 Prev_Token
= Tok_Box
2499 Def_Node
:= New_Node
(N_Unconstrained_Array_Definition
, Array_Loc
);
2500 Restore_Scan_State
(Scan_State
); -- to first subtype mark
2503 Append
(P_Subtype_Mark_Resync
, Subs_List
);
2506 exit when Token
= Tok_Right_Paren
or else Token
= Tok_Of
;
2510 Set_Subtype_Marks
(Def_Node
, Subs_List
);
2513 Def_Node
:= New_Node
(N_Constrained_Array_Definition
, Array_Loc
);
2514 Restore_Scan_State
(Scan_State
); -- to first discrete range
2517 Append
(P_Discrete_Subtype_Definition
, Subs_List
);
2518 exit when not Comma_Present
;
2521 Set_Discrete_Subtype_Definitions
(Def_Node
, Subs_List
);
2527 CompDef_Node
:= New_Node
(N_Component_Definition
, Token_Ptr
);
2529 if Token_Name
= Name_Aliased
then
2530 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
2533 if Token
= Tok_Aliased
then
2534 Aliased_Present
:= True;
2535 Scan
; -- past ALIASED
2538 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/AI-254)
2540 -- Ada 2005 (AI-230): Access Definition case
2542 if Token
= Tok_Access
then
2543 if Ada_Version
< Ada_05
then
2545 ("generalized use of anonymous access types " &
2546 "is an Ada 2005 extension");
2547 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
2550 if Aliased_Present
then
2551 Error_Msg_SP
("ALIASED not allowed here");
2554 Set_Subtype_Indication
(CompDef_Node
, Empty
);
2555 Set_Aliased_Present
(CompDef_Node
, False);
2556 Set_Access_Definition
(CompDef_Node
,
2557 P_Access_Definition
(Not_Null_Present
));
2560 Set_Access_Definition
(CompDef_Node
, Empty
);
2561 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
2562 Set_Null_Exclusion_Present
(CompDef_Node
, Not_Null_Present
);
2563 Set_Subtype_Indication
(CompDef_Node
,
2564 P_Subtype_Indication
(Not_Null_Present
));
2567 Set_Component_Definition
(Def_Node
, CompDef_Node
);
2570 end P_Array_Type_Definition
;
2572 -----------------------------------------
2573 -- 3.6 Unconstrained Array Definition --
2574 -----------------------------------------
2576 -- Parsed by P_Array_Type_Definition (3.6)
2578 ---------------------------------------
2579 -- 3.6 Constrained Array Definition --
2580 ---------------------------------------
2582 -- Parsed by P_Array_Type_Definition (3.6)
2584 --------------------------------------
2585 -- 3.6 Discrete Subtype Definition --
2586 --------------------------------------
2588 -- DISCRETE_SUBTYPE_DEFINITION ::=
2589 -- discrete_SUBTYPE_INDICATION | RANGE
2591 -- Note: the discrete subtype definition appearing in a constrained
2592 -- array definition is parsed by P_Array_Type_Definition (3.6)
2594 -- Error recovery: cannot raise Error_Resync
2596 function P_Discrete_Subtype_Definition
return Node_Id
is
2598 -- The syntax of a discrete subtype definition is identical to that
2599 -- of a discrete range, so we simply share the same parsing code.
2601 return P_Discrete_Range
;
2602 end P_Discrete_Subtype_Definition
;
2604 -------------------------------
2605 -- 3.6 Component Definition --
2606 -------------------------------
2608 -- For the array case, parsed by P_Array_Type_Definition (3.6)
2609 -- For the record case, parsed by P_Component_Declaration (3.8)
2611 -----------------------------
2612 -- 3.6.1 Index Constraint --
2613 -----------------------------
2615 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2617 ---------------------------
2618 -- 3.6.1 Discrete Range --
2619 ---------------------------
2621 -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
2623 -- The possible forms for a discrete range are:
2625 -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2)
2626 -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2)
2627 -- Range_Attribute (RANGE, 3.5)
2628 -- Simple_Expression .. Simple_Expression (RANGE, 3.5)
2630 -- Error recovery: cannot raise Error_Resync
2632 function P_Discrete_Range
return Node_Id
is
2633 Expr_Node
: Node_Id
;
2634 Range_Node
: Node_Id
;
2637 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2639 if Expr_Form
= EF_Range_Attr
then
2642 elsif Token
= Tok_Range
then
2643 if Expr_Form
/= EF_Simple_Name
then
2644 Error_Msg_SC
("range must be preceded by subtype mark");
2647 return P_Subtype_Indication
(Expr_Node
);
2649 -- Check Expression .. Expression case
2651 elsif Token
= Tok_Dot_Dot
then
2652 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2653 Set_Low_Bound
(Range_Node
, Expr_Node
);
2655 Expr_Node
:= P_Expression
;
2656 Check_Simple_Expression
(Expr_Node
);
2657 Set_High_Bound
(Range_Node
, Expr_Node
);
2660 -- Otherwise we must have a subtype mark
2662 elsif Expr_Form
= EF_Simple_Name
then
2665 -- If incorrect, complain that we expect ..
2671 end P_Discrete_Range
;
2673 ----------------------------
2674 -- 3.7 Discriminant Part --
2675 ----------------------------
2677 -- DISCRIMINANT_PART ::=
2678 -- UNKNOWN_DISCRIMINANT_PART
2679 -- | KNOWN_DISCRIMINANT_PART
2681 -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
2682 -- or P_Unknown_Discriminant_Part (3.7), since we know which we want.
2684 ------------------------------------
2685 -- 3.7 Unknown Discriminant Part --
2686 ------------------------------------
2688 -- UNKNOWN_DISCRIMINANT_PART ::= (<>)
2690 -- If no unknown discriminant part is present, then False is returned,
2691 -- otherwise the unknown discriminant is scanned out and True is returned.
2693 -- Error recovery: cannot raise Error_Resync
2695 function P_Unknown_Discriminant_Part_Opt
return Boolean is
2696 Scan_State
: Saved_Scan_State
;
2699 if Token
/= Tok_Left_Paren
then
2703 Save_Scan_State
(Scan_State
);
2704 Scan
; -- past the left paren
2706 if Token
= Tok_Box
then
2707 if Ada_Version
= Ada_83
then
2708 Error_Msg_SC
("(Ada 83) unknown discriminant not allowed!");
2711 Scan
; -- past the box
2712 T_Right_Paren
; -- must be followed by right paren
2716 Restore_Scan_State
(Scan_State
);
2720 end P_Unknown_Discriminant_Part_Opt
;
2722 ----------------------------------
2723 -- 3.7 Known Discriminant Part --
2724 ----------------------------------
2726 -- KNOWN_DISCRIMINANT_PART ::=
2727 -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
2729 -- DISCRIMINANT_SPECIFICATION ::=
2730 -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
2731 -- [:= DEFAULT_EXPRESSION]
2732 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
2733 -- [:= DEFAULT_EXPRESSION]
2735 -- If no known discriminant part is present, then No_List is returned
2737 -- Error recovery: cannot raise Error_Resync
2739 function P_Known_Discriminant_Part_Opt
return List_Id
is
2740 Specification_Node
: Node_Id
;
2741 Specification_List
: List_Id
;
2742 Ident_Sloc
: Source_Ptr
;
2743 Scan_State
: Saved_Scan_State
;
2745 Not_Null_Present
: Boolean;
2748 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
2749 -- This array holds the list of defining identifiers. The upper bound
2750 -- of 4096 is intended to be essentially infinite, and we do not even
2751 -- bother to check for it being exceeded.
2754 if Token
= Tok_Left_Paren
then
2755 Specification_List
:= New_List
;
2757 P_Pragmas_Misplaced
;
2759 Specification_Loop
: loop
2761 Ident_Sloc
:= Token_Ptr
;
2762 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
2765 while Comma_Present
loop
2766 Num_Idents
:= Num_Idents
+ 1;
2767 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
2772 -- If there are multiple identifiers, we repeatedly scan the
2773 -- type and initialization expression information by resetting
2774 -- the scan pointer (so that we get completely separate trees
2775 -- for each occurrence).
2777 if Num_Idents
> 1 then
2778 Save_Scan_State
(Scan_State
);
2781 -- Loop through defining identifiers in list
2785 Specification_Node
:=
2786 New_Node
(N_Discriminant_Specification
, Ident_Sloc
);
2787 Set_Defining_Identifier
(Specification_Node
, Idents
(Ident
));
2788 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
2790 if Token
= Tok_Access
then
2791 if Ada_Version
= Ada_83
then
2793 ("(Ada 83) access discriminant not allowed!");
2796 Set_Discriminant_Type
2797 (Specification_Node
,
2798 P_Access_Definition
(Not_Null_Present
));
2801 Set_Discriminant_Type
2802 (Specification_Node
, P_Subtype_Mark
);
2804 Set_Null_Exclusion_Present
-- Ada 2005 (AI-231)
2805 (Specification_Node
, Not_Null_Present
);
2809 (Specification_Node
, Init_Expr_Opt
(True));
2812 Set_Prev_Ids
(Specification_Node
, True);
2815 if Ident
< Num_Idents
then
2816 Set_More_Ids
(Specification_Node
, True);
2819 Append
(Specification_Node
, Specification_List
);
2820 exit Ident_Loop
when Ident
= Num_Idents
;
2822 Restore_Scan_State
(Scan_State
);
2823 end loop Ident_Loop
;
2825 exit Specification_Loop
when Token
/= Tok_Semicolon
;
2827 P_Pragmas_Misplaced
;
2828 end loop Specification_Loop
;
2831 return Specification_List
;
2836 end P_Known_Discriminant_Part_Opt
;
2838 -------------------------------------
2839 -- 3.7 DIscriminant Specification --
2840 -------------------------------------
2842 -- Parsed by P_Known_Discriminant_Part_Opt (3.7)
2844 -----------------------------
2845 -- 3.7 Default Expression --
2846 -----------------------------
2848 -- Always parsed (simply as an Expression) by the parent construct
2850 ------------------------------------
2851 -- 3.7.1 Discriminant Constraint --
2852 ------------------------------------
2854 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2856 --------------------------------------------------------
2857 -- 3.7.1 Index or Discriminant Constraint (also 3.6) --
2858 --------------------------------------------------------
2860 -- DISCRIMINANT_CONSTRAINT ::=
2861 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
2863 -- DISCRIMINANT_ASSOCIATION ::=
2864 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2867 -- This routine parses either an index or a discriminant constraint. As
2868 -- is clear from the above grammar, it is often possible to clearly
2869 -- determine which of the two possibilities we have, but there are
2870 -- cases (those in which we have a series of expressions of the same
2871 -- syntactic form as subtype indications), where we cannot tell. Since
2872 -- this means that in any case the semantic phase has to distinguish
2873 -- between the two, there is not much point in the parser trying to
2874 -- distinguish even those cases where the difference is clear. In any
2875 -- case, if we have a situation like:
2877 -- (A => 123, 235 .. 500)
2879 -- it is not clear which of the two items is the wrong one, better to
2880 -- let the semantic phase give a clear message. Consequently, this
2881 -- routine in general returns a list of items which can be either
2882 -- discrete ranges or discriminant associations.
2884 -- The caller has checked that the initial token is a left paren
2886 -- Error recovery: can raise Error_Resync
2888 function P_Index_Or_Discriminant_Constraint
return Node_Id
is
2889 Scan_State
: Saved_Scan_State
;
2890 Constr_Node
: Node_Id
;
2891 Constr_List
: List_Id
;
2892 Expr_Node
: Node_Id
;
2893 Result_Node
: Node_Id
;
2896 Result_Node
:= New_Node
(N_Index_Or_Discriminant_Constraint
, Token_Ptr
);
2898 Constr_List
:= New_List
;
2899 Set_Constraints
(Result_Node
, Constr_List
);
2901 -- The two syntactic forms are a little mixed up, so what we are doing
2902 -- here is looking at the first entry to determine which case we have
2904 -- A discriminant constraint is a list of discriminant associations,
2905 -- which have one of the following possible forms:
2909 -- Id | Id | .. | Id => Expression
2911 -- An index constraint is a list of discrete ranges which have one
2912 -- of the following possible forms:
2915 -- Subtype_Mark range Range
2917 -- Simple_Expression .. Simple_Expression
2919 -- Loop through discriminants in list
2922 -- Check cases of Id => Expression or Id | Id => Expression
2924 if Token
= Tok_Identifier
then
2925 Save_Scan_State
(Scan_State
); -- at Id
2928 if Token
= Tok_Arrow
or else Token
= Tok_Vertical_Bar
then
2929 Restore_Scan_State
(Scan_State
); -- to Id
2930 Append
(P_Discriminant_Association
, Constr_List
);
2933 Restore_Scan_State
(Scan_State
); -- to Id
2937 -- Otherwise scan out an expression and see what we have got
2939 Expr_Node
:= P_Expression_Or_Range_Attribute
;
2941 if Expr_Form
= EF_Range_Attr
then
2942 Append
(Expr_Node
, Constr_List
);
2944 elsif Token
= Tok_Range
then
2945 if Expr_Form
/= EF_Simple_Name
then
2946 Error_Msg_SC
("subtype mark required before RANGE");
2949 Append
(P_Subtype_Indication
(Expr_Node
), Constr_List
);
2952 -- Check Simple_Expression .. Simple_Expression case
2954 elsif Token
= Tok_Dot_Dot
then
2955 Check_Simple_Expression
(Expr_Node
);
2956 Constr_Node
:= New_Node
(N_Range
, Token_Ptr
);
2957 Set_Low_Bound
(Constr_Node
, Expr_Node
);
2959 Expr_Node
:= P_Expression
;
2960 Check_Simple_Expression
(Expr_Node
);
2961 Set_High_Bound
(Constr_Node
, Expr_Node
);
2962 Append
(Constr_Node
, Constr_List
);
2965 -- Case of an expression which could be either form
2968 Append
(Expr_Node
, Constr_List
);
2972 -- Here with a single entry scanned
2975 exit when not Comma_Present
;
2981 end P_Index_Or_Discriminant_Constraint
;
2983 -------------------------------------
2984 -- 3.7.1 Discriminant Association --
2985 -------------------------------------
2987 -- DISCRIMINANT_ASSOCIATION ::=
2988 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2991 -- This routine is used only when the name list is present and the caller
2992 -- has already checked this (by scanning ahead and repositioning the
2995 -- Error_Recovery: cannot raise Error_Resync;
2997 function P_Discriminant_Association
return Node_Id
is
2998 Discr_Node
: Node_Id
;
2999 Names_List
: List_Id
;
3000 Ident_Sloc
: Source_Ptr
;
3003 Ident_Sloc
:= Token_Ptr
;
3004 Names_List
:= New_List
;
3007 Append
(P_Identifier
(C_Vertical_Bar_Arrow
), Names_List
);
3008 exit when Token
/= Tok_Vertical_Bar
;
3012 Discr_Node
:= New_Node
(N_Discriminant_Association
, Ident_Sloc
);
3013 Set_Selector_Names
(Discr_Node
, Names_List
);
3015 Set_Expression
(Discr_Node
, P_Expression
);
3017 end P_Discriminant_Association
;
3019 ---------------------------------
3020 -- 3.8 Record Type Definition --
3021 ---------------------------------
3023 -- RECORD_TYPE_DEFINITION ::=
3024 -- [[abstract] tagged] [limited] RECORD_DEFINITION
3026 -- There is no node in the tree for a record type definition. Instead
3027 -- a record definition node appears, with possible Abstract_Present,
3028 -- Tagged_Present, and Limited_Present flags set appropriately.
3030 ----------------------------
3031 -- 3.8 Record Definition --
3032 ----------------------------
3034 -- RECORD_DEFINITION ::=
3040 -- Note: in the case where a record definition node is used to represent
3041 -- a record type definition, the caller sets the Tagged_Present and
3042 -- Limited_Present flags in the resulting N_Record_Definition node as
3045 -- Note that the RECORD token at the start may be missing in certain
3046 -- error situations, so this function is expected to post the error
3048 -- Error recovery: can raise Error_Resync
3050 function P_Record_Definition
return Node_Id
is
3054 Rec_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
3058 if Token
= Tok_Null
then
3061 Set_Null_Present
(Rec_Node
, True);
3063 -- Case starting with RECORD keyword. Build scope stack entry. For the
3064 -- column, we use the first non-blank character on the line, to deal
3065 -- with situations such as:
3071 -- which is not official RM indentation, but is not uncommon usage
3075 Scope
.Table
(Scope
.Last
).Etyp
:= E_Record
;
3076 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
3077 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
3078 Scope
.Table
(Scope
.Last
).Labl
:= Error
;
3079 Scope
.Table
(Scope
.Last
).Junk
:= (Token
/= Tok_Record
);
3083 Set_Component_List
(Rec_Node
, P_Component_List
);
3086 exit when Check_End
;
3087 Discard_Junk_Node
(P_Component_List
);
3092 end P_Record_Definition
;
3094 -------------------------
3095 -- 3.8 Component List --
3096 -------------------------
3098 -- COMPONENT_LIST ::=
3099 -- COMPONENT_ITEM {COMPONENT_ITEM}
3100 -- | {COMPONENT_ITEM} VARIANT_PART
3103 -- Error recovery: cannot raise Error_Resync
3105 function P_Component_List
return Node_Id
is
3106 Component_List_Node
: Node_Id
;
3107 Decls_List
: List_Id
;
3108 Scan_State
: Saved_Scan_State
;
3111 Component_List_Node
:= New_Node
(N_Component_List
, Token_Ptr
);
3112 Decls_List
:= New_List
;
3114 if Token
= Tok_Null
then
3117 P_Pragmas_Opt
(Decls_List
);
3118 Set_Null_Present
(Component_List_Node
, True);
3119 return Component_List_Node
;
3122 P_Pragmas_Opt
(Decls_List
);
3124 if Token
/= Tok_Case
then
3125 Component_Scan_Loop
: loop
3126 P_Component_Items
(Decls_List
);
3127 P_Pragmas_Opt
(Decls_List
);
3129 exit Component_Scan_Loop
when Token
= Tok_End
3130 or else Token
= Tok_Case
3131 or else Token
= Tok_When
;
3133 -- We are done if we do not have an identifier. However, if
3134 -- we have a misspelled reserved identifier that is in a column
3135 -- to the right of the record definition, we will treat it as
3136 -- an identifier. It turns out to be too dangerous in practice
3137 -- to accept such a mis-spelled identifier which does not have
3138 -- this additional clue that confirms the incorrect spelling.
3140 if Token
/= Tok_Identifier
then
3141 if Start_Column
> Scope
.Table
(Scope
.Last
).Ecol
3142 and then Is_Reserved_Identifier
3144 Save_Scan_State
(Scan_State
); -- at reserved id
3145 Scan
; -- possible reserved id
3147 if Token
= Tok_Comma
or else Token
= Tok_Colon
then
3148 Restore_Scan_State
(Scan_State
);
3149 Scan_Reserved_Identifier
(Force_Msg
=> True);
3151 -- Note reserved identifier used as field name after
3152 -- all because not followed by colon or comma
3155 Restore_Scan_State
(Scan_State
);
3156 exit Component_Scan_Loop
;
3159 -- Non-identifier that definitely was not reserved id
3162 exit Component_Scan_Loop
;
3165 end loop Component_Scan_Loop
;
3168 if Token
= Tok_Case
then
3169 Set_Variant_Part
(Component_List_Node
, P_Variant_Part
);
3171 -- Check for junk after variant part
3173 if Token
= Tok_Identifier
then
3174 Save_Scan_State
(Scan_State
);
3175 Scan
; -- past identifier
3177 if Token
= Tok_Colon
then
3178 Restore_Scan_State
(Scan_State
);
3179 Error_Msg_SC
("component may not follow variant part");
3180 Discard_Junk_Node
(P_Component_List
);
3182 elsif Token
= Tok_Case
then
3183 Restore_Scan_State
(Scan_State
);
3184 Error_Msg_SC
("only one variant part allowed in a record");
3185 Discard_Junk_Node
(P_Component_List
);
3188 Restore_Scan_State
(Scan_State
);
3194 Set_Component_Items
(Component_List_Node
, Decls_List
);
3195 return Component_List_Node
;
3196 end P_Component_List
;
3198 -------------------------
3199 -- 3.8 Component Item --
3200 -------------------------
3202 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
3204 -- COMPONENT_DECLARATION ::=
3205 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
3206 -- [:= DEFAULT_EXPRESSION];
3208 -- COMPONENT_DEFINITION ::=
3209 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
3211 -- Error recovery: cannot raise Error_Resync, if an error occurs,
3212 -- the scan is positioned past the following semicolon.
3214 -- Note: we do not yet allow representation clauses to appear as component
3215 -- items, do we need to add this capability sometime in the future ???
3217 procedure P_Component_Items
(Decls
: List_Id
) is
3218 Aliased_Present
: Boolean := False;
3219 CompDef_Node
: Node_Id
;
3220 Decl_Node
: Node_Id
;
3221 Scan_State
: Saved_Scan_State
;
3222 Not_Null_Present
: Boolean := False;
3225 Ident_Sloc
: Source_Ptr
;
3227 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
3228 -- This array holds the list of defining identifiers. The upper bound
3229 -- of 4096 is intended to be essentially infinite, and we do not even
3230 -- bother to check for it being exceeded.
3233 if Token
/= Tok_Identifier
then
3234 Error_Msg_SC
("component declaration expected");
3235 Resync_Past_Semicolon
;
3239 Ident_Sloc
:= Token_Ptr
;
3240 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
3243 while Comma_Present
loop
3244 Num_Idents
:= Num_Idents
+ 1;
3245 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
3250 -- If there are multiple identifiers, we repeatedly scan the
3251 -- type and initialization expression information by resetting
3252 -- the scan pointer (so that we get completely separate trees
3253 -- for each occurrence).
3255 if Num_Idents
> 1 then
3256 Save_Scan_State
(Scan_State
);
3259 -- Loop through defining identifiers in list
3264 -- The following block is present to catch Error_Resync
3265 -- which causes the parse to be reset past the semicolon
3268 Decl_Node
:= New_Node
(N_Component_Declaration
, Ident_Sloc
);
3269 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
3271 if Token
= Tok_Constant
then
3272 Error_Msg_SC
("constant components are not permitted");
3276 CompDef_Node
:= New_Node
(N_Component_Definition
, Token_Ptr
);
3278 if Token_Name
= Name_Aliased
then
3279 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
3282 if Token
= Tok_Aliased
then
3283 Aliased_Present
:= True;
3284 Scan
; -- past ALIASED
3287 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/AI-254)
3289 -- Ada 2005 (AI-230): Access Definition case
3291 if Token
= Tok_Access
then
3292 if Ada_Version
< Ada_05
then
3294 ("generalized use of anonymous access types " &
3295 "is an Ada 2005 extension");
3296 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
3299 if Aliased_Present
then
3300 Error_Msg_SP
("ALIASED not allowed here");
3303 Set_Subtype_Indication
(CompDef_Node
, Empty
);
3304 Set_Aliased_Present
(CompDef_Node
, False);
3305 Set_Access_Definition
(CompDef_Node
,
3306 P_Access_Definition
(Not_Null_Present
));
3309 Set_Access_Definition
(CompDef_Node
, Empty
);
3310 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
3311 Set_Null_Exclusion_Present
(CompDef_Node
, Not_Null_Present
);
3313 if Token
= Tok_Array
then
3315 ("anonymous arrays not allowed as components");
3319 Set_Subtype_Indication
(CompDef_Node
,
3320 P_Subtype_Indication
(Not_Null_Present
));
3323 Set_Component_Definition
(Decl_Node
, CompDef_Node
);
3324 Set_Expression
(Decl_Node
, Init_Expr_Opt
);
3327 Set_Prev_Ids
(Decl_Node
, True);
3330 if Ident
< Num_Idents
then
3331 Set_More_Ids
(Decl_Node
, True);
3334 Append
(Decl_Node
, Decls
);
3337 when Error_Resync
=>
3338 if Token
/= Tok_End
then
3339 Resync_Past_Semicolon
;
3343 exit Ident_Loop
when Ident
= Num_Idents
;
3345 Restore_Scan_State
(Scan_State
);
3347 end loop Ident_Loop
;
3350 end P_Component_Items
;
3352 --------------------------------
3353 -- 3.8 Component Declaration --
3354 --------------------------------
3356 -- Parsed by P_Component_Items (3.8)
3358 -------------------------
3359 -- 3.8.1 Variant Part --
3360 -------------------------
3363 -- case discriminant_DIRECT_NAME is
3368 -- The caller has checked that the initial token is CASE
3370 -- Error recovery: cannot raise Error_Resync
3372 function P_Variant_Part
return Node_Id
is
3373 Variant_Part_Node
: Node_Id
;
3374 Variants_List
: List_Id
;
3375 Case_Node
: Node_Id
;
3378 Variant_Part_Node
:= New_Node
(N_Variant_Part
, Token_Ptr
);
3380 Scope
.Table
(Scope
.Last
).Etyp
:= E_Case
;
3381 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
3382 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
3385 Case_Node
:= P_Expression
;
3386 Set_Name
(Variant_Part_Node
, Case_Node
);
3388 if Nkind
(Case_Node
) /= N_Identifier
then
3389 Set_Name
(Variant_Part_Node
, Error
);
3390 Error_Msg
("discriminant name expected", Sloc
(Case_Node
));
3394 Variants_List
:= New_List
;
3395 P_Pragmas_Opt
(Variants_List
);
3397 -- Test missing variant
3399 if Token
= Tok_End
then
3400 Error_Msg_BC
("WHEN expected (must have at least one variant)");
3402 Append
(P_Variant
, Variants_List
);
3405 -- Loop through variants, note that we allow if in place of when,
3406 -- this error will be detected and handled in P_Variant.
3409 P_Pragmas_Opt
(Variants_List
);
3411 if Token
/= Tok_When
3412 and then Token
/= Tok_If
3413 and then Token
/= Tok_Others
3415 exit when Check_End
;
3418 Append
(P_Variant
, Variants_List
);
3421 Set_Variants
(Variant_Part_Node
, Variants_List
);
3422 return Variant_Part_Node
;
3425 --------------------
3427 --------------------
3430 -- when DISCRETE_CHOICE_LIST =>
3433 -- Error recovery: cannot raise Error_Resync
3435 -- The initial token on entry is either WHEN, IF or OTHERS
3437 function P_Variant
return Node_Id
is
3438 Variant_Node
: Node_Id
;
3441 -- Special check to recover nicely from use of IF in place of WHEN
3443 if Token
= Tok_If
then
3450 Variant_Node
:= New_Node
(N_Variant
, Prev_Token_Ptr
);
3451 Set_Discrete_Choices
(Variant_Node
, P_Discrete_Choice_List
);
3453 Set_Component_List
(Variant_Node
, P_Component_List
);
3454 return Variant_Node
;
3457 ---------------------------------
3458 -- 3.8.1 Discrete Choice List --
3459 ---------------------------------
3461 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
3463 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
3465 -- Note: in Ada 83, the expression must be a simple expression
3467 -- Error recovery: cannot raise Error_Resync
3469 function P_Discrete_Choice_List
return List_Id
is
3471 Expr_Node
: Node_Id
;
3472 Choice_Node
: Node_Id
;
3475 Choices
:= New_List
;
3478 if Token
= Tok_Others
then
3479 Append
(New_Node
(N_Others_Choice
, Token_Ptr
), Choices
);
3480 Scan
; -- past OTHERS
3484 Expr_Node
:= No_Right_Paren
(P_Expression_Or_Range_Attribute
);
3486 if Token
= Tok_Colon
3487 and then Nkind
(Expr_Node
) = N_Identifier
3489 Error_Msg_SP
("label not permitted in this context");
3492 elsif Expr_Form
= EF_Range_Attr
then
3493 Append
(Expr_Node
, Choices
);
3495 elsif Token
= Tok_Dot_Dot
then
3496 Check_Simple_Expression
(Expr_Node
);
3497 Choice_Node
:= New_Node
(N_Range
, Token_Ptr
);
3498 Set_Low_Bound
(Choice_Node
, Expr_Node
);
3500 Expr_Node
:= P_Expression_No_Right_Paren
;
3501 Check_Simple_Expression
(Expr_Node
);
3502 Set_High_Bound
(Choice_Node
, Expr_Node
);
3503 Append
(Choice_Node
, Choices
);
3505 elsif Expr_Form
= EF_Simple_Name
then
3506 if Token
= Tok_Range
then
3507 Append
(P_Subtype_Indication
(Expr_Node
), Choices
);
3509 elsif Token
in Token_Class_Consk
then
3511 ("the only constraint allowed here " &
3512 "is a range constraint");
3513 Discard_Junk_Node
(P_Constraint_Opt
);
3514 Append
(Expr_Node
, Choices
);
3517 Append
(Expr_Node
, Choices
);
3521 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
3522 Append
(Expr_Node
, Choices
);
3526 when Error_Resync
=>
3532 if Token
= Tok_Comma
then
3533 Error_Msg_SC
(""","" should be ""'|""");
3535 exit when Token
/= Tok_Vertical_Bar
;
3538 Scan
; -- past | or comma
3542 end P_Discrete_Choice_List
;
3544 ----------------------------
3545 -- 3.8.1 Discrete Choice --
3546 ----------------------------
3548 -- Parsed by P_Discrete_Choice_List (3.8.1)
3550 ----------------------------------
3551 -- 3.9.1 Record Extension Part --
3552 ----------------------------------
3554 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
3556 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
3558 --------------------------------------
3559 -- 3.9.4 Interface Type Definition --
3560 --------------------------------------
3562 -- INTERFACE_TYPE_DEFINITION ::=
3563 -- [limited | task | protected | synchronized] interface
3564 -- [and INTERFACE_LIST]
3566 -- Error recovery: cannot raise Error_Resync
3568 function P_Interface_Type_Definition
3569 (Abstract_Present
: Boolean;
3570 Is_Synchronized
: Boolean) return Node_Id
3572 Typedef_Node
: Node_Id
;
3575 if Ada_Version
< Ada_05
then
3576 Error_Msg_SP
("abstract interface is an Ada 2005 extension");
3577 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
3580 if Abstract_Present
then
3581 Error_Msg_SP
("ABSTRACT not allowed in interface type definition " &
3582 "('R'M' 3.9.4(2/2))");
3585 Scan
; -- past INTERFACE
3587 -- Ada 2005 (AI-345): In case of synchronized interfaces and
3588 -- interfaces with a null list of interfaces we build a
3589 -- record_definition node.
3592 or else Token
= Tok_Semicolon
3594 Typedef_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
3596 Set_Abstract_Present
(Typedef_Node
);
3597 Set_Tagged_Present
(Typedef_Node
);
3598 Set_Null_Present
(Typedef_Node
);
3599 Set_Interface_Present
(Typedef_Node
);
3602 and then Token
= Tok_And
3605 Set_Interface_List
(Typedef_Node
, New_List
);
3608 Append
(P_Qualified_Simple_Name
,
3609 Interface_List
(Typedef_Node
));
3610 exit when Token
/= Tok_And
;
3615 -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have
3616 -- a list of interfaces we build a derived_type_definition node. This
3617 -- simplifies the semantic analysis (and hence further mainteinance)
3620 if Token
/= Tok_And
then
3621 Error_Msg_AP
("AND expected");
3626 Typedef_Node
:= New_Node
(N_Derived_Type_Definition
, Token_Ptr
);
3628 Set_Abstract_Present
(Typedef_Node
);
3629 Set_Interface_Present
(Typedef_Node
);
3630 Set_Subtype_Indication
(Typedef_Node
, P_Qualified_Simple_Name
);
3632 Set_Record_Extension_Part
(Typedef_Node
,
3633 New_Node
(N_Record_Definition
, Token_Ptr
));
3634 Set_Null_Present
(Record_Extension_Part
(Typedef_Node
));
3636 if Token
= Tok_And
then
3637 Set_Interface_List
(Typedef_Node
, New_List
);
3641 Append
(P_Qualified_Simple_Name
,
3642 Interface_List
(Typedef_Node
));
3643 exit when Token
/= Tok_And
;
3649 return Typedef_Node
;
3650 end P_Interface_Type_Definition
;
3652 ----------------------------------
3653 -- 3.10 Access Type Definition --
3654 ----------------------------------
3656 -- ACCESS_TYPE_DEFINITION ::=
3657 -- ACCESS_TO_OBJECT_DEFINITION
3658 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3660 -- ACCESS_TO_OBJECT_DEFINITION ::=
3661 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
3663 -- GENERAL_ACCESS_MODIFIER ::= all | constant
3665 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3666 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3667 -- | [NULL_EXCLUSION] access [protected] function
3668 -- PARAMETER_AND_RESULT_PROFILE
3670 -- PARAMETER_PROFILE ::= [FORMAL_PART]
3672 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
3674 -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already
3675 -- parsed the null_exclusion part and has also removed the ACCESS token;
3676 -- otherwise the caller has just checked that the initial token is ACCESS
3678 -- Error recovery: can raise Error_Resync
3680 function P_Access_Type_Definition
3681 (Header_Already_Parsed
: Boolean := False) return Node_Id
is
3682 Access_Loc
: constant Source_Ptr
:= Token_Ptr
;
3683 Prot_Flag
: Boolean;
3684 Not_Null_Present
: Boolean := False;
3685 Type_Def_Node
: Node_Id
;
3686 Result_Not_Null
: Boolean;
3687 Result_Node
: Node_Id
;
3689 procedure Check_Junk_Subprogram_Name
;
3690 -- Used in access to subprogram definition cases to check for an
3691 -- identifier or operator symbol that does not belong.
3693 procedure Check_Junk_Subprogram_Name
is
3694 Saved_State
: Saved_Scan_State
;
3697 if Token
= Tok_Identifier
or else Token
= Tok_Operator_Symbol
then
3698 Save_Scan_State
(Saved_State
);
3699 Scan
; -- past possible junk subprogram name
3701 if Token
= Tok_Left_Paren
or else Token
= Tok_Semicolon
then
3702 Error_Msg_SP
("unexpected subprogram name ignored");
3706 Restore_Scan_State
(Saved_State
);
3709 end Check_Junk_Subprogram_Name
;
3711 -- Start of processing for P_Access_Type_Definition
3714 if not Header_Already_Parsed
then
3715 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
3716 Scan
; -- past ACCESS
3719 if Token_Name
= Name_Protected
then
3720 Check_95_Keyword
(Tok_Protected
, Tok_Procedure
);
3721 Check_95_Keyword
(Tok_Protected
, Tok_Function
);
3724 Prot_Flag
:= (Token
= Tok_Protected
);
3727 Scan
; -- past PROTECTED
3729 if Token
/= Tok_Procedure
and then Token
/= Tok_Function
then
3730 Error_Msg_SC
("FUNCTION or PROCEDURE expected");
3734 if Token
= Tok_Procedure
then
3735 if Ada_Version
= Ada_83
then
3736 Error_Msg_SC
("(Ada 83) access to procedure not allowed!");
3739 Type_Def_Node
:= New_Node
(N_Access_Procedure_Definition
, Access_Loc
);
3740 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3741 Scan
; -- past PROCEDURE
3742 Check_Junk_Subprogram_Name
;
3743 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
3744 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
3746 elsif Token
= Tok_Function
then
3747 if Ada_Version
= Ada_83
then
3748 Error_Msg_SC
("(Ada 83) access to function not allowed!");
3751 Type_Def_Node
:= New_Node
(N_Access_Function_Definition
, Access_Loc
);
3752 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3753 Scan
; -- past FUNCTION
3754 Check_Junk_Subprogram_Name
;
3755 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
3756 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
3759 Result_Not_Null
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
3761 -- Ada 2005 (AI-318-02)
3763 if Token
= Tok_Access
then
3764 if Ada_Version
< Ada_05
then
3766 ("anonymous access result type is an Ada 2005 extension");
3767 Error_Msg_SC
("\unit must be compiled with -gnat05 switch");
3770 Result_Node
:= P_Access_Definition
(Result_Not_Null
);
3773 Result_Node
:= P_Subtype_Mark
;
3777 -- Note: A null exclusion given on the result type needs to
3778 -- be coded by a distinct flag, since Null_Exclusion_Present
3779 -- on an access-to-function type pertains to a null exclusion
3780 -- on the access type itself (as set above). ???
3781 -- Set_Null_Exclusion_Present??? (Type_Def_Node, Result_Not_Null);
3783 Set_Result_Definition
(Type_Def_Node
, Result_Node
);
3787 New_Node
(N_Access_To_Object_Definition
, Access_Loc
);
3788 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3790 if Token
= Tok_All
or else Token
= Tok_Constant
then
3791 if Ada_Version
= Ada_83
then
3792 Error_Msg_SC
("(Ada 83) access modifier not allowed!");
3795 if Token
= Tok_All
then
3796 Set_All_Present
(Type_Def_Node
, True);
3799 Set_Constant_Present
(Type_Def_Node
, True);
3802 Scan
; -- past ALL or CONSTANT
3805 Set_Subtype_Indication
(Type_Def_Node
,
3806 P_Subtype_Indication
(Not_Null_Present
));
3809 return Type_Def_Node
;
3810 end P_Access_Type_Definition
;
3812 ---------------------------------------
3813 -- 3.10 Access To Object Definition --
3814 ---------------------------------------
3816 -- Parsed by P_Access_Type_Definition (3.10)
3818 -----------------------------------
3819 -- 3.10 General Access Modifier --
3820 -----------------------------------
3822 -- Parsed by P_Access_Type_Definition (3.10)
3824 -------------------------------------------
3825 -- 3.10 Access To Subprogram Definition --
3826 -------------------------------------------
3828 -- Parsed by P_Access_Type_Definition (3.10)
3830 -----------------------------
3831 -- 3.10 Access Definition --
3832 -----------------------------
3834 -- ACCESS_DEFINITION ::=
3835 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3836 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3838 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3839 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3840 -- | [NULL_EXCLUSION] access [protected] function
3841 -- PARAMETER_AND_RESULT_PROFILE
3843 -- The caller has parsed the null-exclusion part and it has also checked
3844 -- that the next token is ACCESS
3846 -- Error recovery: cannot raise Error_Resync
3848 function P_Access_Definition
3849 (Null_Exclusion_Present
: Boolean) return Node_Id
is
3851 Subp_Node
: Node_Id
;
3854 Def_Node
:= New_Node
(N_Access_Definition
, Token_Ptr
);
3855 Scan
; -- past ACCESS
3857 -- Ada 2005 (AI-254): Access_To_Subprogram_Definition
3859 if Token
= Tok_Protected
3860 or else Token
= Tok_Procedure
3861 or else Token
= Tok_Function
3863 if Ada_Version
< Ada_05
then
3864 Error_Msg_SP
("access-to-subprogram is an Ada 2005 extension");
3865 Error_Msg_SP
("\unit should be compiled with -gnat05 switch");
3868 Subp_Node
:= P_Access_Type_Definition
(Header_Already_Parsed
=> True);
3869 Set_Null_Exclusion_Present
(Subp_Node
, Null_Exclusion_Present
);
3870 Set_Access_To_Subprogram_Definition
(Def_Node
, Subp_Node
);
3872 -- Ada 2005 (AI-231)
3873 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3876 Set_Null_Exclusion_Present
(Def_Node
, Null_Exclusion_Present
);
3878 if Token
= Tok_All
then
3879 if Ada_Version
< Ada_05
then
3881 ("access-all in this context is an Ada 2005 extension");
3882 Error_Msg_SP
("\unit should be compiled with -gnat05 switch");
3886 Set_All_Present
(Def_Node
);
3888 elsif Token
= Tok_Constant
then
3889 if Ada_Version
< Ada_05
then
3890 Error_Msg_SP
("access-to-constant is an Ada 2005 extension");
3891 Error_Msg_SP
("\unit should be compiled with -gnat05 switch");
3894 Scan
; -- past CONSTANT
3895 Set_Constant_Present
(Def_Node
);
3898 Set_Subtype_Mark
(Def_Node
, P_Subtype_Mark
);
3903 end P_Access_Definition
;
3905 -----------------------------------------
3906 -- 3.10.1 Incomplete Type Declaration --
3907 -----------------------------------------
3909 -- Parsed by P_Type_Declaration (3.2.1)
3911 ----------------------------
3912 -- 3.11 Declarative Part --
3913 ----------------------------
3915 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
3917 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items
3918 -- handles errors, and returns cleanly after an error has occurred)
3920 function P_Declarative_Part
return List_Id
is
3925 -- Indicate no bad declarations detected yet. This will be reset by
3926 -- P_Declarative_Items if a bad declaration is discovered.
3928 Missing_Begin_Msg
:= No_Error_Msg
;
3930 -- Get rid of active SIS entry from outer scope. This means we will
3931 -- miss some nested cases, but it doesn't seem worth the effort. See
3932 -- discussion in Par for further details
3934 SIS_Entry_Active
:= False;
3937 -- Loop to scan out the declarations
3940 P_Declarative_Items
(Decls
, Done
, In_Spec
=> False);
3944 -- Get rid of active SIS entry which is left set only if we scanned a
3945 -- procedure declaration and have not found the body. We could give
3946 -- an error message, but that really would be usurping the role of
3947 -- semantic analysis (this really is a missing body case).
3949 SIS_Entry_Active
:= False;
3951 end P_Declarative_Part
;
3953 ----------------------------
3954 -- 3.11 Declarative Item --
3955 ----------------------------
3957 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
3959 -- Can return Error if a junk declaration is found, or Empty if no
3960 -- declaration is found (i.e. a token ending declarations, such as
3961 -- BEGIN or END is encountered).
3963 -- Error recovery: cannot raise Error_Resync. If an error resync occurs,
3964 -- then the scan is set past the next semicolon and Error is returned.
3966 procedure P_Declarative_Items
3971 Scan_State
: Saved_Scan_State
;
3974 if Style_Check
then Style
.Check_Indentation
; end if;
3978 when Tok_Function
=>
3980 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3986 -- Check for loop (premature statement)
3988 Save_Scan_State
(Scan_State
);
3991 if Token
= Tok_Identifier
then
3992 Scan
; -- past identifier
3994 if Token
= Tok_In
then
3995 Restore_Scan_State
(Scan_State
);
3996 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4001 -- Not a loop, so must be rep clause
4003 Restore_Scan_State
(Scan_State
);
4004 Append
(P_Representation_Clause
, Decls
);
4009 Append
(P_Generic
, Decls
);
4012 when Tok_Identifier
=>
4014 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4016 -- Ada2005: A subprogram declaration can start with "not" or
4017 -- "overriding". In older versions, "overriding" is handled
4018 -- like an identifier, with the appropriate warning.
4022 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
4025 when Tok_Overriding
=>
4027 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
4032 Append
(P_Package
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
4036 Append
(P_Pragma
, Decls
);
4039 when Tok_Procedure
=>
4041 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
4044 when Tok_Protected
=>
4046 Scan
; -- past PROTECTED
4047 Append
(P_Protected
, Decls
);
4052 Append
(P_Subtype_Declaration
, Decls
);
4058 Append
(P_Task
, Decls
);
4063 Append
(P_Type_Declaration
, Decls
);
4068 Append
(P_Use_Clause
, Decls
);
4073 Error_Msg_SC
("WITH can only appear in context clause");
4076 -- BEGIN terminates the scan of a sequence of declarations unless
4077 -- there is a missing subprogram body, see section on handling
4078 -- semicolon in place of IS. We only treat the begin as satisfying
4079 -- the subprogram declaration if it falls in the expected column
4083 if SIS_Entry_Active
and then Start_Column
>= SIS_Ecol
then
4085 -- Here we have the case where a BEGIN is encountered during
4086 -- declarations in a declarative part, or at the outer level,
4087 -- and there is a subprogram declaration outstanding for which
4088 -- no body has been supplied. This is the case where we assume
4089 -- that the semicolon in the subprogram declaration should
4090 -- really have been is. The active SIS entry describes the
4091 -- subprogram declaration. On return the declaration has been
4092 -- modified to become a body.
4095 Specification_Node
: Node_Id
;
4096 Decl_Node
: Node_Id
;
4097 Body_Node
: Node_Id
;
4100 -- First issue the error message. If we had a missing
4101 -- semicolon in the declaration, then change the message
4102 -- to <missing "is">
4104 if SIS_Missing_Semicolon_Message
/= No_Error_Msg
then
4105 Change_Error_Text
-- Replace: "missing "";"" "
4106 (SIS_Missing_Semicolon_Message
, "missing ""is""");
4108 -- Otherwise we saved the semicolon position, so complain
4111 Error_Msg
(""";"" should be IS", SIS_Semicolon_Sloc
);
4114 -- The next job is to fix up any declarations that occurred
4115 -- between the procedure header and the BEGIN. These got
4116 -- chained to the outer declarative region (immediately
4117 -- after the procedure declaration) and they should be
4118 -- chained to the subprogram itself, which is a body
4119 -- rather than a spec.
4121 Specification_Node
:= Specification
(SIS_Declaration_Node
);
4122 Change_Node
(SIS_Declaration_Node
, N_Subprogram_Body
);
4123 Body_Node
:= SIS_Declaration_Node
;
4124 Set_Specification
(Body_Node
, Specification_Node
);
4125 Set_Declarations
(Body_Node
, New_List
);
4128 Decl_Node
:= Remove_Next
(Body_Node
);
4129 exit when Decl_Node
= Empty
;
4130 Append
(Decl_Node
, Declarations
(Body_Node
));
4133 -- Now make the scope table entry for the Begin-End and
4137 Scope
.Table
(Scope
.Last
).Sloc
:= SIS_Sloc
;
4138 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
4139 Scope
.Table
(Scope
.Last
).Ecol
:= SIS_Ecol
;
4140 Scope
.Table
(Scope
.Last
).Labl
:= SIS_Labl
;
4141 Scope
.Table
(Scope
.Last
).Lreq
:= False;
4142 SIS_Entry_Active
:= False;
4144 Set_Handled_Statement_Sequence
(Body_Node
,
4145 P_Handled_Sequence_Of_Statements
);
4146 End_Statements
(Handled_Statement_Sequence
(Body_Node
));
4155 -- Normally an END terminates the scan for basic declarative
4156 -- items. The one exception is END RECORD, which is probably
4157 -- left over from some other junk.
4160 Save_Scan_State
(Scan_State
); -- at END
4163 if Token
= Tok_Record
then
4164 Error_Msg_SP
("no RECORD for this `end record`!");
4165 Scan
; -- past RECORD
4169 Restore_Scan_State
(Scan_State
); -- to END
4173 -- The following tokens which can only be the start of a statement
4174 -- are considered to end a declarative part (i.e. we have a missing
4175 -- BEGIN situation). We are fairly conservative in making this
4176 -- judgment, because it is a real mess to go into statement mode
4177 -- prematurely in response to a junk declaration.
4192 -- But before we decide that it's a statement, let's check for
4193 -- a reserved word misused as an identifier.
4195 if Is_Reserved_Identifier
then
4196 Save_Scan_State
(Scan_State
);
4197 Scan
; -- past the token
4199 -- If reserved identifier not followed by colon or comma, then
4200 -- this is most likely an assignment statement to the bad id.
4202 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
4203 Restore_Scan_State
(Scan_State
);
4204 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4207 -- Otherwise we have a declaration of the bad id
4210 Restore_Scan_State
(Scan_State
);
4211 Scan_Reserved_Identifier
(Force_Msg
=> True);
4212 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4215 -- If not reserved identifier, then it's definitely a statement
4218 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4222 -- The token RETURN may well also signal a missing BEGIN situation,
4223 -- however, we never let it end the declarative part, because it may
4224 -- also be part of a half-baked function declaration.
4227 Error_Msg_SC
("misplaced RETURN statement");
4230 -- PRIVATE definitely terminates the declarations in a spec,
4231 -- and is an error in a body.
4237 Error_Msg_SC
("PRIVATE not allowed in body");
4238 Scan
; -- past PRIVATE
4241 -- An end of file definitely terminates the declarations!
4246 -- The remaining tokens do not end the scan, but cannot start a
4247 -- valid declaration, so we signal an error and resynchronize.
4248 -- But first check for misuse of a reserved identifier.
4252 -- Here we check for a reserved identifier
4254 if Is_Reserved_Identifier
then
4255 Save_Scan_State
(Scan_State
);
4256 Scan
; -- past the token
4258 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
4259 Restore_Scan_State
(Scan_State
);
4260 Set_Declaration_Expected
;
4263 Restore_Scan_State
(Scan_State
);
4264 Scan_Reserved_Identifier
(Force_Msg
=> True);
4266 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4270 Set_Declaration_Expected
;
4275 -- To resynchronize after an error, we scan to the next semicolon and
4276 -- return with Done = False, indicating that there may still be more
4277 -- valid declarations to come.
4280 when Error_Resync
=>
4281 Resync_Past_Semicolon
;
4283 end P_Declarative_Items
;
4285 ----------------------------------
4286 -- 3.11 Basic Declarative Item --
4287 ----------------------------------
4289 -- BASIC_DECLARATIVE_ITEM ::=
4290 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
4292 -- Scan zero or more basic declarative items
4294 -- Error recovery: cannot raise Error_Resync. If an error is detected, then
4295 -- the scan pointer is repositioned past the next semicolon, and the scan
4296 -- for declarative items continues.
4298 function P_Basic_Declarative_Items
return List_Id
is
4305 -- Indicate no bad declarations detected yet in the current context:
4306 -- visible or private declarations of a package spec.
4308 Missing_Begin_Msg
:= No_Error_Msg
;
4310 -- Get rid of active SIS entry from outer scope. This means we will
4311 -- miss some nested cases, but it doesn't seem worth the effort. See
4312 -- discussion in Par for further details
4314 SIS_Entry_Active
:= False;
4316 -- Loop to scan out declarations
4321 P_Declarative_Items
(Decls
, Done
, In_Spec
=> True);
4325 -- Get rid of active SIS entry. This is set only if we have scanned a
4326 -- procedure declaration and have not found the body. We could give
4327 -- an error message, but that really would be usurping the role of
4328 -- semantic analysis (this really is a case of a missing body).
4330 SIS_Entry_Active
:= False;
4332 -- Test for assorted illegal declarations not diagnosed elsewhere
4334 Decl
:= First
(Decls
);
4336 while Present
(Decl
) loop
4337 Kind
:= Nkind
(Decl
);
4339 -- Test for body scanned, not acceptable as basic decl item
4341 if Kind
= N_Subprogram_Body
or else
4342 Kind
= N_Package_Body
or else
4343 Kind
= N_Task_Body
or else
4344 Kind
= N_Protected_Body
4347 ("proper body not allowed in package spec", Sloc
(Decl
));
4349 -- Test for body stub scanned, not acceptable as basic decl item
4351 elsif Kind
in N_Body_Stub
then
4353 ("body stub not allowed in package spec", Sloc
(Decl
));
4355 elsif Kind
= N_Assignment_Statement
then
4357 ("assignment statement not allowed in package spec",
4365 end P_Basic_Declarative_Items
;
4371 -- For proper body, see below
4372 -- For body stub, see 10.1.3
4374 -----------------------
4375 -- 3.11 Proper Body --
4376 -----------------------
4378 -- Subprogram body is parsed by P_Subprogram (6.1)
4379 -- Package body is parsed by P_Package (7.1)
4380 -- Task body is parsed by P_Task (9.1)
4381 -- Protected body is parsed by P_Protected (9.4)
4383 ------------------------------
4384 -- Set_Declaration_Expected --
4385 ------------------------------
4387 procedure Set_Declaration_Expected
is
4389 Error_Msg_SC
("declaration expected");
4391 if Missing_Begin_Msg
= No_Error_Msg
then
4392 Missing_Begin_Msg
:= Get_Msg_Id
;
4394 end Set_Declaration_Expected
;
4396 ----------------------
4397 -- Skip_Declaration --
4398 ----------------------
4400 procedure Skip_Declaration
(S
: List_Id
) is
4401 Dummy_Done
: Boolean;
4404 P_Declarative_Items
(S
, Dummy_Done
, False);
4405 end Skip_Declaration
;
4407 -----------------------------------------
4408 -- Statement_When_Declaration_Expected --
4409 -----------------------------------------
4411 procedure Statement_When_Declaration_Expected
4417 -- Case of second occurrence of statement in one declaration sequence
4419 if Missing_Begin_Msg
/= No_Error_Msg
then
4421 -- In the procedure spec case, just ignore it, we only give one
4422 -- message for the first occurrence, since otherwise we may get
4423 -- horrible cascading if BODY was missing in the header line.
4428 -- In the declarative part case, take a second statement as a sure
4429 -- sign that we really have a missing BEGIN, and end the declarative
4430 -- part now. Note that the caller will fix up the first message to
4431 -- say "missing BEGIN" so that's how the error will be signalled.
4438 -- Case of first occurrence of unexpected statement
4441 -- If we are in a package spec, then give message of statement
4442 -- not allowed in package spec. This message never gets changed.
4445 Error_Msg_SC
("statement not allowed in package spec");
4447 -- If in declarative part, then we give the message complaining
4448 -- about finding a statement when a declaration is expected. This
4449 -- gets changed to a complaint about a missing BEGIN if we later
4450 -- find that no BEGIN is present.
4453 Error_Msg_SC
("statement not allowed in declarative part");
4456 -- Capture message Id. This is used for two purposes, first to
4457 -- stop multiple messages, see test above, and second, to allow
4458 -- the replacement of the message in the declarative part case.
4460 Missing_Begin_Msg
:= Get_Msg_Id
;
4463 -- In all cases except the case in which we decided to terminate the
4464 -- declaration sequence on a second error, we scan out the statement
4465 -- and append it to the list of declarations (note that the semantics
4466 -- can handle statements in a declaration list so if we proceed to
4467 -- call the semantic phase, all will be (reasonably) well!
4469 Append_List_To
(Decls
, P_Sequence_Of_Statements
(SS_Unco
));
4471 -- Done is set to False, since we want to continue the scan of
4472 -- declarations, hoping that this statement was a temporary glitch.
4473 -- If we indeed are now in the statement part (i.e. this was a missing
4474 -- BEGIN, then it's not terrible, we will simply keep calling this
4475 -- procedure to process the statements one by one, and then finally
4476 -- hit the missing BEGIN, which will clean up the error message.
4479 end Statement_When_Declaration_Expected
;