1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2024, 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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 pragma Style_Checks
(All_Checks
);
27 -- Turn off subprogram body ordering check. Subprograms are in order
28 -- by RM section rather than alphabetical
33 ---------------------------------------------
34 -- 7.1 Package (also 8.5.3, 10.1.3, 12.3) --
35 ---------------------------------------------
37 -- This routine scans out a package declaration, package body, or a
38 -- renaming declaration or generic instantiation starting with PACKAGE
40 -- PACKAGE_DECLARATION ::=
41 -- PACKAGE_SPECIFICATION;
43 -- PACKAGE_SPECIFICATION ::=
44 -- package DEFINING_PROGRAM_UNIT_NAME
45 -- [ASPECT_SPECIFICATIONS]
47 -- {BASIC_DECLARATIVE_ITEM}
49 -- {BASIC_DECLARATIVE_ITEM}]
50 -- end [[PARENT_UNIT_NAME .] IDENTIFIER]
53 -- package body DEFINING_PROGRAM_UNIT_NAME
54 -- [ASPECT_SPECIFICATIONS]
58 -- HANDLED_SEQUENCE_OF_STATEMENTS]
59 -- end [[PARENT_UNIT_NAME .] IDENTIFIER]
61 -- PACKAGE_RENAMING_DECLARATION ::=
62 -- package DEFINING_IDENTIFIER renames package_NAME
63 -- [ASPECT_SPECIFICATIONS];
65 -- PACKAGE_BODY_STUB ::=
66 -- package body DEFINING_IDENTIFIER is separate
67 -- [ASPECT_SPECIFICATIONS];
69 -- PACKAGE_INSTANTIATION ::=
70 -- package DEFINING_PROGRAM_UNIT_NAME is
71 -- new generic_package_NAME [GENERIC_ACTUAL_PART]
72 -- [ASPECT_SPECIFICATIONS];
74 -- Note: in all contexts where a package specification is required, there
75 -- is a terminating semicolon. This semicolon is scanned out in the case
76 -- where Pf_Flags is set to Pf_Spcn, even though it is not strictly part
77 -- of the package specification (it's just too much trouble, and really
78 -- quite unnecessary, to deal with scanning out an END where the semicolon
79 -- after the END is not considered to be part of the END.
81 -- The caller has checked that the initial token is PACKAGE
83 -- Error recovery: cannot raise Error_Resync
85 function P_Package
(Pf_Flags
: Pf_Rec
) return Node_Id
is
86 Package_Node
: Node_Id
;
87 Specification_Node
: Node_Id
;
89 Package_Sloc
: Source_Ptr
;
91 Aspect_Sloc
: Source_Ptr
:= No_Location
;
92 -- Save location of WITH for scanned aspects. Left set to No_Location
93 -- if no aspects scanned before the IS keyword.
96 -- Save location of IS token for package declaration
98 Dummy_Node
: constant Node_Id
:=
99 New_Node
(N_Package_Specification
, Token_Ptr
);
100 -- Dummy node to attach aspect specifications to until we properly
101 -- figure out where they eventually belong.
105 Scopes
(Scope
.Last
).Etyp
:= E_Name
;
106 Scopes
(Scope
.Last
).Ecol
:= Start_Column
;
107 Scopes
(Scope
.Last
).Lreq
:= False;
109 Package_Sloc
:= Token_Ptr
;
110 Scan
; -- past PACKAGE
112 if Token
= Tok_Type
then
113 Error_Msg_SC
-- CODEFIX
114 ("TYPE not allowed here");
118 -- Case of package body. Note that we demand a package body if that
119 -- is the only possibility (even if the BODY keyword is not present)
121 if Token
= Tok_Body
or else Pf_Flags
= Pf_Pbod_Pexp
then
122 if not Pf_Flags
.Pbod
then
123 Error_Msg_SC
("package body cannot appear here!");
127 Scopes
(Scope
.Last
).Sloc
:= Token_Ptr
;
128 Name_Node
:= P_Defining_Program_Unit_Name
;
129 Scopes
(Scope
.Last
).Labl
:= Name_Node
;
130 Current_Node
:= Name_Node
;
132 if Aspect_Specifications_Present
then
133 Aspect_Sloc
:= Token_Ptr
;
134 P_Aspect_Specifications
(Dummy_Node
, Semicolon
=> False);
139 if Separate_Present
then
140 if not Pf_Flags
.Stub
then
141 Error_Msg_SC
("body stub cannot appear here!");
144 Scan
; -- past SEPARATE
146 Package_Node
:= New_Node
(N_Package_Body_Stub
, Package_Sloc
);
147 Set_Defining_Identifier
(Package_Node
, Name_Node
);
149 if Has_Aspects
(Dummy_Node
) then
151 ("aspect specifications must come after SEPARATE",
155 P_Aspect_Specifications
(Package_Node
, Semicolon
=> False);
160 Package_Node
:= New_Node
(N_Package_Body
, Package_Sloc
);
161 Set_Defining_Unit_Name
(Package_Node
, Name_Node
);
163 -- Move the aspect specifications to the body node
165 Move_Aspects
(From
=> Dummy_Node
, To
=> Package_Node
);
167 Parse_Decls_Begin_End
(Package_Node
);
170 -- Cases other than Package_Body
173 Scopes
(Scope
.Last
).Sloc
:= Token_Ptr
;
174 Name_Node
:= P_Defining_Program_Unit_Name
;
175 Scopes
(Scope
.Last
).Labl
:= Name_Node
;
176 Current_Node
:= Name_Node
;
178 -- Case of renaming declaration
180 Check_Misspelling_Of
(Tok_Renames
);
182 if Token
= Tok_Renames
then
183 if not Pf_Flags
.Rnam
then
184 Error_Msg_SC
("renaming declaration cannot appear here!");
187 Scan
; -- past RENAMES;
190 New_Node
(N_Package_Renaming_Declaration
, Package_Sloc
);
191 Set_Defining_Unit_Name
(Package_Node
, Name_Node
);
192 Set_Name
(Package_Node
, P_Qualified_Simple_Name
);
195 P_Aspect_Specifications
(Package_Node
, Semicolon
=> False);
199 -- Generic package instantiation or package declaration
202 if Aspect_Specifications_Present
then
203 Aspect_Sloc
:= Token_Ptr
;
204 P_Aspect_Specifications
(Dummy_Node
, Semicolon
=> False);
207 Is_Sloc
:= Token_Ptr
;
210 -- Case of generic instantiation
212 if Token
= Tok_New
then
213 if not Pf_Flags
.Gins
then
215 ("generic instantiation cannot appear here!");
218 if Aspect_Sloc
/= No_Location
then
220 ("misplaced aspects for package instantiation",
227 New_Node
(N_Package_Instantiation
, Package_Sloc
);
228 Set_Defining_Unit_Name
(Package_Node
, Name_Node
);
229 Set_Name
(Package_Node
, P_Qualified_Simple_Name
);
230 Set_Generic_Associations
231 (Package_Node
, P_Generic_Actual_Part_Opt
);
233 if Aspect_Sloc
/= No_Location
234 and then not Aspect_Specifications_Present
236 Error_Msg_SC
("info: aspect specifications belong here");
237 Move_Aspects
(From
=> Dummy_Node
, To
=> Package_Node
);
240 P_Aspect_Specifications
(Package_Node
, Semicolon
=> True);
243 -- Case of package declaration or package specification
246 Specification_Node
:=
247 New_Node
(N_Package_Specification
, Package_Sloc
);
249 Set_Defining_Unit_Name
(Specification_Node
, Name_Node
);
250 Set_Visible_Declarations
252 P_Basic_Declarative_Items
(Declare_Expression
=> False));
254 if Token
= Tok_Private
then
255 Error_Msg_Col
:= Scopes
(Scope
.Last
).Ecol
;
257 if RM_Column_Check
then
258 if Token_Is_At_Start_Of_Line
259 and then Start_Column
/= Error_Msg_Col
262 ("(style) PRIVATE in wrong column, should be@?l?");
266 Scan
; -- past PRIVATE
268 Set_Private_Declarations
270 P_Basic_Declarative_Items
(Declare_Expression
=> False));
272 -- Deal gracefully with multiple PRIVATE parts
274 while Token
= Tok_Private
loop
276 ("only one private part allowed per package");
277 Scan
; -- past PRIVATE
279 (P_Basic_Declarative_Items
280 (Declare_Expression
=> False),
281 Private_Declarations
(Specification_Node
));
285 if Pf_Flags
= Pf_Spcn
then
286 Package_Node
:= Specification_Node
;
289 New_Node
(N_Package_Declaration
, Package_Sloc
);
290 Set_Specification
(Package_Node
, Specification_Node
);
293 if Token
= Tok_Begin
then
294 Error_Msg_SC
("begin block not allowed in package spec");
296 Discard_Junk_List
(P_Sequence_Of_Statements
(SS_None
));
299 End_Statements
(Specification_Node
, Empty
, Is_Sloc
);
300 Move_Aspects
(From
=> Dummy_Node
, To
=> Package_Node
);
308 ------------------------------
309 -- 7.1 Package Declaration --
310 ------------------------------
312 -- Parsed by P_Package (7.1)
314 --------------------------------
315 -- 7.1 Package Specification --
316 --------------------------------
318 -- Parsed by P_Package (7.1)
320 -----------------------
321 -- 7.1 Package Body --
322 -----------------------
324 -- Parsed by P_Package (7.1)
326 -----------------------------------
327 -- 7.3 Private Type Declaration --
328 -----------------------------------
330 -- Parsed by P_Type_Declaration (3.2.1)
332 ----------------------------------------
333 -- 7.3 Private Extension Declaration --
334 ----------------------------------------
336 -- Parsed by P_Type_Declaration (3.2.1)