1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
26 ------------------------------------------------------------------------------
28 pragma Style_Checks
(All_Checks
);
29 -- Turn off subprogram body ordering check. Subprograms are in order
30 -- by RM section rather than alphabetical
32 with Sinfo
.CN
; use Sinfo
.CN
;
38 -----------------------
39 -- Local Subprograms --
40 -----------------------
42 function P_Component_List
return Node_Id
;
43 function P_Defining_Character_Literal
return Node_Id
;
44 function P_Delta_Constraint
return Node_Id
;
45 function P_Derived_Type_Def_Or_Private_Ext_Decl
return Node_Id
;
46 function P_Digits_Constraint
return Node_Id
;
47 function P_Discriminant_Association
return Node_Id
;
48 function P_Enumeration_Literal_Specification
return Node_Id
;
49 function P_Enumeration_Type_Definition
return Node_Id
;
50 function P_Fixed_Point_Definition
return Node_Id
;
51 function P_Floating_Point_Definition
return Node_Id
;
52 function P_Index_Or_Discriminant_Constraint
return Node_Id
;
53 function P_Real_Range_Specification_Opt
return Node_Id
;
54 function P_Subtype_Declaration
return Node_Id
;
55 function P_Type_Declaration
return Node_Id
;
56 function P_Modular_Type_Definition
return Node_Id
;
57 function P_Variant
return Node_Id
;
58 function P_Variant_Part
return Node_Id
;
60 procedure P_Declarative_Items
64 -- Scans out a single declarative item, or, in the case of a declaration
65 -- with a list of identifiers, a list of declarations, one for each of
66 -- the identifiers in the list. The declaration or declarations scanned
67 -- are appended to the given list. Done indicates whether or not there
68 -- may be additional declarative items to scan. If Done is True, then
69 -- a decision has been made that there are no more items to scan. If
70 -- Done is False, then there may be additional declarations to scan.
71 -- In_Spec is true if we are scanning a package declaration, and is used
72 -- to generate an appropriate message if a statement is encountered in
75 procedure P_Identifier_Declarations
79 -- Scans out a set of declarations for an identifier or list of
80 -- identifiers, and appends them to the given list. The parameters have
81 -- the same significance as for P_Declarative_Items.
83 procedure Statement_When_Declaration_Expected
87 -- Called when a statement is found at a point where a declaration was
88 -- expected. The parameters are as described for P_Declarative_Items.
90 procedure Set_Declaration_Expected
;
91 -- Posts a "declaration expected" error messages at the start of the
92 -- current token, and if this is the first such message issued, saves
93 -- the message id in Missing_Begin_Msg, for possible later replacement.
99 function Init_Expr_Opt
(P
: Boolean := False) return Node_Id
is
101 if Token
= Tok_Colon_Equal
102 or else Token
= Tok_Equal
103 or else Token
= Tok_Colon
104 or else Token
= Tok_Is
108 -- One other possibility. If we have a literal followed by a semicolon,
109 -- we assume that we have a missing colon-equal.
111 elsif Token
in Token_Class_Literal
then
113 Scan_State
: Saved_Scan_State
;
116 Save_Scan_State
(Scan_State
);
117 Scan
; -- past literal or identifier
119 if Token
= Tok_Semicolon
then
120 Restore_Scan_State
(Scan_State
);
122 Restore_Scan_State
(Scan_State
);
127 -- Otherwise we definitely have no initialization expression
133 -- Merge here if we have an initialization expression
140 return P_Expression_No_Right_Paren
;
144 ----------------------------
145 -- 3.1 Basic Declaration --
146 ----------------------------
148 -- Parsed by P_Basic_Declarative_Items (3.9)
150 ------------------------------
151 -- 3.1 Defining Identifier --
152 ------------------------------
154 -- DEFINING_IDENTIFIER ::= IDENTIFIER
156 -- Error recovery: can raise Error_Resync
158 function P_Defining_Identifier
return Node_Id
is
159 Ident_Node
: Node_Id
;
162 -- Scan out the identifier. Note that this code is essentially identical
163 -- to P_Identifier, except that in the call to Scan_Reserved_Identifier
164 -- we set Force_Msg to True, since we want at least one message for each
165 -- separate declaration (but not use) of a reserved identifier.
167 if Token
= Tok_Identifier
then
170 -- If we have a reserved identifier, manufacture an identifier with
171 -- a corresponding name after posting an appropriate error message
173 elsif Is_Reserved_Identifier
then
174 Scan_Reserved_Identifier
(Force_Msg
=> True);
176 -- Otherwise we have junk that cannot be interpreted as an identifier
179 T_Identifier
; -- to give message
183 Ident_Node
:= Token_Node
;
184 Scan
; -- past the reserved identifier
186 if Ident_Node
/= Error
then
187 Change_Identifier_To_Defining_Identifier
(Ident_Node
);
191 end P_Defining_Identifier
;
193 -----------------------------
194 -- 3.2.1 Type Declaration --
195 -----------------------------
197 -- TYPE_DECLARATION ::=
198 -- FULL_TYPE_DECLARATION
199 -- | INCOMPLETE_TYPE_DECLARATION
200 -- | PRIVATE_TYPE_DECLARATION
201 -- | PRIVATE_EXTENSION_DECLARATION
203 -- FULL_TYPE_DECLARATION ::=
204 -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION;
205 -- | CONCURRENT_TYPE_DECLARATION
207 -- INCOMPLETE_TYPE_DECLARATION ::=
208 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART];
210 -- PRIVATE_TYPE_DECLARATION ::=
211 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
212 -- is [abstract] [tagged] [limited] private;
214 -- PRIVATE_EXTENSION_DECLARATION ::=
215 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
216 -- [abstract] new ancestor_SUBTYPE_INDICATION with private;
218 -- TYPE_DEFINITION ::=
219 -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
220 -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION
221 -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION
222 -- | DERIVED_TYPE_DEFINITION
224 -- INTEGER_TYPE_DEFINITION ::=
225 -- SIGNED_INTEGER_TYPE_DEFINITION
226 -- MODULAR_TYPE_DEFINITION
228 -- Error recovery: can raise Error_Resync
230 -- Note: The processing for full type declaration, incomplete type
231 -- declaration, private type declaration and type definition is
232 -- included in this function. The processing for concurrent type
233 -- declarations is NOT here, but rather in chapter 9 (i.e. this
234 -- function handles only declarations starting with TYPE).
236 function P_Type_Declaration
return Node_Id
is
237 Type_Loc
: Source_Ptr
;
238 Type_Start_Col
: Column_Number
;
239 Ident_Node
: Node_Id
;
241 Discr_List
: List_Id
;
242 Unknown_Dis
: Boolean;
243 Discr_Sloc
: Source_Ptr
;
244 Abstract_Present
: Boolean;
245 Abstract_Loc
: Source_Ptr
;
248 Typedef_Node
: Node_Id
;
249 -- Normally holds type definition, except in the case of a private
250 -- extension declaration, in which case it holds the declaration itself
253 Type_Loc
:= Token_Ptr
;
254 Type_Start_Col
:= Start_Column
;
256 Ident_Node
:= P_Defining_Identifier
;
257 Discr_Sloc
:= Token_Ptr
;
259 if P_Unknown_Discriminant_Part_Opt
then
261 Discr_List
:= No_List
;
263 Unknown_Dis
:= False;
264 Discr_List
:= P_Known_Discriminant_Part_Opt
;
267 -- Incomplete type declaration. We complete the processing for this
268 -- case here and return the resulting incomplete type declaration node
270 if Token
= Tok_Semicolon
then
272 Decl_Node
:= New_Node
(N_Incomplete_Type_Declaration
, Type_Loc
);
273 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
274 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
275 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
282 -- Full type declaration or private type declaration, must have IS
284 if Token
= Tok_Equal
then
286 Scan
; -- past = used in place of IS
288 elsif Token
= Tok_Renames
then
289 Error_Msg_SC
("RENAMES should be IS");
290 Scan
; -- past RENAMES used in place of IS
296 -- First an error check, if we have two identifiers in a row, a likely
297 -- possibility is that the first of the identifiers is an incorrectly
300 if Token
= Tok_Identifier
then
302 SS
: Saved_Scan_State
;
306 Save_Scan_State
(SS
);
307 Scan
; -- past initial identifier
308 I2
:= (Token
= Tok_Identifier
);
309 Restore_Scan_State
(SS
);
313 (Bad_Spelling_Of
(Tok_Abstract
) or else
314 Bad_Spelling_Of
(Tok_Access
) or else
315 Bad_Spelling_Of
(Tok_Aliased
) or else
316 Bad_Spelling_Of
(Tok_Constant
))
323 -- Check for misuse of Ada 95 keyword abstract in Ada 83 mode
325 if Token_Name
= Name_Abstract
then
326 Check_95_Keyword
(Tok_Abstract
, Tok_Tagged
);
327 Check_95_Keyword
(Tok_Abstract
, Tok_New
);
330 -- Check cases of misuse of ABSTRACT
332 if Token
= Tok_Abstract
then
333 Abstract_Present
:= True;
334 Abstract_Loc
:= Token_Ptr
;
335 Scan
; -- past ABSTRACT
337 if Token
= Tok_Limited
338 or else Token
= Tok_Private
339 or else Token
= Tok_Record
340 or else Token
= Tok_Null
342 Error_Msg_AP
("TAGGED expected");
346 Abstract_Present
:= False;
347 Abstract_Loc
:= No_Location
;
350 -- Check for misuse of Ada 95 keyword Tagged
352 if Token_Name
= Name_Tagged
then
353 Check_95_Keyword
(Tok_Tagged
, Tok_Private
);
354 Check_95_Keyword
(Tok_Tagged
, Tok_Limited
);
355 Check_95_Keyword
(Tok_Tagged
, Tok_Record
);
358 -- Special check for misuse of Aliased
360 if Token
= Tok_Aliased
or else Token_Name
= Name_Aliased
then
361 Error_Msg_SC
("ALIASED not allowed in type definition");
362 Scan
; -- past ALIASED
365 -- The following procesing deals with either a private type declaration
366 -- or a full type declaration. In the private type case, we build the
367 -- N_Private_Type_Declaration node, setting its Tagged_Present and
368 -- Limited_Present flags, on encountering the Private keyword, and
369 -- leave Typedef_Node set to Empty. For the full type declaration
370 -- case, Typedef_Node gets set to the type definition.
372 Typedef_Node
:= Empty
;
374 -- Switch on token following the IS. The loop normally runs once. It
375 -- only runs more than once if an error is detected, to try again after
376 -- detecting and fixing up the error.
382 Typedef_Node
:= P_Access_Type_Definition
;
387 Typedef_Node
:= P_Array_Type_Definition
;
392 Typedef_Node
:= P_Fixed_Point_Definition
;
397 Typedef_Node
:= P_Floating_Point_Definition
;
404 when Tok_Integer_Literal
=>
406 Typedef_Node
:= P_Signed_Integer_Type_Definition
;
411 Typedef_Node
:= P_Record_Definition
;
415 when Tok_Left_Paren
=>
416 Typedef_Node
:= P_Enumeration_Type_Definition
;
419 Make_Identifier
(Token_Ptr
,
420 Chars
=> Chars
(Ident_Node
));
421 Set_Comes_From_Source
(End_Labl
, False);
423 Set_End_Label
(Typedef_Node
, End_Labl
);
428 Typedef_Node
:= P_Modular_Type_Definition
;
433 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
438 Typedef_Node
:= P_Signed_Integer_Type_Definition
;
443 Typedef_Node
:= P_Record_Definition
;
446 Make_Identifier
(Token_Ptr
,
447 Chars
=> Chars
(Ident_Node
));
448 Set_Comes_From_Source
(End_Labl
, False);
450 Set_End_Label
(Typedef_Node
, End_Labl
);
457 if Token
= Tok_Abstract
then
458 Error_Msg_SC
("ABSTRACT must come before TAGGED");
459 Abstract_Present
:= True;
460 Abstract_Loc
:= Token_Ptr
;
461 Scan
; -- past ABSTRACT
464 if Token
= Tok_Limited
then
465 Scan
; -- past LIMITED
467 -- TAGGED LIMITED PRIVATE case
469 if Token
= Tok_Private
then
471 New_Node
(N_Private_Type_Declaration
, Type_Loc
);
472 Set_Tagged_Present
(Decl_Node
, True);
473 Set_Limited_Present
(Decl_Node
, True);
474 Scan
; -- past PRIVATE
476 -- TAGGED LIMITED RECORD
479 Typedef_Node
:= P_Record_Definition
;
480 Set_Tagged_Present
(Typedef_Node
, True);
481 Set_Limited_Present
(Typedef_Node
, True);
484 Make_Identifier
(Token_Ptr
,
485 Chars
=> Chars
(Ident_Node
));
486 Set_Comes_From_Source
(End_Labl
, False);
488 Set_End_Label
(Typedef_Node
, End_Labl
);
494 if Token
= Tok_Private
then
496 New_Node
(N_Private_Type_Declaration
, Type_Loc
);
497 Set_Tagged_Present
(Decl_Node
, True);
498 Scan
; -- past PRIVATE
503 Typedef_Node
:= P_Record_Definition
;
504 Set_Tagged_Present
(Typedef_Node
, True);
507 Make_Identifier
(Token_Ptr
,
508 Chars
=> Chars
(Ident_Node
));
509 Set_Comes_From_Source
(End_Labl
, False);
511 Set_End_Label
(Typedef_Node
, End_Labl
);
519 Decl_Node
:= New_Node
(N_Private_Type_Declaration
, Type_Loc
);
520 Scan
; -- past PRIVATE
525 Scan
; -- past LIMITED
528 if Token
= Tok_Tagged
then
529 Error_Msg_SC
("TAGGED must come before LIMITED");
532 elsif Token
= Tok_Abstract
then
533 Error_Msg_SC
("ABSTRACT must come before LIMITED");
534 Scan
; -- past ABSTRACT
541 -- LIMITED RECORD or LIMITED NULL RECORD
543 if Token
= Tok_Record
or else Token
= Tok_Null
then
546 ("(Ada 83) limited record declaration not allowed!");
549 Typedef_Node
:= P_Record_Definition
;
550 Set_Limited_Present
(Typedef_Node
, True);
552 -- LIMITED PRIVATE is the only remaining possibility here
555 Decl_Node
:= New_Node
(N_Private_Type_Declaration
, Type_Loc
);
556 Set_Limited_Present
(Decl_Node
, True);
557 T_Private
; -- past PRIVATE (or complain if not there!)
563 -- Here we have an identifier after the IS, which is certainly
564 -- wrong and which might be one of several different mistakes.
566 when Tok_Identifier
=>
568 -- First case, if identifier is on same line, then probably we
569 -- have something like "type X is Integer .." and the best
570 -- diagnosis is a missing NEW. Note: the missing new message
571 -- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl.
573 if not Token_Is_At_Start_Of_Line
then
574 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
577 -- If the identifier is at the start of the line, and is in the
578 -- same column as the type declaration itself then we consider
579 -- that we had a missing type definition on the previous line
581 elsif Start_Column
<= Type_Start_Col
then
582 Error_Msg_AP
("type definition expected");
583 Typedef_Node
:= Error
;
585 -- If the identifier is at the start of the line, and is in
586 -- a column to the right of the type declaration line, then we
587 -- may have something like:
592 -- and the best diagnosis is a missing record keyword
595 Typedef_Node
:= P_Record_Definition
;
601 -- Anything else is an error
604 if Bad_Spelling_Of
(Tok_Access
)
606 Bad_Spelling_Of
(Tok_Array
)
608 Bad_Spelling_Of
(Tok_Delta
)
610 Bad_Spelling_Of
(Tok_Digits
)
612 Bad_Spelling_Of
(Tok_Limited
)
614 Bad_Spelling_Of
(Tok_Private
)
616 Bad_Spelling_Of
(Tok_Range
)
618 Bad_Spelling_Of
(Tok_Record
)
620 Bad_Spelling_Of
(Tok_Tagged
)
625 Error_Msg_AP
("type definition expected");
632 -- For the private type declaration case, the private type declaration
633 -- node has been built, with the Tagged_Present and Limited_Present
634 -- flags set as needed, and Typedef_Node is left set to Empty.
636 if No
(Typedef_Node
) then
637 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
638 Set_Abstract_Present
(Decl_Node
, Abstract_Present
);
640 -- For a private extension declaration, Typedef_Node contains the
641 -- N_Private_Extension_Declaration node, which we now complete. Note
642 -- that the private extension declaration, unlike a full type
643 -- declaration, does permit unknown discriminants.
645 elsif Nkind
(Typedef_Node
) = N_Private_Extension_Declaration
then
646 Decl_Node
:= Typedef_Node
;
647 Set_Sloc
(Decl_Node
, Type_Loc
);
648 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
649 Set_Abstract_Present
(Typedef_Node
, Abstract_Present
);
651 -- In the full type declaration case, Typedef_Node has the type
652 -- definition and here is where we build the full type declaration
653 -- node. This is also where we check for improper use of an unknown
654 -- discriminant part (not allowed for full type declaration).
657 if Nkind
(Typedef_Node
) = N_Record_Definition
658 or else (Nkind
(Typedef_Node
) = N_Derived_Type_Definition
659 and then Present
(Record_Extension_Part
(Typedef_Node
)))
661 Set_Abstract_Present
(Typedef_Node
, Abstract_Present
);
663 elsif Abstract_Present
then
664 Error_Msg
("ABSTRACT not allowed here, ignored", Abstract_Loc
);
667 Decl_Node
:= New_Node
(N_Full_Type_Declaration
, Type_Loc
);
668 Set_Type_Definition
(Decl_Node
, Typedef_Node
);
672 ("Full type declaration cannot have unknown discriminants",
677 -- Remaining processing is common for all three cases
679 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
680 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
683 end P_Type_Declaration
;
685 ----------------------------------
686 -- 3.2.1 Full Type Declaration --
687 ----------------------------------
689 -- Parsed by P_Type_Declaration (3.2.1)
691 ----------------------------
692 -- 3.2.1 Type Definition --
693 ----------------------------
695 -- Parsed by P_Type_Declaration (3.2.1)
697 --------------------------------
698 -- 3.2.2 Subtype Declaration --
699 --------------------------------
701 -- SUBTYPE_DECLARATION ::=
702 -- subtype DEFINING_IDENTIFIER is SUBTYPE_INDICATION;
704 -- The caller has checked that the initial token is SUBTYPE
706 -- Error recovery: can raise Error_Resync
708 function P_Subtype_Declaration
return Node_Id
is
712 Decl_Node
:= New_Node
(N_Subtype_Declaration
, Token_Ptr
);
713 Scan
; -- past SUBTYPE
714 Set_Defining_Identifier
(Decl_Node
, P_Defining_Identifier
);
717 if Token
= Tok_New
then
718 Error_Msg_SC
("NEW ignored (only allowed in type declaration)");
722 Set_Subtype_Indication
(Decl_Node
, P_Subtype_Indication
);
725 end P_Subtype_Declaration
;
727 -------------------------------
728 -- 3.2.2 Subtype Indication --
729 -------------------------------
731 -- SUBTYPE_INDICATION ::= SUBTYPE_MARK [CONSTRAINT]
733 -- Error recovery: can raise Error_Resync
735 function P_Subtype_Indication
return Node_Id
is
739 if Token
= Tok_Identifier
or else Token
= Tok_Operator_Symbol
then
740 Type_Node
:= P_Subtype_Mark
;
741 return P_Subtype_Indication
(Type_Node
);
744 -- Check for error of using record definition and treat it nicely,
745 -- otherwise things are really messed up, so resynchronize.
747 if Token
= Tok_Record
then
748 Error_Msg_SC
("anonymous record definitions are not permitted");
749 Discard_Junk_Node
(P_Record_Definition
);
753 Error_Msg_AP
("subtype indication expected");
757 end P_Subtype_Indication
;
759 -- The following function is identical except that it is called with
760 -- the subtype mark already scanned out, and it scans out the constraint
762 -- Error recovery: can raise Error_Resync
764 function P_Subtype_Indication
(Subtype_Mark
: Node_Id
) return Node_Id
is
765 Indic_Node
: Node_Id
;
766 Constr_Node
: Node_Id
;
769 Constr_Node
:= P_Constraint_Opt
;
771 if No
(Constr_Node
) then
774 Indic_Node
:= New_Node
(N_Subtype_Indication
, Sloc
(Subtype_Mark
));
775 Set_Subtype_Mark
(Indic_Node
, Check_Subtype_Mark
(Subtype_Mark
));
776 Set_Constraint
(Indic_Node
, Constr_Node
);
780 end P_Subtype_Indication
;
782 -------------------------
783 -- 3.2.2 Subtype Mark --
784 -------------------------
786 -- SUBTYPE_MARK ::= subtype_NAME;
788 -- Note: The subtype mark which appears after an IN or NOT IN
789 -- operator is parsed by P_Range_Or_Subtype_Mark (3.5)
791 -- Error recovery: cannot raise Error_Resync
793 function P_Subtype_Mark
return Node_Id
is
795 return P_Subtype_Mark_Resync
;
802 -- This routine differs from P_Subtype_Mark in that it insists that an
803 -- identifier be present, and if it is not, it raises Error_Resync.
805 -- Error recovery: can raise Error_Resync
807 function P_Subtype_Mark_Resync
return Node_Id
is
811 if Token
= Tok_Access
then
812 Error_Msg_SC
("anonymous access type definition not allowed here");
816 if Token
= Tok_Array
then
817 Error_Msg_SC
("anonymous array definition not allowed here");
818 Discard_Junk_Node
(P_Array_Type_Definition
);
822 Type_Node
:= P_Qualified_Simple_Name_Resync
;
824 -- Check for a subtype mark attribute. The only valid possibilities
825 -- are 'CLASS and 'BASE. Anything else is a definite error. We may
826 -- as well catch it here.
828 if Token
= Tok_Apostrophe
then
829 return P_Subtype_Mark_Attribute
(Type_Node
);
834 end P_Subtype_Mark_Resync
;
836 -- The following function is called to scan out a subtype mark attribute.
837 -- The caller has already scanned out the subtype mark, which is passed in
838 -- as the argument, and has checked that the current token is apostrophe.
840 -- Only a special subclass of attributes, called type attributes
841 -- (see Snames package) are allowed in this syntactic position.
843 -- Note: if the apostrophe is followed by other than an identifier, then
844 -- the input expression is returned unchanged, and the scan pointer is
845 -- left pointing to the apostrophe.
847 -- Error recovery: can raise Error_Resync
849 function P_Subtype_Mark_Attribute
(Type_Node
: Node_Id
) return Node_Id
is
850 Attr_Node
: Node_Id
:= Empty
;
851 Scan_State
: Saved_Scan_State
;
855 Prefix
:= Check_Subtype_Mark
(Type_Node
);
857 if Prefix
= Error
then
861 -- Loop through attributes appearing (more than one can appear as for
862 -- for example in X'Base'Class). We are at an apostrophe on entry to
863 -- this loop, and it runs once for each attribute parsed, with
864 -- Prefix being the current possible prefix if it is an attribute.
867 Save_Scan_State
(Scan_State
); -- at Apostrophe
868 Scan
; -- past apostrophe
870 if Token
/= Tok_Identifier
then
871 Restore_Scan_State
(Scan_State
); -- to apostrophe
872 return Prefix
; -- no attribute after all
874 elsif not Is_Type_Attribute_Name
(Token_Name
) then
876 ("attribute & may not be used in a subtype mark", Token_Node
);
881 Make_Attribute_Reference
(Prev_Token_Ptr
,
883 Attribute_Name
=> Token_Name
);
884 Delete_Node
(Token_Node
);
885 Scan
; -- past type attribute identifier
888 exit when Token
/= Tok_Apostrophe
;
892 -- Fall through here after scanning type attribute
895 end P_Subtype_Mark_Attribute
;
897 -----------------------
898 -- 3.2.2 Constraint --
899 -----------------------
901 -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
903 -- SCALAR_CONSTRAINT ::=
904 -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
906 -- COMPOSITE_CONSTRAINT ::=
907 -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
909 -- If no constraint is present, this function returns Empty
911 -- Error recovery: can raise Error_Resync
913 function P_Constraint_Opt
return Node_Id
is
916 or else Bad_Spelling_Of
(Tok_Range
)
918 return P_Range_Constraint
;
920 elsif Token
= Tok_Digits
921 or else Bad_Spelling_Of
(Tok_Digits
)
923 return P_Digits_Constraint
;
925 elsif Token
= Tok_Delta
926 or else Bad_Spelling_Of
(Tok_Delta
)
928 return P_Delta_Constraint
;
930 elsif Token
= Tok_Left_Paren
then
931 return P_Index_Or_Discriminant_Constraint
;
933 elsif Token
= Tok_In
then
935 return P_Constraint_Opt
;
941 end P_Constraint_Opt
;
943 ------------------------------
944 -- 3.2.2 Scalar Constraint --
945 ------------------------------
947 -- Parsed by P_Constraint_Opt (3.2.2)
949 ---------------------------------
950 -- 3.2.2 Composite Constraint --
951 ---------------------------------
953 -- Parsed by P_Constraint_Opt (3.2.2)
955 --------------------------------------------------------
956 -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) --
957 --------------------------------------------------------
959 -- This routine scans out a declaration starting with an identifier:
961 -- OBJECT_DECLARATION ::=
962 -- DEFINING_IDENTIFIER_LIST : [constant] [aliased]
963 -- SUBTYPE_INDICATION [:= EXPRESSION];
964 -- | DEFINING_IDENTIFIER_LIST : [constant] [aliased]
965 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
967 -- NUMBER_DECLARATION ::=
968 -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
970 -- OBJECT_RENAMING_DECLARATION ::=
971 -- DEFINING_IDENTIFIER : SUBTYPE_MARK renames object_NAME;
973 -- EXCEPTION_RENAMING_DECLARATION ::=
974 -- DEFINING_IDENTIFIER : exception renames exception_NAME;
976 -- EXCEPTION_DECLARATION ::=
977 -- DEFINING_IDENTIFIER_LIST : exception;
979 -- Note that the ALIASED indication in an object declaration is
980 -- marked by a flag in the parent node.
982 -- The caller has checked that the initial token is an identifier
984 -- The value returned is a list of declarations, one for each identifier
985 -- in the list (as described in Sinfo, we always split up multiple
986 -- declarations into the equivalent sequence of single declarations
987 -- using the More_Ids and Prev_Ids flags to preserve the source).
989 -- If the identifier turns out to be a probable statement rather than
990 -- an identifier, then the scan is left pointing to the identifier and
991 -- No_List is returned.
993 -- Error recovery: can raise Error_Resync
995 procedure P_Identifier_Declarations
1000 Decl_Node
: Node_Id
;
1001 Type_Node
: Node_Id
;
1002 Ident_Sloc
: Source_Ptr
;
1003 Scan_State
: Saved_Scan_State
;
1004 List_OK
: Boolean := True;
1006 Init_Expr
: Node_Id
;
1007 Init_Loc
: Source_Ptr
;
1008 Con_Loc
: Source_Ptr
;
1010 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
1011 -- Used to save identifiers in the identifier list. The upper bound
1012 -- of 4096 is expected to be infinite in practice, and we do not even
1013 -- bother to check if this upper bound is exceeded.
1015 Num_Idents
: Nat
:= 1;
1016 -- Number of identifiers stored in Idents
1019 -- This procedure is called in renames cases to make sure that we do
1020 -- not have more than one identifier. If we do have more than one
1021 -- then an error message is issued (and the declaration is split into
1022 -- multiple declarations)
1024 function Token_Is_Renames
return Boolean;
1025 -- Checks if current token is RENAMES, and if so, scans past it and
1026 -- returns True, otherwise returns False. Includes checking for some
1027 -- common error cases.
1029 procedure No_List
is
1031 if Num_Idents
> 1 then
1032 Error_Msg
("identifier list not allowed for RENAMES",
1039 function Token_Is_Renames
return Boolean is
1040 At_Colon
: Saved_Scan_State
;
1043 if Token
= Tok_Colon
then
1044 Save_Scan_State
(At_Colon
);
1046 Check_Misspelling_Of
(Tok_Renames
);
1048 if Token
= Tok_Renames
then
1049 Error_Msg_SP
("extra "":"" ignored");
1050 Scan
; -- past RENAMES
1053 Restore_Scan_State
(At_Colon
);
1058 Check_Misspelling_Of
(Tok_Renames
);
1060 if Token
= Tok_Renames
then
1061 Scan
; -- past RENAMES
1067 end Token_Is_Renames
;
1069 -- Start of processing for P_Identifier_Declarations
1072 Ident_Sloc
:= Token_Ptr
;
1073 Save_Scan_State
(Scan_State
); -- at first identifier
1074 Idents
(1) := P_Defining_Identifier
;
1076 -- If we have a colon after the identifier, then we can assume that
1077 -- this is in fact a valid identifier declaration and can steam ahead.
1079 if Token
= Tok_Colon
then
1082 -- If we have a comma, then scan out the list of identifiers
1084 elsif Token
= Tok_Comma
then
1086 while Comma_Present
loop
1087 Num_Idents
:= Num_Idents
+ 1;
1088 Idents
(Num_Idents
) := P_Defining_Identifier
;
1091 Save_Scan_State
(Scan_State
); -- at colon
1094 -- If we have identifier followed by := then we assume that what is
1095 -- really meant is an assignment statement. The assignment statement
1096 -- is scanned out and added to the list of declarations. An exception
1097 -- occurs if the := is followed by the keyword constant, in which case
1098 -- we assume it was meant to be a colon.
1100 elsif Token
= Tok_Colon_Equal
then
1103 if Token
= Tok_Constant
then
1104 Error_Msg_SP
("colon expected");
1107 Restore_Scan_State
(Scan_State
);
1108 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
1112 -- If we have an IS keyword, then assume the TYPE keyword was missing
1114 elsif Token
= Tok_Is
then
1115 Restore_Scan_State
(Scan_State
);
1116 Append_To
(Decls
, P_Type_Declaration
);
1120 -- Otherwise we have an error situation
1123 Restore_Scan_State
(Scan_State
);
1125 -- First case is possible misuse of PROTECTED in Ada 83 mode. If
1126 -- so, fix the keyword and return to scan the protected declaration.
1128 if Token_Name
= Name_Protected
then
1129 Check_95_Keyword
(Tok_Protected
, Tok_Identifier
);
1130 Check_95_Keyword
(Tok_Protected
, Tok_Type
);
1131 Check_95_Keyword
(Tok_Protected
, Tok_Body
);
1133 if Token
= Tok_Protected
then
1138 -- Check misspelling possibilities. If so, correct the misspelling
1139 -- and return to scan out the resulting declaration.
1141 elsif Bad_Spelling_Of
(Tok_Function
)
1142 or else Bad_Spelling_Of
(Tok_Procedure
)
1143 or else Bad_Spelling_Of
(Tok_Package
)
1144 or else Bad_Spelling_Of
(Tok_Pragma
)
1145 or else Bad_Spelling_Of
(Tok_Protected
)
1146 or else Bad_Spelling_Of
(Tok_Generic
)
1147 or else Bad_Spelling_Of
(Tok_Subtype
)
1148 or else Bad_Spelling_Of
(Tok_Type
)
1149 or else Bad_Spelling_Of
(Tok_Task
)
1150 or else Bad_Spelling_Of
(Tok_Use
)
1151 or else Bad_Spelling_Of
(Tok_For
)
1156 -- Otherwise we definitely have an ordinary identifier with a junk
1157 -- token after it. Just complain that we expect a declaration, and
1158 -- skip to a semicolon
1161 Set_Declaration_Expected
;
1162 Resync_Past_Semicolon
;
1168 -- Come here with an identifier list and colon scanned out. We now
1169 -- build the nodes for the declarative items. One node is built for
1170 -- each identifier in the list, with the type information being
1171 -- repeated by rescanning the appropriate section of source.
1173 -- First an error check, if we have two identifiers in a row, a likely
1174 -- possibility is that the first of the identifiers is an incorrectly
1177 if Token
= Tok_Identifier
then
1179 SS
: Saved_Scan_State
;
1183 Save_Scan_State
(SS
);
1184 Scan
; -- past initial identifier
1185 I2
:= (Token
= Tok_Identifier
);
1186 Restore_Scan_State
(SS
);
1190 (Bad_Spelling_Of
(Tok_Access
) or else
1191 Bad_Spelling_Of
(Tok_Aliased
) or else
1192 Bad_Spelling_Of
(Tok_Constant
))
1199 -- Loop through identifiers
1204 -- Check for some cases of misused Ada 95 keywords
1206 if Token_Name
= Name_Aliased
then
1207 Check_95_Keyword
(Tok_Aliased
, Tok_Array
);
1208 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
1209 Check_95_Keyword
(Tok_Aliased
, Tok_Constant
);
1214 if Token
= Tok_Constant
then
1215 Con_Loc
:= Token_Ptr
;
1216 Scan
; -- past CONSTANT
1218 -- Number declaration, initialization required
1220 Init_Expr
:= Init_Expr_Opt
;
1222 if Present
(Init_Expr
) then
1223 Decl_Node
:= New_Node
(N_Number_Declaration
, Ident_Sloc
);
1224 Set_Expression
(Decl_Node
, Init_Expr
);
1226 -- Constant object declaration
1229 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1230 Set_Constant_Present
(Decl_Node
, True);
1232 if Token_Name
= Name_Aliased
then
1233 Check_95_Keyword
(Tok_Aliased
, Tok_Array
);
1234 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
1237 if Token
= Tok_Aliased
then
1238 Error_Msg_SC
("ALIASED should be before CONSTANT");
1239 Scan
; -- past ALIASED
1240 Set_Aliased_Present
(Decl_Node
, True);
1243 if Token
= Tok_Array
then
1244 Set_Object_Definition
1245 (Decl_Node
, P_Array_Type_Definition
);
1247 Set_Object_Definition
(Decl_Node
, P_Subtype_Indication
);
1250 if Token
= Tok_Renames
then
1252 ("CONSTANT not permitted in renaming declaration",
1254 Scan
; -- Past renames
1255 Discard_Junk_Node
(P_Name
);
1261 elsif Token
= Tok_Exception
then
1262 Scan
; -- past EXCEPTION
1264 if Token_Is_Renames
then
1267 New_Node
(N_Exception_Renaming_Declaration
, Ident_Sloc
);
1268 Set_Name
(Decl_Node
, P_Qualified_Simple_Name_Resync
);
1271 Decl_Node
:= New_Node
(N_Exception_Declaration
, Prev_Token_Ptr
);
1274 -- Aliased case (note that an object definition is required)
1276 elsif Token
= Tok_Aliased
then
1277 Scan
; -- past ALIASED
1278 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1279 Set_Aliased_Present
(Decl_Node
, True);
1281 if Token
= Tok_Constant
then
1282 Scan
; -- past CONSTANT
1283 Set_Constant_Present
(Decl_Node
, True);
1286 if Token
= Tok_Array
then
1287 Set_Object_Definition
1288 (Decl_Node
, P_Array_Type_Definition
);
1290 Set_Object_Definition
(Decl_Node
, P_Subtype_Indication
);
1295 elsif Token
= Tok_Array
then
1296 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1297 Set_Object_Definition
(Decl_Node
, P_Array_Type_Definition
);
1299 -- Subtype indication case
1302 Type_Node
:= P_Subtype_Mark
;
1304 -- Object renaming declaration
1306 if Token_Is_Renames
then
1309 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1310 Set_Subtype_Mark
(Decl_Node
, Type_Node
);
1311 Set_Name
(Decl_Node
, P_Name
);
1313 -- Object declaration
1316 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1317 Set_Object_Definition
1318 (Decl_Node
, P_Subtype_Indication
(Type_Node
));
1320 -- RENAMES at this point means that we had the combination of
1321 -- a constraint on the Type_Node and renames, which is illegal
1323 if Token_Is_Renames
then
1325 ("constraint not allowed in object renaming declaration",
1326 Constraint
(Object_Definition
(Decl_Node
)));
1332 -- Scan out initialization, allowed only for object declaration
1334 Init_Loc
:= Token_Ptr
;
1335 Init_Expr
:= Init_Expr_Opt
;
1337 if Present
(Init_Expr
) then
1338 if Nkind
(Decl_Node
) = N_Object_Declaration
then
1339 Set_Expression
(Decl_Node
, Init_Expr
);
1341 Error_Msg
("initialization not allowed here", Init_Loc
);
1346 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
1349 if Ident
< Num_Idents
then
1350 Set_More_Ids
(Decl_Node
, True);
1354 Set_Prev_Ids
(Decl_Node
, True);
1358 Append
(Decl_Node
, Decls
);
1359 exit Ident_Loop
when Ident
= Num_Idents
;
1360 Restore_Scan_State
(Scan_State
);
1363 end loop Ident_Loop
;
1367 end P_Identifier_Declarations
;
1369 -------------------------------
1370 -- 3.3.1 Object Declaration --
1371 -------------------------------
1373 -- OBJECT DECLARATION ::=
1374 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1375 -- SUBTYPE_INDICATION [:= EXPRESSION];
1376 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1377 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1378 -- | SINGLE_TASK_DECLARATION
1379 -- | SINGLE_PROTECTED_DECLARATION
1381 -- Cases starting with TASK are parsed by P_Task (9.1)
1382 -- Cases starting with PROTECTED are parsed by P_Protected (9.4)
1383 -- All other cases are parsed by P_Identifier_Declarations (3.3)
1385 -------------------------------------
1386 -- 3.3.1 Defining Identifier List --
1387 -------------------------------------
1389 -- DEFINING_IDENTIFIER_LIST ::=
1390 -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
1392 -- Always parsed by the construct in which it appears. See special
1393 -- section on "Handling of Defining Identifier Lists" in this unit.
1395 -------------------------------
1396 -- 3.3.2 Number Declaration --
1397 -------------------------------
1399 -- Parsed by P_Identifier_Declarations (3.3)
1401 -------------------------------------------------------------------------
1402 -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) --
1403 -------------------------------------------------------------------------
1405 -- DERIVED_TYPE_DEFINITION ::=
1406 -- [abstract] new parent_SUBTYPE_INDICATION [RECORD_EXTENSION_PART]
1408 -- PRIVATE_EXTENSION_DECLARATION ::=
1409 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
1410 -- [abstract] new ancestor_SUBTYPE_INDICATION with PRIVATE;
1412 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
1414 -- The caller has already scanned out the part up to the NEW, and Token
1415 -- either contains Tok_New (or ought to, if it doesn't this procedure
1416 -- will post an appropriate "NEW expected" message).
1418 -- Note: the caller is responsible for filling in the Sloc field of
1419 -- the returned node in the private extension declaration case as
1420 -- well as the stuff relating to the discriminant part.
1422 -- Error recovery: can raise Error_Resync;
1424 function P_Derived_Type_Def_Or_Private_Ext_Decl
return Node_Id
is
1425 Typedef_Node
: Node_Id
;
1426 Typedecl_Node
: Node_Id
;
1429 Typedef_Node
:= New_Node
(N_Derived_Type_Definition
, Token_Ptr
);
1432 if Token
= Tok_Abstract
then
1433 Error_Msg_SC
("ABSTRACT must come before NEW, not after");
1437 Set_Subtype_Indication
(Typedef_Node
, P_Subtype_Indication
);
1439 -- Deal with record extension, note that we assume that a WITH is
1440 -- missing in the case of "type X is new Y record ..." or in the
1441 -- case of "type X is new Y null record".
1444 or else Token
= Tok_Record
1445 or else Token
= Tok_Null
1447 T_With
; -- past WITH or give error message
1449 if Token
= Tok_Limited
then
1451 ("LIMITED keyword not allowed in private extension");
1452 Scan
; -- ignore LIMITED
1455 -- Private extension declaration
1457 if Token
= Tok_Private
then
1458 Scan
; -- past PRIVATE
1460 -- Throw away the type definition node and build the type
1461 -- declaration node. Note the caller must set the Sloc,
1462 -- Discriminant_Specifications, Unknown_Discriminants_Present,
1463 -- and Defined_Identifier fields in the returned node.
1466 Make_Private_Extension_Declaration
(No_Location
,
1467 Defining_Identifier
=> Empty
,
1468 Subtype_Indication
=> Subtype_Indication
(Typedef_Node
),
1469 Abstract_Present
=> Abstract_Present
(Typedef_Node
));
1471 Delete_Node
(Typedef_Node
);
1472 return Typedecl_Node
;
1474 -- Derived type definition with record extension part
1477 Set_Record_Extension_Part
(Typedef_Node
, P_Record_Definition
);
1478 return Typedef_Node
;
1481 -- Derived type definition with no record extension part
1484 return Typedef_Node
;
1486 end P_Derived_Type_Def_Or_Private_Ext_Decl
;
1488 ---------------------------
1489 -- 3.5 Range Constraint --
1490 ---------------------------
1492 -- RANGE_CONSTRAINT ::= range RANGE
1494 -- The caller has checked that the initial token is RANGE
1496 -- Error recovery: cannot raise Error_Resync
1498 function P_Range_Constraint
return Node_Id
is
1499 Range_Node
: Node_Id
;
1502 Range_Node
:= New_Node
(N_Range_Constraint
, Token_Ptr
);
1504 Set_Range_Expression
(Range_Node
, P_Range
);
1506 end P_Range_Constraint
;
1513 -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
1515 -- Note: the range that appears in a membership test is parsed by
1516 -- P_Range_Or_Subtype_Mark (3.5).
1518 -- Error recovery: cannot raise Error_Resync
1520 function P_Range
return Node_Id
is
1521 Expr_Node
: Node_Id
;
1522 Range_Node
: Node_Id
;
1525 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
1527 if Expr_Form
= EF_Range_Attr
then
1530 elsif Token
= Tok_Dot_Dot
then
1531 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
1532 Set_Low_Bound
(Range_Node
, Expr_Node
);
1534 Expr_Node
:= P_Expression
;
1535 Check_Simple_Expression
(Expr_Node
);
1536 Set_High_Bound
(Range_Node
, Expr_Node
);
1539 -- Anything else is an error
1542 T_Dot_Dot
; -- force missing .. message
1547 ----------------------------------
1548 -- 3.5 P_Range_Or_Subtype_Mark --
1549 ----------------------------------
1552 -- RANGE_ATTRIBUTE_REFERENCE
1553 -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
1555 -- This routine scans out the range or subtype mark that forms the right
1556 -- operand of a membership test.
1558 -- Note: as documented in the Sinfo interface, although the syntax only
1559 -- allows a subtype mark, we in fact allow any simple expression to be
1560 -- returned from this routine. The semantics is responsible for issuing
1561 -- an appropriate message complaining if the argument is not a name.
1562 -- This simplifies the coding and error recovery processing in the
1563 -- parser, and in any case it is preferable not to consider this a
1564 -- syntax error and to continue with the semantic analysis.
1566 -- Error recovery: cannot raise Error_Resync
1568 function P_Range_Or_Subtype_Mark
return Node_Id
is
1569 Expr_Node
: Node_Id
;
1570 Range_Node
: Node_Id
;
1573 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
1575 if Expr_Form
= EF_Range_Attr
then
1578 -- Simple_Expression .. Simple_Expression
1580 elsif Token
= Tok_Dot_Dot
then
1581 Check_Simple_Expression
(Expr_Node
);
1582 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
1583 Set_Low_Bound
(Range_Node
, Expr_Node
);
1585 Set_High_Bound
(Range_Node
, P_Simple_Expression
);
1588 -- Case of subtype mark (optionally qualified simple name or an
1589 -- attribute whose prefix is an optionally qualifed simple name)
1591 elsif Expr_Form
= EF_Simple_Name
1592 or else Nkind
(Expr_Node
) = N_Attribute_Reference
1594 -- Check for error of range constraint after a subtype mark
1596 if Token
= Tok_Range
then
1598 ("range constraint not allowed in membership test");
1602 -- Check for error of DIGITS or DELTA after a subtype mark
1604 elsif Token
= Tok_Digits
or else Token
= Tok_Delta
then
1606 ("accuracy definition not allowed in membership test");
1607 Scan
; -- past DIGITS or DELTA
1610 elsif Token
= Tok_Apostrophe
then
1611 return P_Subtype_Mark_Attribute
(Expr_Node
);
1617 -- At this stage, we have some junk following the expression. We
1618 -- really can't tell what is wrong, might be a missing semicolon,
1619 -- or a missing THEN, or whatever. Our caller will figure it out!
1624 end P_Range_Or_Subtype_Mark
;
1626 ----------------------------------------
1627 -- 3.5.1 Enumeration Type Definition --
1628 ----------------------------------------
1630 -- ENUMERATION_TYPE_DEFINITION ::=
1631 -- (ENUMERATION_LITERAL_SPECIFICATION
1632 -- {, ENUMERATION_LITERAL_SPECIFICATION})
1634 -- The caller has already scanned out the TYPE keyword
1636 -- Error recovery: can raise Error_Resync;
1638 function P_Enumeration_Type_Definition
return Node_Id
is
1639 Typedef_Node
: Node_Id
;
1642 Typedef_Node
:= New_Node
(N_Enumeration_Type_Definition
, Token_Ptr
);
1643 Set_Literals
(Typedef_Node
, New_List
);
1648 Append
(P_Enumeration_Literal_Specification
, Literals
(Typedef_Node
));
1649 exit when not Comma_Present
;
1653 return Typedef_Node
;
1654 end P_Enumeration_Type_Definition
;
1656 ----------------------------------------------
1657 -- 3.5.1 Enumeration Literal Specification --
1658 ----------------------------------------------
1660 -- ENUMERATION_LITERAL_SPECIFICATION ::=
1661 -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
1663 -- Error recovery: can raise Error_Resync
1665 function P_Enumeration_Literal_Specification
return Node_Id
is
1667 if Token
= Tok_Char_Literal
then
1668 return P_Defining_Character_Literal
;
1670 return P_Defining_Identifier
;
1672 end P_Enumeration_Literal_Specification
;
1674 ---------------------------------------
1675 -- 3.5.1 Defining_Character_Literal --
1676 ---------------------------------------
1678 -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
1680 -- Error recovery: cannot raise Error_Resync
1682 -- The caller has checked that the current token is a character literal
1684 function P_Defining_Character_Literal
return Node_Id
is
1685 Literal_Node
: Node_Id
;
1688 Literal_Node
:= Token_Node
;
1689 Change_Character_Literal_To_Defining_Character_Literal
(Literal_Node
);
1690 Scan
; -- past character literal
1691 return Literal_Node
;
1692 end P_Defining_Character_Literal
;
1694 ------------------------------------
1695 -- 3.5.4 Integer Type Definition --
1696 ------------------------------------
1698 -- Parsed by P_Type_Declaration (3.2.1)
1700 -------------------------------------------
1701 -- 3.5.4 Signed Integer Type Definition --
1702 -------------------------------------------
1704 -- SIGNED_INTEGER_TYPE_DEFINITION ::=
1705 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
1707 -- Normally the initial token on entry is RANGE, but in some
1708 -- error conditions, the range token was missing and control is
1709 -- passed with Token pointing to first token of the first expression.
1711 -- Error recovery: cannot raise Error_Resync
1713 function P_Signed_Integer_Type_Definition
return Node_Id
is
1714 Typedef_Node
: Node_Id
;
1715 Expr_Node
: Node_Id
;
1718 Typedef_Node
:= New_Node
(N_Signed_Integer_Type_Definition
, Token_Ptr
);
1720 if Token
= Tok_Range
then
1724 Expr_Node
:= P_Expression
;
1725 Check_Simple_Expression
(Expr_Node
);
1726 Set_Low_Bound
(Typedef_Node
, Expr_Node
);
1728 Expr_Node
:= P_Expression
;
1729 Check_Simple_Expression
(Expr_Node
);
1730 Set_High_Bound
(Typedef_Node
, Expr_Node
);
1731 return Typedef_Node
;
1732 end P_Signed_Integer_Type_Definition
;
1734 ------------------------------------
1735 -- 3.5.4 Modular Type Definition --
1736 ------------------------------------
1738 -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
1740 -- The caller has checked that the initial token is MOD
1742 -- Error recovery: cannot raise Error_Resync
1744 function P_Modular_Type_Definition
return Node_Id
is
1745 Typedef_Node
: Node_Id
;
1749 Error_Msg_SC
("(Ada 83): modular types not allowed");
1752 Typedef_Node
:= New_Node
(N_Modular_Type_Definition
, Token_Ptr
);
1754 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
1756 -- Handle mod L..R cleanly
1758 if Token
= Tok_Dot_Dot
then
1759 Error_Msg_SC
("range not allowed for modular type");
1761 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
1764 return Typedef_Node
;
1765 end P_Modular_Type_Definition
;
1767 ---------------------------------
1768 -- 3.5.6 Real Type Definition --
1769 ---------------------------------
1771 -- Parsed by P_Type_Declaration (3.2.1)
1773 --------------------------------------
1774 -- 3.5.7 Floating Point Definition --
1775 --------------------------------------
1777 -- FLOATING_POINT_DEFINITION ::=
1778 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
1780 -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
1782 -- The caller has checked that the initial token is DIGITS
1784 -- Error recovery: cannot raise Error_Resync
1786 function P_Floating_Point_Definition
return Node_Id
is
1787 Digits_Loc
: constant Source_Ptr
:= Token_Ptr
;
1789 Expr_Node
: Node_Id
;
1792 Scan
; -- past DIGITS
1793 Expr_Node
:= P_Expression_No_Right_Paren
;
1794 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
1796 -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
1798 if Token
= Tok_Delta
then
1799 Error_Msg_SC
("DELTA must come before DIGITS");
1800 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Digits_Loc
);
1802 Set_Delta_Expression
(Def_Node
, P_Expression_No_Right_Paren
);
1804 -- OK floating-point definition
1807 Def_Node
:= New_Node
(N_Floating_Point_Definition
, Digits_Loc
);
1810 Set_Digits_Expression
(Def_Node
, Expr_Node
);
1811 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
1813 end P_Floating_Point_Definition
;
1815 -------------------------------------
1816 -- 3.5.7 Real Range Specification --
1817 -------------------------------------
1819 -- REAL_RANGE_SPECIFICATION ::=
1820 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
1822 -- Error recovery: cannot raise Error_Resync
1824 function P_Real_Range_Specification_Opt
return Node_Id
is
1825 Specification_Node
: Node_Id
;
1826 Expr_Node
: Node_Id
;
1829 if Token
= Tok_Range
then
1830 Specification_Node
:=
1831 New_Node
(N_Real_Range_Specification
, Token_Ptr
);
1833 Expr_Node
:= P_Expression_No_Right_Paren
;
1834 Check_Simple_Expression
(Expr_Node
);
1835 Set_Low_Bound
(Specification_Node
, Expr_Node
);
1837 Expr_Node
:= P_Expression_No_Right_Paren
;
1838 Check_Simple_Expression
(Expr_Node
);
1839 Set_High_Bound
(Specification_Node
, Expr_Node
);
1840 return Specification_Node
;
1844 end P_Real_Range_Specification_Opt
;
1846 -----------------------------------
1847 -- 3.5.9 Fixed Point Definition --
1848 -----------------------------------
1850 -- FIXED_POINT_DEFINITION ::=
1851 -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
1853 -- ORDINARY_FIXED_POINT_DEFINITION ::=
1854 -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION
1856 -- DECIMAL_FIXED_POINT_DEFINITION ::=
1857 -- delta static_EXPRESSION
1858 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
1860 -- The caller has checked that the initial token is DELTA
1862 -- Error recovery: cannot raise Error_Resync
1864 function P_Fixed_Point_Definition
return Node_Id
is
1865 Delta_Node
: Node_Id
;
1866 Delta_Loc
: Source_Ptr
;
1868 Expr_Node
: Node_Id
;
1871 Delta_Loc
:= Token_Ptr
;
1873 Delta_Node
:= P_Expression_No_Right_Paren
;
1874 Check_Simple_Expression_In_Ada_83
(Delta_Node
);
1876 if Token
= Tok_Digits
then
1878 Error_Msg_SC
("(Ada 83) decimal fixed type not allowed!");
1881 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Delta_Loc
);
1882 Scan
; -- past DIGITS
1883 Expr_Node
:= P_Expression_No_Right_Paren
;
1884 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
1885 Set_Digits_Expression
(Def_Node
, Expr_Node
);
1888 Def_Node
:= New_Node
(N_Ordinary_Fixed_Point_Definition
, Delta_Loc
);
1890 -- Range is required in ordinary fixed point case
1892 if Token
/= Tok_Range
then
1893 Error_Msg_AP
("range must be given for fixed-point type");
1898 Set_Delta_Expression
(Def_Node
, Delta_Node
);
1899 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
1901 end P_Fixed_Point_Definition
;
1903 --------------------------------------------
1904 -- 3.5.9 Ordinary Fixed Point Definition --
1905 --------------------------------------------
1907 -- Parsed by P_Fixed_Point_Definition (3.5.9)
1909 -------------------------------------------
1910 -- 3.5.9 Decimal Fixed Point Definition --
1911 -------------------------------------------
1913 -- Parsed by P_Decimal_Point_Definition (3.5.9)
1915 ------------------------------
1916 -- 3.5.9 Digits Constraint --
1917 ------------------------------
1919 -- DIGITS_CONSTRAINT ::=
1920 -- digits static_EXPRESSION [RANGE_CONSTRAINT]
1922 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
1924 -- The caller has checked that the initial token is DIGITS
1926 function P_Digits_Constraint
return Node_Id
is
1927 Constraint_Node
: Node_Id
;
1928 Expr_Node
: Node_Id
;
1931 Constraint_Node
:= New_Node
(N_Digits_Constraint
, Token_Ptr
);
1932 Scan
; -- past DIGITS
1933 Expr_Node
:= P_Expression_No_Right_Paren
;
1934 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
1935 Set_Digits_Expression
(Constraint_Node
, Expr_Node
);
1937 if Token
= Tok_Range
then
1938 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
1941 return Constraint_Node
;
1942 end P_Digits_Constraint
;
1944 -----------------------------
1945 -- 3.5.9 Delta Constraint --
1946 -----------------------------
1948 -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
1950 -- Note: this is an obsolescent feature in Ada 95 (I.3)
1952 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
1954 -- The caller has checked that the initial token is DELTA
1956 -- Error recovery: cannot raise Error_Resync
1958 function P_Delta_Constraint
return Node_Id
is
1959 Constraint_Node
: Node_Id
;
1960 Expr_Node
: Node_Id
;
1963 Constraint_Node
:= New_Node
(N_Delta_Constraint
, Token_Ptr
);
1965 Expr_Node
:= P_Expression_No_Right_Paren
;
1966 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
1967 Set_Delta_Expression
(Constraint_Node
, Expr_Node
);
1969 if Token
= Tok_Range
then
1970 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
1973 return Constraint_Node
;
1974 end P_Delta_Constraint
;
1976 --------------------------------
1977 -- 3.6 Array Type Definition --
1978 --------------------------------
1980 -- ARRAY_TYPE_DEFINITION ::=
1981 -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
1983 -- UNCONSTRAINED_ARRAY_DEFINITION ::=
1984 -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
1985 -- COMPONENT_DEFINITION
1987 -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
1989 -- CONSTRAINED_ARRAY_DEFINITION ::=
1990 -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
1991 -- COMPONENT_DEFINITION
1993 -- DISCRETE_SUBTYPE_DEFINITION ::=
1994 -- DISCRETE_SUBTYPE_INDICATION | RANGE
1996 -- COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION
1998 -- The caller has checked that the initial token is ARRAY
2000 -- Error recovery: can raise Error_Resync
2002 function P_Array_Type_Definition
return Node_Id
is
2003 Array_Loc
: Source_Ptr
;
2005 Subs_List
: List_Id
;
2006 Scan_State
: Saved_Scan_State
;
2009 Array_Loc
:= Token_Ptr
;
2011 Subs_List
:= New_List
;
2014 -- It's quite tricky to disentangle these two possibilities, so we do
2015 -- a prescan to determine which case we have and then reset the scan.
2016 -- The prescan skips past possible subtype mark tokens.
2018 Save_Scan_State
(Scan_State
); -- just after paren
2020 while Token
in Token_Class_Desig
or else
2021 Token
= Tok_Dot
or else
2022 Token
= Tok_Apostrophe
-- because of 'BASE, 'CLASS
2027 -- If we end up on RANGE <> then we have the unconstrained case. We
2028 -- will also allow the RANGE to be omitted, just to improve error
2029 -- handling for a case like array (integer <>) of integer;
2031 Scan
; -- past possible RANGE or <>
2033 if (Prev_Token
= Tok_Range
and then Token
= Tok_Box
) or else
2034 Prev_Token
= Tok_Box
2036 Def_Node
:= New_Node
(N_Unconstrained_Array_Definition
, Array_Loc
);
2037 Restore_Scan_State
(Scan_State
); -- to first subtype mark
2040 Append
(P_Subtype_Mark_Resync
, Subs_List
);
2043 exit when Token
= Tok_Right_Paren
or else Token
= Tok_Of
;
2047 Set_Subtype_Marks
(Def_Node
, Subs_List
);
2050 Def_Node
:= New_Node
(N_Constrained_Array_Definition
, Array_Loc
);
2051 Restore_Scan_State
(Scan_State
); -- to first discrete range
2054 Append
(P_Discrete_Subtype_Definition
, Subs_List
);
2055 exit when not Comma_Present
;
2058 Set_Discrete_Subtype_Definitions
(Def_Node
, Subs_List
);
2064 if Token
= Tok_Aliased
then
2065 Set_Aliased_Present
(Def_Node
, True);
2066 Scan
; -- past ALIASED
2069 Set_Subtype_Indication
(Def_Node
, P_Subtype_Indication
);
2071 end P_Array_Type_Definition
;
2073 -----------------------------------------
2074 -- 3.6 Unconstrained Array Definition --
2075 -----------------------------------------
2077 -- Parsed by P_Array_Type_Definition (3.6)
2079 ---------------------------------------
2080 -- 3.6 Constrained Array Definition --
2081 ---------------------------------------
2083 -- Parsed by P_Array_Type_Definition (3.6)
2085 --------------------------------------
2086 -- 3.6 Discrete Subtype Definition --
2087 --------------------------------------
2089 -- DISCRETE_SUBTYPE_DEFINITION ::=
2090 -- discrete_SUBTYPE_INDICATION | RANGE
2092 -- Note: the discrete subtype definition appearing in a constrained
2093 -- array definition is parsed by P_Array_Type_Definition (3.6)
2095 -- Error recovery: cannot raise Error_Resync
2097 function P_Discrete_Subtype_Definition
return Node_Id
is
2100 -- The syntax of a discrete subtype definition is identical to that
2101 -- of a discrete range, so we simply share the same parsing code.
2103 return P_Discrete_Range
;
2104 end P_Discrete_Subtype_Definition
;
2106 -------------------------------
2107 -- 3.6 Component Definition --
2108 -------------------------------
2110 -- For the array case, parsed by P_Array_Type_Definition (3.6)
2111 -- For the record case, parsed by P_Component_Declaration (3.8)
2113 -----------------------------
2114 -- 3.6.1 Index Constraint --
2115 -----------------------------
2117 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2119 ---------------------------
2120 -- 3.6.1 Discrete Range --
2121 ---------------------------
2123 -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
2125 -- The possible forms for a discrete range are:
2127 -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2)
2128 -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2)
2129 -- Range_Attribute (RANGE, 3.5)
2130 -- Simple_Expression .. Simple_Expression (RANGE, 3.5)
2132 -- Error recovery: cannot raise Error_Resync
2134 function P_Discrete_Range
return Node_Id
is
2135 Expr_Node
: Node_Id
;
2136 Range_Node
: Node_Id
;
2139 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2141 if Expr_Form
= EF_Range_Attr
then
2144 elsif Token
= Tok_Range
then
2145 if Expr_Form
/= EF_Simple_Name
then
2146 Error_Msg_SC
("range must be preceded by subtype mark");
2149 return P_Subtype_Indication
(Expr_Node
);
2151 -- Check Expression .. Expression case
2153 elsif Token
= Tok_Dot_Dot
then
2154 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2155 Set_Low_Bound
(Range_Node
, Expr_Node
);
2157 Expr_Node
:= P_Expression
;
2158 Check_Simple_Expression
(Expr_Node
);
2159 Set_High_Bound
(Range_Node
, Expr_Node
);
2162 -- Otherwise we must have a subtype mark
2164 elsif Expr_Form
= EF_Simple_Name
then
2167 -- If incorrect, complain that we expect ..
2173 end P_Discrete_Range
;
2175 ----------------------------
2176 -- 3.7 Discriminant Part --
2177 ----------------------------
2179 -- DISCRIMINANT_PART ::=
2180 -- UNKNOWN_DISCRIMINANT_PART
2181 -- | KNOWN_DISCRIMINANT_PART
2183 -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
2184 -- or P_Unknown_Discriminant_Part (3.7), since we know which we want.
2186 ------------------------------------
2187 -- 3.7 Unknown Discriminant Part --
2188 ------------------------------------
2190 -- UNKNOWN_DISCRIMINANT_PART ::= (<>)
2192 -- If no unknown discriminant part is present, then False is returned,
2193 -- otherwise the unknown discriminant is scanned out and True is returned.
2195 -- Error recovery: cannot raise Error_Resync
2197 function P_Unknown_Discriminant_Part_Opt
return Boolean is
2198 Scan_State
: Saved_Scan_State
;
2201 if Token
/= Tok_Left_Paren
then
2205 Save_Scan_State
(Scan_State
);
2206 Scan
; -- past the left paren
2208 if Token
= Tok_Box
then
2211 Error_Msg_SC
("(Ada 83) unknown discriminant not allowed!");
2214 Scan
; -- past the box
2215 T_Right_Paren
; -- must be followed by right paren
2219 Restore_Scan_State
(Scan_State
);
2223 end P_Unknown_Discriminant_Part_Opt
;
2225 ----------------------------------
2226 -- 3.7 Known Discriminant Part --
2227 ----------------------------------
2229 -- KNOWN_DISCRIMINANT_PART ::=
2230 -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
2232 -- DISCRIMINANT_SPECIFICATION ::=
2233 -- DEFINING_IDENTIFIER_LIST : SUBTYPE_MARK
2234 -- [:= DEFAULT_EXPRESSION]
2235 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
2236 -- [:= DEFAULT_EXPRESSION]
2238 -- If no known discriminant part is present, then No_List is returned
2240 -- Error recovery: cannot raise Error_Resync
2242 function P_Known_Discriminant_Part_Opt
return List_Id
is
2243 Specification_Node
: Node_Id
;
2244 Specification_List
: List_Id
;
2245 Ident_Sloc
: Source_Ptr
;
2246 Scan_State
: Saved_Scan_State
;
2250 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
2251 -- This array holds the list of defining identifiers. The upper bound
2252 -- of 4096 is intended to be essentially infinite, and we do not even
2253 -- bother to check for it being exceeded.
2256 if Token
= Tok_Left_Paren
then
2257 Specification_List
:= New_List
;
2259 P_Pragmas_Misplaced
;
2261 Specification_Loop
: loop
2263 Ident_Sloc
:= Token_Ptr
;
2264 Idents
(1) := P_Defining_Identifier
;
2267 while Comma_Present
loop
2268 Num_Idents
:= Num_Idents
+ 1;
2269 Idents
(Num_Idents
) := P_Defining_Identifier
;
2274 -- If there are multiple identifiers, we repeatedly scan the
2275 -- type and initialization expression information by resetting
2276 -- the scan pointer (so that we get completely separate trees
2277 -- for each occurrence).
2279 if Num_Idents
> 1 then
2280 Save_Scan_State
(Scan_State
);
2283 -- Loop through defining identifiers in list
2287 Specification_Node
:=
2288 New_Node
(N_Discriminant_Specification
, Ident_Sloc
);
2289 Set_Defining_Identifier
(Specification_Node
, Idents
(Ident
));
2291 if Token
= Tok_Access
then
2294 ("(Ada 83) access discriminant not allowed!");
2297 Set_Discriminant_Type
2298 (Specification_Node
, P_Access_Definition
);
2300 Set_Discriminant_Type
2301 (Specification_Node
, P_Subtype_Mark
);
2306 (Specification_Node
, Init_Expr_Opt
(True));
2309 Set_Prev_Ids
(Specification_Node
, True);
2312 if Ident
< Num_Idents
then
2313 Set_More_Ids
(Specification_Node
, True);
2316 Append
(Specification_Node
, Specification_List
);
2317 exit Ident_Loop
when Ident
= Num_Idents
;
2319 Restore_Scan_State
(Scan_State
);
2320 end loop Ident_Loop
;
2322 exit Specification_Loop
when Token
/= Tok_Semicolon
;
2324 P_Pragmas_Misplaced
;
2325 end loop Specification_Loop
;
2328 return Specification_List
;
2333 end P_Known_Discriminant_Part_Opt
;
2335 -------------------------------------
2336 -- 3.7 DIscriminant Specification --
2337 -------------------------------------
2339 -- Parsed by P_Known_Discriminant_Part_Opt (3.7)
2341 -----------------------------
2342 -- 3.7 Default Expression --
2343 -----------------------------
2345 -- Always parsed (simply as an Expression) by the parent construct
2347 ------------------------------------
2348 -- 3.7.1 Discriminant Constraint --
2349 ------------------------------------
2351 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2353 --------------------------------------------------------
2354 -- 3.7.1 Index or Discriminant Constraint (also 3.6) --
2355 --------------------------------------------------------
2357 -- DISCRIMINANT_CONSTRAINT ::=
2358 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
2360 -- DISCRIMINANT_ASSOCIATION ::=
2361 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2364 -- This routine parses either an index or a discriminant constraint. As
2365 -- is clear from the above grammar, it is often possible to clearly
2366 -- determine which of the two possibilities we have, but there are
2367 -- cases (those in which we have a series of expressions of the same
2368 -- syntactic form as subtype indications), where we cannot tell. Since
2369 -- this means that in any case the semantic phase has to distinguish
2370 -- between the two, there is not much point in the parser trying to
2371 -- distinguish even those cases where the difference is clear. In any
2372 -- case, if we have a situation like:
2374 -- (A => 123, 235 .. 500)
2376 -- it is not clear which of the two items is the wrong one, better to
2377 -- let the semantic phase give a clear message. Consequently, this
2378 -- routine in general returns a list of items which can be either
2379 -- discrete ranges or discriminant associations.
2381 -- The caller has checked that the initial token is a left paren
2383 -- Error recovery: can raise Error_Resync
2385 function P_Index_Or_Discriminant_Constraint
return Node_Id
is
2386 Scan_State
: Saved_Scan_State
;
2387 Constr_Node
: Node_Id
;
2388 Constr_List
: List_Id
;
2389 Expr_Node
: Node_Id
;
2390 Result_Node
: Node_Id
;
2393 Result_Node
:= New_Node
(N_Index_Or_Discriminant_Constraint
, Token_Ptr
);
2395 Constr_List
:= New_List
;
2396 Set_Constraints
(Result_Node
, Constr_List
);
2398 -- The two syntactic forms are a little mixed up, so what we are doing
2399 -- here is looking at the first entry to determine which case we have
2401 -- A discriminant constraint is a list of discriminant associations,
2402 -- which have one of the following possible forms:
2406 -- Id | Id | .. | Id => Expression
2408 -- An index constraint is a list of discrete ranges which have one
2409 -- of the following possible forms:
2412 -- Subtype_Mark range Range
2414 -- Simple_Expression .. Simple_Expression
2416 -- Loop through discriminants in list
2419 -- Check cases of Id => Expression or Id | Id => Expression
2421 if Token
= Tok_Identifier
then
2422 Save_Scan_State
(Scan_State
); -- at Id
2425 if Token
= Tok_Arrow
or else Token
= Tok_Vertical_Bar
then
2426 Restore_Scan_State
(Scan_State
); -- to Id
2427 Append
(P_Discriminant_Association
, Constr_List
);
2430 Restore_Scan_State
(Scan_State
); -- to Id
2434 -- Otherwise scan out an expression and see what we have got
2436 Expr_Node
:= P_Expression_Or_Range_Attribute
;
2438 if Expr_Form
= EF_Range_Attr
then
2439 Append
(Expr_Node
, Constr_List
);
2441 elsif Token
= Tok_Range
then
2442 if Expr_Form
/= EF_Simple_Name
then
2443 Error_Msg_SC
("subtype mark required before RANGE");
2446 Append
(P_Subtype_Indication
(Expr_Node
), Constr_List
);
2449 -- Check Simple_Expression .. Simple_Expression case
2451 elsif Token
= Tok_Dot_Dot
then
2452 Check_Simple_Expression
(Expr_Node
);
2453 Constr_Node
:= New_Node
(N_Range
, Token_Ptr
);
2454 Set_Low_Bound
(Constr_Node
, Expr_Node
);
2456 Expr_Node
:= P_Expression
;
2457 Check_Simple_Expression
(Expr_Node
);
2458 Set_High_Bound
(Constr_Node
, Expr_Node
);
2459 Append
(Constr_Node
, Constr_List
);
2462 -- Case of an expression which could be either form
2465 Append
(Expr_Node
, Constr_List
);
2469 -- Here with a single entry scanned
2472 exit when not Comma_Present
;
2479 end P_Index_Or_Discriminant_Constraint
;
2481 -------------------------------------
2482 -- 3.7.1 Discriminant Association --
2483 -------------------------------------
2485 -- DISCRIMINANT_ASSOCIATION ::=
2486 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2489 -- This routine is used only when the name list is present and the caller
2490 -- has already checked this (by scanning ahead and repositioning the
2493 -- Error_Recovery: cannot raise Error_Resync;
2495 function P_Discriminant_Association
return Node_Id
is
2496 Discr_Node
: Node_Id
;
2497 Names_List
: List_Id
;
2498 Ident_Sloc
: Source_Ptr
;
2501 Ident_Sloc
:= Token_Ptr
;
2502 Names_List
:= New_List
;
2505 Append
(P_Identifier
, Names_List
);
2506 exit when Token
/= Tok_Vertical_Bar
;
2510 Discr_Node
:= New_Node
(N_Discriminant_Association
, Ident_Sloc
);
2511 Set_Selector_Names
(Discr_Node
, Names_List
);
2513 Set_Expression
(Discr_Node
, P_Expression
);
2515 end P_Discriminant_Association
;
2517 ---------------------------------
2518 -- 3.8 Record Type Definition --
2519 ---------------------------------
2521 -- RECORD_TYPE_DEFINITION ::=
2522 -- [[abstract] tagged] [limited] RECORD_DEFINITION
2524 -- There is no node in the tree for a record type definition. Instead
2525 -- a record definition node appears, with possible Abstract_Present,
2526 -- Tagged_Present, and Limited_Present flags set appropriately.
2528 ----------------------------
2529 -- 3.8 Record Definition --
2530 ----------------------------
2532 -- RECORD_DEFINITION ::=
2538 -- Note: in the case where a record definition node is used to represent
2539 -- a record type definition, the caller sets the Tagged_Present and
2540 -- Limited_Present flags in the resulting N_Record_Definition node as
2543 -- Note that the RECORD token at the start may be missing in certain
2544 -- error situations, so this function is expected to post the error
2546 -- Error recovery: can raise Error_Resync
2548 function P_Record_Definition
return Node_Id
is
2552 Rec_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
2556 if Token
= Tok_Null
then
2559 Set_Null_Present
(Rec_Node
, True);
2561 -- Case starting with RECORD keyword. Build scope stack entry. For the
2562 -- column, we use the first non-blank character on the line, to deal
2563 -- with situations such as:
2569 -- which is not official RM indentation, but is not uncommon usage
2573 Scope
.Table
(Scope
.Last
).Etyp
:= E_Record
;
2574 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
2575 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
2576 Scope
.Table
(Scope
.Last
).Labl
:= Error
;
2577 Scope
.Table
(Scope
.Last
).Junk
:= (Token
/= Tok_Record
);
2581 Set_Component_List
(Rec_Node
, P_Component_List
);
2584 exit when Check_End
;
2585 Discard_Junk_Node
(P_Component_List
);
2590 end P_Record_Definition
;
2592 -------------------------
2593 -- 3.8 Component List --
2594 -------------------------
2596 -- COMPONENT_LIST ::=
2597 -- COMPONENT_ITEM {COMPONENT_ITEM}
2598 -- | {COMPONENT_ITEM} VARIANT_PART
2601 -- Error recovery: cannot raise Error_Resync
2603 function P_Component_List
return Node_Id
is
2604 Component_List_Node
: Node_Id
;
2605 Decls_List
: List_Id
;
2606 Scan_State
: Saved_Scan_State
;
2609 Component_List_Node
:= New_Node
(N_Component_List
, Token_Ptr
);
2610 Decls_List
:= New_List
;
2612 if Token
= Tok_Null
then
2615 P_Pragmas_Opt
(Decls_List
);
2616 Set_Null_Present
(Component_List_Node
, True);
2617 return Component_List_Node
;
2620 P_Pragmas_Opt
(Decls_List
);
2622 if Token
/= Tok_Case
then
2623 Component_Scan_Loop
: loop
2624 P_Component_Items
(Decls_List
);
2625 P_Pragmas_Opt
(Decls_List
);
2627 exit Component_Scan_Loop
when Token
= Tok_End
2628 or else Token
= Tok_Case
2629 or else Token
= Tok_When
;
2631 -- We are done if we do not have an identifier. However, if
2632 -- we have a misspelled reserved identifier that is in a column
2633 -- to the right of the record definition, we will treat it as
2634 -- an identifier. It turns out to be too dangerous in practice
2635 -- to accept such a mis-spelled identifier which does not have
2636 -- this additional clue that confirms the incorrect spelling.
2638 if Token
/= Tok_Identifier
then
2639 if Start_Column
> Scope
.Table
(Scope
.Last
).Ecol
2640 and then Is_Reserved_Identifier
2642 Save_Scan_State
(Scan_State
); -- at reserved id
2643 Scan
; -- possible reserved id
2645 if Token
= Tok_Comma
or else Token
= Tok_Colon
then
2646 Restore_Scan_State
(Scan_State
);
2647 Scan_Reserved_Identifier
(Force_Msg
=> True);
2649 -- Note reserved identifier used as field name after
2650 -- all because not followed by colon or comma
2653 Restore_Scan_State
(Scan_State
);
2654 exit Component_Scan_Loop
;
2657 -- Non-identifier that definitely was not reserved id
2660 exit Component_Scan_Loop
;
2663 end loop Component_Scan_Loop
;
2666 if Token
= Tok_Case
then
2667 Set_Variant_Part
(Component_List_Node
, P_Variant_Part
);
2669 -- Check for junk after variant part
2671 if Token
= Tok_Identifier
then
2672 Save_Scan_State
(Scan_State
);
2673 Scan
; -- past identifier
2675 if Token
= Tok_Colon
then
2676 Restore_Scan_State
(Scan_State
);
2677 Error_Msg_SC
("component may not follow variant part");
2678 Discard_Junk_Node
(P_Component_List
);
2680 elsif Token
= Tok_Case
then
2681 Restore_Scan_State
(Scan_State
);
2682 Error_Msg_SC
("only one variant part allowed in a record");
2683 Discard_Junk_Node
(P_Component_List
);
2686 Restore_Scan_State
(Scan_State
);
2692 Set_Component_Items
(Component_List_Node
, Decls_List
);
2693 return Component_List_Node
;
2695 end P_Component_List
;
2697 -------------------------
2698 -- 3.8 Component Item --
2699 -------------------------
2701 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
2703 -- COMPONENT_DECLARATION ::=
2704 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
2705 -- [:= DEFAULT_EXPRESSION];
2707 -- COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION
2709 -- Error recovery: cannot raise Error_Resync, if an error occurs,
2710 -- the scan is positioned past the following semicolon.
2712 -- Note: we do not yet allow representation clauses to appear as component
2713 -- items, do we need to add this capability sometime in the future ???
2715 procedure P_Component_Items
(Decls
: List_Id
) is
2716 Decl_Node
: Node_Id
;
2717 Scan_State
: Saved_Scan_State
;
2720 Ident_Sloc
: Source_Ptr
;
2722 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
2723 -- This array holds the list of defining identifiers. The upper bound
2724 -- of 4096 is intended to be essentially infinite, and we do not even
2725 -- bother to check for it being exceeded.
2728 if Token
/= Tok_Identifier
then
2729 Error_Msg_SC
("component declaration expected");
2730 Resync_Past_Semicolon
;
2734 Ident_Sloc
:= Token_Ptr
;
2735 Idents
(1) := P_Defining_Identifier
;
2738 while Comma_Present
loop
2739 Num_Idents
:= Num_Idents
+ 1;
2740 Idents
(Num_Idents
) := P_Defining_Identifier
;
2745 -- If there are multiple identifiers, we repeatedly scan the
2746 -- type and initialization expression information by resetting
2747 -- the scan pointer (so that we get completely separate trees
2748 -- for each occurrence).
2750 if Num_Idents
> 1 then
2751 Save_Scan_State
(Scan_State
);
2754 -- Loop through defining identifiers in list
2759 -- The following block is present to catch Error_Resync
2760 -- which causes the parse to be reset past the semicolon
2763 Decl_Node
:= New_Node
(N_Component_Declaration
, Ident_Sloc
);
2764 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
2766 if Token
= Tok_Constant
then
2767 Error_Msg_SC
("constant components are not permitted");
2771 if Token_Name
= Name_Aliased
then
2772 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
2775 if Token
= Tok_Aliased
then
2776 Scan
; -- past ALIASED
2777 Set_Aliased_Present
(Decl_Node
, True);
2780 if Token
= Tok_Array
then
2781 Error_Msg_SC
("anonymous arrays not allowed as components");
2785 Set_Subtype_Indication
(Decl_Node
, P_Subtype_Indication
);
2786 Set_Expression
(Decl_Node
, Init_Expr_Opt
);
2789 Set_Prev_Ids
(Decl_Node
, True);
2792 if Ident
< Num_Idents
then
2793 Set_More_Ids
(Decl_Node
, True);
2796 Append
(Decl_Node
, Decls
);
2799 when Error_Resync
=>
2800 if Token
/= Tok_End
then
2801 Resync_Past_Semicolon
;
2805 exit Ident_Loop
when Ident
= Num_Idents
;
2807 Restore_Scan_State
(Scan_State
);
2809 end loop Ident_Loop
;
2813 end P_Component_Items
;
2815 --------------------------------
2816 -- 3.8 Component Declaration --
2817 --------------------------------
2819 -- Parsed by P_Component_Items (3.8)
2821 -------------------------
2822 -- 3.8.1 Variant Part --
2823 -------------------------
2826 -- case discriminant_DIRECT_NAME is
2831 -- The caller has checked that the initial token is CASE
2833 -- Error recovery: cannot raise Error_Resync
2835 function P_Variant_Part
return Node_Id
is
2836 Variant_Part_Node
: Node_Id
;
2837 Variants_List
: List_Id
;
2838 Case_Node
: Node_Id
;
2839 Case_Sloc
: Source_Ptr
;
2842 Variant_Part_Node
:= New_Node
(N_Variant_Part
, Token_Ptr
);
2844 Scope
.Table
(Scope
.Last
).Etyp
:= E_Case
;
2845 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
2846 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
2849 Case_Node
:= P_Expression
;
2850 Case_Sloc
:= Token_Ptr
;
2851 Set_Name
(Variant_Part_Node
, Case_Node
);
2853 if Nkind
(Case_Node
) /= N_Identifier
then
2854 Set_Name
(Variant_Part_Node
, Error
);
2855 Error_Msg
("discriminant name expected", Sloc
(Case_Node
));
2859 Variants_List
:= New_List
;
2860 P_Pragmas_Opt
(Variants_List
);
2862 -- Test missing variant
2864 if Token
= Tok_End
then
2865 Error_Msg_BC
("WHEN expected (must have at least one variant)");
2867 Append
(P_Variant
, Variants_List
);
2870 -- Loop through variants, note that we allow if in place of when,
2871 -- this error will be detected and handled in P_Variant.
2874 P_Pragmas_Opt
(Variants_List
);
2876 if Token
/= Tok_When
2877 and then Token
/= Tok_If
2878 and then Token
/= Tok_Others
2880 exit when Check_End
;
2883 Append
(P_Variant
, Variants_List
);
2886 Set_Variants
(Variant_Part_Node
, Variants_List
);
2887 return Variant_Part_Node
;
2891 --------------------
2893 --------------------
2896 -- when DISCRETE_CHOICE_LIST =>
2899 -- Error recovery: cannot raise Error_Resync
2901 -- The initial token on entry is either WHEN, IF or OTHERS
2903 function P_Variant
return Node_Id
is
2904 Variant_Node
: Node_Id
;
2907 -- Special check to recover nicely from use of IF in place of WHEN
2909 if Token
= Tok_If
then
2916 Variant_Node
:= New_Node
(N_Variant
, Prev_Token_Ptr
);
2917 Set_Discrete_Choices
(Variant_Node
, P_Discrete_Choice_List
);
2919 Set_Component_List
(Variant_Node
, P_Component_List
);
2920 return Variant_Node
;
2923 ---------------------------------
2924 -- 3.8.1 Discrete Choice List --
2925 ---------------------------------
2927 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
2929 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
2931 -- Note: in Ada 83, the expression must be a simple expression
2933 -- Error recovery: cannot raise Error_Resync
2935 function P_Discrete_Choice_List
return List_Id
is
2937 Expr_Node
: Node_Id
;
2938 Choice_Node
: Node_Id
;
2941 Choices
:= New_List
;
2944 if Token
= Tok_Others
then
2945 Append
(New_Node
(N_Others_Choice
, Token_Ptr
), Choices
);
2946 Scan
; -- past OTHERS
2950 Expr_Node
:= No_Right_Paren
(P_Expression_Or_Range_Attribute
);
2952 if Token
= Tok_Colon
2953 and then Nkind
(Expr_Node
) = N_Identifier
2955 Error_Msg_SP
("label not permitted in this context");
2958 elsif Expr_Form
= EF_Range_Attr
then
2959 Append
(Expr_Node
, Choices
);
2961 elsif Token
= Tok_Dot_Dot
then
2962 Check_Simple_Expression
(Expr_Node
);
2963 Choice_Node
:= New_Node
(N_Range
, Token_Ptr
);
2964 Set_Low_Bound
(Choice_Node
, Expr_Node
);
2966 Expr_Node
:= P_Expression_No_Right_Paren
;
2967 Check_Simple_Expression
(Expr_Node
);
2968 Set_High_Bound
(Choice_Node
, Expr_Node
);
2969 Append
(Choice_Node
, Choices
);
2971 elsif Expr_Form
= EF_Simple_Name
then
2972 if Token
= Tok_Range
then
2973 Append
(P_Subtype_Indication
(Expr_Node
), Choices
);
2975 elsif Token
in Token_Class_Consk
then
2977 ("the only constraint allowed here " &
2978 "is a range constraint");
2979 Discard_Junk_Node
(P_Constraint_Opt
);
2980 Append
(Expr_Node
, Choices
);
2983 Append
(Expr_Node
, Choices
);
2987 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2988 Append
(Expr_Node
, Choices
);
2992 when Error_Resync
=>
2998 if Token
= Tok_Comma
then
2999 Error_Msg_SC
(""","" should be ""'|""");
3001 exit when Token
/= Tok_Vertical_Bar
;
3004 Scan
; -- past | or comma
3008 end P_Discrete_Choice_List
;
3010 ----------------------------
3011 -- 3.8.1 Discrete Choice --
3012 ----------------------------
3014 -- Parsed by P_Discrete_Choice_List (3.8.1)
3016 ----------------------------------
3017 -- 3.9.1 Record Extension Part --
3018 ----------------------------------
3020 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
3022 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
3024 ----------------------------------
3025 -- 3.10 Access Type Definition --
3026 ----------------------------------
3028 -- ACCESS_TYPE_DEFINITION ::=
3029 -- ACCESS_TO_OBJECT_DEFINITION
3030 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3032 -- ACCESS_TO_OBJECT_DEFINITION ::=
3033 -- access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
3035 -- GENERAL_ACCESS_MODIFIER ::= all | constant
3037 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3038 -- access [protected] procedure PARAMETER_PROFILE
3039 -- | access [protected] function PARAMETER_AND_RESULT_PROFILE
3041 -- PARAMETER_PROFILE ::= [FORMAL_PART]
3043 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
3045 -- The caller has checked that the initial token is ACCESS
3047 -- Error recovery: can raise Error_Resync
3049 function P_Access_Type_Definition
return Node_Id
is
3050 Prot_Flag
: Boolean;
3051 Access_Loc
: Source_Ptr
;
3052 Type_Def_Node
: Node_Id
;
3054 procedure Check_Junk_Subprogram_Name
;
3055 -- Used in access to subprogram definition cases to check for an
3056 -- identifier or operator symbol that does not belong.
3058 procedure Check_Junk_Subprogram_Name
is
3059 Saved_State
: Saved_Scan_State
;
3062 if Token
= Tok_Identifier
or else Token
= Tok_Operator_Symbol
then
3063 Save_Scan_State
(Saved_State
);
3064 Scan
; -- past possible junk subprogram name
3066 if Token
= Tok_Left_Paren
or else Token
= Tok_Semicolon
then
3067 Error_Msg_SP
("unexpected subprogram name ignored");
3071 Restore_Scan_State
(Saved_State
);
3074 end Check_Junk_Subprogram_Name
;
3076 -- Start of processing for P_Access_Type_Definition
3079 Access_Loc
:= Token_Ptr
;
3080 Scan
; -- past ACCESS
3082 if Token_Name
= Name_Protected
then
3083 Check_95_Keyword
(Tok_Protected
, Tok_Procedure
);
3084 Check_95_Keyword
(Tok_Protected
, Tok_Function
);
3087 Prot_Flag
:= (Token
= Tok_Protected
);
3090 Scan
; -- past PROTECTED
3091 if Token
/= Tok_Procedure
and then Token
/= Tok_Function
then
3092 Error_Msg_SC
("FUNCTION or PROCEDURE expected");
3096 if Token
= Tok_Procedure
then
3098 Error_Msg_SC
("(Ada 83) access to procedure not allowed!");
3101 Type_Def_Node
:= New_Node
(N_Access_Procedure_Definition
, Access_Loc
);
3102 Scan
; -- past PROCEDURE
3103 Check_Junk_Subprogram_Name
;
3104 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
3105 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
3107 elsif Token
= Tok_Function
then
3109 Error_Msg_SC
("(Ada 83) access to function not allowed!");
3112 Type_Def_Node
:= New_Node
(N_Access_Function_Definition
, Access_Loc
);
3113 Scan
; -- past FUNCTION
3114 Check_Junk_Subprogram_Name
;
3115 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
3116 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
3118 Set_Subtype_Mark
(Type_Def_Node
, P_Subtype_Mark
);
3123 New_Node
(N_Access_To_Object_Definition
, Access_Loc
);
3125 if Token
= Tok_All
or else Token
= Tok_Constant
then
3127 Error_Msg_SC
("(Ada 83) access modifier not allowed!");
3130 if Token
= Tok_All
then
3131 Set_All_Present
(Type_Def_Node
, True);
3134 Set_Constant_Present
(Type_Def_Node
, True);
3137 Scan
; -- past ALL or CONSTANT
3140 Set_Subtype_Indication
(Type_Def_Node
, P_Subtype_Indication
);
3143 return Type_Def_Node
;
3144 end P_Access_Type_Definition
;
3146 ---------------------------------------
3147 -- 3.10 Access To Object Definition --
3148 ---------------------------------------
3150 -- Parsed by P_Access_Type_Definition (3.10)
3152 -----------------------------------
3153 -- 3.10 General Access Modifier --
3154 -----------------------------------
3156 -- Parsed by P_Access_Type_Definition (3.10)
3158 -------------------------------------------
3159 -- 3.10 Access To Subprogram Definition --
3160 -------------------------------------------
3162 -- Parsed by P_Access_Type_Definition (3.10)
3164 -----------------------------
3165 -- 3.10 Access Definition --
3166 -----------------------------
3168 -- ACCESS_DEFINITION ::= access SUBTYPE_MARK
3170 -- The caller has checked that the initial token is ACCESS
3172 -- Error recovery: cannot raise Error_Resync
3174 function P_Access_Definition
return Node_Id
is
3178 Def_Node
:= New_Node
(N_Access_Definition
, Token_Ptr
);
3179 Scan
; -- past ACCESS
3180 Set_Subtype_Mark
(Def_Node
, P_Subtype_Mark
);
3183 end P_Access_Definition
;
3185 -----------------------------------------
3186 -- 3.10.1 Incomplete Type Declaration --
3187 -----------------------------------------
3189 -- Parsed by P_Type_Declaration (3.2.1)
3191 ----------------------------
3192 -- 3.11 Declarative Part --
3193 ----------------------------
3195 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
3197 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items
3198 -- handles errors, and returns cleanly after an error has occurred)
3200 function P_Declarative_Part
return List_Id
is
3205 -- Indicate no bad declarations detected yet. This will be reset by
3206 -- P_Declarative_Items if a bad declaration is discovered.
3208 Missing_Begin_Msg
:= No_Error_Msg
;
3210 -- Get rid of active SIS entry from outer scope. This means we will
3211 -- miss some nested cases, but it doesn't seem worth the effort. See
3212 -- discussion in Par for further details
3214 SIS_Entry_Active
:= False;
3217 -- Loop to scan out the declarations
3220 P_Declarative_Items
(Decls
, Done
, In_Spec
=> False);
3224 -- Get rid of active SIS entry which is left set only if we scanned a
3225 -- procedure declaration and have not found the body. We could give
3226 -- an error message, but that really would be usurping the role of
3227 -- semantic analysis (this really is a missing body case).
3229 SIS_Entry_Active
:= False;
3231 end P_Declarative_Part
;
3233 ----------------------------
3234 -- 3.11 Declarative Item --
3235 ----------------------------
3237 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
3239 -- Can return Error if a junk declaration is found, or Empty if no
3240 -- declaration is found (i.e. a token ending declarations, such as
3241 -- BEGIN or END is encountered).
3243 -- Error recovery: cannot raise Error_Resync. If an error resync occurs,
3244 -- then the scan is set past the next semicolon and Error is returned.
3246 procedure P_Declarative_Items
3251 Scan_State
: Saved_Scan_State
;
3254 if Style_Check
then Style
.Check_Indentation
; end if;
3258 when Tok_Function
=>
3260 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3266 -- Check for loop (premature statement)
3268 Save_Scan_State
(Scan_State
);
3271 if Token
= Tok_Identifier
then
3272 Scan
; -- past identifier
3274 if Token
= Tok_In
then
3275 Restore_Scan_State
(Scan_State
);
3276 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
3281 -- Not a loop, so must be rep clause
3283 Restore_Scan_State
(Scan_State
);
3284 Append
(P_Representation_Clause
, Decls
);
3289 Append
(P_Generic
, Decls
);
3292 when Tok_Identifier
=>
3294 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
3298 Append
(P_Package
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3302 Append
(P_Pragma
, Decls
);
3305 when Tok_Procedure
=>
3307 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3310 when Tok_Protected
=>
3312 Scan
; -- past PROTECTED
3313 Append
(P_Protected
, Decls
);
3318 Append
(P_Subtype_Declaration
, Decls
);
3324 Append
(P_Task
, Decls
);
3329 Append
(P_Type_Declaration
, Decls
);
3334 Append
(P_Use_Clause
, Decls
);
3339 Error_Msg_SC
("WITH can only appear in context clause");
3342 -- BEGIN terminates the scan of a sequence of declarations unless
3343 -- there is a missing subprogram body, see section on handling
3344 -- semicolon in place of IS. We only treat the begin as satisfying
3345 -- the subprogram declaration if it falls in the expected column
3349 if SIS_Entry_Active
and then Start_Column
>= SIS_Ecol
then
3351 -- Here we have the case where a BEGIN is encountered during
3352 -- declarations in a declarative part, or at the outer level,
3353 -- and there is a subprogram declaration outstanding for which
3354 -- no body has been supplied. This is the case where we assume
3355 -- that the semicolon in the subprogram declaration should
3356 -- really have been is. The active SIS entry describes the
3357 -- subprogram declaration. On return the declaration has been
3358 -- modified to become a body.
3361 Specification_Node
: Node_Id
;
3362 Decl_Node
: Node_Id
;
3363 Body_Node
: Node_Id
;
3366 -- First issue the error message. If we had a missing
3367 -- semicolon in the declaration, then change the message
3368 -- to <missing "is">
3370 if SIS_Missing_Semicolon_Message
/= No_Error_Msg
then
3371 Change_Error_Text
-- Replace: "missing "";"" "
3372 (SIS_Missing_Semicolon_Message
, "missing ""is""");
3374 -- Otherwise we saved the semicolon position, so complain
3377 Error_Msg
(""";"" should be IS", SIS_Semicolon_Sloc
);
3380 -- The next job is to fix up any declarations that occurred
3381 -- between the procedure header and the BEGIN. These got
3382 -- chained to the outer declarative region (immediately
3383 -- after the procedure declaration) and they should be
3384 -- chained to the subprogram itself, which is a body
3385 -- rather than a spec.
3387 Specification_Node
:= Specification
(SIS_Declaration_Node
);
3388 Change_Node
(SIS_Declaration_Node
, N_Subprogram_Body
);
3389 Body_Node
:= SIS_Declaration_Node
;
3390 Set_Specification
(Body_Node
, Specification_Node
);
3391 Set_Declarations
(Body_Node
, New_List
);
3394 Decl_Node
:= Remove_Next
(Body_Node
);
3395 exit when Decl_Node
= Empty
;
3396 Append
(Decl_Node
, Declarations
(Body_Node
));
3399 -- Now make the scope table entry for the Begin-End and
3403 Scope
.Table
(Scope
.Last
).Sloc
:= SIS_Sloc
;
3404 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
3405 Scope
.Table
(Scope
.Last
).Ecol
:= SIS_Ecol
;
3406 Scope
.Table
(Scope
.Last
).Labl
:= SIS_Labl
;
3407 Scope
.Table
(Scope
.Last
).Lreq
:= False;
3408 SIS_Entry_Active
:= False;
3410 Set_Handled_Statement_Sequence
(Body_Node
,
3411 P_Handled_Sequence_Of_Statements
);
3412 End_Statements
(Handled_Statement_Sequence
(Body_Node
));
3421 -- Normally an END terminates the scan for basic declarative
3422 -- items. The one exception is END RECORD, which is probably
3423 -- left over from some other junk.
3426 Save_Scan_State
(Scan_State
); -- at END
3429 if Token
= Tok_Record
then
3430 Error_Msg_SP
("no RECORD for this `end record`!");
3431 Scan
; -- past RECORD
3435 Restore_Scan_State
(Scan_State
); -- to END
3439 -- The following tokens which can only be the start of a statement
3440 -- are considered to end a declarative part (i.e. we have a missing
3441 -- BEGIN situation). We are fairly conservative in making this
3442 -- judgment, because it is a real mess to go into statement mode
3443 -- prematurely in response to a junk declaration.
3458 -- But before we decide that it's a statement, let's check for
3459 -- a reserved word misused as an identifier.
3461 if Is_Reserved_Identifier
then
3462 Save_Scan_State
(Scan_State
);
3463 Scan
; -- past the token
3465 -- If reserved identifier not followed by colon or comma, then
3466 -- this is most likely an assignment statement to the bad id.
3468 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
3469 Restore_Scan_State
(Scan_State
);
3470 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
3473 -- Otherwise we have a declaration of the bad id
3476 Restore_Scan_State
(Scan_State
);
3477 Scan_Reserved_Identifier
(Force_Msg
=> True);
3478 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
3481 -- If not reserved identifier, then it's definitely a statement
3484 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
3488 -- The token RETURN may well also signal a missing BEGIN situation,
3489 -- however, we never let it end the declarative part, because it may
3490 -- also be part of a half-baked function declaration.
3493 Error_Msg_SC
("misplaced RETURN statement");
3496 -- PRIVATE definitely terminates the declarations in a spec,
3497 -- and is an error in a body.
3503 Error_Msg_SC
("PRIVATE not allowed in body");
3504 Scan
; -- past PRIVATE
3507 -- An end of file definitely terminates the declarations!
3512 -- The remaining tokens do not end the scan, but cannot start a
3513 -- valid declaration, so we signal an error and resynchronize.
3514 -- But first check for misuse of a reserved identifier.
3518 -- Here we check for a reserved identifier
3520 if Is_Reserved_Identifier
then
3521 Save_Scan_State
(Scan_State
);
3522 Scan
; -- past the token
3524 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
3525 Restore_Scan_State
(Scan_State
);
3526 Set_Declaration_Expected
;
3529 Restore_Scan_State
(Scan_State
);
3530 Scan_Reserved_Identifier
(Force_Msg
=> True);
3532 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
3536 Set_Declaration_Expected
;
3541 -- To resynchronize after an error, we scan to the next semicolon and
3542 -- return with Done = False, indicating that there may still be more
3543 -- valid declarations to come.
3546 when Error_Resync
=>
3547 Resync_Past_Semicolon
;
3550 end P_Declarative_Items
;
3552 ----------------------------------
3553 -- 3.11 Basic Declarative Item --
3554 ----------------------------------
3556 -- BASIC_DECLARATIVE_ITEM ::=
3557 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
3559 -- Scan zero or more basic declarative items
3561 -- Error recovery: cannot raise Error_Resync. If an error is detected, then
3562 -- the scan pointer is repositioned past the next semicolon, and the scan
3563 -- for declarative items continues.
3565 function P_Basic_Declarative_Items
return List_Id
is
3572 -- Get rid of active SIS entry from outer scope. This means we will
3573 -- miss some nested cases, but it doesn't seem worth the effort. See
3574 -- discussion in Par for further details
3576 SIS_Entry_Active
:= False;
3578 -- Loop to scan out declarations
3583 P_Declarative_Items
(Decls
, Done
, In_Spec
=> True);
3587 -- Get rid of active SIS entry. This is set only if we have scanned a
3588 -- procedure declaration and have not found the body. We could give
3589 -- an error message, but that really would be usurping the role of
3590 -- semantic analysis (this really is a case of a missing body).
3592 SIS_Entry_Active
:= False;
3594 -- Test for assorted illegal declarations not diagnosed elsewhere.
3596 Decl
:= First
(Decls
);
3598 while Present
(Decl
) loop
3599 Kind
:= Nkind
(Decl
);
3601 -- Test for body scanned, not acceptable as basic decl item
3603 if Kind
= N_Subprogram_Body
or else
3604 Kind
= N_Package_Body
or else
3605 Kind
= N_Task_Body
or else
3606 Kind
= N_Protected_Body
3609 ("proper body not allowed in package spec", Sloc
(Decl
));
3611 -- Test for body stub scanned, not acceptable as basic decl item
3613 elsif Kind
in N_Body_Stub
then
3615 ("body stub not allowed in package spec", Sloc
(Decl
));
3617 elsif Kind
= N_Assignment_Statement
then
3619 ("assignment statement not allowed in package spec",
3627 end P_Basic_Declarative_Items
;
3633 -- For proper body, see below
3634 -- For body stub, see 10.1.3
3636 -----------------------
3637 -- 3.11 Proper Body --
3638 -----------------------
3640 -- Subprogram body is parsed by P_Subprogram (6.1)
3641 -- Package body is parsed by P_Package (7.1)
3642 -- Task body is parsed by P_Task (9.1)
3643 -- Protected body is parsed by P_Protected (9.4)
3645 ------------------------------
3646 -- Set_Declaration_Expected --
3647 ------------------------------
3649 procedure Set_Declaration_Expected
is
3651 Error_Msg_SC
("declaration expected");
3653 if Missing_Begin_Msg
= No_Error_Msg
then
3654 Missing_Begin_Msg
:= Get_Msg_Id
;
3656 end Set_Declaration_Expected
;
3658 ----------------------
3659 -- Skip_Declaration --
3660 ----------------------
3662 procedure Skip_Declaration
(S
: List_Id
) is
3663 Dummy_Done
: Boolean;
3666 P_Declarative_Items
(S
, Dummy_Done
, False);
3667 end Skip_Declaration
;
3669 -----------------------------------------
3670 -- Statement_When_Declaration_Expected --
3671 -----------------------------------------
3673 procedure Statement_When_Declaration_Expected
3679 -- Case of second occurrence of statement in one declaration sequence
3681 if Missing_Begin_Msg
/= No_Error_Msg
then
3683 -- In the procedure spec case, just ignore it, we only give one
3684 -- message for the first occurrence, since otherwise we may get
3685 -- horrible cascading if BODY was missing in the header line.
3690 -- In the declarative part case, take a second statement as a sure
3691 -- sign that we really have a missing BEGIN, and end the declarative
3692 -- part now. Note that the caller will fix up the first message to
3693 -- say "missing BEGIN" so that's how the error will be signalled.
3700 -- Case of first occurrence of unexpected statement
3703 -- If we are in a package spec, then give message of statement
3704 -- not allowed in package spec. This message never gets changed.
3707 Error_Msg_SC
("statement not allowed in package spec");
3709 -- If in declarative part, then we give the message complaining
3710 -- about finding a statement when a declaration is expected. This
3711 -- gets changed to a complaint about a missing BEGIN if we later
3712 -- find that no BEGIN is present.
3715 Error_Msg_SC
("statement not allowed in declarative part");
3718 -- Capture message Id. This is used for two purposes, first to
3719 -- stop multiple messages, see test above, and second, to allow
3720 -- the replacement of the message in the declarative part case.
3722 Missing_Begin_Msg
:= Get_Msg_Id
;
3725 -- In all cases except the case in which we decided to terminate the
3726 -- declaration sequence on a second error, we scan out the statement
3727 -- and append it to the list of declarations (note that the semantics
3728 -- can handle statements in a declaration list so if we proceed to
3729 -- call the semantic phase, all will be (reasonably) well!
3731 Append_List_To
(Decls
, P_Sequence_Of_Statements
(SS_Unco
));
3733 -- Done is set to False, since we want to continue the scan of
3734 -- declarations, hoping that this statement was a temporary glitch.
3735 -- If we indeed are now in the statement part (i.e. this was a missing
3736 -- BEGIN, then it's not terrible, we will simply keep calling this
3737 -- procedure to process the statements one by one, and then finally
3738 -- hit the missing BEGIN, which will clean up the error message.
3742 end Statement_When_Declaration_Expected
;