1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005, 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
);
1793 if Token
= Tok_Abstract
then
1794 Error_Msg_SC
("ABSTRACT must come before NEW, not after");
1798 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1799 Set_Null_Exclusion_Present
(Typedef_Node
, Not_Null_Present
);
1800 Set_Subtype_Indication
(Typedef_Node
,
1801 P_Subtype_Indication
(Not_Null_Present
));
1803 -- Ada 2005 (AI-251): Deal with interfaces
1805 if Token
= Tok_And
then
1808 if Ada_Version
< Ada_05
then
1810 ("abstract interface is an Ada 2005 extension");
1811 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1814 Set_Interface_List
(Typedef_Node
, New_List
);
1817 Append
(P_Qualified_Simple_Name
, Interface_List
(Typedef_Node
));
1818 exit when Token
/= Tok_And
;
1822 if Token
/= Tok_With
then
1823 Error_Msg_SC
("WITH expected");
1828 -- Deal with record extension, note that we assume that a WITH is
1829 -- missing in the case of "type X is new Y record ..." or in the
1830 -- case of "type X is new Y null record".
1833 or else Token
= Tok_Record
1834 or else Token
= Tok_Null
1836 T_With
; -- past WITH or give error message
1838 if Token
= Tok_Limited
then
1840 ("LIMITED keyword not allowed in private extension");
1841 Scan
; -- ignore LIMITED
1844 -- Private extension declaration
1846 if Token
= Tok_Private
then
1847 Scan
; -- past PRIVATE
1849 -- Throw away the type definition node and build the type
1850 -- declaration node. Note the caller must set the Sloc,
1851 -- Discriminant_Specifications, Unknown_Discriminants_Present,
1852 -- and Defined_Identifier fields in the returned node.
1855 Make_Private_Extension_Declaration
(No_Location
,
1856 Defining_Identifier
=> Empty
,
1857 Subtype_Indication
=> Subtype_Indication
(Typedef_Node
),
1858 Abstract_Present
=> Abstract_Present
(Typedef_Node
),
1859 Interface_List
=> Interface_List
(Typedef_Node
));
1861 Delete_Node
(Typedef_Node
);
1862 return Typedecl_Node
;
1864 -- Derived type definition with record extension part
1867 Set_Record_Extension_Part
(Typedef_Node
, P_Record_Definition
);
1868 return Typedef_Node
;
1871 -- Derived type definition with no record extension part
1874 return Typedef_Node
;
1876 end P_Derived_Type_Def_Or_Private_Ext_Decl
;
1878 ---------------------------
1879 -- 3.5 Range Constraint --
1880 ---------------------------
1882 -- RANGE_CONSTRAINT ::= range RANGE
1884 -- The caller has checked that the initial token is RANGE
1886 -- Error recovery: cannot raise Error_Resync
1888 function P_Range_Constraint
return Node_Id
is
1889 Range_Node
: Node_Id
;
1892 Range_Node
:= New_Node
(N_Range_Constraint
, Token_Ptr
);
1894 Set_Range_Expression
(Range_Node
, P_Range
);
1896 end P_Range_Constraint
;
1903 -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
1905 -- Note: the range that appears in a membership test is parsed by
1906 -- P_Range_Or_Subtype_Mark (3.5).
1908 -- Error recovery: cannot raise Error_Resync
1910 function P_Range
return Node_Id
is
1911 Expr_Node
: Node_Id
;
1912 Range_Node
: Node_Id
;
1915 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
1917 if Expr_Form
= EF_Range_Attr
then
1920 elsif Token
= Tok_Dot_Dot
then
1921 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
1922 Set_Low_Bound
(Range_Node
, Expr_Node
);
1924 Expr_Node
:= P_Expression
;
1925 Check_Simple_Expression
(Expr_Node
);
1926 Set_High_Bound
(Range_Node
, Expr_Node
);
1929 -- Anything else is an error
1932 T_Dot_Dot
; -- force missing .. message
1937 ----------------------------------
1938 -- 3.5 P_Range_Or_Subtype_Mark --
1939 ----------------------------------
1942 -- RANGE_ATTRIBUTE_REFERENCE
1943 -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
1945 -- This routine scans out the range or subtype mark that forms the right
1946 -- operand of a membership test.
1948 -- Note: as documented in the Sinfo interface, although the syntax only
1949 -- allows a subtype mark, we in fact allow any simple expression to be
1950 -- returned from this routine. The semantics is responsible for issuing
1951 -- an appropriate message complaining if the argument is not a name.
1952 -- This simplifies the coding and error recovery processing in the
1953 -- parser, and in any case it is preferable not to consider this a
1954 -- syntax error and to continue with the semantic analysis.
1956 -- Error recovery: cannot raise Error_Resync
1958 function P_Range_Or_Subtype_Mark
return Node_Id
is
1959 Expr_Node
: Node_Id
;
1960 Range_Node
: Node_Id
;
1963 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
1965 if Expr_Form
= EF_Range_Attr
then
1968 -- Simple_Expression .. Simple_Expression
1970 elsif Token
= Tok_Dot_Dot
then
1971 Check_Simple_Expression
(Expr_Node
);
1972 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
1973 Set_Low_Bound
(Range_Node
, Expr_Node
);
1975 Set_High_Bound
(Range_Node
, P_Simple_Expression
);
1978 -- Case of subtype mark (optionally qualified simple name or an
1979 -- attribute whose prefix is an optionally qualifed simple name)
1981 elsif Expr_Form
= EF_Simple_Name
1982 or else Nkind
(Expr_Node
) = N_Attribute_Reference
1984 -- Check for error of range constraint after a subtype mark
1986 if Token
= Tok_Range
then
1988 ("range constraint not allowed in membership test");
1992 -- Check for error of DIGITS or DELTA after a subtype mark
1994 elsif Token
= Tok_Digits
or else Token
= Tok_Delta
then
1996 ("accuracy definition not allowed in membership test");
1997 Scan
; -- past DIGITS or DELTA
2000 elsif Token
= Tok_Apostrophe
then
2001 return P_Subtype_Mark_Attribute
(Expr_Node
);
2007 -- At this stage, we have some junk following the expression. We
2008 -- really can't tell what is wrong, might be a missing semicolon,
2009 -- or a missing THEN, or whatever. Our caller will figure it out!
2014 end P_Range_Or_Subtype_Mark
;
2016 ----------------------------------------
2017 -- 3.5.1 Enumeration Type Definition --
2018 ----------------------------------------
2020 -- ENUMERATION_TYPE_DEFINITION ::=
2021 -- (ENUMERATION_LITERAL_SPECIFICATION
2022 -- {, ENUMERATION_LITERAL_SPECIFICATION})
2024 -- The caller has already scanned out the TYPE keyword
2026 -- Error recovery: can raise Error_Resync;
2028 function P_Enumeration_Type_Definition
return Node_Id
is
2029 Typedef_Node
: Node_Id
;
2032 Typedef_Node
:= New_Node
(N_Enumeration_Type_Definition
, Token_Ptr
);
2033 Set_Literals
(Typedef_Node
, New_List
);
2038 Append
(P_Enumeration_Literal_Specification
, Literals
(Typedef_Node
));
2039 exit when not Comma_Present
;
2043 return Typedef_Node
;
2044 end P_Enumeration_Type_Definition
;
2046 ----------------------------------------------
2047 -- 3.5.1 Enumeration Literal Specification --
2048 ----------------------------------------------
2050 -- ENUMERATION_LITERAL_SPECIFICATION ::=
2051 -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
2053 -- Error recovery: can raise Error_Resync
2055 function P_Enumeration_Literal_Specification
return Node_Id
is
2057 if Token
= Tok_Char_Literal
then
2058 return P_Defining_Character_Literal
;
2060 return P_Defining_Identifier
(C_Comma_Right_Paren
);
2062 end P_Enumeration_Literal_Specification
;
2064 ---------------------------------------
2065 -- 3.5.1 Defining_Character_Literal --
2066 ---------------------------------------
2068 -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
2070 -- Error recovery: cannot raise Error_Resync
2072 -- The caller has checked that the current token is a character literal
2074 function P_Defining_Character_Literal
return Node_Id
is
2075 Literal_Node
: Node_Id
;
2078 Literal_Node
:= Token_Node
;
2079 Change_Character_Literal_To_Defining_Character_Literal
(Literal_Node
);
2080 Scan
; -- past character literal
2081 return Literal_Node
;
2082 end P_Defining_Character_Literal
;
2084 ------------------------------------
2085 -- 3.5.4 Integer Type Definition --
2086 ------------------------------------
2088 -- Parsed by P_Type_Declaration (3.2.1)
2090 -------------------------------------------
2091 -- 3.5.4 Signed Integer Type Definition --
2092 -------------------------------------------
2094 -- SIGNED_INTEGER_TYPE_DEFINITION ::=
2095 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2097 -- Normally the initial token on entry is RANGE, but in some
2098 -- error conditions, the range token was missing and control is
2099 -- passed with Token pointing to first token of the first expression.
2101 -- Error recovery: cannot raise Error_Resync
2103 function P_Signed_Integer_Type_Definition
return Node_Id
is
2104 Typedef_Node
: Node_Id
;
2105 Expr_Node
: Node_Id
;
2108 Typedef_Node
:= New_Node
(N_Signed_Integer_Type_Definition
, Token_Ptr
);
2110 if Token
= Tok_Range
then
2114 Expr_Node
:= P_Expression
;
2115 Check_Simple_Expression
(Expr_Node
);
2116 Set_Low_Bound
(Typedef_Node
, Expr_Node
);
2118 Expr_Node
:= P_Expression
;
2119 Check_Simple_Expression
(Expr_Node
);
2120 Set_High_Bound
(Typedef_Node
, Expr_Node
);
2121 return Typedef_Node
;
2122 end P_Signed_Integer_Type_Definition
;
2124 ------------------------------------
2125 -- 3.5.4 Modular Type Definition --
2126 ------------------------------------
2128 -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
2130 -- The caller has checked that the initial token is MOD
2132 -- Error recovery: cannot raise Error_Resync
2134 function P_Modular_Type_Definition
return Node_Id
is
2135 Typedef_Node
: Node_Id
;
2138 if Ada_Version
= Ada_83
then
2139 Error_Msg_SC
("(Ada 83): modular types not allowed");
2142 Typedef_Node
:= New_Node
(N_Modular_Type_Definition
, Token_Ptr
);
2144 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
2146 -- Handle mod L..R cleanly
2148 if Token
= Tok_Dot_Dot
then
2149 Error_Msg_SC
("range not allowed for modular type");
2151 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
2154 return Typedef_Node
;
2155 end P_Modular_Type_Definition
;
2157 ---------------------------------
2158 -- 3.5.6 Real Type Definition --
2159 ---------------------------------
2161 -- Parsed by P_Type_Declaration (3.2.1)
2163 --------------------------------------
2164 -- 3.5.7 Floating Point Definition --
2165 --------------------------------------
2167 -- FLOATING_POINT_DEFINITION ::=
2168 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2170 -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
2172 -- The caller has checked that the initial token is DIGITS
2174 -- Error recovery: cannot raise Error_Resync
2176 function P_Floating_Point_Definition
return Node_Id
is
2177 Digits_Loc
: constant Source_Ptr
:= Token_Ptr
;
2179 Expr_Node
: Node_Id
;
2182 Scan
; -- past DIGITS
2183 Expr_Node
:= P_Expression_No_Right_Paren
;
2184 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2186 -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
2188 if Token
= Tok_Delta
then
2189 Error_Msg_SC
("DELTA must come before DIGITS");
2190 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Digits_Loc
);
2192 Set_Delta_Expression
(Def_Node
, P_Expression_No_Right_Paren
);
2194 -- OK floating-point definition
2197 Def_Node
:= New_Node
(N_Floating_Point_Definition
, Digits_Loc
);
2200 Set_Digits_Expression
(Def_Node
, Expr_Node
);
2201 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
2203 end P_Floating_Point_Definition
;
2205 -------------------------------------
2206 -- 3.5.7 Real Range Specification --
2207 -------------------------------------
2209 -- REAL_RANGE_SPECIFICATION ::=
2210 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2212 -- Error recovery: cannot raise Error_Resync
2214 function P_Real_Range_Specification_Opt
return Node_Id
is
2215 Specification_Node
: Node_Id
;
2216 Expr_Node
: Node_Id
;
2219 if Token
= Tok_Range
then
2220 Specification_Node
:=
2221 New_Node
(N_Real_Range_Specification
, Token_Ptr
);
2223 Expr_Node
:= P_Expression_No_Right_Paren
;
2224 Check_Simple_Expression
(Expr_Node
);
2225 Set_Low_Bound
(Specification_Node
, Expr_Node
);
2227 Expr_Node
:= P_Expression_No_Right_Paren
;
2228 Check_Simple_Expression
(Expr_Node
);
2229 Set_High_Bound
(Specification_Node
, Expr_Node
);
2230 return Specification_Node
;
2234 end P_Real_Range_Specification_Opt
;
2236 -----------------------------------
2237 -- 3.5.9 Fixed Point Definition --
2238 -----------------------------------
2240 -- FIXED_POINT_DEFINITION ::=
2241 -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
2243 -- ORDINARY_FIXED_POINT_DEFINITION ::=
2244 -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION
2246 -- DECIMAL_FIXED_POINT_DEFINITION ::=
2247 -- delta static_EXPRESSION
2248 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2250 -- The caller has checked that the initial token is DELTA
2252 -- Error recovery: cannot raise Error_Resync
2254 function P_Fixed_Point_Definition
return Node_Id
is
2255 Delta_Node
: Node_Id
;
2256 Delta_Loc
: Source_Ptr
;
2258 Expr_Node
: Node_Id
;
2261 Delta_Loc
:= Token_Ptr
;
2263 Delta_Node
:= P_Expression_No_Right_Paren
;
2264 Check_Simple_Expression_In_Ada_83
(Delta_Node
);
2266 if Token
= Tok_Digits
then
2267 if Ada_Version
= Ada_83
then
2268 Error_Msg_SC
("(Ada 83) decimal fixed type not allowed!");
2271 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Delta_Loc
);
2272 Scan
; -- past DIGITS
2273 Expr_Node
:= P_Expression_No_Right_Paren
;
2274 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2275 Set_Digits_Expression
(Def_Node
, Expr_Node
);
2278 Def_Node
:= New_Node
(N_Ordinary_Fixed_Point_Definition
, Delta_Loc
);
2280 -- Range is required in ordinary fixed point case
2282 if Token
/= Tok_Range
then
2283 Error_Msg_AP
("range must be given for fixed-point type");
2288 Set_Delta_Expression
(Def_Node
, Delta_Node
);
2289 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
2291 end P_Fixed_Point_Definition
;
2293 --------------------------------------------
2294 -- 3.5.9 Ordinary Fixed Point Definition --
2295 --------------------------------------------
2297 -- Parsed by P_Fixed_Point_Definition (3.5.9)
2299 -------------------------------------------
2300 -- 3.5.9 Decimal Fixed Point Definition --
2301 -------------------------------------------
2303 -- Parsed by P_Decimal_Point_Definition (3.5.9)
2305 ------------------------------
2306 -- 3.5.9 Digits Constraint --
2307 ------------------------------
2309 -- DIGITS_CONSTRAINT ::=
2310 -- digits static_EXPRESSION [RANGE_CONSTRAINT]
2312 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2314 -- The caller has checked that the initial token is DIGITS
2316 function P_Digits_Constraint
return Node_Id
is
2317 Constraint_Node
: Node_Id
;
2318 Expr_Node
: Node_Id
;
2321 Constraint_Node
:= New_Node
(N_Digits_Constraint
, Token_Ptr
);
2322 Scan
; -- past DIGITS
2323 Expr_Node
:= P_Expression_No_Right_Paren
;
2324 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2325 Set_Digits_Expression
(Constraint_Node
, Expr_Node
);
2327 if Token
= Tok_Range
then
2328 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
2331 return Constraint_Node
;
2332 end P_Digits_Constraint
;
2334 -----------------------------
2335 -- 3.5.9 Delta Constraint --
2336 -----------------------------
2338 -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
2340 -- Note: this is an obsolescent feature in Ada 95 (I.3)
2342 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2344 -- The caller has checked that the initial token is DELTA
2346 -- Error recovery: cannot raise Error_Resync
2348 function P_Delta_Constraint
return Node_Id
is
2349 Constraint_Node
: Node_Id
;
2350 Expr_Node
: Node_Id
;
2353 Constraint_Node
:= New_Node
(N_Delta_Constraint
, Token_Ptr
);
2355 Expr_Node
:= P_Expression_No_Right_Paren
;
2356 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2357 Set_Delta_Expression
(Constraint_Node
, Expr_Node
);
2359 if Token
= Tok_Range
then
2360 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
2363 return Constraint_Node
;
2364 end P_Delta_Constraint
;
2366 --------------------------------
2367 -- 3.6 Array Type Definition --
2368 --------------------------------
2370 -- ARRAY_TYPE_DEFINITION ::=
2371 -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
2373 -- UNCONSTRAINED_ARRAY_DEFINITION ::=
2374 -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
2375 -- COMPONENT_DEFINITION
2377 -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
2379 -- CONSTRAINED_ARRAY_DEFINITION ::=
2380 -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
2381 -- COMPONENT_DEFINITION
2383 -- DISCRETE_SUBTYPE_DEFINITION ::=
2384 -- DISCRETE_SUBTYPE_INDICATION | RANGE
2386 -- COMPONENT_DEFINITION ::=
2387 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
2389 -- The caller has checked that the initial token is ARRAY
2391 -- Error recovery: can raise Error_Resync
2393 function P_Array_Type_Definition
return Node_Id
is
2394 Array_Loc
: Source_Ptr
;
2395 CompDef_Node
: Node_Id
;
2397 Not_Null_Present
: Boolean := False;
2398 Subs_List
: List_Id
;
2399 Scan_State
: Saved_Scan_State
;
2400 Aliased_Present
: Boolean := False;
2403 Array_Loc
:= Token_Ptr
;
2405 Subs_List
:= New_List
;
2408 -- It's quite tricky to disentangle these two possibilities, so we do
2409 -- a prescan to determine which case we have and then reset the scan.
2410 -- The prescan skips past possible subtype mark tokens.
2412 Save_Scan_State
(Scan_State
); -- just after paren
2414 while Token
in Token_Class_Desig
or else
2415 Token
= Tok_Dot
or else
2416 Token
= Tok_Apostrophe
-- because of 'BASE, 'CLASS
2421 -- If we end up on RANGE <> then we have the unconstrained case. We
2422 -- will also allow the RANGE to be omitted, just to improve error
2423 -- handling for a case like array (integer <>) of integer;
2425 Scan
; -- past possible RANGE or <>
2427 if (Prev_Token
= Tok_Range
and then Token
= Tok_Box
) or else
2428 Prev_Token
= Tok_Box
2430 Def_Node
:= New_Node
(N_Unconstrained_Array_Definition
, Array_Loc
);
2431 Restore_Scan_State
(Scan_State
); -- to first subtype mark
2434 Append
(P_Subtype_Mark_Resync
, Subs_List
);
2437 exit when Token
= Tok_Right_Paren
or else Token
= Tok_Of
;
2441 Set_Subtype_Marks
(Def_Node
, Subs_List
);
2444 Def_Node
:= New_Node
(N_Constrained_Array_Definition
, Array_Loc
);
2445 Restore_Scan_State
(Scan_State
); -- to first discrete range
2448 Append
(P_Discrete_Subtype_Definition
, Subs_List
);
2449 exit when not Comma_Present
;
2452 Set_Discrete_Subtype_Definitions
(Def_Node
, Subs_List
);
2458 CompDef_Node
:= New_Node
(N_Component_Definition
, Token_Ptr
);
2460 if Token_Name
= Name_Aliased
then
2461 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
2464 if Token
= Tok_Aliased
then
2465 Aliased_Present
:= True;
2466 Scan
; -- past ALIASED
2469 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/AI-254)
2471 -- Ada 2005 (AI-230): Access Definition case
2473 if Token
= Tok_Access
then
2474 if Ada_Version
< Ada_05
then
2476 ("generalized use of anonymous access types " &
2477 "is an Ada 2005 extension");
2478 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
2481 if Aliased_Present
then
2482 Error_Msg_SP
("ALIASED not allowed here");
2485 Set_Subtype_Indication
(CompDef_Node
, Empty
);
2486 Set_Aliased_Present
(CompDef_Node
, False);
2487 Set_Access_Definition
(CompDef_Node
,
2488 P_Access_Definition
(Not_Null_Present
));
2491 Set_Access_Definition
(CompDef_Node
, Empty
);
2492 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
2493 Set_Null_Exclusion_Present
(CompDef_Node
, Not_Null_Present
);
2494 Set_Subtype_Indication
(CompDef_Node
,
2495 P_Subtype_Indication
(Not_Null_Present
));
2498 Set_Component_Definition
(Def_Node
, CompDef_Node
);
2501 end P_Array_Type_Definition
;
2503 -----------------------------------------
2504 -- 3.6 Unconstrained Array Definition --
2505 -----------------------------------------
2507 -- Parsed by P_Array_Type_Definition (3.6)
2509 ---------------------------------------
2510 -- 3.6 Constrained Array Definition --
2511 ---------------------------------------
2513 -- Parsed by P_Array_Type_Definition (3.6)
2515 --------------------------------------
2516 -- 3.6 Discrete Subtype Definition --
2517 --------------------------------------
2519 -- DISCRETE_SUBTYPE_DEFINITION ::=
2520 -- discrete_SUBTYPE_INDICATION | RANGE
2522 -- Note: the discrete subtype definition appearing in a constrained
2523 -- array definition is parsed by P_Array_Type_Definition (3.6)
2525 -- Error recovery: cannot raise Error_Resync
2527 function P_Discrete_Subtype_Definition
return Node_Id
is
2529 -- The syntax of a discrete subtype definition is identical to that
2530 -- of a discrete range, so we simply share the same parsing code.
2532 return P_Discrete_Range
;
2533 end P_Discrete_Subtype_Definition
;
2535 -------------------------------
2536 -- 3.6 Component Definition --
2537 -------------------------------
2539 -- For the array case, parsed by P_Array_Type_Definition (3.6)
2540 -- For the record case, parsed by P_Component_Declaration (3.8)
2542 -----------------------------
2543 -- 3.6.1 Index Constraint --
2544 -----------------------------
2546 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2548 ---------------------------
2549 -- 3.6.1 Discrete Range --
2550 ---------------------------
2552 -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
2554 -- The possible forms for a discrete range are:
2556 -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2)
2557 -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2)
2558 -- Range_Attribute (RANGE, 3.5)
2559 -- Simple_Expression .. Simple_Expression (RANGE, 3.5)
2561 -- Error recovery: cannot raise Error_Resync
2563 function P_Discrete_Range
return Node_Id
is
2564 Expr_Node
: Node_Id
;
2565 Range_Node
: Node_Id
;
2568 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2570 if Expr_Form
= EF_Range_Attr
then
2573 elsif Token
= Tok_Range
then
2574 if Expr_Form
/= EF_Simple_Name
then
2575 Error_Msg_SC
("range must be preceded by subtype mark");
2578 return P_Subtype_Indication
(Expr_Node
);
2580 -- Check Expression .. Expression case
2582 elsif Token
= Tok_Dot_Dot
then
2583 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2584 Set_Low_Bound
(Range_Node
, Expr_Node
);
2586 Expr_Node
:= P_Expression
;
2587 Check_Simple_Expression
(Expr_Node
);
2588 Set_High_Bound
(Range_Node
, Expr_Node
);
2591 -- Otherwise we must have a subtype mark
2593 elsif Expr_Form
= EF_Simple_Name
then
2596 -- If incorrect, complain that we expect ..
2602 end P_Discrete_Range
;
2604 ----------------------------
2605 -- 3.7 Discriminant Part --
2606 ----------------------------
2608 -- DISCRIMINANT_PART ::=
2609 -- UNKNOWN_DISCRIMINANT_PART
2610 -- | KNOWN_DISCRIMINANT_PART
2612 -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
2613 -- or P_Unknown_Discriminant_Part (3.7), since we know which we want.
2615 ------------------------------------
2616 -- 3.7 Unknown Discriminant Part --
2617 ------------------------------------
2619 -- UNKNOWN_DISCRIMINANT_PART ::= (<>)
2621 -- If no unknown discriminant part is present, then False is returned,
2622 -- otherwise the unknown discriminant is scanned out and True is returned.
2624 -- Error recovery: cannot raise Error_Resync
2626 function P_Unknown_Discriminant_Part_Opt
return Boolean is
2627 Scan_State
: Saved_Scan_State
;
2630 if Token
/= Tok_Left_Paren
then
2634 Save_Scan_State
(Scan_State
);
2635 Scan
; -- past the left paren
2637 if Token
= Tok_Box
then
2638 if Ada_Version
= Ada_83
then
2639 Error_Msg_SC
("(Ada 83) unknown discriminant not allowed!");
2642 Scan
; -- past the box
2643 T_Right_Paren
; -- must be followed by right paren
2647 Restore_Scan_State
(Scan_State
);
2651 end P_Unknown_Discriminant_Part_Opt
;
2653 ----------------------------------
2654 -- 3.7 Known Discriminant Part --
2655 ----------------------------------
2657 -- KNOWN_DISCRIMINANT_PART ::=
2658 -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
2660 -- DISCRIMINANT_SPECIFICATION ::=
2661 -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
2662 -- [:= DEFAULT_EXPRESSION]
2663 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
2664 -- [:= DEFAULT_EXPRESSION]
2666 -- If no known discriminant part is present, then No_List is returned
2668 -- Error recovery: cannot raise Error_Resync
2670 function P_Known_Discriminant_Part_Opt
return List_Id
is
2671 Specification_Node
: Node_Id
;
2672 Specification_List
: List_Id
;
2673 Ident_Sloc
: Source_Ptr
;
2674 Scan_State
: Saved_Scan_State
;
2676 Not_Null_Present
: Boolean;
2679 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
2680 -- This array holds the list of defining identifiers. The upper bound
2681 -- of 4096 is intended to be essentially infinite, and we do not even
2682 -- bother to check for it being exceeded.
2685 if Token
= Tok_Left_Paren
then
2686 Specification_List
:= New_List
;
2688 P_Pragmas_Misplaced
;
2690 Specification_Loop
: loop
2692 Ident_Sloc
:= Token_Ptr
;
2693 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
2696 while Comma_Present
loop
2697 Num_Idents
:= Num_Idents
+ 1;
2698 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
2703 -- If there are multiple identifiers, we repeatedly scan the
2704 -- type and initialization expression information by resetting
2705 -- the scan pointer (so that we get completely separate trees
2706 -- for each occurrence).
2708 if Num_Idents
> 1 then
2709 Save_Scan_State
(Scan_State
);
2712 -- Loop through defining identifiers in list
2716 Specification_Node
:=
2717 New_Node
(N_Discriminant_Specification
, Ident_Sloc
);
2718 Set_Defining_Identifier
(Specification_Node
, Idents
(Ident
));
2719 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
2721 if Token
= Tok_Access
then
2722 if Ada_Version
= Ada_83
then
2724 ("(Ada 83) access discriminant not allowed!");
2727 Set_Discriminant_Type
2728 (Specification_Node
,
2729 P_Access_Definition
(Not_Null_Present
));
2732 Set_Discriminant_Type
2733 (Specification_Node
, P_Subtype_Mark
);
2735 Set_Null_Exclusion_Present
-- Ada 2005 (AI-231)
2736 (Specification_Node
, Not_Null_Present
);
2740 (Specification_Node
, Init_Expr_Opt
(True));
2743 Set_Prev_Ids
(Specification_Node
, True);
2746 if Ident
< Num_Idents
then
2747 Set_More_Ids
(Specification_Node
, True);
2750 Append
(Specification_Node
, Specification_List
);
2751 exit Ident_Loop
when Ident
= Num_Idents
;
2753 Restore_Scan_State
(Scan_State
);
2754 end loop Ident_Loop
;
2756 exit Specification_Loop
when Token
/= Tok_Semicolon
;
2758 P_Pragmas_Misplaced
;
2759 end loop Specification_Loop
;
2762 return Specification_List
;
2767 end P_Known_Discriminant_Part_Opt
;
2769 -------------------------------------
2770 -- 3.7 DIscriminant Specification --
2771 -------------------------------------
2773 -- Parsed by P_Known_Discriminant_Part_Opt (3.7)
2775 -----------------------------
2776 -- 3.7 Default Expression --
2777 -----------------------------
2779 -- Always parsed (simply as an Expression) by the parent construct
2781 ------------------------------------
2782 -- 3.7.1 Discriminant Constraint --
2783 ------------------------------------
2785 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2787 --------------------------------------------------------
2788 -- 3.7.1 Index or Discriminant Constraint (also 3.6) --
2789 --------------------------------------------------------
2791 -- DISCRIMINANT_CONSTRAINT ::=
2792 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
2794 -- DISCRIMINANT_ASSOCIATION ::=
2795 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2798 -- This routine parses either an index or a discriminant constraint. As
2799 -- is clear from the above grammar, it is often possible to clearly
2800 -- determine which of the two possibilities we have, but there are
2801 -- cases (those in which we have a series of expressions of the same
2802 -- syntactic form as subtype indications), where we cannot tell. Since
2803 -- this means that in any case the semantic phase has to distinguish
2804 -- between the two, there is not much point in the parser trying to
2805 -- distinguish even those cases where the difference is clear. In any
2806 -- case, if we have a situation like:
2808 -- (A => 123, 235 .. 500)
2810 -- it is not clear which of the two items is the wrong one, better to
2811 -- let the semantic phase give a clear message. Consequently, this
2812 -- routine in general returns a list of items which can be either
2813 -- discrete ranges or discriminant associations.
2815 -- The caller has checked that the initial token is a left paren
2817 -- Error recovery: can raise Error_Resync
2819 function P_Index_Or_Discriminant_Constraint
return Node_Id
is
2820 Scan_State
: Saved_Scan_State
;
2821 Constr_Node
: Node_Id
;
2822 Constr_List
: List_Id
;
2823 Expr_Node
: Node_Id
;
2824 Result_Node
: Node_Id
;
2827 Result_Node
:= New_Node
(N_Index_Or_Discriminant_Constraint
, Token_Ptr
);
2829 Constr_List
:= New_List
;
2830 Set_Constraints
(Result_Node
, Constr_List
);
2832 -- The two syntactic forms are a little mixed up, so what we are doing
2833 -- here is looking at the first entry to determine which case we have
2835 -- A discriminant constraint is a list of discriminant associations,
2836 -- which have one of the following possible forms:
2840 -- Id | Id | .. | Id => Expression
2842 -- An index constraint is a list of discrete ranges which have one
2843 -- of the following possible forms:
2846 -- Subtype_Mark range Range
2848 -- Simple_Expression .. Simple_Expression
2850 -- Loop through discriminants in list
2853 -- Check cases of Id => Expression or Id | Id => Expression
2855 if Token
= Tok_Identifier
then
2856 Save_Scan_State
(Scan_State
); -- at Id
2859 if Token
= Tok_Arrow
or else Token
= Tok_Vertical_Bar
then
2860 Restore_Scan_State
(Scan_State
); -- to Id
2861 Append
(P_Discriminant_Association
, Constr_List
);
2864 Restore_Scan_State
(Scan_State
); -- to Id
2868 -- Otherwise scan out an expression and see what we have got
2870 Expr_Node
:= P_Expression_Or_Range_Attribute
;
2872 if Expr_Form
= EF_Range_Attr
then
2873 Append
(Expr_Node
, Constr_List
);
2875 elsif Token
= Tok_Range
then
2876 if Expr_Form
/= EF_Simple_Name
then
2877 Error_Msg_SC
("subtype mark required before RANGE");
2880 Append
(P_Subtype_Indication
(Expr_Node
), Constr_List
);
2883 -- Check Simple_Expression .. Simple_Expression case
2885 elsif Token
= Tok_Dot_Dot
then
2886 Check_Simple_Expression
(Expr_Node
);
2887 Constr_Node
:= New_Node
(N_Range
, Token_Ptr
);
2888 Set_Low_Bound
(Constr_Node
, Expr_Node
);
2890 Expr_Node
:= P_Expression
;
2891 Check_Simple_Expression
(Expr_Node
);
2892 Set_High_Bound
(Constr_Node
, Expr_Node
);
2893 Append
(Constr_Node
, Constr_List
);
2896 -- Case of an expression which could be either form
2899 Append
(Expr_Node
, Constr_List
);
2903 -- Here with a single entry scanned
2906 exit when not Comma_Present
;
2912 end P_Index_Or_Discriminant_Constraint
;
2914 -------------------------------------
2915 -- 3.7.1 Discriminant Association --
2916 -------------------------------------
2918 -- DISCRIMINANT_ASSOCIATION ::=
2919 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2922 -- This routine is used only when the name list is present and the caller
2923 -- has already checked this (by scanning ahead and repositioning the
2926 -- Error_Recovery: cannot raise Error_Resync;
2928 function P_Discriminant_Association
return Node_Id
is
2929 Discr_Node
: Node_Id
;
2930 Names_List
: List_Id
;
2931 Ident_Sloc
: Source_Ptr
;
2934 Ident_Sloc
:= Token_Ptr
;
2935 Names_List
:= New_List
;
2938 Append
(P_Identifier
(C_Vertical_Bar_Arrow
), Names_List
);
2939 exit when Token
/= Tok_Vertical_Bar
;
2943 Discr_Node
:= New_Node
(N_Discriminant_Association
, Ident_Sloc
);
2944 Set_Selector_Names
(Discr_Node
, Names_List
);
2946 Set_Expression
(Discr_Node
, P_Expression
);
2948 end P_Discriminant_Association
;
2950 ---------------------------------
2951 -- 3.8 Record Type Definition --
2952 ---------------------------------
2954 -- RECORD_TYPE_DEFINITION ::=
2955 -- [[abstract] tagged] [limited] RECORD_DEFINITION
2957 -- There is no node in the tree for a record type definition. Instead
2958 -- a record definition node appears, with possible Abstract_Present,
2959 -- Tagged_Present, and Limited_Present flags set appropriately.
2961 ----------------------------
2962 -- 3.8 Record Definition --
2963 ----------------------------
2965 -- RECORD_DEFINITION ::=
2971 -- Note: in the case where a record definition node is used to represent
2972 -- a record type definition, the caller sets the Tagged_Present and
2973 -- Limited_Present flags in the resulting N_Record_Definition node as
2976 -- Note that the RECORD token at the start may be missing in certain
2977 -- error situations, so this function is expected to post the error
2979 -- Error recovery: can raise Error_Resync
2981 function P_Record_Definition
return Node_Id
is
2985 Rec_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
2989 if Token
= Tok_Null
then
2992 Set_Null_Present
(Rec_Node
, True);
2994 -- Case starting with RECORD keyword. Build scope stack entry. For the
2995 -- column, we use the first non-blank character on the line, to deal
2996 -- with situations such as:
3002 -- which is not official RM indentation, but is not uncommon usage
3006 Scope
.Table
(Scope
.Last
).Etyp
:= E_Record
;
3007 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
3008 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
3009 Scope
.Table
(Scope
.Last
).Labl
:= Error
;
3010 Scope
.Table
(Scope
.Last
).Junk
:= (Token
/= Tok_Record
);
3014 Set_Component_List
(Rec_Node
, P_Component_List
);
3017 exit when Check_End
;
3018 Discard_Junk_Node
(P_Component_List
);
3023 end P_Record_Definition
;
3025 -------------------------
3026 -- 3.8 Component List --
3027 -------------------------
3029 -- COMPONENT_LIST ::=
3030 -- COMPONENT_ITEM {COMPONENT_ITEM}
3031 -- | {COMPONENT_ITEM} VARIANT_PART
3034 -- Error recovery: cannot raise Error_Resync
3036 function P_Component_List
return Node_Id
is
3037 Component_List_Node
: Node_Id
;
3038 Decls_List
: List_Id
;
3039 Scan_State
: Saved_Scan_State
;
3042 Component_List_Node
:= New_Node
(N_Component_List
, Token_Ptr
);
3043 Decls_List
:= New_List
;
3045 if Token
= Tok_Null
then
3048 P_Pragmas_Opt
(Decls_List
);
3049 Set_Null_Present
(Component_List_Node
, True);
3050 return Component_List_Node
;
3053 P_Pragmas_Opt
(Decls_List
);
3055 if Token
/= Tok_Case
then
3056 Component_Scan_Loop
: loop
3057 P_Component_Items
(Decls_List
);
3058 P_Pragmas_Opt
(Decls_List
);
3060 exit Component_Scan_Loop
when Token
= Tok_End
3061 or else Token
= Tok_Case
3062 or else Token
= Tok_When
;
3064 -- We are done if we do not have an identifier. However, if
3065 -- we have a misspelled reserved identifier that is in a column
3066 -- to the right of the record definition, we will treat it as
3067 -- an identifier. It turns out to be too dangerous in practice
3068 -- to accept such a mis-spelled identifier which does not have
3069 -- this additional clue that confirms the incorrect spelling.
3071 if Token
/= Tok_Identifier
then
3072 if Start_Column
> Scope
.Table
(Scope
.Last
).Ecol
3073 and then Is_Reserved_Identifier
3075 Save_Scan_State
(Scan_State
); -- at reserved id
3076 Scan
; -- possible reserved id
3078 if Token
= Tok_Comma
or else Token
= Tok_Colon
then
3079 Restore_Scan_State
(Scan_State
);
3080 Scan_Reserved_Identifier
(Force_Msg
=> True);
3082 -- Note reserved identifier used as field name after
3083 -- all because not followed by colon or comma
3086 Restore_Scan_State
(Scan_State
);
3087 exit Component_Scan_Loop
;
3090 -- Non-identifier that definitely was not reserved id
3093 exit Component_Scan_Loop
;
3096 end loop Component_Scan_Loop
;
3099 if Token
= Tok_Case
then
3100 Set_Variant_Part
(Component_List_Node
, P_Variant_Part
);
3102 -- Check for junk after variant part
3104 if Token
= Tok_Identifier
then
3105 Save_Scan_State
(Scan_State
);
3106 Scan
; -- past identifier
3108 if Token
= Tok_Colon
then
3109 Restore_Scan_State
(Scan_State
);
3110 Error_Msg_SC
("component may not follow variant part");
3111 Discard_Junk_Node
(P_Component_List
);
3113 elsif Token
= Tok_Case
then
3114 Restore_Scan_State
(Scan_State
);
3115 Error_Msg_SC
("only one variant part allowed in a record");
3116 Discard_Junk_Node
(P_Component_List
);
3119 Restore_Scan_State
(Scan_State
);
3125 Set_Component_Items
(Component_List_Node
, Decls_List
);
3126 return Component_List_Node
;
3127 end P_Component_List
;
3129 -------------------------
3130 -- 3.8 Component Item --
3131 -------------------------
3133 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
3135 -- COMPONENT_DECLARATION ::=
3136 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
3137 -- [:= DEFAULT_EXPRESSION];
3139 -- COMPONENT_DEFINITION ::=
3140 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
3142 -- Error recovery: cannot raise Error_Resync, if an error occurs,
3143 -- the scan is positioned past the following semicolon.
3145 -- Note: we do not yet allow representation clauses to appear as component
3146 -- items, do we need to add this capability sometime in the future ???
3148 procedure P_Component_Items
(Decls
: List_Id
) is
3149 Aliased_Present
: Boolean := False;
3150 CompDef_Node
: Node_Id
;
3151 Decl_Node
: Node_Id
;
3152 Scan_State
: Saved_Scan_State
;
3153 Not_Null_Present
: Boolean := False;
3156 Ident_Sloc
: Source_Ptr
;
3158 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
3159 -- This array holds the list of defining identifiers. The upper bound
3160 -- of 4096 is intended to be essentially infinite, and we do not even
3161 -- bother to check for it being exceeded.
3164 if Token
/= Tok_Identifier
then
3165 Error_Msg_SC
("component declaration expected");
3166 Resync_Past_Semicolon
;
3170 Ident_Sloc
:= Token_Ptr
;
3171 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
3174 while Comma_Present
loop
3175 Num_Idents
:= Num_Idents
+ 1;
3176 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
3181 -- If there are multiple identifiers, we repeatedly scan the
3182 -- type and initialization expression information by resetting
3183 -- the scan pointer (so that we get completely separate trees
3184 -- for each occurrence).
3186 if Num_Idents
> 1 then
3187 Save_Scan_State
(Scan_State
);
3190 -- Loop through defining identifiers in list
3195 -- The following block is present to catch Error_Resync
3196 -- which causes the parse to be reset past the semicolon
3199 Decl_Node
:= New_Node
(N_Component_Declaration
, Ident_Sloc
);
3200 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
3202 if Token
= Tok_Constant
then
3203 Error_Msg_SC
("constant components are not permitted");
3207 CompDef_Node
:= New_Node
(N_Component_Definition
, Token_Ptr
);
3209 if Token_Name
= Name_Aliased
then
3210 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
3213 if Token
= Tok_Aliased
then
3214 Aliased_Present
:= True;
3215 Scan
; -- past ALIASED
3218 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/AI-254)
3220 -- Ada 2005 (AI-230): Access Definition case
3222 if Token
= Tok_Access
then
3223 if Ada_Version
< Ada_05
then
3225 ("generalized use of anonymous access types " &
3226 "is an Ada 2005 extension");
3227 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
3230 if Aliased_Present
then
3231 Error_Msg_SP
("ALIASED not allowed here");
3234 Set_Subtype_Indication
(CompDef_Node
, Empty
);
3235 Set_Aliased_Present
(CompDef_Node
, False);
3236 Set_Access_Definition
(CompDef_Node
,
3237 P_Access_Definition
(Not_Null_Present
));
3240 Set_Access_Definition
(CompDef_Node
, Empty
);
3241 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
3242 Set_Null_Exclusion_Present
(CompDef_Node
, Not_Null_Present
);
3244 if Token
= Tok_Array
then
3246 ("anonymous arrays not allowed as components");
3250 Set_Subtype_Indication
(CompDef_Node
,
3251 P_Subtype_Indication
(Not_Null_Present
));
3254 Set_Component_Definition
(Decl_Node
, CompDef_Node
);
3255 Set_Expression
(Decl_Node
, Init_Expr_Opt
);
3258 Set_Prev_Ids
(Decl_Node
, True);
3261 if Ident
< Num_Idents
then
3262 Set_More_Ids
(Decl_Node
, True);
3265 Append
(Decl_Node
, Decls
);
3268 when Error_Resync
=>
3269 if Token
/= Tok_End
then
3270 Resync_Past_Semicolon
;
3274 exit Ident_Loop
when Ident
= Num_Idents
;
3276 Restore_Scan_State
(Scan_State
);
3278 end loop Ident_Loop
;
3281 end P_Component_Items
;
3283 --------------------------------
3284 -- 3.8 Component Declaration --
3285 --------------------------------
3287 -- Parsed by P_Component_Items (3.8)
3289 -------------------------
3290 -- 3.8.1 Variant Part --
3291 -------------------------
3294 -- case discriminant_DIRECT_NAME is
3299 -- The caller has checked that the initial token is CASE
3301 -- Error recovery: cannot raise Error_Resync
3303 function P_Variant_Part
return Node_Id
is
3304 Variant_Part_Node
: Node_Id
;
3305 Variants_List
: List_Id
;
3306 Case_Node
: Node_Id
;
3309 Variant_Part_Node
:= New_Node
(N_Variant_Part
, Token_Ptr
);
3311 Scope
.Table
(Scope
.Last
).Etyp
:= E_Case
;
3312 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
3313 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
3316 Case_Node
:= P_Expression
;
3317 Set_Name
(Variant_Part_Node
, Case_Node
);
3319 if Nkind
(Case_Node
) /= N_Identifier
then
3320 Set_Name
(Variant_Part_Node
, Error
);
3321 Error_Msg
("discriminant name expected", Sloc
(Case_Node
));
3325 Variants_List
:= New_List
;
3326 P_Pragmas_Opt
(Variants_List
);
3328 -- Test missing variant
3330 if Token
= Tok_End
then
3331 Error_Msg_BC
("WHEN expected (must have at least one variant)");
3333 Append
(P_Variant
, Variants_List
);
3336 -- Loop through variants, note that we allow if in place of when,
3337 -- this error will be detected and handled in P_Variant.
3340 P_Pragmas_Opt
(Variants_List
);
3342 if Token
/= Tok_When
3343 and then Token
/= Tok_If
3344 and then Token
/= Tok_Others
3346 exit when Check_End
;
3349 Append
(P_Variant
, Variants_List
);
3352 Set_Variants
(Variant_Part_Node
, Variants_List
);
3353 return Variant_Part_Node
;
3356 --------------------
3358 --------------------
3361 -- when DISCRETE_CHOICE_LIST =>
3364 -- Error recovery: cannot raise Error_Resync
3366 -- The initial token on entry is either WHEN, IF or OTHERS
3368 function P_Variant
return Node_Id
is
3369 Variant_Node
: Node_Id
;
3372 -- Special check to recover nicely from use of IF in place of WHEN
3374 if Token
= Tok_If
then
3381 Variant_Node
:= New_Node
(N_Variant
, Prev_Token_Ptr
);
3382 Set_Discrete_Choices
(Variant_Node
, P_Discrete_Choice_List
);
3384 Set_Component_List
(Variant_Node
, P_Component_List
);
3385 return Variant_Node
;
3388 ---------------------------------
3389 -- 3.8.1 Discrete Choice List --
3390 ---------------------------------
3392 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
3394 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
3396 -- Note: in Ada 83, the expression must be a simple expression
3398 -- Error recovery: cannot raise Error_Resync
3400 function P_Discrete_Choice_List
return List_Id
is
3402 Expr_Node
: Node_Id
;
3403 Choice_Node
: Node_Id
;
3406 Choices
:= New_List
;
3409 if Token
= Tok_Others
then
3410 Append
(New_Node
(N_Others_Choice
, Token_Ptr
), Choices
);
3411 Scan
; -- past OTHERS
3415 Expr_Node
:= No_Right_Paren
(P_Expression_Or_Range_Attribute
);
3417 if Token
= Tok_Colon
3418 and then Nkind
(Expr_Node
) = N_Identifier
3420 Error_Msg_SP
("label not permitted in this context");
3423 elsif Expr_Form
= EF_Range_Attr
then
3424 Append
(Expr_Node
, Choices
);
3426 elsif Token
= Tok_Dot_Dot
then
3427 Check_Simple_Expression
(Expr_Node
);
3428 Choice_Node
:= New_Node
(N_Range
, Token_Ptr
);
3429 Set_Low_Bound
(Choice_Node
, Expr_Node
);
3431 Expr_Node
:= P_Expression_No_Right_Paren
;
3432 Check_Simple_Expression
(Expr_Node
);
3433 Set_High_Bound
(Choice_Node
, Expr_Node
);
3434 Append
(Choice_Node
, Choices
);
3436 elsif Expr_Form
= EF_Simple_Name
then
3437 if Token
= Tok_Range
then
3438 Append
(P_Subtype_Indication
(Expr_Node
), Choices
);
3440 elsif Token
in Token_Class_Consk
then
3442 ("the only constraint allowed here " &
3443 "is a range constraint");
3444 Discard_Junk_Node
(P_Constraint_Opt
);
3445 Append
(Expr_Node
, Choices
);
3448 Append
(Expr_Node
, Choices
);
3452 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
3453 Append
(Expr_Node
, Choices
);
3457 when Error_Resync
=>
3463 if Token
= Tok_Comma
then
3464 Error_Msg_SC
(""","" should be ""'|""");
3466 exit when Token
/= Tok_Vertical_Bar
;
3469 Scan
; -- past | or comma
3473 end P_Discrete_Choice_List
;
3475 ----------------------------
3476 -- 3.8.1 Discrete Choice --
3477 ----------------------------
3479 -- Parsed by P_Discrete_Choice_List (3.8.1)
3481 ----------------------------------
3482 -- 3.9.1 Record Extension Part --
3483 ----------------------------------
3485 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
3487 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
3489 --------------------------------------
3490 -- 3.9.4 Interface Type Definition --
3491 --------------------------------------
3493 -- INTERFACE_TYPE_DEFINITION ::=
3494 -- [limited | task | protected | synchronized] interface
3495 -- [AND interface_list]
3497 -- Error recovery: cannot raise Error_Resync
3499 function P_Interface_Type_Definition
3500 (Is_Synchronized
: Boolean) return Node_Id
3502 Typedef_Node
: Node_Id
;
3505 if Ada_Version
< Ada_05
then
3506 Error_Msg_SP
("abstract interface is an Ada 2005 extension");
3507 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
3510 Scan
; -- past INTERFACE
3512 -- Ada 2005 (AI-345): In case of synchronized interfaces and
3513 -- interfaces with a null list of interfaces we build a
3514 -- record_definition node.
3517 or else Token
= Tok_Semicolon
3519 Typedef_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
3521 Set_Abstract_Present
(Typedef_Node
);
3522 Set_Tagged_Present
(Typedef_Node
);
3523 Set_Null_Present
(Typedef_Node
);
3524 Set_Interface_Present
(Typedef_Node
);
3527 and then Token
= Tok_And
3530 Set_Interface_List
(Typedef_Node
, New_List
);
3533 Append
(P_Qualified_Simple_Name
,
3534 Interface_List
(Typedef_Node
));
3535 exit when Token
/= Tok_And
;
3540 -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have
3541 -- a list of interfaces we build a derived_type_definition node. This
3542 -- simplifies the semantic analysis (and hence further mainteinance)
3545 if Token
/= Tok_And
then
3546 Error_Msg_AP
("AND expected");
3551 Typedef_Node
:= New_Node
(N_Derived_Type_Definition
, Token_Ptr
);
3553 Set_Abstract_Present
(Typedef_Node
);
3554 Set_Interface_Present
(Typedef_Node
);
3555 Set_Subtype_Indication
(Typedef_Node
, P_Qualified_Simple_Name
);
3557 Set_Record_Extension_Part
(Typedef_Node
,
3558 New_Node
(N_Record_Definition
, Token_Ptr
));
3559 Set_Null_Present
(Record_Extension_Part
(Typedef_Node
));
3561 if Token
= Tok_And
then
3562 Set_Interface_List
(Typedef_Node
, New_List
);
3566 Append
(P_Qualified_Simple_Name
,
3567 Interface_List
(Typedef_Node
));
3568 exit when Token
/= Tok_And
;
3574 return Typedef_Node
;
3575 end P_Interface_Type_Definition
;
3577 ----------------------------------
3578 -- 3.10 Access Type Definition --
3579 ----------------------------------
3581 -- ACCESS_TYPE_DEFINITION ::=
3582 -- ACCESS_TO_OBJECT_DEFINITION
3583 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3585 -- ACCESS_TO_OBJECT_DEFINITION ::=
3586 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
3588 -- GENERAL_ACCESS_MODIFIER ::= all | constant
3590 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3591 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3592 -- | [NULL_EXCLUSION] access [protected] function
3593 -- PARAMETER_AND_RESULT_PROFILE
3595 -- PARAMETER_PROFILE ::= [FORMAL_PART]
3597 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
3599 -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already
3600 -- parsed the null_exclusion part and has also removed the ACCESS token;
3601 -- otherwise the caller has just checked that the initial token is ACCESS
3603 -- Error recovery: can raise Error_Resync
3605 function P_Access_Type_Definition
3606 (Header_Already_Parsed
: Boolean := False) return Node_Id
is
3607 Access_Loc
: constant Source_Ptr
:= Token_Ptr
;
3608 Prot_Flag
: Boolean;
3609 Not_Null_Present
: Boolean := False;
3610 Type_Def_Node
: Node_Id
;
3611 Result_Not_Null
: Boolean;
3612 Result_Node
: Node_Id
;
3614 procedure Check_Junk_Subprogram_Name
;
3615 -- Used in access to subprogram definition cases to check for an
3616 -- identifier or operator symbol that does not belong.
3618 procedure Check_Junk_Subprogram_Name
is
3619 Saved_State
: Saved_Scan_State
;
3622 if Token
= Tok_Identifier
or else Token
= Tok_Operator_Symbol
then
3623 Save_Scan_State
(Saved_State
);
3624 Scan
; -- past possible junk subprogram name
3626 if Token
= Tok_Left_Paren
or else Token
= Tok_Semicolon
then
3627 Error_Msg_SP
("unexpected subprogram name ignored");
3631 Restore_Scan_State
(Saved_State
);
3634 end Check_Junk_Subprogram_Name
;
3636 -- Start of processing for P_Access_Type_Definition
3639 if not Header_Already_Parsed
then
3640 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
3641 Scan
; -- past ACCESS
3644 if Token_Name
= Name_Protected
then
3645 Check_95_Keyword
(Tok_Protected
, Tok_Procedure
);
3646 Check_95_Keyword
(Tok_Protected
, Tok_Function
);
3649 Prot_Flag
:= (Token
= Tok_Protected
);
3652 Scan
; -- past PROTECTED
3654 if Token
/= Tok_Procedure
and then Token
/= Tok_Function
then
3655 Error_Msg_SC
("FUNCTION or PROCEDURE expected");
3659 if Token
= Tok_Procedure
then
3660 if Ada_Version
= Ada_83
then
3661 Error_Msg_SC
("(Ada 83) access to procedure not allowed!");
3664 Type_Def_Node
:= New_Node
(N_Access_Procedure_Definition
, Access_Loc
);
3665 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3666 Scan
; -- past PROCEDURE
3667 Check_Junk_Subprogram_Name
;
3668 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
3669 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
3671 elsif Token
= Tok_Function
then
3672 if Ada_Version
= Ada_83
then
3673 Error_Msg_SC
("(Ada 83) access to function not allowed!");
3676 Type_Def_Node
:= New_Node
(N_Access_Function_Definition
, Access_Loc
);
3677 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3678 Scan
; -- past FUNCTION
3679 Check_Junk_Subprogram_Name
;
3680 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
3681 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
3684 Result_Not_Null
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
3686 -- Ada 2005 (AI-318-02)
3688 if Token
= Tok_Access
then
3689 if Ada_Version
< Ada_05
then
3691 ("anonymous access result type is an Ada 2005 extension");
3692 Error_Msg_SC
("\unit must be compiled with -gnat05 switch");
3695 Result_Node
:= P_Access_Definition
(Result_Not_Null
);
3698 Result_Node
:= P_Subtype_Mark
;
3702 -- Note: A null exclusion given on the result type needs to
3703 -- be coded by a distinct flag, since Null_Exclusion_Present
3704 -- on an access-to-function type pertains to a null exclusion
3705 -- on the access type itself (as set above). ???
3706 -- Set_Null_Exclusion_Present??? (Type_Def_Node, Result_Not_Null);
3708 Set_Result_Definition
(Type_Def_Node
, Result_Node
);
3712 New_Node
(N_Access_To_Object_Definition
, Access_Loc
);
3713 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3715 if Token
= Tok_All
or else Token
= Tok_Constant
then
3716 if Ada_Version
= Ada_83
then
3717 Error_Msg_SC
("(Ada 83) access modifier not allowed!");
3720 if Token
= Tok_All
then
3721 Set_All_Present
(Type_Def_Node
, True);
3724 Set_Constant_Present
(Type_Def_Node
, True);
3727 Scan
; -- past ALL or CONSTANT
3730 Set_Subtype_Indication
(Type_Def_Node
,
3731 P_Subtype_Indication
(Not_Null_Present
));
3734 return Type_Def_Node
;
3735 end P_Access_Type_Definition
;
3737 ---------------------------------------
3738 -- 3.10 Access To Object Definition --
3739 ---------------------------------------
3741 -- Parsed by P_Access_Type_Definition (3.10)
3743 -----------------------------------
3744 -- 3.10 General Access Modifier --
3745 -----------------------------------
3747 -- Parsed by P_Access_Type_Definition (3.10)
3749 -------------------------------------------
3750 -- 3.10 Access To Subprogram Definition --
3751 -------------------------------------------
3753 -- Parsed by P_Access_Type_Definition (3.10)
3755 -----------------------------
3756 -- 3.10 Access Definition --
3757 -----------------------------
3759 -- ACCESS_DEFINITION ::=
3760 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3761 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3763 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3764 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3765 -- | [NULL_EXCLUSION] access [protected] function
3766 -- PARAMETER_AND_RESULT_PROFILE
3768 -- The caller has parsed the null-exclusion part and it has also checked
3769 -- that the next token is ACCESS
3771 -- Error recovery: cannot raise Error_Resync
3773 function P_Access_Definition
3774 (Null_Exclusion_Present
: Boolean) return Node_Id
is
3776 Subp_Node
: Node_Id
;
3779 Def_Node
:= New_Node
(N_Access_Definition
, Token_Ptr
);
3780 Scan
; -- past ACCESS
3782 -- Ada 2005 (AI-254/AI-231)
3784 if Ada_Version
>= Ada_05
then
3786 -- Ada 2005 (AI-254): Access_To_Subprogram_Definition
3788 if Token
= Tok_Protected
3789 or else Token
= Tok_Procedure
3790 or else Token
= Tok_Function
3793 P_Access_Type_Definition
(Header_Already_Parsed
=> True);
3794 Set_Null_Exclusion_Present
(Subp_Node
, Null_Exclusion_Present
);
3795 Set_Access_To_Subprogram_Definition
(Def_Node
, Subp_Node
);
3797 -- Ada 2005 (AI-231)
3798 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3801 Set_Null_Exclusion_Present
(Def_Node
, Null_Exclusion_Present
);
3803 if Token
= Tok_All
then
3805 Set_All_Present
(Def_Node
);
3807 elsif Token
= Tok_Constant
then
3808 Scan
; -- past CONSTANT
3809 Set_Constant_Present
(Def_Node
);
3812 Set_Subtype_Mark
(Def_Node
, P_Subtype_Mark
);
3819 Set_Null_Exclusion_Present
(Def_Node
, False);
3820 Set_Subtype_Mark
(Def_Node
, P_Subtype_Mark
);
3825 end P_Access_Definition
;
3827 -----------------------------------------
3828 -- 3.10.1 Incomplete Type Declaration --
3829 -----------------------------------------
3831 -- Parsed by P_Type_Declaration (3.2.1)
3833 ----------------------------
3834 -- 3.11 Declarative Part --
3835 ----------------------------
3837 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
3839 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items
3840 -- handles errors, and returns cleanly after an error has occurred)
3842 function P_Declarative_Part
return List_Id
is
3847 -- Indicate no bad declarations detected yet. This will be reset by
3848 -- P_Declarative_Items if a bad declaration is discovered.
3850 Missing_Begin_Msg
:= No_Error_Msg
;
3852 -- Get rid of active SIS entry from outer scope. This means we will
3853 -- miss some nested cases, but it doesn't seem worth the effort. See
3854 -- discussion in Par for further details
3856 SIS_Entry_Active
:= False;
3859 -- Loop to scan out the declarations
3862 P_Declarative_Items
(Decls
, Done
, In_Spec
=> False);
3866 -- Get rid of active SIS entry which is left set only if we scanned a
3867 -- procedure declaration and have not found the body. We could give
3868 -- an error message, but that really would be usurping the role of
3869 -- semantic analysis (this really is a missing body case).
3871 SIS_Entry_Active
:= False;
3873 end P_Declarative_Part
;
3875 ----------------------------
3876 -- 3.11 Declarative Item --
3877 ----------------------------
3879 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
3881 -- Can return Error if a junk declaration is found, or Empty if no
3882 -- declaration is found (i.e. a token ending declarations, such as
3883 -- BEGIN or END is encountered).
3885 -- Error recovery: cannot raise Error_Resync. If an error resync occurs,
3886 -- then the scan is set past the next semicolon and Error is returned.
3888 procedure P_Declarative_Items
3893 Scan_State
: Saved_Scan_State
;
3896 if Style_Check
then Style
.Check_Indentation
; end if;
3900 when Tok_Function
=>
3902 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3908 -- Check for loop (premature statement)
3910 Save_Scan_State
(Scan_State
);
3913 if Token
= Tok_Identifier
then
3914 Scan
; -- past identifier
3916 if Token
= Tok_In
then
3917 Restore_Scan_State
(Scan_State
);
3918 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
3923 -- Not a loop, so must be rep clause
3925 Restore_Scan_State
(Scan_State
);
3926 Append
(P_Representation_Clause
, Decls
);
3931 Append
(P_Generic
, Decls
);
3934 when Tok_Identifier
=>
3936 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
3938 -- Ada2005: A subprogram declaration can start with "not" or
3939 -- "overriding". In older versions, "overriding" is handled
3940 -- like an identifier, with the appropriate warning.
3944 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3947 when Tok_Overriding
=>
3949 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3954 Append
(P_Package
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3958 Append
(P_Pragma
, Decls
);
3961 when Tok_Procedure
=>
3963 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3966 when Tok_Protected
=>
3968 Scan
; -- past PROTECTED
3969 Append
(P_Protected
, Decls
);
3974 Append
(P_Subtype_Declaration
, Decls
);
3980 Append
(P_Task
, Decls
);
3985 Append
(P_Type_Declaration
, Decls
);
3990 Append
(P_Use_Clause
, Decls
);
3995 Error_Msg_SC
("WITH can only appear in context clause");
3998 -- BEGIN terminates the scan of a sequence of declarations unless
3999 -- there is a missing subprogram body, see section on handling
4000 -- semicolon in place of IS. We only treat the begin as satisfying
4001 -- the subprogram declaration if it falls in the expected column
4005 if SIS_Entry_Active
and then Start_Column
>= SIS_Ecol
then
4007 -- Here we have the case where a BEGIN is encountered during
4008 -- declarations in a declarative part, or at the outer level,
4009 -- and there is a subprogram declaration outstanding for which
4010 -- no body has been supplied. This is the case where we assume
4011 -- that the semicolon in the subprogram declaration should
4012 -- really have been is. The active SIS entry describes the
4013 -- subprogram declaration. On return the declaration has been
4014 -- modified to become a body.
4017 Specification_Node
: Node_Id
;
4018 Decl_Node
: Node_Id
;
4019 Body_Node
: Node_Id
;
4022 -- First issue the error message. If we had a missing
4023 -- semicolon in the declaration, then change the message
4024 -- to <missing "is">
4026 if SIS_Missing_Semicolon_Message
/= No_Error_Msg
then
4027 Change_Error_Text
-- Replace: "missing "";"" "
4028 (SIS_Missing_Semicolon_Message
, "missing ""is""");
4030 -- Otherwise we saved the semicolon position, so complain
4033 Error_Msg
(""";"" should be IS", SIS_Semicolon_Sloc
);
4036 -- The next job is to fix up any declarations that occurred
4037 -- between the procedure header and the BEGIN. These got
4038 -- chained to the outer declarative region (immediately
4039 -- after the procedure declaration) and they should be
4040 -- chained to the subprogram itself, which is a body
4041 -- rather than a spec.
4043 Specification_Node
:= Specification
(SIS_Declaration_Node
);
4044 Change_Node
(SIS_Declaration_Node
, N_Subprogram_Body
);
4045 Body_Node
:= SIS_Declaration_Node
;
4046 Set_Specification
(Body_Node
, Specification_Node
);
4047 Set_Declarations
(Body_Node
, New_List
);
4050 Decl_Node
:= Remove_Next
(Body_Node
);
4051 exit when Decl_Node
= Empty
;
4052 Append
(Decl_Node
, Declarations
(Body_Node
));
4055 -- Now make the scope table entry for the Begin-End and
4059 Scope
.Table
(Scope
.Last
).Sloc
:= SIS_Sloc
;
4060 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
4061 Scope
.Table
(Scope
.Last
).Ecol
:= SIS_Ecol
;
4062 Scope
.Table
(Scope
.Last
).Labl
:= SIS_Labl
;
4063 Scope
.Table
(Scope
.Last
).Lreq
:= False;
4064 SIS_Entry_Active
:= False;
4066 Set_Handled_Statement_Sequence
(Body_Node
,
4067 P_Handled_Sequence_Of_Statements
);
4068 End_Statements
(Handled_Statement_Sequence
(Body_Node
));
4077 -- Normally an END terminates the scan for basic declarative
4078 -- items. The one exception is END RECORD, which is probably
4079 -- left over from some other junk.
4082 Save_Scan_State
(Scan_State
); -- at END
4085 if Token
= Tok_Record
then
4086 Error_Msg_SP
("no RECORD for this `end record`!");
4087 Scan
; -- past RECORD
4091 Restore_Scan_State
(Scan_State
); -- to END
4095 -- The following tokens which can only be the start of a statement
4096 -- are considered to end a declarative part (i.e. we have a missing
4097 -- BEGIN situation). We are fairly conservative in making this
4098 -- judgment, because it is a real mess to go into statement mode
4099 -- prematurely in response to a junk declaration.
4114 -- But before we decide that it's a statement, let's check for
4115 -- a reserved word misused as an identifier.
4117 if Is_Reserved_Identifier
then
4118 Save_Scan_State
(Scan_State
);
4119 Scan
; -- past the token
4121 -- If reserved identifier not followed by colon or comma, then
4122 -- this is most likely an assignment statement to the bad id.
4124 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
4125 Restore_Scan_State
(Scan_State
);
4126 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4129 -- Otherwise we have a declaration of the bad id
4132 Restore_Scan_State
(Scan_State
);
4133 Scan_Reserved_Identifier
(Force_Msg
=> True);
4134 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4137 -- If not reserved identifier, then it's definitely a statement
4140 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4144 -- The token RETURN may well also signal a missing BEGIN situation,
4145 -- however, we never let it end the declarative part, because it may
4146 -- also be part of a half-baked function declaration.
4149 Error_Msg_SC
("misplaced RETURN statement");
4152 -- PRIVATE definitely terminates the declarations in a spec,
4153 -- and is an error in a body.
4159 Error_Msg_SC
("PRIVATE not allowed in body");
4160 Scan
; -- past PRIVATE
4163 -- An end of file definitely terminates the declarations!
4168 -- The remaining tokens do not end the scan, but cannot start a
4169 -- valid declaration, so we signal an error and resynchronize.
4170 -- But first check for misuse of a reserved identifier.
4174 -- Here we check for a reserved identifier
4176 if Is_Reserved_Identifier
then
4177 Save_Scan_State
(Scan_State
);
4178 Scan
; -- past the token
4180 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
4181 Restore_Scan_State
(Scan_State
);
4182 Set_Declaration_Expected
;
4185 Restore_Scan_State
(Scan_State
);
4186 Scan_Reserved_Identifier
(Force_Msg
=> True);
4188 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4192 Set_Declaration_Expected
;
4197 -- To resynchronize after an error, we scan to the next semicolon and
4198 -- return with Done = False, indicating that there may still be more
4199 -- valid declarations to come.
4202 when Error_Resync
=>
4203 Resync_Past_Semicolon
;
4205 end P_Declarative_Items
;
4207 ----------------------------------
4208 -- 3.11 Basic Declarative Item --
4209 ----------------------------------
4211 -- BASIC_DECLARATIVE_ITEM ::=
4212 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
4214 -- Scan zero or more basic declarative items
4216 -- Error recovery: cannot raise Error_Resync. If an error is detected, then
4217 -- the scan pointer is repositioned past the next semicolon, and the scan
4218 -- for declarative items continues.
4220 function P_Basic_Declarative_Items
return List_Id
is
4227 -- Indicate no bad declarations detected yet in the current context:
4228 -- visible or private declarations of a package spec.
4230 Missing_Begin_Msg
:= No_Error_Msg
;
4232 -- Get rid of active SIS entry from outer scope. This means we will
4233 -- miss some nested cases, but it doesn't seem worth the effort. See
4234 -- discussion in Par for further details
4236 SIS_Entry_Active
:= False;
4238 -- Loop to scan out declarations
4243 P_Declarative_Items
(Decls
, Done
, In_Spec
=> True);
4247 -- Get rid of active SIS entry. This is set only if we have scanned a
4248 -- procedure declaration and have not found the body. We could give
4249 -- an error message, but that really would be usurping the role of
4250 -- semantic analysis (this really is a case of a missing body).
4252 SIS_Entry_Active
:= False;
4254 -- Test for assorted illegal declarations not diagnosed elsewhere
4256 Decl
:= First
(Decls
);
4258 while Present
(Decl
) loop
4259 Kind
:= Nkind
(Decl
);
4261 -- Test for body scanned, not acceptable as basic decl item
4263 if Kind
= N_Subprogram_Body
or else
4264 Kind
= N_Package_Body
or else
4265 Kind
= N_Task_Body
or else
4266 Kind
= N_Protected_Body
4269 ("proper body not allowed in package spec", Sloc
(Decl
));
4271 -- Test for body stub scanned, not acceptable as basic decl item
4273 elsif Kind
in N_Body_Stub
then
4275 ("body stub not allowed in package spec", Sloc
(Decl
));
4277 elsif Kind
= N_Assignment_Statement
then
4279 ("assignment statement not allowed in package spec",
4287 end P_Basic_Declarative_Items
;
4293 -- For proper body, see below
4294 -- For body stub, see 10.1.3
4296 -----------------------
4297 -- 3.11 Proper Body --
4298 -----------------------
4300 -- Subprogram body is parsed by P_Subprogram (6.1)
4301 -- Package body is parsed by P_Package (7.1)
4302 -- Task body is parsed by P_Task (9.1)
4303 -- Protected body is parsed by P_Protected (9.4)
4305 ------------------------------
4306 -- Set_Declaration_Expected --
4307 ------------------------------
4309 procedure Set_Declaration_Expected
is
4311 Error_Msg_SC
("declaration expected");
4313 if Missing_Begin_Msg
= No_Error_Msg
then
4314 Missing_Begin_Msg
:= Get_Msg_Id
;
4316 end Set_Declaration_Expected
;
4318 ----------------------
4319 -- Skip_Declaration --
4320 ----------------------
4322 procedure Skip_Declaration
(S
: List_Id
) is
4323 Dummy_Done
: Boolean;
4326 P_Declarative_Items
(S
, Dummy_Done
, False);
4327 end Skip_Declaration
;
4329 -----------------------------------------
4330 -- Statement_When_Declaration_Expected --
4331 -----------------------------------------
4333 procedure Statement_When_Declaration_Expected
4339 -- Case of second occurrence of statement in one declaration sequence
4341 if Missing_Begin_Msg
/= No_Error_Msg
then
4343 -- In the procedure spec case, just ignore it, we only give one
4344 -- message for the first occurrence, since otherwise we may get
4345 -- horrible cascading if BODY was missing in the header line.
4350 -- In the declarative part case, take a second statement as a sure
4351 -- sign that we really have a missing BEGIN, and end the declarative
4352 -- part now. Note that the caller will fix up the first message to
4353 -- say "missing BEGIN" so that's how the error will be signalled.
4360 -- Case of first occurrence of unexpected statement
4363 -- If we are in a package spec, then give message of statement
4364 -- not allowed in package spec. This message never gets changed.
4367 Error_Msg_SC
("statement not allowed in package spec");
4369 -- If in declarative part, then we give the message complaining
4370 -- about finding a statement when a declaration is expected. This
4371 -- gets changed to a complaint about a missing BEGIN if we later
4372 -- find that no BEGIN is present.
4375 Error_Msg_SC
("statement not allowed in declarative part");
4378 -- Capture message Id. This is used for two purposes, first to
4379 -- stop multiple messages, see test above, and second, to allow
4380 -- the replacement of the message in the declarative part case.
4382 Missing_Begin_Msg
:= Get_Msg_Id
;
4385 -- In all cases except the case in which we decided to terminate the
4386 -- declaration sequence on a second error, we scan out the statement
4387 -- and append it to the list of declarations (note that the semantics
4388 -- can handle statements in a declaration list so if we proceed to
4389 -- call the semantic phase, all will be (reasonably) well!
4391 Append_List_To
(Decls
, P_Sequence_Of_Statements
(SS_Unco
));
4393 -- Done is set to False, since we want to continue the scan of
4394 -- declarations, hoping that this statement was a temporary glitch.
4395 -- If we indeed are now in the statement part (i.e. this was a missing
4396 -- BEGIN, then it's not terrible, we will simply keep calling this
4397 -- procedure to process the statements one by one, and then finally
4398 -- hit the missing BEGIN, which will clean up the error message.
4401 end Statement_When_Declaration_Expected
;