1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 pragma Style_Checks
(All_Checks
);
28 -- Turn off subprogram body ordering check. Subprograms are in order
29 -- by RM section rather than alphabetical.
31 with Sinfo
.CN
; use Sinfo
.CN
;
37 -----------------------
38 -- Local Subprograms --
39 -----------------------
41 function P_Component_List
return Node_Id
;
42 function P_Defining_Character_Literal
return Node_Id
;
43 function P_Delta_Constraint
return Node_Id
;
44 function P_Derived_Type_Def_Or_Private_Ext_Decl
return Node_Id
;
45 function P_Digits_Constraint
return Node_Id
;
46 function P_Discriminant_Association
return Node_Id
;
47 function P_Enumeration_Literal_Specification
return Node_Id
;
48 function P_Enumeration_Type_Definition
return Node_Id
;
49 function P_Fixed_Point_Definition
return Node_Id
;
50 function P_Floating_Point_Definition
return Node_Id
;
51 function P_Index_Or_Discriminant_Constraint
return Node_Id
;
52 function P_Real_Range_Specification_Opt
return Node_Id
;
53 function P_Subtype_Declaration
return Node_Id
;
54 function P_Type_Declaration
return Node_Id
;
55 function P_Modular_Type_Definition
return Node_Id
;
56 function P_Variant
return Node_Id
;
57 function P_Variant_Part
return Node_Id
;
59 procedure P_Declarative_Items
63 -- Scans out a single declarative item, or, in the case of a declaration
64 -- with a list of identifiers, a list of declarations, one for each of
65 -- the identifiers in the list. The declaration or declarations scanned
66 -- are appended to the given list. Done indicates whether or not there
67 -- may be additional declarative items to scan. If Done is True, then
68 -- a decision has been made that there are no more items to scan. If
69 -- Done is False, then there may be additional declarations to scan.
70 -- In_Spec is true if we are scanning a package declaration, and is used
71 -- to generate an appropriate message if a statement is encountered in
74 procedure P_Identifier_Declarations
78 -- Scans out a set of declarations for an identifier or list of
79 -- identifiers, and appends them to the given list. The parameters have
80 -- the same significance as for P_Declarative_Items.
82 procedure Statement_When_Declaration_Expected
86 -- Called when a statement is found at a point where a declaration was
87 -- expected. The parameters are as described for P_Declarative_Items.
89 procedure Set_Declaration_Expected
;
90 -- Posts a "declaration expected" error messages at the start of the
91 -- current token, and if this is the first such message issued, saves
92 -- the message id in Missing_Begin_Msg, for possible later replacement.
98 function Init_Expr_Opt
(P
: Boolean := False) return Node_Id
is
100 -- For colon, assume it means := unless it is at the end of
101 -- a line, in which case guess that it means a semicolon.
103 if Token
= Tok_Colon
then
104 if Token_Is_At_End_Of_Line
then
109 -- Here if := or something that we will take as equivalent
111 elsif Token
= Tok_Colon_Equal
112 or else Token
= Tok_Equal
113 or else Token
= Tok_Is
117 -- Another possibility. If we have a literal followed by a semicolon,
118 -- we assume that we have a missing colon-equal.
120 elsif Token
in Token_Class_Literal
then
122 Scan_State
: Saved_Scan_State
;
125 Save_Scan_State
(Scan_State
);
126 Scan
; -- past literal or identifier
128 if Token
= Tok_Semicolon
then
129 Restore_Scan_State
(Scan_State
);
131 Restore_Scan_State
(Scan_State
);
136 -- Otherwise we definitely have no initialization expression
142 -- Merge here if we have an initialization expression
149 return P_Expression_No_Right_Paren
;
153 ----------------------------
154 -- 3.1 Basic Declaration --
155 ----------------------------
157 -- Parsed by P_Basic_Declarative_Items (3.9)
159 ------------------------------
160 -- 3.1 Defining Identifier --
161 ------------------------------
163 -- DEFINING_IDENTIFIER ::= IDENTIFIER
165 -- Error recovery: can raise Error_Resync
167 function P_Defining_Identifier
(C
: Id_Check
:= None
) return Node_Id
is
168 Ident_Node
: Node_Id
;
171 -- Scan out the identifier. Note that this code is essentially identical
172 -- to P_Identifier, except that in the call to Scan_Reserved_Identifier
173 -- we set Force_Msg to True, since we want at least one message for each
174 -- separate declaration (but not use) of a reserved identifier.
176 if Token
= Tok_Identifier
then
178 -- Ada 2005 (AI-284): Compiling in Ada95 mode we warn that INTERFACE,
179 -- OVERRIDING, and SYNCHRONIZED are new reserved words.
181 if Ada_Version
= Ada_95
182 and then Warn_On_Ada_2005_Compatibility
184 if Token_Name
= Name_Overriding
185 or else Token_Name
= Name_Synchronized
186 or else (Token_Name
= Name_Interface
187 and then Prev_Token
/= Tok_Pragma
)
189 Error_Msg_N
("& is a reserved word in Ada 2005?", Token_Node
);
193 -- If we have a reserved identifier, manufacture an identifier with
194 -- a corresponding name after posting an appropriate error message
196 elsif Is_Reserved_Identifier
(C
) then
197 Scan_Reserved_Identifier
(Force_Msg
=> True);
199 -- Otherwise we have junk that cannot be interpreted as an identifier
202 T_Identifier
; -- to give message
206 Ident_Node
:= Token_Node
;
207 Scan
; -- past the reserved identifier
209 if Ident_Node
/= Error
then
210 Change_Identifier_To_Defining_Identifier
(Ident_Node
);
214 end P_Defining_Identifier
;
216 -----------------------------
217 -- 3.2.1 Type Declaration --
218 -----------------------------
220 -- TYPE_DECLARATION ::=
221 -- FULL_TYPE_DECLARATION
222 -- | INCOMPLETE_TYPE_DECLARATION
223 -- | PRIVATE_TYPE_DECLARATION
224 -- | PRIVATE_EXTENSION_DECLARATION
226 -- FULL_TYPE_DECLARATION ::=
227 -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION;
228 -- | CONCURRENT_TYPE_DECLARATION
230 -- INCOMPLETE_TYPE_DECLARATION ::=
231 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [IS TAGGED];
233 -- PRIVATE_TYPE_DECLARATION ::=
234 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]
235 -- is [abstract] [tagged] [limited] private;
237 -- PRIVATE_EXTENSION_DECLARATION ::=
238 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
239 -- [abstract] new ancestor_SUBTYPE_INDICATION
240 -- [and INTERFACE_LIST] with private;
242 -- TYPE_DEFINITION ::=
243 -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION
244 -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION
245 -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION
246 -- | DERIVED_TYPE_DEFINITION | INTERFACE_TYPE_DEFINITION
248 -- INTEGER_TYPE_DEFINITION ::=
249 -- SIGNED_INTEGER_TYPE_DEFINITION
250 -- MODULAR_TYPE_DEFINITION
252 -- INTERFACE_TYPE_DEFINITION ::=
253 -- [limited | task | protected | synchronized ] interface
254 -- [AND interface_list]
256 -- Error recovery: can raise Error_Resync
258 -- Note: The processing for full type declaration, incomplete type
259 -- declaration, private type declaration and type definition is
260 -- included in this function. The processing for concurrent type
261 -- declarations is NOT here, but rather in chapter 9 (i.e. this
262 -- function handles only declarations starting with TYPE).
264 function P_Type_Declaration
return Node_Id
is
265 Abstract_Present
: Boolean;
266 Abstract_Loc
: Source_Ptr
;
268 Discr_List
: List_Id
;
269 Discr_Sloc
: Source_Ptr
;
271 Type_Loc
: Source_Ptr
;
272 Type_Start_Col
: Column_Number
;
273 Ident_Node
: Node_Id
;
274 Is_Derived_Iface
: Boolean := False;
275 Unknown_Dis
: Boolean;
277 Typedef_Node
: Node_Id
;
278 -- Normally holds type definition, except in the case of a private
279 -- extension declaration, in which case it holds the declaration itself
282 Type_Loc
:= Token_Ptr
;
283 Type_Start_Col
:= Start_Column
;
285 -- If we have TYPE, then proceed ahead and scan identifier
287 if Token
= Tok_Type
then
289 Ident_Node
:= P_Defining_Identifier
(C_Is
);
291 -- Otherwise this is an error case, and we may already have converted
292 -- the current token to a defining identifier, so don't do it again!
297 if Token
= Tok_Identifier
298 and then Nkind
(Token_Node
) = N_Defining_Identifier
300 Ident_Node
:= Token_Node
;
301 Scan
; -- past defining identifier
303 Ident_Node
:= P_Defining_Identifier
(C_Is
);
307 Discr_Sloc
:= Token_Ptr
;
309 if P_Unknown_Discriminant_Part_Opt
then
311 Discr_List
:= No_List
;
313 Unknown_Dis
:= False;
314 Discr_List
:= P_Known_Discriminant_Part_Opt
;
317 -- Incomplete type declaration. We complete the processing for this
318 -- case here and return the resulting incomplete type declaration node
320 if Token
= Tok_Semicolon
then
322 Decl_Node
:= New_Node
(N_Incomplete_Type_Declaration
, Type_Loc
);
323 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
324 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
325 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
332 -- Full type declaration or private type declaration, must have IS
334 if Token
= Tok_Equal
then
336 Scan
; -- past = used in place of IS
338 elsif Token
= Tok_Renames
then
339 Error_Msg_SC
("RENAMES should be IS");
340 Scan
; -- past RENAMES used in place of IS
346 -- First an error check, if we have two identifiers in a row, a likely
347 -- possibility is that the first of the identifiers is an incorrectly
350 if Token
= Tok_Identifier
then
352 SS
: Saved_Scan_State
;
356 Save_Scan_State
(SS
);
357 Scan
; -- past initial identifier
358 I2
:= (Token
= Tok_Identifier
);
359 Restore_Scan_State
(SS
);
363 (Bad_Spelling_Of
(Tok_Abstract
) or else
364 Bad_Spelling_Of
(Tok_Access
) or else
365 Bad_Spelling_Of
(Tok_Aliased
) or else
366 Bad_Spelling_Of
(Tok_Constant
))
373 -- Check for misuse of Ada 95 keyword abstract in Ada 83 mode
375 if Token_Name
= Name_Abstract
then
376 Check_95_Keyword
(Tok_Abstract
, Tok_Tagged
);
377 Check_95_Keyword
(Tok_Abstract
, Tok_New
);
380 -- Check cases of misuse of ABSTRACT
382 if Token
= Tok_Abstract
then
383 Abstract_Present
:= True;
384 Abstract_Loc
:= Token_Ptr
;
385 Scan
; -- past ABSTRACT
387 if Token
= Tok_Limited
388 or else Token
= Tok_Private
389 or else Token
= Tok_Record
390 or else Token
= Tok_Null
392 Error_Msg_AP
("TAGGED expected");
396 Abstract_Present
:= False;
397 Abstract_Loc
:= No_Location
;
400 -- Check for misuse of Ada 95 keyword Tagged
402 if Token_Name
= Name_Tagged
then
403 Check_95_Keyword
(Tok_Tagged
, Tok_Private
);
404 Check_95_Keyword
(Tok_Tagged
, Tok_Limited
);
405 Check_95_Keyword
(Tok_Tagged
, Tok_Record
);
408 -- Special check for misuse of Aliased
410 if Token
= Tok_Aliased
or else Token_Name
= Name_Aliased
then
411 Error_Msg_SC
("ALIASED not allowed in type definition");
412 Scan
; -- past ALIASED
415 -- The following procesing deals with either a private type declaration
416 -- or a full type declaration. In the private type case, we build the
417 -- N_Private_Type_Declaration node, setting its Tagged_Present and
418 -- Limited_Present flags, on encountering the Private keyword, and
419 -- leave Typedef_Node set to Empty. For the full type declaration
420 -- case, Typedef_Node gets set to the type definition.
422 Typedef_Node
:= Empty
;
424 -- Switch on token following the IS. The loop normally runs once. It
425 -- only runs more than once if an error is detected, to try again after
426 -- detecting and fixing up the error.
432 Tok_Not
=> -- Ada 2005 (AI-231)
433 Typedef_Node
:= P_Access_Type_Definition
;
438 Typedef_Node
:= P_Array_Type_Definition
;
443 Typedef_Node
:= P_Fixed_Point_Definition
;
448 Typedef_Node
:= P_Floating_Point_Definition
;
455 when Tok_Integer_Literal
=>
457 Typedef_Node
:= P_Signed_Integer_Type_Definition
;
462 Typedef_Node
:= P_Record_Definition
;
466 when Tok_Left_Paren
=>
467 Typedef_Node
:= P_Enumeration_Type_Definition
;
470 Make_Identifier
(Token_Ptr
,
471 Chars
=> Chars
(Ident_Node
));
472 Set_Comes_From_Source
(End_Labl
, False);
474 Set_End_Label
(Typedef_Node
, End_Labl
);
479 Typedef_Node
:= P_Modular_Type_Definition
;
484 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
486 if Nkind
(Typedef_Node
) = N_Derived_Type_Definition
487 and then Present
(Record_Extension_Part
(Typedef_Node
))
490 Make_Identifier
(Token_Ptr
,
491 Chars
=> Chars
(Ident_Node
));
492 Set_Comes_From_Source
(End_Labl
, False);
495 (Record_Extension_Part
(Typedef_Node
), End_Labl
);
502 Typedef_Node
:= P_Signed_Integer_Type_Definition
;
507 Typedef_Node
:= P_Record_Definition
;
510 Make_Identifier
(Token_Ptr
,
511 Chars
=> Chars
(Ident_Node
));
512 Set_Comes_From_Source
(End_Labl
, False);
514 Set_End_Label
(Typedef_Node
, End_Labl
);
521 -- Ada 2005 (AI-326): If the words IS TAGGED appear, the type
522 -- is a tagged incomplete type.
524 if Ada_Version
>= Ada_05
525 and then Token
= Tok_Semicolon
530 New_Node
(N_Incomplete_Type_Declaration
, Type_Loc
);
531 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
532 Set_Tagged_Present
(Decl_Node
);
533 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
534 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
539 if Token
= Tok_Abstract
then
540 Error_Msg_SC
("ABSTRACT must come before TAGGED");
541 Abstract_Present
:= True;
542 Abstract_Loc
:= Token_Ptr
;
543 Scan
; -- past ABSTRACT
546 if Token
= Tok_Limited
then
547 Scan
; -- past LIMITED
549 -- TAGGED LIMITED PRIVATE case
551 if Token
= Tok_Private
then
553 New_Node
(N_Private_Type_Declaration
, Type_Loc
);
554 Set_Tagged_Present
(Decl_Node
, True);
555 Set_Limited_Present
(Decl_Node
, True);
556 Scan
; -- past PRIVATE
558 -- TAGGED LIMITED RECORD
561 Typedef_Node
:= P_Record_Definition
;
562 Set_Tagged_Present
(Typedef_Node
, True);
563 Set_Limited_Present
(Typedef_Node
, True);
566 Make_Identifier
(Token_Ptr
,
567 Chars
=> Chars
(Ident_Node
));
568 Set_Comes_From_Source
(End_Labl
, False);
570 Set_End_Label
(Typedef_Node
, End_Labl
);
576 if Token
= Tok_Private
then
578 New_Node
(N_Private_Type_Declaration
, Type_Loc
);
579 Set_Tagged_Present
(Decl_Node
, True);
580 Scan
; -- past PRIVATE
585 Typedef_Node
:= P_Record_Definition
;
586 Set_Tagged_Present
(Typedef_Node
, True);
589 Make_Identifier
(Token_Ptr
,
590 Chars
=> Chars
(Ident_Node
));
591 Set_Comes_From_Source
(End_Labl
, False);
593 Set_End_Label
(Typedef_Node
, End_Labl
);
601 Scan
; -- past LIMITED
604 if Token
= Tok_Tagged
then
605 Error_Msg_SC
("TAGGED must come before LIMITED");
608 elsif Token
= Tok_Abstract
then
609 Error_Msg_SC
("ABSTRACT must come before LIMITED");
610 Scan
; -- past ABSTRACT
617 -- LIMITED RECORD or LIMITED NULL RECORD
619 if Token
= Tok_Record
or else Token
= Tok_Null
then
620 if Ada_Version
= Ada_83
then
622 ("(Ada 83) limited record declaration not allowed!");
625 Typedef_Node
:= P_Record_Definition
;
626 Set_Limited_Present
(Typedef_Node
, True);
628 -- Ada 2005 (AI-251): LIMITED INTERFACE
630 -- If we are compiling in Ada 83 or Ada 95 mode, "interface"
631 -- is not a reserved word but we force its analysis to
632 -- generate the corresponding usage error.
634 elsif Token
= Tok_Interface
635 or else (Token
= Tok_Identifier
636 and then Chars
(Token_Node
) = Name_Interface
)
638 Typedef_Node
:= P_Interface_Type_Definition
639 (Is_Synchronized
=> False);
640 Abstract_Present
:= True;
641 Set_Limited_Present
(Typedef_Node
);
643 if Nkind
(Typedef_Node
) = N_Derived_Type_Definition
then
644 Is_Derived_Iface
:= True;
647 -- Ada 2005 (AI-419): LIMITED NEW
649 elsif Token
= Tok_New
then
650 if Ada_Version
< Ada_05
then
652 ("LIMITED in derived type is an Ada 2005 extension");
654 ("\unit must be compiled with -gnat05 switch");
657 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
658 Set_Limited_Present
(Typedef_Node
);
660 if Nkind
(Typedef_Node
) = N_Derived_Type_Definition
661 and then Present
(Record_Extension_Part
(Typedef_Node
))
664 Make_Identifier
(Token_Ptr
,
665 Chars
=> Chars
(Ident_Node
));
666 Set_Comes_From_Source
(End_Labl
, False);
669 (Record_Extension_Part
(Typedef_Node
), End_Labl
);
672 -- LIMITED PRIVATE is the only remaining possibility here
675 Decl_Node
:= New_Node
(N_Private_Type_Declaration
, Type_Loc
);
676 Set_Limited_Present
(Decl_Node
, True);
677 T_Private
; -- past PRIVATE (or complain if not there!)
683 -- Here we have an identifier after the IS, which is certainly
684 -- wrong and which might be one of several different mistakes.
686 when Tok_Identifier
=>
688 -- First case, if identifier is on same line, then probably we
689 -- have something like "type X is Integer .." and the best
690 -- diagnosis is a missing NEW. Note: the missing new message
691 -- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl.
693 if not Token_Is_At_Start_Of_Line
then
694 Typedef_Node
:= P_Derived_Type_Def_Or_Private_Ext_Decl
;
697 -- If the identifier is at the start of the line, and is in the
698 -- same column as the type declaration itself then we consider
699 -- that we had a missing type definition on the previous line
701 elsif Start_Column
<= Type_Start_Col
then
702 Error_Msg_AP
("type definition expected");
703 Typedef_Node
:= Error
;
705 -- If the identifier is at the start of the line, and is in
706 -- a column to the right of the type declaration line, then we
707 -- may have something like:
712 -- and the best diagnosis is a missing record keyword
715 Typedef_Node
:= P_Record_Definition
;
721 -- Ada 2005 (AI-251): INTERFACE
723 when Tok_Interface
=>
724 Typedef_Node
:= P_Interface_Type_Definition
725 (Is_Synchronized
=> False);
726 Abstract_Present
:= True;
731 Decl_Node
:= New_Node
(N_Private_Type_Declaration
, Type_Loc
);
732 Scan
; -- past PRIVATE
743 Saved_Token
: constant Token_Type
:= Token
;
746 Scan
; -- past TASK, PROTECTED or SYNCHRONIZED
748 Typedef_Node
:= P_Interface_Type_Definition
749 (Is_Synchronized
=> True);
750 Abstract_Present
:= True;
754 Set_Task_Present
(Typedef_Node
);
756 when Tok_Protected
=>
757 Set_Protected_Present
(Typedef_Node
);
759 when Tok_Synchronized
=>
760 Set_Synchronized_Present
(Typedef_Node
);
763 pragma Assert
(False);
771 -- Anything else is an error
774 if Bad_Spelling_Of
(Tok_Access
)
776 Bad_Spelling_Of
(Tok_Array
)
778 Bad_Spelling_Of
(Tok_Delta
)
780 Bad_Spelling_Of
(Tok_Digits
)
782 Bad_Spelling_Of
(Tok_Limited
)
784 Bad_Spelling_Of
(Tok_Private
)
786 Bad_Spelling_Of
(Tok_Range
)
788 Bad_Spelling_Of
(Tok_Record
)
790 Bad_Spelling_Of
(Tok_Tagged
)
795 Error_Msg_AP
("type definition expected");
802 -- For the private type declaration case, the private type declaration
803 -- node has been built, with the Tagged_Present and Limited_Present
804 -- flags set as needed, and Typedef_Node is left set to Empty.
806 if No
(Typedef_Node
) then
807 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
808 Set_Abstract_Present
(Decl_Node
, Abstract_Present
);
810 -- For a private extension declaration, Typedef_Node contains the
811 -- N_Private_Extension_Declaration node, which we now complete. Note
812 -- that the private extension declaration, unlike a full type
813 -- declaration, does permit unknown discriminants.
815 elsif Nkind
(Typedef_Node
) = N_Private_Extension_Declaration
then
816 Decl_Node
:= Typedef_Node
;
817 Set_Sloc
(Decl_Node
, Type_Loc
);
818 Set_Unknown_Discriminants_Present
(Decl_Node
, Unknown_Dis
);
819 Set_Abstract_Present
(Typedef_Node
, Abstract_Present
);
821 -- In the full type declaration case, Typedef_Node has the type
822 -- definition and here is where we build the full type declaration
823 -- node. This is also where we check for improper use of an unknown
824 -- discriminant part (not allowed for full type declaration).
827 if Nkind
(Typedef_Node
) = N_Record_Definition
828 or else (Nkind
(Typedef_Node
) = N_Derived_Type_Definition
829 and then Present
(Record_Extension_Part
(Typedef_Node
)))
830 or else Is_Derived_Iface
832 Set_Abstract_Present
(Typedef_Node
, Abstract_Present
);
834 elsif Abstract_Present
then
835 Error_Msg
("ABSTRACT not allowed here, ignored", Abstract_Loc
);
838 Decl_Node
:= New_Node
(N_Full_Type_Declaration
, Type_Loc
);
839 Set_Type_Definition
(Decl_Node
, Typedef_Node
);
843 ("Full type declaration cannot have unknown discriminants",
848 -- Remaining processing is common for all three cases
850 Set_Defining_Identifier
(Decl_Node
, Ident_Node
);
851 Set_Discriminant_Specifications
(Decl_Node
, Discr_List
);
853 end P_Type_Declaration
;
855 ----------------------------------
856 -- 3.2.1 Full Type Declaration --
857 ----------------------------------
859 -- Parsed by P_Type_Declaration (3.2.1)
861 ----------------------------
862 -- 3.2.1 Type Definition --
863 ----------------------------
865 -- Parsed by P_Type_Declaration (3.2.1)
867 --------------------------------
868 -- 3.2.2 Subtype Declaration --
869 --------------------------------
871 -- SUBTYPE_DECLARATION ::=
872 -- subtype DEFINING_IDENTIFIER is [NULL_EXCLUSION] SUBTYPE_INDICATION;
874 -- The caller has checked that the initial token is SUBTYPE
876 -- Error recovery: can raise Error_Resync
878 function P_Subtype_Declaration
return Node_Id
is
880 Not_Null_Present
: Boolean := False;
883 Decl_Node
:= New_Node
(N_Subtype_Declaration
, Token_Ptr
);
884 Scan
; -- past SUBTYPE
885 Set_Defining_Identifier
(Decl_Node
, P_Defining_Identifier
(C_Is
));
888 if Token
= Tok_New
then
889 Error_Msg_SC
("NEW ignored (only allowed in type declaration)");
893 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
894 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
896 Set_Subtype_Indication
897 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
900 end P_Subtype_Declaration
;
902 -------------------------------
903 -- 3.2.2 Subtype Indication --
904 -------------------------------
906 -- SUBTYPE_INDICATION ::=
907 -- [NOT NULL] SUBTYPE_MARK [CONSTRAINT]
909 -- Error recovery: can raise Error_Resync
911 function P_Null_Exclusion
return Boolean is
913 if Token
/= Tok_Not
then
917 -- Ada 2005 (AI-441): The qualifier has no semantic meaning in Ada 95
918 -- (all access Parameters Are "not null" in Ada 95).
920 if Ada_Version
< Ada_05
then
922 ("null-excluding access is an Ada 2005 extension?");
923 Error_Msg_SP
("\unit should be compiled with -gnat05 switch?");
928 if Token
= Tok_Null
then
931 Error_Msg_SP
("NULL expected");
936 end P_Null_Exclusion
;
938 function P_Subtype_Indication
939 (Not_Null_Present
: Boolean := False) return Node_Id
is
943 if Token
= Tok_Identifier
or else Token
= Tok_Operator_Symbol
then
944 Type_Node
:= P_Subtype_Mark
;
945 return P_Subtype_Indication
(Type_Node
, Not_Null_Present
);
948 -- Check for error of using record definition and treat it nicely,
949 -- otherwise things are really messed up, so resynchronize.
951 if Token
= Tok_Record
then
952 Error_Msg_SC
("anonymous record definitions are not permitted");
953 Discard_Junk_Node
(P_Record_Definition
);
957 Error_Msg_AP
("subtype indication expected");
961 end P_Subtype_Indication
;
963 -- The following function is identical except that it is called with
964 -- the subtype mark already scanned out, and it scans out the constraint
966 -- Error recovery: can raise Error_Resync
968 function P_Subtype_Indication
969 (Subtype_Mark
: Node_Id
;
970 Not_Null_Present
: Boolean := False) return Node_Id
is
971 Indic_Node
: Node_Id
;
972 Constr_Node
: Node_Id
;
975 Constr_Node
:= P_Constraint_Opt
;
977 if No
(Constr_Node
) then
980 if Not_Null_Present
then
981 Error_Msg_SP
("constrained null-exclusion not allowed");
984 Indic_Node
:= New_Node
(N_Subtype_Indication
, Sloc
(Subtype_Mark
));
985 Set_Subtype_Mark
(Indic_Node
, Check_Subtype_Mark
(Subtype_Mark
));
986 Set_Constraint
(Indic_Node
, Constr_Node
);
989 end P_Subtype_Indication
;
991 -------------------------
992 -- 3.2.2 Subtype Mark --
993 -------------------------
995 -- SUBTYPE_MARK ::= subtype_NAME;
997 -- Note: The subtype mark which appears after an IN or NOT IN
998 -- operator is parsed by P_Range_Or_Subtype_Mark (3.5)
1000 -- Error recovery: cannot raise Error_Resync
1002 function P_Subtype_Mark
return Node_Id
is
1004 return P_Subtype_Mark_Resync
;
1007 when Error_Resync
=>
1011 -- This routine differs from P_Subtype_Mark in that it insists that an
1012 -- identifier be present, and if it is not, it raises Error_Resync.
1014 -- Error recovery: can raise Error_Resync
1016 function P_Subtype_Mark_Resync
return Node_Id
is
1017 Type_Node
: Node_Id
;
1020 if Token
= Tok_Access
then
1021 Error_Msg_SC
("anonymous access type definition not allowed here");
1022 Scan
; -- past ACCESS
1025 if Token
= Tok_Array
then
1026 Error_Msg_SC
("anonymous array definition not allowed here");
1027 Discard_Junk_Node
(P_Array_Type_Definition
);
1031 Type_Node
:= P_Qualified_Simple_Name_Resync
;
1033 -- Check for a subtype mark attribute. The only valid possibilities
1034 -- are 'CLASS and 'BASE. Anything else is a definite error. We may
1035 -- as well catch it here.
1037 if Token
= Tok_Apostrophe
then
1038 return P_Subtype_Mark_Attribute
(Type_Node
);
1043 end P_Subtype_Mark_Resync
;
1045 -- The following function is called to scan out a subtype mark attribute.
1046 -- The caller has already scanned out the subtype mark, which is passed in
1047 -- as the argument, and has checked that the current token is apostrophe.
1049 -- Only a special subclass of attributes, called type attributes
1050 -- (see Snames package) are allowed in this syntactic position.
1052 -- Note: if the apostrophe is followed by other than an identifier, then
1053 -- the input expression is returned unchanged, and the scan pointer is
1054 -- left pointing to the apostrophe.
1056 -- Error recovery: can raise Error_Resync
1058 function P_Subtype_Mark_Attribute
(Type_Node
: Node_Id
) return Node_Id
is
1059 Attr_Node
: Node_Id
:= Empty
;
1060 Scan_State
: Saved_Scan_State
;
1064 Prefix
:= Check_Subtype_Mark
(Type_Node
);
1066 if Prefix
= Error
then
1070 -- Loop through attributes appearing (more than one can appear as for
1071 -- for example in X'Base'Class). We are at an apostrophe on entry to
1072 -- this loop, and it runs once for each attribute parsed, with
1073 -- Prefix being the current possible prefix if it is an attribute.
1076 Save_Scan_State
(Scan_State
); -- at Apostrophe
1077 Scan
; -- past apostrophe
1079 if Token
/= Tok_Identifier
then
1080 Restore_Scan_State
(Scan_State
); -- to apostrophe
1081 return Prefix
; -- no attribute after all
1083 elsif not Is_Type_Attribute_Name
(Token_Name
) then
1085 ("attribute & may not be used in a subtype mark", Token_Node
);
1090 Make_Attribute_Reference
(Prev_Token_Ptr
,
1092 Attribute_Name
=> Token_Name
);
1093 Delete_Node
(Token_Node
);
1094 Scan
; -- past type attribute identifier
1097 exit when Token
/= Tok_Apostrophe
;
1098 Prefix
:= Attr_Node
;
1101 -- Fall through here after scanning type attribute
1104 end P_Subtype_Mark_Attribute
;
1106 -----------------------
1107 -- 3.2.2 Constraint --
1108 -----------------------
1110 -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
1112 -- SCALAR_CONSTRAINT ::=
1113 -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
1115 -- COMPOSITE_CONSTRAINT ::=
1116 -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
1118 -- If no constraint is present, this function returns Empty
1120 -- Error recovery: can raise Error_Resync
1122 function P_Constraint_Opt
return Node_Id
is
1124 if Token
= Tok_Range
1125 or else Bad_Spelling_Of
(Tok_Range
)
1127 return P_Range_Constraint
;
1129 elsif Token
= Tok_Digits
1130 or else Bad_Spelling_Of
(Tok_Digits
)
1132 return P_Digits_Constraint
;
1134 elsif Token
= Tok_Delta
1135 or else Bad_Spelling_Of
(Tok_Delta
)
1137 return P_Delta_Constraint
;
1139 elsif Token
= Tok_Left_Paren
then
1140 return P_Index_Or_Discriminant_Constraint
;
1142 elsif Token
= Tok_In
then
1144 return P_Constraint_Opt
;
1149 end P_Constraint_Opt
;
1151 ------------------------------
1152 -- 3.2.2 Scalar Constraint --
1153 ------------------------------
1155 -- Parsed by P_Constraint_Opt (3.2.2)
1157 ---------------------------------
1158 -- 3.2.2 Composite Constraint --
1159 ---------------------------------
1161 -- Parsed by P_Constraint_Opt (3.2.2)
1163 --------------------------------------------------------
1164 -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) --
1165 --------------------------------------------------------
1167 -- This routine scans out a declaration starting with an identifier:
1169 -- OBJECT_DECLARATION ::=
1170 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1171 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1172 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1173 -- ACCESS_DEFINITION [:= EXPRESSION];
1174 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1175 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1177 -- NUMBER_DECLARATION ::=
1178 -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
1180 -- OBJECT_RENAMING_DECLARATION ::=
1181 -- DEFINING_IDENTIFIER : SUBTYPE_MARK renames object_NAME;
1182 -- | DEFINING_IDENTIFIER : ACCESS_DEFINITION renames object_NAME;
1184 -- EXCEPTION_RENAMING_DECLARATION ::=
1185 -- DEFINING_IDENTIFIER : exception renames exception_NAME;
1187 -- EXCEPTION_DECLARATION ::=
1188 -- DEFINING_IDENTIFIER_LIST : exception;
1190 -- Note that the ALIASED indication in an object declaration is
1191 -- marked by a flag in the parent node.
1193 -- The caller has checked that the initial token is an identifier
1195 -- The value returned is a list of declarations, one for each identifier
1196 -- in the list (as described in Sinfo, we always split up multiple
1197 -- declarations into the equivalent sequence of single declarations
1198 -- using the More_Ids and Prev_Ids flags to preserve the source).
1200 -- If the identifier turns out to be a probable statement rather than
1201 -- an identifier, then the scan is left pointing to the identifier and
1202 -- No_List is returned.
1204 -- Error recovery: can raise Error_Resync
1206 procedure P_Identifier_Declarations
1212 Decl_Node
: Node_Id
;
1213 Type_Node
: Node_Id
;
1214 Ident_Sloc
: Source_Ptr
;
1215 Scan_State
: Saved_Scan_State
;
1216 List_OK
: Boolean := True;
1218 Init_Expr
: Node_Id
;
1219 Init_Loc
: Source_Ptr
;
1220 Con_Loc
: Source_Ptr
;
1221 Not_Null_Present
: Boolean := False;
1223 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
1224 -- Used to save identifiers in the identifier list. The upper bound
1225 -- of 4096 is expected to be infinite in practice, and we do not even
1226 -- bother to check if this upper bound is exceeded.
1228 Num_Idents
: Nat
:= 1;
1229 -- Number of identifiers stored in Idents
1232 -- This procedure is called in renames cases to make sure that we do
1233 -- not have more than one identifier. If we do have more than one
1234 -- then an error message is issued (and the declaration is split into
1235 -- multiple declarations)
1237 function Token_Is_Renames
return Boolean;
1238 -- Checks if current token is RENAMES, and if so, scans past it and
1239 -- returns True, otherwise returns False. Includes checking for some
1240 -- common error cases.
1242 procedure No_List
is
1244 if Num_Idents
> 1 then
1245 Error_Msg
("identifier list not allowed for RENAMES",
1252 function Token_Is_Renames
return Boolean is
1253 At_Colon
: Saved_Scan_State
;
1256 if Token
= Tok_Colon
then
1257 Save_Scan_State
(At_Colon
);
1259 Check_Misspelling_Of
(Tok_Renames
);
1261 if Token
= Tok_Renames
then
1262 Error_Msg_SP
("extra "":"" ignored");
1263 Scan
; -- past RENAMES
1266 Restore_Scan_State
(At_Colon
);
1271 Check_Misspelling_Of
(Tok_Renames
);
1273 if Token
= Tok_Renames
then
1274 Scan
; -- past RENAMES
1280 end Token_Is_Renames
;
1282 -- Start of processing for P_Identifier_Declarations
1285 Ident_Sloc
:= Token_Ptr
;
1286 Save_Scan_State
(Scan_State
); -- at first identifier
1287 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
1289 -- If we have a colon after the identifier, then we can assume that
1290 -- this is in fact a valid identifier declaration and can steam ahead.
1292 if Token
= Tok_Colon
then
1295 -- If we have a comma, then scan out the list of identifiers
1297 elsif Token
= Tok_Comma
then
1299 while Comma_Present
loop
1300 Num_Idents
:= Num_Idents
+ 1;
1301 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
1304 Save_Scan_State
(Scan_State
); -- at colon
1307 -- If we have identifier followed by := then we assume that what is
1308 -- really meant is an assignment statement. The assignment statement
1309 -- is scanned out and added to the list of declarations. An exception
1310 -- occurs if the := is followed by the keyword constant, in which case
1311 -- we assume it was meant to be a colon.
1313 elsif Token
= Tok_Colon_Equal
then
1316 if Token
= Tok_Constant
then
1317 Error_Msg_SP
("colon expected");
1320 Restore_Scan_State
(Scan_State
);
1321 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
1325 -- If we have an IS keyword, then assume the TYPE keyword was missing
1327 elsif Token
= Tok_Is
then
1328 Restore_Scan_State
(Scan_State
);
1329 Append_To
(Decls
, P_Type_Declaration
);
1333 -- Otherwise we have an error situation
1336 Restore_Scan_State
(Scan_State
);
1338 -- First case is possible misuse of PROTECTED in Ada 83 mode. If
1339 -- so, fix the keyword and return to scan the protected declaration.
1341 if Token_Name
= Name_Protected
then
1342 Check_95_Keyword
(Tok_Protected
, Tok_Identifier
);
1343 Check_95_Keyword
(Tok_Protected
, Tok_Type
);
1344 Check_95_Keyword
(Tok_Protected
, Tok_Body
);
1346 if Token
= Tok_Protected
then
1351 -- Check misspelling possibilities. If so, correct the misspelling
1352 -- and return to scan out the resulting declaration.
1354 elsif Bad_Spelling_Of
(Tok_Function
)
1355 or else Bad_Spelling_Of
(Tok_Procedure
)
1356 or else Bad_Spelling_Of
(Tok_Package
)
1357 or else Bad_Spelling_Of
(Tok_Pragma
)
1358 or else Bad_Spelling_Of
(Tok_Protected
)
1359 or else Bad_Spelling_Of
(Tok_Generic
)
1360 or else Bad_Spelling_Of
(Tok_Subtype
)
1361 or else Bad_Spelling_Of
(Tok_Type
)
1362 or else Bad_Spelling_Of
(Tok_Task
)
1363 or else Bad_Spelling_Of
(Tok_Use
)
1364 or else Bad_Spelling_Of
(Tok_For
)
1369 -- Otherwise we definitely have an ordinary identifier with a junk
1370 -- token after it. Just complain that we expect a declaration, and
1371 -- skip to a semicolon
1374 Set_Declaration_Expected
;
1375 Resync_Past_Semicolon
;
1381 -- Come here with an identifier list and colon scanned out. We now
1382 -- build the nodes for the declarative items. One node is built for
1383 -- each identifier in the list, with the type information being
1384 -- repeated by rescanning the appropriate section of source.
1386 -- First an error check, if we have two identifiers in a row, a likely
1387 -- possibility is that the first of the identifiers is an incorrectly
1390 if Token
= Tok_Identifier
then
1392 SS
: Saved_Scan_State
;
1396 Save_Scan_State
(SS
);
1397 Scan
; -- past initial identifier
1398 I2
:= (Token
= Tok_Identifier
);
1399 Restore_Scan_State
(SS
);
1403 (Bad_Spelling_Of
(Tok_Access
) or else
1404 Bad_Spelling_Of
(Tok_Aliased
) or else
1405 Bad_Spelling_Of
(Tok_Constant
))
1412 -- Loop through identifiers
1417 -- Check for some cases of misused Ada 95 keywords
1419 if Token_Name
= Name_Aliased
then
1420 Check_95_Keyword
(Tok_Aliased
, Tok_Array
);
1421 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
1422 Check_95_Keyword
(Tok_Aliased
, Tok_Constant
);
1427 if Token
= Tok_Constant
then
1428 Con_Loc
:= Token_Ptr
;
1429 Scan
; -- past CONSTANT
1431 -- Number declaration, initialization required
1433 Init_Expr
:= Init_Expr_Opt
;
1435 if Present
(Init_Expr
) then
1436 if Not_Null_Present
then
1437 Error_Msg_SP
("null-exclusion not allowed in "
1438 & "numeric expression");
1441 Decl_Node
:= New_Node
(N_Number_Declaration
, Ident_Sloc
);
1442 Set_Expression
(Decl_Node
, Init_Expr
);
1444 -- Constant object declaration
1447 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1448 Set_Constant_Present
(Decl_Node
, True);
1450 if Token_Name
= Name_Aliased
then
1451 Check_95_Keyword
(Tok_Aliased
, Tok_Array
);
1452 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
1455 if Token
= Tok_Aliased
then
1456 Error_Msg_SC
("ALIASED should be before CONSTANT");
1457 Scan
; -- past ALIASED
1458 Set_Aliased_Present
(Decl_Node
, True);
1461 if Token
= Tok_Array
then
1462 Set_Object_Definition
1463 (Decl_Node
, P_Array_Type_Definition
);
1466 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1467 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1469 if Token
= Tok_Access
then
1470 if Ada_Version
< Ada_05
then
1472 ("generalized use of anonymous access types " &
1473 "is an Ada 2005 extension");
1475 ("\unit must be compiled with -gnat05 switch");
1478 Set_Object_Definition
1479 (Decl_Node
, P_Access_Definition
(Not_Null_Present
));
1481 Set_Object_Definition
1482 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
1486 if Token
= Tok_Renames
then
1488 ("CONSTANT not permitted in renaming declaration",
1490 Scan
; -- Past renames
1491 Discard_Junk_Node
(P_Name
);
1497 elsif Token
= Tok_Exception
then
1498 Scan
; -- past EXCEPTION
1500 if Token_Is_Renames
then
1503 New_Node
(N_Exception_Renaming_Declaration
, Ident_Sloc
);
1504 Set_Name
(Decl_Node
, P_Qualified_Simple_Name_Resync
);
1507 Decl_Node
:= New_Node
(N_Exception_Declaration
, Prev_Token_Ptr
);
1510 -- Aliased case (note that an object definition is required)
1512 elsif Token
= Tok_Aliased
then
1513 Scan
; -- past ALIASED
1514 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1515 Set_Aliased_Present
(Decl_Node
, True);
1517 if Token
= Tok_Constant
then
1518 Scan
; -- past CONSTANT
1519 Set_Constant_Present
(Decl_Node
, True);
1522 if Token
= Tok_Array
then
1523 Set_Object_Definition
1524 (Decl_Node
, P_Array_Type_Definition
);
1527 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1528 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1530 -- Access definition (AI-406) or subtype indication
1532 if Token
= Tok_Access
then
1533 if Ada_Version
< Ada_05
then
1535 ("generalized use of anonymous access types " &
1536 "is an Ada 2005 extension");
1538 ("\unit must be compiled with -gnat05 switch");
1541 Set_Object_Definition
1542 (Decl_Node
, P_Access_Definition
(Not_Null_Present
));
1544 Set_Object_Definition
1545 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
1551 elsif Token
= Tok_Array
then
1552 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1553 Set_Object_Definition
(Decl_Node
, P_Array_Type_Definition
);
1555 -- Ada 2005 (AI-254, AI-406)
1557 elsif Token
= Tok_Not
then
1559 -- OBJECT_DECLARATION ::=
1560 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1561 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1562 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1563 -- ACCESS_DEFINITION [:= EXPRESSION];
1565 -- OBJECT_RENAMING_DECLARATION ::=
1567 -- | DEFINING_IDENTIFIER : ACCESS_DEFINITION renames object_NAME;
1569 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1571 if Token
= Tok_Access
then
1572 if Ada_Version
< Ada_05
then
1574 ("generalized use of anonymous access types " &
1575 "is an Ada 2005 extension");
1576 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1579 Acc_Node
:= P_Access_Definition
(Not_Null_Present
);
1581 if Token
/= Tok_Renames
then
1582 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1583 Set_Object_Definition
(Decl_Node
, Acc_Node
);
1587 Scan
; -- past renames
1590 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1591 Set_Access_Definition
(Decl_Node
, Acc_Node
);
1592 Set_Name
(Decl_Node
, P_Name
);
1596 Type_Node
:= P_Subtype_Mark
;
1598 -- Object renaming declaration
1600 if Token_Is_Renames
then
1602 ("null-exclusion not allowed in object renamings");
1605 -- Object declaration
1608 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1609 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1610 Set_Object_Definition
1612 P_Subtype_Indication
(Type_Node
, Not_Null_Present
));
1614 -- RENAMES at this point means that we had the combination
1615 -- of a constraint on the Type_Node and renames, which is
1618 if Token_Is_Renames
then
1619 Error_Msg_N
("constraint not allowed in object renaming "
1621 Constraint
(Object_Definition
(Decl_Node
)));
1627 -- Ada 2005 (AI-230): Access Definition case
1629 elsif Token
= Tok_Access
then
1630 if Ada_Version
< Ada_05
then
1632 ("generalized use of anonymous access types " &
1633 "is an Ada 2005 extension");
1634 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1637 Acc_Node
:= P_Access_Definition
(Null_Exclusion_Present
=> False);
1639 -- Object declaration with access definition, or renaming
1641 if Token
/= Tok_Renames
then
1642 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1643 Set_Object_Definition
(Decl_Node
, Acc_Node
);
1644 goto init
; -- ??? is this really needed goes here anyway
1647 Scan
; -- past renames
1650 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1651 Set_Access_Definition
(Decl_Node
, Acc_Node
);
1652 Set_Name
(Decl_Node
, P_Name
);
1655 -- Subtype indication case
1658 Type_Node
:= P_Subtype_Mark
;
1660 -- Object renaming declaration
1662 if Token_Is_Renames
then
1665 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1666 Set_Subtype_Mark
(Decl_Node
, Type_Node
);
1667 Set_Name
(Decl_Node
, P_Name
);
1669 -- Object declaration
1672 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1673 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1674 Set_Object_Definition
1676 P_Subtype_Indication
(Type_Node
, Not_Null_Present
));
1678 -- RENAMES at this point means that we had the combination of
1679 -- a constraint on the Type_Node and renames, which is illegal
1681 if Token_Is_Renames
then
1683 ("constraint not allowed in object renaming declaration",
1684 Constraint
(Object_Definition
(Decl_Node
)));
1690 -- Scan out initialization, allowed only for object declaration
1692 <<init
>> -- is this really needed ???
1693 Init_Loc
:= Token_Ptr
;
1694 Init_Expr
:= Init_Expr_Opt
;
1696 if Present
(Init_Expr
) then
1697 if Nkind
(Decl_Node
) = N_Object_Declaration
then
1698 Set_Expression
(Decl_Node
, Init_Expr
);
1700 Error_Msg
("initialization not allowed here", Init_Loc
);
1705 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
1708 if Ident
< Num_Idents
then
1709 Set_More_Ids
(Decl_Node
, True);
1713 Set_Prev_Ids
(Decl_Node
, True);
1717 Append
(Decl_Node
, Decls
);
1718 exit Ident_Loop
when Ident
= Num_Idents
;
1719 Restore_Scan_State
(Scan_State
);
1722 end loop Ident_Loop
;
1725 end P_Identifier_Declarations
;
1727 -------------------------------
1728 -- 3.3.1 Object Declaration --
1729 -------------------------------
1731 -- OBJECT DECLARATION ::=
1732 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1733 -- SUBTYPE_INDICATION [:= EXPRESSION];
1734 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1735 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1736 -- | SINGLE_TASK_DECLARATION
1737 -- | SINGLE_PROTECTED_DECLARATION
1739 -- Cases starting with TASK are parsed by P_Task (9.1)
1740 -- Cases starting with PROTECTED are parsed by P_Protected (9.4)
1741 -- All other cases are parsed by P_Identifier_Declarations (3.3)
1743 -------------------------------------
1744 -- 3.3.1 Defining Identifier List --
1745 -------------------------------------
1747 -- DEFINING_IDENTIFIER_LIST ::=
1748 -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
1750 -- Always parsed by the construct in which it appears. See special
1751 -- section on "Handling of Defining Identifier Lists" in this unit.
1753 -------------------------------
1754 -- 3.3.2 Number Declaration --
1755 -------------------------------
1757 -- Parsed by P_Identifier_Declarations (3.3)
1759 -------------------------------------------------------------------------
1760 -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) --
1761 -------------------------------------------------------------------------
1763 -- DERIVED_TYPE_DEFINITION ::=
1764 -- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
1765 -- [[AND interface_list] RECORD_EXTENSION_PART]
1767 -- PRIVATE_EXTENSION_DECLARATION ::=
1768 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
1769 -- [abstract] [limited] new ancestor_SUBTYPE_INDICATION
1770 -- [AND interface_list] with PRIVATE;
1772 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
1774 -- The caller has already scanned out the part up to the NEW, and Token
1775 -- either contains Tok_New (or ought to, if it doesn't this procedure
1776 -- will post an appropriate "NEW expected" message).
1778 -- Note: the caller is responsible for filling in the Sloc field of
1779 -- the returned node in the private extension declaration case as
1780 -- well as the stuff relating to the discriminant part.
1782 -- Error recovery: can raise Error_Resync;
1784 function P_Derived_Type_Def_Or_Private_Ext_Decl
return Node_Id
is
1785 Typedef_Node
: Node_Id
;
1786 Typedecl_Node
: Node_Id
;
1787 Not_Null_Present
: Boolean := False;
1790 Typedef_Node
:= New_Node
(N_Derived_Type_Definition
, Token_Ptr
);
1792 if Ada_Version
< Ada_05
1793 and then Token
= Tok_Identifier
1794 and then Token_Name
= Name_Interface
1797 ("abstract interface is an Ada 2005 extension");
1798 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1803 if Token
= Tok_Abstract
then
1804 Error_Msg_SC
("ABSTRACT must come before NEW, not after");
1808 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1809 Set_Null_Exclusion_Present
(Typedef_Node
, Not_Null_Present
);
1810 Set_Subtype_Indication
(Typedef_Node
,
1811 P_Subtype_Indication
(Not_Null_Present
));
1813 -- Ada 2005 (AI-251): Deal with interfaces
1815 if Token
= Tok_And
then
1818 if Ada_Version
< Ada_05
then
1820 ("abstract interface is an Ada 2005 extension");
1821 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1824 Set_Interface_List
(Typedef_Node
, New_List
);
1827 Append
(P_Qualified_Simple_Name
, Interface_List
(Typedef_Node
));
1828 exit when Token
/= Tok_And
;
1832 if Token
/= Tok_With
then
1833 Error_Msg_SC
("WITH expected");
1838 -- Deal with record extension, note that we assume that a WITH is
1839 -- missing in the case of "type X is new Y record ..." or in the
1840 -- case of "type X is new Y null record".
1843 or else Token
= Tok_Record
1844 or else Token
= Tok_Null
1846 T_With
; -- past WITH or give error message
1848 if Token
= Tok_Limited
then
1850 ("LIMITED keyword not allowed in private extension");
1851 Scan
; -- ignore LIMITED
1854 -- Private extension declaration
1856 if Token
= Tok_Private
then
1857 Scan
; -- past PRIVATE
1859 -- Throw away the type definition node and build the type
1860 -- declaration node. Note the caller must set the Sloc,
1861 -- Discriminant_Specifications, Unknown_Discriminants_Present,
1862 -- and Defined_Identifier fields in the returned node.
1865 Make_Private_Extension_Declaration
(No_Location
,
1866 Defining_Identifier
=> Empty
,
1867 Subtype_Indication
=> Subtype_Indication
(Typedef_Node
),
1868 Abstract_Present
=> Abstract_Present
(Typedef_Node
),
1869 Interface_List
=> Interface_List
(Typedef_Node
));
1871 Delete_Node
(Typedef_Node
);
1872 return Typedecl_Node
;
1874 -- Derived type definition with record extension part
1877 Set_Record_Extension_Part
(Typedef_Node
, P_Record_Definition
);
1878 return Typedef_Node
;
1881 -- Derived type definition with no record extension part
1884 return Typedef_Node
;
1886 end P_Derived_Type_Def_Or_Private_Ext_Decl
;
1888 ---------------------------
1889 -- 3.5 Range Constraint --
1890 ---------------------------
1892 -- RANGE_CONSTRAINT ::= range RANGE
1894 -- The caller has checked that the initial token is RANGE
1896 -- Error recovery: cannot raise Error_Resync
1898 function P_Range_Constraint
return Node_Id
is
1899 Range_Node
: Node_Id
;
1902 Range_Node
:= New_Node
(N_Range_Constraint
, Token_Ptr
);
1904 Set_Range_Expression
(Range_Node
, P_Range
);
1906 end P_Range_Constraint
;
1913 -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
1915 -- Note: the range that appears in a membership test is parsed by
1916 -- P_Range_Or_Subtype_Mark (3.5).
1918 -- Error recovery: cannot raise Error_Resync
1920 function P_Range
return Node_Id
is
1921 Expr_Node
: Node_Id
;
1922 Range_Node
: Node_Id
;
1925 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
1927 if Expr_Form
= EF_Range_Attr
then
1930 elsif Token
= Tok_Dot_Dot
then
1931 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
1932 Set_Low_Bound
(Range_Node
, Expr_Node
);
1934 Expr_Node
:= P_Expression
;
1935 Check_Simple_Expression
(Expr_Node
);
1936 Set_High_Bound
(Range_Node
, Expr_Node
);
1939 -- Anything else is an error
1942 T_Dot_Dot
; -- force missing .. message
1947 ----------------------------------
1948 -- 3.5 P_Range_Or_Subtype_Mark --
1949 ----------------------------------
1952 -- RANGE_ATTRIBUTE_REFERENCE
1953 -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
1955 -- This routine scans out the range or subtype mark that forms the right
1956 -- operand of a membership test.
1958 -- Note: as documented in the Sinfo interface, although the syntax only
1959 -- allows a subtype mark, we in fact allow any simple expression to be
1960 -- returned from this routine. The semantics is responsible for issuing
1961 -- an appropriate message complaining if the argument is not a name.
1962 -- This simplifies the coding and error recovery processing in the
1963 -- parser, and in any case it is preferable not to consider this a
1964 -- syntax error and to continue with the semantic analysis.
1966 -- Error recovery: cannot raise Error_Resync
1968 function P_Range_Or_Subtype_Mark
return Node_Id
is
1969 Expr_Node
: Node_Id
;
1970 Range_Node
: Node_Id
;
1973 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
1975 if Expr_Form
= EF_Range_Attr
then
1978 -- Simple_Expression .. Simple_Expression
1980 elsif Token
= Tok_Dot_Dot
then
1981 Check_Simple_Expression
(Expr_Node
);
1982 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
1983 Set_Low_Bound
(Range_Node
, Expr_Node
);
1985 Set_High_Bound
(Range_Node
, P_Simple_Expression
);
1988 -- Case of subtype mark (optionally qualified simple name or an
1989 -- attribute whose prefix is an optionally qualifed simple name)
1991 elsif Expr_Form
= EF_Simple_Name
1992 or else Nkind
(Expr_Node
) = N_Attribute_Reference
1994 -- Check for error of range constraint after a subtype mark
1996 if Token
= Tok_Range
then
1998 ("range constraint not allowed in membership test");
2002 -- Check for error of DIGITS or DELTA after a subtype mark
2004 elsif Token
= Tok_Digits
or else Token
= Tok_Delta
then
2006 ("accuracy definition not allowed in membership test");
2007 Scan
; -- past DIGITS or DELTA
2010 elsif Token
= Tok_Apostrophe
then
2011 return P_Subtype_Mark_Attribute
(Expr_Node
);
2017 -- At this stage, we have some junk following the expression. We
2018 -- really can't tell what is wrong, might be a missing semicolon,
2019 -- or a missing THEN, or whatever. Our caller will figure it out!
2024 end P_Range_Or_Subtype_Mark
;
2026 ----------------------------------------
2027 -- 3.5.1 Enumeration Type Definition --
2028 ----------------------------------------
2030 -- ENUMERATION_TYPE_DEFINITION ::=
2031 -- (ENUMERATION_LITERAL_SPECIFICATION
2032 -- {, ENUMERATION_LITERAL_SPECIFICATION})
2034 -- The caller has already scanned out the TYPE keyword
2036 -- Error recovery: can raise Error_Resync;
2038 function P_Enumeration_Type_Definition
return Node_Id
is
2039 Typedef_Node
: Node_Id
;
2042 Typedef_Node
:= New_Node
(N_Enumeration_Type_Definition
, Token_Ptr
);
2043 Set_Literals
(Typedef_Node
, New_List
);
2048 Append
(P_Enumeration_Literal_Specification
, Literals
(Typedef_Node
));
2049 exit when not Comma_Present
;
2053 return Typedef_Node
;
2054 end P_Enumeration_Type_Definition
;
2056 ----------------------------------------------
2057 -- 3.5.1 Enumeration Literal Specification --
2058 ----------------------------------------------
2060 -- ENUMERATION_LITERAL_SPECIFICATION ::=
2061 -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
2063 -- Error recovery: can raise Error_Resync
2065 function P_Enumeration_Literal_Specification
return Node_Id
is
2067 if Token
= Tok_Char_Literal
then
2068 return P_Defining_Character_Literal
;
2070 return P_Defining_Identifier
(C_Comma_Right_Paren
);
2072 end P_Enumeration_Literal_Specification
;
2074 ---------------------------------------
2075 -- 3.5.1 Defining_Character_Literal --
2076 ---------------------------------------
2078 -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
2080 -- Error recovery: cannot raise Error_Resync
2082 -- The caller has checked that the current token is a character literal
2084 function P_Defining_Character_Literal
return Node_Id
is
2085 Literal_Node
: Node_Id
;
2088 Literal_Node
:= Token_Node
;
2089 Change_Character_Literal_To_Defining_Character_Literal
(Literal_Node
);
2090 Scan
; -- past character literal
2091 return Literal_Node
;
2092 end P_Defining_Character_Literal
;
2094 ------------------------------------
2095 -- 3.5.4 Integer Type Definition --
2096 ------------------------------------
2098 -- Parsed by P_Type_Declaration (3.2.1)
2100 -------------------------------------------
2101 -- 3.5.4 Signed Integer Type Definition --
2102 -------------------------------------------
2104 -- SIGNED_INTEGER_TYPE_DEFINITION ::=
2105 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2107 -- Normally the initial token on entry is RANGE, but in some
2108 -- error conditions, the range token was missing and control is
2109 -- passed with Token pointing to first token of the first expression.
2111 -- Error recovery: cannot raise Error_Resync
2113 function P_Signed_Integer_Type_Definition
return Node_Id
is
2114 Typedef_Node
: Node_Id
;
2115 Expr_Node
: Node_Id
;
2118 Typedef_Node
:= New_Node
(N_Signed_Integer_Type_Definition
, Token_Ptr
);
2120 if Token
= Tok_Range
then
2124 Expr_Node
:= P_Expression
;
2125 Check_Simple_Expression
(Expr_Node
);
2126 Set_Low_Bound
(Typedef_Node
, Expr_Node
);
2128 Expr_Node
:= P_Expression
;
2129 Check_Simple_Expression
(Expr_Node
);
2130 Set_High_Bound
(Typedef_Node
, Expr_Node
);
2131 return Typedef_Node
;
2132 end P_Signed_Integer_Type_Definition
;
2134 ------------------------------------
2135 -- 3.5.4 Modular Type Definition --
2136 ------------------------------------
2138 -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
2140 -- The caller has checked that the initial token is MOD
2142 -- Error recovery: cannot raise Error_Resync
2144 function P_Modular_Type_Definition
return Node_Id
is
2145 Typedef_Node
: Node_Id
;
2148 if Ada_Version
= Ada_83
then
2149 Error_Msg_SC
("(Ada 83): modular types not allowed");
2152 Typedef_Node
:= New_Node
(N_Modular_Type_Definition
, Token_Ptr
);
2154 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
2156 -- Handle mod L..R cleanly
2158 if Token
= Tok_Dot_Dot
then
2159 Error_Msg_SC
("range not allowed for modular type");
2161 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
2164 return Typedef_Node
;
2165 end P_Modular_Type_Definition
;
2167 ---------------------------------
2168 -- 3.5.6 Real Type Definition --
2169 ---------------------------------
2171 -- Parsed by P_Type_Declaration (3.2.1)
2173 --------------------------------------
2174 -- 3.5.7 Floating Point Definition --
2175 --------------------------------------
2177 -- FLOATING_POINT_DEFINITION ::=
2178 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2180 -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
2182 -- The caller has checked that the initial token is DIGITS
2184 -- Error recovery: cannot raise Error_Resync
2186 function P_Floating_Point_Definition
return Node_Id
is
2187 Digits_Loc
: constant Source_Ptr
:= Token_Ptr
;
2189 Expr_Node
: Node_Id
;
2192 Scan
; -- past DIGITS
2193 Expr_Node
:= P_Expression_No_Right_Paren
;
2194 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2196 -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
2198 if Token
= Tok_Delta
then
2199 Error_Msg_SC
("DELTA must come before DIGITS");
2200 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Digits_Loc
);
2202 Set_Delta_Expression
(Def_Node
, P_Expression_No_Right_Paren
);
2204 -- OK floating-point definition
2207 Def_Node
:= New_Node
(N_Floating_Point_Definition
, Digits_Loc
);
2210 Set_Digits_Expression
(Def_Node
, Expr_Node
);
2211 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
2213 end P_Floating_Point_Definition
;
2215 -------------------------------------
2216 -- 3.5.7 Real Range Specification --
2217 -------------------------------------
2219 -- REAL_RANGE_SPECIFICATION ::=
2220 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2222 -- Error recovery: cannot raise Error_Resync
2224 function P_Real_Range_Specification_Opt
return Node_Id
is
2225 Specification_Node
: Node_Id
;
2226 Expr_Node
: Node_Id
;
2229 if Token
= Tok_Range
then
2230 Specification_Node
:=
2231 New_Node
(N_Real_Range_Specification
, Token_Ptr
);
2233 Expr_Node
:= P_Expression_No_Right_Paren
;
2234 Check_Simple_Expression
(Expr_Node
);
2235 Set_Low_Bound
(Specification_Node
, Expr_Node
);
2237 Expr_Node
:= P_Expression_No_Right_Paren
;
2238 Check_Simple_Expression
(Expr_Node
);
2239 Set_High_Bound
(Specification_Node
, Expr_Node
);
2240 return Specification_Node
;
2244 end P_Real_Range_Specification_Opt
;
2246 -----------------------------------
2247 -- 3.5.9 Fixed Point Definition --
2248 -----------------------------------
2250 -- FIXED_POINT_DEFINITION ::=
2251 -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
2253 -- ORDINARY_FIXED_POINT_DEFINITION ::=
2254 -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION
2256 -- DECIMAL_FIXED_POINT_DEFINITION ::=
2257 -- delta static_EXPRESSION
2258 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2260 -- The caller has checked that the initial token is DELTA
2262 -- Error recovery: cannot raise Error_Resync
2264 function P_Fixed_Point_Definition
return Node_Id
is
2265 Delta_Node
: Node_Id
;
2266 Delta_Loc
: Source_Ptr
;
2268 Expr_Node
: Node_Id
;
2271 Delta_Loc
:= Token_Ptr
;
2273 Delta_Node
:= P_Expression_No_Right_Paren
;
2274 Check_Simple_Expression_In_Ada_83
(Delta_Node
);
2276 if Token
= Tok_Digits
then
2277 if Ada_Version
= Ada_83
then
2278 Error_Msg_SC
("(Ada 83) decimal fixed type not allowed!");
2281 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Delta_Loc
);
2282 Scan
; -- past DIGITS
2283 Expr_Node
:= P_Expression_No_Right_Paren
;
2284 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2285 Set_Digits_Expression
(Def_Node
, Expr_Node
);
2288 Def_Node
:= New_Node
(N_Ordinary_Fixed_Point_Definition
, Delta_Loc
);
2290 -- Range is required in ordinary fixed point case
2292 if Token
/= Tok_Range
then
2293 Error_Msg_AP
("range must be given for fixed-point type");
2298 Set_Delta_Expression
(Def_Node
, Delta_Node
);
2299 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
2301 end P_Fixed_Point_Definition
;
2303 --------------------------------------------
2304 -- 3.5.9 Ordinary Fixed Point Definition --
2305 --------------------------------------------
2307 -- Parsed by P_Fixed_Point_Definition (3.5.9)
2309 -------------------------------------------
2310 -- 3.5.9 Decimal Fixed Point Definition --
2311 -------------------------------------------
2313 -- Parsed by P_Decimal_Point_Definition (3.5.9)
2315 ------------------------------
2316 -- 3.5.9 Digits Constraint --
2317 ------------------------------
2319 -- DIGITS_CONSTRAINT ::=
2320 -- digits static_EXPRESSION [RANGE_CONSTRAINT]
2322 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2324 -- The caller has checked that the initial token is DIGITS
2326 function P_Digits_Constraint
return Node_Id
is
2327 Constraint_Node
: Node_Id
;
2328 Expr_Node
: Node_Id
;
2331 Constraint_Node
:= New_Node
(N_Digits_Constraint
, Token_Ptr
);
2332 Scan
; -- past DIGITS
2333 Expr_Node
:= P_Expression_No_Right_Paren
;
2334 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2335 Set_Digits_Expression
(Constraint_Node
, Expr_Node
);
2337 if Token
= Tok_Range
then
2338 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
2341 return Constraint_Node
;
2342 end P_Digits_Constraint
;
2344 -----------------------------
2345 -- 3.5.9 Delta Constraint --
2346 -----------------------------
2348 -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
2350 -- Note: this is an obsolescent feature in Ada 95 (I.3)
2352 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2354 -- The caller has checked that the initial token is DELTA
2356 -- Error recovery: cannot raise Error_Resync
2358 function P_Delta_Constraint
return Node_Id
is
2359 Constraint_Node
: Node_Id
;
2360 Expr_Node
: Node_Id
;
2363 Constraint_Node
:= New_Node
(N_Delta_Constraint
, Token_Ptr
);
2365 Expr_Node
:= P_Expression_No_Right_Paren
;
2366 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2367 Set_Delta_Expression
(Constraint_Node
, Expr_Node
);
2369 if Token
= Tok_Range
then
2370 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
2373 return Constraint_Node
;
2374 end P_Delta_Constraint
;
2376 --------------------------------
2377 -- 3.6 Array Type Definition --
2378 --------------------------------
2380 -- ARRAY_TYPE_DEFINITION ::=
2381 -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
2383 -- UNCONSTRAINED_ARRAY_DEFINITION ::=
2384 -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
2385 -- COMPONENT_DEFINITION
2387 -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
2389 -- CONSTRAINED_ARRAY_DEFINITION ::=
2390 -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
2391 -- COMPONENT_DEFINITION
2393 -- DISCRETE_SUBTYPE_DEFINITION ::=
2394 -- DISCRETE_SUBTYPE_INDICATION | RANGE
2396 -- COMPONENT_DEFINITION ::=
2397 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
2399 -- The caller has checked that the initial token is ARRAY
2401 -- Error recovery: can raise Error_Resync
2403 function P_Array_Type_Definition
return Node_Id
is
2404 Array_Loc
: Source_Ptr
;
2405 CompDef_Node
: Node_Id
;
2407 Not_Null_Present
: Boolean := False;
2408 Subs_List
: List_Id
;
2409 Scan_State
: Saved_Scan_State
;
2410 Aliased_Present
: Boolean := False;
2413 Array_Loc
:= Token_Ptr
;
2415 Subs_List
:= New_List
;
2418 -- It's quite tricky to disentangle these two possibilities, so we do
2419 -- a prescan to determine which case we have and then reset the scan.
2420 -- The prescan skips past possible subtype mark tokens.
2422 Save_Scan_State
(Scan_State
); -- just after paren
2424 while Token
in Token_Class_Desig
or else
2425 Token
= Tok_Dot
or else
2426 Token
= Tok_Apostrophe
-- because of 'BASE, 'CLASS
2431 -- If we end up on RANGE <> then we have the unconstrained case. We
2432 -- will also allow the RANGE to be omitted, just to improve error
2433 -- handling for a case like array (integer <>) of integer;
2435 Scan
; -- past possible RANGE or <>
2437 if (Prev_Token
= Tok_Range
and then Token
= Tok_Box
) or else
2438 Prev_Token
= Tok_Box
2440 Def_Node
:= New_Node
(N_Unconstrained_Array_Definition
, Array_Loc
);
2441 Restore_Scan_State
(Scan_State
); -- to first subtype mark
2444 Append
(P_Subtype_Mark_Resync
, Subs_List
);
2447 exit when Token
= Tok_Right_Paren
or else Token
= Tok_Of
;
2451 Set_Subtype_Marks
(Def_Node
, Subs_List
);
2454 Def_Node
:= New_Node
(N_Constrained_Array_Definition
, Array_Loc
);
2455 Restore_Scan_State
(Scan_State
); -- to first discrete range
2458 Append
(P_Discrete_Subtype_Definition
, Subs_List
);
2459 exit when not Comma_Present
;
2462 Set_Discrete_Subtype_Definitions
(Def_Node
, Subs_List
);
2468 CompDef_Node
:= New_Node
(N_Component_Definition
, Token_Ptr
);
2470 if Token_Name
= Name_Aliased
then
2471 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
2474 if Token
= Tok_Aliased
then
2475 Aliased_Present
:= True;
2476 Scan
; -- past ALIASED
2479 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/AI-254)
2481 -- Ada 2005 (AI-230): Access Definition case
2483 if Token
= Tok_Access
then
2484 if Ada_Version
< Ada_05
then
2486 ("generalized use of anonymous access types " &
2487 "is an Ada 2005 extension");
2488 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
2491 if Aliased_Present
then
2492 Error_Msg_SP
("ALIASED not allowed here");
2495 Set_Subtype_Indication
(CompDef_Node
, Empty
);
2496 Set_Aliased_Present
(CompDef_Node
, False);
2497 Set_Access_Definition
(CompDef_Node
,
2498 P_Access_Definition
(Not_Null_Present
));
2501 Set_Access_Definition
(CompDef_Node
, Empty
);
2502 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
2503 Set_Null_Exclusion_Present
(CompDef_Node
, Not_Null_Present
);
2504 Set_Subtype_Indication
(CompDef_Node
,
2505 P_Subtype_Indication
(Not_Null_Present
));
2508 Set_Component_Definition
(Def_Node
, CompDef_Node
);
2511 end P_Array_Type_Definition
;
2513 -----------------------------------------
2514 -- 3.6 Unconstrained Array Definition --
2515 -----------------------------------------
2517 -- Parsed by P_Array_Type_Definition (3.6)
2519 ---------------------------------------
2520 -- 3.6 Constrained Array Definition --
2521 ---------------------------------------
2523 -- Parsed by P_Array_Type_Definition (3.6)
2525 --------------------------------------
2526 -- 3.6 Discrete Subtype Definition --
2527 --------------------------------------
2529 -- DISCRETE_SUBTYPE_DEFINITION ::=
2530 -- discrete_SUBTYPE_INDICATION | RANGE
2532 -- Note: the discrete subtype definition appearing in a constrained
2533 -- array definition is parsed by P_Array_Type_Definition (3.6)
2535 -- Error recovery: cannot raise Error_Resync
2537 function P_Discrete_Subtype_Definition
return Node_Id
is
2539 -- The syntax of a discrete subtype definition is identical to that
2540 -- of a discrete range, so we simply share the same parsing code.
2542 return P_Discrete_Range
;
2543 end P_Discrete_Subtype_Definition
;
2545 -------------------------------
2546 -- 3.6 Component Definition --
2547 -------------------------------
2549 -- For the array case, parsed by P_Array_Type_Definition (3.6)
2550 -- For the record case, parsed by P_Component_Declaration (3.8)
2552 -----------------------------
2553 -- 3.6.1 Index Constraint --
2554 -----------------------------
2556 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2558 ---------------------------
2559 -- 3.6.1 Discrete Range --
2560 ---------------------------
2562 -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
2564 -- The possible forms for a discrete range are:
2566 -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2)
2567 -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2)
2568 -- Range_Attribute (RANGE, 3.5)
2569 -- Simple_Expression .. Simple_Expression (RANGE, 3.5)
2571 -- Error recovery: cannot raise Error_Resync
2573 function P_Discrete_Range
return Node_Id
is
2574 Expr_Node
: Node_Id
;
2575 Range_Node
: Node_Id
;
2578 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2580 if Expr_Form
= EF_Range_Attr
then
2583 elsif Token
= Tok_Range
then
2584 if Expr_Form
/= EF_Simple_Name
then
2585 Error_Msg_SC
("range must be preceded by subtype mark");
2588 return P_Subtype_Indication
(Expr_Node
);
2590 -- Check Expression .. Expression case
2592 elsif Token
= Tok_Dot_Dot
then
2593 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2594 Set_Low_Bound
(Range_Node
, Expr_Node
);
2596 Expr_Node
:= P_Expression
;
2597 Check_Simple_Expression
(Expr_Node
);
2598 Set_High_Bound
(Range_Node
, Expr_Node
);
2601 -- Otherwise we must have a subtype mark
2603 elsif Expr_Form
= EF_Simple_Name
then
2606 -- If incorrect, complain that we expect ..
2612 end P_Discrete_Range
;
2614 ----------------------------
2615 -- 3.7 Discriminant Part --
2616 ----------------------------
2618 -- DISCRIMINANT_PART ::=
2619 -- UNKNOWN_DISCRIMINANT_PART
2620 -- | KNOWN_DISCRIMINANT_PART
2622 -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
2623 -- or P_Unknown_Discriminant_Part (3.7), since we know which we want.
2625 ------------------------------------
2626 -- 3.7 Unknown Discriminant Part --
2627 ------------------------------------
2629 -- UNKNOWN_DISCRIMINANT_PART ::= (<>)
2631 -- If no unknown discriminant part is present, then False is returned,
2632 -- otherwise the unknown discriminant is scanned out and True is returned.
2634 -- Error recovery: cannot raise Error_Resync
2636 function P_Unknown_Discriminant_Part_Opt
return Boolean is
2637 Scan_State
: Saved_Scan_State
;
2640 if Token
/= Tok_Left_Paren
then
2644 Save_Scan_State
(Scan_State
);
2645 Scan
; -- past the left paren
2647 if Token
= Tok_Box
then
2648 if Ada_Version
= Ada_83
then
2649 Error_Msg_SC
("(Ada 83) unknown discriminant not allowed!");
2652 Scan
; -- past the box
2653 T_Right_Paren
; -- must be followed by right paren
2657 Restore_Scan_State
(Scan_State
);
2661 end P_Unknown_Discriminant_Part_Opt
;
2663 ----------------------------------
2664 -- 3.7 Known Discriminant Part --
2665 ----------------------------------
2667 -- KNOWN_DISCRIMINANT_PART ::=
2668 -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
2670 -- DISCRIMINANT_SPECIFICATION ::=
2671 -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
2672 -- [:= DEFAULT_EXPRESSION]
2673 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
2674 -- [:= DEFAULT_EXPRESSION]
2676 -- If no known discriminant part is present, then No_List is returned
2678 -- Error recovery: cannot raise Error_Resync
2680 function P_Known_Discriminant_Part_Opt
return List_Id
is
2681 Specification_Node
: Node_Id
;
2682 Specification_List
: List_Id
;
2683 Ident_Sloc
: Source_Ptr
;
2684 Scan_State
: Saved_Scan_State
;
2686 Not_Null_Present
: Boolean;
2689 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
2690 -- This array holds the list of defining identifiers. The upper bound
2691 -- of 4096 is intended to be essentially infinite, and we do not even
2692 -- bother to check for it being exceeded.
2695 if Token
= Tok_Left_Paren
then
2696 Specification_List
:= New_List
;
2698 P_Pragmas_Misplaced
;
2700 Specification_Loop
: loop
2702 Ident_Sloc
:= Token_Ptr
;
2703 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
2706 while Comma_Present
loop
2707 Num_Idents
:= Num_Idents
+ 1;
2708 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
2713 -- If there are multiple identifiers, we repeatedly scan the
2714 -- type and initialization expression information by resetting
2715 -- the scan pointer (so that we get completely separate trees
2716 -- for each occurrence).
2718 if Num_Idents
> 1 then
2719 Save_Scan_State
(Scan_State
);
2722 -- Loop through defining identifiers in list
2726 Specification_Node
:=
2727 New_Node
(N_Discriminant_Specification
, Ident_Sloc
);
2728 Set_Defining_Identifier
(Specification_Node
, Idents
(Ident
));
2729 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
2731 if Token
= Tok_Access
then
2732 if Ada_Version
= Ada_83
then
2734 ("(Ada 83) access discriminant not allowed!");
2737 Set_Discriminant_Type
2738 (Specification_Node
,
2739 P_Access_Definition
(Not_Null_Present
));
2742 Set_Discriminant_Type
2743 (Specification_Node
, P_Subtype_Mark
);
2745 Set_Null_Exclusion_Present
-- Ada 2005 (AI-231)
2746 (Specification_Node
, Not_Null_Present
);
2750 (Specification_Node
, Init_Expr_Opt
(True));
2753 Set_Prev_Ids
(Specification_Node
, True);
2756 if Ident
< Num_Idents
then
2757 Set_More_Ids
(Specification_Node
, True);
2760 Append
(Specification_Node
, Specification_List
);
2761 exit Ident_Loop
when Ident
= Num_Idents
;
2763 Restore_Scan_State
(Scan_State
);
2764 end loop Ident_Loop
;
2766 exit Specification_Loop
when Token
/= Tok_Semicolon
;
2768 P_Pragmas_Misplaced
;
2769 end loop Specification_Loop
;
2772 return Specification_List
;
2777 end P_Known_Discriminant_Part_Opt
;
2779 -------------------------------------
2780 -- 3.7 DIscriminant Specification --
2781 -------------------------------------
2783 -- Parsed by P_Known_Discriminant_Part_Opt (3.7)
2785 -----------------------------
2786 -- 3.7 Default Expression --
2787 -----------------------------
2789 -- Always parsed (simply as an Expression) by the parent construct
2791 ------------------------------------
2792 -- 3.7.1 Discriminant Constraint --
2793 ------------------------------------
2795 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2797 --------------------------------------------------------
2798 -- 3.7.1 Index or Discriminant Constraint (also 3.6) --
2799 --------------------------------------------------------
2801 -- DISCRIMINANT_CONSTRAINT ::=
2802 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
2804 -- DISCRIMINANT_ASSOCIATION ::=
2805 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2808 -- This routine parses either an index or a discriminant constraint. As
2809 -- is clear from the above grammar, it is often possible to clearly
2810 -- determine which of the two possibilities we have, but there are
2811 -- cases (those in which we have a series of expressions of the same
2812 -- syntactic form as subtype indications), where we cannot tell. Since
2813 -- this means that in any case the semantic phase has to distinguish
2814 -- between the two, there is not much point in the parser trying to
2815 -- distinguish even those cases where the difference is clear. In any
2816 -- case, if we have a situation like:
2818 -- (A => 123, 235 .. 500)
2820 -- it is not clear which of the two items is the wrong one, better to
2821 -- let the semantic phase give a clear message. Consequently, this
2822 -- routine in general returns a list of items which can be either
2823 -- discrete ranges or discriminant associations.
2825 -- The caller has checked that the initial token is a left paren
2827 -- Error recovery: can raise Error_Resync
2829 function P_Index_Or_Discriminant_Constraint
return Node_Id
is
2830 Scan_State
: Saved_Scan_State
;
2831 Constr_Node
: Node_Id
;
2832 Constr_List
: List_Id
;
2833 Expr_Node
: Node_Id
;
2834 Result_Node
: Node_Id
;
2837 Result_Node
:= New_Node
(N_Index_Or_Discriminant_Constraint
, Token_Ptr
);
2839 Constr_List
:= New_List
;
2840 Set_Constraints
(Result_Node
, Constr_List
);
2842 -- The two syntactic forms are a little mixed up, so what we are doing
2843 -- here is looking at the first entry to determine which case we have
2845 -- A discriminant constraint is a list of discriminant associations,
2846 -- which have one of the following possible forms:
2850 -- Id | Id | .. | Id => Expression
2852 -- An index constraint is a list of discrete ranges which have one
2853 -- of the following possible forms:
2856 -- Subtype_Mark range Range
2858 -- Simple_Expression .. Simple_Expression
2860 -- Loop through discriminants in list
2863 -- Check cases of Id => Expression or Id | Id => Expression
2865 if Token
= Tok_Identifier
then
2866 Save_Scan_State
(Scan_State
); -- at Id
2869 if Token
= Tok_Arrow
or else Token
= Tok_Vertical_Bar
then
2870 Restore_Scan_State
(Scan_State
); -- to Id
2871 Append
(P_Discriminant_Association
, Constr_List
);
2874 Restore_Scan_State
(Scan_State
); -- to Id
2878 -- Otherwise scan out an expression and see what we have got
2880 Expr_Node
:= P_Expression_Or_Range_Attribute
;
2882 if Expr_Form
= EF_Range_Attr
then
2883 Append
(Expr_Node
, Constr_List
);
2885 elsif Token
= Tok_Range
then
2886 if Expr_Form
/= EF_Simple_Name
then
2887 Error_Msg_SC
("subtype mark required before RANGE");
2890 Append
(P_Subtype_Indication
(Expr_Node
), Constr_List
);
2893 -- Check Simple_Expression .. Simple_Expression case
2895 elsif Token
= Tok_Dot_Dot
then
2896 Check_Simple_Expression
(Expr_Node
);
2897 Constr_Node
:= New_Node
(N_Range
, Token_Ptr
);
2898 Set_Low_Bound
(Constr_Node
, Expr_Node
);
2900 Expr_Node
:= P_Expression
;
2901 Check_Simple_Expression
(Expr_Node
);
2902 Set_High_Bound
(Constr_Node
, Expr_Node
);
2903 Append
(Constr_Node
, Constr_List
);
2906 -- Case of an expression which could be either form
2909 Append
(Expr_Node
, Constr_List
);
2913 -- Here with a single entry scanned
2916 exit when not Comma_Present
;
2922 end P_Index_Or_Discriminant_Constraint
;
2924 -------------------------------------
2925 -- 3.7.1 Discriminant Association --
2926 -------------------------------------
2928 -- DISCRIMINANT_ASSOCIATION ::=
2929 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2932 -- This routine is used only when the name list is present and the caller
2933 -- has already checked this (by scanning ahead and repositioning the
2936 -- Error_Recovery: cannot raise Error_Resync;
2938 function P_Discriminant_Association
return Node_Id
is
2939 Discr_Node
: Node_Id
;
2940 Names_List
: List_Id
;
2941 Ident_Sloc
: Source_Ptr
;
2944 Ident_Sloc
:= Token_Ptr
;
2945 Names_List
:= New_List
;
2948 Append
(P_Identifier
(C_Vertical_Bar_Arrow
), Names_List
);
2949 exit when Token
/= Tok_Vertical_Bar
;
2953 Discr_Node
:= New_Node
(N_Discriminant_Association
, Ident_Sloc
);
2954 Set_Selector_Names
(Discr_Node
, Names_List
);
2956 Set_Expression
(Discr_Node
, P_Expression
);
2958 end P_Discriminant_Association
;
2960 ---------------------------------
2961 -- 3.8 Record Type Definition --
2962 ---------------------------------
2964 -- RECORD_TYPE_DEFINITION ::=
2965 -- [[abstract] tagged] [limited] RECORD_DEFINITION
2967 -- There is no node in the tree for a record type definition. Instead
2968 -- a record definition node appears, with possible Abstract_Present,
2969 -- Tagged_Present, and Limited_Present flags set appropriately.
2971 ----------------------------
2972 -- 3.8 Record Definition --
2973 ----------------------------
2975 -- RECORD_DEFINITION ::=
2981 -- Note: in the case where a record definition node is used to represent
2982 -- a record type definition, the caller sets the Tagged_Present and
2983 -- Limited_Present flags in the resulting N_Record_Definition node as
2986 -- Note that the RECORD token at the start may be missing in certain
2987 -- error situations, so this function is expected to post the error
2989 -- Error recovery: can raise Error_Resync
2991 function P_Record_Definition
return Node_Id
is
2995 Rec_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
2999 if Token
= Tok_Null
then
3002 Set_Null_Present
(Rec_Node
, True);
3004 -- Case starting with RECORD keyword. Build scope stack entry. For the
3005 -- column, we use the first non-blank character on the line, to deal
3006 -- with situations such as:
3012 -- which is not official RM indentation, but is not uncommon usage
3016 Scope
.Table
(Scope
.Last
).Etyp
:= E_Record
;
3017 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
3018 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
3019 Scope
.Table
(Scope
.Last
).Labl
:= Error
;
3020 Scope
.Table
(Scope
.Last
).Junk
:= (Token
/= Tok_Record
);
3024 Set_Component_List
(Rec_Node
, P_Component_List
);
3027 exit when Check_End
;
3028 Discard_Junk_Node
(P_Component_List
);
3033 end P_Record_Definition
;
3035 -------------------------
3036 -- 3.8 Component List --
3037 -------------------------
3039 -- COMPONENT_LIST ::=
3040 -- COMPONENT_ITEM {COMPONENT_ITEM}
3041 -- | {COMPONENT_ITEM} VARIANT_PART
3044 -- Error recovery: cannot raise Error_Resync
3046 function P_Component_List
return Node_Id
is
3047 Component_List_Node
: Node_Id
;
3048 Decls_List
: List_Id
;
3049 Scan_State
: Saved_Scan_State
;
3052 Component_List_Node
:= New_Node
(N_Component_List
, Token_Ptr
);
3053 Decls_List
:= New_List
;
3055 if Token
= Tok_Null
then
3058 P_Pragmas_Opt
(Decls_List
);
3059 Set_Null_Present
(Component_List_Node
, True);
3060 return Component_List_Node
;
3063 P_Pragmas_Opt
(Decls_List
);
3065 if Token
/= Tok_Case
then
3066 Component_Scan_Loop
: loop
3067 P_Component_Items
(Decls_List
);
3068 P_Pragmas_Opt
(Decls_List
);
3070 exit Component_Scan_Loop
when Token
= Tok_End
3071 or else Token
= Tok_Case
3072 or else Token
= Tok_When
;
3074 -- We are done if we do not have an identifier. However, if
3075 -- we have a misspelled reserved identifier that is in a column
3076 -- to the right of the record definition, we will treat it as
3077 -- an identifier. It turns out to be too dangerous in practice
3078 -- to accept such a mis-spelled identifier which does not have
3079 -- this additional clue that confirms the incorrect spelling.
3081 if Token
/= Tok_Identifier
then
3082 if Start_Column
> Scope
.Table
(Scope
.Last
).Ecol
3083 and then Is_Reserved_Identifier
3085 Save_Scan_State
(Scan_State
); -- at reserved id
3086 Scan
; -- possible reserved id
3088 if Token
= Tok_Comma
or else Token
= Tok_Colon
then
3089 Restore_Scan_State
(Scan_State
);
3090 Scan_Reserved_Identifier
(Force_Msg
=> True);
3092 -- Note reserved identifier used as field name after
3093 -- all because not followed by colon or comma
3096 Restore_Scan_State
(Scan_State
);
3097 exit Component_Scan_Loop
;
3100 -- Non-identifier that definitely was not reserved id
3103 exit Component_Scan_Loop
;
3106 end loop Component_Scan_Loop
;
3109 if Token
= Tok_Case
then
3110 Set_Variant_Part
(Component_List_Node
, P_Variant_Part
);
3112 -- Check for junk after variant part
3114 if Token
= Tok_Identifier
then
3115 Save_Scan_State
(Scan_State
);
3116 Scan
; -- past identifier
3118 if Token
= Tok_Colon
then
3119 Restore_Scan_State
(Scan_State
);
3120 Error_Msg_SC
("component may not follow variant part");
3121 Discard_Junk_Node
(P_Component_List
);
3123 elsif Token
= Tok_Case
then
3124 Restore_Scan_State
(Scan_State
);
3125 Error_Msg_SC
("only one variant part allowed in a record");
3126 Discard_Junk_Node
(P_Component_List
);
3129 Restore_Scan_State
(Scan_State
);
3135 Set_Component_Items
(Component_List_Node
, Decls_List
);
3136 return Component_List_Node
;
3137 end P_Component_List
;
3139 -------------------------
3140 -- 3.8 Component Item --
3141 -------------------------
3143 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
3145 -- COMPONENT_DECLARATION ::=
3146 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
3147 -- [:= DEFAULT_EXPRESSION];
3149 -- COMPONENT_DEFINITION ::=
3150 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
3152 -- Error recovery: cannot raise Error_Resync, if an error occurs,
3153 -- the scan is positioned past the following semicolon.
3155 -- Note: we do not yet allow representation clauses to appear as component
3156 -- items, do we need to add this capability sometime in the future ???
3158 procedure P_Component_Items
(Decls
: List_Id
) is
3159 Aliased_Present
: Boolean := False;
3160 CompDef_Node
: Node_Id
;
3161 Decl_Node
: Node_Id
;
3162 Scan_State
: Saved_Scan_State
;
3163 Not_Null_Present
: Boolean := False;
3166 Ident_Sloc
: Source_Ptr
;
3168 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
3169 -- This array holds the list of defining identifiers. The upper bound
3170 -- of 4096 is intended to be essentially infinite, and we do not even
3171 -- bother to check for it being exceeded.
3174 if Token
/= Tok_Identifier
then
3175 Error_Msg_SC
("component declaration expected");
3176 Resync_Past_Semicolon
;
3180 Ident_Sloc
:= Token_Ptr
;
3181 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
3184 while Comma_Present
loop
3185 Num_Idents
:= Num_Idents
+ 1;
3186 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
3191 -- If there are multiple identifiers, we repeatedly scan the
3192 -- type and initialization expression information by resetting
3193 -- the scan pointer (so that we get completely separate trees
3194 -- for each occurrence).
3196 if Num_Idents
> 1 then
3197 Save_Scan_State
(Scan_State
);
3200 -- Loop through defining identifiers in list
3205 -- The following block is present to catch Error_Resync
3206 -- which causes the parse to be reset past the semicolon
3209 Decl_Node
:= New_Node
(N_Component_Declaration
, Ident_Sloc
);
3210 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
3212 if Token
= Tok_Constant
then
3213 Error_Msg_SC
("constant components are not permitted");
3217 CompDef_Node
:= New_Node
(N_Component_Definition
, Token_Ptr
);
3219 if Token_Name
= Name_Aliased
then
3220 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
3223 if Token
= Tok_Aliased
then
3224 Aliased_Present
:= True;
3225 Scan
; -- past ALIASED
3228 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/AI-254)
3230 -- Ada 2005 (AI-230): Access Definition case
3232 if Token
= Tok_Access
then
3233 if Ada_Version
< Ada_05
then
3235 ("generalized use of anonymous access types " &
3236 "is an Ada 2005 extension");
3237 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
3240 if Aliased_Present
then
3241 Error_Msg_SP
("ALIASED not allowed here");
3244 Set_Subtype_Indication
(CompDef_Node
, Empty
);
3245 Set_Aliased_Present
(CompDef_Node
, False);
3246 Set_Access_Definition
(CompDef_Node
,
3247 P_Access_Definition
(Not_Null_Present
));
3250 Set_Access_Definition
(CompDef_Node
, Empty
);
3251 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
3252 Set_Null_Exclusion_Present
(CompDef_Node
, Not_Null_Present
);
3254 if Token
= Tok_Array
then
3256 ("anonymous arrays not allowed as components");
3260 Set_Subtype_Indication
(CompDef_Node
,
3261 P_Subtype_Indication
(Not_Null_Present
));
3264 Set_Component_Definition
(Decl_Node
, CompDef_Node
);
3265 Set_Expression
(Decl_Node
, Init_Expr_Opt
);
3268 Set_Prev_Ids
(Decl_Node
, True);
3271 if Ident
< Num_Idents
then
3272 Set_More_Ids
(Decl_Node
, True);
3275 Append
(Decl_Node
, Decls
);
3278 when Error_Resync
=>
3279 if Token
/= Tok_End
then
3280 Resync_Past_Semicolon
;
3284 exit Ident_Loop
when Ident
= Num_Idents
;
3286 Restore_Scan_State
(Scan_State
);
3288 end loop Ident_Loop
;
3291 end P_Component_Items
;
3293 --------------------------------
3294 -- 3.8 Component Declaration --
3295 --------------------------------
3297 -- Parsed by P_Component_Items (3.8)
3299 -------------------------
3300 -- 3.8.1 Variant Part --
3301 -------------------------
3304 -- case discriminant_DIRECT_NAME is
3309 -- The caller has checked that the initial token is CASE
3311 -- Error recovery: cannot raise Error_Resync
3313 function P_Variant_Part
return Node_Id
is
3314 Variant_Part_Node
: Node_Id
;
3315 Variants_List
: List_Id
;
3316 Case_Node
: Node_Id
;
3319 Variant_Part_Node
:= New_Node
(N_Variant_Part
, Token_Ptr
);
3321 Scope
.Table
(Scope
.Last
).Etyp
:= E_Case
;
3322 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
3323 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
3326 Case_Node
:= P_Expression
;
3327 Set_Name
(Variant_Part_Node
, Case_Node
);
3329 if Nkind
(Case_Node
) /= N_Identifier
then
3330 Set_Name
(Variant_Part_Node
, Error
);
3331 Error_Msg
("discriminant name expected", Sloc
(Case_Node
));
3335 Variants_List
:= New_List
;
3336 P_Pragmas_Opt
(Variants_List
);
3338 -- Test missing variant
3340 if Token
= Tok_End
then
3341 Error_Msg_BC
("WHEN expected (must have at least one variant)");
3343 Append
(P_Variant
, Variants_List
);
3346 -- Loop through variants, note that we allow if in place of when,
3347 -- this error will be detected and handled in P_Variant.
3350 P_Pragmas_Opt
(Variants_List
);
3352 if Token
/= Tok_When
3353 and then Token
/= Tok_If
3354 and then Token
/= Tok_Others
3356 exit when Check_End
;
3359 Append
(P_Variant
, Variants_List
);
3362 Set_Variants
(Variant_Part_Node
, Variants_List
);
3363 return Variant_Part_Node
;
3366 --------------------
3368 --------------------
3371 -- when DISCRETE_CHOICE_LIST =>
3374 -- Error recovery: cannot raise Error_Resync
3376 -- The initial token on entry is either WHEN, IF or OTHERS
3378 function P_Variant
return Node_Id
is
3379 Variant_Node
: Node_Id
;
3382 -- Special check to recover nicely from use of IF in place of WHEN
3384 if Token
= Tok_If
then
3391 Variant_Node
:= New_Node
(N_Variant
, Prev_Token_Ptr
);
3392 Set_Discrete_Choices
(Variant_Node
, P_Discrete_Choice_List
);
3394 Set_Component_List
(Variant_Node
, P_Component_List
);
3395 return Variant_Node
;
3398 ---------------------------------
3399 -- 3.8.1 Discrete Choice List --
3400 ---------------------------------
3402 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
3404 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
3406 -- Note: in Ada 83, the expression must be a simple expression
3408 -- Error recovery: cannot raise Error_Resync
3410 function P_Discrete_Choice_List
return List_Id
is
3412 Expr_Node
: Node_Id
;
3413 Choice_Node
: Node_Id
;
3416 Choices
:= New_List
;
3419 if Token
= Tok_Others
then
3420 Append
(New_Node
(N_Others_Choice
, Token_Ptr
), Choices
);
3421 Scan
; -- past OTHERS
3425 Expr_Node
:= No_Right_Paren
(P_Expression_Or_Range_Attribute
);
3427 if Token
= Tok_Colon
3428 and then Nkind
(Expr_Node
) = N_Identifier
3430 Error_Msg_SP
("label not permitted in this context");
3433 elsif Expr_Form
= EF_Range_Attr
then
3434 Append
(Expr_Node
, Choices
);
3436 elsif Token
= Tok_Dot_Dot
then
3437 Check_Simple_Expression
(Expr_Node
);
3438 Choice_Node
:= New_Node
(N_Range
, Token_Ptr
);
3439 Set_Low_Bound
(Choice_Node
, Expr_Node
);
3441 Expr_Node
:= P_Expression_No_Right_Paren
;
3442 Check_Simple_Expression
(Expr_Node
);
3443 Set_High_Bound
(Choice_Node
, Expr_Node
);
3444 Append
(Choice_Node
, Choices
);
3446 elsif Expr_Form
= EF_Simple_Name
then
3447 if Token
= Tok_Range
then
3448 Append
(P_Subtype_Indication
(Expr_Node
), Choices
);
3450 elsif Token
in Token_Class_Consk
then
3452 ("the only constraint allowed here " &
3453 "is a range constraint");
3454 Discard_Junk_Node
(P_Constraint_Opt
);
3455 Append
(Expr_Node
, Choices
);
3458 Append
(Expr_Node
, Choices
);
3462 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
3463 Append
(Expr_Node
, Choices
);
3467 when Error_Resync
=>
3473 if Token
= Tok_Comma
then
3474 Error_Msg_SC
(""","" should be ""'|""");
3476 exit when Token
/= Tok_Vertical_Bar
;
3479 Scan
; -- past | or comma
3483 end P_Discrete_Choice_List
;
3485 ----------------------------
3486 -- 3.8.1 Discrete Choice --
3487 ----------------------------
3489 -- Parsed by P_Discrete_Choice_List (3.8.1)
3491 ----------------------------------
3492 -- 3.9.1 Record Extension Part --
3493 ----------------------------------
3495 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
3497 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
3499 --------------------------------------
3500 -- 3.9.4 Interface Type Definition --
3501 --------------------------------------
3503 -- INTERFACE_TYPE_DEFINITION ::=
3504 -- [limited | task | protected | synchronized] interface
3505 -- [AND interface_list]
3507 -- Error recovery: cannot raise Error_Resync
3509 function P_Interface_Type_Definition
3510 (Is_Synchronized
: Boolean) return Node_Id
3512 Typedef_Node
: Node_Id
;
3515 if Ada_Version
< Ada_05
then
3516 Error_Msg_SP
("abstract interface is an Ada 2005 extension");
3517 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
3520 Scan
; -- past INTERFACE
3522 -- Ada 2005 (AI-345): In case of synchronized interfaces and
3523 -- interfaces with a null list of interfaces we build a
3524 -- record_definition node.
3527 or else Token
= Tok_Semicolon
3529 Typedef_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
3531 Set_Abstract_Present
(Typedef_Node
);
3532 Set_Tagged_Present
(Typedef_Node
);
3533 Set_Null_Present
(Typedef_Node
);
3534 Set_Interface_Present
(Typedef_Node
);
3537 and then Token
= Tok_And
3540 Set_Interface_List
(Typedef_Node
, New_List
);
3543 Append
(P_Qualified_Simple_Name
,
3544 Interface_List
(Typedef_Node
));
3545 exit when Token
/= Tok_And
;
3550 -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have
3551 -- a list of interfaces we build a derived_type_definition node. This
3552 -- simplifies the semantic analysis (and hence further mainteinance)
3555 if Token
/= Tok_And
then
3556 Error_Msg_AP
("AND expected");
3561 Typedef_Node
:= New_Node
(N_Derived_Type_Definition
, Token_Ptr
);
3563 Set_Abstract_Present
(Typedef_Node
);
3564 Set_Interface_Present
(Typedef_Node
);
3565 Set_Subtype_Indication
(Typedef_Node
, P_Qualified_Simple_Name
);
3567 Set_Record_Extension_Part
(Typedef_Node
,
3568 New_Node
(N_Record_Definition
, Token_Ptr
));
3569 Set_Null_Present
(Record_Extension_Part
(Typedef_Node
));
3571 if Token
= Tok_And
then
3572 Set_Interface_List
(Typedef_Node
, New_List
);
3576 Append
(P_Qualified_Simple_Name
,
3577 Interface_List
(Typedef_Node
));
3578 exit when Token
/= Tok_And
;
3584 return Typedef_Node
;
3585 end P_Interface_Type_Definition
;
3587 ----------------------------------
3588 -- 3.10 Access Type Definition --
3589 ----------------------------------
3591 -- ACCESS_TYPE_DEFINITION ::=
3592 -- ACCESS_TO_OBJECT_DEFINITION
3593 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3595 -- ACCESS_TO_OBJECT_DEFINITION ::=
3596 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
3598 -- GENERAL_ACCESS_MODIFIER ::= all | constant
3600 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3601 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3602 -- | [NULL_EXCLUSION] access [protected] function
3603 -- PARAMETER_AND_RESULT_PROFILE
3605 -- PARAMETER_PROFILE ::= [FORMAL_PART]
3607 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
3609 -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already
3610 -- parsed the null_exclusion part and has also removed the ACCESS token;
3611 -- otherwise the caller has just checked that the initial token is ACCESS
3613 -- Error recovery: can raise Error_Resync
3615 function P_Access_Type_Definition
3616 (Header_Already_Parsed
: Boolean := False) return Node_Id
is
3617 Access_Loc
: constant Source_Ptr
:= Token_Ptr
;
3618 Prot_Flag
: Boolean;
3619 Not_Null_Present
: Boolean := False;
3620 Type_Def_Node
: Node_Id
;
3621 Result_Not_Null
: Boolean;
3622 Result_Node
: Node_Id
;
3624 procedure Check_Junk_Subprogram_Name
;
3625 -- Used in access to subprogram definition cases to check for an
3626 -- identifier or operator symbol that does not belong.
3628 procedure Check_Junk_Subprogram_Name
is
3629 Saved_State
: Saved_Scan_State
;
3632 if Token
= Tok_Identifier
or else Token
= Tok_Operator_Symbol
then
3633 Save_Scan_State
(Saved_State
);
3634 Scan
; -- past possible junk subprogram name
3636 if Token
= Tok_Left_Paren
or else Token
= Tok_Semicolon
then
3637 Error_Msg_SP
("unexpected subprogram name ignored");
3641 Restore_Scan_State
(Saved_State
);
3644 end Check_Junk_Subprogram_Name
;
3646 -- Start of processing for P_Access_Type_Definition
3649 if not Header_Already_Parsed
then
3650 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
3651 Scan
; -- past ACCESS
3654 if Token_Name
= Name_Protected
then
3655 Check_95_Keyword
(Tok_Protected
, Tok_Procedure
);
3656 Check_95_Keyword
(Tok_Protected
, Tok_Function
);
3659 Prot_Flag
:= (Token
= Tok_Protected
);
3662 Scan
; -- past PROTECTED
3664 if Token
/= Tok_Procedure
and then Token
/= Tok_Function
then
3665 Error_Msg_SC
("FUNCTION or PROCEDURE expected");
3669 if Token
= Tok_Procedure
then
3670 if Ada_Version
= Ada_83
then
3671 Error_Msg_SC
("(Ada 83) access to procedure not allowed!");
3674 Type_Def_Node
:= New_Node
(N_Access_Procedure_Definition
, Access_Loc
);
3675 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3676 Scan
; -- past PROCEDURE
3677 Check_Junk_Subprogram_Name
;
3678 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
3679 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
3681 elsif Token
= Tok_Function
then
3682 if Ada_Version
= Ada_83
then
3683 Error_Msg_SC
("(Ada 83) access to function not allowed!");
3686 Type_Def_Node
:= New_Node
(N_Access_Function_Definition
, Access_Loc
);
3687 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3688 Scan
; -- past FUNCTION
3689 Check_Junk_Subprogram_Name
;
3690 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
3691 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
3694 Result_Not_Null
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
3696 -- Ada 2005 (AI-318-02)
3698 if Token
= Tok_Access
then
3699 if Ada_Version
< Ada_05
then
3701 ("anonymous access result type is an Ada 2005 extension");
3702 Error_Msg_SC
("\unit must be compiled with -gnat05 switch");
3705 Result_Node
:= P_Access_Definition
(Result_Not_Null
);
3708 Result_Node
:= P_Subtype_Mark
;
3712 -- Note: A null exclusion given on the result type needs to
3713 -- be coded by a distinct flag, since Null_Exclusion_Present
3714 -- on an access-to-function type pertains to a null exclusion
3715 -- on the access type itself (as set above). ???
3716 -- Set_Null_Exclusion_Present??? (Type_Def_Node, Result_Not_Null);
3718 Set_Result_Definition
(Type_Def_Node
, Result_Node
);
3722 New_Node
(N_Access_To_Object_Definition
, Access_Loc
);
3723 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3725 if Token
= Tok_All
or else Token
= Tok_Constant
then
3726 if Ada_Version
= Ada_83
then
3727 Error_Msg_SC
("(Ada 83) access modifier not allowed!");
3730 if Token
= Tok_All
then
3731 Set_All_Present
(Type_Def_Node
, True);
3734 Set_Constant_Present
(Type_Def_Node
, True);
3737 Scan
; -- past ALL or CONSTANT
3740 Set_Subtype_Indication
(Type_Def_Node
,
3741 P_Subtype_Indication
(Not_Null_Present
));
3744 return Type_Def_Node
;
3745 end P_Access_Type_Definition
;
3747 ---------------------------------------
3748 -- 3.10 Access To Object Definition --
3749 ---------------------------------------
3751 -- Parsed by P_Access_Type_Definition (3.10)
3753 -----------------------------------
3754 -- 3.10 General Access Modifier --
3755 -----------------------------------
3757 -- Parsed by P_Access_Type_Definition (3.10)
3759 -------------------------------------------
3760 -- 3.10 Access To Subprogram Definition --
3761 -------------------------------------------
3763 -- Parsed by P_Access_Type_Definition (3.10)
3765 -----------------------------
3766 -- 3.10 Access Definition --
3767 -----------------------------
3769 -- ACCESS_DEFINITION ::=
3770 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3771 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3773 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3774 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3775 -- | [NULL_EXCLUSION] access [protected] function
3776 -- PARAMETER_AND_RESULT_PROFILE
3778 -- The caller has parsed the null-exclusion part and it has also checked
3779 -- that the next token is ACCESS
3781 -- Error recovery: cannot raise Error_Resync
3783 function P_Access_Definition
3784 (Null_Exclusion_Present
: Boolean) return Node_Id
is
3786 Subp_Node
: Node_Id
;
3789 Def_Node
:= New_Node
(N_Access_Definition
, Token_Ptr
);
3790 Scan
; -- past ACCESS
3792 -- Ada 2005 (AI-254): Access_To_Subprogram_Definition
3794 if Token
= Tok_Protected
3795 or else Token
= Tok_Procedure
3796 or else Token
= Tok_Function
3798 if Ada_Version
< Ada_05
then
3799 Error_Msg_SP
("access-to-subprogram is an Ada 2005 extension");
3800 Error_Msg_SP
("\unit should be compiled with -gnat05 switch");
3803 Subp_Node
:= P_Access_Type_Definition
(Header_Already_Parsed
=> True);
3804 Set_Null_Exclusion_Present
(Subp_Node
, Null_Exclusion_Present
);
3805 Set_Access_To_Subprogram_Definition
(Def_Node
, Subp_Node
);
3807 -- Ada 2005 (AI-231)
3808 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3811 Set_Null_Exclusion_Present
(Def_Node
, Null_Exclusion_Present
);
3813 if Token
= Tok_All
then
3814 if Ada_Version
< Ada_05
then
3816 ("access-all in this context is an Ada 2005 extension");
3817 Error_Msg_SP
("\unit should be compiled with -gnat05 switch");
3821 Set_All_Present
(Def_Node
);
3823 elsif Token
= Tok_Constant
then
3824 if Ada_Version
< Ada_05
then
3825 Error_Msg_SP
("access-to-constant is an Ada 2005 extension");
3826 Error_Msg_SP
("\unit should be compiled with -gnat05 switch");
3829 Scan
; -- past CONSTANT
3830 Set_Constant_Present
(Def_Node
);
3833 Set_Subtype_Mark
(Def_Node
, P_Subtype_Mark
);
3838 end P_Access_Definition
;
3840 -----------------------------------------
3841 -- 3.10.1 Incomplete Type Declaration --
3842 -----------------------------------------
3844 -- Parsed by P_Type_Declaration (3.2.1)
3846 ----------------------------
3847 -- 3.11 Declarative Part --
3848 ----------------------------
3850 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
3852 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items
3853 -- handles errors, and returns cleanly after an error has occurred)
3855 function P_Declarative_Part
return List_Id
is
3860 -- Indicate no bad declarations detected yet. This will be reset by
3861 -- P_Declarative_Items if a bad declaration is discovered.
3863 Missing_Begin_Msg
:= No_Error_Msg
;
3865 -- Get rid of active SIS entry from outer scope. This means we will
3866 -- miss some nested cases, but it doesn't seem worth the effort. See
3867 -- discussion in Par for further details
3869 SIS_Entry_Active
:= False;
3872 -- Loop to scan out the declarations
3875 P_Declarative_Items
(Decls
, Done
, In_Spec
=> False);
3879 -- Get rid of active SIS entry which is left set only if we scanned a
3880 -- procedure declaration and have not found the body. We could give
3881 -- an error message, but that really would be usurping the role of
3882 -- semantic analysis (this really is a missing body case).
3884 SIS_Entry_Active
:= False;
3886 end P_Declarative_Part
;
3888 ----------------------------
3889 -- 3.11 Declarative Item --
3890 ----------------------------
3892 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
3894 -- Can return Error if a junk declaration is found, or Empty if no
3895 -- declaration is found (i.e. a token ending declarations, such as
3896 -- BEGIN or END is encountered).
3898 -- Error recovery: cannot raise Error_Resync. If an error resync occurs,
3899 -- then the scan is set past the next semicolon and Error is returned.
3901 procedure P_Declarative_Items
3906 Scan_State
: Saved_Scan_State
;
3909 if Style_Check
then Style
.Check_Indentation
; end if;
3913 when Tok_Function
=>
3915 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3921 -- Check for loop (premature statement)
3923 Save_Scan_State
(Scan_State
);
3926 if Token
= Tok_Identifier
then
3927 Scan
; -- past identifier
3929 if Token
= Tok_In
then
3930 Restore_Scan_State
(Scan_State
);
3931 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
3936 -- Not a loop, so must be rep clause
3938 Restore_Scan_State
(Scan_State
);
3939 Append
(P_Representation_Clause
, Decls
);
3944 Append
(P_Generic
, Decls
);
3947 when Tok_Identifier
=>
3949 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
3951 -- Ada2005: A subprogram declaration can start with "not" or
3952 -- "overriding". In older versions, "overriding" is handled
3953 -- like an identifier, with the appropriate warning.
3957 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3960 when Tok_Overriding
=>
3962 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3967 Append
(P_Package
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3971 Append
(P_Pragma
, Decls
);
3974 when Tok_Procedure
=>
3976 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3979 when Tok_Protected
=>
3981 Scan
; -- past PROTECTED
3982 Append
(P_Protected
, Decls
);
3987 Append
(P_Subtype_Declaration
, Decls
);
3993 Append
(P_Task
, Decls
);
3998 Append
(P_Type_Declaration
, Decls
);
4003 Append
(P_Use_Clause
, Decls
);
4008 Error_Msg_SC
("WITH can only appear in context clause");
4011 -- BEGIN terminates the scan of a sequence of declarations unless
4012 -- there is a missing subprogram body, see section on handling
4013 -- semicolon in place of IS. We only treat the begin as satisfying
4014 -- the subprogram declaration if it falls in the expected column
4018 if SIS_Entry_Active
and then Start_Column
>= SIS_Ecol
then
4020 -- Here we have the case where a BEGIN is encountered during
4021 -- declarations in a declarative part, or at the outer level,
4022 -- and there is a subprogram declaration outstanding for which
4023 -- no body has been supplied. This is the case where we assume
4024 -- that the semicolon in the subprogram declaration should
4025 -- really have been is. The active SIS entry describes the
4026 -- subprogram declaration. On return the declaration has been
4027 -- modified to become a body.
4030 Specification_Node
: Node_Id
;
4031 Decl_Node
: Node_Id
;
4032 Body_Node
: Node_Id
;
4035 -- First issue the error message. If we had a missing
4036 -- semicolon in the declaration, then change the message
4037 -- to <missing "is">
4039 if SIS_Missing_Semicolon_Message
/= No_Error_Msg
then
4040 Change_Error_Text
-- Replace: "missing "";"" "
4041 (SIS_Missing_Semicolon_Message
, "missing ""is""");
4043 -- Otherwise we saved the semicolon position, so complain
4046 Error_Msg
(""";"" should be IS", SIS_Semicolon_Sloc
);
4049 -- The next job is to fix up any declarations that occurred
4050 -- between the procedure header and the BEGIN. These got
4051 -- chained to the outer declarative region (immediately
4052 -- after the procedure declaration) and they should be
4053 -- chained to the subprogram itself, which is a body
4054 -- rather than a spec.
4056 Specification_Node
:= Specification
(SIS_Declaration_Node
);
4057 Change_Node
(SIS_Declaration_Node
, N_Subprogram_Body
);
4058 Body_Node
:= SIS_Declaration_Node
;
4059 Set_Specification
(Body_Node
, Specification_Node
);
4060 Set_Declarations
(Body_Node
, New_List
);
4063 Decl_Node
:= Remove_Next
(Body_Node
);
4064 exit when Decl_Node
= Empty
;
4065 Append
(Decl_Node
, Declarations
(Body_Node
));
4068 -- Now make the scope table entry for the Begin-End and
4072 Scope
.Table
(Scope
.Last
).Sloc
:= SIS_Sloc
;
4073 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
4074 Scope
.Table
(Scope
.Last
).Ecol
:= SIS_Ecol
;
4075 Scope
.Table
(Scope
.Last
).Labl
:= SIS_Labl
;
4076 Scope
.Table
(Scope
.Last
).Lreq
:= False;
4077 SIS_Entry_Active
:= False;
4079 Set_Handled_Statement_Sequence
(Body_Node
,
4080 P_Handled_Sequence_Of_Statements
);
4081 End_Statements
(Handled_Statement_Sequence
(Body_Node
));
4090 -- Normally an END terminates the scan for basic declarative
4091 -- items. The one exception is END RECORD, which is probably
4092 -- left over from some other junk.
4095 Save_Scan_State
(Scan_State
); -- at END
4098 if Token
= Tok_Record
then
4099 Error_Msg_SP
("no RECORD for this `end record`!");
4100 Scan
; -- past RECORD
4104 Restore_Scan_State
(Scan_State
); -- to END
4108 -- The following tokens which can only be the start of a statement
4109 -- are considered to end a declarative part (i.e. we have a missing
4110 -- BEGIN situation). We are fairly conservative in making this
4111 -- judgment, because it is a real mess to go into statement mode
4112 -- prematurely in response to a junk declaration.
4127 -- But before we decide that it's a statement, let's check for
4128 -- a reserved word misused as an identifier.
4130 if Is_Reserved_Identifier
then
4131 Save_Scan_State
(Scan_State
);
4132 Scan
; -- past the token
4134 -- If reserved identifier not followed by colon or comma, then
4135 -- this is most likely an assignment statement to the bad id.
4137 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
4138 Restore_Scan_State
(Scan_State
);
4139 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4142 -- Otherwise we have a declaration of the bad id
4145 Restore_Scan_State
(Scan_State
);
4146 Scan_Reserved_Identifier
(Force_Msg
=> True);
4147 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4150 -- If not reserved identifier, then it's definitely a statement
4153 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4157 -- The token RETURN may well also signal a missing BEGIN situation,
4158 -- however, we never let it end the declarative part, because it may
4159 -- also be part of a half-baked function declaration.
4162 Error_Msg_SC
("misplaced RETURN statement");
4165 -- PRIVATE definitely terminates the declarations in a spec,
4166 -- and is an error in a body.
4172 Error_Msg_SC
("PRIVATE not allowed in body");
4173 Scan
; -- past PRIVATE
4176 -- An end of file definitely terminates the declarations!
4181 -- The remaining tokens do not end the scan, but cannot start a
4182 -- valid declaration, so we signal an error and resynchronize.
4183 -- But first check for misuse of a reserved identifier.
4187 -- Here we check for a reserved identifier
4189 if Is_Reserved_Identifier
then
4190 Save_Scan_State
(Scan_State
);
4191 Scan
; -- past the token
4193 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
4194 Restore_Scan_State
(Scan_State
);
4195 Set_Declaration_Expected
;
4198 Restore_Scan_State
(Scan_State
);
4199 Scan_Reserved_Identifier
(Force_Msg
=> True);
4201 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4205 Set_Declaration_Expected
;
4210 -- To resynchronize after an error, we scan to the next semicolon and
4211 -- return with Done = False, indicating that there may still be more
4212 -- valid declarations to come.
4215 when Error_Resync
=>
4216 Resync_Past_Semicolon
;
4218 end P_Declarative_Items
;
4220 ----------------------------------
4221 -- 3.11 Basic Declarative Item --
4222 ----------------------------------
4224 -- BASIC_DECLARATIVE_ITEM ::=
4225 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
4227 -- Scan zero or more basic declarative items
4229 -- Error recovery: cannot raise Error_Resync. If an error is detected, then
4230 -- the scan pointer is repositioned past the next semicolon, and the scan
4231 -- for declarative items continues.
4233 function P_Basic_Declarative_Items
return List_Id
is
4240 -- Indicate no bad declarations detected yet in the current context:
4241 -- visible or private declarations of a package spec.
4243 Missing_Begin_Msg
:= No_Error_Msg
;
4245 -- Get rid of active SIS entry from outer scope. This means we will
4246 -- miss some nested cases, but it doesn't seem worth the effort. See
4247 -- discussion in Par for further details
4249 SIS_Entry_Active
:= False;
4251 -- Loop to scan out declarations
4256 P_Declarative_Items
(Decls
, Done
, In_Spec
=> True);
4260 -- Get rid of active SIS entry. This is set only if we have scanned a
4261 -- procedure declaration and have not found the body. We could give
4262 -- an error message, but that really would be usurping the role of
4263 -- semantic analysis (this really is a case of a missing body).
4265 SIS_Entry_Active
:= False;
4267 -- Test for assorted illegal declarations not diagnosed elsewhere
4269 Decl
:= First
(Decls
);
4271 while Present
(Decl
) loop
4272 Kind
:= Nkind
(Decl
);
4274 -- Test for body scanned, not acceptable as basic decl item
4276 if Kind
= N_Subprogram_Body
or else
4277 Kind
= N_Package_Body
or else
4278 Kind
= N_Task_Body
or else
4279 Kind
= N_Protected_Body
4282 ("proper body not allowed in package spec", Sloc
(Decl
));
4284 -- Test for body stub scanned, not acceptable as basic decl item
4286 elsif Kind
in N_Body_Stub
then
4288 ("body stub not allowed in package spec", Sloc
(Decl
));
4290 elsif Kind
= N_Assignment_Statement
then
4292 ("assignment statement not allowed in package spec",
4300 end P_Basic_Declarative_Items
;
4306 -- For proper body, see below
4307 -- For body stub, see 10.1.3
4309 -----------------------
4310 -- 3.11 Proper Body --
4311 -----------------------
4313 -- Subprogram body is parsed by P_Subprogram (6.1)
4314 -- Package body is parsed by P_Package (7.1)
4315 -- Task body is parsed by P_Task (9.1)
4316 -- Protected body is parsed by P_Protected (9.4)
4318 ------------------------------
4319 -- Set_Declaration_Expected --
4320 ------------------------------
4322 procedure Set_Declaration_Expected
is
4324 Error_Msg_SC
("declaration expected");
4326 if Missing_Begin_Msg
= No_Error_Msg
then
4327 Missing_Begin_Msg
:= Get_Msg_Id
;
4329 end Set_Declaration_Expected
;
4331 ----------------------
4332 -- Skip_Declaration --
4333 ----------------------
4335 procedure Skip_Declaration
(S
: List_Id
) is
4336 Dummy_Done
: Boolean;
4339 P_Declarative_Items
(S
, Dummy_Done
, False);
4340 end Skip_Declaration
;
4342 -----------------------------------------
4343 -- Statement_When_Declaration_Expected --
4344 -----------------------------------------
4346 procedure Statement_When_Declaration_Expected
4352 -- Case of second occurrence of statement in one declaration sequence
4354 if Missing_Begin_Msg
/= No_Error_Msg
then
4356 -- In the procedure spec case, just ignore it, we only give one
4357 -- message for the first occurrence, since otherwise we may get
4358 -- horrible cascading if BODY was missing in the header line.
4363 -- In the declarative part case, take a second statement as a sure
4364 -- sign that we really have a missing BEGIN, and end the declarative
4365 -- part now. Note that the caller will fix up the first message to
4366 -- say "missing BEGIN" so that's how the error will be signalled.
4373 -- Case of first occurrence of unexpected statement
4376 -- If we are in a package spec, then give message of statement
4377 -- not allowed in package spec. This message never gets changed.
4380 Error_Msg_SC
("statement not allowed in package spec");
4382 -- If in declarative part, then we give the message complaining
4383 -- about finding a statement when a declaration is expected. This
4384 -- gets changed to a complaint about a missing BEGIN if we later
4385 -- find that no BEGIN is present.
4388 Error_Msg_SC
("statement not allowed in declarative part");
4391 -- Capture message Id. This is used for two purposes, first to
4392 -- stop multiple messages, see test above, and second, to allow
4393 -- the replacement of the message in the declarative part case.
4395 Missing_Begin_Msg
:= Get_Msg_Id
;
4398 -- In all cases except the case in which we decided to terminate the
4399 -- declaration sequence on a second error, we scan out the statement
4400 -- and append it to the list of declarations (note that the semantics
4401 -- can handle statements in a declaration list so if we proceed to
4402 -- call the semantic phase, all will be (reasonably) well!
4404 Append_List_To
(Decls
, P_Sequence_Of_Statements
(SS_Unco
));
4406 -- Done is set to False, since we want to continue the scan of
4407 -- declarations, hoping that this statement was a temporary glitch.
4408 -- If we indeed are now in the statement part (i.e. this was a missing
4409 -- BEGIN, then it's not terrible, we will simply keep calling this
4410 -- procedure to process the statements one by one, and then finally
4411 -- hit the missing BEGIN, which will clean up the error message.
4414 end Statement_When_Declaration_Expected
;