1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2022, 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 if Has_Aspects
(Dummy_Node
) then
166 Move_Aspects
(From
=> Dummy_Node
, To
=> Package_Node
);
169 Parse_Decls_Begin_End
(Package_Node
);
172 -- Cases other than Package_Body
175 Scopes
(Scope
.Last
).Sloc
:= Token_Ptr
;
176 Name_Node
:= P_Defining_Program_Unit_Name
;
177 Scopes
(Scope
.Last
).Labl
:= Name_Node
;
178 Current_Node
:= Name_Node
;
180 -- Case of renaming declaration
182 Check_Misspelling_Of
(Tok_Renames
);
184 if Token
= Tok_Renames
then
185 if not Pf_Flags
.Rnam
then
186 Error_Msg_SC
("renaming declaration cannot appear here!");
189 Scan
; -- past RENAMES;
192 New_Node
(N_Package_Renaming_Declaration
, Package_Sloc
);
193 Set_Defining_Unit_Name
(Package_Node
, Name_Node
);
194 Set_Name
(Package_Node
, P_Qualified_Simple_Name
);
197 P_Aspect_Specifications
(Package_Node
, Semicolon
=> False);
201 -- Generic package instantiation or package declaration
204 if Aspect_Specifications_Present
then
205 Aspect_Sloc
:= Token_Ptr
;
206 P_Aspect_Specifications
(Dummy_Node
, Semicolon
=> False);
209 Is_Sloc
:= Token_Ptr
;
212 -- Case of generic instantiation
214 if Token
= Tok_New
then
215 if not Pf_Flags
.Gins
then
217 ("generic instantiation cannot appear here!");
220 if Aspect_Sloc
/= No_Location
then
222 ("misplaced aspects for package instantiation",
229 New_Node
(N_Package_Instantiation
, Package_Sloc
);
230 Set_Defining_Unit_Name
(Package_Node
, Name_Node
);
231 Set_Name
(Package_Node
, P_Qualified_Simple_Name
);
232 Set_Generic_Associations
233 (Package_Node
, P_Generic_Actual_Part_Opt
);
235 if Aspect_Sloc
/= No_Location
236 and then not Aspect_Specifications_Present
238 Error_Msg_SC
("info: aspect specifications belong here??");
239 Move_Aspects
(From
=> Dummy_Node
, To
=> Package_Node
);
242 P_Aspect_Specifications
(Package_Node
);
245 -- Case of package declaration or package specification
248 Specification_Node
:=
249 New_Node
(N_Package_Specification
, Package_Sloc
);
251 Set_Defining_Unit_Name
(Specification_Node
, Name_Node
);
252 Set_Visible_Declarations
254 P_Basic_Declarative_Items
(Declare_Expression
=> False));
256 if Token
= Tok_Private
then
257 Error_Msg_Col
:= Scopes
(Scope
.Last
).Ecol
;
259 if RM_Column_Check
then
260 if Token_Is_At_Start_Of_Line
261 and then Start_Column
/= Error_Msg_Col
264 ("(style) PRIVATE in wrong column, should be@");
268 Scan
; -- past PRIVATE
270 Set_Private_Declarations
272 P_Basic_Declarative_Items
(Declare_Expression
=> False));
274 -- Deal gracefully with multiple PRIVATE parts
276 while Token
= Tok_Private
loop
278 ("only one private part allowed per package");
279 Scan
; -- past PRIVATE
281 (P_Basic_Declarative_Items
282 (Declare_Expression
=> False),
283 Private_Declarations
(Specification_Node
));
287 if Pf_Flags
= Pf_Spcn
then
288 Package_Node
:= Specification_Node
;
291 New_Node
(N_Package_Declaration
, Package_Sloc
);
292 Set_Specification
(Package_Node
, Specification_Node
);
295 if Token
= Tok_Begin
then
296 Error_Msg_SC
("begin block not allowed in package spec");
298 Discard_Junk_List
(P_Sequence_Of_Statements
(SS_None
));
301 End_Statements
(Specification_Node
, Empty
, Is_Sloc
);
302 Move_Aspects
(From
=> Dummy_Node
, To
=> Package_Node
);
310 ------------------------------
311 -- 7.1 Package Declaration --
312 ------------------------------
314 -- Parsed by P_Package (7.1)
316 --------------------------------
317 -- 7.1 Package Specification --
318 --------------------------------
320 -- Parsed by P_Package (7.1)
322 -----------------------
323 -- 7.1 Package Body --
324 -----------------------
326 -- Parsed by P_Package (7.1)
328 -----------------------------------
329 -- 7.3 Private Type Declaration --
330 -----------------------------------
332 -- Parsed by P_Type_Declaration (3.2.1)
334 ----------------------------------------
335 -- 7.3 Private Extension Declaration --
336 ----------------------------------------
338 -- Parsed by P_Type_Declaration (3.2.1)