1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 pragma Style_Checks
(All_Checks
);
28 -- Turn off subprogram body ordering check. Subprograms are in order
29 -- by RM section rather than alphabetical
31 with Sinfo
.CN
; use Sinfo
.CN
;
37 -----------------------
38 -- Local Subprograms --
39 -----------------------
41 function P_Component_List
return Node_Id
;
42 function P_Defining_Character_Literal
return Node_Id
;
43 function P_Delta_Constraint
return Node_Id
;
44 function P_Derived_Type_Def_Or_Private_Ext_Decl
return Node_Id
;
45 function P_Digits_Constraint
return Node_Id
;
46 function P_Discriminant_Association
return Node_Id
;
47 function P_Enumeration_Literal_Specification
return Node_Id
;
48 function P_Enumeration_Type_Definition
return Node_Id
;
49 function P_Fixed_Point_Definition
return Node_Id
;
50 function P_Floating_Point_Definition
return Node_Id
;
51 function P_Index_Or_Discriminant_Constraint
return Node_Id
;
52 function P_Real_Range_Specification_Opt
return Node_Id
;
53 function P_Subtype_Declaration
return Node_Id
;
54 function P_Type_Declaration
return Node_Id
;
55 function P_Modular_Type_Definition
return Node_Id
;
56 function P_Variant
return Node_Id
;
57 function P_Variant_Part
return Node_Id
;
59 procedure P_Declarative_Items
63 -- Scans out a single declarative item, or, in the case of a declaration
64 -- with a list of identifiers, a list of declarations, one for each of
65 -- the identifiers in the list. The declaration or declarations scanned
66 -- are appended to the given list. Done indicates whether or not there
67 -- may be additional declarative items to scan. If Done is True, then
68 -- a decision has been made that there are no more items to scan. If
69 -- Done is False, then there may be additional declarations to scan.
70 -- In_Spec is true if we are scanning a package declaration, and is used
71 -- to generate an appropriate message if a statement is encountered in
74 procedure P_Identifier_Declarations
78 -- Scans out a set of declarations for an identifier or list of
79 -- identifiers, and appends them to the given list. The parameters have
80 -- the same significance as for P_Declarative_Items.
82 procedure Statement_When_Declaration_Expected
86 -- Called when a statement is found at a point where a declaration was
87 -- expected. The parameters are as described for P_Declarative_Items.
89 procedure Set_Declaration_Expected
;
90 -- Posts a "declaration expected" error messages at the start of the
91 -- current token, and if this is the first such message issued, saves
92 -- the message id in Missing_Begin_Msg, for possible later replacement.
98 function Init_Expr_Opt
(P
: Boolean := False) return Node_Id
is
100 -- For colon, assume it means := unless it is at the end of
101 -- a line, in which case guess that it means a semicolon.
103 if Token
= Tok_Colon
then
104 if Token_Is_At_End_Of_Line
then
109 -- Here if := or something that we will take as equivalent
111 elsif Token
= Tok_Colon_Equal
112 or else Token
= Tok_Equal
113 or else Token
= Tok_Is
117 -- Another possibility. If we have a literal followed by a semicolon,
118 -- we assume that we have a missing colon-equal.
120 elsif Token
in Token_Class_Literal
then
122 Scan_State
: Saved_Scan_State
;
125 Save_Scan_State
(Scan_State
);
126 Scan
; -- past literal or identifier
128 if Token
= Tok_Semicolon
then
129 Restore_Scan_State
(Scan_State
);
131 Restore_Scan_State
(Scan_State
);
136 -- Otherwise we definitely have no initialization expression
142 -- Merge here if we have an initialization expression
149 return P_Expression_No_Right_Paren
;
153 ----------------------------
154 -- 3.1 Basic Declaration --
155 ----------------------------
157 -- Parsed by P_Basic_Declarative_Items (3.9)
159 ------------------------------
160 -- 3.1 Defining Identifier --
161 ------------------------------
163 -- DEFINING_IDENTIFIER ::= IDENTIFIER
165 -- Error recovery: can raise Error_Resync
167 function P_Defining_Identifier
(C
: Id_Check
:= None
) return Node_Id
is
168 Ident_Node
: Node_Id
;
171 -- Scan out the identifier. Note that this code is essentially identical
172 -- to P_Identifier, except that in the call to Scan_Reserved_Identifier
173 -- we set Force_Msg to True, since we want at least one message for each
174 -- separate declaration (but not use) of a reserved identifier.
176 if Token
= Tok_Identifier
then
179 -- If we have a reserved identifier, manufacture an identifier with
180 -- a corresponding name after posting an appropriate error message
182 elsif Is_Reserved_Identifier
(C
) then
183 Scan_Reserved_Identifier
(Force_Msg
=> True);
185 -- Otherwise we have junk that cannot be interpreted as an identifier
188 T_Identifier
; -- to give message
192 Ident_Node
:= Token_Node
;
193 Scan
; -- past the reserved identifier
195 if Ident_Node
/= Error
then
196 Change_Identifier_To_Defining_Identifier
(Ident_Node
);
200 end P_Defining_Identifier
;
202 -----------------------------
203 -- 3.2.1 Type Declaration --
204 -----------------------------
206 -- TYPE_DECLARATION ::=
207 -- FULL_TYPE_DECLARATION
208 -- | INCOMPLETE_TYPE_DECLARATION
209 -- | PRIVATE_TYPE_DECLARATION
210 -- | PRIVATE_EXTENSION_DECLARATION
212 -- FULL_TYPE_DECLARATION ::=
213 -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION;
214 -- | CONCURRENT_TYPE_DECLARATION
216 -- INCOMPLETE_TYPE_DECLARATION ::=
217 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART];
219 -- PRIVATE_TYPE_DECLARATION ::=
220 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
221 -- is [abstract] [tagged] [limited] private;
223 -- PRIVATE_EXTENSION_DECLARATION ::=
224 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
225 -- [abstract] new ancestor_SUBTYPE_INDICATION with private;
227 -- TYPE_DEFINITION ::=
228 -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
229 -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION
230 -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION
231 -- | DERIVED_TYPE_DEFINITION
233 -- INTEGER_TYPE_DEFINITION ::=
234 -- SIGNED_INTEGER_TYPE_DEFINITION
235 -- MODULAR_TYPE_DEFINITION
237 -- Error recovery: can raise Error_Resync
239 -- Note: The processing for full type declaration, incomplete type
240 -- declaration, private type declaration and type definition is
241 -- included in this function. The processing for concurrent type
242 -- declarations is NOT here, but rather in chapter 9 (i.e. this
243 -- function handles only declarations starting with TYPE).
245 function P_Type_Declaration
return Node_Id
is
246 Type_Loc
: Source_Ptr
;
247 Type_Start_Col
: Column_Number
;
248 Ident_Node
: Node_Id
;
250 Discr_List
: List_Id
;
251 Unknown_Dis
: Boolean;
252 Discr_Sloc
: Source_Ptr
;
253 Abstract_Present
: Boolean;
254 Abstract_Loc
: Source_Ptr
;
257 Typedef_Node
: Node_Id
;
258 -- Normally holds type definition, except in the case of a private
259 -- extension declaration, in which case it holds the declaration itself
262 Type_Loc
:= Token_Ptr
;
263 Type_Start_Col
:= Start_Column
;
265 Ident_Node
:= P_Defining_Identifier
(C_Is
);
266 Discr_Sloc
:= Token_Ptr
;
268 if P_Unknown_Discriminant_Part_Opt
then
270 Discr_List
:= No_List
;
272 Unknown_Dis
:= False;
273 Discr_List
:= P_Known_Discriminant_Part_Opt
;
276 -- Incomplete type declaration. We complete the processing for this
277 -- case here and return the resulting incomplete type declaration node
279 if Token
= Tok_Semicolon
then
281 Decl_Node
:= New_Node
(N_Incomplete_Type_Declaration
, Type_Loc
);
282 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
283 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
284 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
291 -- Full type declaration or private type declaration, must have IS
293 if Token
= Tok_Equal
then
295 Scan
; -- past = used in place of IS
297 elsif Token
= Tok_Renames
then
298 Error_Msg_SC
("RENAMES should be IS");
299 Scan
; -- past RENAMES used in place of IS
305 -- First an error check, if we have two identifiers in a row, a likely
306 -- possibility is that the first of the identifiers is an incorrectly
309 if Token
= Tok_Identifier
then
311 SS
: Saved_Scan_State
;
315 Save_Scan_State
(SS
);
316 Scan
; -- past initial identifier
317 I2
:= (Token
= Tok_Identifier
);
318 Restore_Scan_State
(SS
);
322 (Bad_Spelling_Of
(Tok_Abstract
) or else
323 Bad_Spelling_Of
(Tok_Access
) or else
324 Bad_Spelling_Of
(Tok_Aliased
) or else
325 Bad_Spelling_Of
(Tok_Constant
))
332 -- Check for misuse of Ada 95 keyword abstract in Ada 83 mode
334 if Token_Name
= Name_Abstract
then
335 Check_95_Keyword
(Tok_Abstract
, Tok_Tagged
);
336 Check_95_Keyword
(Tok_Abstract
, Tok_New
);
339 -- Check cases of misuse of ABSTRACT
341 if Token
= Tok_Abstract
then
342 Abstract_Present
:= True;
343 Abstract_Loc
:= Token_Ptr
;
344 Scan
; -- past ABSTRACT
346 if Token
= Tok_Limited
347 or else Token
= Tok_Private
348 or else Token
= Tok_Record
349 or else Token
= Tok_Null
351 Error_Msg_AP
("TAGGED expected");
355 Abstract_Present
:= False;
356 Abstract_Loc
:= No_Location
;
359 -- Check for misuse of Ada 95 keyword Tagged
361 if Token_Name
= Name_Tagged
then
362 Check_95_Keyword
(Tok_Tagged
, Tok_Private
);
363 Check_95_Keyword
(Tok_Tagged
, Tok_Limited
);
364 Check_95_Keyword
(Tok_Tagged
, Tok_Record
);
367 -- Special check for misuse of Aliased
369 if Token
= Tok_Aliased
or else Token_Name
= Name_Aliased
then
370 Error_Msg_SC
("ALIASED not allowed in type definition");
371 Scan
; -- past ALIASED
374 -- The following procesing deals with either a private type declaration
375 -- or a full type declaration. In the private type case, we build the
376 -- N_Private_Type_Declaration node, setting its Tagged_Present and
377 -- Limited_Present flags, on encountering the Private keyword, and
378 -- leave Typedef_Node set to Empty. For the full type declaration
379 -- case, Typedef_Node gets set to the type definition.
381 Typedef_Node
:= Empty
;
383 -- Switch on token following the IS. The loop normally runs once. It
384 -- only runs more than once if an error is detected, to try again after
385 -- detecting and fixing up the error.
391 Tok_Not
=> -- Ada 2005 (AI-231)
392 Typedef_Node
:= P_Access_Type_Definition
;
397 Typedef_Node
:= P_Array_Type_Definition
;
402 Typedef_Node
:= P_Fixed_Point_Definition
;
407 Typedef_Node
:= P_Floating_Point_Definition
;
414 when Tok_Integer_Literal
=>
416 Typedef_Node
:= P_Signed_Integer_Type_Definition
;
421 Typedef_Node
:= P_Record_Definition
;
425 when Tok_Left_Paren
=>
426 Typedef_Node
:= P_Enumeration_Type_Definition
;
429 Make_Identifier
(Token_Ptr
,
430 Chars
=> Chars
(Ident_Node
));
431 Set_Comes_From_Source
(End_Labl
, False);
433 Set_End_Label
(Typedef_Node
, End_Labl
);
438 Typedef_Node
:= P_Modular_Type_Definition
;
443 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
445 if Nkind
(Typedef_Node
) = N_Derived_Type_Definition
446 and then Present
(Record_Extension_Part
(Typedef_Node
))
449 Make_Identifier
(Token_Ptr
,
450 Chars
=> Chars
(Ident_Node
));
451 Set_Comes_From_Source
(End_Labl
, False);
454 (Record_Extension_Part
(Typedef_Node
), End_Labl
);
461 Typedef_Node
:= P_Signed_Integer_Type_Definition
;
466 Typedef_Node
:= P_Record_Definition
;
469 Make_Identifier
(Token_Ptr
,
470 Chars
=> Chars
(Ident_Node
));
471 Set_Comes_From_Source
(End_Labl
, False);
473 Set_End_Label
(Typedef_Node
, End_Labl
);
480 if Token
= Tok_Abstract
then
481 Error_Msg_SC
("ABSTRACT must come before TAGGED");
482 Abstract_Present
:= True;
483 Abstract_Loc
:= Token_Ptr
;
484 Scan
; -- past ABSTRACT
487 if Token
= Tok_Limited
then
488 Scan
; -- past LIMITED
490 -- TAGGED LIMITED PRIVATE case
492 if Token
= Tok_Private
then
494 New_Node
(N_Private_Type_Declaration
, Type_Loc
);
495 Set_Tagged_Present
(Decl_Node
, True);
496 Set_Limited_Present
(Decl_Node
, True);
497 Scan
; -- past PRIVATE
499 -- TAGGED LIMITED RECORD
502 Typedef_Node
:= P_Record_Definition
;
503 Set_Tagged_Present
(Typedef_Node
, True);
504 Set_Limited_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
);
517 if Token
= Tok_Private
then
519 New_Node
(N_Private_Type_Declaration
, Type_Loc
);
520 Set_Tagged_Present
(Decl_Node
, True);
521 Scan
; -- past PRIVATE
526 Typedef_Node
:= P_Record_Definition
;
527 Set_Tagged_Present
(Typedef_Node
, True);
530 Make_Identifier
(Token_Ptr
,
531 Chars
=> Chars
(Ident_Node
));
532 Set_Comes_From_Source
(End_Labl
, False);
534 Set_End_Label
(Typedef_Node
, End_Labl
);
542 Decl_Node
:= New_Node
(N_Private_Type_Declaration
, Type_Loc
);
543 Scan
; -- past PRIVATE
548 Scan
; -- past LIMITED
551 if Token
= Tok_Tagged
then
552 Error_Msg_SC
("TAGGED must come before LIMITED");
555 elsif Token
= Tok_Abstract
then
556 Error_Msg_SC
("ABSTRACT must come before LIMITED");
557 Scan
; -- past ABSTRACT
564 -- LIMITED RECORD or LIMITED NULL RECORD
566 if Token
= Tok_Record
or else Token
= Tok_Null
then
567 if Ada_Version
= Ada_83
then
569 ("(Ada 83) limited record declaration not allowed!");
572 Typedef_Node
:= P_Record_Definition
;
573 Set_Limited_Present
(Typedef_Node
, True);
575 -- LIMITED PRIVATE is the only remaining possibility here
578 Decl_Node
:= New_Node
(N_Private_Type_Declaration
, Type_Loc
);
579 Set_Limited_Present
(Decl_Node
, True);
580 T_Private
; -- past PRIVATE (or complain if not there!)
586 -- Here we have an identifier after the IS, which is certainly
587 -- wrong and which might be one of several different mistakes.
589 when Tok_Identifier
=>
591 -- First case, if identifier is on same line, then probably we
592 -- have something like "type X is Integer .." and the best
593 -- diagnosis is a missing NEW. Note: the missing new message
594 -- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl.
596 if not Token_Is_At_Start_Of_Line
then
597 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
600 -- If the identifier is at the start of the line, and is in the
601 -- same column as the type declaration itself then we consider
602 -- that we had a missing type definition on the previous line
604 elsif Start_Column
<= Type_Start_Col
then
605 Error_Msg_AP
("type definition expected");
606 Typedef_Node
:= Error
;
608 -- If the identifier is at the start of the line, and is in
609 -- a column to the right of the type declaration line, then we
610 -- may have something like:
615 -- and the best diagnosis is a missing record keyword
618 Typedef_Node
:= P_Record_Definition
;
624 -- Anything else is an error
627 if Bad_Spelling_Of
(Tok_Access
)
629 Bad_Spelling_Of
(Tok_Array
)
631 Bad_Spelling_Of
(Tok_Delta
)
633 Bad_Spelling_Of
(Tok_Digits
)
635 Bad_Spelling_Of
(Tok_Limited
)
637 Bad_Spelling_Of
(Tok_Private
)
639 Bad_Spelling_Of
(Tok_Range
)
641 Bad_Spelling_Of
(Tok_Record
)
643 Bad_Spelling_Of
(Tok_Tagged
)
648 Error_Msg_AP
("type definition expected");
655 -- For the private type declaration case, the private type declaration
656 -- node has been built, with the Tagged_Present and Limited_Present
657 -- flags set as needed, and Typedef_Node is left set to Empty.
659 if No
(Typedef_Node
) then
660 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
661 Set_Abstract_Present
(Decl_Node
, Abstract_Present
);
663 -- For a private extension declaration, Typedef_Node contains the
664 -- N_Private_Extension_Declaration node, which we now complete. Note
665 -- that the private extension declaration, unlike a full type
666 -- declaration, does permit unknown discriminants.
668 elsif Nkind
(Typedef_Node
) = N_Private_Extension_Declaration
then
669 Decl_Node
:= Typedef_Node
;
670 Set_Sloc
(Decl_Node
, Type_Loc
);
671 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
672 Set_Abstract_Present
(Typedef_Node
, Abstract_Present
);
674 -- In the full type declaration case, Typedef_Node has the type
675 -- definition and here is where we build the full type declaration
676 -- node. This is also where we check for improper use of an unknown
677 -- discriminant part (not allowed for full type declaration).
680 if Nkind
(Typedef_Node
) = N_Record_Definition
681 or else (Nkind
(Typedef_Node
) = N_Derived_Type_Definition
682 and then Present
(Record_Extension_Part
(Typedef_Node
)))
684 Set_Abstract_Present
(Typedef_Node
, Abstract_Present
);
686 elsif Abstract_Present
then
687 Error_Msg
("ABSTRACT not allowed here, ignored", Abstract_Loc
);
690 Decl_Node
:= New_Node
(N_Full_Type_Declaration
, Type_Loc
);
691 Set_Type_Definition
(Decl_Node
, Typedef_Node
);
695 ("Full type declaration cannot have unknown discriminants",
700 -- Remaining processing is common for all three cases
702 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
703 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
705 end P_Type_Declaration
;
707 ----------------------------------
708 -- 3.2.1 Full Type Declaration --
709 ----------------------------------
711 -- Parsed by P_Type_Declaration (3.2.1)
713 ----------------------------
714 -- 3.2.1 Type Definition --
715 ----------------------------
717 -- Parsed by P_Type_Declaration (3.2.1)
719 --------------------------------
720 -- 3.2.2 Subtype Declaration --
721 --------------------------------
723 -- SUBTYPE_DECLARATION ::=
724 -- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION;
726 -- The caller has checked that the initial token is SUBTYPE
728 -- Error recovery: can raise Error_Resync
730 function P_Subtype_Declaration
return Node_Id
is
732 Not_Null_Present
: Boolean := False;
734 Decl_Node
:= New_Node
(N_Subtype_Declaration
, Token_Ptr
);
735 Scan
; -- past SUBTYPE
736 Set_Defining_Identifier
(Decl_Node
, P_Defining_Identifier
(C_Is
));
739 if Token
= Tok_New
then
740 Error_Msg_SC
("NEW ignored (only allowed in type declaration)");
744 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
745 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
747 Set_Subtype_Indication
748 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
751 end P_Subtype_Declaration
;
753 -------------------------------
754 -- 3.2.2 Subtype Indication --
755 -------------------------------
757 -- SUBTYPE_INDICATION ::=
758 -- [NOT NULL] SUBTYPE_MARK [CONSTRAINT]
760 -- Error recovery: can raise Error_Resync
762 function P_Null_Exclusion
return Boolean is
764 if Token
/= Tok_Not
then
768 if Ada_Version
< Ada_05
then
770 ("null-excluding access is an Ada 2005 extension");
771 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
776 if Token
= Tok_Null
then
779 Error_Msg_SP
("NULL expected");
784 end P_Null_Exclusion
;
786 function P_Subtype_Indication
787 (Not_Null_Present
: Boolean := False) return Node_Id
is
791 if Token
= Tok_Identifier
or else Token
= Tok_Operator_Symbol
then
792 Type_Node
:= P_Subtype_Mark
;
793 return P_Subtype_Indication
(Type_Node
, Not_Null_Present
);
796 -- Check for error of using record definition and treat it nicely,
797 -- otherwise things are really messed up, so resynchronize.
799 if Token
= Tok_Record
then
800 Error_Msg_SC
("anonymous record definitions are not permitted");
801 Discard_Junk_Node
(P_Record_Definition
);
805 Error_Msg_AP
("subtype indication expected");
809 end P_Subtype_Indication
;
811 -- The following function is identical except that it is called with
812 -- the subtype mark already scanned out, and it scans out the constraint
814 -- Error recovery: can raise Error_Resync
816 function P_Subtype_Indication
817 (Subtype_Mark
: Node_Id
;
818 Not_Null_Present
: Boolean := False) return Node_Id
is
819 Indic_Node
: Node_Id
;
820 Constr_Node
: Node_Id
;
823 Constr_Node
:= P_Constraint_Opt
;
825 if No
(Constr_Node
) then
828 if Not_Null_Present
then
829 Error_Msg_SP
("constrained null-exclusion not allowed");
832 Indic_Node
:= New_Node
(N_Subtype_Indication
, Sloc
(Subtype_Mark
));
833 Set_Subtype_Mark
(Indic_Node
, Check_Subtype_Mark
(Subtype_Mark
));
834 Set_Constraint
(Indic_Node
, Constr_Node
);
837 end P_Subtype_Indication
;
839 -------------------------
840 -- 3.2.2 Subtype Mark --
841 -------------------------
843 -- SUBTYPE_MARK ::= subtype_NAME;
845 -- Note: The subtype mark which appears after an IN or NOT IN
846 -- operator is parsed by P_Range_Or_Subtype_Mark (3.5)
848 -- Error recovery: cannot raise Error_Resync
850 function P_Subtype_Mark
return Node_Id
is
852 return P_Subtype_Mark_Resync
;
859 -- This routine differs from P_Subtype_Mark in that it insists that an
860 -- identifier be present, and if it is not, it raises Error_Resync.
862 -- Error recovery: can raise Error_Resync
864 function P_Subtype_Mark_Resync
return Node_Id
is
868 if Token
= Tok_Access
then
869 Error_Msg_SC
("anonymous access type definition not allowed here");
873 if Token
= Tok_Array
then
874 Error_Msg_SC
("anonymous array definition not allowed here");
875 Discard_Junk_Node
(P_Array_Type_Definition
);
879 Type_Node
:= P_Qualified_Simple_Name_Resync
;
881 -- Check for a subtype mark attribute. The only valid possibilities
882 -- are 'CLASS and 'BASE. Anything else is a definite error. We may
883 -- as well catch it here.
885 if Token
= Tok_Apostrophe
then
886 return P_Subtype_Mark_Attribute
(Type_Node
);
891 end P_Subtype_Mark_Resync
;
893 -- The following function is called to scan out a subtype mark attribute.
894 -- The caller has already scanned out the subtype mark, which is passed in
895 -- as the argument, and has checked that the current token is apostrophe.
897 -- Only a special subclass of attributes, called type attributes
898 -- (see Snames package) are allowed in this syntactic position.
900 -- Note: if the apostrophe is followed by other than an identifier, then
901 -- the input expression is returned unchanged, and the scan pointer is
902 -- left pointing to the apostrophe.
904 -- Error recovery: can raise Error_Resync
906 function P_Subtype_Mark_Attribute
(Type_Node
: Node_Id
) return Node_Id
is
907 Attr_Node
: Node_Id
:= Empty
;
908 Scan_State
: Saved_Scan_State
;
912 Prefix
:= Check_Subtype_Mark
(Type_Node
);
914 if Prefix
= Error
then
918 -- Loop through attributes appearing (more than one can appear as for
919 -- for example in X'Base'Class). We are at an apostrophe on entry to
920 -- this loop, and it runs once for each attribute parsed, with
921 -- Prefix being the current possible prefix if it is an attribute.
924 Save_Scan_State
(Scan_State
); -- at Apostrophe
925 Scan
; -- past apostrophe
927 if Token
/= Tok_Identifier
then
928 Restore_Scan_State
(Scan_State
); -- to apostrophe
929 return Prefix
; -- no attribute after all
931 elsif not Is_Type_Attribute_Name
(Token_Name
) then
933 ("attribute & may not be used in a subtype mark", Token_Node
);
938 Make_Attribute_Reference
(Prev_Token_Ptr
,
940 Attribute_Name
=> Token_Name
);
941 Delete_Node
(Token_Node
);
942 Scan
; -- past type attribute identifier
945 exit when Token
/= Tok_Apostrophe
;
949 -- Fall through here after scanning type attribute
952 end P_Subtype_Mark_Attribute
;
954 -----------------------
955 -- 3.2.2 Constraint --
956 -----------------------
958 -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
960 -- SCALAR_CONSTRAINT ::=
961 -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
963 -- COMPOSITE_CONSTRAINT ::=
964 -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
966 -- If no constraint is present, this function returns Empty
968 -- Error recovery: can raise Error_Resync
970 function P_Constraint_Opt
return Node_Id
is
973 or else Bad_Spelling_Of
(Tok_Range
)
975 return P_Range_Constraint
;
977 elsif Token
= Tok_Digits
978 or else Bad_Spelling_Of
(Tok_Digits
)
980 return P_Digits_Constraint
;
982 elsif Token
= Tok_Delta
983 or else Bad_Spelling_Of
(Tok_Delta
)
985 return P_Delta_Constraint
;
987 elsif Token
= Tok_Left_Paren
then
988 return P_Index_Or_Discriminant_Constraint
;
990 elsif Token
= Tok_In
then
992 return P_Constraint_Opt
;
997 end P_Constraint_Opt
;
999 ------------------------------
1000 -- 3.2.2 Scalar Constraint --
1001 ------------------------------
1003 -- Parsed by P_Constraint_Opt (3.2.2)
1005 ---------------------------------
1006 -- 3.2.2 Composite Constraint --
1007 ---------------------------------
1009 -- Parsed by P_Constraint_Opt (3.2.2)
1011 --------------------------------------------------------
1012 -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) --
1013 --------------------------------------------------------
1015 -- This routine scans out a declaration starting with an identifier:
1017 -- OBJECT_DECLARATION ::=
1018 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1019 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1020 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1021 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1023 -- NUMBER_DECLARATION ::=
1024 -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
1026 -- OBJECT_RENAMING_DECLARATION ::=
1027 -- DEFINING_IDENTIFIER : SUBTYPE_MARK renames object_NAME;
1028 -- | DEFINING_IDENTIFIER : ACCESS_DEFINITION renames object_NAME;
1030 -- EXCEPTION_RENAMING_DECLARATION ::=
1031 -- DEFINING_IDENTIFIER : exception renames exception_NAME;
1033 -- EXCEPTION_DECLARATION ::=
1034 -- DEFINING_IDENTIFIER_LIST : exception;
1036 -- Note that the ALIASED indication in an object declaration is
1037 -- marked by a flag in the parent node.
1039 -- The caller has checked that the initial token is an identifier
1041 -- The value returned is a list of declarations, one for each identifier
1042 -- in the list (as described in Sinfo, we always split up multiple
1043 -- declarations into the equivalent sequence of single declarations
1044 -- using the More_Ids and Prev_Ids flags to preserve the source).
1046 -- If the identifier turns out to be a probable statement rather than
1047 -- an identifier, then the scan is left pointing to the identifier and
1048 -- No_List is returned.
1050 -- Error recovery: can raise Error_Resync
1052 procedure P_Identifier_Declarations
1058 Decl_Node
: Node_Id
;
1059 Type_Node
: Node_Id
;
1060 Ident_Sloc
: Source_Ptr
;
1061 Scan_State
: Saved_Scan_State
;
1062 List_OK
: Boolean := True;
1064 Init_Expr
: Node_Id
;
1065 Init_Loc
: Source_Ptr
;
1066 Con_Loc
: Source_Ptr
;
1067 Not_Null_Present
: Boolean := False;
1069 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
1070 -- Used to save identifiers in the identifier list. The upper bound
1071 -- of 4096 is expected to be infinite in practice, and we do not even
1072 -- bother to check if this upper bound is exceeded.
1074 Num_Idents
: Nat
:= 1;
1075 -- Number of identifiers stored in Idents
1078 -- This procedure is called in renames cases to make sure that we do
1079 -- not have more than one identifier. If we do have more than one
1080 -- then an error message is issued (and the declaration is split into
1081 -- multiple declarations)
1083 function Token_Is_Renames
return Boolean;
1084 -- Checks if current token is RENAMES, and if so, scans past it and
1085 -- returns True, otherwise returns False. Includes checking for some
1086 -- common error cases.
1088 procedure No_List
is
1090 if Num_Idents
> 1 then
1091 Error_Msg
("identifier list not allowed for RENAMES",
1098 function Token_Is_Renames
return Boolean is
1099 At_Colon
: Saved_Scan_State
;
1102 if Token
= Tok_Colon
then
1103 Save_Scan_State
(At_Colon
);
1105 Check_Misspelling_Of
(Tok_Renames
);
1107 if Token
= Tok_Renames
then
1108 Error_Msg_SP
("extra "":"" ignored");
1109 Scan
; -- past RENAMES
1112 Restore_Scan_State
(At_Colon
);
1117 Check_Misspelling_Of
(Tok_Renames
);
1119 if Token
= Tok_Renames
then
1120 Scan
; -- past RENAMES
1126 end Token_Is_Renames
;
1128 -- Start of processing for P_Identifier_Declarations
1131 Ident_Sloc
:= Token_Ptr
;
1132 Save_Scan_State
(Scan_State
); -- at first identifier
1133 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
1135 -- If we have a colon after the identifier, then we can assume that
1136 -- this is in fact a valid identifier declaration and can steam ahead.
1138 if Token
= Tok_Colon
then
1141 -- If we have a comma, then scan out the list of identifiers
1143 elsif Token
= Tok_Comma
then
1145 while Comma_Present
loop
1146 Num_Idents
:= Num_Idents
+ 1;
1147 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
1150 Save_Scan_State
(Scan_State
); -- at colon
1153 -- If we have identifier followed by := then we assume that what is
1154 -- really meant is an assignment statement. The assignment statement
1155 -- is scanned out and added to the list of declarations. An exception
1156 -- occurs if the := is followed by the keyword constant, in which case
1157 -- we assume it was meant to be a colon.
1159 elsif Token
= Tok_Colon_Equal
then
1162 if Token
= Tok_Constant
then
1163 Error_Msg_SP
("colon expected");
1166 Restore_Scan_State
(Scan_State
);
1167 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
1171 -- If we have an IS keyword, then assume the TYPE keyword was missing
1173 elsif Token
= Tok_Is
then
1174 Restore_Scan_State
(Scan_State
);
1175 Append_To
(Decls
, P_Type_Declaration
);
1179 -- Otherwise we have an error situation
1182 Restore_Scan_State
(Scan_State
);
1184 -- First case is possible misuse of PROTECTED in Ada 83 mode. If
1185 -- so, fix the keyword and return to scan the protected declaration.
1187 if Token_Name
= Name_Protected
then
1188 Check_95_Keyword
(Tok_Protected
, Tok_Identifier
);
1189 Check_95_Keyword
(Tok_Protected
, Tok_Type
);
1190 Check_95_Keyword
(Tok_Protected
, Tok_Body
);
1192 if Token
= Tok_Protected
then
1197 -- Check misspelling possibilities. If so, correct the misspelling
1198 -- and return to scan out the resulting declaration.
1200 elsif Bad_Spelling_Of
(Tok_Function
)
1201 or else Bad_Spelling_Of
(Tok_Procedure
)
1202 or else Bad_Spelling_Of
(Tok_Package
)
1203 or else Bad_Spelling_Of
(Tok_Pragma
)
1204 or else Bad_Spelling_Of
(Tok_Protected
)
1205 or else Bad_Spelling_Of
(Tok_Generic
)
1206 or else Bad_Spelling_Of
(Tok_Subtype
)
1207 or else Bad_Spelling_Of
(Tok_Type
)
1208 or else Bad_Spelling_Of
(Tok_Task
)
1209 or else Bad_Spelling_Of
(Tok_Use
)
1210 or else Bad_Spelling_Of
(Tok_For
)
1215 -- Otherwise we definitely have an ordinary identifier with a junk
1216 -- token after it. Just complain that we expect a declaration, and
1217 -- skip to a semicolon
1220 Set_Declaration_Expected
;
1221 Resync_Past_Semicolon
;
1227 -- Come here with an identifier list and colon scanned out. We now
1228 -- build the nodes for the declarative items. One node is built for
1229 -- each identifier in the list, with the type information being
1230 -- repeated by rescanning the appropriate section of source.
1232 -- First an error check, if we have two identifiers in a row, a likely
1233 -- possibility is that the first of the identifiers is an incorrectly
1236 if Token
= Tok_Identifier
then
1238 SS
: Saved_Scan_State
;
1242 Save_Scan_State
(SS
);
1243 Scan
; -- past initial identifier
1244 I2
:= (Token
= Tok_Identifier
);
1245 Restore_Scan_State
(SS
);
1249 (Bad_Spelling_Of
(Tok_Access
) or else
1250 Bad_Spelling_Of
(Tok_Aliased
) or else
1251 Bad_Spelling_Of
(Tok_Constant
))
1258 -- Loop through identifiers
1263 -- Check for some cases of misused Ada 95 keywords
1265 if Token_Name
= Name_Aliased
then
1266 Check_95_Keyword
(Tok_Aliased
, Tok_Array
);
1267 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
1268 Check_95_Keyword
(Tok_Aliased
, Tok_Constant
);
1273 if Token
= Tok_Constant
then
1274 Con_Loc
:= Token_Ptr
;
1275 Scan
; -- past CONSTANT
1277 -- Number declaration, initialization required
1279 Init_Expr
:= Init_Expr_Opt
;
1281 if Present
(Init_Expr
) then
1282 if Not_Null_Present
then
1283 Error_Msg_SP
("null-exclusion not allowed in "
1284 & "numeric expression");
1287 Decl_Node
:= New_Node
(N_Number_Declaration
, Ident_Sloc
);
1288 Set_Expression
(Decl_Node
, Init_Expr
);
1290 -- Constant object declaration
1293 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1294 Set_Constant_Present
(Decl_Node
, True);
1296 if Token_Name
= Name_Aliased
then
1297 Check_95_Keyword
(Tok_Aliased
, Tok_Array
);
1298 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
1301 if Token
= Tok_Aliased
then
1302 Error_Msg_SC
("ALIASED should be before CONSTANT");
1303 Scan
; -- past ALIASED
1304 Set_Aliased_Present
(Decl_Node
, True);
1307 if Token
= Tok_Array
then
1308 Set_Object_Definition
1309 (Decl_Node
, P_Array_Type_Definition
);
1312 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1313 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1315 Set_Object_Definition
(Decl_Node
,
1316 P_Subtype_Indication
(Not_Null_Present
));
1319 if Token
= Tok_Renames
then
1321 ("CONSTANT not permitted in renaming declaration",
1323 Scan
; -- Past renames
1324 Discard_Junk_Node
(P_Name
);
1330 elsif Token
= Tok_Exception
then
1331 Scan
; -- past EXCEPTION
1333 if Token_Is_Renames
then
1336 New_Node
(N_Exception_Renaming_Declaration
, Ident_Sloc
);
1337 Set_Name
(Decl_Node
, P_Qualified_Simple_Name_Resync
);
1340 Decl_Node
:= New_Node
(N_Exception_Declaration
, Prev_Token_Ptr
);
1343 -- Aliased case (note that an object definition is required)
1345 elsif Token
= Tok_Aliased
then
1346 Scan
; -- past ALIASED
1347 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1348 Set_Aliased_Present
(Decl_Node
, True);
1350 if Token
= Tok_Constant
then
1351 Scan
; -- past CONSTANT
1352 Set_Constant_Present
(Decl_Node
, True);
1355 if Token
= Tok_Array
then
1356 Set_Object_Definition
1357 (Decl_Node
, P_Array_Type_Definition
);
1360 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1361 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1362 Set_Object_Definition
(Decl_Node
,
1363 P_Subtype_Indication
(Not_Null_Present
));
1368 elsif Token
= Tok_Array
then
1369 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1370 Set_Object_Definition
(Decl_Node
, P_Array_Type_Definition
);
1372 -- Ada 2005 (AI-254)
1374 elsif Token
= Tok_Not
then
1376 -- OBJECT_DECLARATION ::=
1377 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1378 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1380 -- OBJECT_RENAMING_DECLARATION ::=
1382 -- | DEFINING_IDENTIFIER : ACCESS_DEFINITION renames object_NAME;
1384 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1386 if Token
= Tok_Access
then
1387 if Ada_Version
< Ada_05
then
1389 ("generalized use of anonymous access types " &
1390 "is an Ada 2005 extension");
1391 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1394 Acc_Node
:= P_Access_Definition
(Not_Null_Present
);
1396 if Token
/= Tok_Renames
then
1397 Error_Msg_SC
("'RENAMES' expected");
1401 Scan
; -- past renames
1404 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1405 Set_Access_Definition
(Decl_Node
, Acc_Node
);
1406 Set_Name
(Decl_Node
, P_Name
);
1409 Type_Node
:= P_Subtype_Mark
;
1411 -- Object renaming declaration
1413 if Token_Is_Renames
then
1415 ("null-exclusion not allowed in object renamings");
1418 -- Object declaration
1421 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1422 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1423 Set_Object_Definition
1425 P_Subtype_Indication
(Type_Node
, Not_Null_Present
));
1427 -- RENAMES at this point means that we had the combination
1428 -- of a constraint on the Type_Node and renames, which is
1431 if Token_Is_Renames
then
1432 Error_Msg_N
("constraint not allowed in object renaming "
1434 Constraint
(Object_Definition
(Decl_Node
)));
1440 -- Ada 2005 (AI-230): Access Definition case
1442 elsif Token
= Tok_Access
then
1443 if Ada_Version
< Ada_05
then
1445 ("generalized use of anonymous access types " &
1446 "is an Ada 2005 extension");
1447 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1450 Acc_Node
:= P_Access_Definition
(Null_Exclusion_Present
=> False);
1452 if Token
/= Tok_Renames
then
1453 Error_Msg_SC
("'RENAMES' expected");
1457 Scan
; -- past renames
1460 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1461 Set_Access_Definition
(Decl_Node
, Acc_Node
);
1462 Set_Name
(Decl_Node
, P_Name
);
1464 -- Subtype indication case
1467 Type_Node
:= P_Subtype_Mark
;
1469 -- Object renaming declaration
1471 if Token_Is_Renames
then
1474 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1475 Set_Subtype_Mark
(Decl_Node
, Type_Node
);
1476 Set_Name
(Decl_Node
, P_Name
);
1478 -- Object declaration
1481 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1482 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1483 Set_Object_Definition
1485 P_Subtype_Indication
(Type_Node
, Not_Null_Present
));
1487 -- RENAMES at this point means that we had the combination of
1488 -- a constraint on the Type_Node and renames, which is illegal
1490 if Token_Is_Renames
then
1492 ("constraint not allowed in object renaming declaration",
1493 Constraint
(Object_Definition
(Decl_Node
)));
1499 -- Scan out initialization, allowed only for object declaration
1501 Init_Loc
:= Token_Ptr
;
1502 Init_Expr
:= Init_Expr_Opt
;
1504 if Present
(Init_Expr
) then
1505 if Nkind
(Decl_Node
) = N_Object_Declaration
then
1506 Set_Expression
(Decl_Node
, Init_Expr
);
1508 Error_Msg
("initialization not allowed here", Init_Loc
);
1513 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
1516 if Ident
< Num_Idents
then
1517 Set_More_Ids
(Decl_Node
, True);
1521 Set_Prev_Ids
(Decl_Node
, True);
1525 Append
(Decl_Node
, Decls
);
1526 exit Ident_Loop
when Ident
= Num_Idents
;
1527 Restore_Scan_State
(Scan_State
);
1530 end loop Ident_Loop
;
1533 end P_Identifier_Declarations
;
1535 -------------------------------
1536 -- 3.3.1 Object Declaration --
1537 -------------------------------
1539 -- OBJECT DECLARATION ::=
1540 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1541 -- SUBTYPE_INDICATION [:= EXPRESSION];
1542 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1543 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1544 -- | SINGLE_TASK_DECLARATION
1545 -- | SINGLE_PROTECTED_DECLARATION
1547 -- Cases starting with TASK are parsed by P_Task (9.1)
1548 -- Cases starting with PROTECTED are parsed by P_Protected (9.4)
1549 -- All other cases are parsed by P_Identifier_Declarations (3.3)
1551 -------------------------------------
1552 -- 3.3.1 Defining Identifier List --
1553 -------------------------------------
1555 -- DEFINING_IDENTIFIER_LIST ::=
1556 -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
1558 -- Always parsed by the construct in which it appears. See special
1559 -- section on "Handling of Defining Identifier Lists" in this unit.
1561 -------------------------------
1562 -- 3.3.2 Number Declaration --
1563 -------------------------------
1565 -- Parsed by P_Identifier_Declarations (3.3)
1567 -------------------------------------------------------------------------
1568 -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) --
1569 -------------------------------------------------------------------------
1571 -- DERIVED_TYPE_DEFINITION ::=
1572 -- [abstract] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
1573 -- [RECORD_EXTENSION_PART]
1575 -- PRIVATE_EXTENSION_DECLARATION ::=
1576 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
1577 -- [abstract] new ancestor_SUBTYPE_INDICATION with PRIVATE;
1579 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
1581 -- The caller has already scanned out the part up to the NEW, and Token
1582 -- either contains Tok_New (or ought to, if it doesn't this procedure
1583 -- will post an appropriate "NEW expected" message).
1585 -- Note: the caller is responsible for filling in the Sloc field of
1586 -- the returned node in the private extension declaration case as
1587 -- well as the stuff relating to the discriminant part.
1589 -- Error recovery: can raise Error_Resync;
1591 function P_Derived_Type_Def_Or_Private_Ext_Decl
return Node_Id
is
1592 Typedef_Node
: Node_Id
;
1593 Typedecl_Node
: Node_Id
;
1594 Not_Null_Present
: Boolean := False;
1596 Typedef_Node
:= New_Node
(N_Derived_Type_Definition
, Token_Ptr
);
1599 if Token
= Tok_Abstract
then
1600 Error_Msg_SC
("ABSTRACT must come before NEW, not after");
1604 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1605 Set_Null_Exclusion_Present
(Typedef_Node
, Not_Null_Present
);
1606 Set_Subtype_Indication
(Typedef_Node
,
1607 P_Subtype_Indication
(Not_Null_Present
));
1609 -- Deal with record extension, note that we assume that a WITH is
1610 -- missing in the case of "type X is new Y record ..." or in the
1611 -- case of "type X is new Y null record".
1614 or else Token
= Tok_Record
1615 or else Token
= Tok_Null
1617 T_With
; -- past WITH or give error message
1619 if Token
= Tok_Limited
then
1621 ("LIMITED keyword not allowed in private extension");
1622 Scan
; -- ignore LIMITED
1625 -- Private extension declaration
1627 if Token
= Tok_Private
then
1628 Scan
; -- past PRIVATE
1630 -- Throw away the type definition node and build the type
1631 -- declaration node. Note the caller must set the Sloc,
1632 -- Discriminant_Specifications, Unknown_Discriminants_Present,
1633 -- and Defined_Identifier fields in the returned node.
1636 Make_Private_Extension_Declaration
(No_Location
,
1637 Defining_Identifier
=> Empty
,
1638 Subtype_Indication
=> Subtype_Indication
(Typedef_Node
),
1639 Abstract_Present
=> Abstract_Present
(Typedef_Node
));
1641 Delete_Node
(Typedef_Node
);
1642 return Typedecl_Node
;
1644 -- Derived type definition with record extension part
1647 Set_Record_Extension_Part
(Typedef_Node
, P_Record_Definition
);
1648 return Typedef_Node
;
1651 -- Derived type definition with no record extension part
1654 return Typedef_Node
;
1656 end P_Derived_Type_Def_Or_Private_Ext_Decl
;
1658 ---------------------------
1659 -- 3.5 Range Constraint --
1660 ---------------------------
1662 -- RANGE_CONSTRAINT ::= range RANGE
1664 -- The caller has checked that the initial token is RANGE
1666 -- Error recovery: cannot raise Error_Resync
1668 function P_Range_Constraint
return Node_Id
is
1669 Range_Node
: Node_Id
;
1672 Range_Node
:= New_Node
(N_Range_Constraint
, Token_Ptr
);
1674 Set_Range_Expression
(Range_Node
, P_Range
);
1676 end P_Range_Constraint
;
1683 -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
1685 -- Note: the range that appears in a membership test is parsed by
1686 -- P_Range_Or_Subtype_Mark (3.5).
1688 -- Error recovery: cannot raise Error_Resync
1690 function P_Range
return Node_Id
is
1691 Expr_Node
: Node_Id
;
1692 Range_Node
: Node_Id
;
1695 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
1697 if Expr_Form
= EF_Range_Attr
then
1700 elsif Token
= Tok_Dot_Dot
then
1701 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
1702 Set_Low_Bound
(Range_Node
, Expr_Node
);
1704 Expr_Node
:= P_Expression
;
1705 Check_Simple_Expression
(Expr_Node
);
1706 Set_High_Bound
(Range_Node
, Expr_Node
);
1709 -- Anything else is an error
1712 T_Dot_Dot
; -- force missing .. message
1717 ----------------------------------
1718 -- 3.5 P_Range_Or_Subtype_Mark --
1719 ----------------------------------
1722 -- RANGE_ATTRIBUTE_REFERENCE
1723 -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
1725 -- This routine scans out the range or subtype mark that forms the right
1726 -- operand of a membership test.
1728 -- Note: as documented in the Sinfo interface, although the syntax only
1729 -- allows a subtype mark, we in fact allow any simple expression to be
1730 -- returned from this routine. The semantics is responsible for issuing
1731 -- an appropriate message complaining if the argument is not a name.
1732 -- This simplifies the coding and error recovery processing in the
1733 -- parser, and in any case it is preferable not to consider this a
1734 -- syntax error and to continue with the semantic analysis.
1736 -- Error recovery: cannot raise Error_Resync
1738 function P_Range_Or_Subtype_Mark
return Node_Id
is
1739 Expr_Node
: Node_Id
;
1740 Range_Node
: Node_Id
;
1743 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
1745 if Expr_Form
= EF_Range_Attr
then
1748 -- Simple_Expression .. Simple_Expression
1750 elsif Token
= Tok_Dot_Dot
then
1751 Check_Simple_Expression
(Expr_Node
);
1752 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
1753 Set_Low_Bound
(Range_Node
, Expr_Node
);
1755 Set_High_Bound
(Range_Node
, P_Simple_Expression
);
1758 -- Case of subtype mark (optionally qualified simple name or an
1759 -- attribute whose prefix is an optionally qualifed simple name)
1761 elsif Expr_Form
= EF_Simple_Name
1762 or else Nkind
(Expr_Node
) = N_Attribute_Reference
1764 -- Check for error of range constraint after a subtype mark
1766 if Token
= Tok_Range
then
1768 ("range constraint not allowed in membership test");
1772 -- Check for error of DIGITS or DELTA after a subtype mark
1774 elsif Token
= Tok_Digits
or else Token
= Tok_Delta
then
1776 ("accuracy definition not allowed in membership test");
1777 Scan
; -- past DIGITS or DELTA
1780 elsif Token
= Tok_Apostrophe
then
1781 return P_Subtype_Mark_Attribute
(Expr_Node
);
1787 -- At this stage, we have some junk following the expression. We
1788 -- really can't tell what is wrong, might be a missing semicolon,
1789 -- or a missing THEN, or whatever. Our caller will figure it out!
1794 end P_Range_Or_Subtype_Mark
;
1796 ----------------------------------------
1797 -- 3.5.1 Enumeration Type Definition --
1798 ----------------------------------------
1800 -- ENUMERATION_TYPE_DEFINITION ::=
1801 -- (ENUMERATION_LITERAL_SPECIFICATION
1802 -- {, ENUMERATION_LITERAL_SPECIFICATION})
1804 -- The caller has already scanned out the TYPE keyword
1806 -- Error recovery: can raise Error_Resync;
1808 function P_Enumeration_Type_Definition
return Node_Id
is
1809 Typedef_Node
: Node_Id
;
1812 Typedef_Node
:= New_Node
(N_Enumeration_Type_Definition
, Token_Ptr
);
1813 Set_Literals
(Typedef_Node
, New_List
);
1818 Append
(P_Enumeration_Literal_Specification
, Literals
(Typedef_Node
));
1819 exit when not Comma_Present
;
1823 return Typedef_Node
;
1824 end P_Enumeration_Type_Definition
;
1826 ----------------------------------------------
1827 -- 3.5.1 Enumeration Literal Specification --
1828 ----------------------------------------------
1830 -- ENUMERATION_LITERAL_SPECIFICATION ::=
1831 -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
1833 -- Error recovery: can raise Error_Resync
1835 function P_Enumeration_Literal_Specification
return Node_Id
is
1837 if Token
= Tok_Char_Literal
then
1838 return P_Defining_Character_Literal
;
1840 return P_Defining_Identifier
(C_Comma_Right_Paren
);
1842 end P_Enumeration_Literal_Specification
;
1844 ---------------------------------------
1845 -- 3.5.1 Defining_Character_Literal --
1846 ---------------------------------------
1848 -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
1850 -- Error recovery: cannot raise Error_Resync
1852 -- The caller has checked that the current token is a character literal
1854 function P_Defining_Character_Literal
return Node_Id
is
1855 Literal_Node
: Node_Id
;
1858 Literal_Node
:= Token_Node
;
1859 Change_Character_Literal_To_Defining_Character_Literal
(Literal_Node
);
1860 Scan
; -- past character literal
1861 return Literal_Node
;
1862 end P_Defining_Character_Literal
;
1864 ------------------------------------
1865 -- 3.5.4 Integer Type Definition --
1866 ------------------------------------
1868 -- Parsed by P_Type_Declaration (3.2.1)
1870 -------------------------------------------
1871 -- 3.5.4 Signed Integer Type Definition --
1872 -------------------------------------------
1874 -- SIGNED_INTEGER_TYPE_DEFINITION ::=
1875 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
1877 -- Normally the initial token on entry is RANGE, but in some
1878 -- error conditions, the range token was missing and control is
1879 -- passed with Token pointing to first token of the first expression.
1881 -- Error recovery: cannot raise Error_Resync
1883 function P_Signed_Integer_Type_Definition
return Node_Id
is
1884 Typedef_Node
: Node_Id
;
1885 Expr_Node
: Node_Id
;
1888 Typedef_Node
:= New_Node
(N_Signed_Integer_Type_Definition
, Token_Ptr
);
1890 if Token
= Tok_Range
then
1894 Expr_Node
:= P_Expression
;
1895 Check_Simple_Expression
(Expr_Node
);
1896 Set_Low_Bound
(Typedef_Node
, Expr_Node
);
1898 Expr_Node
:= P_Expression
;
1899 Check_Simple_Expression
(Expr_Node
);
1900 Set_High_Bound
(Typedef_Node
, Expr_Node
);
1901 return Typedef_Node
;
1902 end P_Signed_Integer_Type_Definition
;
1904 ------------------------------------
1905 -- 3.5.4 Modular Type Definition --
1906 ------------------------------------
1908 -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
1910 -- The caller has checked that the initial token is MOD
1912 -- Error recovery: cannot raise Error_Resync
1914 function P_Modular_Type_Definition
return Node_Id
is
1915 Typedef_Node
: Node_Id
;
1918 if Ada_Version
= Ada_83
then
1919 Error_Msg_SC
("(Ada 83): modular types not allowed");
1922 Typedef_Node
:= New_Node
(N_Modular_Type_Definition
, Token_Ptr
);
1924 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
1926 -- Handle mod L..R cleanly
1928 if Token
= Tok_Dot_Dot
then
1929 Error_Msg_SC
("range not allowed for modular type");
1931 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
1934 return Typedef_Node
;
1935 end P_Modular_Type_Definition
;
1937 ---------------------------------
1938 -- 3.5.6 Real Type Definition --
1939 ---------------------------------
1941 -- Parsed by P_Type_Declaration (3.2.1)
1943 --------------------------------------
1944 -- 3.5.7 Floating Point Definition --
1945 --------------------------------------
1947 -- FLOATING_POINT_DEFINITION ::=
1948 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
1950 -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
1952 -- The caller has checked that the initial token is DIGITS
1954 -- Error recovery: cannot raise Error_Resync
1956 function P_Floating_Point_Definition
return Node_Id
is
1957 Digits_Loc
: constant Source_Ptr
:= Token_Ptr
;
1959 Expr_Node
: Node_Id
;
1962 Scan
; -- past DIGITS
1963 Expr_Node
:= P_Expression_No_Right_Paren
;
1964 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
1966 -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
1968 if Token
= Tok_Delta
then
1969 Error_Msg_SC
("DELTA must come before DIGITS");
1970 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Digits_Loc
);
1972 Set_Delta_Expression
(Def_Node
, P_Expression_No_Right_Paren
);
1974 -- OK floating-point definition
1977 Def_Node
:= New_Node
(N_Floating_Point_Definition
, Digits_Loc
);
1980 Set_Digits_Expression
(Def_Node
, Expr_Node
);
1981 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
1983 end P_Floating_Point_Definition
;
1985 -------------------------------------
1986 -- 3.5.7 Real Range Specification --
1987 -------------------------------------
1989 -- REAL_RANGE_SPECIFICATION ::=
1990 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
1992 -- Error recovery: cannot raise Error_Resync
1994 function P_Real_Range_Specification_Opt
return Node_Id
is
1995 Specification_Node
: Node_Id
;
1996 Expr_Node
: Node_Id
;
1999 if Token
= Tok_Range
then
2000 Specification_Node
:=
2001 New_Node
(N_Real_Range_Specification
, Token_Ptr
);
2003 Expr_Node
:= P_Expression_No_Right_Paren
;
2004 Check_Simple_Expression
(Expr_Node
);
2005 Set_Low_Bound
(Specification_Node
, Expr_Node
);
2007 Expr_Node
:= P_Expression_No_Right_Paren
;
2008 Check_Simple_Expression
(Expr_Node
);
2009 Set_High_Bound
(Specification_Node
, Expr_Node
);
2010 return Specification_Node
;
2014 end P_Real_Range_Specification_Opt
;
2016 -----------------------------------
2017 -- 3.5.9 Fixed Point Definition --
2018 -----------------------------------
2020 -- FIXED_POINT_DEFINITION ::=
2021 -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
2023 -- ORDINARY_FIXED_POINT_DEFINITION ::=
2024 -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION
2026 -- DECIMAL_FIXED_POINT_DEFINITION ::=
2027 -- delta static_EXPRESSION
2028 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2030 -- The caller has checked that the initial token is DELTA
2032 -- Error recovery: cannot raise Error_Resync
2034 function P_Fixed_Point_Definition
return Node_Id
is
2035 Delta_Node
: Node_Id
;
2036 Delta_Loc
: Source_Ptr
;
2038 Expr_Node
: Node_Id
;
2041 Delta_Loc
:= Token_Ptr
;
2043 Delta_Node
:= P_Expression_No_Right_Paren
;
2044 Check_Simple_Expression_In_Ada_83
(Delta_Node
);
2046 if Token
= Tok_Digits
then
2047 if Ada_Version
= Ada_83
then
2048 Error_Msg_SC
("(Ada 83) decimal fixed type not allowed!");
2051 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Delta_Loc
);
2052 Scan
; -- past DIGITS
2053 Expr_Node
:= P_Expression_No_Right_Paren
;
2054 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2055 Set_Digits_Expression
(Def_Node
, Expr_Node
);
2058 Def_Node
:= New_Node
(N_Ordinary_Fixed_Point_Definition
, Delta_Loc
);
2060 -- Range is required in ordinary fixed point case
2062 if Token
/= Tok_Range
then
2063 Error_Msg_AP
("range must be given for fixed-point type");
2068 Set_Delta_Expression
(Def_Node
, Delta_Node
);
2069 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
2071 end P_Fixed_Point_Definition
;
2073 --------------------------------------------
2074 -- 3.5.9 Ordinary Fixed Point Definition --
2075 --------------------------------------------
2077 -- Parsed by P_Fixed_Point_Definition (3.5.9)
2079 -------------------------------------------
2080 -- 3.5.9 Decimal Fixed Point Definition --
2081 -------------------------------------------
2083 -- Parsed by P_Decimal_Point_Definition (3.5.9)
2085 ------------------------------
2086 -- 3.5.9 Digits Constraint --
2087 ------------------------------
2089 -- DIGITS_CONSTRAINT ::=
2090 -- digits static_EXPRESSION [RANGE_CONSTRAINT]
2092 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2094 -- The caller has checked that the initial token is DIGITS
2096 function P_Digits_Constraint
return Node_Id
is
2097 Constraint_Node
: Node_Id
;
2098 Expr_Node
: Node_Id
;
2101 Constraint_Node
:= New_Node
(N_Digits_Constraint
, Token_Ptr
);
2102 Scan
; -- past DIGITS
2103 Expr_Node
:= P_Expression_No_Right_Paren
;
2104 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2105 Set_Digits_Expression
(Constraint_Node
, Expr_Node
);
2107 if Token
= Tok_Range
then
2108 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
2111 return Constraint_Node
;
2112 end P_Digits_Constraint
;
2114 -----------------------------
2115 -- 3.5.9 Delta Constraint --
2116 -----------------------------
2118 -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
2120 -- Note: this is an obsolescent feature in Ada 95 (I.3)
2122 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2124 -- The caller has checked that the initial token is DELTA
2126 -- Error recovery: cannot raise Error_Resync
2128 function P_Delta_Constraint
return Node_Id
is
2129 Constraint_Node
: Node_Id
;
2130 Expr_Node
: Node_Id
;
2133 Constraint_Node
:= New_Node
(N_Delta_Constraint
, Token_Ptr
);
2135 Expr_Node
:= P_Expression_No_Right_Paren
;
2136 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2137 Set_Delta_Expression
(Constraint_Node
, Expr_Node
);
2139 if Token
= Tok_Range
then
2140 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
2143 return Constraint_Node
;
2144 end P_Delta_Constraint
;
2146 --------------------------------
2147 -- 3.6 Array Type Definition --
2148 --------------------------------
2150 -- ARRAY_TYPE_DEFINITION ::=
2151 -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
2153 -- UNCONSTRAINED_ARRAY_DEFINITION ::=
2154 -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
2155 -- COMPONENT_DEFINITION
2157 -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
2159 -- CONSTRAINED_ARRAY_DEFINITION ::=
2160 -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
2161 -- COMPONENT_DEFINITION
2163 -- DISCRETE_SUBTYPE_DEFINITION ::=
2164 -- DISCRETE_SUBTYPE_INDICATION | RANGE
2166 -- COMPONENT_DEFINITION ::=
2167 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
2169 -- The caller has checked that the initial token is ARRAY
2171 -- Error recovery: can raise Error_Resync
2173 function P_Array_Type_Definition
return Node_Id
is
2174 Array_Loc
: Source_Ptr
;
2175 CompDef_Node
: Node_Id
;
2177 Not_Null_Present
: Boolean := False;
2178 Subs_List
: List_Id
;
2179 Scan_State
: Saved_Scan_State
;
2180 Aliased_Present
: Boolean := False;
2183 Array_Loc
:= Token_Ptr
;
2185 Subs_List
:= New_List
;
2188 -- It's quite tricky to disentangle these two possibilities, so we do
2189 -- a prescan to determine which case we have and then reset the scan.
2190 -- The prescan skips past possible subtype mark tokens.
2192 Save_Scan_State
(Scan_State
); -- just after paren
2194 while Token
in Token_Class_Desig
or else
2195 Token
= Tok_Dot
or else
2196 Token
= Tok_Apostrophe
-- because of 'BASE, 'CLASS
2201 -- If we end up on RANGE <> then we have the unconstrained case. We
2202 -- will also allow the RANGE to be omitted, just to improve error
2203 -- handling for a case like array (integer <>) of integer;
2205 Scan
; -- past possible RANGE or <>
2207 if (Prev_Token
= Tok_Range
and then Token
= Tok_Box
) or else
2208 Prev_Token
= Tok_Box
2210 Def_Node
:= New_Node
(N_Unconstrained_Array_Definition
, Array_Loc
);
2211 Restore_Scan_State
(Scan_State
); -- to first subtype mark
2214 Append
(P_Subtype_Mark_Resync
, Subs_List
);
2217 exit when Token
= Tok_Right_Paren
or else Token
= Tok_Of
;
2221 Set_Subtype_Marks
(Def_Node
, Subs_List
);
2224 Def_Node
:= New_Node
(N_Constrained_Array_Definition
, Array_Loc
);
2225 Restore_Scan_State
(Scan_State
); -- to first discrete range
2228 Append
(P_Discrete_Subtype_Definition
, Subs_List
);
2229 exit when not Comma_Present
;
2232 Set_Discrete_Subtype_Definitions
(Def_Node
, Subs_List
);
2238 CompDef_Node
:= New_Node
(N_Component_Definition
, Token_Ptr
);
2240 if Token_Name
= Name_Aliased
then
2241 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
2244 if Token
= Tok_Aliased
then
2245 Aliased_Present
:= True;
2246 Scan
; -- past ALIASED
2249 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/AI-254)
2251 -- Ada 2005 (AI-230): Access Definition case
2253 if Token
= Tok_Access
then
2254 if Ada_Version
< Ada_05
then
2256 ("generalized use of anonymous access types " &
2257 "is an Ada 2005 extension");
2258 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
2261 if Aliased_Present
then
2262 Error_Msg_SP
("ALIASED not allowed here");
2265 Set_Subtype_Indication
(CompDef_Node
, Empty
);
2266 Set_Aliased_Present
(CompDef_Node
, False);
2267 Set_Access_Definition
(CompDef_Node
,
2268 P_Access_Definition
(Not_Null_Present
));
2271 Set_Access_Definition
(CompDef_Node
, Empty
);
2272 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
2273 Set_Null_Exclusion_Present
(CompDef_Node
, Not_Null_Present
);
2274 Set_Subtype_Indication
(CompDef_Node
,
2275 P_Subtype_Indication
(Not_Null_Present
));
2278 Set_Component_Definition
(Def_Node
, CompDef_Node
);
2281 end P_Array_Type_Definition
;
2283 -----------------------------------------
2284 -- 3.6 Unconstrained Array Definition --
2285 -----------------------------------------
2287 -- Parsed by P_Array_Type_Definition (3.6)
2289 ---------------------------------------
2290 -- 3.6 Constrained Array Definition --
2291 ---------------------------------------
2293 -- Parsed by P_Array_Type_Definition (3.6)
2295 --------------------------------------
2296 -- 3.6 Discrete Subtype Definition --
2297 --------------------------------------
2299 -- DISCRETE_SUBTYPE_DEFINITION ::=
2300 -- discrete_SUBTYPE_INDICATION | RANGE
2302 -- Note: the discrete subtype definition appearing in a constrained
2303 -- array definition is parsed by P_Array_Type_Definition (3.6)
2305 -- Error recovery: cannot raise Error_Resync
2307 function P_Discrete_Subtype_Definition
return Node_Id
is
2309 -- The syntax of a discrete subtype definition is identical to that
2310 -- of a discrete range, so we simply share the same parsing code.
2312 return P_Discrete_Range
;
2313 end P_Discrete_Subtype_Definition
;
2315 -------------------------------
2316 -- 3.6 Component Definition --
2317 -------------------------------
2319 -- For the array case, parsed by P_Array_Type_Definition (3.6)
2320 -- For the record case, parsed by P_Component_Declaration (3.8)
2322 -----------------------------
2323 -- 3.6.1 Index Constraint --
2324 -----------------------------
2326 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2328 ---------------------------
2329 -- 3.6.1 Discrete Range --
2330 ---------------------------
2332 -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
2334 -- The possible forms for a discrete range are:
2336 -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2)
2337 -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2)
2338 -- Range_Attribute (RANGE, 3.5)
2339 -- Simple_Expression .. Simple_Expression (RANGE, 3.5)
2341 -- Error recovery: cannot raise Error_Resync
2343 function P_Discrete_Range
return Node_Id
is
2344 Expr_Node
: Node_Id
;
2345 Range_Node
: Node_Id
;
2348 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2350 if Expr_Form
= EF_Range_Attr
then
2353 elsif Token
= Tok_Range
then
2354 if Expr_Form
/= EF_Simple_Name
then
2355 Error_Msg_SC
("range must be preceded by subtype mark");
2358 return P_Subtype_Indication
(Expr_Node
);
2360 -- Check Expression .. Expression case
2362 elsif Token
= Tok_Dot_Dot
then
2363 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2364 Set_Low_Bound
(Range_Node
, Expr_Node
);
2366 Expr_Node
:= P_Expression
;
2367 Check_Simple_Expression
(Expr_Node
);
2368 Set_High_Bound
(Range_Node
, Expr_Node
);
2371 -- Otherwise we must have a subtype mark
2373 elsif Expr_Form
= EF_Simple_Name
then
2376 -- If incorrect, complain that we expect ..
2382 end P_Discrete_Range
;
2384 ----------------------------
2385 -- 3.7 Discriminant Part --
2386 ----------------------------
2388 -- DISCRIMINANT_PART ::=
2389 -- UNKNOWN_DISCRIMINANT_PART
2390 -- | KNOWN_DISCRIMINANT_PART
2392 -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
2393 -- or P_Unknown_Discriminant_Part (3.7), since we know which we want.
2395 ------------------------------------
2396 -- 3.7 Unknown Discriminant Part --
2397 ------------------------------------
2399 -- UNKNOWN_DISCRIMINANT_PART ::= (<>)
2401 -- If no unknown discriminant part is present, then False is returned,
2402 -- otherwise the unknown discriminant is scanned out and True is returned.
2404 -- Error recovery: cannot raise Error_Resync
2406 function P_Unknown_Discriminant_Part_Opt
return Boolean is
2407 Scan_State
: Saved_Scan_State
;
2410 if Token
/= Tok_Left_Paren
then
2414 Save_Scan_State
(Scan_State
);
2415 Scan
; -- past the left paren
2417 if Token
= Tok_Box
then
2418 if Ada_Version
= Ada_83
then
2419 Error_Msg_SC
("(Ada 83) unknown discriminant not allowed!");
2422 Scan
; -- past the box
2423 T_Right_Paren
; -- must be followed by right paren
2427 Restore_Scan_State
(Scan_State
);
2431 end P_Unknown_Discriminant_Part_Opt
;
2433 ----------------------------------
2434 -- 3.7 Known Discriminant Part --
2435 ----------------------------------
2437 -- KNOWN_DISCRIMINANT_PART ::=
2438 -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
2440 -- DISCRIMINANT_SPECIFICATION ::=
2441 -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
2442 -- [:= DEFAULT_EXPRESSION]
2443 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
2444 -- [:= DEFAULT_EXPRESSION]
2446 -- If no known discriminant part is present, then No_List is returned
2448 -- Error recovery: cannot raise Error_Resync
2450 function P_Known_Discriminant_Part_Opt
return List_Id
is
2451 Specification_Node
: Node_Id
;
2452 Specification_List
: List_Id
;
2453 Ident_Sloc
: Source_Ptr
;
2454 Scan_State
: Saved_Scan_State
;
2456 Not_Null_Present
: Boolean;
2459 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
2460 -- This array holds the list of defining identifiers. The upper bound
2461 -- of 4096 is intended to be essentially infinite, and we do not even
2462 -- bother to check for it being exceeded.
2465 if Token
= Tok_Left_Paren
then
2466 Specification_List
:= New_List
;
2468 P_Pragmas_Misplaced
;
2470 Specification_Loop
: loop
2472 Ident_Sloc
:= Token_Ptr
;
2473 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
2476 while Comma_Present
loop
2477 Num_Idents
:= Num_Idents
+ 1;
2478 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
2483 -- If there are multiple identifiers, we repeatedly scan the
2484 -- type and initialization expression information by resetting
2485 -- the scan pointer (so that we get completely separate trees
2486 -- for each occurrence).
2488 if Num_Idents
> 1 then
2489 Save_Scan_State
(Scan_State
);
2492 -- Loop through defining identifiers in list
2496 Specification_Node
:=
2497 New_Node
(N_Discriminant_Specification
, Ident_Sloc
);
2498 Set_Defining_Identifier
(Specification_Node
, Idents
(Ident
));
2499 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
2501 if Token
= Tok_Access
then
2502 if Ada_Version
= Ada_83
then
2504 ("(Ada 83) access discriminant not allowed!");
2507 Set_Discriminant_Type
2508 (Specification_Node
,
2509 P_Access_Definition
(Not_Null_Present
));
2512 Set_Discriminant_Type
2513 (Specification_Node
, P_Subtype_Mark
);
2515 Set_Null_Exclusion_Present
-- Ada 2005 (AI-231)
2516 (Specification_Node
, Not_Null_Present
);
2520 (Specification_Node
, Init_Expr_Opt
(True));
2523 Set_Prev_Ids
(Specification_Node
, True);
2526 if Ident
< Num_Idents
then
2527 Set_More_Ids
(Specification_Node
, True);
2530 Append
(Specification_Node
, Specification_List
);
2531 exit Ident_Loop
when Ident
= Num_Idents
;
2533 Restore_Scan_State
(Scan_State
);
2534 end loop Ident_Loop
;
2536 exit Specification_Loop
when Token
/= Tok_Semicolon
;
2538 P_Pragmas_Misplaced
;
2539 end loop Specification_Loop
;
2542 return Specification_List
;
2547 end P_Known_Discriminant_Part_Opt
;
2549 -------------------------------------
2550 -- 3.7 DIscriminant Specification --
2551 -------------------------------------
2553 -- Parsed by P_Known_Discriminant_Part_Opt (3.7)
2555 -----------------------------
2556 -- 3.7 Default Expression --
2557 -----------------------------
2559 -- Always parsed (simply as an Expression) by the parent construct
2561 ------------------------------------
2562 -- 3.7.1 Discriminant Constraint --
2563 ------------------------------------
2565 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2567 --------------------------------------------------------
2568 -- 3.7.1 Index or Discriminant Constraint (also 3.6) --
2569 --------------------------------------------------------
2571 -- DISCRIMINANT_CONSTRAINT ::=
2572 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
2574 -- DISCRIMINANT_ASSOCIATION ::=
2575 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2578 -- This routine parses either an index or a discriminant constraint. As
2579 -- is clear from the above grammar, it is often possible to clearly
2580 -- determine which of the two possibilities we have, but there are
2581 -- cases (those in which we have a series of expressions of the same
2582 -- syntactic form as subtype indications), where we cannot tell. Since
2583 -- this means that in any case the semantic phase has to distinguish
2584 -- between the two, there is not much point in the parser trying to
2585 -- distinguish even those cases where the difference is clear. In any
2586 -- case, if we have a situation like:
2588 -- (A => 123, 235 .. 500)
2590 -- it is not clear which of the two items is the wrong one, better to
2591 -- let the semantic phase give a clear message. Consequently, this
2592 -- routine in general returns a list of items which can be either
2593 -- discrete ranges or discriminant associations.
2595 -- The caller has checked that the initial token is a left paren
2597 -- Error recovery: can raise Error_Resync
2599 function P_Index_Or_Discriminant_Constraint
return Node_Id
is
2600 Scan_State
: Saved_Scan_State
;
2601 Constr_Node
: Node_Id
;
2602 Constr_List
: List_Id
;
2603 Expr_Node
: Node_Id
;
2604 Result_Node
: Node_Id
;
2607 Result_Node
:= New_Node
(N_Index_Or_Discriminant_Constraint
, Token_Ptr
);
2609 Constr_List
:= New_List
;
2610 Set_Constraints
(Result_Node
, Constr_List
);
2612 -- The two syntactic forms are a little mixed up, so what we are doing
2613 -- here is looking at the first entry to determine which case we have
2615 -- A discriminant constraint is a list of discriminant associations,
2616 -- which have one of the following possible forms:
2620 -- Id | Id | .. | Id => Expression
2622 -- An index constraint is a list of discrete ranges which have one
2623 -- of the following possible forms:
2626 -- Subtype_Mark range Range
2628 -- Simple_Expression .. Simple_Expression
2630 -- Loop through discriminants in list
2633 -- Check cases of Id => Expression or Id | Id => Expression
2635 if Token
= Tok_Identifier
then
2636 Save_Scan_State
(Scan_State
); -- at Id
2639 if Token
= Tok_Arrow
or else Token
= Tok_Vertical_Bar
then
2640 Restore_Scan_State
(Scan_State
); -- to Id
2641 Append
(P_Discriminant_Association
, Constr_List
);
2644 Restore_Scan_State
(Scan_State
); -- to Id
2648 -- Otherwise scan out an expression and see what we have got
2650 Expr_Node
:= P_Expression_Or_Range_Attribute
;
2652 if Expr_Form
= EF_Range_Attr
then
2653 Append
(Expr_Node
, Constr_List
);
2655 elsif Token
= Tok_Range
then
2656 if Expr_Form
/= EF_Simple_Name
then
2657 Error_Msg_SC
("subtype mark required before RANGE");
2660 Append
(P_Subtype_Indication
(Expr_Node
), Constr_List
);
2663 -- Check Simple_Expression .. Simple_Expression case
2665 elsif Token
= Tok_Dot_Dot
then
2666 Check_Simple_Expression
(Expr_Node
);
2667 Constr_Node
:= New_Node
(N_Range
, Token_Ptr
);
2668 Set_Low_Bound
(Constr_Node
, Expr_Node
);
2670 Expr_Node
:= P_Expression
;
2671 Check_Simple_Expression
(Expr_Node
);
2672 Set_High_Bound
(Constr_Node
, Expr_Node
);
2673 Append
(Constr_Node
, Constr_List
);
2676 -- Case of an expression which could be either form
2679 Append
(Expr_Node
, Constr_List
);
2683 -- Here with a single entry scanned
2686 exit when not Comma_Present
;
2692 end P_Index_Or_Discriminant_Constraint
;
2694 -------------------------------------
2695 -- 3.7.1 Discriminant Association --
2696 -------------------------------------
2698 -- DISCRIMINANT_ASSOCIATION ::=
2699 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2702 -- This routine is used only when the name list is present and the caller
2703 -- has already checked this (by scanning ahead and repositioning the
2706 -- Error_Recovery: cannot raise Error_Resync;
2708 function P_Discriminant_Association
return Node_Id
is
2709 Discr_Node
: Node_Id
;
2710 Names_List
: List_Id
;
2711 Ident_Sloc
: Source_Ptr
;
2714 Ident_Sloc
:= Token_Ptr
;
2715 Names_List
:= New_List
;
2718 Append
(P_Identifier
(C_Vertical_Bar_Arrow
), Names_List
);
2719 exit when Token
/= Tok_Vertical_Bar
;
2723 Discr_Node
:= New_Node
(N_Discriminant_Association
, Ident_Sloc
);
2724 Set_Selector_Names
(Discr_Node
, Names_List
);
2726 Set_Expression
(Discr_Node
, P_Expression
);
2728 end P_Discriminant_Association
;
2730 ---------------------------------
2731 -- 3.8 Record Type Definition --
2732 ---------------------------------
2734 -- RECORD_TYPE_DEFINITION ::=
2735 -- [[abstract] tagged] [limited] RECORD_DEFINITION
2737 -- There is no node in the tree for a record type definition. Instead
2738 -- a record definition node appears, with possible Abstract_Present,
2739 -- Tagged_Present, and Limited_Present flags set appropriately.
2741 ----------------------------
2742 -- 3.8 Record Definition --
2743 ----------------------------
2745 -- RECORD_DEFINITION ::=
2751 -- Note: in the case where a record definition node is used to represent
2752 -- a record type definition, the caller sets the Tagged_Present and
2753 -- Limited_Present flags in the resulting N_Record_Definition node as
2756 -- Note that the RECORD token at the start may be missing in certain
2757 -- error situations, so this function is expected to post the error
2759 -- Error recovery: can raise Error_Resync
2761 function P_Record_Definition
return Node_Id
is
2765 Rec_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
2769 if Token
= Tok_Null
then
2772 Set_Null_Present
(Rec_Node
, True);
2774 -- Case starting with RECORD keyword. Build scope stack entry. For the
2775 -- column, we use the first non-blank character on the line, to deal
2776 -- with situations such as:
2782 -- which is not official RM indentation, but is not uncommon usage
2786 Scope
.Table
(Scope
.Last
).Etyp
:= E_Record
;
2787 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
2788 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
2789 Scope
.Table
(Scope
.Last
).Labl
:= Error
;
2790 Scope
.Table
(Scope
.Last
).Junk
:= (Token
/= Tok_Record
);
2794 Set_Component_List
(Rec_Node
, P_Component_List
);
2797 exit when Check_End
;
2798 Discard_Junk_Node
(P_Component_List
);
2803 end P_Record_Definition
;
2805 -------------------------
2806 -- 3.8 Component List --
2807 -------------------------
2809 -- COMPONENT_LIST ::=
2810 -- COMPONENT_ITEM {COMPONENT_ITEM}
2811 -- | {COMPONENT_ITEM} VARIANT_PART
2814 -- Error recovery: cannot raise Error_Resync
2816 function P_Component_List
return Node_Id
is
2817 Component_List_Node
: Node_Id
;
2818 Decls_List
: List_Id
;
2819 Scan_State
: Saved_Scan_State
;
2822 Component_List_Node
:= New_Node
(N_Component_List
, Token_Ptr
);
2823 Decls_List
:= New_List
;
2825 if Token
= Tok_Null
then
2828 P_Pragmas_Opt
(Decls_List
);
2829 Set_Null_Present
(Component_List_Node
, True);
2830 return Component_List_Node
;
2833 P_Pragmas_Opt
(Decls_List
);
2835 if Token
/= Tok_Case
then
2836 Component_Scan_Loop
: loop
2837 P_Component_Items
(Decls_List
);
2838 P_Pragmas_Opt
(Decls_List
);
2840 exit Component_Scan_Loop
when Token
= Tok_End
2841 or else Token
= Tok_Case
2842 or else Token
= Tok_When
;
2844 -- We are done if we do not have an identifier. However, if
2845 -- we have a misspelled reserved identifier that is in a column
2846 -- to the right of the record definition, we will treat it as
2847 -- an identifier. It turns out to be too dangerous in practice
2848 -- to accept such a mis-spelled identifier which does not have
2849 -- this additional clue that confirms the incorrect spelling.
2851 if Token
/= Tok_Identifier
then
2852 if Start_Column
> Scope
.Table
(Scope
.Last
).Ecol
2853 and then Is_Reserved_Identifier
2855 Save_Scan_State
(Scan_State
); -- at reserved id
2856 Scan
; -- possible reserved id
2858 if Token
= Tok_Comma
or else Token
= Tok_Colon
then
2859 Restore_Scan_State
(Scan_State
);
2860 Scan_Reserved_Identifier
(Force_Msg
=> True);
2862 -- Note reserved identifier used as field name after
2863 -- all because not followed by colon or comma
2866 Restore_Scan_State
(Scan_State
);
2867 exit Component_Scan_Loop
;
2870 -- Non-identifier that definitely was not reserved id
2873 exit Component_Scan_Loop
;
2876 end loop Component_Scan_Loop
;
2879 if Token
= Tok_Case
then
2880 Set_Variant_Part
(Component_List_Node
, P_Variant_Part
);
2882 -- Check for junk after variant part
2884 if Token
= Tok_Identifier
then
2885 Save_Scan_State
(Scan_State
);
2886 Scan
; -- past identifier
2888 if Token
= Tok_Colon
then
2889 Restore_Scan_State
(Scan_State
);
2890 Error_Msg_SC
("component may not follow variant part");
2891 Discard_Junk_Node
(P_Component_List
);
2893 elsif Token
= Tok_Case
then
2894 Restore_Scan_State
(Scan_State
);
2895 Error_Msg_SC
("only one variant part allowed in a record");
2896 Discard_Junk_Node
(P_Component_List
);
2899 Restore_Scan_State
(Scan_State
);
2905 Set_Component_Items
(Component_List_Node
, Decls_List
);
2906 return Component_List_Node
;
2907 end P_Component_List
;
2909 -------------------------
2910 -- 3.8 Component Item --
2911 -------------------------
2913 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
2915 -- COMPONENT_DECLARATION ::=
2916 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
2917 -- [:= DEFAULT_EXPRESSION];
2919 -- COMPONENT_DEFINITION ::=
2920 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
2922 -- Error recovery: cannot raise Error_Resync, if an error occurs,
2923 -- the scan is positioned past the following semicolon.
2925 -- Note: we do not yet allow representation clauses to appear as component
2926 -- items, do we need to add this capability sometime in the future ???
2928 procedure P_Component_Items
(Decls
: List_Id
) is
2929 Aliased_Present
: Boolean := False;
2930 CompDef_Node
: Node_Id
;
2931 Decl_Node
: Node_Id
;
2932 Scan_State
: Saved_Scan_State
;
2933 Not_Null_Present
: Boolean := False;
2936 Ident_Sloc
: Source_Ptr
;
2938 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
2939 -- This array holds the list of defining identifiers. The upper bound
2940 -- of 4096 is intended to be essentially infinite, and we do not even
2941 -- bother to check for it being exceeded.
2944 if Token
/= Tok_Identifier
then
2945 Error_Msg_SC
("component declaration expected");
2946 Resync_Past_Semicolon
;
2950 Ident_Sloc
:= Token_Ptr
;
2951 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
2954 while Comma_Present
loop
2955 Num_Idents
:= Num_Idents
+ 1;
2956 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
2961 -- If there are multiple identifiers, we repeatedly scan the
2962 -- type and initialization expression information by resetting
2963 -- the scan pointer (so that we get completely separate trees
2964 -- for each occurrence).
2966 if Num_Idents
> 1 then
2967 Save_Scan_State
(Scan_State
);
2970 -- Loop through defining identifiers in list
2975 -- The following block is present to catch Error_Resync
2976 -- which causes the parse to be reset past the semicolon
2979 Decl_Node
:= New_Node
(N_Component_Declaration
, Ident_Sloc
);
2980 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
2982 if Token
= Tok_Constant
then
2983 Error_Msg_SC
("constant components are not permitted");
2987 CompDef_Node
:= New_Node
(N_Component_Definition
, Token_Ptr
);
2989 if Token_Name
= Name_Aliased
then
2990 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
2993 if Token
= Tok_Aliased
then
2994 Aliased_Present
:= True;
2995 Scan
; -- past ALIASED
2998 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/AI-254)
3000 -- Ada 2005 (AI-230): Access Definition case
3002 if Token
= Tok_Access
then
3003 if Ada_Version
< Ada_05
then
3005 ("generalized use of anonymous access types " &
3006 "is an Ada 2005 extension");
3007 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
3010 if Aliased_Present
then
3011 Error_Msg_SP
("ALIASED not allowed here");
3014 Set_Subtype_Indication
(CompDef_Node
, Empty
);
3015 Set_Aliased_Present
(CompDef_Node
, False);
3016 Set_Access_Definition
(CompDef_Node
,
3017 P_Access_Definition
(Not_Null_Present
));
3020 Set_Access_Definition
(CompDef_Node
, Empty
);
3021 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
3022 Set_Null_Exclusion_Present
(CompDef_Node
, Not_Null_Present
);
3024 if Token
= Tok_Array
then
3026 ("anonymous arrays not allowed as components");
3030 Set_Subtype_Indication
(CompDef_Node
,
3031 P_Subtype_Indication
(Not_Null_Present
));
3034 Set_Component_Definition
(Decl_Node
, CompDef_Node
);
3035 Set_Expression
(Decl_Node
, Init_Expr_Opt
);
3038 Set_Prev_Ids
(Decl_Node
, True);
3041 if Ident
< Num_Idents
then
3042 Set_More_Ids
(Decl_Node
, True);
3045 Append
(Decl_Node
, Decls
);
3048 when Error_Resync
=>
3049 if Token
/= Tok_End
then
3050 Resync_Past_Semicolon
;
3054 exit Ident_Loop
when Ident
= Num_Idents
;
3056 Restore_Scan_State
(Scan_State
);
3058 end loop Ident_Loop
;
3061 end P_Component_Items
;
3063 --------------------------------
3064 -- 3.8 Component Declaration --
3065 --------------------------------
3067 -- Parsed by P_Component_Items (3.8)
3069 -------------------------
3070 -- 3.8.1 Variant Part --
3071 -------------------------
3074 -- case discriminant_DIRECT_NAME is
3079 -- The caller has checked that the initial token is CASE
3081 -- Error recovery: cannot raise Error_Resync
3083 function P_Variant_Part
return Node_Id
is
3084 Variant_Part_Node
: Node_Id
;
3085 Variants_List
: List_Id
;
3086 Case_Node
: Node_Id
;
3089 Variant_Part_Node
:= New_Node
(N_Variant_Part
, Token_Ptr
);
3091 Scope
.Table
(Scope
.Last
).Etyp
:= E_Case
;
3092 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
3093 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
3096 Case_Node
:= P_Expression
;
3097 Set_Name
(Variant_Part_Node
, Case_Node
);
3099 if Nkind
(Case_Node
) /= N_Identifier
then
3100 Set_Name
(Variant_Part_Node
, Error
);
3101 Error_Msg
("discriminant name expected", Sloc
(Case_Node
));
3105 Variants_List
:= New_List
;
3106 P_Pragmas_Opt
(Variants_List
);
3108 -- Test missing variant
3110 if Token
= Tok_End
then
3111 Error_Msg_BC
("WHEN expected (must have at least one variant)");
3113 Append
(P_Variant
, Variants_List
);
3116 -- Loop through variants, note that we allow if in place of when,
3117 -- this error will be detected and handled in P_Variant.
3120 P_Pragmas_Opt
(Variants_List
);
3122 if Token
/= Tok_When
3123 and then Token
/= Tok_If
3124 and then Token
/= Tok_Others
3126 exit when Check_End
;
3129 Append
(P_Variant
, Variants_List
);
3132 Set_Variants
(Variant_Part_Node
, Variants_List
);
3133 return Variant_Part_Node
;
3136 --------------------
3138 --------------------
3141 -- when DISCRETE_CHOICE_LIST =>
3144 -- Error recovery: cannot raise Error_Resync
3146 -- The initial token on entry is either WHEN, IF or OTHERS
3148 function P_Variant
return Node_Id
is
3149 Variant_Node
: Node_Id
;
3152 -- Special check to recover nicely from use of IF in place of WHEN
3154 if Token
= Tok_If
then
3161 Variant_Node
:= New_Node
(N_Variant
, Prev_Token_Ptr
);
3162 Set_Discrete_Choices
(Variant_Node
, P_Discrete_Choice_List
);
3164 Set_Component_List
(Variant_Node
, P_Component_List
);
3165 return Variant_Node
;
3168 ---------------------------------
3169 -- 3.8.1 Discrete Choice List --
3170 ---------------------------------
3172 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
3174 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
3176 -- Note: in Ada 83, the expression must be a simple expression
3178 -- Error recovery: cannot raise Error_Resync
3180 function P_Discrete_Choice_List
return List_Id
is
3182 Expr_Node
: Node_Id
;
3183 Choice_Node
: Node_Id
;
3186 Choices
:= New_List
;
3189 if Token
= Tok_Others
then
3190 Append
(New_Node
(N_Others_Choice
, Token_Ptr
), Choices
);
3191 Scan
; -- past OTHERS
3195 Expr_Node
:= No_Right_Paren
(P_Expression_Or_Range_Attribute
);
3197 if Token
= Tok_Colon
3198 and then Nkind
(Expr_Node
) = N_Identifier
3200 Error_Msg_SP
("label not permitted in this context");
3203 elsif Expr_Form
= EF_Range_Attr
then
3204 Append
(Expr_Node
, Choices
);
3206 elsif Token
= Tok_Dot_Dot
then
3207 Check_Simple_Expression
(Expr_Node
);
3208 Choice_Node
:= New_Node
(N_Range
, Token_Ptr
);
3209 Set_Low_Bound
(Choice_Node
, Expr_Node
);
3211 Expr_Node
:= P_Expression_No_Right_Paren
;
3212 Check_Simple_Expression
(Expr_Node
);
3213 Set_High_Bound
(Choice_Node
, Expr_Node
);
3214 Append
(Choice_Node
, Choices
);
3216 elsif Expr_Form
= EF_Simple_Name
then
3217 if Token
= Tok_Range
then
3218 Append
(P_Subtype_Indication
(Expr_Node
), Choices
);
3220 elsif Token
in Token_Class_Consk
then
3222 ("the only constraint allowed here " &
3223 "is a range constraint");
3224 Discard_Junk_Node
(P_Constraint_Opt
);
3225 Append
(Expr_Node
, Choices
);
3228 Append
(Expr_Node
, Choices
);
3232 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
3233 Append
(Expr_Node
, Choices
);
3237 when Error_Resync
=>
3243 if Token
= Tok_Comma
then
3244 Error_Msg_SC
(""","" should be ""'|""");
3246 exit when Token
/= Tok_Vertical_Bar
;
3249 Scan
; -- past | or comma
3253 end P_Discrete_Choice_List
;
3255 ----------------------------
3256 -- 3.8.1 Discrete Choice --
3257 ----------------------------
3259 -- Parsed by P_Discrete_Choice_List (3.8.1)
3261 ----------------------------------
3262 -- 3.9.1 Record Extension Part --
3263 ----------------------------------
3265 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
3267 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
3269 ----------------------------------
3270 -- 3.10 Access Type Definition --
3271 ----------------------------------
3273 -- ACCESS_TYPE_DEFINITION ::=
3274 -- ACCESS_TO_OBJECT_DEFINITION
3275 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3277 -- ACCESS_TO_OBJECT_DEFINITION ::=
3278 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
3280 -- GENERAL_ACCESS_MODIFIER ::= all | constant
3282 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3283 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3284 -- | [NULL_EXCLUSION] access [protected] function
3285 -- PARAMETER_AND_RESULT_PROFILE
3287 -- PARAMETER_PROFILE ::= [FORMAL_PART]
3289 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
3291 -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already
3292 -- parsed the null_exclusion part and has also removed the ACCESS token;
3293 -- otherwise the caller has just checked that the initial token is ACCESS
3295 -- Error recovery: can raise Error_Resync
3297 function P_Access_Type_Definition
3298 (Header_Already_Parsed
: Boolean := False) return Node_Id
is
3299 Access_Loc
: constant Source_Ptr
:= Token_Ptr
;
3300 Prot_Flag
: Boolean;
3301 Not_Null_Present
: Boolean := False;
3302 Type_Def_Node
: Node_Id
;
3304 procedure Check_Junk_Subprogram_Name
;
3305 -- Used in access to subprogram definition cases to check for an
3306 -- identifier or operator symbol that does not belong.
3308 procedure Check_Junk_Subprogram_Name
is
3309 Saved_State
: Saved_Scan_State
;
3312 if Token
= Tok_Identifier
or else Token
= Tok_Operator_Symbol
then
3313 Save_Scan_State
(Saved_State
);
3314 Scan
; -- past possible junk subprogram name
3316 if Token
= Tok_Left_Paren
or else Token
= Tok_Semicolon
then
3317 Error_Msg_SP
("unexpected subprogram name ignored");
3321 Restore_Scan_State
(Saved_State
);
3324 end Check_Junk_Subprogram_Name
;
3326 -- Start of processing for P_Access_Type_Definition
3329 if not Header_Already_Parsed
then
3330 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
3331 Scan
; -- past ACCESS
3334 if Token_Name
= Name_Protected
then
3335 Check_95_Keyword
(Tok_Protected
, Tok_Procedure
);
3336 Check_95_Keyword
(Tok_Protected
, Tok_Function
);
3339 Prot_Flag
:= (Token
= Tok_Protected
);
3342 Scan
; -- past PROTECTED
3344 if Token
/= Tok_Procedure
and then Token
/= Tok_Function
then
3345 Error_Msg_SC
("FUNCTION or PROCEDURE expected");
3349 if Token
= Tok_Procedure
then
3350 if Ada_Version
= Ada_83
then
3351 Error_Msg_SC
("(Ada 83) access to procedure not allowed!");
3354 Type_Def_Node
:= New_Node
(N_Access_Procedure_Definition
, Access_Loc
);
3355 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3356 Scan
; -- past PROCEDURE
3357 Check_Junk_Subprogram_Name
;
3358 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
3359 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
3361 elsif Token
= Tok_Function
then
3362 if Ada_Version
= Ada_83
then
3363 Error_Msg_SC
("(Ada 83) access to function not allowed!");
3366 Type_Def_Node
:= New_Node
(N_Access_Function_Definition
, Access_Loc
);
3367 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3368 Scan
; -- past FUNCTION
3369 Check_Junk_Subprogram_Name
;
3370 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
3371 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
3373 Set_Subtype_Mark
(Type_Def_Node
, P_Subtype_Mark
);
3378 New_Node
(N_Access_To_Object_Definition
, Access_Loc
);
3379 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3381 if Token
= Tok_All
or else Token
= Tok_Constant
then
3382 if Ada_Version
= Ada_83
then
3383 Error_Msg_SC
("(Ada 83) access modifier not allowed!");
3386 if Token
= Tok_All
then
3387 Set_All_Present
(Type_Def_Node
, True);
3390 Set_Constant_Present
(Type_Def_Node
, True);
3393 Scan
; -- past ALL or CONSTANT
3396 Set_Subtype_Indication
(Type_Def_Node
,
3397 P_Subtype_Indication
(Not_Null_Present
));
3400 return Type_Def_Node
;
3401 end P_Access_Type_Definition
;
3403 ---------------------------------------
3404 -- 3.10 Access To Object Definition --
3405 ---------------------------------------
3407 -- Parsed by P_Access_Type_Definition (3.10)
3409 -----------------------------------
3410 -- 3.10 General Access Modifier --
3411 -----------------------------------
3413 -- Parsed by P_Access_Type_Definition (3.10)
3415 -------------------------------------------
3416 -- 3.10 Access To Subprogram Definition --
3417 -------------------------------------------
3419 -- Parsed by P_Access_Type_Definition (3.10)
3421 -----------------------------
3422 -- 3.10 Access Definition --
3423 -----------------------------
3425 -- ACCESS_DEFINITION ::=
3426 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3427 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3429 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3430 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3431 -- | [NULL_EXCLUSION] access [protected] function
3432 -- PARAMETER_AND_RESULT_PROFILE
3434 -- The caller has parsed the null-exclusion part and it has also checked
3435 -- that the next token is ACCESS
3437 -- Error recovery: cannot raise Error_Resync
3439 function P_Access_Definition
3440 (Null_Exclusion_Present
: Boolean) return Node_Id
is
3442 Subp_Node
: Node_Id
;
3445 Def_Node
:= New_Node
(N_Access_Definition
, Token_Ptr
);
3446 Scan
; -- past ACCESS
3448 -- Ada 2005 (AI-254/AI-231)
3450 if Ada_Version
>= Ada_05
then
3452 -- Ada 2005 (AI-254): Access_To_Subprogram_Definition
3454 if Token
= Tok_Protected
3455 or else Token
= Tok_Procedure
3456 or else Token
= Tok_Function
3459 P_Access_Type_Definition
(Header_Already_Parsed
=> True);
3460 Set_Null_Exclusion_Present
(Subp_Node
, Null_Exclusion_Present
);
3461 Set_Access_To_Subprogram_Definition
(Def_Node
, Subp_Node
);
3463 -- Ada 2005 (AI-231)
3464 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3467 Set_Null_Exclusion_Present
(Def_Node
, Null_Exclusion_Present
);
3469 if Token
= Tok_All
then
3471 Set_All_Present
(Def_Node
);
3473 elsif Token
= Tok_Constant
then
3474 Scan
; -- past CONSTANT
3475 Set_Constant_Present
(Def_Node
);
3478 Set_Subtype_Mark
(Def_Node
, P_Subtype_Mark
);
3485 -- Ada 2005 (AI-254): The null-exclusion present is never present
3486 -- in Ada 83 and Ada 95
3488 pragma Assert
(Null_Exclusion_Present
= False);
3490 Set_Null_Exclusion_Present
(Def_Node
, False);
3491 Set_Subtype_Mark
(Def_Node
, P_Subtype_Mark
);
3496 end P_Access_Definition
;
3498 -----------------------------------------
3499 -- 3.10.1 Incomplete Type Declaration --
3500 -----------------------------------------
3502 -- Parsed by P_Type_Declaration (3.2.1)
3504 ----------------------------
3505 -- 3.11 Declarative Part --
3506 ----------------------------
3508 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
3510 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items
3511 -- handles errors, and returns cleanly after an error has occurred)
3513 function P_Declarative_Part
return List_Id
is
3518 -- Indicate no bad declarations detected yet. This will be reset by
3519 -- P_Declarative_Items if a bad declaration is discovered.
3521 Missing_Begin_Msg
:= No_Error_Msg
;
3523 -- Get rid of active SIS entry from outer scope. This means we will
3524 -- miss some nested cases, but it doesn't seem worth the effort. See
3525 -- discussion in Par for further details
3527 SIS_Entry_Active
:= False;
3530 -- Loop to scan out the declarations
3533 P_Declarative_Items
(Decls
, Done
, In_Spec
=> False);
3537 -- Get rid of active SIS entry which is left set only if we scanned a
3538 -- procedure declaration and have not found the body. We could give
3539 -- an error message, but that really would be usurping the role of
3540 -- semantic analysis (this really is a missing body case).
3542 SIS_Entry_Active
:= False;
3544 end P_Declarative_Part
;
3546 ----------------------------
3547 -- 3.11 Declarative Item --
3548 ----------------------------
3550 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
3552 -- Can return Error if a junk declaration is found, or Empty if no
3553 -- declaration is found (i.e. a token ending declarations, such as
3554 -- BEGIN or END is encountered).
3556 -- Error recovery: cannot raise Error_Resync. If an error resync occurs,
3557 -- then the scan is set past the next semicolon and Error is returned.
3559 procedure P_Declarative_Items
3564 Scan_State
: Saved_Scan_State
;
3567 if Style_Check
then Style
.Check_Indentation
; end if;
3571 when Tok_Function
=>
3573 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3579 -- Check for loop (premature statement)
3581 Save_Scan_State
(Scan_State
);
3584 if Token
= Tok_Identifier
then
3585 Scan
; -- past identifier
3587 if Token
= Tok_In
then
3588 Restore_Scan_State
(Scan_State
);
3589 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
3594 -- Not a loop, so must be rep clause
3596 Restore_Scan_State
(Scan_State
);
3597 Append
(P_Representation_Clause
, Decls
);
3602 Append
(P_Generic
, Decls
);
3605 when Tok_Identifier
=>
3607 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
3611 Append
(P_Package
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3615 Append
(P_Pragma
, Decls
);
3618 when Tok_Procedure
=>
3620 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3623 when Tok_Protected
=>
3625 Scan
; -- past PROTECTED
3626 Append
(P_Protected
, Decls
);
3631 Append
(P_Subtype_Declaration
, Decls
);
3637 Append
(P_Task
, Decls
);
3642 Append
(P_Type_Declaration
, Decls
);
3647 Append
(P_Use_Clause
, Decls
);
3652 Error_Msg_SC
("WITH can only appear in context clause");
3655 -- BEGIN terminates the scan of a sequence of declarations unless
3656 -- there is a missing subprogram body, see section on handling
3657 -- semicolon in place of IS. We only treat the begin as satisfying
3658 -- the subprogram declaration if it falls in the expected column
3662 if SIS_Entry_Active
and then Start_Column
>= SIS_Ecol
then
3664 -- Here we have the case where a BEGIN is encountered during
3665 -- declarations in a declarative part, or at the outer level,
3666 -- and there is a subprogram declaration outstanding for which
3667 -- no body has been supplied. This is the case where we assume
3668 -- that the semicolon in the subprogram declaration should
3669 -- really have been is. The active SIS entry describes the
3670 -- subprogram declaration. On return the declaration has been
3671 -- modified to become a body.
3674 Specification_Node
: Node_Id
;
3675 Decl_Node
: Node_Id
;
3676 Body_Node
: Node_Id
;
3679 -- First issue the error message. If we had a missing
3680 -- semicolon in the declaration, then change the message
3681 -- to <missing "is">
3683 if SIS_Missing_Semicolon_Message
/= No_Error_Msg
then
3684 Change_Error_Text
-- Replace: "missing "";"" "
3685 (SIS_Missing_Semicolon_Message
, "missing ""is""");
3687 -- Otherwise we saved the semicolon position, so complain
3690 Error_Msg
(""";"" should be IS", SIS_Semicolon_Sloc
);
3693 -- The next job is to fix up any declarations that occurred
3694 -- between the procedure header and the BEGIN. These got
3695 -- chained to the outer declarative region (immediately
3696 -- after the procedure declaration) and they should be
3697 -- chained to the subprogram itself, which is a body
3698 -- rather than a spec.
3700 Specification_Node
:= Specification
(SIS_Declaration_Node
);
3701 Change_Node
(SIS_Declaration_Node
, N_Subprogram_Body
);
3702 Body_Node
:= SIS_Declaration_Node
;
3703 Set_Specification
(Body_Node
, Specification_Node
);
3704 Set_Declarations
(Body_Node
, New_List
);
3707 Decl_Node
:= Remove_Next
(Body_Node
);
3708 exit when Decl_Node
= Empty
;
3709 Append
(Decl_Node
, Declarations
(Body_Node
));
3712 -- Now make the scope table entry for the Begin-End and
3716 Scope
.Table
(Scope
.Last
).Sloc
:= SIS_Sloc
;
3717 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
3718 Scope
.Table
(Scope
.Last
).Ecol
:= SIS_Ecol
;
3719 Scope
.Table
(Scope
.Last
).Labl
:= SIS_Labl
;
3720 Scope
.Table
(Scope
.Last
).Lreq
:= False;
3721 SIS_Entry_Active
:= False;
3723 Set_Handled_Statement_Sequence
(Body_Node
,
3724 P_Handled_Sequence_Of_Statements
);
3725 End_Statements
(Handled_Statement_Sequence
(Body_Node
));
3734 -- Normally an END terminates the scan for basic declarative
3735 -- items. The one exception is END RECORD, which is probably
3736 -- left over from some other junk.
3739 Save_Scan_State
(Scan_State
); -- at END
3742 if Token
= Tok_Record
then
3743 Error_Msg_SP
("no RECORD for this `end record`!");
3744 Scan
; -- past RECORD
3748 Restore_Scan_State
(Scan_State
); -- to END
3752 -- The following tokens which can only be the start of a statement
3753 -- are considered to end a declarative part (i.e. we have a missing
3754 -- BEGIN situation). We are fairly conservative in making this
3755 -- judgment, because it is a real mess to go into statement mode
3756 -- prematurely in response to a junk declaration.
3771 -- But before we decide that it's a statement, let's check for
3772 -- a reserved word misused as an identifier.
3774 if Is_Reserved_Identifier
then
3775 Save_Scan_State
(Scan_State
);
3776 Scan
; -- past the token
3778 -- If reserved identifier not followed by colon or comma, then
3779 -- this is most likely an assignment statement to the bad id.
3781 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
3782 Restore_Scan_State
(Scan_State
);
3783 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
3786 -- Otherwise we have a declaration of the bad id
3789 Restore_Scan_State
(Scan_State
);
3790 Scan_Reserved_Identifier
(Force_Msg
=> True);
3791 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
3794 -- If not reserved identifier, then it's definitely a statement
3797 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
3801 -- The token RETURN may well also signal a missing BEGIN situation,
3802 -- however, we never let it end the declarative part, because it may
3803 -- also be part of a half-baked function declaration.
3806 Error_Msg_SC
("misplaced RETURN statement");
3809 -- PRIVATE definitely terminates the declarations in a spec,
3810 -- and is an error in a body.
3816 Error_Msg_SC
("PRIVATE not allowed in body");
3817 Scan
; -- past PRIVATE
3820 -- An end of file definitely terminates the declarations!
3825 -- The remaining tokens do not end the scan, but cannot start a
3826 -- valid declaration, so we signal an error and resynchronize.
3827 -- But first check for misuse of a reserved identifier.
3831 -- Here we check for a reserved identifier
3833 if Is_Reserved_Identifier
then
3834 Save_Scan_State
(Scan_State
);
3835 Scan
; -- past the token
3837 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
3838 Restore_Scan_State
(Scan_State
);
3839 Set_Declaration_Expected
;
3842 Restore_Scan_State
(Scan_State
);
3843 Scan_Reserved_Identifier
(Force_Msg
=> True);
3845 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
3849 Set_Declaration_Expected
;
3854 -- To resynchronize after an error, we scan to the next semicolon and
3855 -- return with Done = False, indicating that there may still be more
3856 -- valid declarations to come.
3859 when Error_Resync
=>
3860 Resync_Past_Semicolon
;
3862 end P_Declarative_Items
;
3864 ----------------------------------
3865 -- 3.11 Basic Declarative Item --
3866 ----------------------------------
3868 -- BASIC_DECLARATIVE_ITEM ::=
3869 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
3871 -- Scan zero or more basic declarative items
3873 -- Error recovery: cannot raise Error_Resync. If an error is detected, then
3874 -- the scan pointer is repositioned past the next semicolon, and the scan
3875 -- for declarative items continues.
3877 function P_Basic_Declarative_Items
return List_Id
is
3884 -- Indicate no bad declarations detected yet in the current context:
3885 -- visible or private declarations of a package spec.
3887 Missing_Begin_Msg
:= No_Error_Msg
;
3889 -- Get rid of active SIS entry from outer scope. This means we will
3890 -- miss some nested cases, but it doesn't seem worth the effort. See
3891 -- discussion in Par for further details
3893 SIS_Entry_Active
:= False;
3895 -- Loop to scan out declarations
3900 P_Declarative_Items
(Decls
, Done
, In_Spec
=> True);
3904 -- Get rid of active SIS entry. This is set only if we have scanned a
3905 -- procedure declaration and have not found the body. We could give
3906 -- an error message, but that really would be usurping the role of
3907 -- semantic analysis (this really is a case of a missing body).
3909 SIS_Entry_Active
:= False;
3911 -- Test for assorted illegal declarations not diagnosed elsewhere.
3913 Decl
:= First
(Decls
);
3915 while Present
(Decl
) loop
3916 Kind
:= Nkind
(Decl
);
3918 -- Test for body scanned, not acceptable as basic decl item
3920 if Kind
= N_Subprogram_Body
or else
3921 Kind
= N_Package_Body
or else
3922 Kind
= N_Task_Body
or else
3923 Kind
= N_Protected_Body
3926 ("proper body not allowed in package spec", Sloc
(Decl
));
3928 -- Test for body stub scanned, not acceptable as basic decl item
3930 elsif Kind
in N_Body_Stub
then
3932 ("body stub not allowed in package spec", Sloc
(Decl
));
3934 elsif Kind
= N_Assignment_Statement
then
3936 ("assignment statement not allowed in package spec",
3944 end P_Basic_Declarative_Items
;
3950 -- For proper body, see below
3951 -- For body stub, see 10.1.3
3953 -----------------------
3954 -- 3.11 Proper Body --
3955 -----------------------
3957 -- Subprogram body is parsed by P_Subprogram (6.1)
3958 -- Package body is parsed by P_Package (7.1)
3959 -- Task body is parsed by P_Task (9.1)
3960 -- Protected body is parsed by P_Protected (9.4)
3962 ------------------------------
3963 -- Set_Declaration_Expected --
3964 ------------------------------
3966 procedure Set_Declaration_Expected
is
3968 Error_Msg_SC
("declaration expected");
3970 if Missing_Begin_Msg
= No_Error_Msg
then
3971 Missing_Begin_Msg
:= Get_Msg_Id
;
3973 end Set_Declaration_Expected
;
3975 ----------------------
3976 -- Skip_Declaration --
3977 ----------------------
3979 procedure Skip_Declaration
(S
: List_Id
) is
3980 Dummy_Done
: Boolean;
3983 P_Declarative_Items
(S
, Dummy_Done
, False);
3984 end Skip_Declaration
;
3986 -----------------------------------------
3987 -- Statement_When_Declaration_Expected --
3988 -----------------------------------------
3990 procedure Statement_When_Declaration_Expected
3996 -- Case of second occurrence of statement in one declaration sequence
3998 if Missing_Begin_Msg
/= No_Error_Msg
then
4000 -- In the procedure spec case, just ignore it, we only give one
4001 -- message for the first occurrence, since otherwise we may get
4002 -- horrible cascading if BODY was missing in the header line.
4007 -- In the declarative part case, take a second statement as a sure
4008 -- sign that we really have a missing BEGIN, and end the declarative
4009 -- part now. Note that the caller will fix up the first message to
4010 -- say "missing BEGIN" so that's how the error will be signalled.
4017 -- Case of first occurrence of unexpected statement
4020 -- If we are in a package spec, then give message of statement
4021 -- not allowed in package spec. This message never gets changed.
4024 Error_Msg_SC
("statement not allowed in package spec");
4026 -- If in declarative part, then we give the message complaining
4027 -- about finding a statement when a declaration is expected. This
4028 -- gets changed to a complaint about a missing BEGIN if we later
4029 -- find that no BEGIN is present.
4032 Error_Msg_SC
("statement not allowed in declarative part");
4035 -- Capture message Id. This is used for two purposes, first to
4036 -- stop multiple messages, see test above, and second, to allow
4037 -- the replacement of the message in the declarative part case.
4039 Missing_Begin_Msg
:= Get_Msg_Id
;
4042 -- In all cases except the case in which we decided to terminate the
4043 -- declaration sequence on a second error, we scan out the statement
4044 -- and append it to the list of declarations (note that the semantics
4045 -- can handle statements in a declaration list so if we proceed to
4046 -- call the semantic phase, all will be (reasonably) well!
4048 Append_List_To
(Decls
, P_Sequence_Of_Statements
(SS_Unco
));
4050 -- Done is set to False, since we want to continue the scan of
4051 -- declarations, hoping that this statement was a temporary glitch.
4052 -- If we indeed are now in the statement part (i.e. this was a missing
4053 -- BEGIN, then it's not terrible, we will simply keep calling this
4054 -- procedure to process the statements one by one, and then finally
4055 -- hit the missing BEGIN, which will clean up the error message.
4058 end Statement_When_Declaration_Expected
;