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 if Ada_Version
< Ada_05
then
919 ("null-excluding access is an Ada 2005 extension");
920 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
925 if Token
= Tok_Null
then
928 Error_Msg_SP
("NULL expected");
933 end P_Null_Exclusion
;
935 function P_Subtype_Indication
936 (Not_Null_Present
: Boolean := False) return Node_Id
is
940 if Token
= Tok_Identifier
or else Token
= Tok_Operator_Symbol
then
941 Type_Node
:= P_Subtype_Mark
;
942 return P_Subtype_Indication
(Type_Node
, Not_Null_Present
);
945 -- Check for error of using record definition and treat it nicely,
946 -- otherwise things are really messed up, so resynchronize.
948 if Token
= Tok_Record
then
949 Error_Msg_SC
("anonymous record definitions are not permitted");
950 Discard_Junk_Node
(P_Record_Definition
);
954 Error_Msg_AP
("subtype indication expected");
958 end P_Subtype_Indication
;
960 -- The following function is identical except that it is called with
961 -- the subtype mark already scanned out, and it scans out the constraint
963 -- Error recovery: can raise Error_Resync
965 function P_Subtype_Indication
966 (Subtype_Mark
: Node_Id
;
967 Not_Null_Present
: Boolean := False) return Node_Id
is
968 Indic_Node
: Node_Id
;
969 Constr_Node
: Node_Id
;
972 Constr_Node
:= P_Constraint_Opt
;
974 if No
(Constr_Node
) then
977 if Not_Null_Present
then
978 Error_Msg_SP
("constrained null-exclusion not allowed");
981 Indic_Node
:= New_Node
(N_Subtype_Indication
, Sloc
(Subtype_Mark
));
982 Set_Subtype_Mark
(Indic_Node
, Check_Subtype_Mark
(Subtype_Mark
));
983 Set_Constraint
(Indic_Node
, Constr_Node
);
986 end P_Subtype_Indication
;
988 -------------------------
989 -- 3.2.2 Subtype Mark --
990 -------------------------
992 -- SUBTYPE_MARK ::= subtype_NAME;
994 -- Note: The subtype mark which appears after an IN or NOT IN
995 -- operator is parsed by P_Range_Or_Subtype_Mark (3.5)
997 -- Error recovery: cannot raise Error_Resync
999 function P_Subtype_Mark
return Node_Id
is
1001 return P_Subtype_Mark_Resync
;
1004 when Error_Resync
=>
1008 -- This routine differs from P_Subtype_Mark in that it insists that an
1009 -- identifier be present, and if it is not, it raises Error_Resync.
1011 -- Error recovery: can raise Error_Resync
1013 function P_Subtype_Mark_Resync
return Node_Id
is
1014 Type_Node
: Node_Id
;
1017 if Token
= Tok_Access
then
1018 Error_Msg_SC
("anonymous access type definition not allowed here");
1019 Scan
; -- past ACCESS
1022 if Token
= Tok_Array
then
1023 Error_Msg_SC
("anonymous array definition not allowed here");
1024 Discard_Junk_Node
(P_Array_Type_Definition
);
1028 Type_Node
:= P_Qualified_Simple_Name_Resync
;
1030 -- Check for a subtype mark attribute. The only valid possibilities
1031 -- are 'CLASS and 'BASE. Anything else is a definite error. We may
1032 -- as well catch it here.
1034 if Token
= Tok_Apostrophe
then
1035 return P_Subtype_Mark_Attribute
(Type_Node
);
1040 end P_Subtype_Mark_Resync
;
1042 -- The following function is called to scan out a subtype mark attribute.
1043 -- The caller has already scanned out the subtype mark, which is passed in
1044 -- as the argument, and has checked that the current token is apostrophe.
1046 -- Only a special subclass of attributes, called type attributes
1047 -- (see Snames package) are allowed in this syntactic position.
1049 -- Note: if the apostrophe is followed by other than an identifier, then
1050 -- the input expression is returned unchanged, and the scan pointer is
1051 -- left pointing to the apostrophe.
1053 -- Error recovery: can raise Error_Resync
1055 function P_Subtype_Mark_Attribute
(Type_Node
: Node_Id
) return Node_Id
is
1056 Attr_Node
: Node_Id
:= Empty
;
1057 Scan_State
: Saved_Scan_State
;
1061 Prefix
:= Check_Subtype_Mark
(Type_Node
);
1063 if Prefix
= Error
then
1067 -- Loop through attributes appearing (more than one can appear as for
1068 -- for example in X'Base'Class). We are at an apostrophe on entry to
1069 -- this loop, and it runs once for each attribute parsed, with
1070 -- Prefix being the current possible prefix if it is an attribute.
1073 Save_Scan_State
(Scan_State
); -- at Apostrophe
1074 Scan
; -- past apostrophe
1076 if Token
/= Tok_Identifier
then
1077 Restore_Scan_State
(Scan_State
); -- to apostrophe
1078 return Prefix
; -- no attribute after all
1080 elsif not Is_Type_Attribute_Name
(Token_Name
) then
1082 ("attribute & may not be used in a subtype mark", Token_Node
);
1087 Make_Attribute_Reference
(Prev_Token_Ptr
,
1089 Attribute_Name
=> Token_Name
);
1090 Delete_Node
(Token_Node
);
1091 Scan
; -- past type attribute identifier
1094 exit when Token
/= Tok_Apostrophe
;
1095 Prefix
:= Attr_Node
;
1098 -- Fall through here after scanning type attribute
1101 end P_Subtype_Mark_Attribute
;
1103 -----------------------
1104 -- 3.2.2 Constraint --
1105 -----------------------
1107 -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT
1109 -- SCALAR_CONSTRAINT ::=
1110 -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT
1112 -- COMPOSITE_CONSTRAINT ::=
1113 -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT
1115 -- If no constraint is present, this function returns Empty
1117 -- Error recovery: can raise Error_Resync
1119 function P_Constraint_Opt
return Node_Id
is
1121 if Token
= Tok_Range
1122 or else Bad_Spelling_Of
(Tok_Range
)
1124 return P_Range_Constraint
;
1126 elsif Token
= Tok_Digits
1127 or else Bad_Spelling_Of
(Tok_Digits
)
1129 return P_Digits_Constraint
;
1131 elsif Token
= Tok_Delta
1132 or else Bad_Spelling_Of
(Tok_Delta
)
1134 return P_Delta_Constraint
;
1136 elsif Token
= Tok_Left_Paren
then
1137 return P_Index_Or_Discriminant_Constraint
;
1139 elsif Token
= Tok_In
then
1141 return P_Constraint_Opt
;
1146 end P_Constraint_Opt
;
1148 ------------------------------
1149 -- 3.2.2 Scalar Constraint --
1150 ------------------------------
1152 -- Parsed by P_Constraint_Opt (3.2.2)
1154 ---------------------------------
1155 -- 3.2.2 Composite Constraint --
1156 ---------------------------------
1158 -- Parsed by P_Constraint_Opt (3.2.2)
1160 --------------------------------------------------------
1161 -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) --
1162 --------------------------------------------------------
1164 -- This routine scans out a declaration starting with an identifier:
1166 -- OBJECT_DECLARATION ::=
1167 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1168 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1169 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1170 -- ACCESS_DEFINITION [:= EXPRESSION];
1171 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1172 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1174 -- NUMBER_DECLARATION ::=
1175 -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION;
1177 -- OBJECT_RENAMING_DECLARATION ::=
1178 -- DEFINING_IDENTIFIER : SUBTYPE_MARK renames object_NAME;
1179 -- | DEFINING_IDENTIFIER : ACCESS_DEFINITION renames object_NAME;
1181 -- EXCEPTION_RENAMING_DECLARATION ::=
1182 -- DEFINING_IDENTIFIER : exception renames exception_NAME;
1184 -- EXCEPTION_DECLARATION ::=
1185 -- DEFINING_IDENTIFIER_LIST : exception;
1187 -- Note that the ALIASED indication in an object declaration is
1188 -- marked by a flag in the parent node.
1190 -- The caller has checked that the initial token is an identifier
1192 -- The value returned is a list of declarations, one for each identifier
1193 -- in the list (as described in Sinfo, we always split up multiple
1194 -- declarations into the equivalent sequence of single declarations
1195 -- using the More_Ids and Prev_Ids flags to preserve the source).
1197 -- If the identifier turns out to be a probable statement rather than
1198 -- an identifier, then the scan is left pointing to the identifier and
1199 -- No_List is returned.
1201 -- Error recovery: can raise Error_Resync
1203 procedure P_Identifier_Declarations
1209 Decl_Node
: Node_Id
;
1210 Type_Node
: Node_Id
;
1211 Ident_Sloc
: Source_Ptr
;
1212 Scan_State
: Saved_Scan_State
;
1213 List_OK
: Boolean := True;
1215 Init_Expr
: Node_Id
;
1216 Init_Loc
: Source_Ptr
;
1217 Con_Loc
: Source_Ptr
;
1218 Not_Null_Present
: Boolean := False;
1220 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
1221 -- Used to save identifiers in the identifier list. The upper bound
1222 -- of 4096 is expected to be infinite in practice, and we do not even
1223 -- bother to check if this upper bound is exceeded.
1225 Num_Idents
: Nat
:= 1;
1226 -- Number of identifiers stored in Idents
1229 -- This procedure is called in renames cases to make sure that we do
1230 -- not have more than one identifier. If we do have more than one
1231 -- then an error message is issued (and the declaration is split into
1232 -- multiple declarations)
1234 function Token_Is_Renames
return Boolean;
1235 -- Checks if current token is RENAMES, and if so, scans past it and
1236 -- returns True, otherwise returns False. Includes checking for some
1237 -- common error cases.
1239 procedure No_List
is
1241 if Num_Idents
> 1 then
1242 Error_Msg
("identifier list not allowed for RENAMES",
1249 function Token_Is_Renames
return Boolean is
1250 At_Colon
: Saved_Scan_State
;
1253 if Token
= Tok_Colon
then
1254 Save_Scan_State
(At_Colon
);
1256 Check_Misspelling_Of
(Tok_Renames
);
1258 if Token
= Tok_Renames
then
1259 Error_Msg_SP
("extra "":"" ignored");
1260 Scan
; -- past RENAMES
1263 Restore_Scan_State
(At_Colon
);
1268 Check_Misspelling_Of
(Tok_Renames
);
1270 if Token
= Tok_Renames
then
1271 Scan
; -- past RENAMES
1277 end Token_Is_Renames
;
1279 -- Start of processing for P_Identifier_Declarations
1282 Ident_Sloc
:= Token_Ptr
;
1283 Save_Scan_State
(Scan_State
); -- at first identifier
1284 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
1286 -- If we have a colon after the identifier, then we can assume that
1287 -- this is in fact a valid identifier declaration and can steam ahead.
1289 if Token
= Tok_Colon
then
1292 -- If we have a comma, then scan out the list of identifiers
1294 elsif Token
= Tok_Comma
then
1296 while Comma_Present
loop
1297 Num_Idents
:= Num_Idents
+ 1;
1298 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
1301 Save_Scan_State
(Scan_State
); -- at colon
1304 -- If we have identifier followed by := then we assume that what is
1305 -- really meant is an assignment statement. The assignment statement
1306 -- is scanned out and added to the list of declarations. An exception
1307 -- occurs if the := is followed by the keyword constant, in which case
1308 -- we assume it was meant to be a colon.
1310 elsif Token
= Tok_Colon_Equal
then
1313 if Token
= Tok_Constant
then
1314 Error_Msg_SP
("colon expected");
1317 Restore_Scan_State
(Scan_State
);
1318 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
1322 -- If we have an IS keyword, then assume the TYPE keyword was missing
1324 elsif Token
= Tok_Is
then
1325 Restore_Scan_State
(Scan_State
);
1326 Append_To
(Decls
, P_Type_Declaration
);
1330 -- Otherwise we have an error situation
1333 Restore_Scan_State
(Scan_State
);
1335 -- First case is possible misuse of PROTECTED in Ada 83 mode. If
1336 -- so, fix the keyword and return to scan the protected declaration.
1338 if Token_Name
= Name_Protected
then
1339 Check_95_Keyword
(Tok_Protected
, Tok_Identifier
);
1340 Check_95_Keyword
(Tok_Protected
, Tok_Type
);
1341 Check_95_Keyword
(Tok_Protected
, Tok_Body
);
1343 if Token
= Tok_Protected
then
1348 -- Check misspelling possibilities. If so, correct the misspelling
1349 -- and return to scan out the resulting declaration.
1351 elsif Bad_Spelling_Of
(Tok_Function
)
1352 or else Bad_Spelling_Of
(Tok_Procedure
)
1353 or else Bad_Spelling_Of
(Tok_Package
)
1354 or else Bad_Spelling_Of
(Tok_Pragma
)
1355 or else Bad_Spelling_Of
(Tok_Protected
)
1356 or else Bad_Spelling_Of
(Tok_Generic
)
1357 or else Bad_Spelling_Of
(Tok_Subtype
)
1358 or else Bad_Spelling_Of
(Tok_Type
)
1359 or else Bad_Spelling_Of
(Tok_Task
)
1360 or else Bad_Spelling_Of
(Tok_Use
)
1361 or else Bad_Spelling_Of
(Tok_For
)
1366 -- Otherwise we definitely have an ordinary identifier with a junk
1367 -- token after it. Just complain that we expect a declaration, and
1368 -- skip to a semicolon
1371 Set_Declaration_Expected
;
1372 Resync_Past_Semicolon
;
1378 -- Come here with an identifier list and colon scanned out. We now
1379 -- build the nodes for the declarative items. One node is built for
1380 -- each identifier in the list, with the type information being
1381 -- repeated by rescanning the appropriate section of source.
1383 -- First an error check, if we have two identifiers in a row, a likely
1384 -- possibility is that the first of the identifiers is an incorrectly
1387 if Token
= Tok_Identifier
then
1389 SS
: Saved_Scan_State
;
1393 Save_Scan_State
(SS
);
1394 Scan
; -- past initial identifier
1395 I2
:= (Token
= Tok_Identifier
);
1396 Restore_Scan_State
(SS
);
1400 (Bad_Spelling_Of
(Tok_Access
) or else
1401 Bad_Spelling_Of
(Tok_Aliased
) or else
1402 Bad_Spelling_Of
(Tok_Constant
))
1409 -- Loop through identifiers
1414 -- Check for some cases of misused Ada 95 keywords
1416 if Token_Name
= Name_Aliased
then
1417 Check_95_Keyword
(Tok_Aliased
, Tok_Array
);
1418 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
1419 Check_95_Keyword
(Tok_Aliased
, Tok_Constant
);
1424 if Token
= Tok_Constant
then
1425 Con_Loc
:= Token_Ptr
;
1426 Scan
; -- past CONSTANT
1428 -- Number declaration, initialization required
1430 Init_Expr
:= Init_Expr_Opt
;
1432 if Present
(Init_Expr
) then
1433 if Not_Null_Present
then
1434 Error_Msg_SP
("null-exclusion not allowed in "
1435 & "numeric expression");
1438 Decl_Node
:= New_Node
(N_Number_Declaration
, Ident_Sloc
);
1439 Set_Expression
(Decl_Node
, Init_Expr
);
1441 -- Constant object declaration
1444 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1445 Set_Constant_Present
(Decl_Node
, True);
1447 if Token_Name
= Name_Aliased
then
1448 Check_95_Keyword
(Tok_Aliased
, Tok_Array
);
1449 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
1452 if Token
= Tok_Aliased
then
1453 Error_Msg_SC
("ALIASED should be before CONSTANT");
1454 Scan
; -- past ALIASED
1455 Set_Aliased_Present
(Decl_Node
, True);
1458 if Token
= Tok_Array
then
1459 Set_Object_Definition
1460 (Decl_Node
, P_Array_Type_Definition
);
1463 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1464 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1466 if Token
= Tok_Access
then
1467 if Ada_Version
< Ada_05
then
1469 ("generalized use of anonymous access types " &
1470 "is an Ada 2005 extension");
1472 ("\unit must be compiled with -gnat05 switch");
1475 Set_Object_Definition
1476 (Decl_Node
, P_Access_Definition
(Not_Null_Present
));
1478 Set_Object_Definition
1479 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
1483 if Token
= Tok_Renames
then
1485 ("CONSTANT not permitted in renaming declaration",
1487 Scan
; -- Past renames
1488 Discard_Junk_Node
(P_Name
);
1494 elsif Token
= Tok_Exception
then
1495 Scan
; -- past EXCEPTION
1497 if Token_Is_Renames
then
1500 New_Node
(N_Exception_Renaming_Declaration
, Ident_Sloc
);
1501 Set_Name
(Decl_Node
, P_Qualified_Simple_Name_Resync
);
1504 Decl_Node
:= New_Node
(N_Exception_Declaration
, Prev_Token_Ptr
);
1507 -- Aliased case (note that an object definition is required)
1509 elsif Token
= Tok_Aliased
then
1510 Scan
; -- past ALIASED
1511 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1512 Set_Aliased_Present
(Decl_Node
, True);
1514 if Token
= Tok_Constant
then
1515 Scan
; -- past CONSTANT
1516 Set_Constant_Present
(Decl_Node
, True);
1519 if Token
= Tok_Array
then
1520 Set_Object_Definition
1521 (Decl_Node
, P_Array_Type_Definition
);
1524 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1525 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1527 -- Access definition (AI-406) or subtype indication
1529 if Token
= Tok_Access
then
1530 if Ada_Version
< Ada_05
then
1532 ("generalized use of anonymous access types " &
1533 "is an Ada 2005 extension");
1535 ("\unit must be compiled with -gnat05 switch");
1538 Set_Object_Definition
1539 (Decl_Node
, P_Access_Definition
(Not_Null_Present
));
1541 Set_Object_Definition
1542 (Decl_Node
, P_Subtype_Indication
(Not_Null_Present
));
1548 elsif Token
= Tok_Array
then
1549 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1550 Set_Object_Definition
(Decl_Node
, P_Array_Type_Definition
);
1552 -- Ada 2005 (AI-254, AI-406)
1554 elsif Token
= Tok_Not
then
1556 -- OBJECT_DECLARATION ::=
1557 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1558 -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION];
1559 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1560 -- ACCESS_DEFINITION [:= EXPRESSION];
1562 -- OBJECT_RENAMING_DECLARATION ::=
1564 -- | DEFINING_IDENTIFIER : ACCESS_DEFINITION renames object_NAME;
1566 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1568 if Token
= Tok_Access
then
1569 if Ada_Version
< Ada_05
then
1571 ("generalized use of anonymous access types " &
1572 "is an Ada 2005 extension");
1573 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1576 Acc_Node
:= P_Access_Definition
(Not_Null_Present
);
1578 if Token
/= Tok_Renames
then
1579 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1580 Set_Object_Definition
(Decl_Node
, Acc_Node
);
1584 Scan
; -- past renames
1587 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1588 Set_Access_Definition
(Decl_Node
, Acc_Node
);
1589 Set_Name
(Decl_Node
, P_Name
);
1593 Type_Node
:= P_Subtype_Mark
;
1595 -- Object renaming declaration
1597 if Token_Is_Renames
then
1599 ("null-exclusion not allowed in object renamings");
1602 -- Object declaration
1605 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1606 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1607 Set_Object_Definition
1609 P_Subtype_Indication
(Type_Node
, Not_Null_Present
));
1611 -- RENAMES at this point means that we had the combination
1612 -- of a constraint on the Type_Node and renames, which is
1615 if Token_Is_Renames
then
1616 Error_Msg_N
("constraint not allowed in object renaming "
1618 Constraint
(Object_Definition
(Decl_Node
)));
1624 -- Ada 2005 (AI-230): Access Definition case
1626 elsif Token
= Tok_Access
then
1627 if Ada_Version
< Ada_05
then
1629 ("generalized use of anonymous access types " &
1630 "is an Ada 2005 extension");
1631 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1634 Acc_Node
:= P_Access_Definition
(Null_Exclusion_Present
=> False);
1636 -- Object declaration with access definition, or renaming
1638 if Token
/= Tok_Renames
then
1639 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1640 Set_Object_Definition
(Decl_Node
, Acc_Node
);
1641 goto init
; -- ??? is this really needed goes here anyway
1644 Scan
; -- past renames
1647 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1648 Set_Access_Definition
(Decl_Node
, Acc_Node
);
1649 Set_Name
(Decl_Node
, P_Name
);
1652 -- Subtype indication case
1655 Type_Node
:= P_Subtype_Mark
;
1657 -- Object renaming declaration
1659 if Token_Is_Renames
then
1662 New_Node
(N_Object_Renaming_Declaration
, Ident_Sloc
);
1663 Set_Subtype_Mark
(Decl_Node
, Type_Node
);
1664 Set_Name
(Decl_Node
, P_Name
);
1666 -- Object declaration
1669 Decl_Node
:= New_Node
(N_Object_Declaration
, Ident_Sloc
);
1670 Set_Null_Exclusion_Present
(Decl_Node
, Not_Null_Present
);
1671 Set_Object_Definition
1673 P_Subtype_Indication
(Type_Node
, Not_Null_Present
));
1675 -- RENAMES at this point means that we had the combination of
1676 -- a constraint on the Type_Node and renames, which is illegal
1678 if Token_Is_Renames
then
1680 ("constraint not allowed in object renaming declaration",
1681 Constraint
(Object_Definition
(Decl_Node
)));
1687 -- Scan out initialization, allowed only for object declaration
1689 <<init
>> -- is this really needed ???
1690 Init_Loc
:= Token_Ptr
;
1691 Init_Expr
:= Init_Expr_Opt
;
1693 if Present
(Init_Expr
) then
1694 if Nkind
(Decl_Node
) = N_Object_Declaration
then
1695 Set_Expression
(Decl_Node
, Init_Expr
);
1697 Error_Msg
("initialization not allowed here", Init_Loc
);
1702 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
1705 if Ident
< Num_Idents
then
1706 Set_More_Ids
(Decl_Node
, True);
1710 Set_Prev_Ids
(Decl_Node
, True);
1714 Append
(Decl_Node
, Decls
);
1715 exit Ident_Loop
when Ident
= Num_Idents
;
1716 Restore_Scan_State
(Scan_State
);
1719 end loop Ident_Loop
;
1722 end P_Identifier_Declarations
;
1724 -------------------------------
1725 -- 3.3.1 Object Declaration --
1726 -------------------------------
1728 -- OBJECT DECLARATION ::=
1729 -- DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1730 -- SUBTYPE_INDICATION [:= EXPRESSION];
1731 -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant]
1732 -- ARRAY_TYPE_DEFINITION [:= EXPRESSION];
1733 -- | SINGLE_TASK_DECLARATION
1734 -- | SINGLE_PROTECTED_DECLARATION
1736 -- Cases starting with TASK are parsed by P_Task (9.1)
1737 -- Cases starting with PROTECTED are parsed by P_Protected (9.4)
1738 -- All other cases are parsed by P_Identifier_Declarations (3.3)
1740 -------------------------------------
1741 -- 3.3.1 Defining Identifier List --
1742 -------------------------------------
1744 -- DEFINING_IDENTIFIER_LIST ::=
1745 -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER}
1747 -- Always parsed by the construct in which it appears. See special
1748 -- section on "Handling of Defining Identifier Lists" in this unit.
1750 -------------------------------
1751 -- 3.3.2 Number Declaration --
1752 -------------------------------
1754 -- Parsed by P_Identifier_Declarations (3.3)
1756 -------------------------------------------------------------------------
1757 -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) --
1758 -------------------------------------------------------------------------
1760 -- DERIVED_TYPE_DEFINITION ::=
1761 -- [abstract] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION
1762 -- [[AND interface_list] RECORD_EXTENSION_PART]
1764 -- PRIVATE_EXTENSION_DECLARATION ::=
1765 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is
1766 -- [abstract] [limited] new ancestor_SUBTYPE_INDICATION
1767 -- [AND interface_list] with PRIVATE;
1769 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
1771 -- The caller has already scanned out the part up to the NEW, and Token
1772 -- either contains Tok_New (or ought to, if it doesn't this procedure
1773 -- will post an appropriate "NEW expected" message).
1775 -- Note: the caller is responsible for filling in the Sloc field of
1776 -- the returned node in the private extension declaration case as
1777 -- well as the stuff relating to the discriminant part.
1779 -- Error recovery: can raise Error_Resync;
1781 function P_Derived_Type_Def_Or_Private_Ext_Decl
return Node_Id
is
1782 Typedef_Node
: Node_Id
;
1783 Typedecl_Node
: Node_Id
;
1784 Not_Null_Present
: Boolean := False;
1787 Typedef_Node
:= New_Node
(N_Derived_Type_Definition
, Token_Ptr
);
1790 if Token
= Tok_Abstract
then
1791 Error_Msg_SC
("ABSTRACT must come before NEW, not after");
1795 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
1796 Set_Null_Exclusion_Present
(Typedef_Node
, Not_Null_Present
);
1797 Set_Subtype_Indication
(Typedef_Node
,
1798 P_Subtype_Indication
(Not_Null_Present
));
1800 -- Ada 2005 (AI-251): Deal with interfaces
1802 if Token
= Tok_And
then
1805 if Ada_Version
< Ada_05
then
1807 ("abstract interface is an Ada 2005 extension");
1808 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
1811 Set_Interface_List
(Typedef_Node
, New_List
);
1814 Append
(P_Qualified_Simple_Name
, Interface_List
(Typedef_Node
));
1815 exit when Token
/= Tok_And
;
1819 if Token
/= Tok_With
then
1820 Error_Msg_SC
("WITH expected");
1825 -- Deal with record extension, note that we assume that a WITH is
1826 -- missing in the case of "type X is new Y record ..." or in the
1827 -- case of "type X is new Y null record".
1830 or else Token
= Tok_Record
1831 or else Token
= Tok_Null
1833 T_With
; -- past WITH or give error message
1835 if Token
= Tok_Limited
then
1837 ("LIMITED keyword not allowed in private extension");
1838 Scan
; -- ignore LIMITED
1841 -- Private extension declaration
1843 if Token
= Tok_Private
then
1844 Scan
; -- past PRIVATE
1846 -- Throw away the type definition node and build the type
1847 -- declaration node. Note the caller must set the Sloc,
1848 -- Discriminant_Specifications, Unknown_Discriminants_Present,
1849 -- and Defined_Identifier fields in the returned node.
1852 Make_Private_Extension_Declaration
(No_Location
,
1853 Defining_Identifier
=> Empty
,
1854 Subtype_Indication
=> Subtype_Indication
(Typedef_Node
),
1855 Abstract_Present
=> Abstract_Present
(Typedef_Node
),
1856 Interface_List
=> Interface_List
(Typedef_Node
));
1858 Delete_Node
(Typedef_Node
);
1859 return Typedecl_Node
;
1861 -- Derived type definition with record extension part
1864 Set_Record_Extension_Part
(Typedef_Node
, P_Record_Definition
);
1865 return Typedef_Node
;
1868 -- Derived type definition with no record extension part
1871 return Typedef_Node
;
1873 end P_Derived_Type_Def_Or_Private_Ext_Decl
;
1875 ---------------------------
1876 -- 3.5 Range Constraint --
1877 ---------------------------
1879 -- RANGE_CONSTRAINT ::= range RANGE
1881 -- The caller has checked that the initial token is RANGE
1883 -- Error recovery: cannot raise Error_Resync
1885 function P_Range_Constraint
return Node_Id
is
1886 Range_Node
: Node_Id
;
1889 Range_Node
:= New_Node
(N_Range_Constraint
, Token_Ptr
);
1891 Set_Range_Expression
(Range_Node
, P_Range
);
1893 end P_Range_Constraint
;
1900 -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
1902 -- Note: the range that appears in a membership test is parsed by
1903 -- P_Range_Or_Subtype_Mark (3.5).
1905 -- Error recovery: cannot raise Error_Resync
1907 function P_Range
return Node_Id
is
1908 Expr_Node
: Node_Id
;
1909 Range_Node
: Node_Id
;
1912 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
1914 if Expr_Form
= EF_Range_Attr
then
1917 elsif Token
= Tok_Dot_Dot
then
1918 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
1919 Set_Low_Bound
(Range_Node
, Expr_Node
);
1921 Expr_Node
:= P_Expression
;
1922 Check_Simple_Expression
(Expr_Node
);
1923 Set_High_Bound
(Range_Node
, Expr_Node
);
1926 -- Anything else is an error
1929 T_Dot_Dot
; -- force missing .. message
1934 ----------------------------------
1935 -- 3.5 P_Range_Or_Subtype_Mark --
1936 ----------------------------------
1939 -- RANGE_ATTRIBUTE_REFERENCE
1940 -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION
1942 -- This routine scans out the range or subtype mark that forms the right
1943 -- operand of a membership test.
1945 -- Note: as documented in the Sinfo interface, although the syntax only
1946 -- allows a subtype mark, we in fact allow any simple expression to be
1947 -- returned from this routine. The semantics is responsible for issuing
1948 -- an appropriate message complaining if the argument is not a name.
1949 -- This simplifies the coding and error recovery processing in the
1950 -- parser, and in any case it is preferable not to consider this a
1951 -- syntax error and to continue with the semantic analysis.
1953 -- Error recovery: cannot raise Error_Resync
1955 function P_Range_Or_Subtype_Mark
return Node_Id
is
1956 Expr_Node
: Node_Id
;
1957 Range_Node
: Node_Id
;
1960 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
1962 if Expr_Form
= EF_Range_Attr
then
1965 -- Simple_Expression .. Simple_Expression
1967 elsif Token
= Tok_Dot_Dot
then
1968 Check_Simple_Expression
(Expr_Node
);
1969 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
1970 Set_Low_Bound
(Range_Node
, Expr_Node
);
1972 Set_High_Bound
(Range_Node
, P_Simple_Expression
);
1975 -- Case of subtype mark (optionally qualified simple name or an
1976 -- attribute whose prefix is an optionally qualifed simple name)
1978 elsif Expr_Form
= EF_Simple_Name
1979 or else Nkind
(Expr_Node
) = N_Attribute_Reference
1981 -- Check for error of range constraint after a subtype mark
1983 if Token
= Tok_Range
then
1985 ("range constraint not allowed in membership test");
1989 -- Check for error of DIGITS or DELTA after a subtype mark
1991 elsif Token
= Tok_Digits
or else Token
= Tok_Delta
then
1993 ("accuracy definition not allowed in membership test");
1994 Scan
; -- past DIGITS or DELTA
1997 elsif Token
= Tok_Apostrophe
then
1998 return P_Subtype_Mark_Attribute
(Expr_Node
);
2004 -- At this stage, we have some junk following the expression. We
2005 -- really can't tell what is wrong, might be a missing semicolon,
2006 -- or a missing THEN, or whatever. Our caller will figure it out!
2011 end P_Range_Or_Subtype_Mark
;
2013 ----------------------------------------
2014 -- 3.5.1 Enumeration Type Definition --
2015 ----------------------------------------
2017 -- ENUMERATION_TYPE_DEFINITION ::=
2018 -- (ENUMERATION_LITERAL_SPECIFICATION
2019 -- {, ENUMERATION_LITERAL_SPECIFICATION})
2021 -- The caller has already scanned out the TYPE keyword
2023 -- Error recovery: can raise Error_Resync;
2025 function P_Enumeration_Type_Definition
return Node_Id
is
2026 Typedef_Node
: Node_Id
;
2029 Typedef_Node
:= New_Node
(N_Enumeration_Type_Definition
, Token_Ptr
);
2030 Set_Literals
(Typedef_Node
, New_List
);
2035 Append
(P_Enumeration_Literal_Specification
, Literals
(Typedef_Node
));
2036 exit when not Comma_Present
;
2040 return Typedef_Node
;
2041 end P_Enumeration_Type_Definition
;
2043 ----------------------------------------------
2044 -- 3.5.1 Enumeration Literal Specification --
2045 ----------------------------------------------
2047 -- ENUMERATION_LITERAL_SPECIFICATION ::=
2048 -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL
2050 -- Error recovery: can raise Error_Resync
2052 function P_Enumeration_Literal_Specification
return Node_Id
is
2054 if Token
= Tok_Char_Literal
then
2055 return P_Defining_Character_Literal
;
2057 return P_Defining_Identifier
(C_Comma_Right_Paren
);
2059 end P_Enumeration_Literal_Specification
;
2061 ---------------------------------------
2062 -- 3.5.1 Defining_Character_Literal --
2063 ---------------------------------------
2065 -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL
2067 -- Error recovery: cannot raise Error_Resync
2069 -- The caller has checked that the current token is a character literal
2071 function P_Defining_Character_Literal
return Node_Id
is
2072 Literal_Node
: Node_Id
;
2075 Literal_Node
:= Token_Node
;
2076 Change_Character_Literal_To_Defining_Character_Literal
(Literal_Node
);
2077 Scan
; -- past character literal
2078 return Literal_Node
;
2079 end P_Defining_Character_Literal
;
2081 ------------------------------------
2082 -- 3.5.4 Integer Type Definition --
2083 ------------------------------------
2085 -- Parsed by P_Type_Declaration (3.2.1)
2087 -------------------------------------------
2088 -- 3.5.4 Signed Integer Type Definition --
2089 -------------------------------------------
2091 -- SIGNED_INTEGER_TYPE_DEFINITION ::=
2092 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2094 -- Normally the initial token on entry is RANGE, but in some
2095 -- error conditions, the range token was missing and control is
2096 -- passed with Token pointing to first token of the first expression.
2098 -- Error recovery: cannot raise Error_Resync
2100 function P_Signed_Integer_Type_Definition
return Node_Id
is
2101 Typedef_Node
: Node_Id
;
2102 Expr_Node
: Node_Id
;
2105 Typedef_Node
:= New_Node
(N_Signed_Integer_Type_Definition
, Token_Ptr
);
2107 if Token
= Tok_Range
then
2111 Expr_Node
:= P_Expression
;
2112 Check_Simple_Expression
(Expr_Node
);
2113 Set_Low_Bound
(Typedef_Node
, Expr_Node
);
2115 Expr_Node
:= P_Expression
;
2116 Check_Simple_Expression
(Expr_Node
);
2117 Set_High_Bound
(Typedef_Node
, Expr_Node
);
2118 return Typedef_Node
;
2119 end P_Signed_Integer_Type_Definition
;
2121 ------------------------------------
2122 -- 3.5.4 Modular Type Definition --
2123 ------------------------------------
2125 -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION
2127 -- The caller has checked that the initial token is MOD
2129 -- Error recovery: cannot raise Error_Resync
2131 function P_Modular_Type_Definition
return Node_Id
is
2132 Typedef_Node
: Node_Id
;
2135 if Ada_Version
= Ada_83
then
2136 Error_Msg_SC
("(Ada 83): modular types not allowed");
2139 Typedef_Node
:= New_Node
(N_Modular_Type_Definition
, Token_Ptr
);
2141 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
2143 -- Handle mod L..R cleanly
2145 if Token
= Tok_Dot_Dot
then
2146 Error_Msg_SC
("range not allowed for modular type");
2148 Set_Expression
(Typedef_Node
, P_Expression_No_Right_Paren
);
2151 return Typedef_Node
;
2152 end P_Modular_Type_Definition
;
2154 ---------------------------------
2155 -- 3.5.6 Real Type Definition --
2156 ---------------------------------
2158 -- Parsed by P_Type_Declaration (3.2.1)
2160 --------------------------------------
2161 -- 3.5.7 Floating Point Definition --
2162 --------------------------------------
2164 -- FLOATING_POINT_DEFINITION ::=
2165 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2167 -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION
2169 -- The caller has checked that the initial token is DIGITS
2171 -- Error recovery: cannot raise Error_Resync
2173 function P_Floating_Point_Definition
return Node_Id
is
2174 Digits_Loc
: constant Source_Ptr
:= Token_Ptr
;
2176 Expr_Node
: Node_Id
;
2179 Scan
; -- past DIGITS
2180 Expr_Node
:= P_Expression_No_Right_Paren
;
2181 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2183 -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order
2185 if Token
= Tok_Delta
then
2186 Error_Msg_SC
("DELTA must come before DIGITS");
2187 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Digits_Loc
);
2189 Set_Delta_Expression
(Def_Node
, P_Expression_No_Right_Paren
);
2191 -- OK floating-point definition
2194 Def_Node
:= New_Node
(N_Floating_Point_Definition
, Digits_Loc
);
2197 Set_Digits_Expression
(Def_Node
, Expr_Node
);
2198 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
2200 end P_Floating_Point_Definition
;
2202 -------------------------------------
2203 -- 3.5.7 Real Range Specification --
2204 -------------------------------------
2206 -- REAL_RANGE_SPECIFICATION ::=
2207 -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION
2209 -- Error recovery: cannot raise Error_Resync
2211 function P_Real_Range_Specification_Opt
return Node_Id
is
2212 Specification_Node
: Node_Id
;
2213 Expr_Node
: Node_Id
;
2216 if Token
= Tok_Range
then
2217 Specification_Node
:=
2218 New_Node
(N_Real_Range_Specification
, Token_Ptr
);
2220 Expr_Node
:= P_Expression_No_Right_Paren
;
2221 Check_Simple_Expression
(Expr_Node
);
2222 Set_Low_Bound
(Specification_Node
, Expr_Node
);
2224 Expr_Node
:= P_Expression_No_Right_Paren
;
2225 Check_Simple_Expression
(Expr_Node
);
2226 Set_High_Bound
(Specification_Node
, Expr_Node
);
2227 return Specification_Node
;
2231 end P_Real_Range_Specification_Opt
;
2233 -----------------------------------
2234 -- 3.5.9 Fixed Point Definition --
2235 -----------------------------------
2237 -- FIXED_POINT_DEFINITION ::=
2238 -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION
2240 -- ORDINARY_FIXED_POINT_DEFINITION ::=
2241 -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION
2243 -- DECIMAL_FIXED_POINT_DEFINITION ::=
2244 -- delta static_EXPRESSION
2245 -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION]
2247 -- The caller has checked that the initial token is DELTA
2249 -- Error recovery: cannot raise Error_Resync
2251 function P_Fixed_Point_Definition
return Node_Id
is
2252 Delta_Node
: Node_Id
;
2253 Delta_Loc
: Source_Ptr
;
2255 Expr_Node
: Node_Id
;
2258 Delta_Loc
:= Token_Ptr
;
2260 Delta_Node
:= P_Expression_No_Right_Paren
;
2261 Check_Simple_Expression_In_Ada_83
(Delta_Node
);
2263 if Token
= Tok_Digits
then
2264 if Ada_Version
= Ada_83
then
2265 Error_Msg_SC
("(Ada 83) decimal fixed type not allowed!");
2268 Def_Node
:= New_Node
(N_Decimal_Fixed_Point_Definition
, Delta_Loc
);
2269 Scan
; -- past DIGITS
2270 Expr_Node
:= P_Expression_No_Right_Paren
;
2271 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2272 Set_Digits_Expression
(Def_Node
, Expr_Node
);
2275 Def_Node
:= New_Node
(N_Ordinary_Fixed_Point_Definition
, Delta_Loc
);
2277 -- Range is required in ordinary fixed point case
2279 if Token
/= Tok_Range
then
2280 Error_Msg_AP
("range must be given for fixed-point type");
2285 Set_Delta_Expression
(Def_Node
, Delta_Node
);
2286 Set_Real_Range_Specification
(Def_Node
, P_Real_Range_Specification_Opt
);
2288 end P_Fixed_Point_Definition
;
2290 --------------------------------------------
2291 -- 3.5.9 Ordinary Fixed Point Definition --
2292 --------------------------------------------
2294 -- Parsed by P_Fixed_Point_Definition (3.5.9)
2296 -------------------------------------------
2297 -- 3.5.9 Decimal Fixed Point Definition --
2298 -------------------------------------------
2300 -- Parsed by P_Decimal_Point_Definition (3.5.9)
2302 ------------------------------
2303 -- 3.5.9 Digits Constraint --
2304 ------------------------------
2306 -- DIGITS_CONSTRAINT ::=
2307 -- digits static_EXPRESSION [RANGE_CONSTRAINT]
2309 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2311 -- The caller has checked that the initial token is DIGITS
2313 function P_Digits_Constraint
return Node_Id
is
2314 Constraint_Node
: Node_Id
;
2315 Expr_Node
: Node_Id
;
2318 Constraint_Node
:= New_Node
(N_Digits_Constraint
, Token_Ptr
);
2319 Scan
; -- past DIGITS
2320 Expr_Node
:= P_Expression_No_Right_Paren
;
2321 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2322 Set_Digits_Expression
(Constraint_Node
, Expr_Node
);
2324 if Token
= Tok_Range
then
2325 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
2328 return Constraint_Node
;
2329 end P_Digits_Constraint
;
2331 -----------------------------
2332 -- 3.5.9 Delta Constraint --
2333 -----------------------------
2335 -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT]
2337 -- Note: this is an obsolescent feature in Ada 95 (I.3)
2339 -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION
2341 -- The caller has checked that the initial token is DELTA
2343 -- Error recovery: cannot raise Error_Resync
2345 function P_Delta_Constraint
return Node_Id
is
2346 Constraint_Node
: Node_Id
;
2347 Expr_Node
: Node_Id
;
2350 Constraint_Node
:= New_Node
(N_Delta_Constraint
, Token_Ptr
);
2352 Expr_Node
:= P_Expression_No_Right_Paren
;
2353 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
2354 Set_Delta_Expression
(Constraint_Node
, Expr_Node
);
2356 if Token
= Tok_Range
then
2357 Set_Range_Constraint
(Constraint_Node
, P_Range_Constraint
);
2360 return Constraint_Node
;
2361 end P_Delta_Constraint
;
2363 --------------------------------
2364 -- 3.6 Array Type Definition --
2365 --------------------------------
2367 -- ARRAY_TYPE_DEFINITION ::=
2368 -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION
2370 -- UNCONSTRAINED_ARRAY_DEFINITION ::=
2371 -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of
2372 -- COMPONENT_DEFINITION
2374 -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <>
2376 -- CONSTRAINED_ARRAY_DEFINITION ::=
2377 -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of
2378 -- COMPONENT_DEFINITION
2380 -- DISCRETE_SUBTYPE_DEFINITION ::=
2381 -- DISCRETE_SUBTYPE_INDICATION | RANGE
2383 -- COMPONENT_DEFINITION ::=
2384 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
2386 -- The caller has checked that the initial token is ARRAY
2388 -- Error recovery: can raise Error_Resync
2390 function P_Array_Type_Definition
return Node_Id
is
2391 Array_Loc
: Source_Ptr
;
2392 CompDef_Node
: Node_Id
;
2394 Not_Null_Present
: Boolean := False;
2395 Subs_List
: List_Id
;
2396 Scan_State
: Saved_Scan_State
;
2397 Aliased_Present
: Boolean := False;
2400 Array_Loc
:= Token_Ptr
;
2402 Subs_List
:= New_List
;
2405 -- It's quite tricky to disentangle these two possibilities, so we do
2406 -- a prescan to determine which case we have and then reset the scan.
2407 -- The prescan skips past possible subtype mark tokens.
2409 Save_Scan_State
(Scan_State
); -- just after paren
2411 while Token
in Token_Class_Desig
or else
2412 Token
= Tok_Dot
or else
2413 Token
= Tok_Apostrophe
-- because of 'BASE, 'CLASS
2418 -- If we end up on RANGE <> then we have the unconstrained case. We
2419 -- will also allow the RANGE to be omitted, just to improve error
2420 -- handling for a case like array (integer <>) of integer;
2422 Scan
; -- past possible RANGE or <>
2424 if (Prev_Token
= Tok_Range
and then Token
= Tok_Box
) or else
2425 Prev_Token
= Tok_Box
2427 Def_Node
:= New_Node
(N_Unconstrained_Array_Definition
, Array_Loc
);
2428 Restore_Scan_State
(Scan_State
); -- to first subtype mark
2431 Append
(P_Subtype_Mark_Resync
, Subs_List
);
2434 exit when Token
= Tok_Right_Paren
or else Token
= Tok_Of
;
2438 Set_Subtype_Marks
(Def_Node
, Subs_List
);
2441 Def_Node
:= New_Node
(N_Constrained_Array_Definition
, Array_Loc
);
2442 Restore_Scan_State
(Scan_State
); -- to first discrete range
2445 Append
(P_Discrete_Subtype_Definition
, Subs_List
);
2446 exit when not Comma_Present
;
2449 Set_Discrete_Subtype_Definitions
(Def_Node
, Subs_List
);
2455 CompDef_Node
:= New_Node
(N_Component_Definition
, Token_Ptr
);
2457 if Token_Name
= Name_Aliased
then
2458 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
2461 if Token
= Tok_Aliased
then
2462 Aliased_Present
:= True;
2463 Scan
; -- past ALIASED
2466 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/AI-254)
2468 -- Ada 2005 (AI-230): Access Definition case
2470 if Token
= Tok_Access
then
2471 if Ada_Version
< Ada_05
then
2473 ("generalized use of anonymous access types " &
2474 "is an Ada 2005 extension");
2475 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
2478 if Aliased_Present
then
2479 Error_Msg_SP
("ALIASED not allowed here");
2482 Set_Subtype_Indication
(CompDef_Node
, Empty
);
2483 Set_Aliased_Present
(CompDef_Node
, False);
2484 Set_Access_Definition
(CompDef_Node
,
2485 P_Access_Definition
(Not_Null_Present
));
2488 Set_Access_Definition
(CompDef_Node
, Empty
);
2489 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
2490 Set_Null_Exclusion_Present
(CompDef_Node
, Not_Null_Present
);
2491 Set_Subtype_Indication
(CompDef_Node
,
2492 P_Subtype_Indication
(Not_Null_Present
));
2495 Set_Component_Definition
(Def_Node
, CompDef_Node
);
2498 end P_Array_Type_Definition
;
2500 -----------------------------------------
2501 -- 3.6 Unconstrained Array Definition --
2502 -----------------------------------------
2504 -- Parsed by P_Array_Type_Definition (3.6)
2506 ---------------------------------------
2507 -- 3.6 Constrained Array Definition --
2508 ---------------------------------------
2510 -- Parsed by P_Array_Type_Definition (3.6)
2512 --------------------------------------
2513 -- 3.6 Discrete Subtype Definition --
2514 --------------------------------------
2516 -- DISCRETE_SUBTYPE_DEFINITION ::=
2517 -- discrete_SUBTYPE_INDICATION | RANGE
2519 -- Note: the discrete subtype definition appearing in a constrained
2520 -- array definition is parsed by P_Array_Type_Definition (3.6)
2522 -- Error recovery: cannot raise Error_Resync
2524 function P_Discrete_Subtype_Definition
return Node_Id
is
2526 -- The syntax of a discrete subtype definition is identical to that
2527 -- of a discrete range, so we simply share the same parsing code.
2529 return P_Discrete_Range
;
2530 end P_Discrete_Subtype_Definition
;
2532 -------------------------------
2533 -- 3.6 Component Definition --
2534 -------------------------------
2536 -- For the array case, parsed by P_Array_Type_Definition (3.6)
2537 -- For the record case, parsed by P_Component_Declaration (3.8)
2539 -----------------------------
2540 -- 3.6.1 Index Constraint --
2541 -----------------------------
2543 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2545 ---------------------------
2546 -- 3.6.1 Discrete Range --
2547 ---------------------------
2549 -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE
2551 -- The possible forms for a discrete range are:
2553 -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2)
2554 -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2)
2555 -- Range_Attribute (RANGE, 3.5)
2556 -- Simple_Expression .. Simple_Expression (RANGE, 3.5)
2558 -- Error recovery: cannot raise Error_Resync
2560 function P_Discrete_Range
return Node_Id
is
2561 Expr_Node
: Node_Id
;
2562 Range_Node
: Node_Id
;
2565 Expr_Node
:= P_Simple_Expression_Or_Range_Attribute
;
2567 if Expr_Form
= EF_Range_Attr
then
2570 elsif Token
= Tok_Range
then
2571 if Expr_Form
/= EF_Simple_Name
then
2572 Error_Msg_SC
("range must be preceded by subtype mark");
2575 return P_Subtype_Indication
(Expr_Node
);
2577 -- Check Expression .. Expression case
2579 elsif Token
= Tok_Dot_Dot
then
2580 Range_Node
:= New_Node
(N_Range
, Token_Ptr
);
2581 Set_Low_Bound
(Range_Node
, Expr_Node
);
2583 Expr_Node
:= P_Expression
;
2584 Check_Simple_Expression
(Expr_Node
);
2585 Set_High_Bound
(Range_Node
, Expr_Node
);
2588 -- Otherwise we must have a subtype mark
2590 elsif Expr_Form
= EF_Simple_Name
then
2593 -- If incorrect, complain that we expect ..
2599 end P_Discrete_Range
;
2601 ----------------------------
2602 -- 3.7 Discriminant Part --
2603 ----------------------------
2605 -- DISCRIMINANT_PART ::=
2606 -- UNKNOWN_DISCRIMINANT_PART
2607 -- | KNOWN_DISCRIMINANT_PART
2609 -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7)
2610 -- or P_Unknown_Discriminant_Part (3.7), since we know which we want.
2612 ------------------------------------
2613 -- 3.7 Unknown Discriminant Part --
2614 ------------------------------------
2616 -- UNKNOWN_DISCRIMINANT_PART ::= (<>)
2618 -- If no unknown discriminant part is present, then False is returned,
2619 -- otherwise the unknown discriminant is scanned out and True is returned.
2621 -- Error recovery: cannot raise Error_Resync
2623 function P_Unknown_Discriminant_Part_Opt
return Boolean is
2624 Scan_State
: Saved_Scan_State
;
2627 if Token
/= Tok_Left_Paren
then
2631 Save_Scan_State
(Scan_State
);
2632 Scan
; -- past the left paren
2634 if Token
= Tok_Box
then
2635 if Ada_Version
= Ada_83
then
2636 Error_Msg_SC
("(Ada 83) unknown discriminant not allowed!");
2639 Scan
; -- past the box
2640 T_Right_Paren
; -- must be followed by right paren
2644 Restore_Scan_State
(Scan_State
);
2648 end P_Unknown_Discriminant_Part_Opt
;
2650 ----------------------------------
2651 -- 3.7 Known Discriminant Part --
2652 ----------------------------------
2654 -- KNOWN_DISCRIMINANT_PART ::=
2655 -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION})
2657 -- DISCRIMINANT_SPECIFICATION ::=
2658 -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] SUBTYPE_MARK
2659 -- [:= DEFAULT_EXPRESSION]
2660 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
2661 -- [:= DEFAULT_EXPRESSION]
2663 -- If no known discriminant part is present, then No_List is returned
2665 -- Error recovery: cannot raise Error_Resync
2667 function P_Known_Discriminant_Part_Opt
return List_Id
is
2668 Specification_Node
: Node_Id
;
2669 Specification_List
: List_Id
;
2670 Ident_Sloc
: Source_Ptr
;
2671 Scan_State
: Saved_Scan_State
;
2673 Not_Null_Present
: Boolean;
2676 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
2677 -- This array holds the list of defining identifiers. The upper bound
2678 -- of 4096 is intended to be essentially infinite, and we do not even
2679 -- bother to check for it being exceeded.
2682 if Token
= Tok_Left_Paren
then
2683 Specification_List
:= New_List
;
2685 P_Pragmas_Misplaced
;
2687 Specification_Loop
: loop
2689 Ident_Sloc
:= Token_Ptr
;
2690 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
2693 while Comma_Present
loop
2694 Num_Idents
:= Num_Idents
+ 1;
2695 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
2700 -- If there are multiple identifiers, we repeatedly scan the
2701 -- type and initialization expression information by resetting
2702 -- the scan pointer (so that we get completely separate trees
2703 -- for each occurrence).
2705 if Num_Idents
> 1 then
2706 Save_Scan_State
(Scan_State
);
2709 -- Loop through defining identifiers in list
2713 Specification_Node
:=
2714 New_Node
(N_Discriminant_Specification
, Ident_Sloc
);
2715 Set_Defining_Identifier
(Specification_Node
, Idents
(Ident
));
2716 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
2718 if Token
= Tok_Access
then
2719 if Ada_Version
= Ada_83
then
2721 ("(Ada 83) access discriminant not allowed!");
2724 Set_Discriminant_Type
2725 (Specification_Node
,
2726 P_Access_Definition
(Not_Null_Present
));
2729 Set_Discriminant_Type
2730 (Specification_Node
, P_Subtype_Mark
);
2732 Set_Null_Exclusion_Present
-- Ada 2005 (AI-231)
2733 (Specification_Node
, Not_Null_Present
);
2737 (Specification_Node
, Init_Expr_Opt
(True));
2740 Set_Prev_Ids
(Specification_Node
, True);
2743 if Ident
< Num_Idents
then
2744 Set_More_Ids
(Specification_Node
, True);
2747 Append
(Specification_Node
, Specification_List
);
2748 exit Ident_Loop
when Ident
= Num_Idents
;
2750 Restore_Scan_State
(Scan_State
);
2751 end loop Ident_Loop
;
2753 exit Specification_Loop
when Token
/= Tok_Semicolon
;
2755 P_Pragmas_Misplaced
;
2756 end loop Specification_Loop
;
2759 return Specification_List
;
2764 end P_Known_Discriminant_Part_Opt
;
2766 -------------------------------------
2767 -- 3.7 DIscriminant Specification --
2768 -------------------------------------
2770 -- Parsed by P_Known_Discriminant_Part_Opt (3.7)
2772 -----------------------------
2773 -- 3.7 Default Expression --
2774 -----------------------------
2776 -- Always parsed (simply as an Expression) by the parent construct
2778 ------------------------------------
2779 -- 3.7.1 Discriminant Constraint --
2780 ------------------------------------
2782 -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1)
2784 --------------------------------------------------------
2785 -- 3.7.1 Index or Discriminant Constraint (also 3.6) --
2786 --------------------------------------------------------
2788 -- DISCRIMINANT_CONSTRAINT ::=
2789 -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION})
2791 -- DISCRIMINANT_ASSOCIATION ::=
2792 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2795 -- This routine parses either an index or a discriminant constraint. As
2796 -- is clear from the above grammar, it is often possible to clearly
2797 -- determine which of the two possibilities we have, but there are
2798 -- cases (those in which we have a series of expressions of the same
2799 -- syntactic form as subtype indications), where we cannot tell. Since
2800 -- this means that in any case the semantic phase has to distinguish
2801 -- between the two, there is not much point in the parser trying to
2802 -- distinguish even those cases where the difference is clear. In any
2803 -- case, if we have a situation like:
2805 -- (A => 123, 235 .. 500)
2807 -- it is not clear which of the two items is the wrong one, better to
2808 -- let the semantic phase give a clear message. Consequently, this
2809 -- routine in general returns a list of items which can be either
2810 -- discrete ranges or discriminant associations.
2812 -- The caller has checked that the initial token is a left paren
2814 -- Error recovery: can raise Error_Resync
2816 function P_Index_Or_Discriminant_Constraint
return Node_Id
is
2817 Scan_State
: Saved_Scan_State
;
2818 Constr_Node
: Node_Id
;
2819 Constr_List
: List_Id
;
2820 Expr_Node
: Node_Id
;
2821 Result_Node
: Node_Id
;
2824 Result_Node
:= New_Node
(N_Index_Or_Discriminant_Constraint
, Token_Ptr
);
2826 Constr_List
:= New_List
;
2827 Set_Constraints
(Result_Node
, Constr_List
);
2829 -- The two syntactic forms are a little mixed up, so what we are doing
2830 -- here is looking at the first entry to determine which case we have
2832 -- A discriminant constraint is a list of discriminant associations,
2833 -- which have one of the following possible forms:
2837 -- Id | Id | .. | Id => Expression
2839 -- An index constraint is a list of discrete ranges which have one
2840 -- of the following possible forms:
2843 -- Subtype_Mark range Range
2845 -- Simple_Expression .. Simple_Expression
2847 -- Loop through discriminants in list
2850 -- Check cases of Id => Expression or Id | Id => Expression
2852 if Token
= Tok_Identifier
then
2853 Save_Scan_State
(Scan_State
); -- at Id
2856 if Token
= Tok_Arrow
or else Token
= Tok_Vertical_Bar
then
2857 Restore_Scan_State
(Scan_State
); -- to Id
2858 Append
(P_Discriminant_Association
, Constr_List
);
2861 Restore_Scan_State
(Scan_State
); -- to Id
2865 -- Otherwise scan out an expression and see what we have got
2867 Expr_Node
:= P_Expression_Or_Range_Attribute
;
2869 if Expr_Form
= EF_Range_Attr
then
2870 Append
(Expr_Node
, Constr_List
);
2872 elsif Token
= Tok_Range
then
2873 if Expr_Form
/= EF_Simple_Name
then
2874 Error_Msg_SC
("subtype mark required before RANGE");
2877 Append
(P_Subtype_Indication
(Expr_Node
), Constr_List
);
2880 -- Check Simple_Expression .. Simple_Expression case
2882 elsif Token
= Tok_Dot_Dot
then
2883 Check_Simple_Expression
(Expr_Node
);
2884 Constr_Node
:= New_Node
(N_Range
, Token_Ptr
);
2885 Set_Low_Bound
(Constr_Node
, Expr_Node
);
2887 Expr_Node
:= P_Expression
;
2888 Check_Simple_Expression
(Expr_Node
);
2889 Set_High_Bound
(Constr_Node
, Expr_Node
);
2890 Append
(Constr_Node
, Constr_List
);
2893 -- Case of an expression which could be either form
2896 Append
(Expr_Node
, Constr_List
);
2900 -- Here with a single entry scanned
2903 exit when not Comma_Present
;
2909 end P_Index_Or_Discriminant_Constraint
;
2911 -------------------------------------
2912 -- 3.7.1 Discriminant Association --
2913 -------------------------------------
2915 -- DISCRIMINANT_ASSOCIATION ::=
2916 -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>]
2919 -- This routine is used only when the name list is present and the caller
2920 -- has already checked this (by scanning ahead and repositioning the
2923 -- Error_Recovery: cannot raise Error_Resync;
2925 function P_Discriminant_Association
return Node_Id
is
2926 Discr_Node
: Node_Id
;
2927 Names_List
: List_Id
;
2928 Ident_Sloc
: Source_Ptr
;
2931 Ident_Sloc
:= Token_Ptr
;
2932 Names_List
:= New_List
;
2935 Append
(P_Identifier
(C_Vertical_Bar_Arrow
), Names_List
);
2936 exit when Token
/= Tok_Vertical_Bar
;
2940 Discr_Node
:= New_Node
(N_Discriminant_Association
, Ident_Sloc
);
2941 Set_Selector_Names
(Discr_Node
, Names_List
);
2943 Set_Expression
(Discr_Node
, P_Expression
);
2945 end P_Discriminant_Association
;
2947 ---------------------------------
2948 -- 3.8 Record Type Definition --
2949 ---------------------------------
2951 -- RECORD_TYPE_DEFINITION ::=
2952 -- [[abstract] tagged] [limited] RECORD_DEFINITION
2954 -- There is no node in the tree for a record type definition. Instead
2955 -- a record definition node appears, with possible Abstract_Present,
2956 -- Tagged_Present, and Limited_Present flags set appropriately.
2958 ----------------------------
2959 -- 3.8 Record Definition --
2960 ----------------------------
2962 -- RECORD_DEFINITION ::=
2968 -- Note: in the case where a record definition node is used to represent
2969 -- a record type definition, the caller sets the Tagged_Present and
2970 -- Limited_Present flags in the resulting N_Record_Definition node as
2973 -- Note that the RECORD token at the start may be missing in certain
2974 -- error situations, so this function is expected to post the error
2976 -- Error recovery: can raise Error_Resync
2978 function P_Record_Definition
return Node_Id
is
2982 Rec_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
2986 if Token
= Tok_Null
then
2989 Set_Null_Present
(Rec_Node
, True);
2991 -- Case starting with RECORD keyword. Build scope stack entry. For the
2992 -- column, we use the first non-blank character on the line, to deal
2993 -- with situations such as:
2999 -- which is not official RM indentation, but is not uncommon usage
3003 Scope
.Table
(Scope
.Last
).Etyp
:= E_Record
;
3004 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
3005 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
3006 Scope
.Table
(Scope
.Last
).Labl
:= Error
;
3007 Scope
.Table
(Scope
.Last
).Junk
:= (Token
/= Tok_Record
);
3011 Set_Component_List
(Rec_Node
, P_Component_List
);
3014 exit when Check_End
;
3015 Discard_Junk_Node
(P_Component_List
);
3020 end P_Record_Definition
;
3022 -------------------------
3023 -- 3.8 Component List --
3024 -------------------------
3026 -- COMPONENT_LIST ::=
3027 -- COMPONENT_ITEM {COMPONENT_ITEM}
3028 -- | {COMPONENT_ITEM} VARIANT_PART
3031 -- Error recovery: cannot raise Error_Resync
3033 function P_Component_List
return Node_Id
is
3034 Component_List_Node
: Node_Id
;
3035 Decls_List
: List_Id
;
3036 Scan_State
: Saved_Scan_State
;
3039 Component_List_Node
:= New_Node
(N_Component_List
, Token_Ptr
);
3040 Decls_List
:= New_List
;
3042 if Token
= Tok_Null
then
3045 P_Pragmas_Opt
(Decls_List
);
3046 Set_Null_Present
(Component_List_Node
, True);
3047 return Component_List_Node
;
3050 P_Pragmas_Opt
(Decls_List
);
3052 if Token
/= Tok_Case
then
3053 Component_Scan_Loop
: loop
3054 P_Component_Items
(Decls_List
);
3055 P_Pragmas_Opt
(Decls_List
);
3057 exit Component_Scan_Loop
when Token
= Tok_End
3058 or else Token
= Tok_Case
3059 or else Token
= Tok_When
;
3061 -- We are done if we do not have an identifier. However, if
3062 -- we have a misspelled reserved identifier that is in a column
3063 -- to the right of the record definition, we will treat it as
3064 -- an identifier. It turns out to be too dangerous in practice
3065 -- to accept such a mis-spelled identifier which does not have
3066 -- this additional clue that confirms the incorrect spelling.
3068 if Token
/= Tok_Identifier
then
3069 if Start_Column
> Scope
.Table
(Scope
.Last
).Ecol
3070 and then Is_Reserved_Identifier
3072 Save_Scan_State
(Scan_State
); -- at reserved id
3073 Scan
; -- possible reserved id
3075 if Token
= Tok_Comma
or else Token
= Tok_Colon
then
3076 Restore_Scan_State
(Scan_State
);
3077 Scan_Reserved_Identifier
(Force_Msg
=> True);
3079 -- Note reserved identifier used as field name after
3080 -- all because not followed by colon or comma
3083 Restore_Scan_State
(Scan_State
);
3084 exit Component_Scan_Loop
;
3087 -- Non-identifier that definitely was not reserved id
3090 exit Component_Scan_Loop
;
3093 end loop Component_Scan_Loop
;
3096 if Token
= Tok_Case
then
3097 Set_Variant_Part
(Component_List_Node
, P_Variant_Part
);
3099 -- Check for junk after variant part
3101 if Token
= Tok_Identifier
then
3102 Save_Scan_State
(Scan_State
);
3103 Scan
; -- past identifier
3105 if Token
= Tok_Colon
then
3106 Restore_Scan_State
(Scan_State
);
3107 Error_Msg_SC
("component may not follow variant part");
3108 Discard_Junk_Node
(P_Component_List
);
3110 elsif Token
= Tok_Case
then
3111 Restore_Scan_State
(Scan_State
);
3112 Error_Msg_SC
("only one variant part allowed in a record");
3113 Discard_Junk_Node
(P_Component_List
);
3116 Restore_Scan_State
(Scan_State
);
3122 Set_Component_Items
(Component_List_Node
, Decls_List
);
3123 return Component_List_Node
;
3124 end P_Component_List
;
3126 -------------------------
3127 -- 3.8 Component Item --
3128 -------------------------
3130 -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE
3132 -- COMPONENT_DECLARATION ::=
3133 -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION
3134 -- [:= DEFAULT_EXPRESSION];
3136 -- COMPONENT_DEFINITION ::=
3137 -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION
3139 -- Error recovery: cannot raise Error_Resync, if an error occurs,
3140 -- the scan is positioned past the following semicolon.
3142 -- Note: we do not yet allow representation clauses to appear as component
3143 -- items, do we need to add this capability sometime in the future ???
3145 procedure P_Component_Items
(Decls
: List_Id
) is
3146 Aliased_Present
: Boolean := False;
3147 CompDef_Node
: Node_Id
;
3148 Decl_Node
: Node_Id
;
3149 Scan_State
: Saved_Scan_State
;
3150 Not_Null_Present
: Boolean := False;
3153 Ident_Sloc
: Source_Ptr
;
3155 Idents
: array (Int
range 1 .. 4096) of Entity_Id
;
3156 -- This array holds the list of defining identifiers. The upper bound
3157 -- of 4096 is intended to be essentially infinite, and we do not even
3158 -- bother to check for it being exceeded.
3161 if Token
/= Tok_Identifier
then
3162 Error_Msg_SC
("component declaration expected");
3163 Resync_Past_Semicolon
;
3167 Ident_Sloc
:= Token_Ptr
;
3168 Idents
(1) := P_Defining_Identifier
(C_Comma_Colon
);
3171 while Comma_Present
loop
3172 Num_Idents
:= Num_Idents
+ 1;
3173 Idents
(Num_Idents
) := P_Defining_Identifier
(C_Comma_Colon
);
3178 -- If there are multiple identifiers, we repeatedly scan the
3179 -- type and initialization expression information by resetting
3180 -- the scan pointer (so that we get completely separate trees
3181 -- for each occurrence).
3183 if Num_Idents
> 1 then
3184 Save_Scan_State
(Scan_State
);
3187 -- Loop through defining identifiers in list
3192 -- The following block is present to catch Error_Resync
3193 -- which causes the parse to be reset past the semicolon
3196 Decl_Node
:= New_Node
(N_Component_Declaration
, Ident_Sloc
);
3197 Set_Defining_Identifier
(Decl_Node
, Idents
(Ident
));
3199 if Token
= Tok_Constant
then
3200 Error_Msg_SC
("constant components are not permitted");
3204 CompDef_Node
:= New_Node
(N_Component_Definition
, Token_Ptr
);
3206 if Token_Name
= Name_Aliased
then
3207 Check_95_Keyword
(Tok_Aliased
, Tok_Identifier
);
3210 if Token
= Tok_Aliased
then
3211 Aliased_Present
:= True;
3212 Scan
; -- past ALIASED
3215 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231/AI-254)
3217 -- Ada 2005 (AI-230): Access Definition case
3219 if Token
= Tok_Access
then
3220 if Ada_Version
< Ada_05
then
3222 ("generalized use of anonymous access types " &
3223 "is an Ada 2005 extension");
3224 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
3227 if Aliased_Present
then
3228 Error_Msg_SP
("ALIASED not allowed here");
3231 Set_Subtype_Indication
(CompDef_Node
, Empty
);
3232 Set_Aliased_Present
(CompDef_Node
, False);
3233 Set_Access_Definition
(CompDef_Node
,
3234 P_Access_Definition
(Not_Null_Present
));
3237 Set_Access_Definition
(CompDef_Node
, Empty
);
3238 Set_Aliased_Present
(CompDef_Node
, Aliased_Present
);
3239 Set_Null_Exclusion_Present
(CompDef_Node
, Not_Null_Present
);
3241 if Token
= Tok_Array
then
3243 ("anonymous arrays not allowed as components");
3247 Set_Subtype_Indication
(CompDef_Node
,
3248 P_Subtype_Indication
(Not_Null_Present
));
3251 Set_Component_Definition
(Decl_Node
, CompDef_Node
);
3252 Set_Expression
(Decl_Node
, Init_Expr_Opt
);
3255 Set_Prev_Ids
(Decl_Node
, True);
3258 if Ident
< Num_Idents
then
3259 Set_More_Ids
(Decl_Node
, True);
3262 Append
(Decl_Node
, Decls
);
3265 when Error_Resync
=>
3266 if Token
/= Tok_End
then
3267 Resync_Past_Semicolon
;
3271 exit Ident_Loop
when Ident
= Num_Idents
;
3273 Restore_Scan_State
(Scan_State
);
3275 end loop Ident_Loop
;
3278 end P_Component_Items
;
3280 --------------------------------
3281 -- 3.8 Component Declaration --
3282 --------------------------------
3284 -- Parsed by P_Component_Items (3.8)
3286 -------------------------
3287 -- 3.8.1 Variant Part --
3288 -------------------------
3291 -- case discriminant_DIRECT_NAME is
3296 -- The caller has checked that the initial token is CASE
3298 -- Error recovery: cannot raise Error_Resync
3300 function P_Variant_Part
return Node_Id
is
3301 Variant_Part_Node
: Node_Id
;
3302 Variants_List
: List_Id
;
3303 Case_Node
: Node_Id
;
3306 Variant_Part_Node
:= New_Node
(N_Variant_Part
, Token_Ptr
);
3308 Scope
.Table
(Scope
.Last
).Etyp
:= E_Case
;
3309 Scope
.Table
(Scope
.Last
).Sloc
:= Token_Ptr
;
3310 Scope
.Table
(Scope
.Last
).Ecol
:= Start_Column
;
3313 Case_Node
:= P_Expression
;
3314 Set_Name
(Variant_Part_Node
, Case_Node
);
3316 if Nkind
(Case_Node
) /= N_Identifier
then
3317 Set_Name
(Variant_Part_Node
, Error
);
3318 Error_Msg
("discriminant name expected", Sloc
(Case_Node
));
3322 Variants_List
:= New_List
;
3323 P_Pragmas_Opt
(Variants_List
);
3325 -- Test missing variant
3327 if Token
= Tok_End
then
3328 Error_Msg_BC
("WHEN expected (must have at least one variant)");
3330 Append
(P_Variant
, Variants_List
);
3333 -- Loop through variants, note that we allow if in place of when,
3334 -- this error will be detected and handled in P_Variant.
3337 P_Pragmas_Opt
(Variants_List
);
3339 if Token
/= Tok_When
3340 and then Token
/= Tok_If
3341 and then Token
/= Tok_Others
3343 exit when Check_End
;
3346 Append
(P_Variant
, Variants_List
);
3349 Set_Variants
(Variant_Part_Node
, Variants_List
);
3350 return Variant_Part_Node
;
3353 --------------------
3355 --------------------
3358 -- when DISCRETE_CHOICE_LIST =>
3361 -- Error recovery: cannot raise Error_Resync
3363 -- The initial token on entry is either WHEN, IF or OTHERS
3365 function P_Variant
return Node_Id
is
3366 Variant_Node
: Node_Id
;
3369 -- Special check to recover nicely from use of IF in place of WHEN
3371 if Token
= Tok_If
then
3378 Variant_Node
:= New_Node
(N_Variant
, Prev_Token_Ptr
);
3379 Set_Discrete_Choices
(Variant_Node
, P_Discrete_Choice_List
);
3381 Set_Component_List
(Variant_Node
, P_Component_List
);
3382 return Variant_Node
;
3385 ---------------------------------
3386 -- 3.8.1 Discrete Choice List --
3387 ---------------------------------
3389 -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE}
3391 -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others
3393 -- Note: in Ada 83, the expression must be a simple expression
3395 -- Error recovery: cannot raise Error_Resync
3397 function P_Discrete_Choice_List
return List_Id
is
3399 Expr_Node
: Node_Id
;
3400 Choice_Node
: Node_Id
;
3403 Choices
:= New_List
;
3406 if Token
= Tok_Others
then
3407 Append
(New_Node
(N_Others_Choice
, Token_Ptr
), Choices
);
3408 Scan
; -- past OTHERS
3412 Expr_Node
:= No_Right_Paren
(P_Expression_Or_Range_Attribute
);
3414 if Token
= Tok_Colon
3415 and then Nkind
(Expr_Node
) = N_Identifier
3417 Error_Msg_SP
("label not permitted in this context");
3420 elsif Expr_Form
= EF_Range_Attr
then
3421 Append
(Expr_Node
, Choices
);
3423 elsif Token
= Tok_Dot_Dot
then
3424 Check_Simple_Expression
(Expr_Node
);
3425 Choice_Node
:= New_Node
(N_Range
, Token_Ptr
);
3426 Set_Low_Bound
(Choice_Node
, Expr_Node
);
3428 Expr_Node
:= P_Expression_No_Right_Paren
;
3429 Check_Simple_Expression
(Expr_Node
);
3430 Set_High_Bound
(Choice_Node
, Expr_Node
);
3431 Append
(Choice_Node
, Choices
);
3433 elsif Expr_Form
= EF_Simple_Name
then
3434 if Token
= Tok_Range
then
3435 Append
(P_Subtype_Indication
(Expr_Node
), Choices
);
3437 elsif Token
in Token_Class_Consk
then
3439 ("the only constraint allowed here " &
3440 "is a range constraint");
3441 Discard_Junk_Node
(P_Constraint_Opt
);
3442 Append
(Expr_Node
, Choices
);
3445 Append
(Expr_Node
, Choices
);
3449 Check_Simple_Expression_In_Ada_83
(Expr_Node
);
3450 Append
(Expr_Node
, Choices
);
3454 when Error_Resync
=>
3460 if Token
= Tok_Comma
then
3461 Error_Msg_SC
(""","" should be ""'|""");
3463 exit when Token
/= Tok_Vertical_Bar
;
3466 Scan
; -- past | or comma
3470 end P_Discrete_Choice_List
;
3472 ----------------------------
3473 -- 3.8.1 Discrete Choice --
3474 ----------------------------
3476 -- Parsed by P_Discrete_Choice_List (3.8.1)
3478 ----------------------------------
3479 -- 3.9.1 Record Extension Part --
3480 ----------------------------------
3482 -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION
3484 -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4)
3486 --------------------------------------
3487 -- 3.9.4 Interface Type Definition --
3488 --------------------------------------
3490 -- INTERFACE_TYPE_DEFINITION ::=
3491 -- [limited | task | protected | synchronized] interface
3492 -- [AND interface_list]
3494 -- Error recovery: cannot raise Error_Resync
3496 function P_Interface_Type_Definition
3497 (Is_Synchronized
: Boolean) return Node_Id
3499 Typedef_Node
: Node_Id
;
3502 if Ada_Version
< Ada_05
then
3503 Error_Msg_SP
("abstract interface is an Ada 2005 extension");
3504 Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
3507 Scan
; -- past INTERFACE
3509 -- Ada 2005 (AI-345): In case of synchronized interfaces and
3510 -- interfaces with a null list of interfaces we build a
3511 -- record_definition node.
3514 or else Token
= Tok_Semicolon
3516 Typedef_Node
:= New_Node
(N_Record_Definition
, Token_Ptr
);
3518 Set_Abstract_Present
(Typedef_Node
);
3519 Set_Tagged_Present
(Typedef_Node
);
3520 Set_Null_Present
(Typedef_Node
);
3521 Set_Interface_Present
(Typedef_Node
);
3524 and then Token
= Tok_And
3527 Set_Interface_List
(Typedef_Node
, New_List
);
3530 Append
(P_Qualified_Simple_Name
,
3531 Interface_List
(Typedef_Node
));
3532 exit when Token
/= Tok_And
;
3537 -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have
3538 -- a list of interfaces we build a derived_type_definition node. This
3539 -- simplifies the semantic analysis (and hence further mainteinance)
3542 if Token
/= Tok_And
then
3543 Error_Msg_AP
("AND expected");
3548 Typedef_Node
:= New_Node
(N_Derived_Type_Definition
, Token_Ptr
);
3550 Set_Abstract_Present
(Typedef_Node
);
3551 Set_Interface_Present
(Typedef_Node
);
3552 Set_Subtype_Indication
(Typedef_Node
, P_Qualified_Simple_Name
);
3554 Set_Record_Extension_Part
(Typedef_Node
,
3555 New_Node
(N_Record_Definition
, Token_Ptr
));
3556 Set_Null_Present
(Record_Extension_Part
(Typedef_Node
));
3558 if Token
= Tok_And
then
3559 Set_Interface_List
(Typedef_Node
, New_List
);
3563 Append
(P_Qualified_Simple_Name
,
3564 Interface_List
(Typedef_Node
));
3565 exit when Token
/= Tok_And
;
3571 return Typedef_Node
;
3572 end P_Interface_Type_Definition
;
3574 ----------------------------------
3575 -- 3.10 Access Type Definition --
3576 ----------------------------------
3578 -- ACCESS_TYPE_DEFINITION ::=
3579 -- ACCESS_TO_OBJECT_DEFINITION
3580 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3582 -- ACCESS_TO_OBJECT_DEFINITION ::=
3583 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION
3585 -- GENERAL_ACCESS_MODIFIER ::= all | constant
3587 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3588 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3589 -- | [NULL_EXCLUSION] access [protected] function
3590 -- PARAMETER_AND_RESULT_PROFILE
3592 -- PARAMETER_PROFILE ::= [FORMAL_PART]
3594 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK
3596 -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already
3597 -- parsed the null_exclusion part and has also removed the ACCESS token;
3598 -- otherwise the caller has just checked that the initial token is ACCESS
3600 -- Error recovery: can raise Error_Resync
3602 function P_Access_Type_Definition
3603 (Header_Already_Parsed
: Boolean := False) return Node_Id
is
3604 Access_Loc
: constant Source_Ptr
:= Token_Ptr
;
3605 Prot_Flag
: Boolean;
3606 Not_Null_Present
: Boolean := False;
3607 Type_Def_Node
: Node_Id
;
3608 Result_Not_Null
: Boolean;
3609 Result_Node
: Node_Id
;
3611 procedure Check_Junk_Subprogram_Name
;
3612 -- Used in access to subprogram definition cases to check for an
3613 -- identifier or operator symbol that does not belong.
3615 procedure Check_Junk_Subprogram_Name
is
3616 Saved_State
: Saved_Scan_State
;
3619 if Token
= Tok_Identifier
or else Token
= Tok_Operator_Symbol
then
3620 Save_Scan_State
(Saved_State
);
3621 Scan
; -- past possible junk subprogram name
3623 if Token
= Tok_Left_Paren
or else Token
= Tok_Semicolon
then
3624 Error_Msg_SP
("unexpected subprogram name ignored");
3628 Restore_Scan_State
(Saved_State
);
3631 end Check_Junk_Subprogram_Name
;
3633 -- Start of processing for P_Access_Type_Definition
3636 if not Header_Already_Parsed
then
3637 Not_Null_Present
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
3638 Scan
; -- past ACCESS
3641 if Token_Name
= Name_Protected
then
3642 Check_95_Keyword
(Tok_Protected
, Tok_Procedure
);
3643 Check_95_Keyword
(Tok_Protected
, Tok_Function
);
3646 Prot_Flag
:= (Token
= Tok_Protected
);
3649 Scan
; -- past PROTECTED
3651 if Token
/= Tok_Procedure
and then Token
/= Tok_Function
then
3652 Error_Msg_SC
("FUNCTION or PROCEDURE expected");
3656 if Token
= Tok_Procedure
then
3657 if Ada_Version
= Ada_83
then
3658 Error_Msg_SC
("(Ada 83) access to procedure not allowed!");
3661 Type_Def_Node
:= New_Node
(N_Access_Procedure_Definition
, Access_Loc
);
3662 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3663 Scan
; -- past PROCEDURE
3664 Check_Junk_Subprogram_Name
;
3665 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
3666 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
3668 elsif Token
= Tok_Function
then
3669 if Ada_Version
= Ada_83
then
3670 Error_Msg_SC
("(Ada 83) access to function not allowed!");
3673 Type_Def_Node
:= New_Node
(N_Access_Function_Definition
, Access_Loc
);
3674 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3675 Scan
; -- past FUNCTION
3676 Check_Junk_Subprogram_Name
;
3677 Set_Parameter_Specifications
(Type_Def_Node
, P_Parameter_Profile
);
3678 Set_Protected_Present
(Type_Def_Node
, Prot_Flag
);
3681 Result_Not_Null
:= P_Null_Exclusion
; -- Ada 2005 (AI-231)
3683 -- Ada 2005 (AI-318-02)
3685 if Token
= Tok_Access
then
3686 if Ada_Version
< Ada_05
then
3688 ("anonymous access result type is an Ada 2005 extension");
3689 Error_Msg_SC
("\unit must be compiled with -gnat05 switch");
3692 Result_Node
:= P_Access_Definition
(Result_Not_Null
);
3695 Result_Node
:= P_Subtype_Mark
;
3699 -- Note: A null exclusion given on the result type needs to
3700 -- be coded by a distinct flag, since Null_Exclusion_Present
3701 -- on an access-to-function type pertains to a null exclusion
3702 -- on the access type itself (as set above). ???
3703 -- Set_Null_Exclusion_Present??? (Type_Def_Node, Result_Not_Null);
3705 Set_Result_Definition
(Type_Def_Node
, Result_Node
);
3709 New_Node
(N_Access_To_Object_Definition
, Access_Loc
);
3710 Set_Null_Exclusion_Present
(Type_Def_Node
, Not_Null_Present
);
3712 if Token
= Tok_All
or else Token
= Tok_Constant
then
3713 if Ada_Version
= Ada_83
then
3714 Error_Msg_SC
("(Ada 83) access modifier not allowed!");
3717 if Token
= Tok_All
then
3718 Set_All_Present
(Type_Def_Node
, True);
3721 Set_Constant_Present
(Type_Def_Node
, True);
3724 Scan
; -- past ALL or CONSTANT
3727 Set_Subtype_Indication
(Type_Def_Node
,
3728 P_Subtype_Indication
(Not_Null_Present
));
3731 return Type_Def_Node
;
3732 end P_Access_Type_Definition
;
3734 ---------------------------------------
3735 -- 3.10 Access To Object Definition --
3736 ---------------------------------------
3738 -- Parsed by P_Access_Type_Definition (3.10)
3740 -----------------------------------
3741 -- 3.10 General Access Modifier --
3742 -----------------------------------
3744 -- Parsed by P_Access_Type_Definition (3.10)
3746 -------------------------------------------
3747 -- 3.10 Access To Subprogram Definition --
3748 -------------------------------------------
3750 -- Parsed by P_Access_Type_Definition (3.10)
3752 -----------------------------
3753 -- 3.10 Access Definition --
3754 -----------------------------
3756 -- ACCESS_DEFINITION ::=
3757 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3758 -- | ACCESS_TO_SUBPROGRAM_DEFINITION
3760 -- ACCESS_TO_SUBPROGRAM_DEFINITION
3761 -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE
3762 -- | [NULL_EXCLUSION] access [protected] function
3763 -- PARAMETER_AND_RESULT_PROFILE
3765 -- The caller has parsed the null-exclusion part and it has also checked
3766 -- that the next token is ACCESS
3768 -- Error recovery: cannot raise Error_Resync
3770 function P_Access_Definition
3771 (Null_Exclusion_Present
: Boolean) return Node_Id
is
3773 Subp_Node
: Node_Id
;
3776 Def_Node
:= New_Node
(N_Access_Definition
, Token_Ptr
);
3777 Scan
; -- past ACCESS
3779 -- Ada 2005 (AI-254/AI-231)
3781 if Ada_Version
>= Ada_05
then
3783 -- Ada 2005 (AI-254): Access_To_Subprogram_Definition
3785 if Token
= Tok_Protected
3786 or else Token
= Tok_Procedure
3787 or else Token
= Tok_Function
3790 P_Access_Type_Definition
(Header_Already_Parsed
=> True);
3791 Set_Null_Exclusion_Present
(Subp_Node
, Null_Exclusion_Present
);
3792 Set_Access_To_Subprogram_Definition
(Def_Node
, Subp_Node
);
3794 -- Ada 2005 (AI-231)
3795 -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK
3798 Set_Null_Exclusion_Present
(Def_Node
, Null_Exclusion_Present
);
3800 if Token
= Tok_All
then
3802 Set_All_Present
(Def_Node
);
3804 elsif Token
= Tok_Constant
then
3805 Scan
; -- past CONSTANT
3806 Set_Constant_Present
(Def_Node
);
3809 Set_Subtype_Mark
(Def_Node
, P_Subtype_Mark
);
3816 -- Ada 2005 (AI-254): The null-exclusion present is never present
3817 -- in Ada 83 and Ada 95
3819 pragma Assert
(Null_Exclusion_Present
= False);
3821 Set_Null_Exclusion_Present
(Def_Node
, False);
3822 Set_Subtype_Mark
(Def_Node
, P_Subtype_Mark
);
3827 end P_Access_Definition
;
3829 -----------------------------------------
3830 -- 3.10.1 Incomplete Type Declaration --
3831 -----------------------------------------
3833 -- Parsed by P_Type_Declaration (3.2.1)
3835 ----------------------------
3836 -- 3.11 Declarative Part --
3837 ----------------------------
3839 -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM}
3841 -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items
3842 -- handles errors, and returns cleanly after an error has occurred)
3844 function P_Declarative_Part
return List_Id
is
3849 -- Indicate no bad declarations detected yet. This will be reset by
3850 -- P_Declarative_Items if a bad declaration is discovered.
3852 Missing_Begin_Msg
:= No_Error_Msg
;
3854 -- Get rid of active SIS entry from outer scope. This means we will
3855 -- miss some nested cases, but it doesn't seem worth the effort. See
3856 -- discussion in Par for further details
3858 SIS_Entry_Active
:= False;
3861 -- Loop to scan out the declarations
3864 P_Declarative_Items
(Decls
, Done
, In_Spec
=> False);
3868 -- Get rid of active SIS entry which is left set only if we scanned a
3869 -- procedure declaration and have not found the body. We could give
3870 -- an error message, but that really would be usurping the role of
3871 -- semantic analysis (this really is a missing body case).
3873 SIS_Entry_Active
:= False;
3875 end P_Declarative_Part
;
3877 ----------------------------
3878 -- 3.11 Declarative Item --
3879 ----------------------------
3881 -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY
3883 -- Can return Error if a junk declaration is found, or Empty if no
3884 -- declaration is found (i.e. a token ending declarations, such as
3885 -- BEGIN or END is encountered).
3887 -- Error recovery: cannot raise Error_Resync. If an error resync occurs,
3888 -- then the scan is set past the next semicolon and Error is returned.
3890 procedure P_Declarative_Items
3895 Scan_State
: Saved_Scan_State
;
3898 if Style_Check
then Style
.Check_Indentation
; end if;
3902 when Tok_Function
=>
3904 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3910 -- Check for loop (premature statement)
3912 Save_Scan_State
(Scan_State
);
3915 if Token
= Tok_Identifier
then
3916 Scan
; -- past identifier
3918 if Token
= Tok_In
then
3919 Restore_Scan_State
(Scan_State
);
3920 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
3925 -- Not a loop, so must be rep clause
3927 Restore_Scan_State
(Scan_State
);
3928 Append
(P_Representation_Clause
, Decls
);
3933 Append
(P_Generic
, Decls
);
3936 when Tok_Identifier
=>
3938 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
3940 -- Ada2005: A subprogram declaration can start with "not" or
3941 -- "overriding". In older versions, "overriding" is handled
3942 -- like an identifier, with the appropriate warning.
3946 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3949 when Tok_Overriding
=>
3951 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3956 Append
(P_Package
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3960 Append
(P_Pragma
, Decls
);
3963 when Tok_Procedure
=>
3965 Append
(P_Subprogram
(Pf_Decl_Gins_Pbod_Rnam_Stub
), Decls
);
3968 when Tok_Protected
=>
3970 Scan
; -- past PROTECTED
3971 Append
(P_Protected
, Decls
);
3976 Append
(P_Subtype_Declaration
, Decls
);
3982 Append
(P_Task
, Decls
);
3987 Append
(P_Type_Declaration
, Decls
);
3992 Append
(P_Use_Clause
, Decls
);
3997 Error_Msg_SC
("WITH can only appear in context clause");
4000 -- BEGIN terminates the scan of a sequence of declarations unless
4001 -- there is a missing subprogram body, see section on handling
4002 -- semicolon in place of IS. We only treat the begin as satisfying
4003 -- the subprogram declaration if it falls in the expected column
4007 if SIS_Entry_Active
and then Start_Column
>= SIS_Ecol
then
4009 -- Here we have the case where a BEGIN is encountered during
4010 -- declarations in a declarative part, or at the outer level,
4011 -- and there is a subprogram declaration outstanding for which
4012 -- no body has been supplied. This is the case where we assume
4013 -- that the semicolon in the subprogram declaration should
4014 -- really have been is. The active SIS entry describes the
4015 -- subprogram declaration. On return the declaration has been
4016 -- modified to become a body.
4019 Specification_Node
: Node_Id
;
4020 Decl_Node
: Node_Id
;
4021 Body_Node
: Node_Id
;
4024 -- First issue the error message. If we had a missing
4025 -- semicolon in the declaration, then change the message
4026 -- to <missing "is">
4028 if SIS_Missing_Semicolon_Message
/= No_Error_Msg
then
4029 Change_Error_Text
-- Replace: "missing "";"" "
4030 (SIS_Missing_Semicolon_Message
, "missing ""is""");
4032 -- Otherwise we saved the semicolon position, so complain
4035 Error_Msg
(""";"" should be IS", SIS_Semicolon_Sloc
);
4038 -- The next job is to fix up any declarations that occurred
4039 -- between the procedure header and the BEGIN. These got
4040 -- chained to the outer declarative region (immediately
4041 -- after the procedure declaration) and they should be
4042 -- chained to the subprogram itself, which is a body
4043 -- rather than a spec.
4045 Specification_Node
:= Specification
(SIS_Declaration_Node
);
4046 Change_Node
(SIS_Declaration_Node
, N_Subprogram_Body
);
4047 Body_Node
:= SIS_Declaration_Node
;
4048 Set_Specification
(Body_Node
, Specification_Node
);
4049 Set_Declarations
(Body_Node
, New_List
);
4052 Decl_Node
:= Remove_Next
(Body_Node
);
4053 exit when Decl_Node
= Empty
;
4054 Append
(Decl_Node
, Declarations
(Body_Node
));
4057 -- Now make the scope table entry for the Begin-End and
4061 Scope
.Table
(Scope
.Last
).Sloc
:= SIS_Sloc
;
4062 Scope
.Table
(Scope
.Last
).Etyp
:= E_Name
;
4063 Scope
.Table
(Scope
.Last
).Ecol
:= SIS_Ecol
;
4064 Scope
.Table
(Scope
.Last
).Labl
:= SIS_Labl
;
4065 Scope
.Table
(Scope
.Last
).Lreq
:= False;
4066 SIS_Entry_Active
:= False;
4068 Set_Handled_Statement_Sequence
(Body_Node
,
4069 P_Handled_Sequence_Of_Statements
);
4070 End_Statements
(Handled_Statement_Sequence
(Body_Node
));
4079 -- Normally an END terminates the scan for basic declarative
4080 -- items. The one exception is END RECORD, which is probably
4081 -- left over from some other junk.
4084 Save_Scan_State
(Scan_State
); -- at END
4087 if Token
= Tok_Record
then
4088 Error_Msg_SP
("no RECORD for this `end record`!");
4089 Scan
; -- past RECORD
4093 Restore_Scan_State
(Scan_State
); -- to END
4097 -- The following tokens which can only be the start of a statement
4098 -- are considered to end a declarative part (i.e. we have a missing
4099 -- BEGIN situation). We are fairly conservative in making this
4100 -- judgment, because it is a real mess to go into statement mode
4101 -- prematurely in response to a junk declaration.
4116 -- But before we decide that it's a statement, let's check for
4117 -- a reserved word misused as an identifier.
4119 if Is_Reserved_Identifier
then
4120 Save_Scan_State
(Scan_State
);
4121 Scan
; -- past the token
4123 -- If reserved identifier not followed by colon or comma, then
4124 -- this is most likely an assignment statement to the bad id.
4126 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
4127 Restore_Scan_State
(Scan_State
);
4128 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4131 -- Otherwise we have a declaration of the bad id
4134 Restore_Scan_State
(Scan_State
);
4135 Scan_Reserved_Identifier
(Force_Msg
=> True);
4136 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4139 -- If not reserved identifier, then it's definitely a statement
4142 Statement_When_Declaration_Expected
(Decls
, Done
, In_Spec
);
4146 -- The token RETURN may well also signal a missing BEGIN situation,
4147 -- however, we never let it end the declarative part, because it may
4148 -- also be part of a half-baked function declaration.
4151 Error_Msg_SC
("misplaced RETURN statement");
4154 -- PRIVATE definitely terminates the declarations in a spec,
4155 -- and is an error in a body.
4161 Error_Msg_SC
("PRIVATE not allowed in body");
4162 Scan
; -- past PRIVATE
4165 -- An end of file definitely terminates the declarations!
4170 -- The remaining tokens do not end the scan, but cannot start a
4171 -- valid declaration, so we signal an error and resynchronize.
4172 -- But first check for misuse of a reserved identifier.
4176 -- Here we check for a reserved identifier
4178 if Is_Reserved_Identifier
then
4179 Save_Scan_State
(Scan_State
);
4180 Scan
; -- past the token
4182 if Token
/= Tok_Colon
and then Token
/= Tok_Comma
then
4183 Restore_Scan_State
(Scan_State
);
4184 Set_Declaration_Expected
;
4187 Restore_Scan_State
(Scan_State
);
4188 Scan_Reserved_Identifier
(Force_Msg
=> True);
4190 P_Identifier_Declarations
(Decls
, Done
, In_Spec
);
4194 Set_Declaration_Expected
;
4199 -- To resynchronize after an error, we scan to the next semicolon and
4200 -- return with Done = False, indicating that there may still be more
4201 -- valid declarations to come.
4204 when Error_Resync
=>
4205 Resync_Past_Semicolon
;
4207 end P_Declarative_Items
;
4209 ----------------------------------
4210 -- 3.11 Basic Declarative Item --
4211 ----------------------------------
4213 -- BASIC_DECLARATIVE_ITEM ::=
4214 -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE
4216 -- Scan zero or more basic declarative items
4218 -- Error recovery: cannot raise Error_Resync. If an error is detected, then
4219 -- the scan pointer is repositioned past the next semicolon, and the scan
4220 -- for declarative items continues.
4222 function P_Basic_Declarative_Items
return List_Id
is
4229 -- Indicate no bad declarations detected yet in the current context:
4230 -- visible or private declarations of a package spec.
4232 Missing_Begin_Msg
:= No_Error_Msg
;
4234 -- Get rid of active SIS entry from outer scope. This means we will
4235 -- miss some nested cases, but it doesn't seem worth the effort. See
4236 -- discussion in Par for further details
4238 SIS_Entry_Active
:= False;
4240 -- Loop to scan out declarations
4245 P_Declarative_Items
(Decls
, Done
, In_Spec
=> True);
4249 -- Get rid of active SIS entry. This is set only if we have scanned a
4250 -- procedure declaration and have not found the body. We could give
4251 -- an error message, but that really would be usurping the role of
4252 -- semantic analysis (this really is a case of a missing body).
4254 SIS_Entry_Active
:= False;
4256 -- Test for assorted illegal declarations not diagnosed elsewhere
4258 Decl
:= First
(Decls
);
4260 while Present
(Decl
) loop
4261 Kind
:= Nkind
(Decl
);
4263 -- Test for body scanned, not acceptable as basic decl item
4265 if Kind
= N_Subprogram_Body
or else
4266 Kind
= N_Package_Body
or else
4267 Kind
= N_Task_Body
or else
4268 Kind
= N_Protected_Body
4271 ("proper body not allowed in package spec", Sloc
(Decl
));
4273 -- Test for body stub scanned, not acceptable as basic decl item
4275 elsif Kind
in N_Body_Stub
then
4277 ("body stub not allowed in package spec", Sloc
(Decl
));
4279 elsif Kind
= N_Assignment_Statement
then
4281 ("assignment statement not allowed in package spec",
4289 end P_Basic_Declarative_Items
;
4295 -- For proper body, see below
4296 -- For body stub, see 10.1.3
4298 -----------------------
4299 -- 3.11 Proper Body --
4300 -----------------------
4302 -- Subprogram body is parsed by P_Subprogram (6.1)
4303 -- Package body is parsed by P_Package (7.1)
4304 -- Task body is parsed by P_Task (9.1)
4305 -- Protected body is parsed by P_Protected (9.4)
4307 ------------------------------
4308 -- Set_Declaration_Expected --
4309 ------------------------------
4311 procedure Set_Declaration_Expected
is
4313 Error_Msg_SC
("declaration expected");
4315 if Missing_Begin_Msg
= No_Error_Msg
then
4316 Missing_Begin_Msg
:= Get_Msg_Id
;
4318 end Set_Declaration_Expected
;
4320 ----------------------
4321 -- Skip_Declaration --
4322 ----------------------
4324 procedure Skip_Declaration
(S
: List_Id
) is
4325 Dummy_Done
: Boolean;
4328 P_Declarative_Items
(S
, Dummy_Done
, False);
4329 end Skip_Declaration
;
4331 -----------------------------------------
4332 -- Statement_When_Declaration_Expected --
4333 -----------------------------------------
4335 procedure Statement_When_Declaration_Expected
4341 -- Case of second occurrence of statement in one declaration sequence
4343 if Missing_Begin_Msg
/= No_Error_Msg
then
4345 -- In the procedure spec case, just ignore it, we only give one
4346 -- message for the first occurrence, since otherwise we may get
4347 -- horrible cascading if BODY was missing in the header line.
4352 -- In the declarative part case, take a second statement as a sure
4353 -- sign that we really have a missing BEGIN, and end the declarative
4354 -- part now. Note that the caller will fix up the first message to
4355 -- say "missing BEGIN" so that's how the error will be signalled.
4362 -- Case of first occurrence of unexpected statement
4365 -- If we are in a package spec, then give message of statement
4366 -- not allowed in package spec. This message never gets changed.
4369 Error_Msg_SC
("statement not allowed in package spec");
4371 -- If in declarative part, then we give the message complaining
4372 -- about finding a statement when a declaration is expected. This
4373 -- gets changed to a complaint about a missing BEGIN if we later
4374 -- find that no BEGIN is present.
4377 Error_Msg_SC
("statement not allowed in declarative part");
4380 -- Capture message Id. This is used for two purposes, first to
4381 -- stop multiple messages, see test above, and second, to allow
4382 -- the replacement of the message in the declarative part case.
4384 Missing_Begin_Msg
:= Get_Msg_Id
;
4387 -- In all cases except the case in which we decided to terminate the
4388 -- declaration sequence on a second error, we scan out the statement
4389 -- and append it to the list of declarations (note that the semantics
4390 -- can handle statements in a declaration list so if we proceed to
4391 -- call the semantic phase, all will be (reasonably) well!
4393 Append_List_To
(Decls
, P_Sequence_Of_Statements
(SS_Unco
));
4395 -- Done is set to False, since we want to continue the scan of
4396 -- declarations, hoping that this statement was a temporary glitch.
4397 -- If we indeed are now in the statement part (i.e. this was a missing
4398 -- BEGIN, then it's not terrible, we will simply keep calling this
4399 -- procedure to process the statements one by one, and then finally
4400 -- hit the missing BEGIN, which will clean up the error message.
4403 end Statement_When_Declaration_Expected
;