1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2002, 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 if Token
= Tok_Colon_Equal
101 or else Token
= Tok_Equal
102 or else Token
= Tok_Colon
103 or else Token
= Tok_Is
107 -- One other possibility. If we have a literal followed by a semicolon,
108 -- we assume that we have a missing colon-equal.
110 elsif Token
in Token_Class_Literal
then
112 Scan_State
: Saved_Scan_State
;
115 Save_Scan_State
(Scan_State
);
116 Scan
; -- past literal or identifier
118 if Token
= Tok_Semicolon
then
119 Restore_Scan_State
(Scan_State
);
121 Restore_Scan_State
(Scan_State
);
126 -- Otherwise we definitely have no initialization expression
132 -- Merge here if we have an initialization expression
139 return P_Expression_No_Right_Paren
;
143 ----------------------------
144 -- 3.1 Basic Declaration --
145 ----------------------------
147 -- Parsed by P_Basic_Declarative_Items (3.9)
149 ------------------------------
150 -- 3.1 Defining Identifier --
151 ------------------------------
153 -- DEFINING_IDENTIFIER ::= IDENTIFIER
155 -- Error recovery: can raise Error_Resync
157 function P_Defining_Identifier
return Node_Id
is
158 Ident_Node
: Node_Id
;
161 -- Scan out the identifier. Note that this code is essentially identical
162 -- to P_Identifier, except that in the call to Scan_Reserved_Identifier
163 -- we set Force_Msg to True, since we want at least one message for each
164 -- separate declaration (but not use) of a reserved identifier.
166 if Token
= Tok_Identifier
then
169 -- If we have a reserved identifier, manufacture an identifier with
170 -- a corresponding name after posting an appropriate error message
172 elsif Is_Reserved_Identifier
then
173 Scan_Reserved_Identifier
(Force_Msg
=> True);
175 -- Otherwise we have junk that cannot be interpreted as an identifier
178 T_Identifier
; -- to give message
182 Ident_Node
:= Token_Node
;
183 Scan
; -- past the reserved identifier
185 if Ident_Node
/= Error
then
186 Change_Identifier_To_Defining_Identifier
(Ident_Node
);
190 end P_Defining_Identifier
;
192 -----------------------------
193 -- 3.2.1 Type Declaration --
194 -----------------------------
196 -- TYPE_DECLARATION ::=
197 -- FULL_TYPE_DECLARATION
198 -- | INCOMPLETE_TYPE_DECLARATION
199 -- | PRIVATE_TYPE_DECLARATION
200 -- | PRIVATE_EXTENSION_DECLARATION
202 -- FULL_TYPE_DECLARATION ::=
203 -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION;
204 -- | CONCURRENT_TYPE_DECLARATION
206 -- INCOMPLETE_TYPE_DECLARATION ::=
207 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART];
209 -- PRIVATE_TYPE_DECLARATION ::=
210 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
211 -- is [abstract] [tagged] [limited] private;
213 -- PRIVATE_EXTENSION_DECLARATION ::=
214 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
215 -- [abstract] new ancestor_SUBTYPE_INDICATION with private;
217 -- TYPE_DEFINITION ::=
218 -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
219 -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION
220 -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION
221 -- | DERIVED_TYPE_DEFINITION
223 -- INTEGER_TYPE_DEFINITION ::=
224 -- SIGNED_INTEGER_TYPE_DEFINITION
225 -- MODULAR_TYPE_DEFINITION
227 -- Error recovery: can raise Error_Resync
229 -- Note: The processing for full type declaration, incomplete type
230 -- declaration, private type declaration and type definition is
231 -- included in this function. The processing for concurrent type
232 -- declarations is NOT here, but rather in chapter 9 (i.e. this
233 -- function handles only declarations starting with TYPE).
235 function P_Type_Declaration
return Node_Id
is
236 Type_Loc
: Source_Ptr
;
237 Type_Start_Col
: Column_Number
;
238 Ident_Node
: Node_Id
;
240 Discr_List
: List_Id
;
241 Unknown_Dis
: Boolean;
242 Discr_Sloc
: Source_Ptr
;
243 Abstract_Present
: Boolean;
244 Abstract_Loc
: Source_Ptr
;
247 Typedef_Node
: Node_Id
;
248 -- Normally holds type definition, except in the case of a private
249 -- extension declaration, in which case it holds the declaration itself
252 Type_Loc
:= Token_Ptr
;
253 Type_Start_Col
:= Start_Column
;
255 Ident_Node
:= P_Defining_Identifier
;
256 Discr_Sloc
:= Token_Ptr
;
258 if P_Unknown_Discriminant_Part_Opt
then
260 Discr_List
:= No_List
;
262 Unknown_Dis
:= False;
263 Discr_List
:= P_Known_Discriminant_Part_Opt
;
266 -- Incomplete type declaration. We complete the processing for this
267 -- case here and return the resulting incomplete type declaration node
269 if Token
= Tok_Semicolon
then
271 Decl_Node
:= New_Node
(N_Incomplete_Type_Declaration
, Type_Loc
);
272 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
273 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
274 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
281 -- Full type declaration or private type declaration, must have IS
283 if Token
= Tok_Equal
then
285 Scan
; -- past = used in place of IS
287 elsif Token
= Tok_Renames
then
288 Error_Msg_SC
("RENAMES should be IS");
289 Scan
; -- past RENAMES used in place of IS
295 -- First an error check, if we have two identifiers in a row, a likely
296 -- possibility is that the first of the identifiers is an incorrectly
299 if Token
= Tok_Identifier
then
301 SS
: Saved_Scan_State
;
305 Save_Scan_State
(SS
);
306 Scan
; -- past initial identifier
307 I2
:= (Token
= Tok_Identifier
);
308 Restore_Scan_State
(SS
);
312 (Bad_Spelling_Of
(Tok_Abstract
) or else
313 Bad_Spelling_Of
(Tok_Access
) or else
314 Bad_Spelling_Of
(Tok_Aliased
) or else
315 Bad_Spelling_Of
(Tok_Constant
))
322 -- Check for misuse of Ada 95 keyword abstract in Ada 83 mode
324 if Token_Name
= Name_Abstract
then
325 Check_95_Keyword
(Tok_Abstract
, Tok_Tagged
);
326 Check_95_Keyword
(Tok_Abstract
, Tok_New
);
329 -- Check cases of misuse of ABSTRACT
331 if Token
= Tok_Abstract
then
332 Abstract_Present
:= True;
333 Abstract_Loc
:= Token_Ptr
;
334 Scan
; -- past ABSTRACT
336 if Token
= Tok_Limited
337 or else Token
= Tok_Private
338 or else Token
= Tok_Record
339 or else Token
= Tok_Null
341 Error_Msg_AP
("TAGGED expected");
345 Abstract_Present
:= False;
346 Abstract_Loc
:= No_Location
;
349 -- Check for misuse of Ada 95 keyword Tagged
351 if Token_Name
= Name_Tagged
then
352 Check_95_Keyword
(Tok_Tagged
, Tok_Private
);
353 Check_95_Keyword
(Tok_Tagged
, Tok_Limited
);
354 Check_95_Keyword
(Tok_Tagged
, Tok_Record
);
357 -- Special check for misuse of Aliased
359 if Token
= Tok_Aliased
or else Token_Name
= Name_Aliased
then
360 Error_Msg_SC
("ALIASED not allowed in type definition");
361 Scan
; -- past ALIASED
364 -- The following procesing deals with either a private type declaration
365 -- or a full type declaration. In the private type case, we build the
366 -- N_Private_Type_Declaration node, setting its Tagged_Present and
367 -- Limited_Present flags, on encountering the Private keyword, and
368 -- leave Typedef_Node set to Empty. For the full type declaration
369 -- case, Typedef_Node gets set to the type definition.
371 Typedef_Node
:= Empty
;
373 -- Switch on token following the IS. The loop normally runs once. It
374 -- only runs more than once if an error is detected, to try again after
375 -- detecting and fixing up the error.
381 Typedef_Node
:= P_Access_Type_Definition
;
386 Typedef_Node
:= P_Array_Type_Definition
;
391 Typedef_Node
:= P_Fixed_Point_Definition
;
396 Typedef_Node
:= P_Floating_Point_Definition
;
403 when Tok_Integer_Literal
=>
405 Typedef_Node
:= P_Signed_Integer_Type_Definition
;
410 Typedef_Node
:= P_Record_Definition
;
414 when Tok_Left_Paren
=>
415 Typedef_Node
:= P_Enumeration_Type_Definition
;
418 Make_Identifier
(Token_Ptr
,
419 Chars
=> Chars
(Ident_Node
));
420 Set_Comes_From_Source
(End_Labl
, False);
422 Set_End_Label
(Typedef_Node
, End_Labl
);
427 Typedef_Node
:= P_Modular_Type_Definition
;
432 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
437 Typedef_Node
:= P_Signed_Integer_Type_Definition
;
442 Typedef_Node
:= P_Record_Definition
;
445 Make_Identifier
(Token_Ptr
,
446 Chars
=> Chars
(Ident_Node
));
447 Set_Comes_From_Source
(End_Labl
, False);
449 Set_End_Label
(Typedef_Node
, End_Labl
);
456 if Token
= Tok_Abstract
then
457 Error_Msg_SC
("ABSTRACT must come before TAGGED");
458 Abstract_Present
:= True;
459 Abstract_Loc
:= Token_Ptr
;
460 Scan
; -- past ABSTRACT
463 if Token
= Tok_Limited
then
464 Scan
; -- past LIMITED
466 -- TAGGED LIMITED PRIVATE case
468 if Token
= Tok_Private
then
470 New_Node
(N_Private_Type_Declaration
, Type_Loc
);
471 Set_Tagged_Present
(Decl_Node
, True);
472 Set_Limited_Present
(Decl_Node
, True);
473 Scan
; -- past PRIVATE
475 -- TAGGED LIMITED RECORD
478 Typedef_Node
:= P_Record_Definition
;
479 Set_Tagged_Present
(Typedef_Node
, True);
480 Set_Limited_Present
(Typedef_Node
, True);
483 Make_Identifier
(Token_Ptr
,
484 Chars
=> Chars
(Ident_Node
));
485 Set_Comes_From_Source
(End_Labl
, False);
487 Set_End_Label
(Typedef_Node
, End_Labl
);
493 if Token
= Tok_Private
then
495 New_Node
(N_Private_Type_Declaration
, Type_Loc
);
496 Set_Tagged_Present
(Decl_Node
, True);
497 Scan
; -- past PRIVATE
502 Typedef_Node
:= P_Record_Definition
;
503 Set_Tagged_Present
(Typedef_Node
, True);
506 Make_Identifier
(Token_Ptr
,
507 Chars
=> Chars
(Ident_Node
));
508 Set_Comes_From_Source
(End_Labl
, False);
510 Set_End_Label
(Typedef_Node
, End_Labl
);
518 Decl_Node
:= New_Node
(N_Private_Type_Declaration
, Type_Loc
);
519 Scan
; -- past PRIVATE
524 Scan
; -- past LIMITED
527 if Token
= Tok_Tagged
then
528 Error_Msg_SC
("TAGGED must come before LIMITED");
531 elsif Token
= Tok_Abstract
then
532 Error_Msg_SC
("ABSTRACT must come before LIMITED");
533 Scan
; -- past ABSTRACT
540 -- LIMITED RECORD or LIMITED NULL RECORD
542 if Token
= Tok_Record
or else Token
= Tok_Null
then
545 ("(Ada 83) limited record declaration not allowed!");
548 Typedef_Node
:= P_Record_Definition
;
549 Set_Limited_Present
(Typedef_Node
, True);
551 -- LIMITED PRIVATE is the only remaining possibility here
554 Decl_Node
:= New_Node
(N_Private_Type_Declaration
, Type_Loc
);
555 Set_Limited_Present
(Decl_Node
, True);
556 T_Private
; -- past PRIVATE (or complain if not there!)
562 -- Here we have an identifier after the IS, which is certainly
563 -- wrong and which might be one of several different mistakes.
565 when Tok_Identifier
=>
567 -- First case, if identifier is on same line, then probably we
568 -- have something like "type X is Integer .." and the best
569 -- diagnosis is a missing NEW. Note: the missing new message
570 -- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl.
572 if not Token_Is_At_Start_Of_Line
then
573 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
576 -- If the identifier is at the start of the line, and is in the
577 -- same column as the type declaration itself then we consider
578 -- that we had a missing type definition on the previous line
580 elsif Start_Column
<= Type_Start_Col
then
581 Error_Msg_AP
("type definition expected");
582 Typedef_Node
:= Error
;
584 -- If the identifier is at the start of the line, and is in
585 -- a column to the right of the type declaration line, then we
586 -- may have something like:
591 -- and the best diagnosis is a missing record keyword
594 Typedef_Node
:= P_Record_Definition
;
600 -- Anything else is an error
603 if Bad_Spelling_Of
(Tok_Access
)
605 Bad_Spelling_Of
(Tok_Array
)
607 Bad_Spelling_Of
(Tok_Delta
)
609 Bad_Spelling_Of
(Tok_Digits
)
611 Bad_Spelling_Of
(Tok_Limited
)
613 Bad_Spelling_Of
(Tok_Private
)
615 Bad_Spelling_Of
(Tok_Range
)
617 Bad_Spelling_Of
(Tok_Record
)
619 Bad_Spelling_Of
(Tok_Tagged
)
624 Error_Msg_AP
("type definition expected");
631 -- For the private type declaration case, the private type declaration
632 -- node has been built, with the Tagged_Present and Limited_Present
633 -- flags set as needed, and Typedef_Node is left set to Empty.
635 if No
(Typedef_Node
) then
636 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
637 Set_Abstract_Present
(Decl_Node
, Abstract_Present
);
639 -- For a private extension declaration, Typedef_Node contains the
640 -- N_Private_Extension_Declaration node, which we now complete. Note
641 -- that the private extension declaration, unlike a full type
642 -- declaration, does permit unknown discriminants.
644 elsif Nkind
(Typedef_Node
) = N_Private_Extension_Declaration
then
645 Decl_Node
:= Typedef_Node
;
646 Set_Sloc
(Decl_Node
, Type_Loc
);
647 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
648 Set_Abstract_Present
(Typedef_Node
, Abstract_Present
);
650 -- In the full type declaration case, Typedef_Node has the type
651 -- definition and here is where we build the full type declaration
652 -- node. This is also where we check for improper use of an unknown
653 -- discriminant part (not allowed for full type declaration).
656 if Nkind
(Typedef_Node
) = N_Record_Definition
657 or else (Nkind
(Typedef_Node
) = N_Derived_Type_Definition
658 and then Present
(Record_Extension_Part
(Typedef_Node
)))
660 Set_Abstract_Present
(Typedef_Node
, Abstract_Present
);
662 elsif Abstract_Present
then
663 Error_Msg
("ABSTRACT not allowed here, ignored", Abstract_Loc
);
666 Decl_Node
:= New_Node
(N_Full_Type_Declaration
, Type_Loc
);
667 Set_Type_Definition
(Decl_Node
, Typedef_Node
);
671 ("Full type declaration cannot have unknown discriminants",
676 -- Remaining processing is common for all three cases
678 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
679 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
682 end P_Type_Declaration
;
684 ----------------------------------
685 -- 3.2.1 Full Type Declaration --
686 ----------------------------------
688 -- Parsed by P_Type_Declaration (3.2.1)
690 ----------------------------
691 -- 3.2.1 Type Definition --
692 ----------------------------
694 -- Parsed by P_Type_Declaration (3.2.1)
696 --------------------------------
697 -- 3.2.2 Subtype Declaration --
698 --------------------------------
700 -- SUBTYPE_DECLARATION ::=
701 -- subtype DEFINING_IDENTIFIER is SUBTYPE_INDICATION;
703 -- The caller has checked that the initial token is SUBTYPE
705 -- Error recovery: can raise Error_Resync
707 function P_Subtype_Declaration
return Node_Id
is
711 Decl_Node
:= New_Node
(N_Subtype_Declaration
, Token_Ptr
);
712 Scan
; -- past SUBTYPE
713 Set_Defining_Identifier
(Decl_Node
, P_Defining_Identifier
);
716 if Token
= Tok_New
then
717 Error_Msg_SC
("NEW ignored (only allowed in type declaration)");
721 Set_Subtype_Indication
(Decl_Node
, P_Subtype_Indication
);
724 end P_Subtype_Declaration
;
726 -------------------------------
727 -- 3.2.2 Subtype Indication --
728 -------------------------------
730 -- SUBTYPE_INDICATION ::= SUBTYPE_MARK [CONSTRAINT]
732 -- Error recovery: can raise Error_Resync
734 function P_Subtype_Indication
return Node_Id
is
738 if Token
= Tok_Identifier
or else Token
= Tok_Operator_Symbol
then
739 Type_Node
:= P_Subtype_Mark
;
740 return P_Subtype_Indication
(Type_Node
);
743 -- Check for error of using record definition and treat it nicely,
744 -- otherwise things are really messed up, so resynchronize.
746 if Token
= Tok_Record
then
747 Error_Msg_SC
("anonymous record definitions are not permitted");
748 Discard_Junk_Node
(P_Record_Definition
);
752 Error_Msg_AP
("subtype indication expected");
756 end P_Subtype_Indication
;
758 -- The following function is identical except that it is called with
759 -- the subtype mark already scanned out, and it scans out the constraint
761 -- Error recovery: can raise Error_Resync
763 function P_Subtype_Indication
(Subtype_Mark
: Node_Id
) return Node_Id
is
764 Indic_Node
: Node_Id
;
765 Constr_Node
: Node_Id
;
768 Constr_Node
:= P_Constraint_Opt
;
770 if No
(Constr_Node
) then
773 Indic_Node
:= New_Node
(N_Subtype_Indication
, Sloc
(Subtype_Mark
));
774 Set_Subtype_Mark
(Indic_Node
, Check_Subtype_Mark
(Subtype_Mark
));
775 Set_Constraint
(Indic_Node
, Constr_Node
);
779 end P_Subtype_Indication
;
781 -------------------------
782 -- 3.2.2 Subtype Mark --
783 -------------------------
785 -- SUBTYPE_MARK ::= subtype_NAME;
787 -- Note: The subtype mark which appears after an IN or NOT IN
788 -- operator is parsed by P_Range_Or_Subtype_Mark (3.5)
790 -- Error recovery: cannot raise Error_Resync
792 function P_Subtype_Mark
return Node_Id
is
794 return P_Subtype_Mark_Resync
;
801 -- This routine differs from P_Subtype_Mark in that it insists that an
802 -- identifier be present, and if it is not, it raises Error_Resync.
804 -- Error recovery: can raise Error_Resync
806 function P_Subtype_Mark_Resync
return Node_Id
is
810 if Token
= Tok_Access
then
811 Error_Msg_SC
("anonymous access type definition not allowed here");
815 if Token
= Tok_Array
then
816 Error_Msg_SC
("anonymous array definition not allowed here");
817 Discard_Junk_Node
(P_Array_Type_Definition
);
821 Type_Node
:= P_Qualified_Simple_Name_Resync
;
823 -- Check for a subtype mark attribute. The only valid possibilities
824 -- are 'CLASS and 'BASE. Anything else is a definite error. We may
825 -- as well catch it here.
827 if Token
= Tok_Apostrophe
then
828 return P_Subtype_Mark_Attribute
(Type_Node
);
833 end P_Subtype_Mark_Resync
;
835 -- The following function is called to scan out a subtype mark attribute.
836 -- The caller has already scanned out the subtype mark, which is passed in
837 -- as the argument, and has checked that the current token is apostrophe.
839 -- Only a special subclass of attributes, called type attributes
840 -- (see Snames package) are allowed in this syntactic position.
842 -- Note: if the apostrophe is followed by other than an identifier, then
843 -- the input expression is returned unchanged, and the scan pointer is
844 -- left pointing to the apostrophe.
846 -- Error recovery: can raise Error_Resync
848 function P_Subtype_Mark_Attribute
(Type_Node
: Node_Id
) return Node_Id
is
849 Attr_Node
: Node_Id
:= Empty
;
850 Scan_State
: Saved_Scan_State
;
854 Prefix
:= Check_Subtype_Mark
(Type_Node
);
856 if Prefix
= Error
then
860 -- Loop through attributes appearing (more than one can appear as for
861 -- for example in X'Base'Class). We are at an apostrophe on entry to
862 -- this loop, and it runs once for each attribute parsed, with
863 -- Prefix being the current possible prefix if it is an attribute.
866 Save_Scan_State
(Scan_State
); -- at Apostrophe
867 Scan
; -- past apostrophe
869 if Token
/= Tok_Identifier
then
870 Restore_Scan_State
(Scan_State
); -- to apostrophe
871 return Prefix
; -- no attribute after all
873 elsif not Is_Type_Attribute_Name
(Token_Name
) then
875 ("attribute & may not be used in a subtype mark", Token_Node
);
880 Make_Attribute_Reference
(Prev_Token_Ptr
,
882 Attribute_Name
=> Token_Name
);
883 Delete_Node
(Token_Node
);
884 Scan
; -- past type attribute identifier
887 exit when Token
/= Tok_Apostrophe
;
891 -- Fall through here after scanning type attribute
894 end P_Subtype_Mark_Attribute
;
896 -----------------------
897 -- 3.2.2 Constraint --
898 -----------------------
900 -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
902 -- SCALAR_CONSTRAINT ::=
903 -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
905 -- COMPOSITE_CONSTRAINT ::=
906 -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
908 -- If no constraint is present, this function returns Empty
910 -- Error recovery: can raise Error_Resync
912 function P_Constraint_Opt
return Node_Id
is
915 or else Bad_Spelling_Of
(Tok_Range
)
917 return P_Range_Constraint
;
919 elsif Token
= Tok_Digits
920 or else Bad_Spelling_Of
(Tok_Digits
)
922 return P_Digits_Constraint
;
924 elsif Token
= Tok_Delta
925 or else Bad_Spelling_Of
(Tok_Delta
)
927 return P_Delta_Constraint
;
929 elsif Token
= Tok_Left_Paren
then
930 return P_Index_Or_Discriminant_Constraint
;
932 elsif Token
= Tok_In
then
934 return P_Constraint_Opt
;
940 end P_Constraint_Opt
;
942 ------------------------------
943 -- 3.2.2 Scalar Constraint --
944 ------------------------------
946 -- Parsed by P_Constraint_Opt (3.2.2)
948 ---------------------------------
949 -- 3.2.2 Composite Constraint --
950 ---------------------------------
952 -- Parsed by P_Constraint_Opt (3.2.2)
954 --------------------------------------------------------
955 -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) --
956 --------------------------------------------------------
958 -- This routine scans out a declaration starting with an identifier:
960 -- OBJECT_DECLARATION ::=
961 -- DEFINING_IDENTIFIER_LIST : [constant] [aliased]
962 -- SUBTYPE_INDICATION [:= EXPRESSION];
963 -- | DEFINING_IDENTIFIER_LIST : [constant] [aliased]
964 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
966 -- NUMBER_DECLARATION ::=
967 -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
969 -- OBJECT_RENAMING_DECLARATION ::=
970 -- DEFINING_IDENTIFIER : SUBTYPE_MARK renames object_NAME;
972 -- EXCEPTION_RENAMING_DECLARATION ::=
973 -- DEFINING_IDENTIFIER : exception renames exception_NAME;
975 -- EXCEPTION_DECLARATION ::=
976 -- DEFINING_IDENTIFIER_LIST : exception;
978 -- Note that the ALIASED indication in an object declaration is
979 -- marked by a flag in the parent node.
981 -- The caller has checked that the initial token is an identifier
983 -- The value returned is a list of declarations, one for each identifier
984 -- in the list (as described in Sinfo, we always split up multiple
985 -- declarations into the equivalent sequence of single declarations
986 -- using the More_Ids and Prev_Ids flags to preserve the source).
988 -- If the identifier turns out to be a probable statement rather than
989 -- an identifier, then the scan is left pointing to the identifier and
990 -- No_List is returned.
992 -- Error recovery: can raise Error_Resync
994 procedure P_Identifier_Declarations
1000 Type_Node
: Node_Id
;
1001 Ident_Sloc
: Source_Ptr
;
1002 Scan_State
: Saved_Scan_State
;
1003 List_OK
: Boolean := True;
1005 Init_Expr
: Node_Id
;
1006 Init_Loc
: Source_Ptr
;
1007 Con_Loc
: Source_Ptr
;
1009 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
1010 -- Used to save identifiers in the identifier list. The upper bound
1011 -- of 4096 is expected to be infinite in practice, and we do not even
1012 -- bother to check if this upper bound is exceeded.
1014 Num_Idents
: Nat
:= 1;
1015 -- Number of identifiers stored in Idents
1018 -- This procedure is called in renames cases to make sure that we do
1019 -- not have more than one identifier. If we do have more than one
1020 -- then an error message is issued (and the declaration is split into
1021 -- multiple declarations)
1023 function Token_Is_Renames
return Boolean;
1024 -- Checks if current token is RENAMES, and if so, scans past it and
1025 -- returns True, otherwise returns False. Includes checking for some
1026 -- common error cases.
1028 procedure No_List
is
1030 if Num_Idents
> 1 then
1031 Error_Msg
("identifier list not allowed for RENAMES",
1038 function Token_Is_Renames
return Boolean is
1039 At_Colon
: Saved_Scan_State
;
1042 if Token
= Tok_Colon
then
1043 Save_Scan_State
(At_Colon
);
1045 Check_Misspelling_Of
(Tok_Renames
);
1047 if Token
= Tok_Renames
then
1048 Error_Msg_SP
("extra "":"" ignored");
1049 Scan
; -- past RENAMES
1052 Restore_Scan_State
(At_Colon
);
1057 Check_Misspelling_Of
(Tok_Renames
);
1059 if Token
= Tok_Renames
then
1060 Scan
; -- past RENAMES
1066 end Token_Is_Renames
;
1068 -- Start of processing for P_Identifier_Declarations
1071 Ident_Sloc
:= Token_Ptr
;
1072 Save_Scan_State
(Scan_State
); -- at first identifier
1073 Idents
(1) := P_Defining_Identifier
;
1075 -- If we have a colon after the identifier, then we can assume that
1076 -- this is in fact a valid identifier declaration and can steam ahead.
1078 if Token
= Tok_Colon
then
1081 -- If we have a comma, then scan out the list of identifiers
1083 elsif Token
= Tok_Comma
then
1085 while Comma_Present
loop
1086 Num_Idents
:= Num_Idents
+ 1;
1087 Idents
(Num_Idents
) := P_Defining_Identifier
;
1090 Save_Scan_State
(Scan_State
); -- at colon
1093 -- If we have identifier followed by := then we assume that what is
1094 -- really meant is an assignment statement. The assignment statement
1095 -- is scanned out and added to the list of declarations. An exception
1096 -- occurs if the := is followed by the keyword constant, in which case
1097 -- we assume it was meant to be a colon.
1099 elsif Token
= Tok_Colon_Equal
then
1102 if Token
= Tok_Constant
then
1103 Error_Msg_SP
("colon expected");
1106 Restore_Scan_State
(Scan_State
);
1107 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
1111 -- If we have an IS keyword, then assume the TYPE keyword was missing
1113 elsif Token
= Tok_Is
then
1114 Restore_Scan_State
(Scan_State
);
1115 Append_To
(Decls
, P_Type_Declaration
);
1119 -- Otherwise we have an error situation
1122 Restore_Scan_State
(Scan_State
);
1124 -- First case is possible misuse of PROTECTED in Ada 83 mode. If
1125 -- so, fix the keyword and return to scan the protected declaration.
1127 if Token_Name
= Name_Protected
then
1128 Check_95_Keyword
(Tok_Protected
, Tok_Identifier
);
1129 Check_95_Keyword
(Tok_Protected
, Tok_Type
);
1130 Check_95_Keyword
(Tok_Protected
, Tok_Body
);
1132 if Token
= Tok_Protected
then
1137 -- Check misspelling possibilities. If so, correct the misspelling
1138 -- and return to scan out the resulting declaration.
1140 elsif Bad_Spelling_Of
(Tok_Function
)
1141 or else Bad_Spelling_Of
(Tok_Procedure
)
1142 or else Bad_Spelling_Of
(Tok_Package
)
1143 or else Bad_Spelling_Of
(Tok_Pragma
)
1144 or else Bad_Spelling_Of
(Tok_Protected
)
1145 or else Bad_Spelling_Of
(Tok_Generic
)
1146 or else Bad_Spelling_Of
(Tok_Subtype
)
1147 or else Bad_Spelling_Of
(Tok_Type
)
1148 or else Bad_Spelling_Of
(Tok_Task
)
1149 or else Bad_Spelling_Of
(Tok_Use
)
1150 or else Bad_Spelling_Of
(Tok_For
)
1155 -- Otherwise we definitely have an ordinary identifier with a junk
1156 -- token after it. Just complain that we expect a declaration, and
1157 -- skip to a semicolon
1160 Set_Declaration_Expected
;
1161 Resync_Past_Semicolon
;
1167 -- Come here with an identifier list and colon scanned out. We now
1168 -- build the nodes for the declarative items. One node is built for
1169 -- each identifier in the list, with the type information being
1170 -- repeated by rescanning the appropriate section of source.
1172 -- First an error check, if we have two identifiers in a row, a likely
1173 -- possibility is that the first of the identifiers is an incorrectly
1176 if Token
= Tok_Identifier
then
1178 SS
: Saved_Scan_State
;
1182 Save_Scan_State
(SS
);
1183 Scan
; -- past initial identifier
1184 I2
:= (Token
= Tok_Identifier
);
1185 Restore_Scan_State
(SS
);
1189 (Bad_Spelling_Of
(Tok_Access
) or else
1190 Bad_Spelling_Of
(Tok_Aliased
) or else
1191 Bad_Spelling_Of
(Tok_Constant
))
1198 -- Loop through identifiers
1203 -- Check for some cases of misused Ada 95 keywords
1205 if Token_Name
= Name_Aliased
then
1206 Check_95_Keyword
(Tok_Aliased
, Tok_Array
);
1207 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
1208 Check_95_Keyword
(Tok_Aliased
, Tok_Constant
);
1213 if Token
= Tok_Constant
then
1214 Con_Loc
:= Token_Ptr
;
1215 Scan
; -- past CONSTANT
1217 -- Number declaration, initialization required
1219 Init_Expr
:= Init_Expr_Opt
;
1221 if Present
(Init_Expr
) then
1222 Decl_Node
:= New_Node
(N_Number_Declaration
, Ident_Sloc
);
1223 Set_Expression
(Decl_Node
, Init_Expr
);
1225 -- Constant object declaration
1228 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1229 Set_Constant_Present
(Decl_Node
, True);
1231 if Token_Name
= Name_Aliased
then
1232 Check_95_Keyword
(Tok_Aliased
, Tok_Array
);
1233 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
1236 if Token
= Tok_Aliased
then
1237 Error_Msg_SC
("ALIASED should be before CONSTANT");
1238 Scan
; -- past ALIASED
1239 Set_Aliased_Present
(Decl_Node
, True);
1242 if Token
= Tok_Array
then
1243 Set_Object_Definition
1244 (Decl_Node
, P_Array_Type_Definition
);
1246 Set_Object_Definition
(Decl_Node
, P_Subtype_Indication
);
1249 if Token
= Tok_Renames
then
1251 ("CONSTANT not permitted in renaming declaration",
1253 Scan
; -- Past renames
1254 Discard_Junk_Node
(P_Name
);
1260 elsif Token
= Tok_Exception
then
1261 Scan
; -- past EXCEPTION
1263 if Token_Is_Renames
then
1266 New_Node
(N_Exception_Renaming_Declaration
, Ident_Sloc
);
1267 Set_Name
(Decl_Node
, P_Qualified_Simple_Name_Resync
);
1270 Decl_Node
:= New_Node
(N_Exception_Declaration
, Prev_Token_Ptr
);
1273 -- Aliased case (note that an object definition is required)
1275 elsif Token
= Tok_Aliased
then
1276 Scan
; -- past ALIASED
1277 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1278 Set_Aliased_Present
(Decl_Node
, True);
1280 if Token
= Tok_Constant
then
1281 Scan
; -- past CONSTANT
1282 Set_Constant_Present
(Decl_Node
, True);
1285 if Token
= Tok_Array
then
1286 Set_Object_Definition
1287 (Decl_Node
, P_Array_Type_Definition
);
1289 Set_Object_Definition
(Decl_Node
, P_Subtype_Indication
);
1294 elsif Token
= Tok_Array
then
1295 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1296 Set_Object_Definition
(Decl_Node
, P_Array_Type_Definition
);
1298 -- Subtype indication case
1301 Type_Node
:= P_Subtype_Mark
;
1303 -- Object renaming declaration
1305 if Token_Is_Renames
then
1308 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1309 Set_Subtype_Mark
(Decl_Node
, Type_Node
);
1310 Set_Name
(Decl_Node
, P_Name
);
1312 -- Object declaration
1315 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1316 Set_Object_Definition
1317 (Decl_Node
, P_Subtype_Indication
(Type_Node
));
1319 -- RENAMES at this point means that we had the combination of
1320 -- a constraint on the Type_Node and renames, which is illegal
1322 if Token_Is_Renames
then
1324 ("constraint not allowed in object renaming declaration",
1325 Constraint
(Object_Definition
(Decl_Node
)));
1331 -- Scan out initialization, allowed only for object declaration
1333 Init_Loc
:= Token_Ptr
;
1334 Init_Expr
:= Init_Expr_Opt
;
1336 if Present
(Init_Expr
) then
1337 if Nkind
(Decl_Node
) = N_Object_Declaration
then
1338 Set_Expression
(Decl_Node
, Init_Expr
);
1340 Error_Msg
("initialization not allowed here", Init_Loc
);
1345 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
1348 if Ident
< Num_Idents
then
1349 Set_More_Ids
(Decl_Node
, True);
1353 Set_Prev_Ids
(Decl_Node
, True);
1357 Append
(Decl_Node
, Decls
);
1358 exit Ident_Loop
when Ident
= Num_Idents
;
1359 Restore_Scan_State
(Scan_State
);
1362 end loop Ident_Loop
;
1366 end P_Identifier_Declarations
;
1368 -------------------------------
1369 -- 3.3.1 Object Declaration --
1370 -------------------------------
1372 -- OBJECT DECLARATION ::=
1373 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1374 -- SUBTYPE_INDICATION [:= EXPRESSION];
1375 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1376 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1377 -- | SINGLE_TASK_DECLARATION
1378 -- | SINGLE_PROTECTED_DECLARATION
1380 -- Cases starting with TASK are parsed by P_Task (9.1)
1381 -- Cases starting with PROTECTED are parsed by P_Protected (9.4)
1382 -- All other cases are parsed by P_Identifier_Declarations (3.3)
1384 -------------------------------------
1385 -- 3.3.1 Defining Identifier List --
1386 -------------------------------------
1388 -- DEFINING_IDENTIFIER_LIST ::=
1389 -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
1391 -- Always parsed by the construct in which it appears. See special
1392 -- section on "Handling of Defining Identifier Lists" in this unit.
1394 -------------------------------
1395 -- 3.3.2 Number Declaration --
1396 -------------------------------
1398 -- Parsed by P_Identifier_Declarations (3.3)
1400 -------------------------------------------------------------------------
1401 -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) --
1402 -------------------------------------------------------------------------
1404 -- DERIVED_TYPE_DEFINITION ::=
1405 -- [abstract] new parent_SUBTYPE_INDICATION [RECORD_EXTENSION_PART]
1407 -- PRIVATE_EXTENSION_DECLARATION ::=
1408 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
1409 -- [abstract] new ancestor_SUBTYPE_INDICATION with PRIVATE;
1411 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
1413 -- The caller has already scanned out the part up to the NEW, and Token
1414 -- either contains Tok_New (or ought to, if it doesn't this procedure
1415 -- will post an appropriate "NEW expected" message).
1417 -- Note: the caller is responsible for filling in the Sloc field of
1418 -- the returned node in the private extension declaration case as
1419 -- well as the stuff relating to the discriminant part.
1421 -- Error recovery: can raise Error_Resync;
1423 function P_Derived_Type_Def_Or_Private_Ext_Decl
return Node_Id
is
1424 Typedef_Node
: Node_Id
;
1425 Typedecl_Node
: Node_Id
;
1428 Typedef_Node
:= New_Node
(N_Derived_Type_Definition
, Token_Ptr
);
1431 if Token
= Tok_Abstract
then
1432 Error_Msg_SC
("ABSTRACT must come before NEW, not after");
1436 Set_Subtype_Indication
(Typedef_Node
, P_Subtype_Indication
);
1438 -- Deal with record extension, note that we assume that a WITH is
1439 -- missing in the case of "type X is new Y record ..." or in the
1440 -- case of "type X is new Y null record".
1443 or else Token
= Tok_Record
1444 or else Token
= Tok_Null
1446 T_With
; -- past WITH or give error message
1448 if Token
= Tok_Limited
then
1450 ("LIMITED keyword not allowed in private extension");
1451 Scan
; -- ignore LIMITED
1454 -- Private extension declaration
1456 if Token
= Tok_Private
then
1457 Scan
; -- past PRIVATE
1459 -- Throw away the type definition node and build the type
1460 -- declaration node. Note the caller must set the Sloc,
1461 -- Discriminant_Specifications, Unknown_Discriminants_Present,
1462 -- and Defined_Identifier fields in the returned node.
1465 Make_Private_Extension_Declaration
(No_Location
,
1466 Defining_Identifier
=> Empty
,
1467 Subtype_Indication
=> Subtype_Indication
(Typedef_Node
),
1468 Abstract_Present
=> Abstract_Present
(Typedef_Node
));
1470 Delete_Node
(Typedef_Node
);
1471 return Typedecl_Node
;
1473 -- Derived type definition with record extension part
1476 Set_Record_Extension_Part
(Typedef_Node
, P_Record_Definition
);
1477 return Typedef_Node
;
1480 -- Derived type definition with no record extension part
1483 return Typedef_Node
;
1485 end P_Derived_Type_Def_Or_Private_Ext_Decl
;
1487 ---------------------------
1488 -- 3.5 Range Constraint --
1489 ---------------------------
1491 -- RANGE_CONSTRAINT ::= range RANGE
1493 -- The caller has checked that the initial token is RANGE
1495 -- Error recovery: cannot raise Error_Resync
1497 function P_Range_Constraint
return Node_Id
is
1498 Range_Node
: Node_Id
;
1501 Range_Node
:= New_Node
(N_Range_Constraint
, Token_Ptr
);
1503 Set_Range_Expression
(Range_Node
, P_Range
);
1505 end P_Range_Constraint
;
1512 -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
1514 -- Note: the range that appears in a membership test is parsed by
1515 -- P_Range_Or_Subtype_Mark (3.5).
1517 -- Error recovery: cannot raise Error_Resync
1519 function P_Range
return Node_Id
is
1520 Expr_Node
: Node_Id
;
1521 Range_Node
: Node_Id
;
1524 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
1526 if Expr_Form
= EF_Range_Attr
then
1529 elsif Token
= Tok_Dot_Dot
then
1530 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
1531 Set_Low_Bound
(Range_Node
, Expr_Node
);
1533 Expr_Node
:= P_Expression
;
1534 Check_Simple_Expression
(Expr_Node
);
1535 Set_High_Bound
(Range_Node
, Expr_Node
);
1538 -- Anything else is an error
1541 T_Dot_Dot
; -- force missing .. message
1546 ----------------------------------
1547 -- 3.5 P_Range_Or_Subtype_Mark --
1548 ----------------------------------
1551 -- RANGE_ATTRIBUTE_REFERENCE
1552 -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
1554 -- This routine scans out the range or subtype mark that forms the right
1555 -- operand of a membership test.
1557 -- Note: as documented in the Sinfo interface, although the syntax only
1558 -- allows a subtype mark, we in fact allow any simple expression to be
1559 -- returned from this routine. The semantics is responsible for issuing
1560 -- an appropriate message complaining if the argument is not a name.
1561 -- This simplifies the coding and error recovery processing in the
1562 -- parser, and in any case it is preferable not to consider this a
1563 -- syntax error and to continue with the semantic analysis.
1565 -- Error recovery: cannot raise Error_Resync
1567 function P_Range_Or_Subtype_Mark
return Node_Id
is
1568 Expr_Node
: Node_Id
;
1569 Range_Node
: Node_Id
;
1572 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
1574 if Expr_Form
= EF_Range_Attr
then
1577 -- Simple_Expression .. Simple_Expression
1579 elsif Token
= Tok_Dot_Dot
then
1580 Check_Simple_Expression
(Expr_Node
);
1581 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
1582 Set_Low_Bound
(Range_Node
, Expr_Node
);
1584 Set_High_Bound
(Range_Node
, P_Simple_Expression
);
1587 -- Case of subtype mark (optionally qualified simple name or an
1588 -- attribute whose prefix is an optionally qualifed simple name)
1590 elsif Expr_Form
= EF_Simple_Name
1591 or else Nkind
(Expr_Node
) = N_Attribute_Reference
1593 -- Check for error of range constraint after a subtype mark
1595 if Token
= Tok_Range
then
1597 ("range constraint not allowed in membership test");
1601 -- Check for error of DIGITS or DELTA after a subtype mark
1603 elsif Token
= Tok_Digits
or else Token
= Tok_Delta
then
1605 ("accuracy definition not allowed in membership test");
1606 Scan
; -- past DIGITS or DELTA
1609 elsif Token
= Tok_Apostrophe
then
1610 return P_Subtype_Mark_Attribute
(Expr_Node
);
1616 -- At this stage, we have some junk following the expression. We
1617 -- really can't tell what is wrong, might be a missing semicolon,
1618 -- or a missing THEN, or whatever. Our caller will figure it out!
1623 end P_Range_Or_Subtype_Mark
;
1625 ----------------------------------------
1626 -- 3.5.1 Enumeration Type Definition --
1627 ----------------------------------------
1629 -- ENUMERATION_TYPE_DEFINITION ::=
1630 -- (ENUMERATION_LITERAL_SPECIFICATION
1631 -- {, ENUMERATION_LITERAL_SPECIFICATION})
1633 -- The caller has already scanned out the TYPE keyword
1635 -- Error recovery: can raise Error_Resync;
1637 function P_Enumeration_Type_Definition
return Node_Id
is
1638 Typedef_Node
: Node_Id
;
1641 Typedef_Node
:= New_Node
(N_Enumeration_Type_Definition
, Token_Ptr
);
1642 Set_Literals
(Typedef_Node
, New_List
);
1647 Append
(P_Enumeration_Literal_Specification
, Literals
(Typedef_Node
));
1648 exit when not Comma_Present
;
1652 return Typedef_Node
;
1653 end P_Enumeration_Type_Definition
;
1655 ----------------------------------------------
1656 -- 3.5.1 Enumeration Literal Specification --
1657 ----------------------------------------------
1659 -- ENUMERATION_LITERAL_SPECIFICATION ::=
1660 -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
1662 -- Error recovery: can raise Error_Resync
1664 function P_Enumeration_Literal_Specification
return Node_Id
is
1666 if Token
= Tok_Char_Literal
then
1667 return P_Defining_Character_Literal
;
1669 return P_Defining_Identifier
;
1671 end P_Enumeration_Literal_Specification
;
1673 ---------------------------------------
1674 -- 3.5.1 Defining_Character_Literal --
1675 ---------------------------------------
1677 -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
1679 -- Error recovery: cannot raise Error_Resync
1681 -- The caller has checked that the current token is a character literal
1683 function P_Defining_Character_Literal
return Node_Id
is
1684 Literal_Node
: Node_Id
;
1687 Literal_Node
:= Token_Node
;
1688 Change_Character_Literal_To_Defining_Character_Literal
(Literal_Node
);
1689 Scan
; -- past character literal
1690 return Literal_Node
;
1691 end P_Defining_Character_Literal
;
1693 ------------------------------------
1694 -- 3.5.4 Integer Type Definition --
1695 ------------------------------------
1697 -- Parsed by P_Type_Declaration (3.2.1)
1699 -------------------------------------------
1700 -- 3.5.4 Signed Integer Type Definition --
1701 -------------------------------------------
1703 -- SIGNED_INTEGER_TYPE_DEFINITION ::=
1704 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
1706 -- Normally the initial token on entry is RANGE, but in some
1707 -- error conditions, the range token was missing and control is
1708 -- passed with Token pointing to first token of the first expression.
1710 -- Error recovery: cannot raise Error_Resync
1712 function P_Signed_Integer_Type_Definition
return Node_Id
is
1713 Typedef_Node
: Node_Id
;
1714 Expr_Node
: Node_Id
;
1717 Typedef_Node
:= New_Node
(N_Signed_Integer_Type_Definition
, Token_Ptr
);
1719 if Token
= Tok_Range
then
1723 Expr_Node
:= P_Expression
;
1724 Check_Simple_Expression
(Expr_Node
);
1725 Set_Low_Bound
(Typedef_Node
, Expr_Node
);
1727 Expr_Node
:= P_Expression
;
1728 Check_Simple_Expression
(Expr_Node
);
1729 Set_High_Bound
(Typedef_Node
, Expr_Node
);
1730 return Typedef_Node
;
1731 end P_Signed_Integer_Type_Definition
;
1733 ------------------------------------
1734 -- 3.5.4 Modular Type Definition --
1735 ------------------------------------
1737 -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
1739 -- The caller has checked that the initial token is MOD
1741 -- Error recovery: cannot raise Error_Resync
1743 function P_Modular_Type_Definition
return Node_Id
is
1744 Typedef_Node
: Node_Id
;
1748 Error_Msg_SC
("(Ada 83): modular types not allowed");
1751 Typedef_Node
:= New_Node
(N_Modular_Type_Definition
, Token_Ptr
);
1753 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
1755 -- Handle mod L..R cleanly
1757 if Token
= Tok_Dot_Dot
then
1758 Error_Msg_SC
("range not allowed for modular type");
1760 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
1763 return Typedef_Node
;
1764 end P_Modular_Type_Definition
;
1766 ---------------------------------
1767 -- 3.5.6 Real Type Definition --
1768 ---------------------------------
1770 -- Parsed by P_Type_Declaration (3.2.1)
1772 --------------------------------------
1773 -- 3.5.7 Floating Point Definition --
1774 --------------------------------------
1776 -- FLOATING_POINT_DEFINITION ::=
1777 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
1779 -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
1781 -- The caller has checked that the initial token is DIGITS
1783 -- Error recovery: cannot raise Error_Resync
1785 function P_Floating_Point_Definition
return Node_Id
is
1786 Digits_Loc
: constant Source_Ptr
:= Token_Ptr
;
1788 Expr_Node
: Node_Id
;
1791 Scan
; -- past DIGITS
1792 Expr_Node
:= P_Expression_No_Right_Paren
;
1793 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
1795 -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
1797 if Token
= Tok_Delta
then
1798 Error_Msg_SC
("DELTA must come before DIGITS");
1799 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Digits_Loc
);
1801 Set_Delta_Expression
(Def_Node
, P_Expression_No_Right_Paren
);
1803 -- OK floating-point definition
1806 Def_Node
:= New_Node
(N_Floating_Point_Definition
, Digits_Loc
);
1809 Set_Digits_Expression
(Def_Node
, Expr_Node
);
1810 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
1812 end P_Floating_Point_Definition
;
1814 -------------------------------------
1815 -- 3.5.7 Real Range Specification --
1816 -------------------------------------
1818 -- REAL_RANGE_SPECIFICATION ::=
1819 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
1821 -- Error recovery: cannot raise Error_Resync
1823 function P_Real_Range_Specification_Opt
return Node_Id
is
1824 Specification_Node
: Node_Id
;
1825 Expr_Node
: Node_Id
;
1828 if Token
= Tok_Range
then
1829 Specification_Node
:=
1830 New_Node
(N_Real_Range_Specification
, Token_Ptr
);
1832 Expr_Node
:= P_Expression_No_Right_Paren
;
1833 Check_Simple_Expression
(Expr_Node
);
1834 Set_Low_Bound
(Specification_Node
, Expr_Node
);
1836 Expr_Node
:= P_Expression_No_Right_Paren
;
1837 Check_Simple_Expression
(Expr_Node
);
1838 Set_High_Bound
(Specification_Node
, Expr_Node
);
1839 return Specification_Node
;
1843 end P_Real_Range_Specification_Opt
;
1845 -----------------------------------
1846 -- 3.5.9 Fixed Point Definition --
1847 -----------------------------------
1849 -- FIXED_POINT_DEFINITION ::=
1850 -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
1852 -- ORDINARY_FIXED_POINT_DEFINITION ::=
1853 -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION
1855 -- DECIMAL_FIXED_POINT_DEFINITION ::=
1856 -- delta static_EXPRESSION
1857 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
1859 -- The caller has checked that the initial token is DELTA
1861 -- Error recovery: cannot raise Error_Resync
1863 function P_Fixed_Point_Definition
return Node_Id
is
1864 Delta_Node
: Node_Id
;
1865 Delta_Loc
: Source_Ptr
;
1867 Expr_Node
: Node_Id
;
1870 Delta_Loc
:= Token_Ptr
;
1872 Delta_Node
:= P_Expression_No_Right_Paren
;
1873 Check_Simple_Expression_In_Ada_83
(Delta_Node
);
1875 if Token
= Tok_Digits
then
1877 Error_Msg_SC
("(Ada 83) decimal fixed type not allowed!");
1880 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Delta_Loc
);
1881 Scan
; -- past DIGITS
1882 Expr_Node
:= P_Expression_No_Right_Paren
;
1883 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
1884 Set_Digits_Expression
(Def_Node
, Expr_Node
);
1887 Def_Node
:= New_Node
(N_Ordinary_Fixed_Point_Definition
, Delta_Loc
);
1889 -- Range is required in ordinary fixed point case
1891 if Token
/= Tok_Range
then
1892 Error_Msg_AP
("range must be given for fixed-point type");
1897 Set_Delta_Expression
(Def_Node
, Delta_Node
);
1898 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
1900 end P_Fixed_Point_Definition
;
1902 --------------------------------------------
1903 -- 3.5.9 Ordinary Fixed Point Definition --
1904 --------------------------------------------
1906 -- Parsed by P_Fixed_Point_Definition (3.5.9)
1908 -------------------------------------------
1909 -- 3.5.9 Decimal Fixed Point Definition --
1910 -------------------------------------------
1912 -- Parsed by P_Decimal_Point_Definition (3.5.9)
1914 ------------------------------
1915 -- 3.5.9 Digits Constraint --
1916 ------------------------------
1918 -- DIGITS_CONSTRAINT ::=
1919 -- digits static_EXPRESSION [RANGE_CONSTRAINT]
1921 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
1923 -- The caller has checked that the initial token is DIGITS
1925 function P_Digits_Constraint
return Node_Id
is
1926 Constraint_Node
: Node_Id
;
1927 Expr_Node
: Node_Id
;
1930 Constraint_Node
:= New_Node
(N_Digits_Constraint
, Token_Ptr
);
1931 Scan
; -- past DIGITS
1932 Expr_Node
:= P_Expression_No_Right_Paren
;
1933 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
1934 Set_Digits_Expression
(Constraint_Node
, Expr_Node
);
1936 if Token
= Tok_Range
then
1937 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
1940 return Constraint_Node
;
1941 end P_Digits_Constraint
;
1943 -----------------------------
1944 -- 3.5.9 Delta Constraint --
1945 -----------------------------
1947 -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
1949 -- Note: this is an obsolescent feature in Ada 95 (I.3)
1951 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
1953 -- The caller has checked that the initial token is DELTA
1955 -- Error recovery: cannot raise Error_Resync
1957 function P_Delta_Constraint
return Node_Id
is
1958 Constraint_Node
: Node_Id
;
1959 Expr_Node
: Node_Id
;
1962 Constraint_Node
:= New_Node
(N_Delta_Constraint
, Token_Ptr
);
1964 Expr_Node
:= P_Expression_No_Right_Paren
;
1965 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
1966 Set_Delta_Expression
(Constraint_Node
, Expr_Node
);
1968 if Token
= Tok_Range
then
1969 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
1972 return Constraint_Node
;
1973 end P_Delta_Constraint
;
1975 --------------------------------
1976 -- 3.6 Array Type Definition --
1977 --------------------------------
1979 -- ARRAY_TYPE_DEFINITION ::=
1980 -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
1982 -- UNCONSTRAINED_ARRAY_DEFINITION ::=
1983 -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
1984 -- COMPONENT_DEFINITION
1986 -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
1988 -- CONSTRAINED_ARRAY_DEFINITION ::=
1989 -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
1990 -- COMPONENT_DEFINITION
1992 -- DISCRETE_SUBTYPE_DEFINITION ::=
1993 -- DISCRETE_SUBTYPE_INDICATION | RANGE
1995 -- COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION
1997 -- The caller has checked that the initial token is ARRAY
1999 -- Error recovery: can raise Error_Resync
2001 function P_Array_Type_Definition
return Node_Id
is
2002 Array_Loc
: Source_Ptr
;
2004 Subs_List
: List_Id
;
2005 Scan_State
: Saved_Scan_State
;
2008 Array_Loc
:= Token_Ptr
;
2010 Subs_List
:= New_List
;
2013 -- It's quite tricky to disentangle these two possibilities, so we do
2014 -- a prescan to determine which case we have and then reset the scan.
2015 -- The prescan skips past possible subtype mark tokens.
2017 Save_Scan_State
(Scan_State
); -- just after paren
2019 while Token
in Token_Class_Desig
or else
2020 Token
= Tok_Dot
or else
2021 Token
= Tok_Apostrophe
-- because of 'BASE, 'CLASS
2026 -- If we end up on RANGE <> then we have the unconstrained case. We
2027 -- will also allow the RANGE to be omitted, just to improve error
2028 -- handling for a case like array (integer <>) of integer;
2030 Scan
; -- past possible RANGE or <>
2032 if (Prev_Token
= Tok_Range
and then Token
= Tok_Box
) or else
2033 Prev_Token
= Tok_Box
2035 Def_Node
:= New_Node
(N_Unconstrained_Array_Definition
, Array_Loc
);
2036 Restore_Scan_State
(Scan_State
); -- to first subtype mark
2039 Append
(P_Subtype_Mark_Resync
, Subs_List
);
2042 exit when Token
= Tok_Right_Paren
or else Token
= Tok_Of
;
2046 Set_Subtype_Marks
(Def_Node
, Subs_List
);
2049 Def_Node
:= New_Node
(N_Constrained_Array_Definition
, Array_Loc
);
2050 Restore_Scan_State
(Scan_State
); -- to first discrete range
2053 Append
(P_Discrete_Subtype_Definition
, Subs_List
);
2054 exit when not Comma_Present
;
2057 Set_Discrete_Subtype_Definitions
(Def_Node
, Subs_List
);
2063 if Token
= Tok_Aliased
then
2064 Set_Aliased_Present
(Def_Node
, True);
2065 Scan
; -- past ALIASED
2068 Set_Subtype_Indication
(Def_Node
, P_Subtype_Indication
);
2070 end P_Array_Type_Definition
;
2072 -----------------------------------------
2073 -- 3.6 Unconstrained Array Definition --
2074 -----------------------------------------
2076 -- Parsed by P_Array_Type_Definition (3.6)
2078 ---------------------------------------
2079 -- 3.6 Constrained Array Definition --
2080 ---------------------------------------
2082 -- Parsed by P_Array_Type_Definition (3.6)
2084 --------------------------------------
2085 -- 3.6 Discrete Subtype Definition --
2086 --------------------------------------
2088 -- DISCRETE_SUBTYPE_DEFINITION ::=
2089 -- discrete_SUBTYPE_INDICATION | RANGE
2091 -- Note: the discrete subtype definition appearing in a constrained
2092 -- array definition is parsed by P_Array_Type_Definition (3.6)
2094 -- Error recovery: cannot raise Error_Resync
2096 function P_Discrete_Subtype_Definition
return Node_Id
is
2099 -- The syntax of a discrete subtype definition is identical to that
2100 -- of a discrete range, so we simply share the same parsing code.
2102 return P_Discrete_Range
;
2103 end P_Discrete_Subtype_Definition
;
2105 -------------------------------
2106 -- 3.6 Component Definition --
2107 -------------------------------
2109 -- For the array case, parsed by P_Array_Type_Definition (3.6)
2110 -- For the record case, parsed by P_Component_Declaration (3.8)
2112 -----------------------------
2113 -- 3.6.1 Index Constraint --
2114 -----------------------------
2116 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2118 ---------------------------
2119 -- 3.6.1 Discrete Range --
2120 ---------------------------
2122 -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
2124 -- The possible forms for a discrete range are:
2126 -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2)
2127 -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2)
2128 -- Range_Attribute (RANGE, 3.5)
2129 -- Simple_Expression .. Simple_Expression (RANGE, 3.5)
2131 -- Error recovery: cannot raise Error_Resync
2133 function P_Discrete_Range
return Node_Id
is
2134 Expr_Node
: Node_Id
;
2135 Range_Node
: Node_Id
;
2138 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2140 if Expr_Form
= EF_Range_Attr
then
2143 elsif Token
= Tok_Range
then
2144 if Expr_Form
/= EF_Simple_Name
then
2145 Error_Msg_SC
("range must be preceded by subtype mark");
2148 return P_Subtype_Indication
(Expr_Node
);
2150 -- Check Expression .. Expression case
2152 elsif Token
= Tok_Dot_Dot
then
2153 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2154 Set_Low_Bound
(Range_Node
, Expr_Node
);
2156 Expr_Node
:= P_Expression
;
2157 Check_Simple_Expression
(Expr_Node
);
2158 Set_High_Bound
(Range_Node
, Expr_Node
);
2161 -- Otherwise we must have a subtype mark
2163 elsif Expr_Form
= EF_Simple_Name
then
2166 -- If incorrect, complain that we expect ..
2172 end P_Discrete_Range
;
2174 ----------------------------
2175 -- 3.7 Discriminant Part --
2176 ----------------------------
2178 -- DISCRIMINANT_PART ::=
2179 -- UNKNOWN_DISCRIMINANT_PART
2180 -- | KNOWN_DISCRIMINANT_PART
2182 -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
2183 -- or P_Unknown_Discriminant_Part (3.7), since we know which we want.
2185 ------------------------------------
2186 -- 3.7 Unknown Discriminant Part --
2187 ------------------------------------
2189 -- UNKNOWN_DISCRIMINANT_PART ::= (<>)
2191 -- If no unknown discriminant part is present, then False is returned,
2192 -- otherwise the unknown discriminant is scanned out and True is returned.
2194 -- Error recovery: cannot raise Error_Resync
2196 function P_Unknown_Discriminant_Part_Opt
return Boolean is
2197 Scan_State
: Saved_Scan_State
;
2200 if Token
/= Tok_Left_Paren
then
2204 Save_Scan_State
(Scan_State
);
2205 Scan
; -- past the left paren
2207 if Token
= Tok_Box
then
2210 Error_Msg_SC
("(Ada 83) unknown discriminant not allowed!");
2213 Scan
; -- past the box
2214 T_Right_Paren
; -- must be followed by right paren
2218 Restore_Scan_State
(Scan_State
);
2222 end P_Unknown_Discriminant_Part_Opt
;
2224 ----------------------------------
2225 -- 3.7 Known Discriminant Part --
2226 ----------------------------------
2228 -- KNOWN_DISCRIMINANT_PART ::=
2229 -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
2231 -- DISCRIMINANT_SPECIFICATION ::=
2232 -- DEFINING_IDENTIFIER_LIST : SUBTYPE_MARK
2233 -- [:= DEFAULT_EXPRESSION]
2234 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
2235 -- [:= DEFAULT_EXPRESSION]
2237 -- If no known discriminant part is present, then No_List is returned
2239 -- Error recovery: cannot raise Error_Resync
2241 function P_Known_Discriminant_Part_Opt
return List_Id
is
2242 Specification_Node
: Node_Id
;
2243 Specification_List
: List_Id
;
2244 Ident_Sloc
: Source_Ptr
;
2245 Scan_State
: Saved_Scan_State
;
2249 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
2250 -- This array holds the list of defining identifiers. The upper bound
2251 -- of 4096 is intended to be essentially infinite, and we do not even
2252 -- bother to check for it being exceeded.
2255 if Token
= Tok_Left_Paren
then
2256 Specification_List
:= New_List
;
2258 P_Pragmas_Misplaced
;
2260 Specification_Loop
: loop
2262 Ident_Sloc
:= Token_Ptr
;
2263 Idents
(1) := P_Defining_Identifier
;
2266 while Comma_Present
loop
2267 Num_Idents
:= Num_Idents
+ 1;
2268 Idents
(Num_Idents
) := P_Defining_Identifier
;
2273 -- If there are multiple identifiers, we repeatedly scan the
2274 -- type and initialization expression information by resetting
2275 -- the scan pointer (so that we get completely separate trees
2276 -- for each occurrence).
2278 if Num_Idents
> 1 then
2279 Save_Scan_State
(Scan_State
);
2282 -- Loop through defining identifiers in list
2286 Specification_Node
:=
2287 New_Node
(N_Discriminant_Specification
, Ident_Sloc
);
2288 Set_Defining_Identifier
(Specification_Node
, Idents
(Ident
));
2290 if Token
= Tok_Access
then
2293 ("(Ada 83) access discriminant not allowed!");
2296 Set_Discriminant_Type
2297 (Specification_Node
, P_Access_Definition
);
2299 Set_Discriminant_Type
2300 (Specification_Node
, P_Subtype_Mark
);
2305 (Specification_Node
, Init_Expr_Opt
(True));
2308 Set_Prev_Ids
(Specification_Node
, True);
2311 if Ident
< Num_Idents
then
2312 Set_More_Ids
(Specification_Node
, True);
2315 Append
(Specification_Node
, Specification_List
);
2316 exit Ident_Loop
when Ident
= Num_Idents
;
2318 Restore_Scan_State
(Scan_State
);
2319 end loop Ident_Loop
;
2321 exit Specification_Loop
when Token
/= Tok_Semicolon
;
2323 P_Pragmas_Misplaced
;
2324 end loop Specification_Loop
;
2327 return Specification_List
;
2332 end P_Known_Discriminant_Part_Opt
;
2334 -------------------------------------
2335 -- 3.7 DIscriminant Specification --
2336 -------------------------------------
2338 -- Parsed by P_Known_Discriminant_Part_Opt (3.7)
2340 -----------------------------
2341 -- 3.7 Default Expression --
2342 -----------------------------
2344 -- Always parsed (simply as an Expression) by the parent construct
2346 ------------------------------------
2347 -- 3.7.1 Discriminant Constraint --
2348 ------------------------------------
2350 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2352 --------------------------------------------------------
2353 -- 3.7.1 Index or Discriminant Constraint (also 3.6) --
2354 --------------------------------------------------------
2356 -- DISCRIMINANT_CONSTRAINT ::=
2357 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
2359 -- DISCRIMINANT_ASSOCIATION ::=
2360 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2363 -- This routine parses either an index or a discriminant constraint. As
2364 -- is clear from the above grammar, it is often possible to clearly
2365 -- determine which of the two possibilities we have, but there are
2366 -- cases (those in which we have a series of expressions of the same
2367 -- syntactic form as subtype indications), where we cannot tell. Since
2368 -- this means that in any case the semantic phase has to distinguish
2369 -- between the two, there is not much point in the parser trying to
2370 -- distinguish even those cases where the difference is clear. In any
2371 -- case, if we have a situation like:
2373 -- (A => 123, 235 .. 500)
2375 -- it is not clear which of the two items is the wrong one, better to
2376 -- let the semantic phase give a clear message. Consequently, this
2377 -- routine in general returns a list of items which can be either
2378 -- discrete ranges or discriminant associations.
2380 -- The caller has checked that the initial token is a left paren
2382 -- Error recovery: can raise Error_Resync
2384 function P_Index_Or_Discriminant_Constraint
return Node_Id
is
2385 Scan_State
: Saved_Scan_State
;
2386 Constr_Node
: Node_Id
;
2387 Constr_List
: List_Id
;
2388 Expr_Node
: Node_Id
;
2389 Result_Node
: Node_Id
;
2392 Result_Node
:= New_Node
(N_Index_Or_Discriminant_Constraint
, Token_Ptr
);
2394 Constr_List
:= New_List
;
2395 Set_Constraints
(Result_Node
, Constr_List
);
2397 -- The two syntactic forms are a little mixed up, so what we are doing
2398 -- here is looking at the first entry to determine which case we have
2400 -- A discriminant constraint is a list of discriminant associations,
2401 -- which have one of the following possible forms:
2405 -- Id | Id | .. | Id => Expression
2407 -- An index constraint is a list of discrete ranges which have one
2408 -- of the following possible forms:
2411 -- Subtype_Mark range Range
2413 -- Simple_Expression .. Simple_Expression
2415 -- Loop through discriminants in list
2418 -- Check cases of Id => Expression or Id | Id => Expression
2420 if Token
= Tok_Identifier
then
2421 Save_Scan_State
(Scan_State
); -- at Id
2424 if Token
= Tok_Arrow
or else Token
= Tok_Vertical_Bar
then
2425 Restore_Scan_State
(Scan_State
); -- to Id
2426 Append
(P_Discriminant_Association
, Constr_List
);
2429 Restore_Scan_State
(Scan_State
); -- to Id
2433 -- Otherwise scan out an expression and see what we have got
2435 Expr_Node
:= P_Expression_Or_Range_Attribute
;
2437 if Expr_Form
= EF_Range_Attr
then
2438 Append
(Expr_Node
, Constr_List
);
2440 elsif Token
= Tok_Range
then
2441 if Expr_Form
/= EF_Simple_Name
then
2442 Error_Msg_SC
("subtype mark required before RANGE");
2445 Append
(P_Subtype_Indication
(Expr_Node
), Constr_List
);
2448 -- Check Simple_Expression .. Simple_Expression case
2450 elsif Token
= Tok_Dot_Dot
then
2451 Check_Simple_Expression
(Expr_Node
);
2452 Constr_Node
:= New_Node
(N_Range
, Token_Ptr
);
2453 Set_Low_Bound
(Constr_Node
, Expr_Node
);
2455 Expr_Node
:= P_Expression
;
2456 Check_Simple_Expression
(Expr_Node
);
2457 Set_High_Bound
(Constr_Node
, Expr_Node
);
2458 Append
(Constr_Node
, Constr_List
);
2461 -- Case of an expression which could be either form
2464 Append
(Expr_Node
, Constr_List
);
2468 -- Here with a single entry scanned
2471 exit when not Comma_Present
;
2478 end P_Index_Or_Discriminant_Constraint
;
2480 -------------------------------------
2481 -- 3.7.1 Discriminant Association --
2482 -------------------------------------
2484 -- DISCRIMINANT_ASSOCIATION ::=
2485 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2488 -- This routine is used only when the name list is present and the caller
2489 -- has already checked this (by scanning ahead and repositioning the
2492 -- Error_Recovery: cannot raise Error_Resync;
2494 function P_Discriminant_Association
return Node_Id
is
2495 Discr_Node
: Node_Id
;
2496 Names_List
: List_Id
;
2497 Ident_Sloc
: Source_Ptr
;
2500 Ident_Sloc
:= Token_Ptr
;
2501 Names_List
:= New_List
;
2504 Append
(P_Identifier
, Names_List
);
2505 exit when Token
/= Tok_Vertical_Bar
;
2509 Discr_Node
:= New_Node
(N_Discriminant_Association
, Ident_Sloc
);
2510 Set_Selector_Names
(Discr_Node
, Names_List
);
2512 Set_Expression
(Discr_Node
, P_Expression
);
2514 end P_Discriminant_Association
;
2516 ---------------------------------
2517 -- 3.8 Record Type Definition --
2518 ---------------------------------
2520 -- RECORD_TYPE_DEFINITION ::=
2521 -- [[abstract] tagged] [limited] RECORD_DEFINITION
2523 -- There is no node in the tree for a record type definition. Instead
2524 -- a record definition node appears, with possible Abstract_Present,
2525 -- Tagged_Present, and Limited_Present flags set appropriately.
2527 ----------------------------
2528 -- 3.8 Record Definition --
2529 ----------------------------
2531 -- RECORD_DEFINITION ::=
2537 -- Note: in the case where a record definition node is used to represent
2538 -- a record type definition, the caller sets the Tagged_Present and
2539 -- Limited_Present flags in the resulting N_Record_Definition node as
2542 -- Note that the RECORD token at the start may be missing in certain
2543 -- error situations, so this function is expected to post the error
2545 -- Error recovery: can raise Error_Resync
2547 function P_Record_Definition
return Node_Id
is
2551 Rec_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
2555 if Token
= Tok_Null
then
2558 Set_Null_Present
(Rec_Node
, True);
2560 -- Case starting with RECORD keyword. Build scope stack entry. For the
2561 -- column, we use the first non-blank character on the line, to deal
2562 -- with situations such as:
2568 -- which is not official RM indentation, but is not uncommon usage
2572 Scope
.Table
(Scope
.Last
).Etyp
:= E_Record
;
2573 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
2574 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
2575 Scope
.Table
(Scope
.Last
).Labl
:= Error
;
2576 Scope
.Table
(Scope
.Last
).Junk
:= (Token
/= Tok_Record
);
2580 Set_Component_List
(Rec_Node
, P_Component_List
);
2583 exit when Check_End
;
2584 Discard_Junk_Node
(P_Component_List
);
2589 end P_Record_Definition
;
2591 -------------------------
2592 -- 3.8 Component List --
2593 -------------------------
2595 -- COMPONENT_LIST ::=
2596 -- COMPONENT_ITEM {COMPONENT_ITEM}
2597 -- | {COMPONENT_ITEM} VARIANT_PART
2600 -- Error recovery: cannot raise Error_Resync
2602 function P_Component_List
return Node_Id
is
2603 Component_List_Node
: Node_Id
;
2604 Decls_List
: List_Id
;
2605 Scan_State
: Saved_Scan_State
;
2608 Component_List_Node
:= New_Node
(N_Component_List
, Token_Ptr
);
2609 Decls_List
:= New_List
;
2611 if Token
= Tok_Null
then
2614 P_Pragmas_Opt
(Decls_List
);
2615 Set_Null_Present
(Component_List_Node
, True);
2616 return Component_List_Node
;
2619 P_Pragmas_Opt
(Decls_List
);
2621 if Token
/= Tok_Case
then
2622 Component_Scan_Loop
: loop
2623 P_Component_Items
(Decls_List
);
2624 P_Pragmas_Opt
(Decls_List
);
2626 exit Component_Scan_Loop
when Token
= Tok_End
2627 or else Token
= Tok_Case
2628 or else Token
= Tok_When
;
2630 -- We are done if we do not have an identifier. However, if
2631 -- we have a misspelled reserved identifier that is in a column
2632 -- to the right of the record definition, we will treat it as
2633 -- an identifier. It turns out to be too dangerous in practice
2634 -- to accept such a mis-spelled identifier which does not have
2635 -- this additional clue that confirms the incorrect spelling.
2637 if Token
/= Tok_Identifier
then
2638 if Start_Column
> Scope
.Table
(Scope
.Last
).Ecol
2639 and then Is_Reserved_Identifier
2641 Save_Scan_State
(Scan_State
); -- at reserved id
2642 Scan
; -- possible reserved id
2644 if Token
= Tok_Comma
or else Token
= Tok_Colon
then
2645 Restore_Scan_State
(Scan_State
);
2646 Scan_Reserved_Identifier
(Force_Msg
=> True);
2648 -- Note reserved identifier used as field name after
2649 -- all because not followed by colon or comma
2652 Restore_Scan_State
(Scan_State
);
2653 exit Component_Scan_Loop
;
2656 -- Non-identifier that definitely was not reserved id
2659 exit Component_Scan_Loop
;
2662 end loop Component_Scan_Loop
;
2665 if Token
= Tok_Case
then
2666 Set_Variant_Part
(Component_List_Node
, P_Variant_Part
);
2668 -- Check for junk after variant part
2670 if Token
= Tok_Identifier
then
2671 Save_Scan_State
(Scan_State
);
2672 Scan
; -- past identifier
2674 if Token
= Tok_Colon
then
2675 Restore_Scan_State
(Scan_State
);
2676 Error_Msg_SC
("component may not follow variant part");
2677 Discard_Junk_Node
(P_Component_List
);
2679 elsif Token
= Tok_Case
then
2680 Restore_Scan_State
(Scan_State
);
2681 Error_Msg_SC
("only one variant part allowed in a record");
2682 Discard_Junk_Node
(P_Component_List
);
2685 Restore_Scan_State
(Scan_State
);
2691 Set_Component_Items
(Component_List_Node
, Decls_List
);
2692 return Component_List_Node
;
2694 end P_Component_List
;
2696 -------------------------
2697 -- 3.8 Component Item --
2698 -------------------------
2700 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
2702 -- COMPONENT_DECLARATION ::=
2703 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
2704 -- [:= DEFAULT_EXPRESSION];
2706 -- COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION
2708 -- Error recovery: cannot raise Error_Resync, if an error occurs,
2709 -- the scan is positioned past the following semicolon.
2711 -- Note: we do not yet allow representation clauses to appear as component
2712 -- items, do we need to add this capability sometime in the future ???
2714 procedure P_Component_Items
(Decls
: List_Id
) is
2715 Decl_Node
: Node_Id
;
2716 Scan_State
: Saved_Scan_State
;
2719 Ident_Sloc
: Source_Ptr
;
2721 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
2722 -- This array holds the list of defining identifiers. The upper bound
2723 -- of 4096 is intended to be essentially infinite, and we do not even
2724 -- bother to check for it being exceeded.
2727 if Token
/= Tok_Identifier
then
2728 Error_Msg_SC
("component declaration expected");
2729 Resync_Past_Semicolon
;
2733 Ident_Sloc
:= Token_Ptr
;
2734 Idents
(1) := P_Defining_Identifier
;
2737 while Comma_Present
loop
2738 Num_Idents
:= Num_Idents
+ 1;
2739 Idents
(Num_Idents
) := P_Defining_Identifier
;
2744 -- If there are multiple identifiers, we repeatedly scan the
2745 -- type and initialization expression information by resetting
2746 -- the scan pointer (so that we get completely separate trees
2747 -- for each occurrence).
2749 if Num_Idents
> 1 then
2750 Save_Scan_State
(Scan_State
);
2753 -- Loop through defining identifiers in list
2758 -- The following block is present to catch Error_Resync
2759 -- which causes the parse to be reset past the semicolon
2762 Decl_Node
:= New_Node
(N_Component_Declaration
, Ident_Sloc
);
2763 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
2765 if Token
= Tok_Constant
then
2766 Error_Msg_SC
("constant components are not permitted");
2770 if Token_Name
= Name_Aliased
then
2771 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
2774 if Token
= Tok_Aliased
then
2775 Scan
; -- past ALIASED
2776 Set_Aliased_Present
(Decl_Node
, True);
2779 if Token
= Tok_Array
then
2780 Error_Msg_SC
("anonymous arrays not allowed as components");
2784 Set_Subtype_Indication
(Decl_Node
, P_Subtype_Indication
);
2785 Set_Expression
(Decl_Node
, Init_Expr_Opt
);
2788 Set_Prev_Ids
(Decl_Node
, True);
2791 if Ident
< Num_Idents
then
2792 Set_More_Ids
(Decl_Node
, True);
2795 Append
(Decl_Node
, Decls
);
2798 when Error_Resync
=>
2799 if Token
/= Tok_End
then
2800 Resync_Past_Semicolon
;
2804 exit Ident_Loop
when Ident
= Num_Idents
;
2806 Restore_Scan_State
(Scan_State
);
2808 end loop Ident_Loop
;
2812 end P_Component_Items
;
2814 --------------------------------
2815 -- 3.8 Component Declaration --
2816 --------------------------------
2818 -- Parsed by P_Component_Items (3.8)
2820 -------------------------
2821 -- 3.8.1 Variant Part --
2822 -------------------------
2825 -- case discriminant_DIRECT_NAME is
2830 -- The caller has checked that the initial token is CASE
2832 -- Error recovery: cannot raise Error_Resync
2834 function P_Variant_Part
return Node_Id
is
2835 Variant_Part_Node
: Node_Id
;
2836 Variants_List
: List_Id
;
2837 Case_Node
: Node_Id
;
2838 Case_Sloc
: Source_Ptr
;
2841 Variant_Part_Node
:= New_Node
(N_Variant_Part
, Token_Ptr
);
2843 Scope
.Table
(Scope
.Last
).Etyp
:= E_Case
;
2844 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
2845 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
2848 Case_Node
:= P_Expression
;
2849 Case_Sloc
:= Token_Ptr
;
2850 Set_Name
(Variant_Part_Node
, Case_Node
);
2852 if Nkind
(Case_Node
) /= N_Identifier
then
2853 Set_Name
(Variant_Part_Node
, Error
);
2854 Error_Msg
("discriminant name expected", Sloc
(Case_Node
));
2858 Variants_List
:= New_List
;
2859 P_Pragmas_Opt
(Variants_List
);
2861 -- Test missing variant
2863 if Token
= Tok_End
then
2864 Error_Msg_BC
("WHEN expected (must have at least one variant)");
2866 Append
(P_Variant
, Variants_List
);
2869 -- Loop through variants, note that we allow if in place of when,
2870 -- this error will be detected and handled in P_Variant.
2873 P_Pragmas_Opt
(Variants_List
);
2875 if Token
/= Tok_When
2876 and then Token
/= Tok_If
2877 and then Token
/= Tok_Others
2879 exit when Check_End
;
2882 Append
(P_Variant
, Variants_List
);
2885 Set_Variants
(Variant_Part_Node
, Variants_List
);
2886 return Variant_Part_Node
;
2890 --------------------
2892 --------------------
2895 -- when DISCRETE_CHOICE_LIST =>
2898 -- Error recovery: cannot raise Error_Resync
2900 -- The initial token on entry is either WHEN, IF or OTHERS
2902 function P_Variant
return Node_Id
is
2903 Variant_Node
: Node_Id
;
2906 -- Special check to recover nicely from use of IF in place of WHEN
2908 if Token
= Tok_If
then
2915 Variant_Node
:= New_Node
(N_Variant
, Prev_Token_Ptr
);
2916 Set_Discrete_Choices
(Variant_Node
, P_Discrete_Choice_List
);
2918 Set_Component_List
(Variant_Node
, P_Component_List
);
2919 return Variant_Node
;
2922 ---------------------------------
2923 -- 3.8.1 Discrete Choice List --
2924 ---------------------------------
2926 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
2928 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
2930 -- Note: in Ada 83, the expression must be a simple expression
2932 -- Error recovery: cannot raise Error_Resync
2934 function P_Discrete_Choice_List
return List_Id
is
2936 Expr_Node
: Node_Id
;
2937 Choice_Node
: Node_Id
;
2940 Choices
:= New_List
;
2943 if Token
= Tok_Others
then
2944 Append
(New_Node
(N_Others_Choice
, Token_Ptr
), Choices
);
2945 Scan
; -- past OTHERS
2949 Expr_Node
:= No_Right_Paren
(P_Expression_Or_Range_Attribute
);
2951 if Token
= Tok_Colon
2952 and then Nkind
(Expr_Node
) = N_Identifier
2954 Error_Msg_SP
("label not permitted in this context");
2957 elsif Expr_Form
= EF_Range_Attr
then
2958 Append
(Expr_Node
, Choices
);
2960 elsif Token
= Tok_Dot_Dot
then
2961 Check_Simple_Expression
(Expr_Node
);
2962 Choice_Node
:= New_Node
(N_Range
, Token_Ptr
);
2963 Set_Low_Bound
(Choice_Node
, Expr_Node
);
2965 Expr_Node
:= P_Expression_No_Right_Paren
;
2966 Check_Simple_Expression
(Expr_Node
);
2967 Set_High_Bound
(Choice_Node
, Expr_Node
);
2968 Append
(Choice_Node
, Choices
);
2970 elsif Expr_Form
= EF_Simple_Name
then
2971 if Token
= Tok_Range
then
2972 Append
(P_Subtype_Indication
(Expr_Node
), Choices
);
2974 elsif Token
in Token_Class_Consk
then
2976 ("the only constraint allowed here " &
2977 "is a range constraint");
2978 Discard_Junk_Node
(P_Constraint_Opt
);
2979 Append
(Expr_Node
, Choices
);
2982 Append
(Expr_Node
, Choices
);
2986 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2987 Append
(Expr_Node
, Choices
);
2991 when Error_Resync
=>
2997 if Token
= Tok_Comma
then
2998 Error_Msg_SC
(""","" should be ""'|""");
3000 exit when Token
/= Tok_Vertical_Bar
;
3003 Scan
; -- past | or comma
3007 end P_Discrete_Choice_List
;
3009 ----------------------------
3010 -- 3.8.1 Discrete Choice --
3011 ----------------------------
3013 -- Parsed by P_Discrete_Choice_List (3.8.1)
3015 ----------------------------------
3016 -- 3.9.1 Record Extension Part --
3017 ----------------------------------
3019 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
3021 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
3023 ----------------------------------
3024 -- 3.10 Access Type Definition --
3025 ----------------------------------
3027 -- ACCESS_TYPE_DEFINITION ::=
3028 -- ACCESS_TO_OBJECT_DEFINITION
3029 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3031 -- ACCESS_TO_OBJECT_DEFINITION ::=
3032 -- access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
3034 -- GENERAL_ACCESS_MODIFIER ::= all | constant
3036 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3037 -- access [protected] procedure PARAMETER_PROFILE
3038 -- | access [protected] function PARAMETER_AND_RESULT_PROFILE
3040 -- PARAMETER_PROFILE ::= [FORMAL_PART]
3042 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
3044 -- The caller has checked that the initial token is ACCESS
3046 -- Error recovery: can raise Error_Resync
3048 function P_Access_Type_Definition
return Node_Id
is
3049 Prot_Flag
: Boolean;
3050 Access_Loc
: Source_Ptr
;
3051 Type_Def_Node
: Node_Id
;
3053 procedure Check_Junk_Subprogram_Name
;
3054 -- Used in access to subprogram definition cases to check for an
3055 -- identifier or operator symbol that does not belong.
3057 procedure Check_Junk_Subprogram_Name
is
3058 Saved_State
: Saved_Scan_State
;
3061 if Token
= Tok_Identifier
or else Token
= Tok_Operator_Symbol
then
3062 Save_Scan_State
(Saved_State
);
3063 Scan
; -- past possible junk subprogram name
3065 if Token
= Tok_Left_Paren
or else Token
= Tok_Semicolon
then
3066 Error_Msg_SP
("unexpected subprogram name ignored");
3070 Restore_Scan_State
(Saved_State
);
3073 end Check_Junk_Subprogram_Name
;
3075 -- Start of processing for P_Access_Type_Definition
3078 Access_Loc
:= Token_Ptr
;
3079 Scan
; -- past ACCESS
3081 if Token_Name
= Name_Protected
then
3082 Check_95_Keyword
(Tok_Protected
, Tok_Procedure
);
3083 Check_95_Keyword
(Tok_Protected
, Tok_Function
);
3086 Prot_Flag
:= (Token
= Tok_Protected
);
3089 Scan
; -- past PROTECTED
3090 if Token
/= Tok_Procedure
and then Token
/= Tok_Function
then
3091 Error_Msg_SC
("FUNCTION or PROCEDURE expected");
3095 if Token
= Tok_Procedure
then
3097 Error_Msg_SC
("(Ada 83) access to procedure not allowed!");
3100 Type_Def_Node
:= New_Node
(N_Access_Procedure_Definition
, Access_Loc
);
3101 Scan
; -- past PROCEDURE
3102 Check_Junk_Subprogram_Name
;
3103 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
3104 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
3106 elsif Token
= Tok_Function
then
3108 Error_Msg_SC
("(Ada 83) access to function not allowed!");
3111 Type_Def_Node
:= New_Node
(N_Access_Function_Definition
, Access_Loc
);
3112 Scan
; -- past FUNCTION
3113 Check_Junk_Subprogram_Name
;
3114 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
3115 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
3117 Set_Subtype_Mark
(Type_Def_Node
, P_Subtype_Mark
);
3122 New_Node
(N_Access_To_Object_Definition
, Access_Loc
);
3124 if Token
= Tok_All
or else Token
= Tok_Constant
then
3126 Error_Msg_SC
("(Ada 83) access modifier not allowed!");
3129 if Token
= Tok_All
then
3130 Set_All_Present
(Type_Def_Node
, True);
3133 Set_Constant_Present
(Type_Def_Node
, True);
3136 Scan
; -- past ALL or CONSTANT
3139 Set_Subtype_Indication
(Type_Def_Node
, P_Subtype_Indication
);
3142 return Type_Def_Node
;
3143 end P_Access_Type_Definition
;
3145 ---------------------------------------
3146 -- 3.10 Access To Object Definition --
3147 ---------------------------------------
3149 -- Parsed by P_Access_Type_Definition (3.10)
3151 -----------------------------------
3152 -- 3.10 General Access Modifier --
3153 -----------------------------------
3155 -- Parsed by P_Access_Type_Definition (3.10)
3157 -------------------------------------------
3158 -- 3.10 Access To Subprogram Definition --
3159 -------------------------------------------
3161 -- Parsed by P_Access_Type_Definition (3.10)
3163 -----------------------------
3164 -- 3.10 Access Definition --
3165 -----------------------------
3167 -- ACCESS_DEFINITION ::= access SUBTYPE_MARK
3169 -- The caller has checked that the initial token is ACCESS
3171 -- Error recovery: cannot raise Error_Resync
3173 function P_Access_Definition
return Node_Id
is
3177 Def_Node
:= New_Node
(N_Access_Definition
, Token_Ptr
);
3178 Scan
; -- past ACCESS
3179 Set_Subtype_Mark
(Def_Node
, P_Subtype_Mark
);
3182 end P_Access_Definition
;
3184 -----------------------------------------
3185 -- 3.10.1 Incomplete Type Declaration --
3186 -----------------------------------------
3188 -- Parsed by P_Type_Declaration (3.2.1)
3190 ----------------------------
3191 -- 3.11 Declarative Part --
3192 ----------------------------
3194 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
3196 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items
3197 -- handles errors, and returns cleanly after an error has occurred)
3199 function P_Declarative_Part
return List_Id
is
3204 -- Indicate no bad declarations detected yet. This will be reset by
3205 -- P_Declarative_Items if a bad declaration is discovered.
3207 Missing_Begin_Msg
:= No_Error_Msg
;
3209 -- Get rid of active SIS entry from outer scope. This means we will
3210 -- miss some nested cases, but it doesn't seem worth the effort. See
3211 -- discussion in Par for further details
3213 SIS_Entry_Active
:= False;
3216 -- Loop to scan out the declarations
3219 P_Declarative_Items
(Decls
, Done
, In_Spec
=> False);
3223 -- Get rid of active SIS entry which is left set only if we scanned a
3224 -- procedure declaration and have not found the body. We could give
3225 -- an error message, but that really would be usurping the role of
3226 -- semantic analysis (this really is a missing body case).
3228 SIS_Entry_Active
:= False;
3230 end P_Declarative_Part
;
3232 ----------------------------
3233 -- 3.11 Declarative Item --
3234 ----------------------------
3236 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
3238 -- Can return Error if a junk declaration is found, or Empty if no
3239 -- declaration is found (i.e. a token ending declarations, such as
3240 -- BEGIN or END is encountered).
3242 -- Error recovery: cannot raise Error_Resync. If an error resync occurs,
3243 -- then the scan is set past the next semicolon and Error is returned.
3245 procedure P_Declarative_Items
3250 Scan_State
: Saved_Scan_State
;
3253 if Style_Check
then Style
.Check_Indentation
; end if;
3257 when Tok_Function
=>
3259 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3265 -- Check for loop (premature statement)
3267 Save_Scan_State
(Scan_State
);
3270 if Token
= Tok_Identifier
then
3271 Scan
; -- past identifier
3273 if Token
= Tok_In
then
3274 Restore_Scan_State
(Scan_State
);
3275 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
3280 -- Not a loop, so must be rep clause
3282 Restore_Scan_State
(Scan_State
);
3283 Append
(P_Representation_Clause
, Decls
);
3288 Append
(P_Generic
, Decls
);
3291 when Tok_Identifier
=>
3293 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
3297 Append
(P_Package
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3301 Append
(P_Pragma
, Decls
);
3304 when Tok_Procedure
=>
3306 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3309 when Tok_Protected
=>
3311 Scan
; -- past PROTECTED
3312 Append
(P_Protected
, Decls
);
3317 Append
(P_Subtype_Declaration
, Decls
);
3323 Append
(P_Task
, Decls
);
3328 Append
(P_Type_Declaration
, Decls
);
3333 Append
(P_Use_Clause
, Decls
);
3338 Error_Msg_SC
("WITH can only appear in context clause");
3341 -- BEGIN terminates the scan of a sequence of declarations unless
3342 -- there is a missing subprogram body, see section on handling
3343 -- semicolon in place of IS. We only treat the begin as satisfying
3344 -- the subprogram declaration if it falls in the expected column
3348 if SIS_Entry_Active
and then Start_Column
>= SIS_Ecol
then
3350 -- Here we have the case where a BEGIN is encountered during
3351 -- declarations in a declarative part, or at the outer level,
3352 -- and there is a subprogram declaration outstanding for which
3353 -- no body has been supplied. This is the case where we assume
3354 -- that the semicolon in the subprogram declaration should
3355 -- really have been is. The active SIS entry describes the
3356 -- subprogram declaration. On return the declaration has been
3357 -- modified to become a body.
3360 Specification_Node
: Node_Id
;
3361 Decl_Node
: Node_Id
;
3362 Body_Node
: Node_Id
;
3365 -- First issue the error message. If we had a missing
3366 -- semicolon in the declaration, then change the message
3367 -- to <missing "is">
3369 if SIS_Missing_Semicolon_Message
/= No_Error_Msg
then
3370 Change_Error_Text
-- Replace: "missing "";"" "
3371 (SIS_Missing_Semicolon_Message
, "missing ""is""");
3373 -- Otherwise we saved the semicolon position, so complain
3376 Error_Msg
(""";"" should be IS", SIS_Semicolon_Sloc
);
3379 -- The next job is to fix up any declarations that occurred
3380 -- between the procedure header and the BEGIN. These got
3381 -- chained to the outer declarative region (immediately
3382 -- after the procedure declaration) and they should be
3383 -- chained to the subprogram itself, which is a body
3384 -- rather than a spec.
3386 Specification_Node
:= Specification
(SIS_Declaration_Node
);
3387 Change_Node
(SIS_Declaration_Node
, N_Subprogram_Body
);
3388 Body_Node
:= SIS_Declaration_Node
;
3389 Set_Specification
(Body_Node
, Specification_Node
);
3390 Set_Declarations
(Body_Node
, New_List
);
3393 Decl_Node
:= Remove_Next
(Body_Node
);
3394 exit when Decl_Node
= Empty
;
3395 Append
(Decl_Node
, Declarations
(Body_Node
));
3398 -- Now make the scope table entry for the Begin-End and
3402 Scope
.Table
(Scope
.Last
).Sloc
:= SIS_Sloc
;
3403 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
3404 Scope
.Table
(Scope
.Last
).Ecol
:= SIS_Ecol
;
3405 Scope
.Table
(Scope
.Last
).Labl
:= SIS_Labl
;
3406 Scope
.Table
(Scope
.Last
).Lreq
:= False;
3407 SIS_Entry_Active
:= False;
3409 Set_Handled_Statement_Sequence
(Body_Node
,
3410 P_Handled_Sequence_Of_Statements
);
3411 End_Statements
(Handled_Statement_Sequence
(Body_Node
));
3420 -- Normally an END terminates the scan for basic declarative
3421 -- items. The one exception is END RECORD, which is probably
3422 -- left over from some other junk.
3425 Save_Scan_State
(Scan_State
); -- at END
3428 if Token
= Tok_Record
then
3429 Error_Msg_SP
("no RECORD for this `end record`!");
3430 Scan
; -- past RECORD
3434 Restore_Scan_State
(Scan_State
); -- to END
3438 -- The following tokens which can only be the start of a statement
3439 -- are considered to end a declarative part (i.e. we have a missing
3440 -- BEGIN situation). We are fairly conservative in making this
3441 -- judgment, because it is a real mess to go into statement mode
3442 -- prematurely in response to a junk declaration.
3457 -- But before we decide that it's a statement, let's check for
3458 -- a reserved word misused as an identifier.
3460 if Is_Reserved_Identifier
then
3461 Save_Scan_State
(Scan_State
);
3462 Scan
; -- past the token
3464 -- If reserved identifier not followed by colon or comma, then
3465 -- this is most likely an assignment statement to the bad id.
3467 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
3468 Restore_Scan_State
(Scan_State
);
3469 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
3472 -- Otherwise we have a declaration of the bad id
3475 Restore_Scan_State
(Scan_State
);
3476 Scan_Reserved_Identifier
(Force_Msg
=> True);
3477 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
3480 -- If not reserved identifier, then it's definitely a statement
3483 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
3487 -- The token RETURN may well also signal a missing BEGIN situation,
3488 -- however, we never let it end the declarative part, because it may
3489 -- also be part of a half-baked function declaration.
3492 Error_Msg_SC
("misplaced RETURN statement");
3495 -- PRIVATE definitely terminates the declarations in a spec,
3496 -- and is an error in a body.
3502 Error_Msg_SC
("PRIVATE not allowed in body");
3503 Scan
; -- past PRIVATE
3506 -- An end of file definitely terminates the declarations!
3511 -- The remaining tokens do not end the scan, but cannot start a
3512 -- valid declaration, so we signal an error and resynchronize.
3513 -- But first check for misuse of a reserved identifier.
3517 -- Here we check for a reserved identifier
3519 if Is_Reserved_Identifier
then
3520 Save_Scan_State
(Scan_State
);
3521 Scan
; -- past the token
3523 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
3524 Restore_Scan_State
(Scan_State
);
3525 Set_Declaration_Expected
;
3528 Restore_Scan_State
(Scan_State
);
3529 Scan_Reserved_Identifier
(Force_Msg
=> True);
3531 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
3535 Set_Declaration_Expected
;
3540 -- To resynchronize after an error, we scan to the next semicolon and
3541 -- return with Done = False, indicating that there may still be more
3542 -- valid declarations to come.
3545 when Error_Resync
=>
3546 Resync_Past_Semicolon
;
3549 end P_Declarative_Items
;
3551 ----------------------------------
3552 -- 3.11 Basic Declarative Item --
3553 ----------------------------------
3555 -- BASIC_DECLARATIVE_ITEM ::=
3556 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
3558 -- Scan zero or more basic declarative items
3560 -- Error recovery: cannot raise Error_Resync. If an error is detected, then
3561 -- the scan pointer is repositioned past the next semicolon, and the scan
3562 -- for declarative items continues.
3564 function P_Basic_Declarative_Items
return List_Id
is
3571 -- Get rid of active SIS entry from outer scope. This means we will
3572 -- miss some nested cases, but it doesn't seem worth the effort. See
3573 -- discussion in Par for further details
3575 SIS_Entry_Active
:= False;
3577 -- Loop to scan out declarations
3582 P_Declarative_Items
(Decls
, Done
, In_Spec
=> True);
3586 -- Get rid of active SIS entry. This is set only if we have scanned a
3587 -- procedure declaration and have not found the body. We could give
3588 -- an error message, but that really would be usurping the role of
3589 -- semantic analysis (this really is a case of a missing body).
3591 SIS_Entry_Active
:= False;
3593 -- Test for assorted illegal declarations not diagnosed elsewhere.
3595 Decl
:= First
(Decls
);
3597 while Present
(Decl
) loop
3598 Kind
:= Nkind
(Decl
);
3600 -- Test for body scanned, not acceptable as basic decl item
3602 if Kind
= N_Subprogram_Body
or else
3603 Kind
= N_Package_Body
or else
3604 Kind
= N_Task_Body
or else
3605 Kind
= N_Protected_Body
3608 ("proper body not allowed in package spec", Sloc
(Decl
));
3610 -- Test for body stub scanned, not acceptable as basic decl item
3612 elsif Kind
in N_Body_Stub
then
3614 ("body stub not allowed in package spec", Sloc
(Decl
));
3616 elsif Kind
= N_Assignment_Statement
then
3618 ("assignment statement not allowed in package spec",
3626 end P_Basic_Declarative_Items
;
3632 -- For proper body, see below
3633 -- For body stub, see 10.1.3
3635 -----------------------
3636 -- 3.11 Proper Body --
3637 -----------------------
3639 -- Subprogram body is parsed by P_Subprogram (6.1)
3640 -- Package body is parsed by P_Package (7.1)
3641 -- Task body is parsed by P_Task (9.1)
3642 -- Protected body is parsed by P_Protected (9.4)
3644 ------------------------------
3645 -- Set_Declaration_Expected --
3646 ------------------------------
3648 procedure Set_Declaration_Expected
is
3650 Error_Msg_SC
("declaration expected");
3652 if Missing_Begin_Msg
= No_Error_Msg
then
3653 Missing_Begin_Msg
:= Get_Msg_Id
;
3655 end Set_Declaration_Expected
;
3657 ----------------------
3658 -- Skip_Declaration --
3659 ----------------------
3661 procedure Skip_Declaration
(S
: List_Id
) is
3662 Dummy_Done
: Boolean;
3665 P_Declarative_Items
(S
, Dummy_Done
, False);
3666 end Skip_Declaration
;
3668 -----------------------------------------
3669 -- Statement_When_Declaration_Expected --
3670 -----------------------------------------
3672 procedure Statement_When_Declaration_Expected
3678 -- Case of second occurrence of statement in one declaration sequence
3680 if Missing_Begin_Msg
/= No_Error_Msg
then
3682 -- In the procedure spec case, just ignore it, we only give one
3683 -- message for the first occurrence, since otherwise we may get
3684 -- horrible cascading if BODY was missing in the header line.
3689 -- In the declarative part case, take a second statement as a sure
3690 -- sign that we really have a missing BEGIN, and end the declarative
3691 -- part now. Note that the caller will fix up the first message to
3692 -- say "missing BEGIN" so that's how the error will be signalled.
3699 -- Case of first occurrence of unexpected statement
3702 -- If we are in a package spec, then give message of statement
3703 -- not allowed in package spec. This message never gets changed.
3706 Error_Msg_SC
("statement not allowed in package spec");
3708 -- If in declarative part, then we give the message complaining
3709 -- about finding a statement when a declaration is expected. This
3710 -- gets changed to a complaint about a missing BEGIN if we later
3711 -- find that no BEGIN is present.
3714 Error_Msg_SC
("statement not allowed in declarative part");
3717 -- Capture message Id. This is used for two purposes, first to
3718 -- stop multiple messages, see test above, and second, to allow
3719 -- the replacement of the message in the declarative part case.
3721 Missing_Begin_Msg
:= Get_Msg_Id
;
3724 -- In all cases except the case in which we decided to terminate the
3725 -- declaration sequence on a second error, we scan out the statement
3726 -- and append it to the list of declarations (note that the semantics
3727 -- can handle statements in a declaration list so if we proceed to
3728 -- call the semantic phase, all will be (reasonably) well!
3730 Append_List_To
(Decls
, P_Sequence_Of_Statements
(SS_Unco
));
3732 -- Done is set to False, since we want to continue the scan of
3733 -- declarations, hoping that this statement was a temporary glitch.
3734 -- If we indeed are now in the statement part (i.e. this was a missing
3735 -- BEGIN, then it's not terrible, we will simply keep calling this
3736 -- procedure to process the statements one by one, and then finally
3737 -- hit the missing BEGIN, which will clean up the error message.
3741 end Statement_When_Declaration_Expected
;